package TM; use strict; use warnings; require Exporter; use base qw(Exporter); our $VERSION = '1.30'; use Data::Dumper; # !!! HACK to suppress an annoying warning about Data::Dumper's VERSION not being numerical $Data::Dumper::VERSION = '2.12108'; # !!! END of HACK use Class::Struct; use Time::HiRes; use Test::Deep::NoTest; # for eq_deeply use TM::PSI; use Log::Log4perl; Log::Log4perl::init( \ q( log4perl.rootLogger=DEBUG, LOGFILE log4perl.appender.LOGFILE=Log::Log4perl::Appender::File log4perl.appender.LOGFILE.filename=tm.log log4perl.appender.LOGFILE.mode=append log4perl.appender.LOGFILE.layout=PatternLayout log4perl.appender.LOGFILE.layout.ConversionPattern=[%r] %F %L %c - %m%n ) ); our $log = Log::Log4perl->get_logger("TM"); =pod =head1 NAME TM - Topic Maps, Base Class =head1 SYNOPSIS my $tm = new TM (baseuri => 'tm://whatever/'); # empty map # add a midlet (= minimal topic, only identification, no characteristics) # by specifying an internal ID $tm->internalize ('aaa'); # only internal identifier $tm->internalize ('bbb' => 'http://bbb/'); # with a subject address $tm->internalize ('ccc' => \ 'http://ccc/'); # with a subject indicator # without specifying an internal ID (will be auto-generated) $tm->internalize (undef => 'http://ccc/'); # with a subject address $tm->internalize (undef => \ 'http://ccc/'); # with a subject indicator # get rid of midlet(s) $tm->externalize ('tm://whatever/aaa', ...); # add an assertion (association or characteristic) $a = $tm->assert (Assertion->new (type => 'is-subclass-of', roles => [ 'subclass', 'superclass' ], players => [ 'rumsti', 'ramsti' ])); # get rid of assertion(s) $tm->retract ($a->[TM->LID], ...); # extract particular assertions my @as = $tm->retrieve ('id..of...assertion...here'); # find particular assertions my @as = $tm->match_forall (scope => 'tm://whatever/sss'); my @bs = $tm->match_forall (type => 'tm://whatever/ttt', roles => [ 'tm://whatever/aaa', 'tm://whatever/bbb' ]); my @cs = $tm->match_forall (type => 'tm://whatever/is-subclass-of', arole => 'tm://whatever/superclass', aplayer => 'tm://whatever/rumsti', brole => 'tm://whatever/subclass'); my @ds = $tm->match_forall (type => 'tm://whatever/isa' instance=> 'tm://whatever/person'); # perform merging, cleanup, etc. $tm->consolidate; # find full URI of a topic (uhm, midlet) my $mid = $tm->mids ('person'); # returns tm://whatever/person my @mids = $tm->mids ('person', ...) # for a whole list # get all midlets my @ms = $tm->midlets; # taxonomy stuff warn "%-|" if $tm->is_a ($tm->mids ('gw_bush', 'moron')); # what a subtle joke die unless $tm->is_subclass ($tm->mids ('politician', 'moron'); # returns Mr. Spock if Volcans are subclassing Aliens warn "my best friends: ". Dumper [ $tm->instancesT ($tm->mids ('alien')) ]; =head1 ABSTRACT This (monster) class provides read/write access to so-called I maps, i.e. maps which completely can reside in memory. Implementations for non-materialized maps can be derived from it. =head1 DESCRIPTION As it stands, this package implements directly so-called I maps, i.e. those maps which completely reside in memory. Non-materialized and non-materializable maps can be implemented by deriving from this class by overloading one or all of the sub-interfaces. If this is done cleverly, then any application, even a TMQL query processor can operate on non-materialized (virtual) maps in the same way as on materialized ones. The data manipulation interface is very low-level and B exposes internal data structures. As long as you do not mess with the information you get and you follow the API rules, this can provide a convenient, fast, albeit not overly comfortable interface. If you prefer more a TMDM-like style of accessing a map then have a look at L. =head2 Midlets and Maplets To make the data structure as flat as possible, map content is stored in two hashes. One is holding I, i.e. simplified forms of topics and the other contains only I, a simplified form of association. =head3 Maplets Maplets contain the role/player combinations we are so used to. As such they are suitable to represent all associations in a map, including those C and C ones. Each maplets includes its own type and the scope (which is always defined and defaults to the universal scope. Also names and occurrences follow a similar structure, whereby one player is the topic, the other is the literal value. But such maplets also have a type and a scope component. =head3 Midlets Midlets are only the part of a topic which deals with its subject identification, either via a subject locator or any number of subject indicating URIs. That's it. Not quite. As every maplet is also a subject, you will find an entry for each of them there. =head2 Identifiers Of course, L supports the subject locator and the subject indicator mechanism as mandated by the Topic Maps standards. Additionally, though, this package also uses I identifiers to address everything which looks and smells like a topic: associations, names and occurrences. For topics the application (or author) of the topic map will most likely provide these internal identifiers. For the others the identifiers are generated. In any case, all identifiers are I using the C as an absolute URI to resolve against. So, a local identifier C will become C if the base URI of the map were C. The method C helps you in this process. =head2 Consistency An application using a map may expect that a map is I, i.e. that the following consistency conditions are met: =over =item B (fixed on) Every topic appearing in some association as type, role or player is also registered as topic. =item B (fixed on) Every association in the map is also a registered topic. =item B (default: on) Two (or more) topics sharing the same I are treated as one topic. =item B (default: on) Two (or more) topics sharing the same I are treated as one topic. =item B (default: off) Two (or more) topics sharing the same name in the same scope are treated as one topic. =back =cut use constant { Subject_based_Merging => 1, Indicator_based_Merging => 2, TNC_based_Merging => 3, }; =pod While the first two (A1, A2) are related with the internal consistency of the data structure, the others are a choice the application can make. See method C. This consistency is not automatically provided when a map is modified by the application. It is the applications responsibility to trigger the process to consolidate the map. When an IO driver is consuming a map from a resource (say loading from an XTM file), then that driver will ensure that the map is consolidated according to the current settings before it is handed to the application. The application is then in full control of the map as it can change, add and delete topics and associations. This implies that that can become unconsolidated in this process. The method C reinstates consistency again. You can change these defaults by (a) providing an additional option to the constructor new TM (...., consistency => [ TM->Subject_based_Merging, TM->Indicator_based_Merging ]); or (b) by using the accessor C (see below). =head1 INFRASTRUCTURE INTERFACE =head2 Constructor The constructor will create an empty map, or, to be more exact, it will fill the map with the taxonomy from L which covers basic concepts such as I or I. The constructor understands a number of key/value pair parameters: =over =item C (default: C) Every item in the map has an unique local identifier (e.g. C). The C parameter controls how an absolute URI is built from this identifier. =item C (default: [ Subject_based_Merging, Indicator_based_Merging ]) =item C =back If you need to roll your own taxonomy to bootstrap with, you can pass in a structure which has exactly the same structure as that in L. =cut sub new { my $class = shift; my %self = @_; $self{consistency} ||= [ Subject_based_Merging, Indicator_based_Merging ]; $self{baseuri} ||= 'tm://nirvana/'; $self{baseuri} .= '#' unless $self{baseuri} =~ m|[/\#:]$|; my $self = bless \%self, $class; unless ($self->{mid2iid}) { # we need to do fast cloning of basic vocabulary use TM::PSI; my $psis = $self{psis} || $TM::PSI::topicmaps; my $mids = $psis->{mid2iid}; my $bu = $self->{baseuri}; # now create low-level TM content via fast cloning $self->{mid2iid} = { map { $bu.$_ => [ undef, [ @{$mids->{$_}} ] ] } keys %{$mids} }; $self->{usual_suspects} = { map { $_ => mids ($self, $_) } @TM::PSI::Usual_Suspects }; assert ($self, map { Assertion->new (type => $_->[0], roles => [@{$_->[1]}], # here we clone the roles/player list players => [@{$_->[2]}])} @{$psis->{assertions}} ); delete $self{psis}; # we do not need it anymore } $self->{last_mod} = 0; # book keeping $self->{created} = Time::HiRes::time; return $self; } sub DESTROY {} # not much to do here =pod =head2 Methods =over =item B I<$bu> = I<$tm>->baseuri This methods retrieves/sets the base URI component of the map. This is a read-only method. The base URI is B defined. =cut sub baseuri { my $self = shift; return $self->{baseuri}; } =pod =item B I<@merging_constraints> = I<$tm>->consistency I<$tm>->consistency (I<@list_of_constants>) This method provides read/write access to the consistency settings. If no parameters are provided, then the current list of consistency settings is returned. If parameters are provided, that list must consist of the constants defined above (see L). B: Changing the consistency does B automatically trigger C. =cut sub consistency { my $self = shift; my @params = @_; $self->{consistency} = [ @params ] if @params; return @{$self->{consistency}}; } =pod =item B Returns the UNIX date of last modifying the map content. This comes as a L time. =cut sub last_mod { my $self = shift; return $self->{last_mod}; } =pod =item B I<$tm>->consolidate This method I a map by performing the following actions: =over =item * perform merging based on subject address (see TMDM section 5.3.2) =item * perform merging based on subject indicators (see TMDM section 5.3.2) =item * remove all superfluous midlets (those which do not take part in any association) B: Not implemented yet! =back The optional parameter is a list of constants, all of which are defined in L. If the list is empty, then the consistency of the map will be used, otherwise the consistency as defined with this list will override. B: In all cases the map will be modified. B: After merging some of the I might not be reliably point to a topic. =cut # NOTE: Below there much is done regarding speed. First the toplets are swept detecting which have # to be merged. This is not done immediately (as this is an expensive operation), instead a 'merger' hash # is built. Note how merging information A -> B and A -> C is morphed into A -> B and B -> C using # the _find_free function. # That merger hash is then consolidated by following edges until their end, so that there are no # cycles. sub consolidate { my $self = shift; my $cons = @_ ? [ @_ ] : $self->{consistency}; # override my $indi = grep ($_ == Indicator_based_Merging, @{$self->{consistency}}); my $subj = grep ($_ == Subject_based_Merging, @{$self->{consistency}}); my $tnc = grep ($_ == TNC_based_Merging, @{$self->{consistency}}); #warn "cond indi $indi subj $subj tnc $tnc"; my %SIDs; # holds subject addresses found my %SINs; # holds subject indicators found my %BNs; # holds basename + scope found #warn Dumper $cons; #== find merging points and memorize this in mergers ======================================================================= my %mergers; # will contain the merging edges my $mid2iid = $self->{mid2iid}; # shortcut MERGE: foreach my $this (keys %{$mid2iid}) { #warn "looking at $this"; my $thism = $mid2iid->{$this}; #warn "SIDs: ". Dumper \%SIDs; #warn "SINs: ". Dumper \%SINs; #-- based on subject indication ------------------------------------------------------------------------------------------ if ($indi) { foreach my $sin (@{$thism->[TM->INDICATORS]}) { # walk over the subject indicators if (my $that = $SINs{$sin}) { # $that is now a key pointing to a merging partner #warn "merging (IND) $this >> $that"; #. Dumper $thism, $thatm; $mergers{_find_free ($this, \%mergers)} = $that; sub _find_free { my $this = shift; my $mergers = shift; my $this2 = $this; my $this3; while ($this3 = $mergers->{$this2}) { if ($this3 eq $this || $this3 eq $this2) { # loop, we do not need it return $this3; } else { $this2 = $this3; # we follow the trail } } return $this2; # this2 was the end of the trail } } else { # no merging, so enter the sins $SINs{$sin} = $this; } } } #-- based on subject address --------------------------------------------------------------------------------------------- if ($subj) { if (my $sid = $thism->[TM->ADDRESS]) { if (my $that = $SIDs{$sid}) { # found partner => should be merged #warn "merging (ADDR) $this >> $that"; $mergers{_find_free ($this, \%mergers)} = $that; # must obviously both have the same subject address, so, no reason to touch this } else { # there is no partner, first one with this subject address $SIDs{$sid} = $this; } } } #warn "after TM->ADDRESS on '$this' ";#.Dumper $mid2iid; } #-- based on TNC --------------------------------------------------------------------------------------------- if ($tnc) { my ($THING, $VALUE) = @{$self->{usual_suspects}}{'thing', 'value'}; foreach my $a (values %{$self->{assertions}}) { next unless $a->[TM->KIND] == TM->NAME; # we are only interested in basenames #warn "checking assertion ".Dumper $a; my ($v) = get_x_players ($self, $a, $VALUE); # if we get back a longer list, bad luck my $bn_plus_scope = $v->[0] . # the basename is a string reference $a->[TM->SCOPE]; # relative to the scope my ($this) = get_x_players ($self, $a, $THING); # thing which plays 'topic' #warn " --> player is $this"; if (my $that = $BNs{$bn_plus_scope}) { # if we have seen it before #warn " -> SEEN"; $mergers{_find_free ($this, \%mergers)} = $that; } else { # it is new to use, we store it into %BNs #warn " -> NOT SEEN"; $BNs{$bn_plus_scope} = $this; #warn "BNs ".Dumper \%BNs; } } } #== consolidate mergers: no cycles, trail followed through ====================================================== #warn "mergers ".Dumper \%mergers; for (2..2) { # at most 2, theoretical only one should be sufficient my $changes = 0; foreach my $h (keys %mergers) { #warn "working on $h"; if ($mergers{$h} eq $h) { # micro loop delete $mergers{$h}; } elsif (defined $mergers{$mergers{$h}} && $mergers{$mergers{$h}} eq $h) { delete $mergers{$h}; } else { my $h2 = $mergers{$h}; my %seen = ($h => 1, $h2 => 1); # loop avoidance #warn "seeen start".Dumper \%seen; while ($mergers{$h2} and !$seen{$mergers{$h2}}++) { $h2 = $mergers{$h} = $mergers{$h2}; $changes++;} #warn "half consolidated (chagens $changes)" .Dumper $H; } } # warn "consoli loop $_: changes: $changes"; warn "early finish" if $_ == 1 and $changes == 0; last if $changes == 0; # die "not clean" if $_ == 2 and $changes > 0; } #warn "consolidated mergers ".Dumper \%mergers; #== actual merging ======================================================================================== foreach my $that (keys %mergers) { my $this = $mergers{$that}; my $thism = $mid2iid->{$this}; my $thatm = $mid2iid->{$that}; # shorthand next if $thatm == $thism; # we already have merged $log->logdie ("two different subject addresses for two topics to be merged ($this, $that)") if $thism->[TM->ADDRESS] and $thatm->[TM->ADDRESS] and $thism->[TM->ADDRESS] ne $thatm->[TM->ADDRESS]; #warn "merge now $that > $this"; $thism->[TM->ADDRESS] ||= $thatm->[TM->ADDRESS]; # first subject address, then indicators push @{$thism->[TM->INDICATORS]}, @{$thatm->[TM->INDICATORS]}; $mid2iid->{$that} = $thism; } #warn "after post-merger ". Dumper $mid2iid; $self->{mid2iid} = $mid2iid; # this makes tie happy, in the case the map is tied $self->{last_mod} = Time::HiRes::time; } =pod =item B I<$tm>->add (I<$tm2>, ...) This method accepts a list of L objects and adds all content (associations and topics) from these maps. B: There is B merging done. Use explicitly method C for it. =cut sub add { my $self = shift; #warn "store add". Dumper \@_; foreach (@_) { # deal with one store after the other while (my ($k, $v) = each %{$_->{assertions}}) { $self->{assertions}->{$k} = $v; # there should not be any conflicts, using MD5 hashes over type/scope/roles/players should be good enough } my $mid2iid = $self->{mid2iid}; # shorthand while (my ($k, $v) = each %{$_->{mid2iid}}) { if (! $mid2iid->{$k}) { # we had no entry here => simply... $mid2iid->{$k} = $v; # ...add what the other has } else { # same internal identifier? danger lurking... if (!$v->[0]) { # new had undef there, leave what we have } elsif (!$mid2iid->{$k}->[0]) { # old had nothing, => $mid2iid->{$k}->[0] = $v->[0]; # copy it } elsif ($mid2iid->{$k}->[0] eq $v->[0]) { # old had something and new has something and they are the same # leave it } else { # not good, subject addresses differ $log->logdie ("using the same internal identifier '$k', but different subject addresses (".$mid2iid->{$k}->[0].",".$v->[0].") is not good (change the baseuri of one map)"); } push @{$mid2iid->{$k}->[1]}, @{$v->[1]}; # simply add all the subject indication stuff } } } $self->{last_mod} = Time::HiRes::time; } =pod =item B I<$diff> = $tm->diff($oldmap) I<$diff> = TM::diff($newmap, $oldmap) I<$diff> = TM::diff($newmap, $oldmap, {consistency=>[TM->Subject_based_Merging], include_changes=>1}) diff compares two topicmaps and returns their differences as a hash reference. If diff is used in OO-style, the current map is interpreted as the new map and the map in the arguments as the old one. The function honours the options I and I. For any changes, the midlet and assertion identifiers are returned by default; the option include_changes causes the return of the actual midlets and assertions themselves. The option makes diff's output more self-contained: with the option enabled, one can fully (re)create the new map from the old one plus the diff (and vice versa). The consistency parameter uses the same format as the TM constructor (see L) and describes how corresponding topics in the two maps are to be identified. Topics with the same topic ids are always considered equal. If Subject based consistency is active, topics with the same Subject Locator are considered equal (overriding the topic identities). If Indicator based consistency is active, topics with a matching Subject Indicator are considered equal (overriding the previous identities). Note that this overriding of previous conditions for identity is necessary to keep the equality relationship unique and one-to-one. As an example, consider the following scenario: a topic I in the old map is split into multiple new topics I and I in the new map. If I had a locator or identifier that is moved to I (and if consistency options are active), then the identity detector will consider I to be equal to I, and B I in the new map to correspond to I in the old map. However, this will never lead to loss of information: I in the new map is flagged as completely new topic. The differences between old and new map are returned beneath the keys I, I, I and I. If include_changes is on, the extra keys I, I and I are defined. The values of all these keys are hashes themselves. =over =item I, I The plus and minus hashes list new or removed topics, respectively (with their midlet identifiers as keys). For each topic, the value if the hash is an array of associated assertion ids. The array is empty but defined if there are no associated assertions. For 'normal' topics the attached assertions are the usual ones (names, occurrences) and class-instance relationships (attached to the instance topic). For associations, the assertions are attached to the type topic. =item I This hash consists of the non-trivial topic identities that were found. If neither Subject- nor Indicator-based merging is active, then this hash is empty. Otherwise, the keys are topic identifiers in the old map, with the corresponding topic identifier in the new map as value. =item I The modified hash contains the changes for matched topics. The key is the topic identifier in the old map (which is potentially different from the one in the new map; see identities above). The value is a hash with three keys: I, I and I. The value for the identities key is defined if and only if the midlet associated with this topic has changed (i.e. Subject Locator or Indicators have changed). The values for the plus and minus keys are arrays with the new or removed assertions that are attached to this topic. These arrays are defined but empty where no applicable information is present. =item I, I These hashes hold the actual new or removed midlets if the option include_changes is active. Keys are the midlet ids, values are references to the actual midlet datastructures. =item I This hash holds the actual assertions where the maps differ; it exists only if the option include_changes is active. Keys are the assertion identifiers, values the references to the actual assertion datastructures. Note that assertion ids uniquely identify the assertion contents, therefore this hash can hold assertions from both new and old map. =back =cut sub diff { my ($newmap,$oldmap,$options)=@_; return undef if (!$oldmap || !$newmap); my (%plus,%minus,%modified); # a lot of comparison/translation can be skipped if tids are the only identity my $xlatneeded= grep($_==TM->Subject_based_Merging || $_==TM->Indicator_based_Merging,@{$options->{consistency}}); my ($base)=$oldmap->baseuri; $log->logdie ("comparison of maps with different bases not supported yet!") if ($newmap->baseuri ne $base); # first walk the maps to match old and new items my (%seen,%locators,%indicators); for my $map ($oldmap,$newmap) { my $key=($map eq $oldmap?"old":"new"); my $value=($map eq $oldmap?1:2); for my $m ($map->midlets(\ '+all')) { # get the topic-aspects (tid, locators and identifiers) # for finding unchanged/new/old topics my $midlet=$map->midlet($m); $locators{$key}->{$midlet->[TM->ADDRESS]}=$m if ($midlet->[TM->ADDRESS]); map { $indicators{$key}->{$_}=$m } (@{$midlet->[TM->INDICATORS]}); $seen{$m}|=$value; } } # identify same topics # first identity: same topic ids my %old2new = map { ($_,$_) } (grep($seen{$_}==3,keys %seen)); my $foundxlat; if (grep($_==TM->Subject_based_Merging,@{$options->{consistency}})) { # second: same locators # note that this overwrites topic identitites! # scenario: old has topica/loc x; new has topica/no loc and topicb/loc x map { $foundxlat||=($locators{old}->{$_} ne $locators{new}->{$_}); $old2new{$locators{old}->{$_}}=$locators{new}->{$_}; } (grep(exists $locators{new}->{$_}, keys %{$locators{old}})); } if (grep($_==TM->Indicator_based_Merging,@{$options->{consistency}})) { # final: matching indicators # note that this overwrites topic and locator identitites, similar scenario as above map { $foundxlat||=($indicators{old}->{$_} ne $indicators{new}->{$_}); $old2new{$indicators{old}->{$_}}=$indicators{new}->{$_}; } (grep(exists $indicators{new}->{$_}, keys %{$indicators{old}})); } # no need to bother with translating assertions if there are no changed-tid identities $xlatneeded=0 if ($xlatneeded && !$foundxlat); # produce list of missing/new topics my %new2old=($xlatneeded?(reverse %old2new):%old2new); my (%checkmidlet,%plusass,%minusass); for my $t (keys %seen) { if ($seen{$t}==2 && !$new2old{$t}) { $newmap->retrieve($t)?$plusass{$t}=1:$plus{$t}=[]; } elsif ($seen{$t}==1 && !$old2new{$t}) { $oldmap->retrieve($t)?$minusass{$t}=1:$minus{$t}=[]; } else { # we work along the old tids (when not the same) $checkmidlet{$seen{$t}==2?$new2old{$t}:$t}=1; } } undef %seen; undef %locators; undef %indicators; # weed out the topics/midlets that are unchanged # and all the identical assertions my @checkassertion; for my $t (keys %checkmidlet) { if (!eq_deeply($oldmap->midlet($t), $newmap->midlet($old2new{$t}))) { $modified{$t}->{identities}=1; $modified{$t}->{plus}||=[]; $modified{$t}->{minus}||=[]; } my $oa=$oldmap->retrieve($t); my $on=$newmap->retrieve($old2new{$t}); if ($oa && $on && !eq_deeply($oa,$on)) { push @checkassertion,$t; } } my %old2newid; if ($xlatneeded) { # now do the translation for assertions: rebuild old assertions # into new namespace and compute the id # don't waste time: do this only on the assertions that may be required for my $t (@checkassertion,keys %minusass) { my $m=$oldmap->retrieve($t); my ($lid,$scope,$kind,$type,$roles,$players)= @{$m}[TM->LID,TM->SCOPE,TM->KIND,TM->TYPE,TM->ROLES,TM->PLAYERS]; # if any of the topics is untranslatable, then skip the remaining work # as it can't successfully compare anyway... $scope=$old2new{$scope} || next; $type=$old2new{$type} || next; my @newroles = map { ref($_)?$_:$old2new{$_} || next; } (@{$roles}); my @newplayers = map { ref($_)?$_:$old2new{$_} || next; } (@{$players}); my $n=Assertion->new(scope=>$scope, kind=>$kind, type=>$type, roles=>\@newroles,players=>\@newplayers); $newmap->canonicalize($n); my $newid=$base.TM::hash($n); $old2newid{$t}=$newid; if ($plusass{$newid}) { delete $plusass{$newid}; delete $minusass{$t}; } } } # finally, find and attach the modified assertions to their topics # attributes: to the topic # associations: to the type-topic for my $key ("plus","minus") { my ($unmodified,$map,$candidates); if ($key eq "plus") { $unmodified=\%plus; $map=$newmap; $candidates=\%plusass; } else { $unmodified=\%minus; $map=$oldmap; $candidates=\%minusass; } for my $t (keys %{$candidates}) { my $m=$map->retrieve($t); my ($oldwho,$who,$what); if ($m->[TM->KIND] ne TM->ASSOC) { # bn or oc: attach to referenced topic $who=($map->get_x_players($m,$base."thing"))[0]; $what=$t; } elsif ($m->[TM->TYPE] eq $base."isa") { # isa associations get attached to the instance topic $who=($map->get_x_players($m,$base."instance"))[0]; $what=$t; } else { # general assoc: gets attached to type topic $who=$m->[TM->TYPE]; $what=$t; } # if this assertion belongs to a topic that is marked gone/new, we save it with that topic if ($unmodified->{$who}) { push @{$unmodified->{$who}},$what; } else # if this belongs to a modified topic: more details please (new/old ass) { # we access things along the old id axis... if ($key eq "plus") { $who=$new2old{$who}; } $modified{$who}->{$key}||=[]; push @{$modified{$who}->{$key}},$what; } } } my %identities; map { $identities{$_}=$old2new{$_} if ($_ ne $old2new{$_}); } (keys %old2new); my $returnvalue={ 'identities'=>\%identities, 'plus'=>\%plus, 'minus'=>\%minus, 'modified'=>\%modified, }; # pull in the midlets and assertions that have been affected, # so that the resulting datastructure can be frozen and used together with oldmap # to (re)create newmap if ($options->{include_changes}) { # one problem, though is naming: midlets can have changed but their name doesn't # reflect that: we need two midlet datastructures here. # (assertions are fine, their names always reflect their content uniquely) my (%plusm,%minusm,%ass,$a); map { $plusm{$_}=$newmap->midlet($_); $a=$newmap->retrieve($_) and $ass{$_}=$a; } (keys %plus); map { $minusm{$_}=$oldmap->midlet($_); $a=$oldmap->retrieve($_) and $ass{$_}=$a; } (keys %minus); for my $k (keys %modified) { # these are corresponding topics with differing midlet (contents) if ($modified{$k}->{identities}) { $plusm{$k}=$newmap->midlet($old2new{$k}); $minusm{$k}=$oldmap->midlet($k); } map { $plusm{$_}=$newmap->midlet($_); $a=$newmap->retrieve($_) and $ass{$_}=$a; } (@{$modified{$k}->{plus}}); map { $minusm{$_}=$oldmap->midlet($_); $a=$oldmap->retrieve($_) and $ass{$_}=$a; } (@{$modified{$k}->{minus}}); } $returnvalue->{plus_midlets}=\%plusm; $returnvalue->{minus_midlets}=\%minusm; $returnvalue->{assertions}=\%ass; } return $returnvalue; } =pod =item B I<$tm>->melt (I<$tm2>) This - probably more auxilary - function copies relevant aspect of a second map into the object. =cut our @ESSENTIALS = qw(mid2iid assertions baseuri usual_suspects variants); sub melt { my $self = shift; my $tm2 = shift; @{$self}{@ESSENTIALS} = @{$tm2}{@ESSENTIALS}; $self->{last_mod} = Time::HiRes::time; } =pod =back =head1 MANIPULATION INTERFACE This package provides a low-level implementation of a memory-based assertion store. The assertions are stored together with some hash information to speed up particular access patterns. It is designed to hold a significant amount of information in pure-Perl representation in memory. It is a also a prime candidate to be implemented in C later. All changes to the store are immediate; there is no transaction concept at this level. The whole map consists of two components: An assertion holds association information, occurrence attachments to topics and name attachments to topics. Subject identifiers and one (!) subject locator is kept in a minimalistic topic. Every assertion is ALSO a topic. On this level you can modify each component individually giving you much freedom and direct access to the map structure. Needless to say, that you can shoot yourself into the knee. =head2 Identifiers All identifiers which are passed into methods here MUST be absolute URIs. This interface makes no attempt to I identifiers. The URIs are kept as strings, not L objects. =head2 Assertions One assertion is a record containing its own identifier, the scope, the type of the assocation, a (redundant) field whether this is an association, an occurrence or a name and then all roles and all players, in separate lists. These lists B have the same length, so that every player corresponds to exactly one role. If one role is played by several players, the role appears multiple times. These lists are also canonicalized, i.e. ordered in such a way, that assertions can be compared. To flag that an assertion is canonicalized there is another field in the assertion record. =cut struct 'Assertion' => [ lid => '$', scope => '$', type => '$', kind => '$', # argh roles => '$', players => '$', canon => '$', ]; # indices into this array for fast access use constant { LID => 0, SCOPE => 1, TYPE => 2, KIND => 3, ROLES => 4, PLAYERS => 5, CANON => 6 }; =pod Assertions consist of the following components: =over =item C: Every assertion is also a thing in the map, so it has an identifier. For midlet-related information this is the absolute topic ID, for maplets this is a unique identifier generated from a canonicalized form of the assertion itself. =item C: Yes, the scope of the assertion. =item C (redundant information): For technical reasons (read: it is faster) we distinguish between full associations (C), and characteristics (C, C). =cut # values for 'kind' use constant { ASSOC => 0, NAME => 1, OCC => 2, }; =pod =item C: The topic ID of the type of this assertion. =item C: A list reference which holds a list of topic IDs for the roles. =item C: A list reference which holds a list of topic IDs for the players. =item C: Either C<1> or undef to signal whether this assertion has been (already) canonicalized (see L). =back =head2 Assertion Construction Functions These lowest-level functions deal with housekeeping functions for assertions. =over =item Constructor I<$assertion> = Assertion->new (...) Any of the above fields can be defined. =item B I<$assertion> = absolutize (I<$tm>, I<$assertion>) This method takes one assertion and makes sure that all identifiers in it (for the type, the scope and all the role and players) are made absolute for the context map. It returns this very assertion. =cut sub absolutize { my $self = shift; my $a = shift; return $a if $a->[CANON]; # skip it if we are already canonicalized #warn "in abosl ".Dumper $a; $a->[TYPE] = mids ($self, $a->[TYPE]) if $a->[TYPE]; $a->[SCOPE] = mids ($self, $a->[SCOPE]) if $a->[SCOPE]; map { $_ = mids ($self, $_) } @{$a->[ROLES]} if $a->[ROLES]; # things which are references, we will keep map { $_ = ref ($_) ? $_ : mids ($self, $_) } @{$a->[PLAYERS]} if $a->[PLAYERS]; # the others are treated as ids (could be literal references!) #warn "after abosl ".Dumper $a; return $a; } =pod =item B I<$assertion> = canonicalize (I<$tm>, I<$assertion>) This method takes an assertion and reorders the roles (together with their respective players) in a consistent way. It also makes sure that the KIND is defined (defaults to C), that the type is defined (defaults to C) and that all references are made absolute LIDs. Finally, the field C is set to 1 to indicate that the assertion is canonicalized. The function will not do anything if the assertion is already canonicalized. The component C is set to C<1> if the assertion has been canonicalized. Conveniently, the function returns the same assertion, albeit a maybe modified one. =cut sub canonicalize { my $self = shift; # my $LIDs = $store->{si}; # my $base = $store->{baseuri}; my $s = shift; #warn "in canon ".Dumper $s; #warn "using LIDs ".Dumper $LIDs; return $s if $s->[CANON]; # skip it if we are already canonicalized # reorder role/players canonically my $rs = $s->[ROLES]; my $ps = $s->[PLAYERS]; my @reorder = (0..$#$ps); # create 0, 1, 2, ..., how many roles #warn @reorder; # sort according to roles (alphanum) and at ties according to players on position $a, $b @reorder = sort { $rs->[$a] cmp $rs->[$b] || $ps->[$a] cmp $ps->[$b] } @reorder; #warn @reorder; $s->[ROLES] = [ map { $rs->[$_] } @reorder ]; $s->[PLAYERS] = [ map { $ps->[$_] } @reorder ]; # we are done (almost) $s->[CANON] = 1; #warn "in canon return ".Dumper $s; return $s; } =pod =item B I<$hash> = hash (I<$assertion>); For internal optimization all characteristics have an additional HASH component which can be used to maintain indices. This function takes a assertion and computes an MD5 hash and sets the C component if that is not yet defined. Such a hash only makes sense if the assertion is canonicalized, otherwise an exception is raised. Example: my $a = Assertion->new (lid => 'urn:x-rho:important'); print "this uniquely (well) identifies the assertion ". hash ($a); =cut sub hash { my $a = shift; $log->logdie ("refuse to hash non canonicalized assertion") unless $a->[CANON]; use Digest::MD5 qw(md5_hex); return md5_hex ($a->[SCOPE], $a->[TYPE], @{$a->[ROLES]}, map { ref ($_) ? join ("", @$_) : $_ } @{$a->[PLAYERS]}); # recompute the hash if necessary # ^^^^^^^^^^^^^^ # this is a literal value # ^^ # this is for a normal identifier } =pod =back =head2 Assertion Role Retrieval =over =item B, B I<$bool> = is_player (I<$tm>, I<$assertion>, I<$player_id>, [ I<$role_id> ]) I<$bool> = is_x_player (I<$tm>, I<$assertion>, I<$player_id>, [ I<$role_id> ]) This function returns C<1> if the identifier specified by the C parameter plays any role in the assertion provided as C parameter. If the C is provided as third parameter then it must be exactly this role (or any subclass thereof) that is played. The 'x'-version is using equality instead of 'subclassing' ('x' for "exact"). =cut sub is_player { my $self = shift; my $m = shift; # warn "is_player ".Dumper \@_; # warn "caller: ". Dumper [ caller ]; # foreach (0..0) { # warn " ".join (' ---- ', caller($_)); # } my $p = shift;# or die "must specify valid player: ".Dumper ([ $m ])." and role is ".shift; # # warn "after shifting player '$p'"; my $r = shift; # may be undefined $log->logdie ("must specify a player '$p' for role '$r'") unless $p; if ($r) { my ($ps, $rs) = ($m->[PLAYERS], $m->[ROLES]); for (my $i = 0; $i < @$ps; $i++) { next unless $ps->[$i] eq $p; next unless $self->is_subclass ($rs->[$i], $r); return 1; } } else { return 1 if grep ($_ eq $p, @{$m->[PLAYERS]}); } return 0; } sub is_x_player { my $self = shift; my $m = shift; my $p = shift or $log->logdie ("must specify x-player: ".Dumper ([ $m ])); my $r = shift; # may be undefined if ($r) { my ($ps, $rs) = ($m->[PLAYERS], $m->[ROLES]); for (my $i = 0; $i < @$ps; $i++) { next unless $ps->[$i] eq $p; next unless $rs->[$i] eq $r; return 1; } } else { return 1 if grep ($_ eq $p, @{$m->[PLAYERS]}); } return 0; } =pod =item B, B I<@player_ids> = get_players (I<$tm>, I<$assertion>, [ I<$role_id> ]) I<@player_ids> = get_x_players (I<$tm>, I<$assertion>, I<$role_id>) This function returns the player(s) for the given role. If the role is not provided all players are returned. The "x" version does not honor subclassing. =cut sub get_players { my $self = shift; my $a = shift; my $r = shift; return @{ $a->[PLAYERS] } unless $r; my ($ps, $rs) = ($a->[PLAYERS], $a->[ROLES]); my @ps; for (my $i = 0; $i < @$ps; $i++) { next unless $self->is_subclass ($rs->[$i], $r); push @ps, $ps->[$i]; } return @ps; } sub get_x_players { my $self = shift; my $a = shift; my $r = shift; my ($ps, $rs) = ($a->[PLAYERS], $a->[ROLES]); my @ps; for (my $i = 0; $i < @$ps; $i++) { next unless $rs->[$i] eq $r; push @ps, $ps->[$i]; } return @ps; } =pod =item B, B I<$bool> = is_role (I<$tm>, I<$assertion>, I<$role_id>) I<$bool> = is_x_role (I<$tm>, I<$assertion>, I<$role_id>) This function returns C<1> if the C is a role in the assertion provided. The "x" version of this function does not honor subclassing. =cut sub is_role { my $self = shift; my $m = shift; my $r = shift or $log->logdie ("must specify role: ".Dumper ([ $m ])); return 1 if grep ($self->is_subclass ($_, $r), @{$m->[ROLES]}); } sub is_x_role { my $self = shift; my $m = shift; my $r = shift or $log->logdie ("must specify role: ".Dumper ([ $m ])); return 1 if grep ($_ eq $r, @{$m->[ROLES]}); } =pod =item B I<@role_ids> = get_roles (I<$tm>, I<$assertion>, I<$player>) This function returns a list of roles a particular player plays in a given assertion =cut sub get_roles { my $self = shift; my $a = shift; my $p = shift; # the player my ($ps, $rs) = ($a->[PLAYERS], $a->[ROLES]); my @rs; for (my $i = 0; $i < @$ps; $i++) { next unless $ps->[$i] eq $p; push @rs, $rs->[$i]; } return @rs; } =pod =item B I<@role_ids> = @{ get_role_s (I<$tm>, I<$assertion>) } This function extracts a reference to the list of role identifiers. =cut sub get_role_s { my $self = shift; my $a = shift; return $a->[ROLES]; } =pod =back =head2 Assertion Map Methods =over =item B I<$tm>->assert (I<@list-of-assertions>) This method takes a list of assertions, canonicalizes them and then injects them into the map. If one of the newly added assertions already existed in the map, it will be ignored. In this process, all assertions will be completed (if fields are missing) and will be canonicalized (unless they already were). This implies that non-canonicalized assertions will be modified, in that the role/player lists change. If an assertion does not have a type, it will default to C<$TM::PSI::THING>. If an assertion does not have a scope, it defaults to C<$TM::PSI::US>. Any assertion not having an LID will get one. Examples: my $a = Assertion->new (type => 'rumsti'); $ms->assert ($a); The method returns a list of all asserted assertions (sic). =cut sub assert { my $self = shift; my ($THING, $US) = @{$self->{usual_suspects}}{'thing', 'us'}; #warn "sub $THING assert $self".ref ($self); my $assertions = $self->{assertions}; foreach (@_) { unless ($_->[CANON]) { $_->[KIND] ||= ASSOC; $_->[TYPE] ||= $THING; $_->[TYPE] = $self->internalize ($_->[TYPE] => undef); $_->[SCOPE] ||= $US; $_->[SCOPE] = $self->internalize ($_->[SCOPE] => undef); $_->[ROLES] = [ map { $self->internalize ($_ => undef ) } @{$_->[ROLES]} ]; $_->[PLAYERS] = [ map { $_ = ref ($_) ? $_ : $self->internalize ($_ => undef) } @{$_->[PLAYERS]} ]; $self->canonicalize ($_); $_->[LID] ||= hash ($_); # the LID is either already there, or it will default to a hash over the canonicalized info $_->[LID] = $self->internalize ($_->[LID] => undef); } $assertions->{$_->[LID]} = $_; } $self->{assertions} = $assertions; ##!! needed for Berkeley DBM recognize changes on deeper levels $self->{last_mod} = Time::HiRes::time; return @_; } =pod =item B I<$assertion> = I<$tm>->retrieve (I<$some_assertion_id>) I<@assertions> = I<$tm>->retrieve (I<$some_assertion_id>, ...) This method takes a list of assertion IDs and returns the assertion(s) with the given (subject) ID(s). If the assertion is not identifiable, C will be returned in its place. Called in list context, it will return a list of assertion references. =cut sub retrieve { my $self = shift; if (wantarray) { return map { $self->{assertions}->{$_} } @_; } else { return $self->{assertions}->{$_[0]}; } } =pod =item B I<$bool> = I<$tm>->is_asserted (I<$a>) This method will return C<1> if the passed-in assertion exists in the store. The assertion will be canonicalized before checking, but no defaults will be added if parts are missing. =cut sub is_asserted { my $self = shift; my $a = shift; unless ($a->[CANON]) { absolutize ($self, $a); canonicalize ($self, $a); } return $self->{assertions}->{$self->{baseuri} . hash ($a)}; } =pod =item B I<$tm>->retract (I<@list_of_assertion_ids>) This methods expects a list of assertion IDs and will remove the assertions from the map. If an ID is bogus, it will be ignored. Only these particular assertions will be deleted. Any topics in these assertions will remain. Use C to remove unnecessary topics. =cut sub retract { my $self = shift; # TODO: does delete $self->{assertions}->{@_} work? my $assertions = $self->{assertions}; map { delete $assertions->{$_} # delete them from the primary store } @_; $self->{assertions} = $assertions; ##!! needed for Berkeley DBM recognize changes on deeper levels $self->{last_mod} = Time::HiRes::time; } =pod =item B, B, B I<@list> = I<$tm>->match (CFORALL> or CEXISTS> [ , I, ... ]); I<@list> = I<$tm>->match_forall ( I, ... ]); I<@list> = I<$tm>->match_exists ( I, ... ]); These methods takes a search specification and return matching assertions. The result list contains references to the assertions themselves, not to copies. You can change the assertions themselves on your own risk (read: better not do it). For C, if the constant C is used as first parameter, this method returns a list of all assertions in the store following the search specification. If the constant C is used the method will return a non-empty value if at least one can be found. Calling the more specific C is the same as calling C with C. Similar for C. B: C is not yet implemented. The search specification is a hash with the same fields as for the constructor of an assertion: Example: $tm->match (TM->FORALL, type => '...', scope => '..., roles => [ ...., ....], players => [ ...., ....]); Any combination of assertion components can be used, all are optional, with the only constraint that the number of roles must match that for the players. All involved IDs will be absolutized before matching. B: Some combinations will be very fast, while others quite slow. The latter is the case when there is no special-purpose matcher implemented and the general-purpose one has to be used as a fallback. B: The implementation also understands a number of rather specialized query handlers. These are not yet documented here as there may be some shifts in the near future. =cut use constant { EXISTS => 1, FORALL => 0 }; our %exists_handlers = (); # they should be written at some point our %forall_handlers = ('' => sub { # no params => want all of them my $self = shift; return values %{$self->{assertions}}; }, 'nochar' => sub { my $self = shift; return grep ($_->[KIND] <= ASSOC, values %{$self->{assertions}}); }, #-- taxos --------------------------------------------------------------------------------------------- 'subclass.type' => sub { my $self = shift; my $st = shift; my ($ISSC, $SUBCLASS) = @{$self->{usual_suspects}}{'is-subclass-of', 'subclass'}; return () unless shift eq $ISSC; return grep ( $self->is_x_player ($_, $st, $SUBCLASS), grep ( $_->[TYPE] eq $ISSC, values %{$self->{assertions}})); }, 'superclass.type' => sub { my $self = shift; my $st = shift; my ($ISSC, $SUPERCLASS) = @{$self->{usual_suspects}}{'is-subclass-of', 'superclass'}; return () unless shift eq $ISSC; return grep ( $self->is_x_player ($_, $st, $SUPERCLASS), grep ( $_->[TYPE] eq $ISSC, values %{$self->{assertions}})); }, 'class.type' => sub { my $self = shift; my $t = shift; my ($ISA, $CLASS) = @{$self->{usual_suspects}}{'isa', 'class'}; return () unless shift eq $ISA; return grep ( $self->is_x_player ($_, $t, $CLASS), grep ( $_->[TYPE] eq $ISA, values %{$self->{assertions}})); }, 'instance.type' => sub { my $self = shift; my $i = shift; my ($ISA, $INSTANCE) = @{$self->{usual_suspects}}{'isa', 'instance'}; return () unless shift eq $ISA; return grep ( $self->is_x_player ($_, $i, $INSTANCE), grep ( $_->[TYPE] eq $ISA, values %{$self->{assertions}})); }, #-- 'char.irole' => sub { warn "char.irole is deprecated. use char.topic instead"; my $self = shift; my $topic = $_[1]; return undef unless $topic; return grep ($self->is_player ($_, $topic) && # TODO: optimize this grep away (getting chars is expensive) NAME <= $_->[KIND] && $_->[KIND] <= OCC, values %{$self->{assertions}}); }, 'char.topic' => sub { my $self = shift; my $topic = $_[1]; return grep (NAME <= $_->[KIND] && $_->[KIND] <= OCC && $_->[PLAYERS]->[0] eq $topic, # first role is always the 'thing' values %{$self->{assertions}}); }, 'char.value' => sub { my $self = shift; my $value = $_[1]; return grep (NAME <= $_->[KIND] && $_->[KIND] <= OCC && $_->[PLAYERS]->[1]->[0] eq $value->[0] && # second role is always the value $_->[PLAYERS]->[1]->[1] eq $value->[1], # test value AND type values %{$self->{assertions}}); }, 'char.topic.type' => sub { my $self = shift; my $topic = $_[1]; my $type = $_[2]; return grep ($self->is_subclass ($_->[TYPE], $type), grep ($_->[PLAYERS]->[0] eq $topic && # first role is always the 'thing' NAME <= $_->[KIND] && $_->[KIND] <= OCC, values %{$self->{assertions}})); }, 'lid' => # have unique ID? sub { my $self = shift; my $lid = $_[1]; return $self->{assertions}->{$lid} || (); }, 'type' => sub { my $self = shift; my $type = $_[0]; return grep ($self->is_subclass ($_->[TYPE], $type), values %{$self->{assertions}}); }, 'iplayer' => sub { my $self = shift; my $ip = $_[0]; return grep ($self->is_player ($_, $ip), values %{$self->{assertions}}); }, 'iplayer.type' => sub { my $self = shift; my ($ip, $ty) = @_; return grep ($self->is_player ($_, $ip) && $self->is_subclass ($_->[TYPE], $ty), values %{$self->{assertions}}); }, 'iplayer.irole' => sub { my $self = shift; my ($ip, $ir) = @_; return grep ($self->is_player ($_, $ip, $ir), values %{$self->{assertions}}); }, 'iplayer.irole.type' => sub { my $self = shift; my ($ip, $ir, $ty) = @_; return grep ($self->is_subclass ($_->[TYPE], $ty) && $self->is_player ($_, $ip, $ir), values %{$self->{assertions}}); }, 'irole.type' => sub { my $self = shift; my ($ir, $ty) = @_; return grep ($self->is_role ($_, $ir) && $self->is_subclass ($_->[TYPE], $ty), values %{$self->{assertions}}); }, 'irole' => sub { my $self = shift; my ($ir) = @_; return grep ($self->is_role ($_, $ir), values %{$self->{assertions}}); }, 'aplayer.arole.brole.type' => sub { my $self = shift; my ($ap, $ar, $br, $ty) = @_; return grep ( $self->is_role ($_, $br), grep ( $self->is_player ($_, $ap, $ar), grep ( $self->is_subclass ($_->[TYPE], $ty), values %{$self->{assertions}}))); }, 'aplayer.arole.bplayer.brole.type' => sub { my $self = shift; my ($ap, $ar, $bp, $br, $ty) = @_; return grep ( $self->is_player ($_, $bp, $br), grep ( $self->is_player ($_, $ap, $ar), grep ( $self->is_subclass ($_->[TYPE], $ty), values %{$self->{assertions}}))); }, 'anyid' => sub { my $self = shift; my $lid = shift; return grep ( ## $self->is_subclass ($_->[TYPE], $lid) || # probably not a good idea $_->[TYPE] eq $lid || # this seems a bit safer $_->[SCOPE] eq $lid || $self->is_player ($_, $lid) || $self->is_role ($_, $lid) , values %{$self->{assertions}}); }, ); sub _allinone { my $self = shift; my $exists = shift; my $template = Assertion->new (@_); # we create an assertion on the fly #warn "allinone ".Dumper $template; # $self->absolutize ($template); #warn "allinone2".Dumper $template; $self->canonicalize ($template); # of course, need to be canonicalized #warn "allinone3".Dumper $template; #warn "in store match template ".Dumper $template; my @mads; ASSERTION: foreach my $m (values %{$self->{assertions}}) { # arbitrary AsTMa! queries TBD, can be faster as well next if defined $template->[KIND] && $m->[KIND] ne $template->[KIND]; # does kind match? #warn "after kind"; next if defined $template->[SCOPE] && $m->[SCOPE] ne $template->[SCOPE]; # does scope match? #warn "after scope"; next if defined $template->[TYPE] && !$self->is_subclass ($m->[TYPE], $template->[TYPE]); # does type match? #warn "after type"; my ($rm, $rc) = ($m->[ROLES], $template->[ROLES]); push @mads, $m and next ASSERTION if ! @$rc; # match ok, if we have no roles #warn "after push roles"; next if @$rm != @$rc; # quick check: roles must be of equal length #warn "after roles"; my ($pm, $pc) = ($m->[PLAYERS], $template->[PLAYERS]); push @mads, $m and next ASSERTION if ! @$pc; # match ok, if we have no players next if @$pm != @$pc; # quick check: roles and players must be of equal length #warn "after players"; for (my $i = 0; $i < @{$rm}; $i++) { # order is canonicalized, would not want to test all permutations #warn "before role tests : is $rm->[$i] subclass of $rc->[$i]?"; next ASSERTION if defined $rc->[$i] && !$self->is_subclass ($rm->[$i], $rc->[$i]); # go to next assertion if that does not match #warn "after role ok"; next ASSERTION if defined $pc->[$i] && $pm->[$i] ne $pc->[$i]; } #warn "after players roles"; return (1) if $exists; # with exists that's it push @mads, $m; # with forall we do continue to collect } #warn "we return ".Dumper \@mads; return @mads; # and return what we got } sub match_forall { my $self = shift; my %query = @_; #warn "forall ".Dumper \%query; my @skeys = sort keys %query; # all fields make up the key my $skeys = join ('.', @skeys); my @svals = map { $query{$_} } @skeys; # if (my $index = $self->{indices}->{match}) { # there exists a dedicated index # my $key = "$skeys:" . join ('.', @svals); # if (my $lids = $index->is_cached ($key)) { # if result was cached, lets take the list of lids # return map { $self->{assertions}->{$_} } @$lids; # and return fully fledged # } else { # not defined means not cache => recompute # my @as = _dispatch_forall ($self, \%query, $skeys, @svals); # do it the hard way # $index->do_cache ($key, [ map { $_->[LID] } @as ]); # save it for later # return @as; # } # } else { # no cache, let's do the ochsentour # return _dispatch_forall ($self, \%query, $skeys, @svals); # } if (my $idxs = $self->{indices}) { # there are indices to help me my $key = "$skeys:" . join ('.', @svals); foreach my $idx (@$idxs) { if (my $lids = $idx->is_cached ($key)) { # if result was cached, lets take the list of lids # warn "using cached for $key". Dumper $lids; return map { $self->{assertions}->{$_} } @$lids; # and return fully fledged } } # obviously we have not found it # not defined means not cache => recompute my @as = _dispatch_forall ($self, \%query, $skeys, @svals); # do it the hard way $idxs->[0]->do_cache ($key, [ map { $_->[LID] } @as ]); # save it for later, simply use the first [0] return @as; } else { # no cache, let's do the ochsentour # warn "ochsen"; return _dispatch_forall ($self, \%query, $skeys, @svals); } sub _dispatch_forall { my $self = shift; my $query = shift; my $skeys = shift; #warn "keys for this $skeys"; if (my $handler = $forall_handlers{$skeys}) { # there is a constraint and we have a handler return &{$handler} ($self, @_); } else { # otherwise return _allinone ($self, 0, %$query); # we use a generic handler, slow but should do the trick } } } sub match_exists { my $self = shift; my %query = @_; #warn "exists ".Dumper $query; my @skeys = sort keys %query; # all fields make up the key my $skeys = join ('.', @skeys); #warn "keys for this $skeys"; if (my $handler = $exists_handlers{$skeys}) { # there is a constraint and we have a handler return &{$handler} ($self, map { $query{$_} } @skeys); } else { # otherwise return _allinone ($self, 1, %query); # we use a generic handler, slow but should do the trick } } sub match { my $self = shift; my $exists = shift; # FORALL or EXIST, DOES NOT work yet return $exists ? match_exists ($self, @_) : match_forall ($self, @_); } =pod =back =head2 Midlets Midlets are light-weight topics in that their information is quite minimal. One midlet is represented by an array with two fields: =over =item C
It contains the B URI, if known, otherwise C. =item C This is a reference to a list containing B. The list can be empty, no duplicate removal is attempted. =back =cut use constant { ADDRESS => 0, INDICATORS => 1 }; =pod =head2 Midlet Methods =over =item B I<$iid> = I<$tm>->internalize (I<$some_id>) I<$iid> = I<$tm>->internalize (I<$some_id> => I<$some_id>) I<@iids> = I<$tm>->internalize (I<$some_id> => I<$some_id>, ...) This method does some trickery when a new topic should be added to the map, depending on how parameters are passed into it. The general scheme is that pairs of identifiers are passed in. The first is usually the internal identifier, the second the subject identifier or the subject locator. The convention is that subject identifier URIs are passed in as string reference, whereas subject locator URIs are passed in as strings. The following cases are covered: =over =item C undef> If the ID is already an absolute URI and contains the C of the map as prefix, then this URI is used. If the ID is some other URI, then a topic with that URI as subject locator is search in the map. If such a topic already exists, then nothing special needs to happen. If no such topic existed, a new URI, based on the C and a random number will be created. =item C URI> Like above, only that the URI is used as subject locator. =item C \ URI> (reference to string) Like above, only that the URI is used as another subject identifier. =item C URI> Like above, only that the internal identifier has to be (maybe) created. =item C \ URI> Like above, only that the internal identifier has to be (maybe) created and the URI us used as subject identifier. =item C undef> A topic with a generated ID will be inserted. Not sure what this is good for. =back In any case, the internal identifier(s) of all inserted (or existing) topics are returned. =cut my $toplet_ctr = 0; sub internalize { my $self = shift; my $baseuri = $self->{baseuri}; #warn "internalize base: $baseuri"; my @mids; my $mid2iid = $self->{mid2iid}; while (@_) { my ($k, $v) = (shift, shift); # assume to get here undef => URI or ID => URI or ID => \ URI or ID => undef #warn "internalize $k, $v"; # make sure that $k contains a mid if (defined $k) { if ($k =~ /^$baseuri/) { # ha, perfect # null # keep it as it is } elsif ($k =~ /^\w+:/) { # some other absURL if (my $k2 = $self->mids ($k)) { # we already had it ($k, $v) = ($k2, $k); } else { # it is unknown so far ($k, $v) = ($baseuri.sprintf ("uuid-%010d", $toplet_ctr++), $k); } } elsif (my $k2 = $self->mids ($k)) { $k = $k2; # then we already have it, maybe under a different mid, take that } else { # this means we have a absURI and it is not from that map $k = $baseuri.$k; # but now it is } } elsif (my $k2 = $self->mids ($v)) { # k is not defined, lets look at v; we already had it $k = $k2; # this will be k then } else { # it is unknown so far $k = $baseuri.sprintf ("uuid-%010d", $toplet_ctr++); # generate a new one } #warn "really internalizing '$k' '$v'"; push @mids, $k; # now see that we have an entry in the mid2iid table $mid2iid->{$k} ||= [ undef, [] ]; my $kentry = $mid2iid->{$k}; # keep this as a shortcut if ($v) { if (ref($v)) { # being a reference means that we have a subject indication push @{$kentry->[TM->INDICATORS]}, $$v; # append it to the list } elsif ($kentry->[TM->ADDRESS]) { # this is a subject address and, oh, there is already a subject address, not good $log->logdie ("duplicate subject address '$v' for '$k'") unless $v eq $kentry->[TM->ADDRESS]; } else { # everything is fine, we can set it $kentry->[TM->ADDRESS] = $v; } } } $self->{mid2iid} = $mid2iid; #!! needed for Berkeley DBM recognize changes on deeper levels $self->{last_mod} = Time::HiRes::time; return wantarray ? @mids : $mids[0]; } =pod =item B I<$mid> = I<$tm>->mids (I<$some_id>) I<@mids> = I<$tm>->mids (I<$some_id>, ...) This function tries to build absolute versions of the identifiers passed in. C will be returned if no such can be found. Can be used in scalar and list context. =over =item If the passed in identifier is a relative URI, so it is made absolute by prefixing it with the map C and then we look for a topic with that internal identifier. =item If the passed in identifier is an absolute URI, where the C is a prefix, then that URI will be used as internal identifier to look for a topic. =item If the passed in identifier is an absolute URI, where the C is B a prefix, then that URI will be used as subject locator and such a topic will be looked for. =item If the passed in identifier is a reference to an absolute URI, then that URI will be used as subject identifier and such a topic will be looked for. =back =cut sub mids { my $self = shift; my $baseuri = $self->{baseuri}; my @ks; my $mid2iid = $self->{mid2iid}; # warn "mids ".Dumper \@_; MID: foreach my $k (@_) { if (! defined $k) { # someone put in undef push @ks, undef; } elsif (ref ($k)) { # would be subject indicator ref my $kk = $$k; foreach my $k2 (keys %{$mid2iid}) { if (grep ($_ eq $kk, @{$mid2iid->{$k2}->[TM->INDICATORS]} )) { push @ks, $k2; next MID; } } push @ks, undef; } elsif ($k =~ /^$baseuri/) { # we already have something which looks like a mid push @ks, $mid2iid->{$k} ? $k : undef; } elsif ($k =~ /^\w+:/) { # must be some other uri, must be subject address no warnings; my @k2 = grep ($mid2iid->{$_}->[TM->ADDRESS] eq $k, keys %{$mid2iid}); push @ks, @k2 ? $k2[0] : undef; } else { # only a string, like 'aaa' my $k2 = $baseuri.$k; # make it absolute, and... push @ks, $mid2iid->{$k2} ? $k2 : undef; # see whether there is something } } #warn "mids ".Dumper (\@_)." returning ".Dumper (\@ks); return wantarray ? @ks : $ks[0]; } =pod =item B I<$tm>->externalize (I<$some_id>, ...) This function simply deletes the topic entry for a given internal identifier(s). See C to find these. The function returns all deleted topic entries. B: Assertions in which this topic is involved will not be removed. Use C to clean up all assertion where non-existing topics still exist. =cut sub externalize { my $self = shift; my $mid2iid = $self->{mid2iid}; my @doomed = map { delete $mid2iid->{$_} } @_; $self->{mid2iid} = $mid2iid; ## !! needed for Berkeley DBM recognize changes on deeper levels $self->{last_mod} = Time::HiRes::time; return @doomed; } =pod =item B I<@mids> = I<$tm>->midlets I<@mids> = I<$tm>->midlets (I<@list-of-ids>) I<@mids> = I<$tm>->midlets (I<$selection-spec>) This function returns things - actually their absolutized ids - from the map. If no parameter is used, all I are returned. This includes really everything also infrastructure topics and all associations, occurrences, etc. If an explicit list is used, the only exciting thing which will happen is that these IDs are absolutized. If a search specification is used, it has to be passed in as string reference. That string contains the selection specification using the following simple language: specification -> { ( '+' | '-' ) group } whereby I is one of the following: =over =item C refers to B topics in the map. This includes those supplied by the application, but also all associations, names and occurrences. The list also includes all infrastructure topics which the software maintains for completeness. =item C refers to all topics which are actually associations =item C refers to all topics which are actually name characteristics =item C refers to all topics which are actually occurrences =item C refers to all topics the infrastructure has provided. This implies that all - infrastructure is everything the user (application) has supplied. =back Examples: # all midlets except those from TM::PSI $tm->midlets (\ '+all -infrastructure') # like above, without assocs, so with names and occurrences $tm->midlets (\ '+all -assocs') =cut sub midlets { my $self = shift; if ($_[0]) { # if there is some parameter if (ref ($_[0]) ) { # whoohie, a search spec my $spec = ${$_[0]}; my $l = []; # will be list while ($spec =~ s/([+-])(\w+)//) { #warn "working on $1 $2"; if ($2 eq 'all') { $l = _mod_list ($1 eq '+', $l, keys %{$self->{mid2iid}}); } elsif ($2 eq 'associations') { $l = _mod_list ($1 eq '+', $l, map { $_->[TM->LID] } grep ($_->[TM->KIND] == TM->ASSOC, values %{$self->{assertions}})); } elsif ($2 eq 'names') { $l = _mod_list ($1 eq '+', $l, map { $_->[TM->LID] } grep ($_->[TM->KIND] == TM->NAME, values %{$self->{assertions}})); } elsif ($2 eq 'occurrences') { $l = _mod_list ($1 eq '+', $l, map { $_->[TM->LID] } grep ($_->[TM->KIND] == TM->OCC, values %{$self->{assertions}})); } elsif ($2 eq 'infrastructure') { $l = _mod_list ($1 eq '+', $l, $self->mids (keys %{$TM::PSI::topicmaps->{mid2iid}})); } else { $log->logdie (scalar __PACKAGE__ .": specification '$2' unknown"); } } $log->logdie (scalar __PACKAGE__ .": unhandled specification '$spec' left") if $spec =~ /\S/; return _mk_uniq (@$l); } else { return $self->mids (@_); # make all these fu**ing identifiers map-absolute } } else { # if the list was empty, we assume every thing in the map return keys %{$self->{mid2iid}}; } sub _mod_list { my $pm = shift; # non-zero for + my $l = shift; if ($pm) { return [ @$l, @_ ]; } else { my %minus; @minus{ @_ } = (1) x @_; return [ grep (!$minus{$_}, @$l) ]; } } sub _mk_uniq { my %uniq; @uniq {@_} = (1) x @_; return keys %uniq; } } =pod =item B I<$t> = I<$tm>->midlet (I<$mid>) I<@ts> = I<$tm>->midlet (I<$mid>, ....) This function returns a reference to a midlet structure. That includes a subject address, if available and a list (reference) for the optional subject indicators. Can be used in scalar and list context. =cut sub midlet { my $self = shift; my $mid2iid = $self->{mid2iid}; if (wantarray) { return (map { defined $_ ? $mid2iid->{$_} : $_ } @_); } else { return $mid2iid->{$_[0]}; } } =pod =back =head2 Taxonomics and Subsumption The following methods provide useful basic, ontological functionality around subclassing (also transitive) between classes and instance/type relationships. Deriving classes may want to consider to overload/redefine these methods better suitable for their representation of the a map. Saying this, the methods below are not optimized for speed. B: There are NO subclasses of the C. But everything is an instance of C. B: See L for predefined things. =over =item B I<$bool> = I<$tm>->is_subclass (I<$superclass_id>, I<$subclass_id>) This function returns C<1> if the first parameter is a (transitive) superclass of the second, i.e. there is an assertion of type I in the context map. It also returns C<1> if the superclass is a $TM::PSI::THING or if subclass and superclass are the same (reflexive). =cut #use Memoize; #memoize('is_subclass'); sub is_subclass { my $self = shift; my $class = shift; my $super = shift; return 1 if $class eq $super; # we always assume that A subclasses A my ($ISA, $US, $THING, $SUBCLASSES, $SUBCLASS, $SUPERCLASS, $INSTANCE, $CLASS) = @{$self->{usual_suspects}}{'isa', 'us', 'thing', 'is-subclass-of', 'subclass', 'superclass', 'instance', 'class'}; #warn "is_subclass?: class $class super $super , thing $THING, $SUBCLASSES, $SUPERCLASS"; return 1 if $super eq $THING; # everything is a topic # but not if the class is one of the predefined things, yes, there is a method to this madness return 0 if $class eq $ISA; return 0 if $class eq $US; return 0 if $class eq $THING; return 0 if $class eq $SUBCLASSES; return 0 if $class eq $SUBCLASS; return 0 if $class eq $SUPERCLASS; return 0 if $class eq $INSTANCE; return 0 if $class eq $CLASS; # # see whether there is an assertion that we have a direct subclasses relationship between the two # This would be an optimization, but this does not go through match # return 1 if $self->is_asserted (Assertion->new (scope => $US, # TODO OPTIMIZE # type => $SUBCLASSES, # roles => [ $SUBCLASS, $SUPERCLASS ], # players => [ $class, $super ]) # ); # if we still do not have a decision, we will check all super types of $class and see (recursively) whether we can establish is-subclass-of return 1 if grep ($self->is_subclass ($_, $super), # check all of the intermediate type whether there is a transitive relation map { $self->get_x_players ($_, $SUPERCLASS) } # find the superclass player there => intermediate type $self->match_forall (type => $SUBCLASSES, subclass => $class) ); return 0; # ok, we give up now } =pod =item B I<$bool> = I<$tm>->is_a (I<$something_lid>, I<$class_lid>) This method returns C<1> if the thing referenced by the first parameter is an instance of the class referenced by the second. The method honors transitive subclassing and B is a C. =cut sub is_a { my $self = shift; my $thingie = shift; my $type = shift; # ok, what class are looking at? my ($ISA, $CLASS, $THING) = @{$self->{usual_suspects}}{'isa', 'class', 'thing'}; #warn "isa thingie $thingie class $type"; return 1 if $type eq $THING and # is the class == 'thing' and $self->{mid2iid}->{$thingie}; # and does the thingie exist? my ($m) = $self->retrieve ($thingie); return 1 if $m and # is it an assertion ? and... $self->is_subclass ($m->[TYPE], $type); # is the assertion type a subclass? return 1 if grep ($self->is_subclass ($_, $type), # check all of the intermediate type whether there is a transitive relation map { $self->get_players ($_, $CLASS) } # find the class player there => intermediate type $self->match_forall (type => $ISA, instance => $thingie) ); return 0; } =pod =item B, B I<@lids> = I<$tm>->subclasses (I<$lid>) I<@lids> = I<$tm>->subclassesT (I<$lid>) C returns all B subclasses of the thing identified by C<$lid>. If the thing does not exist, the list will be empty. C is a variant which honors the transitive subclassing (so if A is a subclass of B and B is a subclass of C, then A is also a subclass of C). =cut sub subclasses { my $self = shift; my $lid = shift; my ($SUBCLASSES) = @{$self->{usual_suspects}}{'is-subclass-of'}; return map { $_->[PLAYERS]->[0] } $self->match_forall (type => $SUBCLASSES, superclass => $lid); } sub subclassesT { my $self = shift; my $lid = shift; my @sc = $self->subclasses ($lid); my %dup; return map { $dup{$_}++ ? () : $_ } ($lid), (@sc), (map { $self->subclassesT ($_) } @sc); } =pod =item B, B I<@lids> = I<$tm>->superclasses (I<$lid>) I<@lids> = I<$tm>->superclassesT (I<$lid>) The method C returns all direct superclasses of the thing identified by C<$lid>. If the thing does not exist, the list will be empty. C is a variant which honors transitive subclassing. =cut sub superclasses { my $self = shift; my $lid = shift; my ($SUBCLASSES) = @{$self->{usual_suspects}}{'is-subclass-of'}; return map { $_->[PLAYERS]->[1] } $self->match_forall (type => $SUBCLASSES, subclass => $lid); } sub superclassesT { my $self = shift; my $lid = shift; my @sc = $self->superclasses ($lid); my %dup; return map { $dup{$_}++ ? () : $_ } ($lid), (@sc), (map { $self->superclassesT ($_) } @sc); # laziness equals recursion } =pod =item B, B I<@lids> = I<$tm>->types (I<$lid>) I<@lids> = I<$tm>->typesT (I<$lid>) The method C returns all direct classes of the thing identified by C<$lid>. If the thing does not exist, the list will be empty. C is a variant which honors transitive subclassing (so if I is an instance of type I and I is a subclass of I, then I is also an instance of I). =cut sub types { my $self = shift; my $lid = shift; if (my $a = $self->retrieve ($lid)) { return ($a->[TYPE]) }; my ($ISA) = @{$self->{usual_suspects}}{'isa'}; return (map { $_->[PLAYERS]->[0] } $self->match_forall (type => $ISA, instance => $lid)); } sub typesT { my $self = shift; my $lid = shift; my @sc = $self->types ($lid); my %dup; return map { $dup{$_}++ ? () : $_ } (@sc), (map { $self->superclassesT ($_) } @sc); } =pod =item B, B I<@lids> = I<$tm>->instances (I<$lid>) I<@lids> = I<$tm>->instancesT (I<$lid>) These methods return the direct (C) and also indirect (C) instances of the thing identified by C<$lid>. =cut sub instances { my $self = shift; my $lid = shift; my ($ISA, $THING) = @{$self->{usual_suspects}}{'isa', 'thing'}; return $self->midlets if $lid eq $THING; return (map { $_->[LID ] } $self->match_forall (type => $lid)), (map { $_->[PLAYERS]->[1] } $self->match_forall (type => $ISA, class => $lid)) ; } sub instancesT { my $self = shift; my $lid = shift; return map { $self->instances ($_) } $self->subclassesT ($lid); } =pod =back =head3 Filters Quite often one needs to walk through a list of things to determine whether they are instances (or types, subtypes or supertypes) of some concept. This list of functions lets you do that: you pass in a list and the function behaves as filter. =over =item B I<@ids> = I<$tm>->are_instances (I<$class_id>, I<@list_of_ids>) Returns all those ids where the topic is an instance of the class provided. =cut sub are_instances { my $self = shift; my $class = shift; # ok, what class are we looking at? my ($THING, $ISA, $CLASS) = @{$self->{usual_suspects}}{'thing', 'isa', 'class'}; my @rs; foreach my $thing (@{$_[0]}) { # we work through all the things we got #warn "checking $thing"; push @rs, $thing and next # we happily take one if if $class eq $THING and # is the class = 'thing' ? and $self->midlet ($thing); # then does the thing exist in the map ? my $m = $self->retrieve ($thing); push @rs, $thing and next # we happily take one if if $m and # it is an assertion ? and... ($class eq $THING # either it is the class a THING (we did not explicitly store _that_) or $self->is_subclass ($m->[TYPE], $class) # or is the assertion type a subclass? ); push @rs, $thing and next # we happily take one if if grep ($self->is_subclass ($_, $class), # finall we check all of the intermediate type whether there is a transitive relation map { $self->get_players ($_, $CLASS) } # then we find the 'class' value $self->match_forall (type => $ISA, instance => $thing)); # nothing # otherwise we do not push } return \@rs; } =pod =item B (Warning: placeholder only) I<@ids> = I<$tm>->are_types (I<$instance_id>, I<@list_of_ids>) Returns all those ids where the topic is a type of the instance provided. =cut sub are_types { $log->logdie ("not implemented function"); } =pod =item B (Warning: placeholder only) I<@ids> = I<$tm>->are_supertypes (I<$class_id>, I<@list_of_ids>) Returns all those ids where the topic is a supertype of the class provided. =cut sub are_supertypes { $log->logdie ("not implemented function"); } =pod =item B (Warning: placeholder only) I<@ids> = I<$tm>->are_subtypes (I<$class_id>, I<@list_of_ids>) Returns all those ids where the topic is a subtype of the class provided. =cut sub are_subtypes { $log->logdie ("not implemented function"); } =pod =back =head2 Reification =over =item B (experimental) Provided with an identifier, this method returns the subject locator. It returns C if there is no such topic or no locator. TODO: list context TODO: name sucks WARNING: this function may go away =cut sub reified_by { my $self = shift; my $mid = shift; return $self->{mid2iid}->{$mid} ? $self->{mid2iid}->{$mid}->[TM->ADDRESS] : undef; } =pod =item B (experimental) WARNING: this function may go away =cut sub reifies { my $self = shift; my $url = shift; my $mid2iid = $self->{mid2iid}; # shortcut my $s; # temp return grep (($s = $mid2iid->{$_}->[TM->ADDRESS]) && ($s eq $url), keys %{$mid2iid}); } =pod =back =head2 Variants (aka "The Warts") No comment. =over =item B I<$tm>->variants (I<$id>, I<$variant>) I<$tm>->variants (I<$id>) With this method you can get/set a variant tree for B topic. According to the standard only basenames (aka topic names) can have variants, but, hey, this is such an ugly beast (I am digressing). According to this data model you can have variants for B toplets/maplets. You only need their id. The structure is like this: $VAR1 = { 'tm:param1' => { 'variants' => { 'tm:param3' => { 'variants' => undef, 'value' => 'name for param3' } }, 'value' => 'name for param1' }, 'tm:param2' => { 'variants' => undef, 'value' => 'name for param2' } }; The parameters are the keys (there can only be one, which is a useful, cough, restriction of the standard) and the data is the value. Obviously, one key value (i.e. parameter) can only exists once. Caveat: This is not very well tested (read: not tested at all). =cut sub variants { my $self = shift; my $id = shift; my $var = shift; $self->{last_mod} = Time::HiRes::time if $var; return $var ? $self->{variants}->{$id} = $var : $self->{variants}->{$id}; } =pod =back =head1 LOGGING The L module hosts (since 1.29) the Log4Perl object C<$TM::log>. It is initialized with some reasonable defaults, but an using application can access it, tweak it, or overwrite it completely. =head1 SEE ALSO L =head1 COPYRIGHT AND LICENSE Copyright 200[1-7] by Robert Barta, Edrrho@cpan.orgE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut our $REVISION = '$Id: TM.pm,v 1.45 2007/07/17 16:24:00 rho Exp $'; 1; __END__