Curl.xs

/* vim: ts=4:sw=4:fdm=marker

 *
 * Perl interface for libcurl. Check out the file README for more info.
 */

/*
 * Copyright (C) 2000, 2001, 2002, 2005, 2008 Daniel Stenberg, Cris Bailiff, et al.
 * Copyright (C) 2011-2015 Przemyslaw Iskra.
 * You may opt to use, copy, modify, merge, publish, distribute and/or
 * sell copies of the Software, and permit persons to whom the
 * Software is furnished to do so, under the terms of the MPL or
 * the MIT/X-derivate licenses. You may pick one of these licenses.
 */
#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"

/* Implement perl5 7169efc77525df for older perls (part 1): */
#define STMT_START  do
#define STMT_END    while (0)

#include "perl.h"
#include "XSUB.h"

/* Implement perl5 7169efc77525df for older perls (part 2): */
#undef STMT_START
#undef STMT_END
#define STMT_START  do
#define STMT_END    while (0)

#include <curl/curl.h>
#include <curl/easy.h>
#include <curl/multi.h>
#include "const-defenums-h.inc"

#ifndef LIBCURL_COPYRIGHT
# define LIBCURL_COPYRIGHT "1996 - 2013 Daniel Stenberg, <daniel@haxx.se>."
#endif

#ifndef LIBCURL_TIMESTAMP
# define LIBCURL_TIMESTAMP "DEV"
#endif

#ifndef Newx
# define Newx(v,n,t)	New(0,v,n,t)
# define Newxc(v,n,t,c)	Newc(0,v,n,t,c)
# define Newxz(v,n,t)	Newz(0,v,n,t)
#endif

#ifndef hv_stores
# define hv_stores(hv,key,val) hv_store( hv, key, sizeof( key ) - 1, val, 0 )
#endif
#ifndef hv_fetchs
# define hv_fetchs(hv,key,store) hv_fetch( hv, key, sizeof( key ) - 1, store );
#endif

#ifndef CLEAR_ERRSV
# define CLEAR_ERRSV()					\
	STMT_START {						\
		sv_setpvn( ERRSV, "", 0 );		\
		if ( SvMAGICAL( ERRSV ) )		\
			mg_free( ERRSV );			\
		SvPOK_only( ERRSV );			\
	} STMT_END
#endif

#ifndef croak_sv
# define croak_sv( arg )		\
	STMT_START {				\
		SvSetSV( ERRSV, arg );	\
		croak( NULL );			\
	} STMT_END
#endif

#define die_code( pkg, num )			\
	STMT_START {						\
		SV *errsv = sv_newmortal();		\
		sv_setref_iv( errsv, "Net::Curl::" pkg "::Code", num ); \
		croak_sv( errsv );				\
	} STMT_END


#ifndef mPUSHs
# define mPUSHs( sv ) PUSHs( sv_2mortal( sv ) )
#endif
#ifndef mXPUSHs
# define mXPUSHs( sv ) XPUSHs( sv_2mortal( sv ) )
#endif
#ifndef PTR2nat
# define PTR2nat(p)	(PTRV)(p)
#endif

/*
 * Convenient way to copy SVs
 */
#define SvREPLACE( dst, src ) \
	STMT_START {						\
		SV *src_ = (src);				\
		if ( dst )						\
			sv_2mortal( dst );			\
		if ( (src_) && SvOK( src_ ) )	\
			dst = newSVsv( src_ );		\
		else							\
			dst = NULL;					\
	} STMT_END

/*
 * create a reference for perl callbacks
 */
#define SELF2PERL( obj ) \
	sv_bless( newRV_inc( (obj)->perl_self ), SvSTASH( (obj)->perl_self ) )

typedef struct {
	/* function that will be called */
	SV *func;

	/* user data */
	SV *data;
} callback_t;

typedef struct simplell_s simplell_t;
struct simplell_s {
	/* next in the linked list */
	simplell_t *next;

	/* curl option it belongs to */
	PTRV key;

	/* the actual data */
	void *value;
};

//----------------------------------------------------------------------

typedef enum {
	CB_MULTI_SOCKET = 0,
	CB_MULTI_TIMER,
	CB_MULTI_LAST,
} perl_curl_multi_callback_code_t;

struct perl_curl_multi_s {
	/* last seen version of this object */
	SV *perl_self;

	/* curl multi handle */
	CURLM *handle;

	/* list of callbacks */
	callback_t cb[ CB_MULTI_LAST ];

