TM::Bulk - Topic Maps, Bulk Retrieval Trait

  my $tm = .....                          # get a map from anywhere

  use TM::Bulk;
  use Class::Trait;
  Class::Trait->apply ($tm, 'TM::Bulk');  # give the map the trait

  # find out environment of topic
  my $vortex = $tm->vortex ('some-lid',
                           {
	  	 	    'types'       => [ 'types' ],
		 	    'instances'   => [ 'instances*', 0, 20 ],
			    'topic'       => [ 'topic' ],
			    'roles'       => [ 'roles',     0, 10 ],
			    'members'     => [ 'players' ],
			   },
			   );
  # find names of topics (optionally using a scope preference list)
  my $names = $tm->names ([ 'ccc', 'bbb', 'aaa' ], [ 's1', 's3', '*' ]);

package TM::Bulk;

use TM;
use Class::Trait 'base';

use Data::Dumper;

sub names {
    my $self   = shift;
    my $topics = shift || [];
    my $scopes = shift || [ '*' ];

#warn "looking for ".Dumper ($topics). "with scopes ".Dumper $scopes;
    my $dontcare = 0;                                                  # one of the rare occasions I need a boolean
    if ($scopes->[-1] eq '*') {
	pop @$scopes;                                                  # get rid of this '*' to have a clean topic list
	$dontcare = 1;                                                 # remember this incident for below
    }
    my @scopes = grep { $_ } $self->tids (@$scopes);                   # make them absolute, so that we can compare later (only keep existing ones)
#warn "scopes".Dumper \@scopes;

    my ($US) = ('us');

    my %dict;                                                          # this is what we are building
TOPICS:
    foreach my $lid (grep { $_ } $self->tids (@$topics)) {             # for all in my working list, make them absolute, and test
#	next if $dict{$lid};                                           # do not things twice
#	$dict{$lid} = undef;                                           # but make sure we have an entry there, whatever comes next

	my @as = grep { $_->[TM->KIND] == TM->NAME }                   # filter all characteristics for basenames
	            $self->match_forall (char => 1, topic => $lid);
	unless (@as) {                                                 # no names? => done 
	    $dict{$lid} = undef;
	    next;
	}
                                                                       # assertion: @as contains at least one entry!
	unless (@scopes) {                                             # empty list? => preference is unconstrained scope
	    if (my @aas = grep ($_->[TM->SCOPE] eq $US, @as)) {
		$dict{$lid.'@'.$US} = $aas[0]->[TM->PLAYERS]->[1]->[0];
		next TOPICS;
	    }
	}
	foreach my $sco ($self->tids (@scopes)) {                      # check out all scope preferences (note, there is at least one in @as!)
	    if (my @aas = grep ($_->[TM->SCOPE] eq $sco, @as)) {
		$dict{$lid.'@'.$sco} = $aas[0]->[TM->PLAYERS]->[1]->[0];
		next TOPICS;
	    }
	}
	if ($dontcare) {                                               # get some name item and derereference it
	    $dict{$lid.'@'.$as[0]->[TM->SCOPE]} = $as[0]->[TM->PLAYERS]->[1]->[0]; # scope it with what we have
	} else {                                                       # otherwise send back nothing
	    $dict{$lid} = undef;
	}
    }
#warn "returning dict ".Dumper \%dict;
    return \%dict;
}

sub vortex {
  my $self   = shift;
  my $lid    = shift;
  my $what   = shift;
  my $scopes = shift             and $TM::log->logdie ("scopes not supported yet");

  my $alid   = $self->tids ($lid) or $TM::log->logdie ("no topic '$lid'");

  my ($ISSC, $ISA) = ('is-subclass-of', 'isa');
  
  my @as = $self->match_forall (iplayer => $alid);            # find out everything we know about the player

  my $_t;                                                     # here all the goodies go
  foreach my $where (keys %{$what}) {                         # collect here what the user wants
      my $w = shift @{$what->{$where}};

      if ($w eq 'topic') {
	  $_t->{$where} = $self->toplet ($alid);
	  
      } else {
	  my @is;
	  if (grep ($w =~ /^$_\*?$/, qw(instances types subclasses superclasses))) {
	      $w =~ s/\*/T/;

	      @is  = $self->$w ($alid); # whoa, Perl late binding rocks !
	  
	  } elsif ($w eq 'names') {
	      @is = map { [ $_->[TM->TYPE], $_->[TM->SCOPE], $_->[TM->PLAYERS]->[1]->[0] ] }
	            grep { $_->[TM->KIND] == TM->NAME }
                    @as;
	  
	  } elsif ($w eq 'occurrences') {
	      @is = map { [ $_->[TM->TYPE], $_->[TM->SCOPE], $_->[TM->PLAYERS]->[1] ] }
	            grep { $_->[TM->KIND] == TM->OCC }
	            @as;
	  
	  } elsif ($w eq 'roles') {
	      @is = map { $_->[ TM->LID ] }
                    grep { $_->[TM->TYPE] ne $ISSC && $_->[TM->TYPE] ne $ISA }
	            grep { $_->[TM->KIND] == TM->ASSOC }
                    @as;

          } elsif ($w eq 'peers') {
              @is = grep { $_ ne $alid } $self->instances ($self->types ($alid));

          } elsif ($w eq 'peers*') {
              @is = grep { $_ ne $alid }  $self->instancesT ($self->types ($alid)) ;

          } elsif ($w eq 'peers**') {
              @is = grep { $_ ne $alid } $self->instancesT ($self->typesT ($alid)) ;

	  } elsif ($w eq 'associations') { # TODO! test case
sub _morph {
    my $lid = shift;
    my $a   = shift;

    my ($ps, $rs) = ($a->[TM->PLAYERS], $a->[TM->ROLES]);
    my $r;                                                                    # my own role
    my %rs;                                                                   # the other roles
    for (my $i = 0; $i < @$ps; $i++) {
        if ($lid eq $ps->[$i]) {                                              # we talk about ourselves
            $r = $rs->[$i];
        } else {                                                              # this is about something else
            push @{ $rs{ $rs->[$i] } }, $ps->[$i];
        }
    }
    return ($r, \%rs);
}
              @is = map { [  $_->[TM->TYPE], $_->[TM->SCOPE], _morph ($alid, $_) ] }
                    grep { $_->[TM->TYPE] ne $ISSC && $_->[TM->TYPE] ne $ISA }
                    grep { $_->[TM->KIND] == TM->ASSOC }
                    @as;

	  }
	  my ($from, $to) = _calc_limits (scalar @is, shift @{$what->{$where}}, shift @{$what->{$where}});
	  $_t->{$where} = [ @is[ $from .. $to ] ];
      }
  }
  return $_t;                                                                   # and ship it all back

  sub _calc_limits {
      my $last  = (shift) - 1; # last available
      my $from  = shift || 0;
      my $want  = shift || 10;
      my $to = $from + $want - 1;
      $to = $last if $to > $last;
      return ($from, $to);
  }
}

our $VERSION  = 0.5;
our $REVISION = '$Id: Bulk.pm,v 1.2 2007/07/17 16:23:05 rho Exp $';

1;

__END__