view release on metacpan or  search on metacpan

Curl_Easy.xsh  view on Meta::CPAN

	SIMPLELL_FREE( easy->strings, Safefree );
	SIMPLELL_FREE( easy->slists, curl_slist_free_all );

	if ( easy->form_sv )
		sv_2mortal( easy->form_sv );
} /*}}}*/

static inline CURLMcode
perl_curl_easy_remove_from_multi( pTHX_  perl_curl_easy_t* easy )
{
	CURLMcode ret = CURLM_OK;

	if (easy->multi) {
		/* NB: We remove easy from multi->easies BEFORE calling
		   curl_multi_remove_handle(). See below for details.
		*/

		{
			SV *easysv;
			easysv = perl_curl_simplell_del( aTHX_ &easy->multi->easies,
				PTR2nat( easy ) );
			if ( !easysv )
				croak( "internal Net::Curl error" );
			sv_2mortal( easysv );
		}

		/* In certain cases curl_multi_remove_handle() invokes a callback
		   that may decrement the multi SV’s reference count, which triggers
		   Perl’s garbage collection, which frees the multi while curl
		   is in the middle of removing an easy from it, which in turn
		   triggers a segfault.

		   We avoid that by incrementing/decrementing the reference count.
		*/
		SvREFCNT_inc( easy->multi->perl_self );

		ret = curl_multi_remove_handle( easy->multi->handle, easy->handle );

		/* As described above: */
		SvREFCNT_dec( easy->multi->perl_self );

		easy->multi = NULL;
	}

	return ret;
}

static void
perl_curl_easy_delete( pTHX_ perl_curl_easy_t *easy )
/*{{{*/ {

	/* this may trigger a callback,
	 * we want it while easy handle is still alive */
	curl_easy_setopt( easy->handle, CURLOPT_SHARE, NULL );

	/* when using multi handle, the connection may stay open in that multi,
	 * but the easy will be long dead. In case of ftp for instance, connection
	 * closing will send a trailer with no apparent destination */
	/* this also disables header callback if not using multi, SORRY */
	curl_easy_setopt( easy->handle, CURLOPT_HEADERFUNCTION, NULL );
	curl_easy_setopt( easy->handle, CURLOPT_WRITEHEADER, NULL );

	/* If Perl reaps an easy and its multi "together", there is a
	 * chance Perl might clear the easy first, leading to a segfault when
	 * the multi tries to remove an easy that is already cleaned up.
	 * This prevents that. */
	perl_curl_easy_remove_from_multi( aTHX_ easy );

	if ( easy->handle )
		curl_easy_cleanup( easy->handle );

	perl_curl_easy_delete_mostly( aTHX_ easy );

	if ( easy->share_sv )
		sv_2mortal( easy->share_sv );

	Safefree( easy );

} /*}}}*/

static int
perl_curl_easy_magic_free( pTHX_ SV *sv, MAGIC *mg )
{
	if ( mg->mg_ptr ) {
		/* prevent recursive destruction */
		SvREFCNT( sv ) = 1 << 30;

		perl_curl_easy_delete( aTHX_ (void *)mg->mg_ptr );

		SvREFCNT( sv ) = 0;
	}
	return 0;
}

static MGVTBL perl_curl_easy_vtbl = {
	NULL, NULL, NULL, NULL
	,perl_curl_easy_magic_free
	,NULL
	,perl_curl_any_magic_nodup
#ifdef MGf_LOCAL
	,NULL
#endif
};

static void
perl_curl_easy_preset( perl_curl_easy_t *easy )
{
	/* configure curl to always callback to the XS interface layer */
	curl_easy_setopt( easy->handle, CURLOPT_WRITEFUNCTION, cb_easy_write );
	curl_easy_setopt( easy->handle, CURLOPT_READFUNCTION, cb_easy_read );

	/* set our own object as the context for all curl callbacks */
	curl_easy_setopt( easy->handle, CURLOPT_FILE, easy );
	curl_easy_setopt( easy->handle, CURLOPT_INFILE, easy );

	/* we always collect this, in case it's wanted */
	curl_easy_setopt( easy->handle, CURLOPT_ERRORBUFFER, easy->errbuf );

	curl_easy_setopt( easy->handle, CURLOPT_PRIVATE, (void *) easy );
}

