path: root/perl/Curl_easy/easy.xs

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

Copyright (C) 2000, Daniel Stenberg, , et al.  
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.                                             
*/

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

#include <curl/curl.h>
#include <curl/easy.h>

#if (LIBCURL_VERSION_NUM<0x070702)
#define CURLOPT_HEADERFUNCTION 20079
#define header_callback_func write_callback_func
#else
#define header_callback_func writeheader_callback_func
#endif

/* Lists that can be set via curl_easy_setopt() */

static struct curl_slist *httpheader = NULL, *quote = NULL, *postquote = NULL;


/* Buffer and varname for option CURLOPT_ERRORBUFFER */

static char errbuf[CURL_ERROR_SIZE];
static char *errbufvarname = NULL;


/* Callback functions */

static SV *read_callback = NULL, *write_callback = NULL,
          *progress_callback = NULL, *passwd_callback = NULL,
	  *header_callback = NULL; 
	  /* *closepolicy_callback = NULL; */


/* For storing the content */

static char *contbuf = NULL, *bufptr = NULL;
static int bufsize = 32768, contlen = 0;


/* Internal options for this perl module */

#define USE_INTERNAL_VARS 0x01

static int internal_options = 0;


/* Setup these global vars */

static void init_globals(void)
{
    if (httpheader) curl_slist_free_all(httpheader);
    if (quote) curl_slist_free_all(quote);
    if (postquote) curl_slist_free_all(postquote);
    httpheader = quote = postquote = NULL;
    if (errbufvarname) free(errbufvarname);
    errbufvarname = NULL;
    if (contbuf == NULL) {
	contbuf = malloc(bufsize + 1);
    }
    bufptr = contbuf;
    *bufptr = '\0';
    contlen = 0;
    internal_options = 0;
}


/* Register a callback function */

static void register_callback(SV **callback, SV *function)
{
    if (*callback == NULL) {
	/* First time, create new SV */
	*callback = newSVsv(function);
    } else {
	/* Been there, done that. Just overwrite the SV */
	SvSetSV(*callback, function);
    }
}

/* generic fwrite callback, which decides which callback to call */
static size_t
fwrite_wrapper (const void *ptr,
		size_t size,
		size_t nmemb,
		void *stream,
		void *call_function)
{
    dSP;
    int count, status;
    SV *sv;

    if (call_function) {
	/* then we are doing a callback to perl */

	ENTER;
	SAVETMPS;

	PUSHMARK(SP);

	if (stream == stdout) {
	    sv = newSViv(0);	/* FIXME: should cast stdout to GLOB somehow? */
	} else if (stream == NULL) {
            sv = &PL_sv_undef;
        } else {		/* its already an SV */
	    sv = stream;
	}

	if (ptr != NULL) {
	    XPUSHs(sv_2mortal(newSVpvn((char *)ptr, (STRLEN)(size * nmemb))));
	} else {
	    XPUSHs(sv_2mortal(newSVpv("", 0)));
	}
	XPUSHs(sv_2mortal(newSVsv(sv)));	/* CURLOPT_FILE SV* */
	PUTBACK;

	count = perl_call_sv((SV *) call_function, G_SCALAR);

	SPAGAIN;
	if (count != 1)
	    croak("Big trouble, perl_call_sv(write_callback) didn't return status\n");

	status = POPi;

	PUTBACK;

	FREETMPS;
	LEAVE;
	return status;

    } else {
	/* default to a normal 'fwrite' */
	/* stream could be a FILE * or an SV * */
        /* or NULL since libcurl-7.8.1pre3  */
	FILE *f;

	if (stream == stdout ||
            stream == NULL) { /* the only possible FILE ? Think so */
	    f = stream;
	} else {		/* its a GLOB */
	    f = IoIFP(sv_2io(stream));	/* may barf if not a GLOB */
	}

	if (f)
           return fwrite(ptr, size, nmemb, f);
	else
           return (size_t) size*nmemb;
    }
}

/* Write callback for calling a perl callback */
size_t
write_callback_func( const void *ptr, size_t size,
                                size_t nmemb, void *stream)
{
    return fwrite_wrapper(ptr,size,nmemb,stream,
        write_callback);
}

