1 files changed, 483 insertions, 19 deletions

diff --git a/perl/Curl_easy/easy.xs b/perl/Curl_easy/easy.xs
index c7f19b026..4fff2b332 100644
--- a/perl/Curl_easy/easy.xs
+++ b/perl/Curl_easy/easy.xs
@@ -7,6 +7,17 @@
 #include <curl/curl.h>
 #include <curl/easy.h>
 
+#if (LIBCURL_VERSION_NUM<0x070702)
+#define CURLOPT_HEADERFUNCTION 79
+#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 */
 
@@ -14,6 +25,341 @@ 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 { /* its already an SV */
+            sv = stream;
+        }
+	
+        if (ptr != NULL) {
+            XPUSHs(sv_2mortal(newSVpvn(ptr, size * nmemb))); 
+	} else {
+            XPUSHs(sv_2mortal(newSVpv("",0)));
+        }
+        XPUSHs(sv_2mortal(newSVsv(sv)));  /* CURLOPT_FILE SV* */
+        PUTBACK ;
+
+        count = 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 * */
+            FILE *f;
+	
+            if (stream == stdout) { /* the only possible FILE ? Think so*/
+                f = stream;
+            } else { /* its a GLOB */
+                f = IoIFP(sv_2io(stream)); /* may barf if not a GLOB */
+            }
+
+            return fwrite(ptr,size,nmemb,f);
+    }
+}
+
+/* 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 = 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 = 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)
 {
@@ -97,6 +443,7 @@ constant(char *name, int arg)
 	case 'G':
 	case 'H':
 	    if (strEQ(name, "HEADER")) return CURLOPT_HEADER;
+        if (strEQ(name, "HEADERFUNCTION")) return CURLOPT_HEADERFUNCTION;
 	    if (strEQ(name, "HTTPHEADER")) return CURLOPT_HTTPHEADER;
 	    if (strEQ(name, "HTTPPOST")) return CURLOPT_HTTPPOST;
 	    if (strEQ(name, "HTTPPROXYTUNNEL")) return CURLOPT_HTTPPROXYTUNNEL;
@@ -124,6 +471,8 @@ constant(char *name, int arg)
 	    break;
 	case 'O':
 	case 'P':
+	    if (strEQ(name, "PASSWDDATA")) return CURLOPT_PASSWDDATA;
+	    if (strEQ(name, "PASSWDFUNCTION")) return CURLOPT_PASSWDFUNCTION;
 	    if (strEQ(name, "PORT")) return CURLOPT_PORT;
 	    if (strEQ(name, "POST")) return CURLOPT_POST;
 	    if (strEQ(name, "POSTFIELDS")) return CURLOPT_POSTFIELDS;
@@ -173,12 +522,13 @@ constant(char *name, int arg)
 	    break;
 	}
     }
+    if (strEQ(name, "USE_INTERNAL_VARS")) return USE_INTERNAL_VARS;
     errno = EINVAL;
     return 0;
 }
 
 
-MODULE = Curl::easy		PACKAGE = Curl::easy		
+MODULE = Curl::easy		PACKAGE = Curl::easy		PREFIX = curl_easy_
 
 int
 constant(name,arg)
@@ -189,56 +539,167 @@ constant(name,arg)
 void *
 curl_easy_init()
 CODE:
-    if (errbufvarname) free(errbufvarname);
-    errbufvarname = NULL;
+    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
-char * value
+SV * value
 CODE:
     if (option < CURLOPTTYPE_OBJECTPOINT) {
+
 	/* This is an option specifying an integer value: */
-	long value = (long)SvIV(ST(2));
-	RETVAL = curl_easy_setopt(curl, option, value);
+	RETVAL = curl_easy_setopt(curl, option, (long)SvIV(value));
+
     } else if (option == CURLOPT_FILE || option == CURLOPT_INFILE ||
-	    option == CURLOPT_WRITEHEADER) {
-	/* This is an option specifying a FILE * value: */
-	FILE * value = IoIFP(sv_2io(ST(2)));
-	RETVAL = curl_easy_setopt(curl, option, value);
+	    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) {
-	SV *sv;
+	/* Pass in variable name for storing error messages... */
 	RETVAL = curl_easy_setopt(curl, option, errbuf);
 	if (errbufvarname) free(errbufvarname);
-	errbufvarname = strdup(value);
-	sv = perl_get_sv(errbufvarname, TRUE | GV_ADDMULTI);
+	errbufvarname = strdup((char *)SvPV(value, PL_na));
+
     } else if (option == CURLOPT_WRITEFUNCTION || option ==
-	    CURLOPT_READFUNCTION || option == CURLOPT_PROGRESSFUNCTION) {
+	    CURLOPT_READFUNCTION || option == CURLOPT_PROGRESSFUNCTION ||
+	    option == CURLOPT_PASSWDFUNCTION || option == CURLOPT_HEADERFUNCTION) {
 	/* This is an option specifying a callback function */
-	/* not yet implemented */
+	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;
+	}
+	/* ...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 {
-	/* default, option specifying a char * value: */
-	RETVAL = curl_easy_setopt(curl, option, value);
+	/* 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
 
@@ -249,6 +710,10 @@ 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);
@@ -282,8 +747,7 @@ curl_easy_cleanup(curl)
 void * curl 
 CODE:
     curl_easy_cleanup(curl);
-    if (errbufvarname) free(errbufvarname);
-    errbufvarname = NULL;
+    init_globals();
     RETVAL = 0;
 OUTPUT:
     RETVAL