diff options
Diffstat (limited to 'perl/Curl_easy')
| -rw-r--r-- | perl/Curl_easy/Changes | 34 | ||||
| -rw-r--r-- | perl/Curl_easy/Makefile.PL | 2 | ||||
| -rw-r--r-- | perl/Curl_easy/easy.pm | 130 | ||||
| -rw-r--r-- | perl/Curl_easy/easy.xs | 502 | ||||
| -rw-r--r-- | perl/Curl_easy/test.pl | 296 |
5 files changed, 893 insertions, 71 deletions
diff --git a/perl/Curl_easy/Changes b/perl/Curl_easy/Changes index a38cc34a4..647017c54 100644 --- a/perl/Curl_easy/Changes +++ b/perl/Curl_easy/Changes @@ -1,6 +1,40 @@ Revision history for Perl extension Curl::easy. Check out the file README for more info. +1.1.3 Wed Apr 18 2001: - Cris Bailiff <c.bailiff@devsecure.com> + - Change/shorten module function names: + Curl::easy::curl_easy_setopt becomes Curl::easy::setopt etc. + This requires minor changes to existing scripts.... + - Added callback function support to pass arbitrary SV * (including + FILE globs) from perl through libcurl to the perl callback. + - Make callbacks still work with existing scripts which use STDIO + - Initial support for libcurl 7.7.2 HEADERFUNCTION callback feature + - Minor API cleanups/changes in the callback function signatures + - Added Curl::easy::version function to return curl version string + - Callback documentation added in easy.pm + - More tests in test.pl + +1.1.2 Mon Apr 16 2001: - Georg Horn <horn@koblenz-net.de> + - Added support for callback functions. This is for the curl_easy_setopt() + options WRITEFUNCTION, READFUNCTION, PROGRESSFUNCTION and PASSWDFUNCTION. + Still missing, but not really neccessary: Passing a FILE * pointer, + that is passed in from libcurl, on to the perl callback function. + - Various cleanups, fixes and enhancements to easy.xs and test.pl. + +1.1.1 Thu Apr 12 2001: + - Made more options of curl_easy_setopt() work: Options that require + a list of curl_slist structs to be passed in, like CURLOPT_HTTPHEADER, + are now working by passing a perl array containing the list elements. + As always, look at the test script test.pl for an example. + +1.1.0 Wed Apr 11 2001: + - tested against libcurl 7.7 + - Added new function Curl::easy::internal_setopt(). By calling + Curl::easy::internal_setopt(Curl::easy::USE_INTERNAL_VARS, 1); + the headers and content of the fetched page are no longer stored + into files (or written to stdout) but are stored into internal + Variables $Curl::easy::headers and $Curl::easy::content. + 1.0.2 Tue Oct 10 2000: - runs with libcurl 7.4 - modified curl_easy_getinfo(). It now calls curl_getinfo() that has diff --git a/perl/Curl_easy/Makefile.PL b/perl/Curl_easy/Makefile.PL index c0d6c2ddf..58a8528ad 100644 --- a/perl/Curl_easy/Makefile.PL +++ b/perl/Curl_easy/Makefile.PL @@ -8,7 +8,7 @@ WriteMakefile( 'NAME' => 'Curl::easy', 'VERSION_FROM' => 'easy.pm', # finds $VERSION 'LIBS' => ['-lcurl '], # e.g., '-lm' - 'DEFINE' => '-Wall', # e.g., '-DHAVE_SOMETHING' + 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' 'INC' => '', # e.g., '-I/usr/include/other' 'clean' => {FILES => "head.out body.out"} ); diff --git a/perl/Curl_easy/easy.pm b/perl/Curl_easy/easy.pm index 126be14a9..e484a28f2 100644 --- a/perl/Curl_easy/easy.pm +++ b/perl/Curl_easy/easy.pm @@ -29,6 +29,7 @@ CURLOPT_FTPASCII CURLOPT_FTPLISTONLY CURLOPT_FTPPORT CURLOPT_HEADER +CURLOPT_HEADERFUNCTION CURLOPT_HTTPHEADER CURLOPT_HTTPPOST CURLOPT_HTTPPROXYTUNNEL @@ -44,6 +45,8 @@ CURLOPT_NETRC CURLOPT_NOBODY CURLOPT_NOPROGRESS CURLOPT_NOTHING +CURLOPT_PASSWDDATA +CURLOPT_PASSWDFUNCTION CURLOPT_PORT CURLOPT_POST CURLOPT_POSTFIELDS @@ -88,8 +91,14 @@ CURLINFO_SPEED_DOWNLOAD CURLINFO_SPEED_UPLOAD CURLINFO_HEADER_SIZE CURLINFO_REQUEST_SIZE + +USE_INTERNAL_VARS ); -$VERSION = '1.0.1'; + +$VERSION = '1.1.3'; + +$Curl::easy::headers = ""; +$Curl::easy::content = ""; sub AUTOLOAD { # This AUTOLOAD is used to 'autoload' constants from the constant() @@ -116,21 +125,122 @@ Curl::easy - Perl extension for libcurl =head1 SYNOPSIS use Curl::easy; - - $CURL = curl_easy_init(); - $CURLcode = curl_easy_setopt($CURL, CURLoption, Value); - $CURLcode = curl_easy_perform($CURL); - curl_easy_cleanup($CURL); - - + + $curl = Curl::easy::init(); + $CURLcode = Curl::easy::setopt($curl, CURLoption, Value); + $CURLcode = Curl::easy::perform($curl); + Curl::easy::cleanup($curl); + =head1 DESCRIPTION - + This perl module provides an interface to the libcurl C library. See http://curl.haxx.se/ for more information on cURL and libcurl. + +=head1 FILES and CALLBACKS -=head1 AUTHOR +Curl::easy supports the various options of curl_easy_setopt which require either a FILE * or +a callback function. + +The perl callback functions are handled through a C wrapper which takes care of converting +from C to perl variables and back again. This wrapper simplifies some C arguments to make +them behave in a more 'perl' like manner. In particular, the read and write callbacks do not +look just like the 'fread' and 'fwrite' C functions - perl variables do not need separate length +parameters, and perl functions can return a list of variables, instead of needing a pointer +to modify. The details are described below. + +=head2 FILE handles (GLOBS) + +Curl options which take a FILE, such as CURLOPT_FILE, CURLOPT_WRITEHEADER, CURLOPT_INFILE +can be passed a perl file handle: + + open BODY,">body.out"; + $CURLcode = Curl::easy::setopt($curl, CURLOPT_FILE, BODY); + +=head2 WRITE callback + +The CUROPT_WRITEFUNCTION option may be set which will cause libcurl to callback to +the given subroutine: + + sub chunk { my ($data,$pointer)=@_; ...; return length($data) } + $CURLcode = Curl::easy::setopt($curl, CURLOPT_WRITEFUNCTION, \&chunk ); + $CURLcode = Curl::easy::setopt($curl, CURLOPT_FILE, ); + +In this case, the subroutine will be passed whatever is defined by CURLOPT_FILE. This can be +a ref to a scalar, or a GLOB or anything else you like. + +The callback function must return the number of bytes 'handled' ( length($data) ) or the transfer +will abort. A transfer can be aborted by returning a 'length' of '-1'. + +The option CURLOPT_WRITEHEADER can be set to pass a different '$pointer' into the CURLOPT_WRITEFUNCTION +for header values. This lets you collect the headers and body separately: + + my $headers=""; + my $body=""; + sub chunk { my ($data,$pointer)=@_; ${$pointer}.=$data; return length($data) } + + $CURLcode = Curl::easy::setopt($curl, CURLOPT_WRITEFUNCTION, \&chunk ); + $CURLcode = Curl::easy::setopt($curl, CURLOPT_WRITEHEADER, \$header ); + $CURLcode = Curl::easy::setopt($curl, CURLOPT_FILE, \$body ); +If you have libcurl > 7.7.1, then you could instead set CURLOPT_HEADERFUNCTION to a different callback, +and have the header collected that way. + +=head2 READ callback + +Curl::easy supports CURLOPT_READFUNCTION. This function should look something like this: + + sub read_callback { + my ($maxlength,$pointer)=@_; + + .... + + return $data; + } + +The subroutine must return an empty string "" at the end of the data. Note that this function +isn't told how much data to provide - $maxlength is just the maximum size of the buffer +provided by libcurl. If you are doing an HTTP POST or PUT for example, it is important that this +function only returns as much data as the 'Content-Length' header specifies, followed by a +an empty (0 length) buffer. + +=head2 PROGRESS callback + +Curl::easy supports CURLOPT_PROGRESSFUNCTION. This function should look something like this: + + sub prog_callb + { + my ($clientp,$dltotal,$dlnow,$ultotal,$ulnow)=@_; + .... + return 0; + } + +The function should return 0 normally, or -1 which will abort/cancel the transfer. $clientp is whatever +value/scalar is set using the CURLOPT_PROGRESSDATA option. + +=head2 PASSWD callback + +Curl::easy supports CURLOPT_PASSWDFUNCTION. This function should look something like this: + + sub passwd_callb + { + my ($clientp,$prompt,$buflen)=@_; + ... + return (0,$data); + } + +$clientp is whatever scalar is set using the CURLOPT_PASSWDDATA option. +$prompt is a text string which can be used to prompt for a password. +$buflen is the maximum accepted password reply. + +The function must return 0 (for 'OK') and the password data as a list. Return (-1,"") to +indicate an error. + +=head1 AUTHOR + Georg Horn <horn@koblenz-net.de> + +Additional callback,pod and tes work by Cris Bailiff <c.bailiff@devsecure.com> +and Forrest Cahoon <forrest.cahoon@merrillcorp.com> =head1 SEE ALSO 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 = "e; 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 diff --git a/perl/Curl_easy/test.pl b/perl/Curl_easy/test.pl index a93b05692..1d52e3c24 100644 --- a/perl/Curl_easy/test.pl +++ b/perl/Curl_easy/test.pl @@ -8,11 +8,14 @@ # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) +use Benchmark; +use strict; -BEGIN { $| = 1; print "1..5\n"; } -END {print "not ok 1\n" unless $loaded;} +BEGIN { $| = 1; print "1..13\n"; } +END {print "not ok 1\n" unless $::loaded;} use Curl::easy; -$loaded = 1; + +$::loaded = 1; print "ok 1\n"; ######################### End of black magic. @@ -21,81 +24,292 @@ print "ok 1\n"; # (correspondingly "not ok 13") depending on the success of chunk 13 # of the test code): +print "Testing curl version ",&Curl::easy::version(),"\n"; + # Read URL to get -$defurl = "http://www/"; -$url = ""; +my $defurl = "http://localhost/cgi-bin/printenv"; +my $url = ""; print "Please enter an URL to fetch [$defurl]: "; $url = <STDIN>; if ($url =~ /^\s*\n/) { $url = $defurl; } -# Use this for simple benchmarking -#for ($i=0; $i<1000; $i++) { - # Init the curl session -if (($curl = Curl::easy::curl_easy_init()) != 0) { +my $curl; +if (($curl = Curl::easy::init()) != 0) { print "ok 2\n"; } else { print "ko 2\n"; } -# Set URL to get -if (Curl::easy::curl_easy_setopt($curl, Curl::easy::CURLOPT_URL, $url) == 0) { - print "ok 3\n"; -} else { - print "ko 3\n"; -} # No progress meter please -Curl::easy::curl_easy_setopt($curl, Curl::easy::CURLOPT_NOPROGRESS, 1); +# !! Need this on for all tests, as once disabled, can't re-enable it... +#Curl::easy::setopt($curl, CURLOPT_NOPROGRESS, 1); # Shut up completely -Curl::easy::curl_easy_setopt($curl, Curl::easy::CURLOPT_MUTE, 1); +Curl::easy::setopt($curl, CURLOPT_MUTE, 1); # Follow location headers -Curl::easy::curl_easy_setopt($curl, Curl::easy::CURLOPT_FOLLOWLOCATION, 1); +Curl::easy::setopt($curl, CURLOPT_FOLLOWLOCATION, 1); # Set timeout -Curl::easy::curl_easy_setopt($curl, Curl::easy::CURLOPT_TIMEOUT, 30); +Curl::easy::setopt($curl, CURLOPT_TIMEOUT, 30); # Set file where to read cookies from -Curl::easy::curl_easy_setopt($curl, Curl::easy::CURLOPT_COOKIEFILE, "cookies"); +Curl::easy::setopt($curl, CURLOPT_COOKIEFILE, "cookies"); # Set file where to store the header open HEAD, ">head.out"; -Curl::easy::curl_easy_setopt($curl, Curl::easy::CURLOPT_WRITEHEADER, HEAD); +Curl::easy::setopt($curl, CURLOPT_WRITEHEADER, *HEAD); +print "ok 3\n"; # Set file where to store the body -open BODY, ">body.out"; -Curl::easy::curl_easy_setopt($curl, Curl::easy::CURLOPT_FILE, BODY); +# Send body to stdout - test difference between FILE * and SV * +#open BODY, ">body.out"; +#Curl::easy::setopt($curl, CURLOPT_FILE,*BODY); +print "ok 4\n"; +# Add some additional headers to the http-request: +my @myheaders; +$myheaders[0] = "Server: www"; +$myheaders[1] = "User-Agent: Perl interface for libcURL"; +Curl::easy::setopt($curl, Curl::easy::CURLOPT_HTTPHEADER, \@myheaders); + # Store error messages in variable $errbuf # NOTE: The name of the variable is passed as a string! -# curl_easy_setopt() creates a perl variable with that name, and -# curl_easy_perform() stores the errormessage into it if an error occurs. -Curl::easy::curl_easy_setopt($curl, Curl::easy::CURLOPT_ERRORBUFFER, "errbuf"); +# setopt() creates a perl variable with that name, and +# perform() stores the errormessage into it if an error occurs. + +Curl::easy::setopt($curl, CURLOPT_ERRORBUFFER, "errbuf"); +Curl::easy::setopt($curl, CURLOPT_URL, $url); +print "ok 5\n"; + +my $bytes; +my $realurl; +my $httpcode; +my $errbuf; # Go get it -if (Curl::easy::curl_easy_perform($curl) == 0) { - Curl::easy::curl_easy_getinfo($curl, Curl::easy::CURLINFO_SIZE_DOWNLOAD, $bytes); - print "ok 4: $bytes bytes read\n"; - print "check out the files head.out and body.out\n"; - print "for the headers and content of the URL you just fetched...\n"; - Curl::easy::curl_easy_getinfo($curl, Curl::easy::CURLINFO_EFFECTIVE_URL, $realurl); - Curl::easy::curl_easy_getinfo($curl, Curl::easy::CURLINFO_HTTP_CODE, $httpcode); +if (Curl::easy::perform($curl) == 0) { + Curl::easy::getinfo($curl, CURLINFO_SIZE_DOWNLOAD, $bytes); + print "ok 6: $bytes bytes read\n"; + Curl::easy::getinfo($curl, CURLINFO_EFFECTIVE_URL, $realurl); + Curl::easy::getinfo($curl, CURLINFO_HTTP_CODE, $httpcode); print "effective fetched url (http code: $httpcode) was: $url\n"; } else { + # We can acces the error message in $errbuf here + print "not ok 6: '$errbuf'\n"; + die "basic url access failed"; +} + +# cleanup +#close HEAD; +# test here - BODY is still expected to be the output +# Curl-easy-1.0.2.pm core dumps if we 'perform' with a closed output FD... +#close BODY; +#exit; +# +# The header callback will only be called if your libcurl has the +# CURLOPT_HEADERFUNCTION supported, otherwise your headers +# go to CURLOPT_WRITEFUNCTION instead... +# + +my $header_called=0; +sub header_callback { print "header callback called\n"; $header_called=1; return length($_[0])}; + +# test for sub reference and head callback +Curl::easy::setopt($curl, CURLOPT_HEADERFUNCTION, \&header_callback); +print "ok 7\n"; # so far so good + +if (Curl::easy::perform($curl) != 0) { + print "not "; +}; +print "ok 8\n"; + +print "next test will fail on libcurl < 7.7.2\n"; +print "not " if (!$header_called); # ok if you have a libcurl <7.7.2 +print "ok 9\n"; + +my $body_called=0; +sub body_callback { + my ($chunk,$handle)=@_; + print "body callback called with ",length($chunk)," bytes\n"; + print "data=$chunk\n"; + $body_called++; + return length($chunk); # OK +} + +# test for ref to sub and body callback +my $body_ref=\&body_callback; +Curl::easy::setopt($curl, CURLOPT_WRITEFUNCTION, $body_ref); + +if (Curl::easy::perform($curl) != 0) { + print "not "; +}; +print "ok 10\n"; + +print "not " if (!$body_called); +print "ok 11\n"; + +my $body_abort_called=0; +sub body_abort_callback { + my ($chunk,$sv)=@_; + print "body abort callback called with ",length($chunk)," bytes\n"; + $body_abort_called++; + return -1; # signal a failure +} + +# test we can abort a request mid-way +my $body_abort_ref=\&body_abort_callback; +Curl::easy::setopt($curl, CURLOPT_WRITEFUNCTION, $body_abort_ref); + +if (Curl::easy::perform($curl) == 0) { # reverse test - this should have failed + print "not "; +}; +print "ok 12\n"; + +print "not " if (!$body_abort_called); # should have been called +print "ok 13\n"; + +# reset to a working 'write' function for next tests +Curl::easy::setopt($curl,CURLOPT_WRITEFUNCTION, sub { return length($_[0])} ); + +# inline progress function +# tests for inline subs and progress callback +# - progress callback must return 'true' on each call. + +my $progress_called=0; +sub prog_callb +{ + my ($clientp,$dltotal,$dlnow,$ultotal,$ulnow)=@_; + print "\nperl progress_callback has been called!\n"; + print "clientp: $clientp, dltotal: $dltotal, dlnow: $dlnow, ultotal: $ultotal, "; + print "ulnow: $ulnow\n"; + $progress_called++; + return 0; +} + +Curl::easy::setopt($curl, CURLOPT_PROGRESSFUNCTION, \&prog_callb); + +# Turn progress meter back on - this doesn't work - once its off, its off. +Curl::easy::setopt($curl, CURLOPT_NOPROGRESS, 0); + +if (Curl::easy::perform($curl) != 0) { + print "not "; +}; +print "ok 14\n"; + +print "not " if (!$progress_called); +print "ok 15\n"; + +my $read_max=10; + +sub read_callb +{ + my ($maxlen,$sv)=@_; + print "\nperl read_callback has been called!\n"; + print "max data size: $maxlen\n"; + print "(upload needs $read_max bytes)\n"; + print "context: ".$sv."\n"; + if ($read_max > 0) { + print "\nEnter max ", $read_max, " characters to be uploaded.\n"; + my $data = <STDIN>; + chomp $data; + $read_max=$read_max-length($data); + return $data; + } else { + return ""; + } +} + +# +# test post/read callback functions - requires a url which accepts posts, or it fails! +# + +Curl::easy::setopt($curl,CURLOPT_READFUNCTION,\&read_callb); +Curl::easy::setopt($curl,CURLOPT_INFILESIZE,$read_max ); +Curl::easy::setopt($curl,CURLOPT_UPLOAD,1 ); +Curl::easy::setopt($curl,CURLOPT_CUSTOMREQUEST,"POST" ); + +if (Curl::easy::perform($curl) != 0) { + print "not "; +}; +print "ok 16\n"; + +sub passwd_callb +{ + my ($clientp,$prompt,$buflen)=@_; + print "\nperl passwd_callback has been called!\n"; + print "clientp: $clientp, prompt: $prompt, buflen: $buflen\n"; + print "\nEnter max $buflen characters for $prompt "; + my $data = <STDIN>; + chomp($data); + return (0,$data); +} + +Curl::easy::cleanup($curl); + +# Now do an ftp upload: + +$defurl = "ftp://horn\@localhost//tmp/bla"; +print "\n\nPlease enter an URL for ftp upload [$defurl]: "; +$url = <STDIN>; +if ($url =~ /^\s*\n/) { + $url = $defurl; +} + +# Init the curl session +if (($curl = Curl::easy::init()) != 0) { + print "ok 17\n"; +} else { + print "not ok 17\n"; +} + +# Set URL to get +if (Curl::easy::setopt($curl, Curl::easy::CURLOPT_URL, $url) == 0) { + print "ok 18\n"; +} else { + print "not ok 18\n"; + +} + +# Tell libcurl to to an upload +Curl::easy::setopt($curl, Curl::easy::CURLOPT_UPLOAD, 1); + +# No progress meter please +#Curl::easy::setopt($curl, Curl::easy::CURLOPT_NOPROGRESS, 1); + +# Use our own progress callback +Curl::easy::setopt($curl, Curl::easy::CURLOPT_PROGRESSFUNCTION, \&prog_callb); + +# Shut up completely +Curl::easy::setopt($curl, Curl::easy::CURLOPT_MUTE, 1); + +# Store error messages in $errbuf +Curl::easy::setopt($curl, Curl::easy::CURLOPT_ERRORBUFFER, "errbuf"); + +$read_max=10; +# Use perl read callback to read data to be uploaded +Curl::easy::setopt($curl, Curl::easy::CURLOPT_READFUNCTION, + \&read_callb); + +# Use perl passwd callback to read password for login to ftp server +Curl::easy::setopt($curl, Curl::easy::CURLOPT_PASSWDFUNCTION, \&passwd_callb); + +print "ok 19\n"; + +# Go get it +if (Curl::easy::perform($curl) == 0) { + Curl::easy::getinfo($curl, Curl::easy::CURLINFO_SIZE_UPLOAD, $bytes); + print "ok 20: $bytes bytes transferred\n\n"; +} else { # We can acces the error message in $errbuf here - print "ko 4: '$errbuf'\n"; + print "not ok 20: '$errbuf'\n"; } # Cleanup -close HEAD; -close BODY; -Curl::easy::curl_easy_cleanup($curl); -print "ok 5\n"; - -# Use this for simple benchmarking -#} +Curl::easy::cleanup($curl); +print "ok 21\n"; |