diff --git a/src/xmpp.f90 b/src/xmpp.f90 index 1b14bf3..a59f7c6 100644 --- a/src/xmpp.f90 +++ b/src/xmpp.f90 @@ -186,6 +186,7 @@ module xmpp public :: xmpp_disconnect public :: xmpp_error_new public :: xmpp_error_new_ + public :: xmpp_free public :: xmpp_free_sm_state public :: xmpp_free_sm_state_ public :: xmpp_get_default_logger @@ -244,6 +245,7 @@ module xmpp public :: xmpp_sha1_update public :: xmpp_sha1_update_ public :: xmpp_shutdown + public :: xmpp_sockopt_cb_keepalive public :: xmpp_stanza_add_child public :: xmpp_stanza_add_child_ex public :: xmpp_stanza_clone @@ -379,7 +381,7 @@ end subroutine xmpp_log_handler function xmpp_password_callback(pw, pw_max, conn, user_data) bind(c) import :: c_char, c_int, c_ptr, c_size_t implicit none - character(kind=c_char), intent(in) :: pw + type(c_ptr), intent(in), value :: pw integer(kind=c_size_t), intent(in), value :: pw_max type(c_ptr), intent(in), value :: conn type(c_ptr), intent(in), value :: user_data @@ -785,6 +787,14 @@ function xmpp_error_new_(ctx, type, text) bind(c, name='xmpp_error_new') type(c_ptr) :: xmpp_error_new_ end function xmpp_error_new_ + ! void xmpp_free(const xmpp_ctx_t *ctx, void *p) + subroutine xmpp_free(ctx, ptr) bind(c, name='xmpp_free') + import :: c_ptr + implicit none + type(c_ptr), intent(in), value :: ctx + type(c_ptr), intent(in), value :: ptr + end subroutine xmpp_free + ! void xmpp_free_sm_state(xmpp_sm_state_t *sm_state) subroutine xmpp_free_sm_state_(sm_state) bind(c, name='xmpp_free_sm_state') import :: c_ptr @@ -820,14 +830,14 @@ end subroutine xmpp_global_timed_handler_delete ! void xmpp_handler_add(xmpp_conn_t *conn, xmpp_handler handler, const char *ns, const char *name, const char *type, void *userdata) subroutine xmpp_handler_add_(conn, handler, ns, name, type, user_data) bind(c, name='xmpp_handler_add') - import :: c_char, c_ptr, xmpp_handler + import :: c_ptr, xmpp_handler implicit none - type(c_ptr), intent(in), value :: conn - procedure(xmpp_handler) :: handler - character(kind=c_char), intent(in) :: ns - character(kind=c_char), intent(in) :: name - character(kind=c_char), intent(in) :: type - type(c_ptr), intent(in), value :: user_data + type(c_ptr), intent(in), value :: conn + procedure(xmpp_handler) :: handler + type(c_ptr), intent(in), value :: ns + type(c_ptr), intent(in), value :: name + type(c_ptr), intent(in), value :: type + type(c_ptr), intent(in), value :: user_data end subroutine xmpp_handler_add_ ! void xmpp_handler_delete(xmpp_conn_t *conn, xmpp_handler handler) @@ -1117,6 +1127,15 @@ end subroutine xmpp_sha1_update_ subroutine xmpp_shutdown() bind(c, name='xmpp_shutdown') end subroutine xmpp_shutdown + ! int xmpp_sockopt_cb_keepalive(xmpp_conn_t *conn, void *sock) + function xmpp_sockopt_cb_keepalive(conn, sock) bind(c, name='xmpp_sockopt_cb_keepalive') + import :: c_int, c_ptr + implicit none + type(c_ptr), intent(in), value :: conn + type(c_ptr), intent(in), value :: sock + integer(kind=c_int) :: xmpp_sockopt_cb_keepalive + end function xmpp_sockopt_cb_keepalive + ! int xmpp_stanza_add_child(xmpp_stanza_t *stanza, xmpp_stanza_t *child) function xmpp_stanza_add_child(stanza, child) bind(c, name='xmpp_stanza_add_child') import :: c_int, c_ptr @@ -1558,6 +1577,7 @@ subroutine xmpp_base64_decode_bin(ctx, base64, len, out, out_len) call xmpp_base64_decode_bin_(ctx, base64, len, ptr, out_len) call c_f_str_ptr(ptr, out, out_len) + call xmpp_free(ctx, ptr) end subroutine xmpp_base64_decode_bin function xmpp_base64_decode_str(ctx, base64, len) @@ -1570,6 +1590,7 @@ function xmpp_base64_decode_str(ctx, base64, len) ptr = xmpp_base64_decode_str_(ctx, base64, len) call c_f_str_ptr(ptr, xmpp_base64_decode_str) + call xmpp_free(ctx, ptr) end function xmpp_base64_decode_str function xmpp_base64_encode(ctx, data, len) @@ -1582,6 +1603,7 @@ function xmpp_base64_encode(ctx, data, len) ptr = xmpp_base64_encode_(ctx, data, len) call c_f_str_ptr(ptr, xmpp_base64_encode) + call xmpp_free(ctx, ptr) end function xmpp_base64_encode function xmpp_conn_cert_xmppaddr(conn, n) @@ -1772,6 +1794,8 @@ function xmpp_error_new(ctx, type, text) end function xmpp_error_new subroutine xmpp_handler_add(conn, handler, ns, name, type, user_data) + !! Wrapper routine that passed null-terminated strings or `NULL` to + !! interface. type(c_ptr), intent(in) :: conn procedure(xmpp_handler) :: handler character(len=*), intent(in) :: ns @@ -1779,7 +1803,32 @@ subroutine xmpp_handler_add(conn, handler, ns, name, type, user_data) character(len=*), intent(in) :: type type(c_ptr), intent(in) :: user_data - call xmpp_handler_add_(conn, handler, ns // c_null_char, name // c_null_char, type // c_null_char, user_data) + character(len=len(ns) + 1), target :: ns_str + character(len=len(name) + 1), target :: name_str + character(len=len(type) + 1), target :: type_str + + type(c_ptr) :: ns_ptr, name_ptr, type_ptr + + ns_ptr = c_null_ptr + name_ptr = c_null_ptr + type_ptr = c_null_ptr + + if (len_trim(ns) > 0) then + ns_str = ns // c_null_char + ns_ptr = c_loc(ns_str) + end if + + if (len_trim(name) > 0) then + name_str = name // c_null_char + name_ptr = c_loc(name_str) + end if + + if (len_trim(type) > 0) then + type_str = type // c_null_char + type_ptr = c_loc(type_str) + end if + + call xmpp_handler_add_(conn, handler, ns_ptr, name_ptr, type_ptr, user_data) end subroutine xmpp_handler_add subroutine xmpp_id_handler_add(conn, handler, id, user_data) @@ -1817,6 +1866,7 @@ function xmpp_jid_bare(ctx, jid) ptr = xmpp_jid_bare_(ctx, jid // c_null_char) call c_f_str_ptr(ptr, xmpp_jid_bare) + call xmpp_free(ctx, ptr) end function xmpp_jid_bare function xmpp_jid_domain(ctx, jid) @@ -1828,6 +1878,7 @@ function xmpp_jid_domain(ctx, jid) ptr = xmpp_jid_domain_(ctx, jid // c_null_char) call c_f_str_ptr(ptr, xmpp_jid_domain) + call xmpp_free(ctx, ptr) end function xmpp_jid_domain function xmpp_jid_new(ctx, node, domain, resource) @@ -1841,6 +1892,7 @@ function xmpp_jid_new(ctx, node, domain, resource) ptr = xmpp_jid_new_(ctx, node // c_null_char, domain // c_null_char, resource // c_null_char) call c_f_str_ptr(ptr, xmpp_jid_new) + call xmpp_free(ctx, ptr) end function xmpp_jid_new function xmpp_jid_node(ctx, jid) @@ -1852,6 +1904,7 @@ function xmpp_jid_node(ctx, jid) ptr = xmpp_jid_node_(ctx, jid // c_null_char) call c_f_str_ptr(ptr, xmpp_jid_node) + call xmpp_free(ctx, ptr) end function xmpp_jid_node function xmpp_jid_resource(ctx, jid) @@ -1863,9 +1916,13 @@ function xmpp_jid_resource(ctx, jid) ptr = xmpp_jid_resource_(ctx, jid // c_null_char) call c_f_str_ptr(ptr, xmpp_jid_resource) + call xmpp_free(ctx, ptr) end function xmpp_jid_resource - function xmpp_message_get_body(msg) + function xmpp_message_get_body(ctx, msg) + !! In contrast to the libstrophe API, this wrapper functions requires + !! the context to be passed to free the C string. + type(c_ptr), intent(in) :: ctx type(c_ptr), intent(in) :: msg character(len=:), allocatable :: xmpp_message_get_body @@ -1873,6 +1930,7 @@ function xmpp_message_get_body(msg) ptr = xmpp_message_get_body_(msg) call c_f_str_ptr(ptr, xmpp_message_get_body) + call xmpp_free(ctx, ptr) end function xmpp_message_get_body function xmpp_message_new(ctx, type, to, id) @@ -2072,6 +2130,7 @@ function xmpp_stanza_get_text(stanza) ptr = xmpp_stanza_get_text_(stanza) call c_f_str_ptr(ptr, xmpp_stanza_get_text) + call xmpp_free(xmpp_stanza_get_context(stanza), ptr) end function xmpp_stanza_get_text function xmpp_stanza_get_text_ptr(stanza) @@ -2247,5 +2306,6 @@ function xmpp_uuid_gen(ctx) ptr = xmpp_uuid_gen_(ctx) call c_f_str_ptr(ptr, xmpp_uuid_gen) + call xmpp_free(ctx, ptr) end function xmpp_uuid_gen end module xmpp diff --git a/src/xmpp_macro.c b/src/xmpp_macro.c index c90c032..446d930 100644 --- a/src/xmpp_macro.c +++ b/src/xmpp_macro.c @@ -5,6 +5,8 @@ extern "C" { #endif +void xmpp_send_raw_string_(xmpp_conn_t *, const char *); + /* Non-variadic wrappers. */ void xmpp_send_raw_string_(xmpp_conn_t *conn, const char *str) { diff --git a/src/xmpp_util.f90 b/src/xmpp_util.f90 index 1453441..296ef2c 100644 --- a/src/xmpp_util.f90 +++ b/src/xmpp_util.f90 @@ -7,7 +7,28 @@ module xmpp_util implicit none (type, external) private + interface + ! void *memcpy(void *dst, const void *src, size_t len) + subroutine c_memcpy(dst, src, len) bind(c, name='memcpy') + import :: c_ptr, c_size_t + implicit none + type(c_ptr), intent(in), value :: dst + type(c_ptr), intent(in), value :: src + integer(kind=c_size_t), intent(in), value :: len + end subroutine c_memcpy + + ! size_t strlen(const char *str) + function c_strlen(str) bind(c, name='strlen') + import :: c_ptr, c_size_t + implicit none + type(c_ptr), intent(in), value :: str + integer(kind=c_size_t) :: c_strlen + end function c_strlen + end interface + public :: c_f_str_ptr + public :: c_memcpy + public :: c_strlen contains subroutine c_f_str_ptr(c_str, f_str, size) !! Copies a C string, passed as a C pointer, to a Fortran string. @@ -18,16 +39,6 @@ subroutine c_f_str_ptr(c_str, f_str, size) character(kind=c_char), pointer :: ptrs(:) integer(kind=c_size_t) :: i, sz - interface - ! size_t strlen(const char *str) - function c_strlen(str) bind(c, name='strlen') - import :: c_ptr, c_size_t - implicit none - type(c_ptr), intent(in), value :: str - integer(kind=c_size_t) :: c_strlen - end function c_strlen - end interface - copy_if: if (c_associated(c_str)) then if (present(size)) then sz = size