#define EASY_DIE( ret )			\
	STMT_START {				\
		CURLcode code = (ret);	\
		if ( code != CURLE_OK )	\
			die_code( "Easy", code ); \
	} STMT_END


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

INCLUDE: const-easy-xs.inc

PROTOTYPES: ENABLE

void
new( sclass="Net::Curl::Easy", base=HASHREF_BY_DEFAULT )
	const char *sclass
	SV *base
	PREINIT:
		perl_curl_easy_t *easy;
		HV *stash;
	PPCODE:
		if ( ! SvOK( base ) || ! SvROK( base ) )
			croak( "object base must be a valid reference\n" );

		easy = perl_curl_easy_new();
		perl_curl_easy_preset( easy );

		perl_curl_setptr( aTHX_ base, &perl_curl_easy_vtbl, easy );
		stash = gv_stashpv( sclass, 0 );
		ST(0) = sv_bless( base, stash );

		easy->perl_self = SvRV( ST(0) );

		XSRETURN(1);


void
duphandle( easy, base=HASHREF_BY_DEFAULT )
	Net::Curl::Easy easy
	SV *base
	PREINIT:
		perl_curl_easy_t *clone;
		const char *sclass;
		perl_curl_easy_callback_code_t i;
		HV *stash;
	PPCODE:
		if ( ! SvOK( base ) || ! SvROK( base ) )
			croak( "object base must be a valid reference\n" );

		sclass = sv_reftype( SvRV( ST(0) ), TRUE );
		clone = perl_curl_easy_duphandle( easy );

		perl_curl_easy_preset( clone );

		if ( easy->cb[ CB_EASY_HEADER ].func
				|| easy->cb[ CB_EASY_HEADER ].data ) {
			curl_easy_setopt( clone->handle, CURLOPT_HEADERFUNCTION, cb_easy_header );
			curl_easy_setopt( clone->handle, CURLOPT_WRITEHEADER, clone );
		}

		if ( easy->cb[ CB_EASY_PROGRESS ].func ) {
			curl_easy_setopt( clone->handle, CURLOPT_PROGRESSFUNCTION, cb_easy_progress );
			curl_easy_setopt( clone->handle, CURLOPT_PROGRESSDATA, clone );
		}
		//
#ifdef CURLOPT_XFERINFOFUNCTION
# ifdef CURLOPT_XFERINFODATA
		if ( easy->cb[ CB_EASY_XFERINFO ].func ) {
			curl_easy_setopt( clone->handle, CURLOPT_XFERINFOFUNCTION, cb_easy_xferinfo );
			curl_easy_setopt( clone->handle, CURLOPT_XFERINFODATA, clone );
		}
# endif
#endif

		if ( easy->cb[ CB_EASY_DEBUG ].func ) {
			curl_easy_setopt( clone->handle, CURLOPT_DEBUGFUNCTION, cb_easy_debug );
			curl_easy_setopt( clone->handle, CURLOPT_DEBUGDATA, clone );
		}

		for( i = 0; i < CB_EASY_LAST; i++ ) {
			SvREPLACE( clone->cb[i].func, easy->cb[i].func );
			SvREPLACE( clone->cb[i].data, easy->cb[i].data );
		};

		/* clone strings and set */
		if ( easy->strings ) {
			simplell_t *in, **out;
			in = easy->strings;
			out = &clone->strings;
			do {
				Newx( *out, 1, simplell_t );
				(*out)->next = NULL;
				(*out)->key = in->key;
				(*out)->value = savepv( in->value );

				curl_easy_setopt( clone->handle, in->key, (*out)->value );
				out = &(*out)->next;
				in = in->next;
			} while ( in != NULL );
		}

		/* clone slists and set */
		if ( easy->slists ) {
			simplell_t *in, **out;
			struct curl_slist *sin, *sout;
			in = easy->slists;
			out = &clone->slists;
			do {
				Newx( *out, 1, simplell_t );
				sout = NULL;
				sin = in->value;
				do {
					sout = curl_slist_append( sout, sin->data );
				} while ( ( sin = sin->next ) != NULL );

				(*out)->next = NULL;
				(*out)->key = in->key;
				(*out)->value = sout;