	/* list of data assigned to sockets */
	/* key: socket fd; value: user sv */
	simplell_t *socket_data;

	/* list of easy handles attached to this multi */
	/* key: our easy pointer, value: easy SV */
	simplell_t *easies;
};

//----------------------------------------------------------------------

typedef struct perl_curl_easy_s perl_curl_easy_t;
typedef struct perl_curl_form_s perl_curl_form_t;
typedef struct perl_curl_share_s perl_curl_share_t;
typedef struct perl_curl_multi_s perl_curl_multi_t;

static struct curl_slist *
perl_curl_array2slist( pTHX_ struct curl_slist *slist, SV *arrayref )
{
	AV *array;
	int array_len, i;

	if ( !SvOK( arrayref ) || !SvROK( arrayref ) )
		croak( "not an array" );

	array = (AV *) SvRV( arrayref );
	array_len = av_len( array );

	for ( i = 0; i <= array_len; i++ ) {
		SV **sv;
		char *string;

		sv = av_fetch( array, i, 0 );
		if ( !SvOK( *sv ) )
			continue;
		string = SvPV_nolen( *sv );
		slist = curl_slist_append( slist, string );
	}

	return slist;
}

#if 0
static void *
perl_curl_simplell_get( pTHX_ simplell_t *start, PTRV key )
{
	simplell_t *now = start;

	if ( now == NULL )
		return NULL;

	while ( now ) {
		if ( now->key == key )
			return &(now->value);
		if ( now->key > key )
			return NULL;
		now = now->next;
	}

	return NULL;
}
#endif


static void *
perl_curl_simplell_add( pTHX_ simplell_t **start, PTRV key )
{
	simplell_t **now = start;
	simplell_t *tmp = NULL;

	while ( *now ) {
		if ( (*now)->key == key )
			return &( (*now)->value );
		if ( (*now)->key > key )
			break;
		now = &( (*now)->next );
	}

	tmp = *now;
	Newx( *now, 1, simplell_t );
	(*now)->next = tmp;
	(*now)->key = key;
	(*now)->value = NULL;

	return &( (*now)->value );
}

static void *
perl_curl_simplell_del( pTHX_ simplell_t **start, PTRV key )
{
	simplell_t **now = start;

	while ( *now ) {
		if ( (*now)->key == key ) {
			void *ret = (*now)->value;
			simplell_t *tmp = *now;
			*now = (*now)->next;
			Safefree( tmp );
			return ret;
		}
		if ( (*now)->key > key )
			return NULL;
		now = &( (*now)->next );
	}
	return NULL;
}

#define SIMPLELL_FREE( list, freefunc )			\
	STMT_START {								\
		if ( list ) {							\
			simplell_t *next, *now = list;		\
			do {								\
				next = now->next;				\
				freefunc( now->value );			\
				Safefree( now );				\
			} while ( ( now = next ) != NULL );	\
		}										\
	} STMT_END


/* generic function for our callback calling needs */
static IV
perl_curl_call( pTHX_ callback_t *cb, int argnum, SV **args )
{
	dSP;
	int i;
	IV status;
	SV *olderrsv = NULL;
	int method_call = 0;

	if ( ! cb->func || ! SvOK( cb->func ) ) {
		warn( "callback function is not set\n" );
		return -1;
	} else if ( SvROK( cb->func ) )
		method_call = 0;
	else if ( SvPOK( cb->func ) )
		method_call = 1;
	else {
		warn( "Don't know how to call the callback\n" );
		return -1;
	}

	ENTER;
	SAVETMPS;

	PUSHMARK( SP );

	EXTEND( SP, argnum );
	for ( i = 0; i < argnum; i++ )
		mPUSHs( args[ i ] );

	if ( cb->data )
		mXPUSHs( newSVsv( cb->data ) );

	PUTBACK;

	if ( SvTRUE( ERRSV ) )
		olderrsv = sv_2mortal( newSVsv( ERRSV ) );

	if ( method_call )
		call_method( SvPV_nolen( cb->func ), G_SCALAR | G_EVAL );
	else
		call_sv( cb->func, G_SCALAR | G_EVAL );

	SPAGAIN;

	if ( SvTRUE( ERRSV ) ) {
		/* cleanup after the error */
		(void) POPs;
		status = -1;
	} else {
		status = POPi;
	}

	if ( olderrsv )
		sv_setsv( ERRSV, olderrsv );

	PUTBACK;
	FREETMPS;
	LEAVE;

	return status;
}

