###
### Welcome to the perl implementation of GFP 2.0 from Emergence by Design
###
### Note:
### This file uses named parameters extensively, watch out!
### These named parameters are NOT passed by reference.
### This convention was chosen because it is more LISP-like and
### hence is an excellent match for GFP compatibility.
### Naming conventions:
### Variable, subroutine or key names which begin with _ are by
### convention private to that package and its subclasses.
##########################################################################
## All the packages in this file other than GFP are implemented as object
## oriented classes.
##########################################################################
# CVS revision number $Revision: 1.16 $
#use strict;
###########
## GFP ##
###########
## Purpose:
## The GFP package is a single non-object-oriented API to an OOP
## implementation of the GFP protocol. The goal is simple, easy, efficient
## access to knowledge.
## Calling Conventions:
## It is alright to call GFP methods in either of the following ways:
## @slot_values = get_slot_values($frame,$slot);
## @slot_values = GFP::get_slot_values($frame,$slot);
## But it is not correct to call them using the arrow notation:
## @slot_values = GFP->get_slot_values($frame,$slot); # bugged
package GFP;
use Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(allocate_frame_handle
class_p
create_class
create_frame
create_individual
create_slot
create_kb
current_kb
establish_connection
frame_in_kb_p
get_class_instances
get_class_subclasses
get_frame_in_kb
get_frame_handle
get_frame_name
get_frame_slots
get_frame_type
get_instance_types
get_kbs
get_kb_classes
get_kb_direct_parents
get_slot_value
get_slot_values
goto_kb
individual_p
meta_kb
open_kb
put_instance_types
save_kb
revert_kb
);
$GFP::debug=0;
#%all_connections; # a hash from url to kr object
#$current_kb; # the return value for current_kb()
sub all_connections { # GFP
return values %GFP::all_connections;
}
sub allocate_frame_handle { # GFP
# GFP2.0 p37
## Purpose:
## Create an object in one of the packages CLASS, INDIVIDUAL, SLOT, FACET,
## KB, ANNOTATION, EVALUATION
my($frame_name,$frame_type,%in) = @_;
my(%param) = ('kb' => current_kb(),%in);
## translate ':individual' into perl package name 'INDIVIDUAL'
my($frame_type_pkg) = $frame_type;
my($frame_name_pkg);
$frame_name_pkg =~ s/\://g;
$frame_type_pkg = ucase($frame_name_pkg);
## bless it as an CLASS, INDIVIDUAL, SLOT or FACET
## (or KB,ANNOTATION or EVALUATION)
my($frame) = $frame_type_pkg->new($frame_name,$param{'kb'});
## my($handle) = HANDLE->new($frame);
## return $handle;
return $frame;
}
sub class_p { # GFP
my($thing) = shift;
return $thing->class_p();
}
sub coerce_to_frame { # GFP
## Problems:
## This hack works with the hack in allocate_frame_handle
## It recognizes when something which is already a frame is being
## coerced. This is significant because allocate_frame_handle currently
## returns actual frames (as if they were handles). It is doing that
## so we can allocate frames before they are read in or created.
if ($_->isa("FRAME")) {
return $_;
} else {
return undef();
}
}
sub create_class { # GFP
# GFP2.0 p45
## Purpose:
## Creates a class called $name.
my($name,%in) = @_;
my(%param) = ('kb' => current_kb(),'kb-local-only-p' => 0,%in);
return $param{'kb'}->connection()->create_frame_internal($name,
':class',
%param);
}
sub create_frame { # GFP
# GFP2.0 p47
## Purpose:
## Creates an frame called $name of type $frame_type.
my($name,$frame_type,%in) = @_;
my(%param) = ('kb' => current_kb(),'kb-local-only-p' => 0,%in);
return $param{'kb'}->connection()->create_frame_internal($name,
$frame_type,
%param);
}
sub create_individual { # GFP
# GFP2.0 p47
## Purpose:
## Creates an individual frame called name. Type direct types of the
## instance are given by direct-types. The other parameters have the
## same meaning as for create-frame.
my($name,%in) = @_;
my(%param) = ('kb' => current_kb(),'kb-local-only-p' => 0,%in);
# return $param{'kb'}->connection()->create_frame_internal($name,%param);
return $param{'kb'}->connection()->create_frame_internal($name,
':individual',
%param);
}
sub create_slot { # GFP
# GFP2.0 p45
## Purpose:
## Creates a slot called $name.
my($name,%in) = @_;
my(%param) = ('kb' => current_kb(),'kb-local-only-p' => 0,%in);
return $param{'kb'}->connection()->create_frame_internal($name,
':slot',
%param);
}
sub current_kb { # GFP
## GFP2.0 p39
return $GFP::current_kb;
}
sub establish_connection { # GFP
# GFP2.0 p53
## Purpose:
## Figure out which kind of url this is and pick the right class to
## talk to it. If the url type is not recognized, then die.
## $connection_type could be any one of {DBI}
## h_params to include keys: ## url not defined by GFP but used by dbi!
## port if required use these names says GFP 2.0
## username
## password
## host
## TODO
## The following should be replaced with something more general
## and less backwards. Parent classes should not have to know about
## their children.
my($connection_type,%h_param) = @_;
my($guy);
if (! exists($GFP::all_connections{$h_param{url}})) {
if ($h_param{url} =~ /^dbi:/i) {
$guy = Connection::DBI->connect($h_param{url},
$h_param{username},
$h_param{password});
} else {
die "The url '$h_param{url}' is not of a recognizable form\n";
}
$guy->init();
## index this new KR by url
if (defined($guy)) {
# print "indexing $url to $guy\n";
$GFP::all_connections{$h_param{url}} = $guy;
}
} else {
$guy = $GFP::all_connections{$h_param{url}};
}
return $guy;
}
sub get_frame_in_kb { # GFP
# GFP2.0 p58
## Purpose:
## Returns a frame by name.
## Returns:
## (frame frame_in_kb_p)
my($thing,%in) = @_;
my(%param) = ('kb' => current_kb(),
'error-p' => 1,
'kb-local-only-p' => 0,
%in);
if ($thing eq "meta-KB") {
if (ref($param{'kb'}) eq "META_KB") {
return $param{'kb'};
} else {
die("this is so hosed");
}
}
print "GFP\:\:get_frame_in_kb($thing, 'kb' =\> " . $param{'kb'}->name(). ")\n"
if $GFP::debug > 9;
my($which_kb) = frame_in_kb_p($thing,'kb' => $param{'kb'},
'kb-local-only-p' => $param{'kb-local-only-p'});
if (! $which_kb) {
return (0,0);
}
my(@retval) =
$which_kb->get_frame_in_kb_internal($thing,%param,'kb'=>$which_kb);
# print "GFP frame = $retval[0]\n", "GFP frame = $retval[1]\n";
return @retval;
# return $retval[0];
}
sub get_frame_name { # GFP
# GFP2.0 p58
my($frame,%in) = @_;
my(%param) = (%in);
return $frame->get_frame_name(%in);
}
sub get_frame_slots { # GFP
# GFP2.0 p58
## Purpose:
##
## Returns:
## Returns list-of-slots, a list of all the own, template, or own and
## template slots that are associated with frame, depending on the
## value of slot-type.
my($frame,%in) = @_;
my(%param) = ('kb' => current_kb(),
'interference-level' => ':taxonomic',
'slot-type' => ':all',
'kb-local-only-p' => 0,
%in);
return $frame->get_frame_slots(%param);
}
sub get_frame_type { # GFP
# GFP2.0 p58
## Accepts:
## (thing &key kb (inference-level :taxonomic) kb-local-only-p)
my($thing,%in) = @_;
my(%param) = ('kb' => current_kb(),
'inference-level' => ':taxonomic',
'kb-local-only-p' => 0,%in);
if (ref($thing) && $thing->isa('FRAME')) {
return $thing->get_frame_type(%param);
} else {
return 0;
}
}
sub get_instance_types { # GFP
# GFP2.0 p59
## Accepts:
## (frame &key kb (inference-level :taxonomic) (number-of-values :all) kb-local-only-p)
my($frame,%in) = @_;
my(%param) = ('kb' => current_kb(),
'inference-level' => ':taxonomic',
'number-of-values' => ':all',
'kb-local-only-p' => 0,%in);
if (! $param{'inference-level'} eq ':direct') {
warn "GFP::get_instance_types(" .
"'inference-level' => '" . $param{'inference-level'} .
"' is not supported, doing :direct'\n";
}
return get_slot_values($frame,"DIRECT-TYPE");
}
sub get_class_instances { # GFP
# GFP2.0 p56
## Purpose:
## Accepts:
## (class &key kb (inference-level :taxonomic) (number-of-values :all)
## kb-local-only-p)
## Returns:
## list-of-instances exact-p more-status
## Warnings:
## - Only list-of-instances is returned
## - number-of-values is ignored
my($class,%in) = @_;
my(%param) = ('kb' => current_kb(),
'inference-level' => ':taxonomic',
'number-of-values' => ':all',
'kb-local-only-p' => 0,%in);
return $param{'kb'}->get_class_instances($class,%param);
}
sub get_class_subclasses { # GFP
my($class,%in) = @_;
my(%params) = ('kb' => current_kb(),
'inference-level'=>':taxonomic',
'number-of-values'=>':all',
'kb-local-only-p'=>0,%in);
return $params{'kb'}->get_class_subclasses($class,%params);
}
sub get_class_superclasses { # GFP
# GFP2.0 p56
## Accepts:
## (frame &key kb (inference-level :taxonomic) (number-of-values :all) kb-local-only-p)
my($frame,%in) = @_;
my(%param) = ('kb' => current_kb(),
'inference-level' => ':taxonomic',
'number-of-values' => ':all',
'kb-local-only-p' => 0,%in);
if (! $param{'inference-level'} eq ':direct') {
warn "GFP::get_class_superclasses(" .
"'inference-level' => '" . $param{'inference-level'} .
"' is not supported, doing :direct'\n";
}
return get_slot_values($frame,"DIRECT-SUPER");
}
sub get_kb_classes { # GFP
# GFP2.0 p60
## Purpose:
## Accepts:
## (&key kb (selector :system-default) kb-local-only-p)
my(%param) = ('kb' => current_kb(),
'selector' => ':system-default',
'kb-local-only-p' => 0,@_);
$param{'kb'}->get_kb_classes(%param);
}
sub get_kb_direct_parents { # GFP
# GFP2.0 p60
## Returns:
## List of direct parents of this kb
my(%in) = @_;
my(%param) = ('kb' => current_kb(), %in);
$param{'kb'}->get_kb_direct_parents();
}
sub get_kbs { # GFP
# GFP2.0 p61
## Purpose:
## Accepts:
## (&key (connection (loacl-connection)))
my(%in) = @_;
my(%param) = (%in);
return $param{'connection'}->meta_kb()->get_kbs();
}
sub get_slot_value { # GFP
my($frame,$slot,%in) = @_;
my(%param) = ('slot-type' => ':own', 'inference-level' => ':taxonomic',%in);
return $frame->get_slot_value($slot,%param);
}
sub get_slot_values { # GFP
my($frame,$slot,%in) = @_;
my(%param) = ('slot-type' => ':own', 'inference-level' => ':taxonomic',%in);
return $frame->get_slot_values($slot,%param);
}
sub goto_kb { # GFP
# GFP2.0 p63
my($kb) = @_;
$GFP::current_kb = $kb;
}
sub frame_in_kb_p { # GFP
# GFP2.0 p55
## Purpose:
## Ask the kb whether thing is a frame in it.
## Accepts:
## (thing &key kb kb-local-only-p)
## Returns:
## 0 or something (false or true)
## Discussion:
## This method defers to the associated method on the kb, which
## in turn asks its cache and, if need be, its connection.
my($thing,%in) = @_;
# Notice that the defaults get set here and that the implementations
# in other than the GFP package can assume that the keywords are
# fully specified wrt defaults.
my(%param) = ('kb' => current_kb(), 'kb-local-only-p' => 0,%in);
# print "GFP::frame_in_kb_p() \%param = ",join(", ",%param), "\n" if $GFP::debug > 19;
# print "GFP::frame_in_kb_p() kb = $param{kb}\n" if $GFP::debug > 19;
return $param{'kb'}->frame_in_kb_p($thing,%param);
}
sub local_connection { # GFP
return $GFP::local_connection;
}
sub meta_kb { # GFP
# GFP2.0 p64
## Accepts:
## (&key (connection (local-connection)))
my(%in) = @_;
my(%param) = (%in);
return $param{'connection'}->meta_kb();
}
sub open_kb { # GFP
# GFP2.0 p64
## Purpose:
## Accepts:
## (kb-locator &key kb-type (connection (local-connection)) (error-p true))
## Warnings:
## connection is currently mandatory
my($kb_name,%in) = @_; # kb_locator is just a kb_name at this point
my(%param) = ('error-p' => 1, %in);
# my(%param) = ('connection' => local_connection(), %in);
# my($frame) = $param{'connection'}->get_frame_by_name($kb_name);
# my($frame) = get_frame_in_kb($kb_name,'kb' => meta_kb());
# allocate_frame_handle($kb_name,':kb');
if (0) {
return get_frame_in_kb($kb_name,'kb' => $param{connection}->meta_kb());
} else {
my($kb) = KB->_ensure_stub_in($kb_name,
# $param{'connection'}->meta_kb(),
$param{'connection'}
);
return $kb;
}
}
sub put_instance_types { # GFP
# GFP2.0 p66
## Purpose:
## Changes frame to be an instance of all the classes listed in
## new_types. This operation may signal constraint violation conditions.
my($frame,$ra_new_types,%in) = @_;
my(%param) = ('kb' => current_kb(),
'kb-local-only-p' => 0, %in);
$frame->put_instance_types($ra_new_types,%param);
}
sub get_frame_handle { # GFP
my($frame,%in) = @_;
my(%param) = ('kb' => current_kb(), 'kb-local-only-p' => 0, %in);
return $param{kb}->get_frame_handle($frame,%param);
}
sub save_kb { # GFP
# GFP2.0 p68
## Purpose:
## Saves the contents of hte KB to persistent storage. No commitment
## is made as to the location of hte KB in persistent storage, other
## than that it will be openable given the name, kb-type and connection
## first used to access it. No commitment is made as to whether the
## save operation results in a complete dump of the KB, or whether it
## results only in a dump of the changes made since the KB was last saved.
## If error-p is false, tries to catch errors that occur, and attempts
## to continue with saving to the extent possible. Returns true iff the
## KB was saved successfully, and false otherwise.
## Accepts:
## (&key kb (error-p true))
## Returns:
## boolean
my(%param) = ('kb' => current_kb(), 'error-p' => 1, @_);
$param{'kb'}->save_kb(%param);
}
###############
## META_KB ##
###############
package META_KB;
#$count = 0;
@ISA = qw(KB);
sub new { # META_KB
## Purpose:
## Create a new META_KB object
## Accepts:
## $pkg should be META_KB (or the name of a subclass)
## $kb_name the name of the new kb
## $connection the connection for which this is the meta_kb
my($pkg,$kb_name,$connection) = @_;
# my($self) = FRAME::new($pkg,$kb_name,$in_kb); # this preserves @_[0] as 1st arg
my($self) = KB::_stub_in($pkg,$kb_name,$connection);
print "META_KB::new\t\$self = $self\t\$kbname $kb_name\n" if $GFP::debug > 5;
$connection->set_meta_kb($self);
$self->_init_caches();
$self->connection($connection);
$self->{'frame_id'} = $connection->
_single_valued_query("select kb_id from kb " .
"where name = " .
$connection->{dbh}->quote($kb_name));
# bless($self,$pkg);
# $self->{count} = $count++;
# die("the id is " . $self->id() . "\n");
## add the slot for DIRECT-INCLUDE and then put the GROUND_KB in there
# $self->attach_slot("DIRECT-INCLUDE");
# my($ground_kb) = GFP::open_kb("Ground_kb",'connection' => $connection);
# $self->put_slot_value("DIRECT-INCLUDE",$ground_kb);
$self->kb($self);
$self->fault_in();
return $self;
}
sub get_kbs { # META_KB
# GFP2.0 p61
## Purpose:
## Find the kbs on this meta-KB. Equivalent to finding all the
## kbs accessible via this connection.
## Accepts:
## (&key (connection (local-connection)))
my($self,%in) = @_;
my(%param) = (%in);
return $self->get_kb_type_instances('K');
}
#################
## CacheOnKb ##
#################
## Purpose:
## Caches keep track of a number of values and is capable of
## returning all the instances currently on the cache. There
## is also a flag accessible via the accessor method _got_them_all()
## Which records whether the cache is believed to hold all the
## items it ought to.
package CacheOnKb;
sub new { # CacheOnKb
## Purpose:
## Initialize the cache by creating the storage and setting the
## all flag to false.
## Structure:
## The blessed reference is to an array with the following elements:
## elems - is an array reference into which the items will be pushed.
## all - is a boolean indicating whether all the frames of this type
## are known to have been loaded into RAM.
my($pkg) = @_;
return bless({'elem'=>[], 'all' => 0},$pkg);
}
sub _add { # CacheOnKb
my($self,$frame) = @_;
push(@{$self->{'elem'}},$frame);
}
sub _got_them_all { # CacheOnKb
## Purpose:
## Set or get the indicator of whether all the frames of this
## type in this KB have already been cached on $self.
my($self) = shift;
@_ ? $self->{'all'} = shift
: $self->{'all'};
}
sub current_instances { # CacheOnKb
## Purpose:
## Return a clone of the elem array rather than return the
## actual elem array, thereby avoiding exposing the data structure
## to damage.
my($self) = @_;
my(@retarray);
foreach (@{$self->{'elem'}}) {
push(@retarray,$_);
}
return @retarray;
}
sub dump {
my($self,$indent) = @_;
my($retval)="";
foreach (@{$self->{'elem'}}) {
$retval .= "$indent".$_->name() . "\t$_\n";
}
return $retval;
}
#####################
## TypeCacheOnKb ##
#####################
## Purpose:
## Keep all instance of a particular GFP type cached on a KB.
## For example there should be TypeCacheOnKb instances on each KB
## for each of: Class, Individual, Slot, Facet, Evaluation,
## KB and Annotation.
package TypeCacheOnKb;
@ISA = qw(CacheOnKb);
######################
## ClassCacheOnKb ##
######################
## Purpose:
## To cache on each KB the instances of each ontological class for
## which there are instances in that KB. The _got_them_all() call
## returns whether all instances of a particular class are known to
## already have been cached.
package ClassCacheOnKb;
@ISA = qw(CacheOnKb);
##########
## KB ##
##########
package KB;
@ISA = qw(FRAME);
sub new { # KB
## Purpose:
## Create a new KB object
## Accepts:
## $pkg should be KB (or the name of a subclass)
## $kb_name the name of the new kb
## $in_kb the kb which this kb shall be found in
my($pkg,$kb_name,$in_kb,$connection) = @_;
# my($kb) = FRAME::new($pkg,$kb_name,$in_kb); # this preserves @_[0] as 1st arg
my($kb) = KB::_ensure_stub_in($pkg,$kb_name,$connection);
print "KB::new\t\$kb = $kb\t\$kbname $kb_name\n" if $GFP::debug > 5;
# if ($i++ > 5) {print "I grow weary\n"; exit;}
$kb->_init_caches();
# bless($kb,$pkg);
$kb->connection($connection);
$kb->_ensure_kb_id_loaded();
# if (!defined($in_kb) || ! $in_kb) {
# $in_kb is passed a blank value when Meta-KB is being created.
# In the special case where $in_kb is invalid, tell this kb
# that its frame may be found in itself. This is really only true
# for the meta-KB. Is there a better way to do this?
# $kb->kb($kb);
# }
$kb->fault_in();
return $kb;
}
sub _primitive_reln { # KB
## Purpose:
## Return a list of the names of slots which are primitively on
## instances of KB. This is solely (so far) for the purposes of
## the reln table in the Connection::DBI package. Hopefully there
## is a better way than polluting classes such as this one with such
## tripe.
my($self) = shift;
return ($self->SUPER::_primitive_reln(), 'DIRECT-INCLUDE', 'CONTAINS-FRAME');
}
sub _get_direct_instances { # KB
## Purpose:
## Return all the instances of $class either local to this kb
## or not on the basis of kb-local-only-p.
## Accepts:
## (class &key kb kb-local-only-p)
## Logic:
##
my($self,$class,%in) = @_;
my(%param) = ('kb-local-only-p' => 0,
%in);
my($class_name) = $class;
if (ref($class) || scalar($class) =~ m/=/) { # $class is an obj
$class_name = $class->name();
}
## return the instances from the cache
my($class_cache) = $self->_get_class_cache($class_name);
if (! $class_cache->_got_them_all()) {
# The instances of this class are not known to all be loaded so
# load them all...
$self->connection()->_fetch_all_instances_of_class($class,$self);
$class_cache->_got_them_all(1);
}
my(@di) = $class_cache->current_instances();
# main::print_frames($self->name()." intermediate\n",' ',@di);
if (! $param{'kb-local-only-p'}) {
my(@all_parents) = $self->get_kb_all_parents();
# main::print_frames("all_parents\n",' ',@all_parents);
foreach $_ (@all_parents) {
my @more = $_->_get_direct_instances($class,'kb-local-only-p' => 1);
# print $_->name(), "\t$_ has frames\n" if (@more);
push(@di,@more);
}
}
return @di;
}
sub _get_direct_subclasses { # KB
## Purpose:
## Return all the subclasses of $class either local to this kb
## or not on the basis of kb-local-only-p.
## Accepts:
## (class &key kb kb-local-only-p)
## Logic:
##
my($self,$class,%in) = @_;
my(%param) = ('kb-local-only-p' => 0,
%in);
my($class_name) = $class;
if (ref($class) || scalar($class) =~ m/=/) { # $class is an obj
$class_name = $class->name();
}
## return the instances from the cache
my($subclass_cache) = $self->_get_subclass_cache($class_name);
if (! $subclass_cache->_got_them_all()) {
# The instances of this class are not known to all be loaded so
# load them all...
$self->connection()->_fetch_all_subclasses_of_class($class,$self);
$subclass_cache->_got_them_all(1);
}
my(@dsc) = $subclass_cache->current_instances();
if (! $param{'kb-local-only-p'}) {
my(@all_parents) = $self->get_kb_all_parents();
# main::print_frames("all_parents\n",' ',@all_parents);
foreach $_ (@all_parents) {
my @more = $_->_get_direct_subclasses($class,'kb-local-only-p' => 1);
# print $_->name(), "\t$_ has frames\n" if (@more);
push(@dsc,@more);
}
}
return @dsc;
}
sub _stub_in { # KB
## Purpose:
## Create a new KB object with only DIRECT-INCLUDE
## Warning:
## This method should only be called by _ensure_stub_in which performs
## all appropriate caching.
my($pkg,$kb_name,$connection) = @_;
my($kb) = FRAME::new($pkg,$kb_name,undef()); # this preserves @_[0] as 1st arg
print "KB::new\t\$kb = $kb\t\$kbname $kb_name\n" if $GFP::debug > 5;
# if ($i++ > 5) {print "I grow weary\n"; exit;}
if (ref($kb) eq 'META_KB') {
$connection->set_meta_kb($kb);
}
$kb->_init_caches();
$kb->_init_slot_collections();
$kb->connection($connection);
$kb->_ensure_kb_id_loaded();
$kb->_stub_in_direct_includes();
return $kb;
}
sub _init_slot_collections { # KB
my($self) = @_;
$self->{'own_slots'} = {};
$self->{'template_slots'} = {};
$self->{'pseudo_slots'} = {}; # used internally for DIRECT-INCLUDE, etc
}
sub _stub_in_direct_includes { # KB
## Purpose:
## Populate the DIRECT-INCLUDE slot on this kb with references
## to the directly included kb stubs.
my($self) = @_;
my($connection) = $self->connection();
my($slot_name) = "DIRECT-INCLUDE";
my($direct_include_id) = $connection->{'h_reln_id'}->{$slot_name};
my($self_id) = $self->id();
my($sql) = "select name from reln, kb where src_id = $self_id and " .
"reln_id = $direct_include_id and targ_id = kb_id";
# print $self->name()," ",$sql,"\n";
my(@dp_names) = $connection->_single_column_query($sql);
my($r_current_slot) = OWN_SLOT->create($slot_name);
$self->{'pseudo_slots'}->{$slot_name} = $r_current_slot;
my($value_id) = 1;
my($dp);
foreach $dp (@dp_names) {
my($value) = KB->_ensure_stub_in($dp,$connection);
my($r_value) = VALUE->create($value_id++,'SYMBOL',$value);
$r_current_slot->append_value($r_value);
}
}
sub _ensure_stub_in { # KB
## Purpose:
## Only perform _stub_in if the kb has not already been stubbed in.
my($pkg,$kb_name,$connection) = @_;
my($meta_kb) = $connection->meta_kb();
## if the meta-KB does not already have this kb in its cache
if (! $meta_kb->_frame_in_cache_p($kb_name)) {
## then load it, cache it and return it
my($new_kb) = _stub_in($pkg,$kb_name,$connection);
$meta_kb->_add_frame_to_cache($new_kb);
$new_kb->kb($meta_kb);
return $new_kb;
} else {
## we have already stubbed in this frame so return it
return $meta_kb->_fetch_frame_from_cache($kb_name);
}
}
sub _type_code { # KB
my($one) = shift;
return "K";
}
sub BOGUS_get_kb_type_instances {
my($self,$type) = @_;
return $self->{type_cache}->get_them_all();
}
sub frame_in_kb_p { # KB
## Purpose:
## Say whether the frame is in this kb, or if not kb-local-only-p
## whether it is in any of this kb's direct parents.
## This call is recursive.
my($self,$thing,%param) = @_;
my($name) = (ref($thing))
? $thing->name()
: $thing;
# die("we got to here self = $self and id = " . $self->id() ."\n");
if ($self->_frame_in_cache_p($name) ||
$self->connection()->frame_in_kb_p_internal($name,$self->id(),$self)) {
# return $self->id(); # yup the frame is in this kb
return $self; # yup the frame is in this kb
}
if ($param{'kb-local-only-p'}) {
return 0; # and dont go looking any further
}
my($kb);
foreach (get_kb_all_parents($self)) {
print "Checking for $name in ". $_->name() . "\n" if $GFP::debug > 21;
if ($_->frame_in_kb_p($name,'kb-local-only-p' => 1)) {
# return $_->id(); # ok, we found it
return $_; # ok, we found it
}
}
return 0; # nobody knows
}
sub get_class_instances { # KB
my($self,$theclass,%in) = @_;
my(%params) = ('inference-level'=>':taxonomic',
'number-of-values'=>':all',
'kb-local-only-p'=>0,%in);
my($inference_level) = $params{'inference-level'};
my($kb_local_only_p) = $params{'kb-local-only-p'};
my(@dirinsts) = ();
my(@allinsts) = ();
my(@dirsubs) = ();
my($dirsub);
my(@taxinsts) = ();
@dirinsts = $self->_get_direct_instances($theclass,
'kb-local-only-p'=>$kb_local_only_p);
if ($inference_level eq ":taxonomic"){
@dirsubs = $self->_get_direct_subclasses($theclass);
foreach $dirsub (@dirsubs){
@taxinsts = $self->get_class_instances($dirsub,
'kb-local-only-p'=>$kb_local_only_p);
push(@allinsts,@taxinsts);
}
}
push(@allinsts,@dirinsts);
return @allinsts;
}
sub get_class_subclasses { # KB
## Purpose:
## Logic:
## The logic for the most complex situation: (that is, with default args)
## is:
## 1) get_direct_subclasses
## 2) foreach direct subclass
## 3) a_direct_subclass->get_direct_subclasses()
## 4) collect all the subclasses
## 5) return them all
my($self,$class,%params) = @_;
my(@direct_subclasses) =
$self->_get_direct_subclasses($class,
'kb-local-only-p' =>
$params{'kb-local-only-p'});
my(@all_subclasses);
warn "KB::get_class_subclasses() ".
" does not implement 'number-of-values' other than :all"
if ($params{'number-of-values'} ne ":all");
push(@all_subclasses,@direct_subclasses); # start a copy
my($a_direct_subclass);
if ($params{'inference-level'} ne ':direct') {
foreach $a_direct_subclass (@direct_subclasses) {
my(@direct_subclasses_subclasses) =
$self->get_class_subclasses($a_direct_subclass,
'inference-level' =>
$params{'inference-level'},
'kb-local-only-p' =>
$params{'kb-local-only-p'},
'number-of-values' =>
$params{'number-of-values'}
);
push(@all_subclasses,@direct_subclasses_subclasses);
}
}
return @all_subclasses;
}
sub get_kb_classes { # KB
# GFP2.0 p60
## Purpose:
## Returns list-of-classes, a list of the classes in the KB.
## Selector is one of :all, :frames, :system-default
my($self,%param) = @_;
if ($param{'kb-local-only-p'}) {
return $self->get_kb_type_instances('C');
} else {
my(@classes) = $self->get_kb_classes('kb-local-only-p' => 1);
foreach (get_kb_all_parents($self)) {
push(@classes,$_->get_kb_classes('kb-local-only-p' => 1));
}
return @classes;
}
}
sub get_kb_type_instances { # KB
## Purpose:
## Returns all the instance of a particular type in the kb.
my($self,$type_code) = @_;
my($type_cache) = $self->{type_cache}->{$type_code};
if (! $type_cache->_got_them_all()) {
$self->connection()->_fetch_all_instances_of_type($type_code,$self);
$type_cache->_got_them_all(1);
}
return $type_cache->current_instances();
}
sub get_kb_all_parents { # KB
## This is the entry point to the recursion. The chief task
## is to set up the hash which will be passed down the call tree
## to keep track of which KBs have already been checked.
my($self) = @_;
my(%seen_these) = ("$self" => $self); # block recursion by 'seeing' self
my(@direct_parents) = $self->get_kb_direct_parents();
my($parent);
foreach $parent (@direct_parents) {
if (! exists($seen_these->{"$parent"})) {
$seen_these{"$parent"} = $parent;
$parent->get_kb_all_parents_recurse(\%seen_these);
}
}
# FIXME The following line should be uncommented, because without it
# we have the get_class_instances returning duplicates error.
# Unfortunately, the loading of meta-KB seems to rely on this
# but to avoid a fatal error. Oh my.
delete $seen_these{"$self"}; # but self is not an all-parent of self
return values %seen_these;
}
sub get_kb_all_parents_recurse { # KB
## Purpose:
## This is the recursive part.
my($self,$seen_these) = @_;
my(@direct_parents) = $self->get_kb_direct_parents();
my($parent);
foreach $parent (@direct_parents) {
if (! exists($seen_these->{"$parent"})) {
$seen_these->{"$parent"} = $parent;
$parent->get_kb_all_parents_recurse($seen_these);
}
}
}
sub ITERATIVE_get_kb_all_parents { # KB
## Purpose:
## Return an array of all the kbs this kb inherits from.
## Logic:
## Warning:
## This function does not work.
my($self) = @_;
my(%seen) = ("$self" => $self);
print "\n" . $self->name(), " has all parents:\n";
my(@ap) = $self->get_kb_direct_parents();
# push(@ap,@dp);
my($pkb); # parent kb
foreach $pkb (@ap) {
if (! exists($seen{"$pkb"})) {
$seen{"$pkb"} = $pkb;
print " processing ",$pkb->name(), "\n";
my($another);
my(@more) = $pkb->get_kb_direct_parents();
foreach $another (@more) {
if (! exists($seen{"$another"})) {
print " ", $another->name(), " is being pushed\n";
$seen{"$another"} = $another;
push(@ap,$another);
# print sort values %seen ," ".@ap."\n";
} else {
print " ", $another->name(), " has already been seen\n";
}
}
}
# print %seen." ".@ap."\n";
}
my($list);
foreach (@ap) {
$list .= "\t$_\t".$_->name()."\n";
}
print $list;
return @ap;
}
sub fault_in { # KB
## Purpose:
## Logic:
## call super
my($self) = @_;
if (! $self->loaded()) {
# $self->_ensure_kb_id_loaded();
$self->SUPER::fault_in(@_); # ensure that the frame is loaded
# $self->_ensure_direct_parents_loaded();
}
return $self;
}
sub _ensure_kb_id_loaded {
my($self) = @_;
my($id) = $self->connection()->
_single_valued_query("select kb_id from kb " .
"where name = " .
$self->connection()->{dbh}->quote($self->name()));
$self->id($id);
print "KB::_ensure_kb_id_loaded() id = ",
$self->id(), " name = ",$self->name(), "\n"
if $GFP::debug > 9;
}
sub _ensure_direct_parents_loaded { # KB
## Purpose:
## Ensure that all the direct parents are loaded.
my($self) = @_;
if (! $self->parents_loaded_p()) {
$self->get_kb_direct_parents(); # this creates and faults in each kb
# my($parent);
# foreach $parent (@dp) {
# $parent->_ensure_direct_parents_loaded();
# }
}
return 1;
}
sub get_kb_direct_parents { # KB
## Purpose:
## Return the direct parents as a list of KB objects.
my($self) = shift;
if (exists($self->{'pseudo_slots'}->{'DIRECT-INCLUDE'})) {
$self->{'pseudo_slots'}->{'DIRECT-INCLUDE'}->get_values();
} else {
die("Somehow kb '".$self->name().
"' has been stubbed in without the DIRECT-INCLUDE pseudo slot.");
}
# perform the
# this implementation works but has the problem that it triggers fault_in
# return GFP::get_slot_values($self,"DIRECT-INCLUDE");
# THIS CODE AND MOST subs CALLED BY IT SHOULD BE THROWN AWAY
# if (! $self->parents_loaded_p()) { # if not then ask connection
# $self->parents_loaded_p(1); # must set this before recursing
# $self->connection()->get_kb_direct_parents_internal();
# }
}
sub parents_loaded_p { # KB
my($self) = shift;
@_ ? $self->{'parents_loaded_p'} = shift
: $self->{'parents_loaded_p'};
}
sub connection { # KB
## Purpose:
## Set or get the connection for this kb
my($self) = shift;
@_ ? $self->{'connection'} = shift
: $self->{'connection'};
}
sub get_frame_type { # KB
my($self) = shift;
return ":kb";
}
sub get_frame_handle_internal { # KB
my($self,$frame,%param) = @_;
return $self->connection()->get_frame_handle_internal($frame->name(),
$self->{'handle'});
}
sub get_frame_in_kb_internal { # KB
## Purpose:
## If the frame is in the cache, return it. If not, get it.
## Accepts:
## (thing &key kb (error-p true) kb-local-only-p)
## Returns:
## frame frame-found-p
my($self,$thing,%in) = @_; # the parameters should be fully specified
my(%param) = ('kb' => $self, %in);
# print "KB::get_frame_in_kb_internal ". $self->name() . " $thing\n";
my($frame) = $self->_fetch_frame_from_cache($thing);
if (! defined($frame)) {
$frame = $self->{'connection'}->get_frame_in_kb_internal($thing,$self);
$self->_add_frame_to_cache($frame);
}
my(@retval) = ($frame,(ref($frame)));
print "KB::get_frame_in_kb_internal($thing) = ($retval[0] $retval[1])\n"
if ($GFP::debug > 9);
return @retval;
}
sub save_kb { # KB
my($self,%param) = @_;
$self->connection->save_kb_internal(%param);
}
##
## dirty list management
##
sub add_to_dirty_list { # KB
## Purpose:
## Place $frame in the dirty list and set the dirty flag on it.
my($self,$frame) = @_;
$self->{'dirty_list'}->{"$frame"} = $frame;
$frame->dirty(1);
}
sub delete_from_dirty_list { # KB
## Purpose:
## Remove $frame from the dirty list and remove the dirty flag from it.
my($self,$frame) = @_;
delete($self->{'dirty_list'}->{"$frame"});
$frame->dirty(1);
}
sub number_of_dirty { # KB
## Purpose:
## Return the number of dirty frames.
my($self) = shift;
return %{$self->{'dirty_list'}};
}
sub dirty_list { # KB
## Purpose:
## Return an array of the frames which are dirty
my($self) = shift;
return values %{$self->{'dirty_list'}};
}
sub empty_dirty_list { # KB
## Purpose:
## Remove all entries from the dirty list.
my($self) = shift;
foreach (values %{$self->{'dirty_list'}}) {
$self->delete_from_dirty_list($_);
}
}
##
## KB cache managment stuff
##
sub _add_frame_to_cache { # KB
## Purpose:
## Add a frame to the cache.
my($self,$frame) = @_;
# warn "KB::_add_frame_to_cache(",$self->name(),",",$frame->name(),")\n";
if (! $self->_frame_in_cache_p($frame->name())) {
$self->{cache}->{$frame->name()} = $frame;
$self->{type_cache}->{$frame->_type_code()}->_add($frame);
}
}
sub _frame_in_cache_p { # KB
my($self,$name) = @_;
return exists($self->{'cache'}->{$name});
}
sub _fetch_frame_from_cache { # KB
## Purpose:
## Fetch frame by name from the cache or return undef.
my($self,$name) = @_;
# print "KB::_fetch_frame_from_cache($name)\n" if $GFP::debug > 9;
if (! exists($self->{cache})) {
die("cache for ". $self->{name} ." does not exist");
}
if ($self->_frame_in_cache_p($name)) {
warn "KB::_fetch_frame_from_cache($name) successful\n" if ($GFP::debug > 9);
return $self->{cache}->{$name};
} else {
warn "KB::_fetch_frame_from_cache($name) unsuccessful\n" if ($GFP::debug > 9);
return undef;
}
}
sub _init_caches { # KB
## Purpose:
## Prepare all the caches into which frames are added by
## _add_frame_to_cache
my($self) = @_;
# init the cache upon which all frames in this kb are stashed
$self->{cache} = {};
# init the type caches
$self->{type_cache}->{CLASS->_type_code()} = TypeCacheOnKb->new();
$self->{type_cache}->{INDIVIDUAL->_type_code()} = TypeCacheOnKb->new();
$self->{type_cache}->{KB->_type_code()} = TypeCacheOnKb->new();
$self->{type_cache}->{SLOT_UNIT->_type_code()} = TypeCacheOnKb->new();
# init the class caches
$self->{class_cache} = {};
# init the subclass caches
$self->{subclass_cache} = {};
# init the dirty_list
$self->{'dirty_list'} = {};
}
sub _dump_cache { # KB
my($self,$recurse) = @_;
my($name) = $self->name();
print "\n\n_dump_cache($name($self))\n";
my($key);
foreach $key (keys %{$self->{cache}}) {
print "\t$key\t" . $self->{cache}->{$key}."\n";
}
my($type);
foreach $type (qw(S I C K)) { # Slot Individual Class Kb
print " type_cache $type\n";
print $self->{type_cache}->{$type}->dump("\t");
}
if (defined($recurse) && $recurse) {
my $pkb;
foreach $pkb ($self->get_kb_all_parents()) {
print "\n";
$pkb->_dump_cache();
}
}
}
##
## class cache stuff
##
sub _add_frame_to_class_caches { # KB
## Purpose:
## To ensure that it is recorded for each class that $frame is a
## direct-instance that this is so.
my($self,$frame) = @_;
my(@classes) = GFP::get_instance_types($frame,
'kb' => $self,
'inference-level' => ':direct');
my($class);
foreach $class (@classes) {
my($class_name) = $class->name();
my($class_cache) = $self->_get_class_cache($class_name);
$class_cache->_add($frame);
# a oneline version of the above:
# $self->_get_class_cache($class->name())->_add($frame);
}
}
sub _get_class_cache { # KB
## Purpose:
## Return the cache on this kb of the instances of a class.
## If one does not already exist, create it.
my($self,$class_name) = @_;
if (! exists($self->{'class_cache'}->{$class_name})) {
$self->{'class_cache'}->{$class_name} = ClassCacheOnKb->new();
}
return $self->{'class_cache'}->{$class_name};
}
sub _dump_class_caches { # KB
## Purpose:
## Dump each existing class cache on this KB.
my($self,$recurse) = @_;
my($name) = $self->name();
print "\n\n_dump_class_caches($name($self))\n";
foreach $class_name (keys %{$self->{'class_cache'}}) {
print " class_cache $class_name\n";
print $self->{class_cache}->{$class_name}->dump("\t");
}
if (defined($recurse) && $recurse) {
my $pkb;
foreach $pkb ($self->get_kb_all_parents()) {
print "\n";
$pkb->_dump_class_caches();
}
}
}
##
## subclass cache stuff
##
sub _add_frame_to_subclass_caches { # KB
## Purpose:
## To ensure that it is recorded for each class that $frame is a
## direct-instance that this is so.
my($self,$frame) = @_;
if (! $frame->isa('CLASS')) {
return;
}
my(@classes) = GFP::get_class_superclasses($frame,
'kb' => $self,
'inference-level' => ':direct');
my($class);
foreach $class (@classes) {
my($class_name) = $class->name();
my($subclass_cache) = $self->_get_subclass_cache($class_name);
$subclass_cache->_add($frame);
# a oneline version of the above:
# $self->_get_class_cache($class->name())->_add($frame);
}
}
sub _get_subclass_cache { # KB
## Purpose:
## Return the cache on this kb of subclasses of a class.
## If one does not already exist, create it.
my($self,$class_name) = @_;
if (! exists($self->{'subclass_cache'}->{$class_name})) {
$self->{'subclass_cache'}->{$class_name} = ClassCacheOnKb->new();
}
return $self->{'subclass_cache'}->{$class_name};
}
#############
## FRAME ##
#############
package FRAME;
sub new { # FRAME
## Purpose:
## Create a new FRAME object
my($pkg,$frame_name,$kb) = @_;
my($self) = bless({'name' => $frame_name},$pkg);
$self->frame_in_cache_p(0);
$self->kb($kb);
if (defined($kb)) {
# the cache does not yet exist when self is the meta kb so...
$kb->_add_frame_to_cache($self);
}
print "FRAME::new() blessing $frame_name as $pkg\n" if $GFP::debug > 5;
# $self->fault_in();
return $self;
}
sub _primitive_reln { # FRAME
my($self) = shift;
return ('DIRECT-TYPE');
}
sub _type_code { # FRAME
my($one) = shift;
die("$one needs its own _type_code() implementation\n");
}
sub class_p { # FRAME
return 0;
}
sub get_frame_slots { # FRAME
## Purpose:
## Return the slots on this frame
my($self,%param) = @_;
my(@retarray);
my($slot_name);
if ($param{'slot-type'} =~ m/\:all|\:own/) {
foreach $slot_name (keys %{$self->{own_slots}}) {
# print "own slot_name = '$slot_name'\n";
push(@retarray,$slot_name);
}
}
if ($param{'slot-type'} =~ m/\:all|\:template/) {
foreach $slot_name (keys %{$self->{template_slots}}) {
push(@retarray,$slot_name);
}
}
return @retarray;
}
sub get_slot_values { # FRAME
## Purpose:
## Return an array of values for a named slot.
## Accepts:
## $self an object reference
## $slot a slot name
## %h_params a hash of named parameters with keys:
## slot-type the type {own|template} of the slot to return
# my($self,%params) = @_;
my($self,$slot,%params) = @_;
# $self->fault_in();
my($which) = ":own_slots";
if (exists($params{'slot-type'}) && $params{'slot-type'}) {
$which = "$params{'slot-type'}_slots";
}
$which =~ s/\://; # remove the : from before :own or :template
# print "get_slot_values() $which " . $self->{$which} . ".\n";
# print " blah = ". $self->{$which} . "\n";
# print " h_params{name} = $h_params{name}\n";
# print " blah = ". $self->{$which}->{$h_params{name}} . "\n";
if (exists($self->{$which}) && exists($self->{$which}->{$slot})) {
$GFP::dorf=1; return $self->{$which}->{$slot}->get_values();
} $GFP::dorf=0;
return ();
}
sub get_slot_value { # FRAME
# return ${get_slot_values(@_)}[0];
my(@retarray) = get_slot_values(@_);
if (@retarray) {
return $retarray[0];
} else {
return undef();
}
}
sub fault_in { # FRAME
my($self) = @_;
# $self{'kb'}->connection()->
# if (0) {
if (! $self->loaded()) {
# print "FRAME\:\:fault_in() kb = ", $self->kb() , "\n";
my($conn) = $self->kb()->connection(); # FIXME should be a KB method
my($details) = $conn->fetch_record_for_frame_in_kb($self->name(),
$self->kb());
$self->id($details->{'frame_id'});
$self->loaded(1);
$conn->flesh_out_frame($self,$details);
}
return $self;
}
sub loaded { # FRAME
## Purpose:
## Set or get whether the frame details are loaded yet.
my($self) = shift;
@_ ? $self->{'loaded'} = shift
: $self->{'loaded'};
}
sub kb { # FRAME
## Purpose:
## Set or get which kb the frame is in.
my($self) = shift;
@_ ? $self->{'kb'} = shift
: $self->{'kb'};
}
sub id { # FRAME
## Purpose:
## Set or get the frame_id of the frame
my($self) = shift;
@_ ? $self->{'frame_id'} = shift
: $self->{'frame_id'};
}
sub dirty { # FRAME
## Purpose:
## Set or get the dirty flag on the frame
my($self) = shift;
@_ ? $self->{'dirty'} = shift
: $self->{'dirty'};
}
sub handle { # FRAME
## Purpose:
## Set or get the handle for this kb
my($self) = shift;
@_ ? $self->{'handle'} = shift
: $self->{'handle'};
}
sub name { # FRAME
## Purpose:
## Set or get the name of this frame
my($self) = shift;
@_ ? $self->{'name'} = shift
: $self->{'name'};
}
sub frame_in_cache_p { # FRAME
## Purpose:
## Set or get whether the frame contents are actually present on the object.
my($self) = shift;
@_ ? $self->{'frame_in_cache'} = shift
: $self->{'frame_in_cache'};
}
sub get_frame_handle_internal { # FRAME
my($self,%param) = @_;
if (! exists($self->{'handle'})) {
$self->{'handle'} = $param{'kb'}->get_frame_handle(%param);
}
return $self->{'handle'};
}
sub put_instance_types { # FRAME
# GFP2.0 p66
## Purpose:
## Changes frame to be an instance of all the classes listed in
## new_types. This operation may signal constraint violation conditions.
my($frame,$ra_new_types,%param) = @_;
my(@new_types) = @$ra_new_types;
my($a_class_name);
# FIXME this implementation ignores all proper updating of the
# class_caches on the KB.
foreach $a_class_name (@new_types) {
$class_obj = GFP::get_frame_in_kb($a_class,$kb);
die('not yet implemented');
}
}
sub set_frame_details { # FRAME
## Purpose:
## Analogous to get_frame_details but lets you set em.
## This is very simplistic: it does not merge in values, it replaces them.
## Accepts:
## %param a set of keys including:
## name, type, frame_id, own_slots, template_slots
my($self,$rh_param) = @_;
my($key);
foreach $key (qw(name type frame_id own_slots template_slots)) {
if (exists($$rh_param{$key})) {
$self->{$key} = $$rh_param{$key};
}
}
return $self;
}
sub canonicalize { # FRAME
## Purpose:
## Output a version of the frame which is in the TIE_PARSE_FORMAT
## defined elsewhere in this document.
my($self) = @_;
my(@out);
my($slot_name);
push(@out,'F:'
# .$self->get_type().':'
.$self->_type_code().':'
.$self->get_frame_name());
foreach $slot_name (sort keys %{$self->{own_slots}}) {
push(@out,$self->{own_slots}->{$slot_name}->canonicalize());
}
foreach $slot_name (sort keys %{$self->{template_slots}}) {
push(@out,$self->{template_slots}->{$slot_name}->canonicalize());
}
# push(@out,"\n"); # add a trailing carriage return
return join("\n",@out);
}
sub commented_canonicalize { # FRAME
my(@out);
push(@out,"\n# a canonical dump of a perl FRAME object");
return join("\n",@out,FRAME::canonicalize(@_));
}
sub get_frame_name { # FRAME
## Purpose:
## Return the name of the frame.
my($self) = @_;
return $self->{'name'};
}
sub get_type { # FRAME
## Purpose:
## Return the scope of the frame.
my($self) = @_;
return $self->{'type'};
}
sub individual_p { # FRAME
return 1;
}
sub spill { # FRAME
my($self) = @_;
print "\n\nspill(" . $self->{'name'} . ")\n";
my($key);
foreach $key (keys %$self) {
my($val) = (defined($self->{$key})) ? $self->{$key} : 'undef';
print "\t$key\t$val\n";
}
}
#############
## CLASS ##
#############
package CLASS;
@ISA = qw(FRAME);
sub _primitive_reln { # CLASS
my($self) = shift;
return ($self->SUPER::_primitive_reln(), 'DIRECT-SUPER');
}
sub class_p { # CLASS
return 1;
}
sub get_frame_type { # CLASS
my($self) = shift;
return ":class";
}
sub _type_code { # CLASS
return "C";
}
sub individual_p { # CLASS
return 0;
}
##################
## INDIVIDUAL ##
##################
package INDIVIDUAL;
@ISA = qw(FRAME);
sub get_frame_type { # INDIVIDUAL
return ":individual";
}
sub _type_code { # INDIVIDUAL
return "I";
}
sub individual_p { # FRAME
return 1;
}
#################
## SLOT_UNIT ##
#################
## Purpose:
## This is the class which is a subclass of frame. That is this is
## the class such that its instances have a one to one relationship
## with the differend kinds of slot in a kb.
package SLOT_UNIT;
@ISA = qw(FRAME);
sub get_frame_type { # SLOT_UNIT
return ":slot";
}
sub _type_code { # SLOT_UNIT
return "S";
}
##################
## Connection ##
##################
package Connection;
sub init { # Connection
## Purpose:
## Adds an empty cache hash to the Connection
my($self) = @_;
# $self->{cache} = {};
}
sub meta_kb { # Connection
## Purpose:
## return the kb which is the meta_kb for this connection
my($self) = shift;
if (! exists($self->{'meta_kb'}) ) {
# if meta_kb has not been loaded, then load it, and remember
$self->open_meta_kb($self->name_of_meta_kb());
}
return $self->{'meta_kb'}
}
sub set_meta_kb { # Connection
## Purpose:
## Set the meta_kb for this connection.
my($self,$meta_kb) = @_;
$self->{'meta_kb'} = $meta_kb;
}
sub name_of_meta_kb { # Connection
## Purpose:
## Record the name of the meta_kb so that subclasses of Connection
## may override.
return "Meta-KB"; # this is the standard name
}
sub open_meta_kb { # Connection
my($self,$kb_name) = @_;
# my($meta_kb) = $self->open_kb($kb_name,"");
my($meta_kb) = META_KB->new($kb_name,$self);
$self->{'meta_kb'} = $meta_kb;
$meta_kb->kb($meta_kb); # tell the meta_kb frame which kb it is in
return $meta_kb;
}
sub open_kb { # Connection
my($self,$kb_name,$meta_kb_for_this_kb) = @_;
my($kb) = KB->new($kb_name,$meta_kb_for_this_kb,$self);
# $kb->connection($self);
return $kb;
}
#######################
## Connection::DBI ##
#######################
package Connection::DBI;
@ISA = qw(Connection);
use DBI;
sub name_of_meta_kb {
return "meta-KB"; # this is the name we accidentally chose
}
sub connect { # Connection::DBI
my($pkg,$url,$user,$passwd) = @_;
my($self) = $pkg->just_connect($url,$user,$passwd);
$self->_init_reln_ids();
return $self;
}
sub just_connect { # Connection::DBI
my($pkg,$url,$user,$passwd) = @_;
# print "url = $url\nuser = $user\n";
my($dbh) = DBI->connect($url,$user,$passwd);
if (! $dbh) {
die("Could not connect to
database: $url".
"
as user: $user" .
"
for reason: $DBI::errstr\n");
} else {
# print "successful connection to $url\n";
}
my($self) = (bless {dbh => $dbh,
url => $url}, $pkg);
return $self;
}
sub create_frame_internal { # Connection::DBI
## Purpose:
## This crude subroutine is a quick and dirty (though fast, safe,
## effective and simple) implementation to just get us started.
## A more elaborate version would be implemented in KB and
## hence be more general, but would require methods like:
## put_instance_types, put_slot_values and friends.
## Accepts:
## (name &key kb direct-types doc own-slots own-facets handle
## pretty-name kb-local-only-p)
## with values structured like:
## template-slots,
## own-slots slot specifications are like this:
## ['slot-name',
## [':default', 'default-value'],
## 'slot-value-1',
## slot-value-2-obj]
##
my($self,$name,$frame_type,%param) = @_; # default param are set in GFP
my($kb) = $param{'kb'}; # it will be referenced more than once so...
my($direct_types) =
exists($param{'direct-types'}) ? $param{'direct-types'} : [];
my($direct_superclasses) =
exists($param{'direct-superclasses'}) ? $param{'direct-superclasses'} : [];
my($own_slots) =
exists($param{'own-slots'}) ? $param{'own-slots'} : [];
my($template_slots) =
exists($param{'template-slots'}) ? $param{'template-slots'} : [];
my($own_facets) =
exists($param{'own-facets'}) ? $param{'own-facets'} : [];
my($template_facets) =
exists($param{'template-facets'}) ? $param{'template-facets'} : [];
# $source_conn->copy_to($target_conn,\%field_types);
## if of frame of this name already exists in this kb then fail
# if (! ${GFP::get_frame_in_kb($name,'kb' => $kb,'kb-local-only-p' => 1)}[1]) {
my(@retval) = GFP::get_frame_in_kb($name,'kb' => $kb,'kb-local-only-p' => 1);
if ($retval[1]) {
warn("create_frame_internal($name) frame '$name' already exists in kb ".
$kb->name());
return undef();
}
## initialize an object to some subclass of FRAME
my($frame);
SWITCH: {
if ($frame_type eq ':class') {
$frame = CLASS->new($name,$kb);
last SWITCH;
}
if ($frame_type eq ':individual') {
$frame = INDIVIDUAL->new($name,$kb);
last SWITCH;
}
if ($frame_type eq ':kb') {
$frame = KB->new($name,$kb,$self);
last SWITCH;
}
if ($frame_type eq ':slot') {
$frame = SLOT_UNIT->new($name,$kb);
last SWITCH;
}
die("create_frame_from_record($details->{'name'}) " .
"has unrecognized type: '$frame_type'");
}
# this frame is dirty because it has just been created
$kb->add_to_dirty_list($frame);
# FIXME what is the meaning of kb-local-only-p on put_instance_types?
my($r_current_slot); # the currently active slot
## add the direct-types
my($type);
my($slot_name) = "DIRECT-TYPE";
$r_current_slot = OWN_SLOT->create($slot_name);
$frame->{'own_slots'}->{$slot_name}=$r_current_slot;
my($value_id) = 1;
foreach $type_thing (@$direct_types) {
my($value);
if (ref($type_thing) && scalar($type_thing) =~ m/=/) {
# type_thing is an object
$value = $type_thing;
} else {
# type_thing is just a name
my(@retval) = GFP::get_frame_in_kb($type_thing,'kb' => $kb);
if ($retval[1]) {
$value = $retval[0];
} else {
die("create_frame_internal() could not get the frame '$type_thing'");
}
}
$r_current_slot->append_value(VALUE->create($value_id++,'SYMBOL',$value));
}
if ($frame->isa("CLASS")) {
$slot_name = "DIRECT-SUPER";
$r_current_slot = OWN_SLOT->create($slot_name);
$frame->{'own_slots'}->{$slot_name}=$r_current_slot;
my($value_id) = 1;
foreach $type_thing (@$direct_superclasses) {
my($value);
if (ref($type_thing) && scalar($type_thing) =~ m/=/) {
# type_thing is an object
$value = $type_thing;
} else {
# type_thing is just a name
my(@retval) = GFP::get_frame_in_kb($type_thing,'kb' => $kb);
if ($retval[1]) {
$value = $retval[0];
} else {
die("create_frame_internal() could not get the frame '$type_thing'");
}
}
$r_current_slot->append_value(VALUE->create($value_id++,'SYMBOL',$value));
}
}
## add the pretty-name (if it is specified)
if (defined($param{'pretty-name'})) {
my($slot_name) = 'PRETTY-NAME';
$r_current_slot = OWN_SLOT->create($slot_name);
$frame->{'own_slots'}->{$slot_name}=$r_current_slot;
$r_current_slot->append_value(VALUE->create(1,
"STRING",
$param{'pretty-name'}));
}
## add the documentation string (if it is specified)
if (defined($param{'doc'})) {
my($slot_name) = 'DOCUMENTATION';
$r_current_slot = OWN_SLOT->create($slot_name);
$frame->{'own_slots'}->{$slot_name}=$r_current_slot;
$r_current_slot->append_value(VALUE->create(1,
"STRING",
$param{'doc'}));
}
## add the own_slots (other than direct-type)
my($r_slot_spec); # a specification for a slot and its values
foreach $r_slot_spec (@{$param{'own-slots'}}) {
my($slot_name) = shift(@{$r_slot_spec});
my($slot_value);
$r_current_slot = OWN_SLOT->create($slot_name);
$frame->{'own_slots'}->{$slot_name}=$r_current_slot;
my($value_id) = 0;
foreach $slot_value (@{$r_slot_spec}) {
if (ref($slot_value) eq ARRAY) { # is it a default value?
my($default_value) = @{$slot_value}[1];
warn("create_frame_internal($name) is ignoring :default values");
} else { # it is a simple slot value
my($value_type);
if (ref($slot_value) && scalar($slot_value) =~ m/=/) {
$value_type = 'SYMBOL';
} elsif ($slot_value eq $name) { # the value is this frame itself
$value_type = 'SYMBOL';
$slot_value = $frame;
} else {
# FIXME: whether or not a string should be interpreted as a
# a frame name rather than a string should be based
# on the slot-value-type of the slot itself.
warn("create_frame_internal($name) is assuming STRING" .
" is value_type for $slot_value");
$value_type = 'STRING';
}
my($r_value) = VALUE->create($value_id++,$value_type,$slot_value);
$r_current_slot->append_value($r_value);
}
}
}
## add the template_slots
foreach $r_slot_spec (@{$param{'template-slots'}}) {
my($slot_name) = shift(@{$r_slot_spec});
my($slot_value);
$r_current_slot = TEMPLATE_SLOT->create($slot_name);
$frame->{'template_slots'}->{$slot_name}=$r_current_slot;
my($value_id) = 0;
foreach $slot_value (@{$r_slot_spec}) {
if (ref($slot_value) eq ARRAY) { # is it a default value?
my($default_value) = @{$slot_value}[1];
warn("create_frame_internal($name) is ignoring :default values");
} else { # it is a simple slot value
my($value_type);
if (ref($slot_value) && scalar($slot_value) =~ m/=/) {
$value_type = 'SYMBOL';
} elsif ($slot_value eq $name) { # the value is this frame itself
$value_type = 'SYMBOL';
$slot_value = $frame;
} else {
# FIXME: whether or not a string should be interpreted as a
# a frame name rather than a string should be based
# on the slot-value-type of the slot itself.
warn("create_frame_internal($name) is assuming STRING" .
" is value_type for $slot_value");
$value_type = 'STRING';
}
my($r_value) = VALUE->create($value_id++,$value_type,$slot_value);
$r_current_slot->append_value($r_value);
}
}
}
# be sure that the new frame gets indexed for quick access
$kb->_add_frame_to_class_caches($frame);
# only needed for classes, we COULD test, but it does that for us
$kb->_add_frame_to_subclass_caches($frame);
return $frame;
}
sub save_kb_internal { # Connection::DBI
## Purpose:
## Perform _save_frame on each frame in the dirty list.
my($self,%param) = @_;
# for each frame in the dirty list write it out
my($dirty);
foreach ($param{'kb'}->dirty_list()) {
$self->_save_frame($_);
}
$param{'kb'}->empty_dirty_list();
}
sub _save_frame { # Connection::DBI
## Purpose:
## Save a frame record to the database, affecting at least the
## frame and the reln tables and also the kb table if appropriate.
my($self,$frame) = @_;
my($dbh) = $self->{'dbh'};
my($kb) = $frame->kb();
my($creator) = 0;
my($changer) = 0;
my($created) = 'now';
my($changed) = 'now';
## save the record to the frame table
my($frame_id) =
(defined($frame->id()) && $frame->id() > 0)
? $frame->id()
: $self->_get_next_frame_id();
my(@raw_values) = ($frame_id, # frame_id
$kb->id(), # kb_id
$frame->name(), # name
$frame->canonicalize(), # frame
$frame->_type_code(), # type
$creator, # creator
$created, # created
$changer, # changer
$changed # changed
);
my($frame_quote_field) =
$self->_get_quote_field_array("select * from frame where frame_id = 0");
my($insert_sql) = $self->create_insert_sql("frame",
\@raw_values,
$frame_quote_field);
# print "_save_frame() $insert_sql\n";
my($rv) = $self->{'dbh'}->do($insert_sql);
if (! defined($rv)) {
die("Connection::DBI::_save_frame failed on sql\n\t$insert_sql\nwith error\n\t"
. $self->{dbh}->errstr);
}
## Delete all reln where the current frame is the source
$rv = $self->{'dbh'}->do("delete from reln where src_id = $frame_id");
if (! defined($rv)) {
die("Connection::DBI::_save_frame failed on sql\n\t$insert_sql\nwith error\n\t"
. $self->{dbh}->errstr);
}
## Save appropriate records to the reln table
# discover which fields are in the reln table for the purposes of quoting
my($reln_quote_field) =
$self->_get_quote_field_array("select * from reln where src_id = 0");
my(%reln_relevant_to_types) = ();
if (1) {
my($reln_slot_name);
# foreach $reln_slot_name (keys %{$self->{'h_reln_id'}}) {
foreach $reln_slot_name ($frame->_primitive_reln()) {
# get the slot values (which amount to the targets)
my(@reln_targets) =
GFP::get_slot_values($frame,
$reln_slot_name,
'inference-level' => ':direct',
'slot-type' => ':own',
);
my($reln_id) = $self->{'h_reln_id'}->{$reln_slot_name};
my($reln_target);
foreach $reln_target (@reln_targets) {
$insert_sql = $self->create_insert_sql('reln',
[$reln_id,
$frame_id,
$reln_target->id()],
$reln_quote_field);
# print "reln $insert_sql\n";
my($rv) = $self->{'dbh'}->do($insert_sql);
if (! defined($rv)) {
die("Connection::DBI::_save_frame failed on sql\n" .
"\t$insert_sql\nwith error\n\t" .
$self->{dbh}->errstr);
}
}
}
}
}
sub _get_quote_field_array {
## Purpose:
## Get an array which contains the field types of each field in
## the return table produced by $sql. The motivation for this is
## provide type info to _create_insert_sql to accomodate DBI drivers
## which do not support the meta-information methods fully.
my($self,$sql) = @_;
my($sth) = $self->{dbh}->prepare($sql);
$sth->execute();
my(@quote_field) = @{$sth->{'TYPE'}};
$sth->finish();
return \@quote_field;
}
sub create_insert_sql { # Connection::DBI
my($self,$table_name,$r_array,$r_quote_field) = @_;
# print "r_quote_field = ..." , join(" ",@$r_quote_field), "\n";
my($last_field) = scalar(@{$r_quote_field}) - 1;
# print "last_field = $last_field @$r_quote_field\n";
my (@insert);
foreach $field_no (0..$last_field) {
my($val) = ($$r_quote_field[$field_no] != 23)
? $self->{'dbh'}->quote($$r_array[$field_no])
: $$r_array[$field_no];
if (! defined($val)) {
$val = " NULL";
}
if ($val =~ m/^\s*$/) {
$val = ' NULL';
}
push(@insert,$val);
}
return "insert into $table_name values ("
. join(", ",@insert) . ")";
}
sub _get_next_frame_id { # Connection::DBI
## Purpose:
## Return the id of the next frame record to create.
## Logic:
## Warnings:
## This is vulnerable to other processes operating at the same
## time and both getting the same next_id at the same time.
## FIXME: Somehow ensure that other processes can't clobber this id.
## A possible fix is to return.
my($self) = @_;
my($next_id) =
return $self->_single_valued_query("select max(frame_id)+1 ".
"as next_id from frame");
}
sub copy_to { # Connection::DBI
## Purpose:
## This crude utility function copies an entire Connection::DBI and
## all of its associated tables to another Connection::DBI which
## may or may not already have a meta-KB. The intent is to be able
## to have offline versions of KRs for development purposes.
## Clearly a more sophisticated copying mechanism is required but
## is beyond the scope of this method.
my($self,$target,@tables) = @_;
my($table);
# frame_id|kb_id|name|frame|type|creator|created|changer|changed
# --------+-----+----+-----+----+-------+-------+-------+-------
foreach $table (@tables) {
# print "About to copy table '$table'\n";
$self->copy_table($target,$table);
}
}
sub copy_table {
## Purpose:
## Copy a table by name from one database to another
my($self,$target,$table_name) = @_;
my($sql) = "select * from $table_name";
my($dbh) = $self->{dbh};
my($sth) = $dbh->prepare($sql);
$sth->execute();
my(@quote_field) = @{$sth->{'TYPE'}};
$sth->finish();
my(@retarray);
if ($self->{dbh}->errstr) {
die("Connection::DBI::copy_table failed on sql\n\t$sql\nwith error\n\t" .
$self->{dbh}->errstr);
} elsif ($sth->rows > 0) {
# DBI::dump_results($sth);
my($delete_sql) = "delete from $table_name";
print "$delete_sql;\n";
$target->{dbh}->do($delete_sql);
my $r_array;
my($last_field) = scalar(@quote_field) - 1;
# print "last_field = $last_field = @quote_field\n";
while ($r_array = $sth->fetchrow_arrayref()) {
my (@insert);
foreach $field_no (0..$last_field) {
my($val) = ($quote_field[$field_no] != 23)
? $target->{'dbh'}->quote($$r_array[$field_no])
: $$r_array[$field_no];
if (! defined($val)) {
$val = " NULL";
}
if ($val =~ m/^\s*$/) {
$val = ' NULL';
}
push(@insert,$val);
}
my($insert_sql) = "insert into $table_name values ("
. join(", ",@insert) . ")";
$_ = substr($insert_sql,0,60);
chomp();
print "$_\n";
# print "$insert_sql\n";
$target->{'dbh'}->do($insert_sql);
if ($target->{dbh}->errstr()) {
die("Connection::DBI::copy_table failed on sql\n\t$insert_sql\nwith error\n\t"
. $target->{dbh}->errstr);
}
}
}
}
sub _init_reln_ids{ # Connection::DBI
my($self) = @_;
my($ra_relns) = ['DIRECT-TYPE','DIRECT-SUPER','DIRECT-INCLUDE',
'CONTAINS-FRAME'];
my(%h_ids) = ();
my($i);
my($sql,$reln_id,$reln);
for ($i=0;$i_single_valued_query($sql);
$h_ids{$reln} = $reln_id;
}
$self->{'h_reln_id'} = \%h_ids;
}
sub _record_exists { # Connection::DBI
my($self,$sql) = @_;
my($sth) = $self->{dbh}->prepare($sql);
$sth->execute();
# print "sql\n\t$sql\n";
# print "sth = $sth\n sth->rows = " . $sth->rows . "\n\n";
my($retval) = undef();
return ($sth->rows > 0);
}
sub _single_valued_query { # Connection::DBI
my($self,$sql) = @_;
my($sth) = $self->{dbh}->prepare($sql);
$sth->execute();
# print "_single_valued_query\n sth = $sth\n sth->rows = " . $sth->rows . "\n $sql \n";
my($retval) = undef();
if ($self->{dbh}->errstr) {
die("single_valued_query failed on sql\n\t$sql\nwith error\n\t" . $self->{dbh}->errstr);
} elsif ($sth->rows > 0) {
$retval = ${$sth->fetchrow_arrayref()}[0];
}
$sth->finish();
return $retval;
}
sub _single_column_query { # Connection::DBI
## Purpose:
## Return an array of the values returned in the first column
## produced by the $sql query.
my($self,$sql) = @_;
my($sth) = $self->{dbh}->prepare($sql);
$sth->execute();
my(@retarray);
# FIXME we should just get the column value rather than the whole array
if ($self->{dbh}->errstr) {
die("_single_column_query failed on sql\n\t$sql\nwith error\n\t" .
$self->{dbh}->errstr);
} elsif ($sth->rows > 0) {
my $r_array;
while ($r_array = $sth->fetchrow_arrayref()) {
push(@retarray,${$r_array}[0]);
}
}
$sth->finish();
return @retarray;
}
sub _fetch_all_instances_of_class { # Connection::DBI
## Purpose:
## Read in all the frames within $kb which are instances of
## the type given by type_code.
my($self,$class,$kb) = @_;
my($dbh) = $self->{dbh};
my($direct_type) = $self->{'h_reln_id'}->{'DIRECT-TYPE'};
my($class_id) = $class->id();
my($kb_id) = $kb->id();
my($sql) = "select frame.* from frame,reln" .
" where targ_id = $class_id" .
" and reln_id = $direct_type" .
" and src_id = frame_id" .
" and kb_id = $kb_id";
# print "$sql\n";
$self->_retrieve_frames_by_sql($kb,$sql);
}
sub _fetch_all_instances_of_type { # Connection::DBI
## Purpose:
## Read in all the frames within $kb which are instances of
## the type given by type_code.
my($self,$type_code,$kb) = @_;
my($dbh) = $self->{dbh};
my($sql) = "select * from frame " .
" where kb_id = " . $kb->id() .
" and type = " . $dbh->quote($type_code);
# print "$sql\n";
$self->_retrieve_frames_by_sql($kb,$sql);
}
sub _fetch_all_subclasses_of_class { # Connection::DBI
## Purpose:
## Read in all the frames within $kb which are subclasses of
## the $class within the kb.
my($self,$class,$kb) = @_;
my($dbh) = $self->{dbh};
my($direct_type) = $self->{'h_reln_id'}->{'DIRECT-SUPER'};
my($class_id) = $class->id();
my($kb_id) = $kb->id();
my($sql) = "select frame.* from frame,reln" .
" where targ_id = $class_id" .
" and reln_id = $direct_type" .
" and src_id = frame_id" .
" and kb_id = $kb_id";
# print "$sql\n";
$self->_retrieve_frames_by_sql($kb,$sql);
}
sub frame_in_kb_p_internal { # Connection::DBI
## Purpose:
## Check the database for a frame in the kb.
## Assumptions:
## All the named parameters are specified in the input.
my($self,$name,$kb_id,$kb) = @_;
die("frame_in_kb_p_internal($name) dying ") if (!$kb_id);
my($sql) = "select kb_id from frame, reln " .
"where name = " . $self->{dbh}->quote($name) .
" and frame_id = reln.targ_id " .
" and reln_id = " .
$self->{'h_reln_id'}->{'CONTAINS-FRAME'} .
" and src_id = $kb_id";
$sql = "select kb_id from frame where name = " .
$self->{dbh}->quote($name) . " and kb_id = $kb_id";
# return &_record_exists($self,$sql);
my($retval) = $self->_single_valued_query($sql);
if (! defined($retval)) {
return 0;
} else {
return $kb;
}
return $retval;
}
sub fetch_record_for_frame_id { # Connection::DBI
## Purpose:
## To obtain the details about a frame based on the frame_id.
## Accepts:
## The frame_id of the frame to fetch the details of.
## Returns:
## A reference to a hash of the values for the record from the frame table.
my($self,$frame_id) = @_;
return $self->_fetchrow_hashref("select * from frame " .
"where frame_id = $frame_id");
}
sub fetch_record_for_frame_in_kb { # Connection::DBI
## Purpose:
## To obtain the details about a frame based on the frame_id.
## Accepts:
## The frame_id of the frame to fetch the details of.
## Returns:
## A reference to a hash of the values for the record from the frame table.
my($self,$frame_name,$kb) = @_;
# my($kb_id) = $kb->id();
return $self->_fetchrow_hashref("select * from frame " .
"where name =" .
$self->{'dbh'}->quote($frame_name)
# . " and kb_id = $kb_id"
);
}
sub select_frames_apply_sub { # Connection::DBI
## Purpose:
## Select frame records from the frame table based on the $sql query.
## Call the subroutine $rsub on each frame's details_href.
## Accepts:
## $sql some sql to perform
## $rsub a ref to a sub to perform on each resultant record
## Returns:
## The error string of the first error.
}
sub _retrieve_frames_by_sql { # Connection::DBI
## Purpose:
## Create all frames found by an sql query.
my($self,$kb,$sql) = @_;
my($dbh) = $self->{dbh};
my($sth) = $dbh->prepare($sql);
$sth->execute();
if ($dbh->errstr) {
die("_retrieve_frames_by_sql failed on sql\n\t$sql\nwith error\n\t" .
$self->{dbh}->errstr);
} elsif ($sth->rows > 0) {
my($details);
while ($details = $sth->fetchrow_hashref()) {
if (! $kb->_frame_in_cache_p($details->{'name'})) {
# the frame is not already in the cache, so
$self->create_frame_from_record($kb,$details);
} else {
print $details->{name}, " is already in cache\n" if $GFP::debug > 19;
}
}
}
$sth->finish();
}
sub flesh_out_frame { # Connection::DBI
## Purpose:
## Fleshes out the $frame with the details in $details
## Accepts:
## $frame a naked frame object
## $details a detail hash ref as returned by fetch_record_for_frame_id
## Returns:
## The fleshed out frame object
## Purpose:
## This constructor creates a frame object from the TIE Canonical
## format documented below.
## Accepts:
## $hr_params A reference to a hash containing keys:
## frame_id An integer containing the storage key for the frame
## name A string containing the name of the record.
## scope Either (C)lass or (I)nstance
## type Either (F)acet, (S)lot, (R)egular, (E)valuation
## frame A multiline record in the TIE_PARSE_FORMAT.
## $kr An instance of a KR subclass, the KR this frame is in.
## Format:
## This is the definition of the TIE_PARSE_FORMAT
## Each line is a 'record'.
## Blank lines are permitted.
## Lines which start with any character other than {FOVTSY#}
## cause a warning and are ignored.
## The records are structured as follows:
## F:::the_name_of_a_Frame
## O:the_name_of_an_Own_slot
## T:the_name_of_a_Template_slot
## V:::the_text_of_a_Value
## # comment text
##
## The data types are:
## STRING|INTEGER|SYMBOL|REAL|BLOB
## The types are:
## (C)lass
## (I)nstance
## (S)lot
## (F)acet
## (K)nowledge Base
## (E)valuation
## (A)nnotation
## The value_id is a real number which can be an integer.
## Example:
## F:C:PERSON
## O:DIRECT_TYPE
## V:SYMBOL:AGENT
## T:NUMBER_OF_LEGS
## V:1:INTEGER:2
my($connection,$frame,$rh_params) = @_;
my($kb) = $frame->kb();
my(@lines) = split /^/m, $$rh_params{frame};
my($r_current_slot); # a ref to the current slot
my($ignore,$type,$name);
my($line_number) = 0;
$frame->{'frame_id'} = $$rh_params{'frame_id'};
# FIXME we should use the following line, not the above line
#$frame->id($$rh_params{'frame_id'});
$frame->dirty(0); # tell the frame it is not dirty
FRAME:
foreach (@lines) {
chomp();
$line_number++;
#print "$_\n";
my($line_type) = (substr $_,0,1);
SWITCH: {
if ($line_type eq 'F') { # this is a FRAME
if ($name) { # hey, this is the second frame record for this frame
last FRAME;
}
($ignore,$type,$name) = split(":",$_,3);
$frame->{'name'} = $name;
$frame->{'type'} = $type;
last SWITCH;
}
if ($line_type eq 'O') { # this is an Own slot
my($ignore,$slot_name) = split(":",$_);
$r_current_slot = OWN_SLOT->create($slot_name);
# add the slot to the hash of own slots
# FIXME should we be using the GFP method: attach_slot()?
$frame->{'own_slots'}->{$slot_name}=$r_current_slot;
last SWITCH;
}
if ($line_type eq 'T') { # this is a Template slot
my($ignore,$slot_name) = split(":",$_,2);
$r_current_slot = TEMPLATE_SLOT->create($slot_name);
# add the slot to the hash of template slots
$frame->{'template_slots'}->{$slot_name}=$r_current_slot;
last SWITCH;
}
if ($line_type eq 'V') { # this is a Value
my($ignore,$value_id,$value_type,$value) = split(":",$_,4);
# add the value to the current slot
print "$value_type\t'",$kb->name() , " ... ",
$frame->name(),"'.'",$r_current_slot->name(),
"'.'$value'\n" if $GFP::debug > 9;
if ($value_type eq 'SYMBOL') {
if ($r_current_slot->{'name'} eq "MEMBER-OF-KB"
|| $r_current_slot->{'name'} eq "DIRECT-INCLUDE"
|| $r_current_slot->{'name'} eq "all-include") {
print " ... skipping adding '$value' to ".
$r_current_slot->name() ."\n"
if $GFP::debug > 9;
# ignore values for this slot
last SWITCH;
}
my(@retval) = GFP::get_frame_in_kb($value,'kb' => $kb);
if ($retval[1]) {
$value = $retval[0];
} else {
my(@dp) = GFP::get_kb_direct_parents('kb' => $kb);
my($dp_list)="";
foreach (@dp) {
$dp_list .= $_->name()."($_) ";
}
print " ... kb " . $kb->name() .
"($kb) has these direct parents: $dp_list\n";
# main::show_parents($kb,$kb->connection());
die(" ... can not get frame '$value' in kb '" . $kb->name() . "'");
}
}
# create_stub_as_needed($value_type,$value)
my($r_value) = VALUE->create($value_id,$value_type,$value);
$r_current_slot->append_value($r_value);
last SWITCH;
}
if ($line_type eq '#') { # this is a comment
last SWITCH;
}
if ($line_type eq '') { # this is an empty line
last SWITCH;
}
# this line will be ignored because it is not a proper record
warn("line number $line_number in ".$frame->name()
." is a hosed record\n\t$_");
}
}
## this seems like the most reasonable place to perform...
## FIXME But it should really be performed in the KB package
## rather than be left up to each backend to remember to do.
$kb->_add_frame_to_class_caches($frame);
$kb->_add_frame_to_subclass_caches($frame);
}
sub create_frame_from_record { # Connection::DBI
## Purpose:
## Create a frame object based on a frame record.
## Accepts:
## $kb the kb to put the frame in
## $record a record with the frame details
my($self,$kb,$details) = @_;
my($type) = $details->{'type'};
# print "type = '$type'\n";
my($frame);
SWITCH: {
if ($type eq 'C ') {
$frame = CLASS->new($details->{name},$kb);
last SWITCH;
}
if ($type eq 'I ') {
$frame = INDIVIDUAL->new($details->{name},$kb);
last SWITCH;
}
if ($type eq 'K ') {
$frame = KB->new($details->{name},$kb,$self);
last SWITCH;
}
if ($type eq 'S ') {
$frame = SLOT_UNIT->new($details->{name},$kb);
last SWITCH;
}
die("create_frame_from_record($details->{'name'}) " .
"has unrecognized type: '$type'");
}
$self->flesh_out_frame($frame,$details);
# die("create_frame_from_record() has failed to do anything");
# $frame->fault_in();
return $frame;
}
sub _fetchrow_hashref { # Connection::DBI
my($self,$sql) = @_;
# print "select_frame\n\t${sql}\n";
my($sth) = $self->{dbh}->prepare($sql);
$sth->execute();
# print "rows = ",$sth->rows,"\n";
if ($sth->rows == 1) { # this is what we are hoping for
my($href) = $sth->fetchrow_hashref();
my($rc) = $sth->finish();
return $href;
} elsif ($sth->rows == 0) { # the specified frame does not exist
return undef;
} else { # for some bizarre reason more than one frame matches
die("too many rows returned: ".$sth->rows);
}
}
sub BOGUS_get_kb_direct_parents { # Connection::DBI
## Purpose:
## Read the direct_parents in from the database, creating KB objects
## as needed.
my $sql="select * from RELN " .
"where SRC_ID = (select FRAME_ID from FRAME )";
return ['one','two','three'];
}
sub get_frame_handle_internal { # Connection::DBI
my($self,$frame_name,$kb_handle) = @_;
return $self->_single_valued_query("select frame_id from frame " .
"where name = " .
$self->{dbh}->quote($frame_name) .
" and kb_id = $kb_handle");
}
sub get_frame_in_kb_internal { # Connection::DBI
my($self,$frame_name,$kb) = @_;
my($kb_handle) = $kb->handle();
print "Connection::DBI::get_frame_in_kb_internal\n" .
"\tframe_name = $frame_name\n" if ($GFP::debug > 9);
#hosed
my($record) = $self->fetch_record_for_frame_in_kb($frame_name,$kb);
my($frame) = $self->create_frame_from_record($kb,$record);
return $frame;
}
#############
## VALUE ##
#############
package VALUE;
sub create { # VALUE
my($pkg,$value_id,$value_type,$value) = @_;
# print "creating ",$value_id,'|',$value_type,'|',$value,"\n";
# The loaded attribute is just a flag indicating whether
# the value is really itself. At this point there are only
# these value types: STRING, INTEGER, REAL, and SYMBOL.
# The only situation where loaded != 1 is when the value_type is
# SYMBOL but the value is not a frame reference.
my($loaded) = 1;
if ($value_type eq 'SYMBOL' && ! ref($value)) {
$loaded = 0;
}
# print "# creating the value $value where loaded = $loaded\n";
return bless({value_id => $value_id,
value_type => $value_type,
value => $value,
loaded => $loaded},
$pkg);
}
sub get_value { # VALUE
my($self) = @_;
return $self->{'value'};
if (!$self->{loaded}) {
if (! $self->load_frame_for_symbol_value()) {
die("failed to read in the frame: ".$self->{value});
}
}
return $self->{value};
}
sub load_frame_for_symbol_value { # VALUE
my($self) = @_;
# print "VALUE->load_frame_for_symbol_value()\n";
# print " self=$self\n";
# print " ", $self->canonicalize() . "\n";
my($r_frame) = KR->get_frame_by_name($self->{value});
if (ref($r_frame) eq 'FRAME') {
$self->{loaded} = 1;
$self->{value} = $r_frame;
}
return $self->{loaded};
}
sub canonicalize { # VALUE
## Purpose:
## Return a canonical version of the value
## Example:
## V:1.2:SYMBOL:PERSON
my($self) = @_;
return "V:"
. $self->{value_id} . ':'
. $self->{value_type} . ':'
. $self->canonicalize_value();
}
sub canonicalize_value { # VALUE
## Purpose:
## If the value_type of this value is SYMBOL and the named frame
## has been loaded then return the name of the associated frame.
## Otherwise return the literal value itself.
my($self) = @_;
if ($self->{value_type} eq 'SYMBOL' && $self->{loaded}) {
return $self->{'value'}->get_frame_name();
} else {
return $self->{'value'};
}
}
############
## SLOT ##
############
## Purpose:
## This is a u.s (in the Cyc sense), that is: the structure on a frame which
## holds the values for a particular named slot. That is in contrast
## with SlotUnit which is the perl package which represents the
## FRAME of type SLOT which exists in the KB.
package UNIT_SLOT;
sub create { # UNIT_SLOT
my($pkg,$name) = @_;
return bless({'name' => $name,
'values' => []},
$pkg);
}
sub name {
my($self) = shift;
return $self->{'name'};
}
sub append_value { # UNIT_SLOT
my($self,$value) = @_;
# print "value = $value\n";
# print "append_value(".$value->canonicalize_value().")\n";
push(@{$self->{'values'}},$value);
}
sub canonicalize { # UNIT_SLOT
## Purpose:
## Dump a slot and all its values in canonical form.
my($self) = @_;
my(@out);
my($r_value);
push(@out,$self->canonical_record_prefix().':'.$self->{'name'});
foreach $r_value (@{$self->{'values'}}) {
push(@out,$r_value->canonicalize());
}
return
# $self->canonical_record_prefix().':'.$self->{name} . "\n" .
join("\n",@out);
}
sub get_values { # UNIT_SLOT
## Purpose:
## Return an array of the values on this slot.
my($self) = @_;
my(@retarray) = ();
my($val);
foreach $val (@{$self->{'values'}}) {
# print "$val\-\>get_value() = ",$val->get_value(), "\n";
push(@retarray,$val->get_value());
}
return @retarray;
}
#####################
## TEMPLATE_SLOT ##
#####################
package TEMPLATE_SLOT;
@ISA = qw(UNIT_SLOT);
sub canonical_record_prefix { return 'T';}
################
## OWN_SLOT ##
################
package OWN_SLOT;
@ISA = qw(UNIT_SLOT);
sub canonical_record_prefix { return 'O';}
return 1;
__END__
__END__
sub BOGUS_select_frame_by_name_and_kb_handle { # Connection::DBI
my($self,$frame_name) = @_;
# print "_select_frame_by_name\($frame_name\)\n";
return $self->_select_frame_using_sql(
"select FRAME,FRAME_ID,NAME from FRAME where NAME = "
. $self->{dbh}->quote($frame_name));
}
sub BOGUS_select_frame_by_frame_id { # Connection::DBI
my($self,$frame_id) = @_;
return $self->_select_frame_using_sql(
"select * from FRAME where FRAME_ID = $frame_id");
}
sub BOGUS_select_frame_using_sql { # Connection::DBI
my($self,$sql) = @_;
# print "select_frame\n\t${sql}\n";
my($sth) = $self->{dbh}->prepare($sql);
$sth->execute();
# print "rows = ",$sth->rows,"\n";
if ($sth->rows == 1) { # this is what we are hoping for
my $hr_params = $sth->fetchrow_hashref();
my($rc) = $sth->finish();
return _extract_frame_details($hr_params,$self);
## $self->_add_frame_to_cache($frame);
return $frame;
# print "rc = $rc\n";
# return 1;
} elsif ($sth->rows == 0) { # the specified frame does not exist
return undef;
} else { # for some bizarre reason more than one frame matches
die("too many rows returned: ".$sth->rows);
}
}
sub create_individual_internal { # Connection::DBI
## Purpose:
## This crude subroutine is a quick and dirty (though fast, safe,
## effective and simple) implementation to just get us started.
## A more elaborate version would be implemented in KB and
## hence be more general, but would require methods like:
## put_instance_types, put_slot_values and friends.
## Accepts:
## (name &key kb direct-types doc own-slots own-facets handle
## pretty-name kb-local-only-p)
## with values structured like:
## own-slots slot specifications are like this:
## ['slot-name',
## [':default', 'default-value'],
## 'slot-value-1',
## slot-value-2-obj]
##
my($self,$name,%param) = @_; # default param are set in GFP
my($kb) = $param{'kb'}; # it will be referenced more than once so...
my($direct_types) =
exists($param{'direct-types'}) ? $param{'direct-types'} : [];
my($own_slots) =
exists($param{'own-slots'}) ? $param{'own-slots'} : [];
my($template_slots) =
exists($param{'template-slots'}) ? $param{'template-slots'} : [];
my($own_facets) =
exists($param{'own-facets'}) ? $param{'own-facets'} : [];
my($template_facets) =
exists($param{'template-facets'}) ? $param{'template-facets'} : [];
# $source_conn->copy_to($target_conn,\%field_types);
## if of frame of this name already exists in this kb then fail
if (! ${GFP::get_frame_in_kb($name,'kb' => $kb,'kb-local-only-p' => 1)}[1]) {
warn("create_individual_internal($name) frame '$name' already exists in kb ".
$kb->name());
return undef();
}
my($frame) = INDIVIDUAL->new($name,$param{'kb'});
# FIXME what is the meaning of kb-local-only-p on put_instance_types?
my($r_current_slot); # the currently active slot
## add the direct-types
my($type);
my($slot_name) = "DIRECT-TYPE";
$r_current_slot = OWN_SLOT->create($slot_name);
$frame->{'own_slots'}->{$slot_name}=$r_current_slot;
my($value_id) = 1;
foreach $type_thing (@$direct_types) {
my($value);
if (ref($type_thing) && scalar($type_thing) =~ m/=/) {
# $type_thing is an object
$value = $type_thing;
}
my(@retval) = GFP::get_frame_in_kb($type_thing,'kb' => $kb);
if ($retval[1]) {
$value = $retval[0];
} else {
die("create_individual_internal() could not get the frame '$type'");
}
$r_current_slot->append_value(VALUE->create($value_id++,'SYMBOL',$value));
}
## add the pretty-name (if it is specified)
if (defined($param{'pretty-name'})) {
my($slot_name) = 'PRETTY-NAME';
$r_current_slot = OWN_SLOT->create($slot_name);
$frame->{'own_slots'}->{$slot_name}=$r_current_slot;
$r_current_slot->append_value(VALUE->create(1,
"STRING",
$param{'pretty-name'}));
}
## add the documentation string (if it is specified)
if (defined($param{'doc'})) {
my($slot_name) = 'DOCUMENTATION';
$r_current_slot = OWN_SLOT->create($slot_name);
$frame->{'own_slots'}->{$slot_name}=$r_current_slot;
$r_current_slot->append_value(VALUE->create(1,
"STRING",
$param{'doc'}));
}
## add the own_slots (other than direct-type)
my($r_slot_spec); # a specification for a slot and its values
foreach $r_slot_spec (@{$param{'own-slots'}}) {
my($slot_name) = shift(@{$r_slot_spec});
my($slot_value);
$r_current_slot = OWN_SLOT->create($slot_name);
$frame->{'own_slots'}->{$slot_name}=$r_current_slot;
my($value_id) = 0;
foreach $slot_value (@{$r_slot_spec}) {
if (ref($slot_value)) { # is it a default value?
my($default_value) = @{$slot_value}[1];
warn("create_individual_internal($name) is ignoring :default values");
} else { # it is a simple slot value
my($value_type);
if (ref($slot_value) && scalar($slot_value) =~ m/=/) {
$value_type = 'SYMBOL';
} else {
warn("create_individual_internal($name) is assuming STRING" .
" is value_type for $slot_value");
$value_type = 'STRING';
}
my($r_value) = VALUE->create($value_id++,$value_type,$slot_value);
$r_current_slot->append_value($r_value);
}
}
}
# be sure that the new frame gets indexed for quick access
$kb->_add_frame_to_class_caches($frame);
# only needed for classes
# $kb->_add_frame_to_subclass_caches($frame);
return $frame;
}
sub _save_frame { # Connection::DBI
## Purpose:
## Save a frame record to the database, affecting at least the
## frame and the reln tables and also the kb table if appropriate.
my($self,$frame) = @_;
my($dbh) = $self->{'dbh'};
my($kb) = $frame->kb();
$dbh->quote();
my($creator) = 0;
my($changer) = 0;
my($created) = 'now';
my($changed) = 'now';
my($frame_id) =
(defined($frame->id()) && $frame->id() > 0)
? $frame->id()
: $self->get_next_frame_id();
my(@raw_values) = ($frame_id, # frame_id
$kb->id(), # kb_id
$frame->name(), # name
$frame->canonicalize(), # frame
$frame->_type_code(), # type
$creator, # creator
$created, # created
$changer, # changer
$changed # changed
);
my($index) = 0;
my(@quote_p) = [];
foreach $raw (@raw_values) {
push(@quoted_value,($quote_p[$index]) ? $dbh->quote($raw) : $raw);
}
my($sql) = 'insert into frame values (' . join(", ",@sql_values) . ')';
}