/*
* Copyright 2009 10gen, Inc.
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
*/
#include "perl_mongo.h"
#include "mongo_link.h"
static int
connection_free (pTHX_ SV *sv, MAGIC *mg)
{
mongo_link *link;
PERL_UNUSED_ARG(sv);
link = (mongo_link *)mg->mg_ptr;
if (!link->copy && link->master) {
if (link->master->host) {
Safefree(link->master->host);
}
Safefree(link->master);
}
Safefree(link);
mg->mg_ptr = NULL;
return 0;
}
static int
connection_clone (pTHX_ MAGIC *mg, CLONE_PARAMS *params)
{
mongo_link *link, *new_link;
PERL_UNUSED_ARG (params);
link = (mongo_link *)mg->mg_ptr;
Newx(new_link, 1, mongo_link);
Copy(link, new_link, 1, mongo_link);
if (link->master) {
mongo_server *new_master;
Newx(new_master, 1, mongo_server);
new_master->host = savepv(link->master->host);
new_master->port = link->master->port;
/* Start out disconnected. When we have something to send, we'll
* reconnect automatically.
*
* If we actually wanted to reconnect here, we'd have to make mongo_link
* carry around a backref to the SV it's associated with so we could
* reconnect through perl space.
*/
new_master->connected = 0;
new_link->master = new_master;
}
mg->mg_ptr = (char *)new_link;
return 0;
}
MGVTBL connection_vtbl = {
NULL,
NULL,
NULL,
NULL,
connection_free,
#if MGf_COPY
NULL,
#endif
#if MGf_DUP
connection_clone,
#endif
#if MGf_LOCAL
NULL,
#endif
};
MODULE = MongoDB::MongoClient PACKAGE = MongoDB::MongoClient
PROTOTYPES: DISABLE
void
_init_conn(self, host, port, ssl)
SV *self
char *host
int port
bool ssl
PREINIT:
SV *auto_reconnect_sv = 0, *timeout_sv = 0;
mongo_link *link;
CODE:
Newx(link, 1, mongo_link);
perl_mongo_attach_ptr_to_instance(self, link, &connection_vtbl);
/*
* hosts are of the form:
* [{host => "host", port => 27017}, ...]
*/
Newx(link->master, 1, mongo_server);
Newxz(link->master->host, strlen(host)+1, char);
memcpy(link->master->host, host, strlen(host));
link->master->port = port;
link->master->connected = 0;
link->ssl = ssl;
#ifdef MONGO_SSL
link->ssl_handle = NULL;
link->ssl_context = NULL;
#endif
auto_reconnect_sv = perl_mongo_call_reader (ST(0), "auto_reconnect");
timeout_sv = perl_mongo_call_reader (ST(0), "timeout");
link->auto_reconnect = SvIV(auto_reconnect_sv);
link->timeout = SvIV(timeout_sv);
link->copy = 0;
CLEANUP:
SvREFCNT_dec (auto_reconnect_sv);
SvREFCNT_dec (timeout_sv);
void
_init_conn_holder(self, master)
SV *self
SV *master
PREINIT:
mongo_link *self_link, *master_link;
CODE:
Newx(self_link, 1, mongo_link);
perl_mongo_attach_ptr_to_instance(self, self_link, &connection_vtbl);
master_link = (mongo_link*)perl_mongo_get_ptr_from_instance(master, &connection_vtbl);
self_link->master = master_link->master;
self_link->copy = 1;
self_link->ssl = master_link->ssl;
#ifdef MONGO_SSL
self_link->ssl_handle = master_link->ssl_handle;
self_link->ssl_context = master_link->ssl_context;
#endif
self_link->sender = master_link->sender;
self_link->receiver = master_link->receiver;
void
connect (self)
SV *self
PREINIT:
mongo_link *link = (mongo_link*)perl_mongo_get_ptr_from_instance(self, &connection_vtbl);
SV *username, *password;
CODE:
perl_mongo_connect(link);
if (!link->master->connected) {
croak ("couldn't connect to server %s:%d", link->master->host, link->master->port);
}
// try authentication
username = perl_mongo_call_reader (self, "username");
password = perl_mongo_call_reader (self, "password");
if (SvPOK(username) && SvPOK(password)) {
SV *database, *result, **ok;
database = perl_mongo_call_reader (self, "db_name");
result = perl_mongo_call_method(self, "authenticate", 0, 3, database, username, password);
if (!result) {
SvREFCNT_dec(database);
SvREFCNT_dec(username);
SvREFCNT_dec(password);
croak("authentication returned no result");
}
// we're expecting either a string (failure) or a hash (success hopefully)
if (SvPOK(result)) {
SvREFCNT_dec(database);
SvREFCNT_dec(username);
SvREFCNT_dec(password);
croak("%s", SvPV_nolen(result));
} else if (SvROK(result)) {
ok = hv_fetch((HV*)SvRV(result), "ok", strlen("ok"), 0);
if (!ok || 1 != SvIV(*ok)) {
SvREFCNT_dec(database);
SvREFCNT_dec(username);
SvREFCNT_dec(password);
croak ("couldn't authenticate with server");
}
} else {
sv_dump(result);
SvREFCNT_dec(database);
SvREFCNT_dec(username);
SvREFCNT_dec(password);
croak("something weird happened with authentication");
}
SvREFCNT_dec(database);
}
SvREFCNT_dec(username);
SvREFCNT_dec(password);
int
connected(self)
SV *self
INIT:
mongo_link *link;
CODE:
link = (mongo_link*)perl_mongo_get_ptr_from_instance(self, &connection_vtbl);
if (link->master && link->master->connected) {
RETVAL = 1;
}
else {
RETVAL = 0;
}
OUTPUT:
RETVAL
int
send(self, str)
SV *self
SV *str
PREINIT:
buffer buf;
STRLEN len;
INIT:
buf.start = SvPV(str,len);
buf.pos = buf.start+len;
buf.end = buf.start+len;
CODE:
RETVAL = mongo_link_say(self, &buf);
if (RETVAL == -1) {
die("can't get db response, not connected");
}
OUTPUT:
RETVAL
void
recv(self, cursor)
SV *cursor
CODE:
mongo_link_hear(cursor);
void
DESTROY (self)
SV *self
PREINIT:
mongo_link *link;
CODE:
link = (mongo_link*)perl_mongo_get_ptr_from_instance(self, &connection_vtbl);
if (!link->copy && link->master) {
set_disconnected(self);
}