/* header callback for calling a perl callback */
size_t
writeheader_callback_func( const void *ptr, size_t size,
                              size_t nmemb, void *stream)
{
    return fwrite_wrapper(ptr,size,nmemb,stream,
        header_callback);
}

size_t
read_callback_func( void *ptr, size_t size,
                    size_t nmemb, void *stream)
{
    dSP ;

    int count;
    SV *sv;
    STRLEN len;
    size_t maxlen,mylen;
    char *p;

    maxlen = size*nmemb;

    if (read_callback) {
        /* we are doing a callback to perl */

        ENTER ;
        SAVETMPS ;
 
        PUSHMARK(SP) ;
	
        if (stream == stdin) {
            sv = newSViv(0); /* should cast stdin to GLOB somehow? */
        } else { /* its an SV */
            sv = stream;
        }
	
        XPUSHs(sv_2mortal(newSViv(maxlen))); /* send how many bytes please */
        XPUSHs(sv_2mortal(newSVsv(sv))); /* CURLOPT_INFILE SV*  */
        PUTBACK ;

        count = perl_call_sv(read_callback, G_SCALAR);
	 
        SPAGAIN;
        if (count != 1)
            croak("Big trouble, perl_call_sv(read_callback) didn't return data\n");

        sv = POPs;
        p = SvPV(sv,len);

        /* only allowed to return the number of bytes asked for */
        mylen = len<maxlen ? len : maxlen;
        memcpy(ptr,p,(size_t)mylen);
        PUTBACK ;
 
        FREETMPS ;
        LEAVE ;
        return (size_t) (mylen/size);
    } else {
       /* default to a normal 'fread' */
       /* stream could be a FILE * or an SV * */
       FILE *f;

       if (stream == stdin) { /* the only possible FILE ? Think so*/
           f = stream;
       } else { /* its a GLOB */
           f = IoIFP(sv_2io(stream)); /* may barf if not a GLOB */
       }

       return fread(ptr,size,nmemb,f);
    }
}

/* Porgress callback for calling a perl callback */

static int progress_callback_func(void *clientp, size_t dltotal, size_t dlnow,
    size_t ultotal, size_t ulnow)
{
    dSP;
    int count;

    ENTER;
    SAVETMPS;
    PUSHMARK(sp);
    if (clientp != NULL) {
	XPUSHs(sv_2mortal(newSVpv(clientp, 0)));
    } else {
	XPUSHs(sv_2mortal(newSVpv("", 0)));
    }
    XPUSHs(sv_2mortal(newSViv(dltotal)));
    XPUSHs(sv_2mortal(newSViv(dlnow)));
    XPUSHs(sv_2mortal(newSViv(ultotal)));
    XPUSHs(sv_2mortal(newSViv(ulnow)));
    PUTBACK;
    count = perl_call_sv(progress_callback, G_SCALAR);
    SPAGAIN;
    if (count != 1)
	croak("Big trouble, perl_call_sv(progress_callback) didn't return 1\n");
    count = POPi;
    PUTBACK;
    FREETMPS;
    LEAVE;
    return count;
}


/* Password callback for calling a perl callback */

static int passwd_callback_func(void *clientp, char *prompt, char *buffer,
    int buflen)
{
    dSP;
    int count;
    SV *sv;
    STRLEN len;
    size_t mylen;
    char *p;            

    ENTER;
    SAVETMPS;
    PUSHMARK(sp);
    if (clientp != NULL) {
        XPUSHs(sv_2mortal(newSVsv(clientp)));
    } else {
        XPUSHs(sv_2mortal(newSVpv("", 0)));
    }
    XPUSHs(sv_2mortal(newSVpv(prompt, 0)));
    XPUSHs(sv_2mortal(newSViv(buflen)));
    PUTBACK;
    count = perl_call_sv(passwd_callback, G_ARRAY);
    SPAGAIN;
    if (count != 2)
	croak("Big trouble, perl_call_sv(passwd_callback) didn't return status + data\n");

    sv = POPs;
    count = POPi;

    p = SvPV(sv,len);
 
    /* only allowed to return the number of bytes asked for */
    mylen = len<(buflen-1) ? len : (buflen-1);
    memcpy(buffer,p,mylen);
    buffer[buflen]=0; /* ensure C string terminates */

    PUTBACK;
    FREETMPS;
    LEAVE;
    return count;
}


