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
'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"}
);
CURLOPT_FTPLISTONLY
CURLOPT_FTPPORT
CURLOPT_HEADER
+CURLOPT_HEADERFUNCTION
CURLOPT_HTTPHEADER
CURLOPT_HTTPPOST
CURLOPT_HTTPPROXYTUNNEL
CURLOPT_NOBODY
CURLOPT_NOPROGRESS
CURLOPT_NOTHING
+CURLOPT_PASSWDDATA
+CURLOPT_PASSWDFUNCTION
CURLOPT_PORT
CURLOPT_POST
CURLOPT_POSTFIELDS
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()
=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
#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 */
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)
{
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;
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;
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)
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
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);
void * curl
CODE:
curl_easy_cleanup(curl);
- if (errbufvarname) free(errbufvarname);
- errbufvarname = NULL;
+ init_globals();
RETVAL = 0;
OUTPUT:
RETVAL
# 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.
# (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";
projects / platform / upstream / curl.git / commitdiff