#define PERL_CURL_CALL( cb, arg ) \
	perl_curl_call( aTHX_ (cb), sizeof( arg ) / sizeof( (arg)[0] ), (arg) )


static int
perl_curl_any_magic_nodup( pTHX_ MAGIC *mg, CLONE_PARAMS *param )
{
	warn( "Net::Curl::(Easy|Form|Multi) does not support cloning\n" );
	mg->mg_ptr = NULL;
	return 1;
}

static void *
perl_curl_getptr( pTHX_ SV *self, MGVTBL *vtbl )
{
	MAGIC *mg;

	if ( !self )
		return NULL;

	if ( !SvOK( self ) )
		return NULL;

	if ( !SvROK( self ) )
		return NULL;

	if ( !sv_isobject( self ) )
		return NULL;

	for ( mg = SvMAGIC( SvRV( self ) ); mg != NULL; mg = mg->mg_moremagic ) {
		if ( mg->mg_type == PERL_MAGIC_ext && mg->mg_virtual == vtbl )
			return mg->mg_ptr;
	}

	return NULL;
}


static void *
perl_curl_getptr_fatal( pTHX_ SV *self, MGVTBL *vtbl, const char *name,
		const char *type )
{
	void *ret;
	SV **perl_self;

	if ( ! sv_derived_from( self, type ) )
		croak( "'%s' is not a %s object", name, type );

	ret = perl_curl_getptr( aTHX_ self, vtbl );

	if ( ret == NULL )
		croak( "'%s' is an invalid %s object", name, type );

	/*
	 * keep alive: this trick makes sure user will not destroy last
	 * existing reference from inside of a callback.
	 */
	perl_self = ret;
	if ( perl_self && *perl_self )
		sv_2mortal( newRV_inc( *perl_self ) );

	return ret;
}


static void
perl_curl_setptr( pTHX_ SV *self, MGVTBL *vtbl, void *ptr )
{
	MAGIC *mg;

	if ( perl_curl_getptr( aTHX_ self, vtbl ) )
		croak( "object already has our pointer" );

	mg = sv_magicext( SvRV( self ), 0, PERL_MAGIC_ext,
		vtbl, (const char *) ptr, 0 );
	mg->mg_flags |= MGf_DUP;
}


/* code shamelessly stolen from ExtUtils::Constant */
static void
perl_curl_constant_add( pTHX_ HV *hash, const char *name, I32 namelen,
		SV *value )
{
#if PERL_REVISION == 5 && PERL_VERSION >= 9
	SV **sv = hv_fetch( hash, name, namelen, TRUE );
	if ( !sv )
		croak( "Could not add key '%s' to %%Net::Curl::", name );

	if ( SvOK( *sv ) || SvTYPE( *sv ) == SVt_PVGV ) {
		newCONSTSUB( hash, name, value );
	} else {
#pragma clang diagnostic push
#pragma clang diagnostic ignored "-Wunused-value"
		SvUPGRADE( *sv, SVt_RV );
#pragma clang diagnostic pop
		SvRV_set( *sv, value );
		SvROK_on( *sv );
		SvREADONLY_on( value );
	}
#else
	newCONSTSUB( hash, (char *)name, value );
#endif
}