#if 0
/* awaiting closepolicy prototype */
int 
closepolicy_callback_func(void *clientp)
{
   dSP;
   int argc, status;
   SV *pl_status;

   ENTER;
   SAVETMPS;

   PUSHMARK(SP);
   PUTBACK;

   argc = perl_call_sv(closepolicy_callback, G_SCALAR);
   SPAGAIN;

   if (argc != 1) {
      croak("Unexpected number of arguments returned from closefunction callback\n");
   }
   pl_status = POPs;
   status = SvTRUE(pl_status) ? 0 : 1;

   PUTBACK;
   FREETMPS;
   LEAVE;

   return status;
}
#endif



/* Internal write callback. Only used if USE_INTERNAL_VARS was specified */

static size_t internal_write_callback(char *data, size_t size, size_t num,
    FILE *fp)
{
    int i;

    size *= num;
    if ((contlen + size) >= bufsize) {
	bufsize *= 2;
	contbuf = realloc(contbuf, bufsize + 1);
	bufptr = contbuf + contlen;
    }
    contlen += size;
    for (i = 0; i < size; i++) {
	*bufptr++ = *data++;
    }
    *bufptr = '\0';
    return size;
}


static int
constant(char *name, int arg)
{
    errno = 0;
    if (strncmp(name, "CURLINFO_", 9) == 0) {
	name += 9;
	switch (*name) {
	case 'A':
	case 'B':
	case 'C':
	    if (strEQ(name, "CONNECT_TIME")) return CURLINFO_CONNECT_TIME;
	    if (strEQ(name, "CONTENT_LENGTH_DOWNLOAD")) return CURLINFO_CONTENT_LENGTH_DOWNLOAD;
	    if (strEQ(name, "CONTENT_LENGTH_UPLOAD")) return CURLINFO_CONTENT_LENGTH_UPLOAD;
	    break;
	case 'D':
	case 'E':
	    if (strEQ(name, "EFFECTIVE_URL")) return CURLINFO_EFFECTIVE_URL;
	    break;
	case 'F':
	    if (strEQ(name, "FILETIME")) return CURLINFO_FILETIME;
	    break;
	case 'G':
	case 'H':
	    if (strEQ(name, "HEADER_SIZE")) return CURLINFO_HEADER_SIZE;
	    if (strEQ(name, "HTTP_CODE")) return CURLINFO_HTTP_CODE;
	    break;
	case 'I':
	case 'J':
	case 'K':
	case 'L':
	case 'M':
	case 'N':
	    if (strEQ(name, "NAMELOOKUP_TIME")) return CURLINFO_NAMELOOKUP_TIME;
	    break;
	case 'O':
	case 'P':
	    if (strEQ(name, "PRETRANSFER_TIME")) return CURLINFO_PRETRANSFER_TIME;
	    break;
	case 'Q':
	case 'R':
	    if (strEQ(name, "REQUEST_SIZE")) return CURLINFO_REQUEST_SIZE;
	    break;
	case 'S':
	    if (strEQ(name, "SSL_VERIFYRESULT")) return CURLINFO_SSL_VERIFYRESULT;
	    break;
	case 'T':
	    if (strEQ(name, "SIZE_DOWNLOAD")) return CURLINFO_SIZE_DOWNLOAD;
	    if (strEQ(name, "SIZE_UPLOAD")) return CURLINFO_SIZE_UPLOAD;
	    if (strEQ(name, "SPEED_DOWNLOAD")) return CURLINFO_SPEED_DOWNLOAD;
	    if (strEQ(name, "SPEED_UPLOAD")) return CURLINFO_SPEED_UPLOAD;
	    if (strEQ(name, "TOTAL_TIME")) return CURLINFO_TOTAL_TIME;
	    break;
	case 'U':
	case 'V':
	case 'W':
	case 'X':
	case 'Y':
	case 'Z':
	    break;
	}
    }
    if (strncmp(name, "CURLOPT_", 8) == 0) {
	name += 8;
	switch (*name) {
#include "curlopt-constants.c"
	}
    }
    if (strEQ(name, "USE_INTERNAL_VARS")) return USE_INTERNAL_VARS;
    errno = EINVAL;
    return 0;
}


