view release on metacpan or  search on metacpan

lib/Algorithm/SpatialIndex/Storage/DBI.pm  view on Meta::CPAN

  );
  warn $sql if DEBUG;
  $dbh->do($sql);

  my $bsql = $self->{buckets_create_sql};
  warn $bsql if DEBUG;
  $dbh->do($bsql);
}

=head2 _write_config

Writes the index's configuration to the
configuration table.

=cut

sub _write_config {
  my $self = shift;
  my $dbh = $self->dbh_rw;

  my $table_prefix = $self->table_prefix;

  my $sql_struct = $self->{_write_config_sql};
  my $is_sub = ref($sql_struct) eq 'CODE';
  my $sth;
  $sth = $dbh->prepare_cached($sql_struct->[0]) if not $is_sub;

  my $success = eval {
    foreach my $key (keys %{$self->{config}}) {
      if ($is_sub) {
        $sql_struct->($key, $self->{config}{$key});
      } else {
        my $d = [$key, $self->{config}{$key}];
        $sth->execute(map $d->[$_], @{$sql_struct}[1..$#$sql_struct]);
        my $err = $sth->errstr; die $err if $err;
      }
    }
    1;
  };
  $sth->finish;
}

sub fetch_node {
  my $self  = shift;
  my $index = shift;
  my $dbh = $self->dbh_ro;
  my $str = $self->{_fetch_node_sql};
  my $sth = $dbh->prepare_cached($str);
  $sth->execute($index);
  my $struct = $sth->fetchrow_arrayref;
  $sth->finish;
  return if not defined $struct;
  my $coords = $self->no_of_coords;
  my $snodes = [@{$struct}[1+$coords..$coords+$self->no_of_subnodes]];
  $snodes = [] if not defined $snodes->[0];
  my $node = Algorithm::SpatialIndex::Node->new(
    id => $struct->[0],
    coords => [@{$struct}[1..$coords]],
    subnode_ids => $snodes,
  );
  #use Data::Dumper; warn "FETCH: " . Dumper($node);
  return $node;
}

sub store_node {
  my $self = shift;
  my $node = shift;
  #use Data::Dumper;
  #use Data::Dumper; warn "STORE: " . Dumper($node);
  my $id = $node->id;
  my $dbh = $self->dbh_rw;
  my $tname = $self->table_prefix . '_nodes'; 
  my $sth;
  if (not defined $id) {
    $sth = $dbh->prepare_cached($self->{_write_new_node_sql});
    my $coords = $node->coords;
    my $snids = $node->subnode_ids;
    my @args = (
      @$coords,
      ((undef) x ($self->no_of_coords - @$coords)),
      @$snids,
      ((undef) x ($self->no_of_subnodes - @$snids))
    );
    $sth->execute(@args);
    $id = $dbh->last_insert_id('', '', '', ''); # FIXME NOT PORTABLE LIKE THAT
    $node->id($id);
  }
  else {
    $sth = $dbh->prepare_cached($self->{_write_node_sql});
    $sth->execute($id, @{$node->coords}, @{$node->subnode_ids}, $id);
  }
  $sth->finish();
  return $id;
}

sub get_option {
  my $self = shift;
  return $self->{config}->{shift()}; # We assume this data changes RARELY
}

sub set_option {
  my $self  = shift;
  my $key   = shift;
  my $value = shift;

  $self->{config}->{$key} = $value;
  $self->_write_config(); # FIXME wasteful
}

sub store_bucket {
  my $self   = shift;
  my $bucket = shift;
  my $dbh = $self->dbh_rw;
  my $id = $bucket->node_id;
  my $sql = $self->{buckets_insert_sql};
  my $is_sub = ref($sql) eq 'CODE';
  if (!$is_sub) {
    my $sth = $dbh->prepare_cached($sql->[0]);
    my $d = [$id, map {@$_} @{$bucket->items}];
    $sth->execute(map $d->[$_], @{$sql}[1..$#$sql]);
    my $err = $sth->errstr; die $err if $err;
    $sth->finish;
  }
  else {
    $sql->($id, map {@$_} @{$bucket->items});
  }
}

sub fetch_bucket {

lib/Algorithm/SpatialIndex/Storage/DBI.pm  view on Meta::CPAN

  my $self = shift;
  my $bsize = $self->bucket_size;
  my $tname = $self->table_prefix . '_buckets';

  my %types = (
    float    => 'FLOAT',
    double   => 'DOUBLE',
    integer  => 'INTEGER',
    unsigned => 'INTEGER UNSIGNED',
  );
  my $item_coord_types = [map $types{$_}, @{$self->item_coord_types}];

  # i0 INTEGER, i0c0 DOUBLE, i0c1 DOUBLE, ...
  $self->{buckets_create_sql} = qq{CREATE TABLE IF NOT EXISTS $tname ( node_id INTEGER PRIMARY KEY, }
                                . join(
                                  ', ',
                                  map {
                                    my $i = $_;
                                    my $c = 0;
                                    ("i$i INTEGER", map "i${i}c".$c++." $_", @$item_coord_types)
                                  } 0..$bsize-1
                                )
                                . ')';
  $self->{buckets_select_sql} = qq{SELECT * FROM $tname WHERE node_id=?};

  my $insert_id_list = join(
    ', ',
    map {
      my $i = $_;
      "i$i", map "i${i}c$_", 0..$#$item_coord_types
    } 0..$bsize-1
  );
  my $nentries = 1 + $bsize * (1+@$item_coord_types);
  #my $idlist = join(', ', map "i$_" 0..$bsize-1);
  my $qlist  = '?,' x $nentries;
  $qlist =~ s/,$//;
  if ($self->is_mysql) {
    $self->{buckets_insert_sql} = [
      qq{
        INSERT INTO $tname
        VALUES ($qlist)
        ON DUPLICATE KEY UPDATE $insert_id_list
      }, 0..$nentries-1
    ];
  }
  elsif ($self->is_sqlite) {
    $self->{buckets_insert_sql} = [qq{INSERT OR REPLACE INTO $tname VALUES($qlist)}, 0..$nentries-1 ];
  }
  else {
    my $insert_sql = qq{INSERT INTO $tname VALUES(?, $qlist)};
    my $update_sql = qq{UPDATE $tname SET id=?, $insert_id_list};
    $self->{buckets_insert_sql} = sub {
      my $dbh = shift;
      eval {
        $dbh->do($insert_sql, {}, @_, (undef) x ($nentries-@_));
        $dbh->do($update_sql, {}, @_, (undef) x ($nentries-@_));
        1;
      };
    };
  }
  #use Data::Dumper;
  #warn Dumper $self->{buckets_insert_sql};
}

1;
__END__

=head1 AUTHOR

Steffen Mueller, E<lt>smueller@cpan.orgE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2010, 2011 by Steffen Mueller

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.10.1 or,
at your option, any later version of Perl 5 you may have available.

=cut