1
0
mirror of https://github.com/moparisthebest/curl synced 2024-12-21 23:58:49 -05:00

Cris Bailiff's and Georg Horn's big improvements

This commit is contained in:
Daniel Stenberg 2001-04-18 06:51:30 +00:00
parent 8274bee963
commit ebcafe73b3
5 changed files with 893 additions and 71 deletions

View File

@ -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

View File

@ -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"}
);

View File

@ -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()
@ -117,21 +126,122 @@ Curl::easy - Perl extension for libcurl
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
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
http://curl.haxx.se/

View File

@ -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

View File

@ -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";