MODULE = Curl::easy		PACKAGE = Curl::easy		PREFIX = curl_easy_

int
constant(name,arg)
    char * name
    int arg


void *
curl_easy_init()
CODE:
    init_globals();
    RETVAL = curl_easy_init();
    curl_easy_setopt(RETVAL, CURLOPT_HEADERFUNCTION, header_callback_func);
    curl_easy_setopt(RETVAL, CURLOPT_WRITEFUNCTION, write_callback_func);
OUTPUT:
    RETVAL

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

int
curl_easy_setopt(curl, option, value)
void * curl
int option
SV * value
CODE:
    if (option < CURLOPTTYPE_OBJECTPOINT) {
	/* This is an option specifying an integer value: */
	RETVAL = curl_easy_setopt(curl, option, (long)SvIV(value));
    } else if (option == CURLOPT_FILE || option == CURLOPT_INFILE ||
	    option == CURLOPT_WRITEHEADER || option == CURLOPT_PROGRESSDATA ||
	    option == CURLOPT_PASSWDDATA) {
	/* This is an option specifying an SV * value: */
	RETVAL = curl_easy_setopt(curl, option, newSVsv(ST(2)));
    } else if (option == CURLOPT_ERRORBUFFER) {
	/* Pass in variable name for storing error messages... */
	RETVAL = curl_easy_setopt(curl, option, errbuf);
	if (errbufvarname) free(errbufvarname);
	errbufvarname = strdup((char *)SvPV(value, PL_na));
    } else if (option == CURLOPT_WRITEFUNCTION || option ==
	    CURLOPT_READFUNCTION || option == CURLOPT_PROGRESSFUNCTION ||
	    option == CURLOPT_PASSWDFUNCTION || option == CURLOPT_HEADERFUNCTION) {
	/* This is an option specifying a callback function */
	switch (option) {
	case CURLOPT_WRITEFUNCTION:
	    register_callback(&write_callback, value);
	    curl_easy_setopt(curl, CURLOPT_WRITEFUNCTION, write_callback_func);
	    break;
	case CURLOPT_READFUNCTION:
	    register_callback(&read_callback, value);
	    curl_easy_setopt(curl, CURLOPT_READFUNCTION, read_callback_func);
	    break;
        case CURLOPT_HEADERFUNCTION:
            register_callback(&header_callback, value);
	    curl_easy_setopt(curl, CURLOPT_HEADERFUNCTION, header_callback_func);	
	case CURLOPT_PROGRESSFUNCTION:
	    register_callback(&progress_callback, value);
	    curl_easy_setopt(curl, CURLOPT_PROGRESSFUNCTION, progress_callback_func);
	    break;
	case CURLOPT_PASSWDFUNCTION:
	    register_callback(&passwd_callback, value);
	    curl_easy_setopt(curl, CURLOPT_PASSWDFUNCTION, passwd_callback_func);
	    break;
        /* awaiting a prototype for the closepolicy function callback 
        case CURLOPT_CLOSEFUNCTION:
            register_callback(&closepolicy_callback, value);
            curl_easy_setopt(curl, CURLOPT_CLOSEFUNCTION, closepolicy_callback_func);
            break;
        */
	}
	RETVAL = -1;
    } else if (option == CURLOPT_HTTPHEADER || option == CURLOPT_QUOTE ||
	    option == CURLOPT_POSTQUOTE) {
	/* This is an option specifying a list of curl_slist structs: */
	AV *array = (AV *)SvRV(value);
	struct curl_slist **slist = NULL;
	/* We have to find out which list to use... */
	switch (option) {
	case CURLOPT_HTTPHEADER:
	    slist = &httpheader; break;
	case CURLOPT_QUOTE:
	    slist = &quote; break;
	case CURLOPT_POSTQUOTE:
	    slist = &postquote; break;
	}
        /* free any previous list */
        if (*slist) {
            curl_slist_free_all(*slist);
            *slist=NULL;
        }                                                                       
	/* ...store the values into it... */
	for (;;) {
	    SV *sv = av_shift(array);
	    int len = 0;
	    char *str = SvPV(sv, len);
	    if (len == 0) break;
	    *slist = curl_slist_append(*slist, str);
	}
	/* ...and pass the list into curl_easy_setopt() */
	RETVAL = curl_easy_setopt(curl, option, *slist);
    } else {
	/* This is an option specifying a char * value: */
	RETVAL = curl_easy_setopt(curl, option, SvPV(value, PL_na));
    }