struct iv_s {
	const char *name;
	I32 namelen;
	IV value;
};
#define IV_CONST( c ) \
	{ #c, sizeof( #c ) - 1, c }
struct pv_s {
	const char *name;
	I32 namelen;
	const char *value;
	I32 valuelen;
};
#define PV_CONST( c ) \
	{ #c, sizeof( #c ) - 1, c, sizeof( c ) - 1 }


typedef perl_curl_easy_t *Net__Curl__Easy;
typedef perl_curl_form_t *Net__Curl__Form;
typedef perl_curl_multi_t *Net__Curl__Multi;
typedef perl_curl_share_t *Net__Curl__Share;

/* default base object */
#define HASHREF_BY_DEFAULT		sv_2mortal( newRV_noinc( (SV *) newHV() ) )

#include "curl-Easy-c.inc"
#include "curl-Form-c.inc"
#include "curl-Multi-c.inc"
#include "curl-Share-c.inc"
#include "Curl_Easy_setopt.c"

MODULE = Net::Curl	PACKAGE = Net::Curl

BOOT:
	{
		/* XXX 1: this is _not_ thread safe */
		/* XXX 2: should never be called from a thread */
		static int run_once = 0;
		if ( !run_once++ ) {
			curl_global_init( CURL_GLOBAL_ALL );
			atexit( curl_global_cleanup );
		}
	}
	{
		dTHX;
		HV *symbol_table = get_hv( "Net::Curl::", GV_ADD );
		static const struct iv_s values_for_iv[] = {
			IV_CONST( LIBCURL_VERSION_MAJOR ),
			IV_CONST( LIBCURL_VERSION_MINOR ),
			IV_CONST( LIBCURL_VERSION_PATCH ),
			IV_CONST( LIBCURL_VERSION_NUM ),
			{ NULL, 0, 0 }
		};
		static const struct pv_s values_for_pv[] = {
			PV_CONST( LIBCURL_COPYRIGHT ),
			PV_CONST( LIBCURL_VERSION ),
			PV_CONST( LIBCURL_TIMESTAMP ),
			{ NULL, 0, NULL, 0 }
		};
		const struct iv_s *value_for_iv = values_for_iv;
		const struct pv_s *value_for_pv = values_for_pv;
		while ( value_for_iv->name ) {
			perl_curl_constant_add( aTHX_ symbol_table,
				value_for_iv->name, value_for_iv->namelen,
				newSViv( value_for_iv->value ) );
			++value_for_iv;
		}
		while ( value_for_pv->name ) {
			perl_curl_constant_add( aTHX_ symbol_table,
				value_for_pv->name, value_for_pv->namelen,
				newSVpvn( value_for_pv->value, value_for_pv->valuelen ) );
			++value_for_pv;
		}


		++PL_sub_generation;
	}

PROTOTYPES: ENABLE

INCLUDE: const-curl-xs.inc

time_t
getdate( timedate )
	char *timedate
	CODE:
		RETVAL = curl_getdate( timedate, NULL );
	OUTPUT:
		RETVAL

char *
version()
	CODE:
		RETVAL = curl_version();
	OUTPUT:
		RETVAL


SV *
version_info()
	PREINIT:
		const curl_version_info_data *vi;
		HV *ret;
	CODE:
		/* {{{ */
		vi = curl_version_info( CURLVERSION_NOW );
		if ( vi == NULL )
			croak( "curl_version_info() returned NULL\n" );
		ret = newHV();

		(void) hv_stores( ret, "age", newSViv( vi->age ) );
		if ( vi->age >= CURLVERSION_FIRST ) {
			if ( vi->version )
				(void) hv_stores( ret, "version", newSVpv( vi->version, 0 ) );
			(void) hv_stores( ret, "version_num", newSVuv( vi->version_num ) );
			if ( vi->host )
				(void) hv_stores( ret, "host", newSVpv( vi->host, 0 ) );
			(void) hv_stores( ret, "features", newSViv( vi->features ) );
			if ( vi->ssl_version )
				(void) hv_stores( ret, "ssl_version", newSVpv( vi->ssl_version, 0 ) );
			(void) hv_stores( ret, "ssl_version_num", newSViv( vi->ssl_version_num ) );
			if ( vi->libz_version )
				(void) hv_stores( ret, "libz_version", newSVpv( vi->libz_version, 0 ) );
			if ( vi->protocols ) {
				const char * const *p = vi->protocols;
				AV *prot;
				prot = (AV *) sv_2mortal( (SV *) newAV() );
				while ( *p != NULL ) {
					av_push( prot, newSVpv( *p, 0 ) );
					p++;
				}

				(void) hv_stores( ret, "protocols", newRV( (SV*) prot ) );
			}
		}
		if ( vi->age >= CURLVERSION_SECOND ) {
			if ( vi->ares )
				(void) hv_stores( ret, "ares", newSVpv( vi->ares, 0 ) );
			(void) hv_stores( ret, "ares_num", newSViv( vi->ares_num ) );
		}
		if ( vi->age >= CURLVERSION_THIRD ) {
			if ( vi->libidn )
				(void) hv_stores( ret, "libidn", newSVpv( vi->libidn, 0 ) );
		}
#ifdef CURLVERSION_FOURTH
		if ( vi->age >= CURLVERSION_FOURTH ) {
			(void) hv_stores( ret, "iconv_ver_num", newSViv( vi->iconv_ver_num ) );
			if ( vi->libssh_version )
				(void) hv_stores( ret, "libssh_version", newSVpv( vi->libssh_version, 0 ) );
		}
#endif

		RETVAL = newRV( (SV *) ret );
		/* }}} */
	OUTPUT:
		RETVAL


INCLUDE: curl-Easy-xs.inc
INCLUDE: curl-Form-xs.inc
INCLUDE: curl-Multi-xs.inc
INCLUDE: curl-Share-xs.inc