OUTPUT:
    RETVAL


int
internal_setopt(option, value)
int option
int value
CODE:
    if (value == 1) {
	internal_options |= option;
    } else {
	internal_options &= !option;
    }
    RETVAL = 0;
OUTPUT:
    RETVAL


int
curl_easy_perform(curl)
void * curl 
CODE:
    if (internal_options & USE_INTERNAL_VARS) {
	/* Use internal callback which just stores the content into a buffer. */
	curl_easy_setopt(curl, CURLOPT_WRITEFUNCTION, internal_write_callback);
	curl_easy_setopt(curl, CURLOPT_HEADER, 1);
    }
    RETVAL = curl_easy_perform(curl);
    if (RETVAL && errbufvarname) {
	/* If an error occurred and a varname for error messages has been
	   specified, store the error message. */
	SV *sv = perl_get_sv(errbufvarname, TRUE | GV_ADDMULTI);
	sv_setpv(sv, errbuf);
    }
    if (!RETVAL && (internal_options & USE_INTERNAL_VARS)) {
	/* No error and internal variable for the content are to be used:
	   Split the data into headers and content and store them into
	   perl variables. */
	SV *head_sv = perl_get_sv("Curl::easy::headers", TRUE | GV_ADDMULTI);
	SV *cont_sv = perl_get_sv("Curl::easy::content", TRUE | GV_ADDMULTI);
	char *p = contbuf;
	int nl = 0, found = 0;
	while (p < bufptr) {
	    if (nl && (*p == '\n' || *p == '\r')) {
		/* found empty line, end of headers */
		*p++ = '\0';
		sv_setpv(head_sv, contbuf);
		while (*p == '\n' || *p == '\r') {
		    p++;
		}
		sv_setpv(cont_sv, p);
		found = 1;
		break;
	    }
	    nl = (*p == '\n');
	    p++;
	}
	if (!found) {
	    sv_setpv(head_sv, "");
	    sv_setpv(cont_sv, contbuf);
	}
    }
OUTPUT:
    RETVAL


int
curl_easy_getinfo(curl, option, value)
void * curl
int option
double value
CODE:
#ifdef __GNUC__
    /* a(void) warnig about unnused variable */
    (void) value;
#endif
    switch (option & CURLINFO_TYPEMASK) {
	case CURLINFO_STRING: {
	    char * value = (char *)SvPV(ST(2), PL_na);
	    RETVAL = curl_easy_getinfo(curl, option, &value);
	    sv_setpv(ST(2), value);
	    break;
	}
	case CURLINFO_LONG: {
	    long value = (long)SvIV(ST(2));
	    RETVAL = curl_easy_getinfo(curl, option, &value);
	    sv_setiv(ST(2), value);
	    break;
	}
	case CURLINFO_DOUBLE: {
	    double value = (double)SvNV(ST(2));
	    RETVAL = curl_easy_getinfo(curl, option, &value);
	    sv_setnv(ST(2), value);
	    break;
	}
	default: {
	    RETVAL = CURLE_BAD_FUNCTION_ARGUMENT;
	    break;
	}
    }
OUTPUT:
    RETVAL


int
curl_easy_cleanup(curl)
void * curl 
CODE:
    curl_easy_cleanup(curl);
    init_globals();
    RETVAL = 0;
OUTPUT:
    RETVAL