diff options
| author | Hasan Wan <hasan.wan@intel.com> | 2012-05-25 16:47:13 +0800 |
|---|---|---|
| committer | Hasan Wan <hasan.wan@intel.com> | 2012-05-28 16:06:22 +0800 |
| commit | 33bdf1a3cbfc104bf6f853ae77d7f28eb056e190 (patch) | |
| tree | bafe5f731d075f08a0326b8d2f1c2dc467f4a0dd | |
| parent | 3555375b5b187f5eb25bc6673e2479d54f20ada3 (diff) | |
| download | perl-WWW-Curl-33bdf1a3cbfc104bf6f853ae77d7f28eb056e190.tar.gz perl-WWW-Curl-33bdf1a3cbfc104bf6f853ae77d7f28eb056e190.tar.bz2 perl-WWW-Curl-33bdf1a3cbfc104bf6f853ae77d7f28eb056e190.zip | |
Updated with Tizen:Base source codes
56 files changed, 5317 insertions, 0 deletions
@@ -0,0 +1,246 @@ +Revision history for Perl extension WWW::Curl. +4.05 Sat Jul 06 2008: - Balint Szilakszi <szbalint at cpan.org> + + - Corrected the duphandle mechanism. + - Fixed a typo (fixes RT #37253). + - Added better Windows compatibility detection and separate + installation instructions (thanks to Shiyu Tang). + +4.04 Sat Jun 21 2008: - Balint Szilakszi <szbalint at cpan.org> + + - Test::More and use_ok at begin time doesn't mesh with no plan. + +4.03 Sat Jun 21 2008: - Balint Szilakszi <szbalint at cpan.org> + + - Removing option to pass destination files as a typeglob as + it is a backwards pointing magic and caused bugs. + Use a filehandle or reference instead. + - Fixed tests for 5.6, raised minimum Perl version to 5.6.1 due to tests. + - Fixed a duphandle bug. + +4.02 Thu Jun 19 2008: - Balint Szilakszi <szbalint at cpan.org> + + - Adding forgotten backwards compatibility with older Perl versions + +4.01 Wed Jun 18 2008: - Balint Szilakszi <szbalint at cpan.org> + + - Reimplemented callback handling to fix several I/O issues (fixes RT #35491) + - Documentation showing example WWW::Curl::Multi usage is corrected (fixes RT #35520) + - Should now compile on HP-UX and OSX (fixes RT #36058 and #35349) + - POD validity fix (fixes RT #15850) + - Added several new tests + - Upgraded to Module::Install 0.75 as it now exits correctly on build time + with NA if the required libcurl isn't available. + +4.00 Wed Mar 05 2008: - Balint Szilakszi <szbalint at cpan.org> + - Rewritten documentation. + - New test suite. + - New build system: using Module::Install instead of ExtUtils::Makemaker. + - New minimal requirements, Perl 5.6 and libcurl 7.10.8. + - New WWW::Curl::Multi interface. + - Removed WWW::Curl::easy. + - Removed compatibility code for pre 7.10.8 libcurl. + - Added lots of small improvements to setopt and friends. + - Bugfixes, mainly for memory leaks. + - SIGNATURE. + +3.12 Wed Feb 27 2008: - Cris Bailiff <c.bailiff+curl at devsecure.com> + - New Share.pm.in was missed from the MANIFEST, so was not in the distribution. Fixed. + +3.11 Mon Feb 25 2008: - Cris Bailiff <c.bailiff+curl at devsecure.com> + - Merge recent contributions. + - Updates from various small bug/build reports + +3.10 Fri Feb 22 2008: - Anton Fedorov <datacompboy at mail.ru> + - Fix documentation for multi interface + - Added WWW::Curl::Share + - Added strerror into Easy and Multi interfaces + - Added support for CURLOPT_DEBUGFUNCTION in Easy interface + +3.02_01 Tue Jan 29 2008: - Mark Hindley + - Contributed CURLOPT_*_LARGE support + +3.02_00 Fri Sep 16 2005: - Cris Bailiff <c.bailiff+curl at devsecure.com> + - Workaround case-sensitive filename issues by making equivalent Easy + names in easy namespace + - Test scripts - Fixup ssl tests and remove leftover MUTE option + - NOTE: That due to namespace changes (easy->Easy) you must change any existing + code to 'use WWW::Curl::Easy' instead of 'use WWW::Curl::easy', but + you can still use the WWW::Curl::easy function names until they + are removed in a future release. + - Tested on Redhat EL3 (curl 7.10.6) and Mandrake 10.1 (curl 7.13.1) + +3.01 Thu Apr 20 2004: - Cris Bailiff <c.bailiff+curl at devsecure.com> + - Merged Sebastians changes into CVS + - Updated remaining tests to Test::Simple + - Added backwards compatability to V2 names (WWW::Curl::easy etc) + - Dropped backwards compatability to V1.x names + +3.00 Thu Feb 12 2004: - Sebastian Riedel <sri at oook.de> + - Added multi support + - New module names + - New tests + - New documentation + - New examples + - Big cleanup!!! + - Too much to tell, it's worth an upgrade + +2.00 Tue Apr 22 2003: - Cris Bailiff <c.bailiff+curl at devsecure.com> + - New top level package name of WWW::Curl in preparation for + entry to CPAN + - Rename "Curl::easy" to "WWW::Curl::easy" + - Add backwards compatability namespace module for existing scripts + - Implement initial curl_easy_duphandle support + - Started on curl_easy_form support (WWW:Curl::form) - NOT FUNCTIONAL YET + - Fixup use of env vars in t/07ftp-upload.t (jellyfish at pisem.net) + - Adjust IP addresses for t/08ssl.t tests due to moved https servers + +1.35 Sun Sep 22 2002: - Cris Bailiff <c.bailiff+curl at devsecure.com> + - Fixed progress function callback prototype [ curl-Bugs-612432 ], + reflecting the fix made in curl-7.9.5. Tested in t/05progress.t to + now return sensible values! + +1.34 Wed Aug 7 2002: - Cris Bailiff <c.bailiff+curl at devsecure.com> + - Fix off-by-one error in setting up of curl_slists from perl arrays, + which was causing the last item of slists to be dropped. Added regression + test case. + +1.33 Mon Aug 5 2002: - Cris Bailiff <c.bailiff+curl at devsecure.com> + - Fix serious bug in read callback support (used for POST and upload + requests), introduced in 1.30, which uploaded random data (due to a + reversed src/dest in a memory copy). + +1.32 Thu Aug 1 2002: - Cris Bailiff <c.bailiff+curl at devsecure.com> + - Minor Makefile.PL fixes to build cleanly with curl 7.8 as found + on redhat 7.2. + +1.31 Tue Jul 16 2002: - Cris Bailiff <c.bailiff+curl at devsecure.com> + - Generate better switch() statement syntax in C code, to fix build + issues on some systems with strict compilers. Reported by Ignasi Roca. + +1.30 Mon Jul 15 2002: - Cris Bailiff <c.bailiff+curl at devsecure.com> + - Testing release after complete code overhaul. Now supports + cleaner object interface, supports multiple handles per process, + uses PerlIO for portable I/O (which should be perl 5.8 ready) and + maybe even supports ithreads. Should be fully backwards compatible, + but please read the man page for change details and report any issues. + - Fixed warning caused by slist functions accessing past the end of the + perl array. + - Fixed leak caused by consuming slist arguments without freeing. + - Updates test scripts to OO style, cleaned up output. + - Deprecated USE_INTERNAL_VARS. + +1.21 Thu Jul 11 2002: - Cris Bailiff <c.bailiff+curl at devsecure.com> + - Minor fixes to assist windows builds from Shawn Poulson + - Allow passing curl include location on the command line when + running perl Makefile.PL + +1.20 Sat Feb 16 2002: - Cris Bailiff <c.bailiff+curl at devsecure.com> + - Use standard perl module numbering syntax (valid decimal) + - Skipped 1.10 in case anyone confuses it with 1.1.0 + - Made every build a rebuild and removed 'pre-built' files - no point + worrying about not finding curl.h - if we can't find it, we can't + compile anyway. Obviates bug in 1.1.9 preventing rebuilds. + - Add support for redefining CURLOPT_STDERR (file handle globs only!) + +1.1.9 Sat Dec 8 2001: - Cris Bailiff <c.bailiff+curl at devsecure.com> + - Enhance Makefile.PL to re-build easy.pm and 'constants' xs + function from local installed curl.h. CURLOPT_ and CURLINFO_ + Constants up-to-date for libcurl-7.9.2, but can be re-built + for almost any libcurl version by removing easy.pm and + curlopt-constants.c and re-running 'perl Makefile.PL' + - Use curl-config to find include and library compile options + - Updated test scripts to work better under 'make test' (You need + to set the environment variable 'CURL_TEST_URL' though!) + - Added test script to display transfer times using new time options + - Merge changes in Curl_easy 1.1.2.1 by Georg Horn + +1.1.8 Thu Sep 20 2001: - Cris Bailiff <c.bailiff+curl at devsecure.com> + - Re-generate CURLOPT_ constants from curl.h and enhance makefile + to allow this to be repeated in future or for older versions of + libcurl. Constants up-to-date for libcurl-7.9(pre) + - Split tests into t/*.t to simplify each case + - Add test cases for new SSL switches. This needs ca-bundle.crt + (from mod_ssl) for verifying test cases. + +1.1.7 Thu Sep 13 2001: - Cris Bailiff <c.bailiff+curl at devsecure.com> + - Documentation Update only - Explicitly state that Curl_easy + is released under the MIT-X/MPL dual licence. No code changes. + +1.1.6 Mon Sep 10 2001: - Cris Bailiff <c.bailiff+curl at devsecure.com> + - Fix segfault due to changes in header callback behaviour + since curl-7.8.1-pre3 + +1.1.5 Fri Apr 20 2001: - Cris Bailiff <c.bailiff+curl at devsecure.com> + - Add latest CURLOPT_ and CURLINFO_ constants to the constants list + +1.1.4 Fri Apr 20 2001: - Cris Bailiff <c.bailiff+curl at devsecure.com> + - Fix case where curl_slists such as 'HTTPHEADERS' need to + be re-set over persistant requests + +1.1.3 Wed Apr 18 2001: - Cris Bailiff <c.bailiff+curl at 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 at 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 + been added to libcurl in version 7.4. + +1.0.1 Tue Oct 10 2000: + - Added some missing features of curl_easy_setopt(): + - CURLOPT_ERRORBUFFER now works by passing the name of a perl + variable that shall be crated and the errormessage (if any) + be stored to. + - Passing filehandles (Options FILE, INFILE and WRITEHEADER) now works. + Have a look at test.pl to see how it works... + + - Added a new function, curl_easy_getinfo(), that for now always + returns the number of bytes that where written to disk during the last + download. If the curl_easy_getinfo() function is included in libcurl, + (as promised by Daniel ;-)) i will turn this into just a call to this + function. + +1.0 Thu Oct 5 2000: + - first released version + - runs with libcurl 7.3 + - some features of curl_easy_setopt() are still missing: + - passing function pointers doesn't work (options WRITEFUNCTION, + READFUNCTION and PROGRESSFUNCTION). + - passing FILE * pointers doesn't work (options FILE, INFILE and + WRITEHEADER). + - passing linked lists doesn't work (options HTTPHEADER and + HTTPPOST). + - setting the buffer where to store error messages in doesn't work + (option ERRORBUFFER). + @@ -0,0 +1,1190 @@ + +/* + * Perl interface for libcurl. Check out the file README for more info. + */ + +/* + * Copyright (C) 2000, 2001, 2002, 2005, 2008 Daniel Stenberg, Cris Bailiff, et al. + * You may opt to use, copy, modify, merge, publish, distribute and/or + * sell copies of the Software, and permit persons to whom the + * Software is furnished to do so, under the terms of the MPL or + * the MIT/X-derivate licenses. You may pick one of these licenses. + */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include <curl/curl.h> +#include <curl/easy.h> +#include <curl/multi.h> + +#define header_callback_func writeheader_callback_func + +/* Do a favor for older perl versions */ +#ifndef Newxz +# define Newxz(v,n,t) Newz(0,v,n,t) +#endif + +typedef enum { + CALLBACK_WRITE = 0, + CALLBACK_READ, + CALLBACK_HEADER, + CALLBACK_PROGRESS, + CALLBACK_DEBUG, + CALLBACK_LAST +} perl_curl_easy_callback_code; + +typedef enum { + SLIST_HTTPHEADER = 0, + SLIST_QUOTE, + SLIST_POSTQUOTE, + SLIST_LAST +} perl_curl_easy_slist_code; + + +typedef struct { + /* The main curl handle */ + struct CURL *curl; + I32 *y; + /* Lists that can be set via curl_easy_setopt() */ + struct curl_slist *slist[SLIST_LAST]; + SV *callback[CALLBACK_LAST]; + SV *callback_ctx[CALLBACK_LAST]; + + /* copy of error buffer var for caller*/ + char errbuf[CURL_ERROR_SIZE+1]; + char *errbufvarname; + +} perl_curl_easy; + + +typedef struct { + struct HttpPost * post; + struct HttpPost * last; +} perl_curl_form; + + +typedef struct { +#ifdef __CURL_MULTI_H + struct CURLM *curlm; +#else + struct void *curlm; +#endif +} perl_curl_multi; + +typedef struct { + struct CURLSH *curlsh; +} perl_curl_share; + + +/* switch from curl option codes to the relevant callback index */ +static perl_curl_easy_callback_code callback_index(int option) +{ + switch(option) { + case CURLOPT_WRITEFUNCTION: + case CURLOPT_FILE: + return CALLBACK_WRITE; + break; + + case CURLOPT_READFUNCTION: + case CURLOPT_INFILE: + return CALLBACK_READ; + break; + + case CURLOPT_HEADERFUNCTION: + case CURLOPT_WRITEHEADER: + return CALLBACK_HEADER; + break; + + case CURLOPT_PROGRESSFUNCTION: + case CURLOPT_PROGRESSDATA: + return CALLBACK_PROGRESS; + break; + case CURLOPT_DEBUGFUNCTION: + case CURLOPT_DEBUGDATA: + return CALLBACK_DEBUG; + break; + } + croak("Bad callback index requested\n"); + return CALLBACK_LAST; +} + +/* switch from curl slist names to an slist index */ +static perl_curl_easy_slist_code slist_index(int option) +{ + switch(option) { + case CURLOPT_HTTPHEADER: + return SLIST_HTTPHEADER; + break; + case CURLOPT_QUOTE: + return SLIST_QUOTE; + break; + case CURLOPT_POSTQUOTE: + return SLIST_POSTQUOTE; + break; + } + croak("Bad slist index requested\n"); + return SLIST_LAST; +} + +static perl_curl_easy * perl_curl_easy_new() +{ + perl_curl_easy *self; + Newz(1, self, 1, perl_curl_easy); + if (!self) + croak("out of memory"); + self->curl=curl_easy_init(); + return self; +} + +static perl_curl_easy * perl_curl_easy_duphandle(perl_curl_easy *orig) +{ + perl_curl_easy *self; + Newz(1, self, 1, perl_curl_easy); + if (!self) + croak("out of memory"); + self->curl=curl_easy_duphandle(orig->curl); + return self; +} + +static void perl_curl_easy_delete(perl_curl_easy *self) +{ + perl_curl_easy_slist_code index; + perl_curl_easy_callback_code i; + + if (self->curl) + curl_easy_cleanup(self->curl); + + *self->y = *self->y - 1; + if (*self->y <= 0) { + for (index=0;index<SLIST_LAST;index++) { + if (self->slist[index]) curl_slist_free_all(self->slist[index]); + }; + Safefree(self->y); + } + for(i=0;i<CALLBACK_LAST;i++) { + sv_2mortal(self->callback[i]); + } + for(i=0;i<CALLBACK_LAST;i++) { + sv_2mortal(self->callback_ctx[i]); + } + + + if (self->errbufvarname) + free(self->errbufvarname); + + Safefree(self); + +} + +/* Register a callback function */ + +static void perl_curl_easy_register_callback(perl_curl_easy *self, SV **callback, SV *function) +{ + if (function && SvOK(function)) { + /* FIXME: need to check the ref-counts here */ + if (*callback == NULL) { + *callback = newSVsv(function); + } else { + SvSetSV(*callback, function); + } + } else { + if (*callback != NULL) { + sv_2mortal(*callback); + *callback = NULL; + } + } +} + +/* start of form functions - very un-finished! */ +static perl_curl_form * perl_curl_form_new() +{ + perl_curl_form *self; + Newz(1, self, 1, perl_curl_form); + if (!self) + croak("out of memory"); + self->post=NULL; + self->last=NULL; + return self; +} + +static void perl_curl_form_delete(perl_curl_form *self) +{ +#if 0 + if (self->post) { + curl_formfree(self->post); + } +#endif + Safefree(self); +} + +/* make a new multi */ +static perl_curl_multi * perl_curl_multi_new() +{ + perl_curl_multi *self; + Newz(1, self, 1, perl_curl_multi); + if (!self) + croak("out of memory"); +#ifdef __CURL_MULTI_H + self->curlm=curl_multi_init(); +#else + croak("curl version too old to support curl_multi_init()"); +#endif + return self; +} + +/* delete the multi */ +static void perl_curl_multi_delete(perl_curl_multi *self) +{ +#ifdef __CURL_MULTI_H + if (self->curlm) + curl_multi_cleanup(self->curlm); + Safefree(self); +#endif + +} + +/* make a new share */ +static perl_curl_share * perl_curl_share_new() +{ + perl_curl_share *self; + Newz(1, self, 1, perl_curl_share); + if (!self) + croak("out of memory"); + self->curlsh=curl_share_init(); + return self; +} + +/* delete the share */ +static void perl_curl_share_delete(perl_curl_share *self) +{ + if (self->curlsh) + curl_share_cleanup(self->curlsh); + Safefree(self); +} + + +/* generic fwrite callback, which decides which callback to call */ +static size_t +fwrite_wrapper ( + const void *ptr, + size_t size, + size_t nmemb, + perl_curl_easy *self, + void *call_function, + void *call_ctx) +{ + dSP; + + if (call_function) { /* We are doing a callback to perl */ + int count, status; + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + + if (ptr) { + XPUSHs(sv_2mortal(newSVpvn((char *)ptr, (STRLEN)(size * nmemb)))); + } else { /* just in case */ + XPUSHs(&PL_sv_undef); + } + if (call_ctx) { + XPUSHs(sv_2mortal(newSVsv(call_ctx))); + } else { /* should be a stdio glob ? */ + XPUSHs(&PL_sv_undef); + } + + PUTBACK; + count = perl_call_sv((SV *) call_function, G_SCALAR); + SPAGAIN; + + if (count != 1) + croak("callback for CURLOPT_WRITEFUNCTION didn't return a status\n"); + + status = POPi; + + PUTBACK; + FREETMPS; + LEAVE; + return status; + + } else { + /* perform write directly, via PerlIO */ + + PerlIO *handle; + if (call_ctx) { /* Assume the context is a GLOB */ + handle = IoOFP(sv_2io(call_ctx)); + + } else { /* punt to stdout */ + handle = PerlIO_stdout(); + } + return PerlIO_write(handle,ptr,size*nmemb); + } +} + +/* debug fwrite callback */ +static size_t +fwrite_wrapper2 ( + const void *ptr, + size_t size, + perl_curl_easy *self, + void *call_function, + void *call_ctx, + int curl_infotype) +{ + dSP; + + if (call_function) { /* We are doing a callback to perl */ + int count, status; + SV *sv; + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + + if (ptr) { + XPUSHs(sv_2mortal(newSVpvn((char *)ptr, (STRLEN)(size * sizeof(char))))); + } else { /* just in case */ + XPUSHs(&PL_sv_undef); + } + + if (call_ctx) { + XPUSHs(sv_2mortal(newSVsv(call_ctx))); + } else { /* should be a stdio glob ? */ + XPUSHs(&PL_sv_undef); + } + + XPUSHs(sv_2mortal(newSViv(curl_infotype))); + + PUTBACK; + count = perl_call_sv((SV *) call_function, G_SCALAR); + SPAGAIN; + + if (count != 1) + croak("callback for CURLOPT_*FUNCTION didn't return a status\n"); + + status = POPi; + + PUTBACK; + FREETMPS; + LEAVE; + return status; + + } else { + /* perform write directly, via PerlIO */ + + PerlIO *handle; + if (call_ctx) { /* Assume the context is a GLOB */ + handle = IoOFP(sv_2io(call_ctx)); + + } else { /* punt to stdout */ + handle = PerlIO_stdout(); + } + return PerlIO_write(handle,ptr,size*sizeof(char)); + } +} + +/* Write callback for calling a perl callback */ +size_t +write_callback_func(const void *ptr, size_t size, size_t nmemb, void *stream) +{ + perl_curl_easy *self; + self=(perl_curl_easy *)stream; + return fwrite_wrapper(ptr,size,nmemb,self, + self->callback[CALLBACK_WRITE],self->callback_ctx[CALLBACK_WRITE]); +} + +/* header callback for calling a perl callback */ +size_t +writeheader_callback_func(const void *ptr, size_t size, size_t nmemb, void *stream) +{ + perl_curl_easy *self; + self=(perl_curl_easy *)stream; + + return fwrite_wrapper(ptr,size,nmemb,self, + self->callback[CALLBACK_HEADER],self->callback_ctx[CALLBACK_HEADER]); +} + +/* debug callback for calling a perl callback */ +size_t +debug_callback_func(CURL* handle, int curl_infotype, const void *ptr, size_t size, void *stream) +{ + perl_curl_easy *self; + self=(perl_curl_easy *)stream; + + return fwrite_wrapper2(ptr,size,self, + self->callback[CALLBACK_DEBUG],self->callback_ctx[CALLBACK_DEBUG],curl_infotype); +} + +/* read callback for calling a perl callback */ +size_t +read_callback_func( void *ptr, size_t size, size_t nmemb, void *stream) +{ + dSP ; + + size_t maxlen; + perl_curl_easy *self; + self=(perl_curl_easy *)stream; + + maxlen = size*nmemb; + + if (self->callback[CALLBACK_READ]) { /* We are doing a callback to perl */ + char *data; + int count; + SV *sv; + STRLEN len; + + ENTER ; + SAVETMPS ; + + PUSHMARK(SP) ; + + if (self->callback_ctx[CALLBACK_READ]) { + sv = self->callback_ctx[CALLBACK_READ]; + } else { + sv = &PL_sv_undef; + } + + XPUSHs(sv_2mortal(newSViv(maxlen))); + XPUSHs(sv_2mortal(newSVsv(sv))); + + PUTBACK ; + count = perl_call_sv(self->callback[CALLBACK_READ], G_SCALAR); + SPAGAIN; + + if (count != 1) + croak("callback for CURLOPT_READFUNCTION didn't return any data\n"); + + sv = POPs; + data = SvPV(sv,len); + + /* only allowed to return the number of bytes asked for */ + len = (len<maxlen ? len : maxlen); + /* memcpy(ptr,data,(size_t)len); */ + Copy(data,ptr,len,char); + + PUTBACK ; + FREETMPS ; + LEAVE ; + return (size_t) (len/size); + + } else { + /* read input directly */ + PerlIO *f; + if (self->callback_ctx[CALLBACK_READ]) { /* hope its a GLOB! */ + f = IoIFP(sv_2io(self->callback_ctx[CALLBACK_READ])); + } else { /* punt to stdin */ + f = PerlIO_stdin(); + } + return PerlIO_read(f,ptr,maxlen); + } +} + +/* Progress callback for calling a perl callback */ + +static int progress_callback_func(void *clientp, double dltotal, double dlnow, + double ultotal, double ulnow) +{ + dSP; + + int count; + perl_curl_easy *self; + self=(perl_curl_easy *)clientp; + + ENTER; + SAVETMPS; + PUSHMARK(sp); + if (self->callback_ctx[CALLBACK_PROGRESS]) { + XPUSHs(sv_2mortal(newSVsv(self->callback_ctx[CALLBACK_PROGRESS]))); + } else { + XPUSHs(&PL_sv_undef); + } + XPUSHs(sv_2mortal(newSVnv(dltotal))); + XPUSHs(sv_2mortal(newSVnv(dlnow))); + XPUSHs(sv_2mortal(newSVnv(ultotal))); + XPUSHs(sv_2mortal(newSVnv(ulnow))); + + PUTBACK; + count = perl_call_sv(self->callback[CALLBACK_PROGRESS], G_SCALAR); + SPAGAIN; + + if (count != 1) + croak("callback for CURLOPT_PROGRESSFUNCTION didn't return 1\n"); + + count = POPi; + + PUTBACK; + FREETMPS; + LEAVE; + return count; +} + + + +#if 0 +/* awaiting closepolicy prototype */ +int +closepolicy_callback_func(void *clientp) +{ + dSP; + int argc, status; + SV *pl_status; + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + PUTBACK; + + argc = perl_call_sv(closepolicy_callback, G_SCALAR); + SPAGAIN; + + if (argc != 1) { + croak("Unexpected number of arguments returned from closefunction callback\n"); + } + pl_status = POPs; + status = SvTRUE(pl_status) ? 0 : 1; + + PUTBACK; + FREETMPS; + LEAVE; + + return status; +} +#endif + +#include "curlopt-constants.c" + +typedef perl_curl_easy * WWW__Curl__Easy; + +typedef perl_curl_form * WWW__Curl__Form; + +typedef perl_curl_multi * WWW__Curl__Multi; + +typedef perl_curl_share * WWW__Curl__Share; + +MODULE = WWW::Curl PACKAGE = WWW::Curl::Easy PREFIX = curl_easy_ + +BOOT: + curl_global_init(CURL_GLOBAL_ALL); /* FIXME: does this need a mutex for ithreads? */ + + +PROTOTYPES: ENABLE + +int +constant(name,arg) + char * name + int arg + + +void +curl_easy_init(...) + ALIAS: + new = 1 + PREINIT: + perl_curl_easy *self; + char *sclass = "WWW::Curl::Easy"; + + PPCODE: + if (items>0 && !SvROK(ST(0))) { + STRLEN dummy; + sclass = SvPV(ST(0),dummy); + } + + self=perl_curl_easy_new(); /* curl handle created by this point */ + ST(0) = sv_newmortal(); + sv_setref_pv(ST(0), sclass, (void*)self); + SvREADONLY_on(SvRV(ST(0))); + + Newxz(self->y,1,I32); + if (!self->y) { croak ("out of memory"); } + (*self->y)++; + /* configure curl to always callback to the XS interface layer */ + curl_easy_setopt(self->curl, CURLOPT_WRITEFUNCTION, write_callback_func); + curl_easy_setopt(self->curl, CURLOPT_READFUNCTION, read_callback_func); + + /* set our own object as the context for all curl callbacks */ + curl_easy_setopt(self->curl, CURLOPT_FILE, self); + curl_easy_setopt(self->curl, CURLOPT_INFILE, self); + + /* we always collect this, in case it's wanted */ + curl_easy_setopt(self->curl, CURLOPT_ERRORBUFFER, self->errbuf); + + XSRETURN(1); + +void +curl_easy_duphandle(self) + WWW::Curl::Easy self + PREINIT: + perl_curl_easy *clone; + char *sclass = "WWW::Curl::Easy"; + perl_curl_easy_callback_code i; + + PPCODE: + clone=perl_curl_easy_duphandle(self); + clone->y = self->y; + (*self->y)++; + + ST(0) = sv_newmortal(); + sv_setref_pv(ST(0), sclass, (void*)clone); + SvREADONLY_on(SvRV(ST(0))); + + /* configure curl to always callback to the XS interface layer */ + + curl_easy_setopt(clone->curl, CURLOPT_WRITEFUNCTION, write_callback_func); + curl_easy_setopt(clone->curl, CURLOPT_READFUNCTION, read_callback_func); + if (self->callback[callback_index(CURLOPT_HEADERFUNCTION)] || self->callback_ctx[callback_index(CURLOPT_WRITEHEADER)]) { + curl_easy_setopt(clone->curl, CURLOPT_HEADERFUNCTION, header_callback_func); + curl_easy_setopt(clone->curl, CURLOPT_WRITEHEADER, clone); + } + + if (self->callback[callback_index(CURLOPT_PROGRESSFUNCTION)] || self->callback_ctx[callback_index(CURLOPT_PROGRESSDATA)]) { + curl_easy_setopt(clone->curl, CURLOPT_PROGRESSFUNCTION, progress_callback_func); + curl_easy_setopt(clone->curl, CURLOPT_PROGRESSDATA, clone); + } + + if (self->callback[callback_index(CURLOPT_DEBUGFUNCTION)] || self->callback_ctx[callback_index(CURLOPT_DEBUGDATA)]) { + curl_easy_setopt(clone->curl, CURLOPT_DEBUGFUNCTION, debug_callback_func); + curl_easy_setopt(clone->curl, CURLOPT_DEBUGDATA, clone); + } + + /* set our own object as the context for all curl callbacks */ + curl_easy_setopt(clone->curl, CURLOPT_FILE, clone); + curl_easy_setopt(clone->curl, CURLOPT_INFILE, clone); + curl_easy_setopt(clone->curl, CURLOPT_ERRORBUFFER, clone->errbuf); + + for(i=0;i<CALLBACK_LAST;i++) { + perl_curl_easy_register_callback(clone,&(clone->callback[i]), self->callback[i]); + perl_curl_easy_register_callback(clone,&(clone->callback_ctx[i]), self->callback_ctx[i]); + }; + + XSRETURN(1); + +char * +curl_easy_version(...) + CODE: + RETVAL=curl_version(); + OUTPUT: + RETVAL + +int +curl_easy_setopt(self, option, value) + WWW::Curl::Easy self + int option + SV * value + CODE: + RETVAL=CURLE_OK; + switch(option) { + /* SV * to user contexts for callbacks - any SV (glob,scalar,ref) */ + case CURLOPT_FILE: + case CURLOPT_INFILE: + perl_curl_easy_register_callback(self, + &(self->callback_ctx[callback_index(option)]), value); + break; + case CURLOPT_WRITEHEADER: + curl_easy_setopt(self->curl, CURLOPT_HEADERFUNCTION, SvOK(value) ? header_callback_func : NULL); + curl_easy_setopt(self->curl, option, SvOK(value) ? self : NULL); + perl_curl_easy_register_callback(self,&(self->callback_ctx[callback_index(option)]),value); + break; + case CURLOPT_PROGRESSDATA: + curl_easy_setopt(self->curl, CURLOPT_PROGRESSFUNCTION, SvOK(value) ? progress_callback_func : NULL); + curl_easy_setopt(self->curl, option, SvOK(value) ? self : NULL); + perl_curl_easy_register_callback(self,&(self->callback_ctx[callback_index(option)]), value); + break; + case CURLOPT_DEBUGDATA: + curl_easy_setopt(self->curl, CURLOPT_DEBUGFUNCTION, SvOK(value) ? debug_callback_func : NULL); + curl_easy_setopt(self->curl, option, SvOK(value) ? self : NULL); + perl_curl_easy_register_callback(self,&(self->callback_ctx[callback_index(option)]), value); + break; + + /* SV * to a subroutine ref */ + case CURLOPT_WRITEFUNCTION: + case CURLOPT_READFUNCTION: + perl_curl_easy_register_callback(self,&(self->callback[callback_index(option)]), value); + break; + case CURLOPT_HEADERFUNCTION: + curl_easy_setopt(self->curl, option, SvOK(value) ? header_callback_func : NULL); + curl_easy_setopt(self->curl, CURLOPT_WRITEHEADER, SvOK(value) ? self : NULL); + perl_curl_easy_register_callback(self,&(self->callback[callback_index(option)]), value); + break; + case CURLOPT_PROGRESSFUNCTION: + curl_easy_setopt(self->curl, option, SvOK(value) ? progress_callback_func : NULL); + curl_easy_setopt(self->curl, CURLOPT_PROGRESSDATA, SvOK(value) ? self : NULL); + perl_curl_easy_register_callback(self,&(self->callback[callback_index(option)]), value); + break; + case CURLOPT_DEBUGFUNCTION: + curl_easy_setopt(self->curl, option, SvOK(value) ? debug_callback_func : NULL); + curl_easy_setopt(self->curl, CURLOPT_DEBUGDATA, SvOK(value) ? self : NULL); + perl_curl_easy_register_callback(self,&(self->callback[callback_index(option)]), value); + break; + + /* slist cases */ + case CURLOPT_HTTPHEADER: + case CURLOPT_QUOTE: + case CURLOPT_POSTQUOTE: + { + /* This is an option specifying a list, which we put in a curl_slist struct */ + AV *array = (AV *)SvRV(value); + struct curl_slist **slist = NULL; + int last = av_len(array); + int i; + + /* We have to find out which list to use... */ + slist = &(self->slist[slist_index(option)]); + + /* free any previous list */ + if (*slist) { + curl_slist_free_all(*slist); + *slist=NULL; + } + /* copy perl values into this slist */ + for (i=0;i<=last;i++) { + SV **sv = av_fetch(array,i,0); + STRLEN len = 0; + char *string = SvPV(*sv, len); + if (len == 0) /* FIXME: is this correct? */ + break; + *slist = curl_slist_append(*slist, string); + } + /* pass the list into curl_easy_setopt() */ + RETVAL = curl_easy_setopt(self->curl, option, *slist); + }; + break; + + /* Pass in variable name for storing error messages. Yuck. */ + case CURLOPT_ERRORBUFFER: + { + STRLEN dummy; + if (self->errbufvarname) + free(self->errbufvarname); + self->errbufvarname = strdup((char *)SvPV(value, dummy)); + }; + break; + + /* tell curl to redirect STDERR - value should be a glob */ + case CURLOPT_STDERR: + RETVAL = curl_easy_setopt(self->curl, option, IoOFP(sv_2io(value)) ); + break; + + /* not working yet... + case CURLOPT_HTTPPOST: + if (sv_derived_from(value, "WWW::Curl::Form")) { + WWW__Curl__form wrapper; + IV tmp = SvIV((SV*)SvRV(value)); + wrapper = INT2PTR(WWW__Curl__form,tmp); + RETVAL = curl_easy_setopt(self->curl, option, wrapper->post); + } else + croak("value is not of type WWW::Curl::Form"); + break; + */ + + /* Curl share support from Anton Fedorov */ +#if (LIBCURL_VERSION_NUM>=0x070a03) + case CURLOPT_SHARE: + if (sv_derived_from(value, "WWW::Curl::Share")) { + WWW__Curl__Share wrapper; + IV tmp = SvIV((SV*)SvRV(value)); + wrapper = INT2PTR(WWW__Curl__Share,tmp); + RETVAL = curl_easy_setopt(self->curl, option, wrapper->curlsh); + } else + croak("value is not of type WWW::Curl::Share"); + break; +#endif + case CURLOPT_PRIVATE: + RETVAL = curl_easy_setopt(self->curl, option, (long)SvIV(value)); + break; + + /* default cases */ + default: + if (option < CURLOPTTYPE_OBJECTPOINT) { /* A long (integer) value */ + RETVAL = curl_easy_setopt(self->curl, option, (long)SvIV(value)); + } + else if (option < CURLOPTTYPE_FUNCTIONPOINT) { /* An objectpoint - string */ + /* FIXME: Does curl really want NULL for empty strings? */ + STRLEN dummy; + char *pv = SvPV(value, dummy); + RETVAL = curl_easy_setopt(self->curl, option, SvOK(value) ? pv : NULL); + } +#ifdef CURLOPTTYPE_OFF_T + else if (option < CURLOPTTYPE_OFF_T) { /* A function - notreached? */ + croak("Unknown curl option of type function"); + } + else { /* A LARGE file option using curl_off_t */ + RETVAL = curl_easy_setopt(self->curl, option, (curl_off_t)SvIV(value)); + } +#endif + ; + break; + }; + OUTPUT: + RETVAL + +int +internal_setopt(self, option, value) + WWW::Curl::Easy self + int option + int value + CODE: + croak("internal_setopt no longer supported - use a callback\n"); + RETVAL = 0; + OUTPUT: + RETVAL + +int +curl_easy_perform(self) + WWW::Curl::Easy self + CODE: + /* perform the actual curl fetch */ + RETVAL = curl_easy_perform(self->curl); + + if (RETVAL && self->errbufvarname) { + /* If an error occurred and a varname for error messages has been + specified, store the error message. */ + SV *sv = perl_get_sv(self->errbufvarname, TRUE | GV_ADDMULTI); + sv_setpv(sv, self->errbuf); + } + OUTPUT: + RETVAL + + +SV * +curl_easy_getinfo(self, option, ... ) + WWW::Curl::Easy self + int option + CODE: + switch (option & CURLINFO_TYPEMASK) { + case CURLINFO_STRING: + { + char * vchar; + curl_easy_getinfo(self->curl, option, &vchar); + RETVAL = newSVpv(vchar,0); + break; + } + case CURLINFO_LONG: + { + long vlong; + curl_easy_getinfo(self->curl, option, &vlong); + RETVAL = newSViv(vlong); + break; + } + case CURLINFO_DOUBLE: + { + double vdouble; + curl_easy_getinfo(self->curl, option, &vdouble); + RETVAL = newSVnv(vdouble); + break; + } + default: { + RETVAL = newSViv(CURLE_BAD_FUNCTION_ARGUMENT); + break; + } + } + if (items > 2) + sv_setsv(ST(2),RETVAL); + OUTPUT: + RETVAL + +char * +curl_easy_errbuf(self) + WWW::Curl::Easy self + CODE: + RETVAL = self->errbuf; + OUTPUT: + RETVAL + +int +curl_easy_cleanup(self) + WWW::Curl::Easy self + CODE: + /* does nothing anymore - cleanup is automatic when a curl handle goes out of scope */ + RETVAL = 0; + OUTPUT: + RETVAL + +void +curl_easy_DESTROY(self) + WWW::Curl::Easy self + CODE: + perl_curl_easy_delete(self); + +void +curl_easy_global_cleanup() + CODE: + curl_global_cleanup(); + +SV * +curl_easy_strerror(self, errornum) + WWW::Curl::Easy self + int errornum + CODE: + { +#if (LIBCURL_VERSION_NUM>=0x070C00) + const char * vchar = curl_easy_strerror(errornum); +#else + const char * vchar = "Unknown because curl_easy_strerror function not available}"; +#endif + RETVAL = newSVpv(vchar,0); + } + OUTPUT: + RETVAL + +MODULE = WWW::Curl PACKAGE = WWW::Curl::Form PREFIX = curl_form_ + +void +curl_form_new(...) + PREINIT: + perl_curl_form *self; + char *sclass = "WWW::Curl::Form"; + PPCODE: + if (items>0 && !SvROK(ST(0))) { + STRLEN dummy; + sclass = SvPV(ST(0),dummy); + } + + self=perl_curl_form_new(); + + ST(0) = sv_newmortal(); + sv_setref_pv(ST(0), sclass, (void*)self); + SvREADONLY_on(SvRV(ST(0))); + + XSRETURN(1); + +void +curl_form_add(self,name,value) + WWW::Curl::Form self + char *name + char *value + CODE: +#if 0 + curl_formadd(&(self->post),&(self->last), + CURLFORM_COPYNAME,name, + CURLFORM_COPYCONTENTS,value, + CURLFORM_END); +#endif + +void +curl_form_addfile(self,filename,description,type) + WWW::Curl::Form self + char *filename + char *description + char *type + CODE: +#if 0 + curl_formadd(&(self->post),&(self->last), + CURLFORM_FILE,filename, + CURLFORM_COPYNAME,description, + CURLFORM_CONTENTTYPE,type, + CURLFORM_END); +#endif + +void +curl_form_DESTROY(self) + WWW::Curl::Form self + CODE: + perl_curl_form_delete(self); + +MODULE = WWW::Curl PACKAGE = WWW::Curl::Multi PREFIX = curl_multi_ + +void +curl_multi_new(...) + PREINIT: + perl_curl_multi *self; + char *sclass = "WWW::Curl::Multi"; + PPCODE: + if (items>0 && !SvROK(ST(0))) { + STRLEN dummy; + sclass = SvPV(ST(0),dummy); + } + + self=perl_curl_multi_new(); + + ST(0) = sv_newmortal(); + sv_setref_pv(ST(0), sclass, (void*)self); + SvREADONLY_on(SvRV(ST(0))); + + XSRETURN(1); + +void +curl_multi_add_handle(curlm, curl) + WWW::Curl::Multi curlm + WWW::Curl::Easy curl + CODE: +#ifdef __CURL_MULTI_H + curl_multi_add_handle(curlm->curlm, curl->curl); +#endif + +void +curl_multi_remove_handle(curlm, curl) + WWW::Curl::Multi curlm + WWW::Curl::Easy curl + CODE: +#ifdef __CURL_MULTI_H + curl_multi_remove_handle(curlm->curlm, curl->curl); +#endif + +void +curl_multi_info_read(self) + WWW::Curl::Multi self + PREINIT: + CURL *easy = NULL; + CURLcode res; + long stashid; + int queue; + CURLMsg *msg; + PPCODE: + while ((msg = curl_multi_info_read(self->curlm, &queue))) { + if (msg->msg == CURLMSG_DONE) { + easy=msg->easy_handle; + res=msg->data.result; + break; + } + }; + if (easy) { + curl_easy_getinfo(easy, CURLINFO_PRIVATE, &stashid); + curl_easy_setopt(easy, CURLINFO_PRIVATE, NULL); + curl_multi_remove_handle(self->curlm, easy); + XPUSHs(sv_2mortal(newSViv(stashid))); + XPUSHs(sv_2mortal(newSViv(res))); + } else { + XSRETURN_EMPTY; + } + +int +curl_multi_perform(self) + WWW::Curl::Multi self + PREINIT: + int remaining; + CODE: +#ifdef __CURL_MULTI_H + while(CURLM_CALL_MULTI_PERFORM == + curl_multi_perform(self->curlm, &remaining)); + RETVAL = remaining; + /* while(remaining) { + struct timeval timeout; + int rc; + fd_set fdread; + fd_set fdwrite; + fd_set fdexcep; + int maxfd; + FD_ZERO(&fdread); + FD_ZERO(&fdwrite); + FD_ZERO(&fdexcep); + timeout.tv_sec = 1; + timeout.tv_usec = 0; + curl_multi_fdset(self->curlm, &fdread, &fdwrite, &fdexcep, &maxfd); + rc = select(maxfd+1, &fdread, &fdwrite, &fdexcep, &timeout); + switch(rc) { + case -1: + break; + default: + while(CURLM_CALL_MULTI_PERFORM == + curl_multi_perform(self->curlm, &remaining)); + break; + } + } */ +#endif + OUTPUT: + RETVAL + +void +curl_multi_DESTROY(self) + WWW::Curl::Multi self + CODE: + perl_curl_multi_delete(self); + +SV * +curl_multi_strerror(self, errornum) + WWW::Curl::Multi self + int errornum + CODE: + { +#if (LIBCURL_VERSION_NUM>=0x070C00) + const char * vchar = curl_multi_strerror(errornum); +#else + const char * vchar = "Unknown because curl_multi_strerror function not available}"; +#endif + RETVAL = newSVpv(vchar,0); + } + OUTPUT: + RETVAL + +MODULE = WWW::Curl PACKAGE = WWW::Curl::Share PREFIX = curl_share_ + +PROTOTYPES: ENABLE + +int +constant(name,arg) + char * name + int arg + +void +curl_share_new(...) + PREINIT: + perl_curl_share *self; + char *sclass = "WWW::Curl::Share"; + PPCODE: + if (items>0 && !SvROK(ST(0))) { + STRLEN dummy; + sclass = SvPV(ST(0),dummy); + } + + self=perl_curl_share_new(); + + ST(0) = sv_newmortal(); + sv_setref_pv(ST(0), sclass, (void*)self); + SvREADONLY_on(SvRV(ST(0))); + + XSRETURN(1); + +void +curl_share_DESTROY(self) + WWW::Curl::Share self + CODE: + perl_curl_share_delete(self); + +int +curl_share_setopt(self, option, value) + WWW::Curl::Share self + int option + SV * value + CODE: + RETVAL=CURLE_OK; +#if (LIBCURL_VERSION_NUM>=0x070a03) + switch(option) { + /* slist cases */ + case CURLSHOPT_SHARE: + case CURLSHOPT_UNSHARE: + if (option < CURLOPTTYPE_OBJECTPOINT) { /* An integer value: */ + RETVAL = curl_share_setopt(self->curlsh, option, (long)SvIV(value)); + } else { /* A char * value: */ + /* FIXME: Does curl really want NULL for empty strings? */ + STRLEN dummy; + char *pv = SvPV(value, dummy); + RETVAL = curl_share_setopt(self->curlsh, option, *pv ? pv : NULL); + }; + break; + }; +#else + croak("curl_share_setopt not supported in your libcurl version"); +#endif + OUTPUT: + RETVAL + +SV * +curl_share_strerror(self, errornum) + WWW::Curl::Share self + int errornum + CODE: + { +#if (LIBCURL_VERSION_NUM>=0x070C00) + const char * vchar = curl_share_strerror(errornum); +#else + const char * vchar = "Unknown because curl_share_strerror function not available}"; +#endif + RETVAL = newSVpv(vchar,0); + } + OUTPUT: + RETVAL @@ -0,0 +1,4 @@ +You may opt to use, copy, modify, merge, publish, distribute and/or sell +copies of the Software, and permit persons to whom the Software is furnished +to do so, under the terms of the MPL or the MIT/X-derivate licenses. You may +pick one of these licenses. diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..1fb8309 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,55 @@ +Changes +Curl.xs +inc/Module/Install.pm +inc/Module/Install/Base.pm +inc/Module/Install/Can.pm +inc/Module/Install/External.pm +inc/Module/Install/Makefile.pm +inc/Module/Install/MakeMaker.pm +inc/Module/Install/Metadata.pm +lib/WWW/Curl.pm +lib/WWW/Curl/Easy.pm +lib/WWW/Curl/Form.pm +lib/WWW/Curl/Multi.pm +lib/WWW/Curl/Share.pm +LICENSE +Makefile.PL +MANIFEST +META.yml +README +README.Win32 +SIGNATURE +t/00constants.t +t/01basic.t +t/02callbacks.t +t/04abort-test.t +t/05progress.t +t/06http-post.t +t/07ftp-upload.t +t/08ssl.t +t/09times.t +t/10errbuf.t +t/13slowleak.t +t/14duphandle.t +t/15duphandle-callback.t +t/16formpost.t +t/17slist.t +t/18twinhandles.t +t/meta.t +t/pod-coverage.t +t/pod.t +t/new/00constants.t +t/new/01basic.t +t/new/02header-callback.t +t/new/03body-callback.t +t/new/04abort.t +t/new/05progress.t +t/new/06http-post.t +t/new/07errbuf.t +t/new/08duphandle.t +t/new/09duphandle-callback.t +t/new/10multi-callback.t +t/new/README +template/Easy.pm.tmpl +template/Share.pm.tmpl +typemap diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..8e51613 --- /dev/null +++ b/META.yml @@ -0,0 +1,22 @@ +--- +abstract: 'Perl extension interface for libcurl' +author: + - 'Cris Bailiff <c.bailiff+curl at devsecure.com>' +configure_requires: + ExtUtils::MakeMaker: 6.42 +distribution_type: module +generated_by: 'Module::Install version 0.75' +license: 'MPL or MIT/X-derivate' +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.3.html + version: 1.3 +module_name: WWW::Curl +name: WWW-Curl +no_index: + directory: + - template + - inc + - t +requires: + perl: 5.6.1 +version: 4.05 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..92c3ba3 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,302 @@ +# Makefile.PL for Perl module WWW::Curl +# Check out the README file for more information. + +use inc::Module::Install; + +name 'WWW-Curl'; +abstract 'Perl extension interface for libcurl'; +author 'Cris Bailiff <c.bailiff+curl at devsecure.com>'; +license 'MPL or MIT/X-derivate'; +perl_version '5.006001'; +no_index directory => 'template'; +# This is a hack. If you have libcurl installed, just specify curl.h below +# and comment out this line. +if ($^O ne 'MSWin32') { + requires_external_bin 'curl-config'; +} else { + print "Sorry, no automated install is available on Windows,\n". + "please see the README.Win32 file on instructions for a manual install.\n"; + exit(0); +} + +my @includes = qw(); +my ($cflags,$lflags, $ldflags) = ('','',''); + +# This utility helper generates the constants function from curl.h +# It is normally only used by the maintainer, but if you're curl is older +# or missing some constants, you can delete curlopt-constants.c and re-run 'perl Makefile.PL' +# You may need to specify where to find curl.h on your platform +# These are guesses only, in case curl-config is not telling us. + +if ($^O ne 'MSWin32') { + push @includes, qw( + /usr/include + /usr/local/curl/include + /usr/local/include/curl + ../../include + ../curl/include + ); +} +# +# Get curl to tell us where it is, if we can. +# + + +if ($^O ne 'MSWin32') { + $cflags = `curl-config --cflags`; + $lflags = `curl-config --libs`; +} + +# can't find link flags, make some guesses +if (!defined($lflags)) { + $lflags="-lcurl"; + print "Guessing your linker flags as: $lflags\n"; +} + +my ($flag) = ($cflags =~ m/-I(\S+)/); + +if (defined $flag) { + unshift @includes, $flag; # first guess +} + +# try the path given on the command line, if any +if (defined($ARGV[0])) { + unshift @includes, $ARGV[0]; +}; + +my $curl_d = ""; +my $curl_h; + +# otherwise try a list of common locations +foreach my $try (@includes) { + if (-f $try . "/curl/curl.h") { + $curl_d = $try; + $curl_h = $try . "/curl/curl.h"; + last; + } +} + +if (!defined($curl_h)) { + die "Cannot find curl.h - cannot build constants files - see Makefile.PL"; +} else { + $curl_d = "-I" . $curl_d; + print "Found curl.h in $curl_h\n"; + open(CURL_H, "<" . $curl_h) or die "Can't open curl.h\n"; + my %cinit_types; + my %cinit_codes; + my @curlinfo; + my @curlshopt; + my @curllockopt; + while (<CURL_H>) { + if ($_ =~ m/CINIT\(/ and $_ !~ m/#/) { + my ($option, $type, $code) = + m/.*CINIT\((\w*)\s*,\s*(\w+)\s*,\s*(\d+).*/; + $cinit_types{$option} = $option; + $cinit_codes{$option} = $code; + } elsif ($_ =~ m/^#define CURLOPT_\w+ CURLOPT_\w+/) { + my ($option, $value) = + m/^#define CURLOPT_(\w+) CURLOPT_(\w+)/; + $cinit_types{$option} = $value; + } elsif ($_ =~ m/^\s*(CURLINFO_\w+)/) { + push @curlinfo, $1; + } elsif ($_ =~ m/^\s*(CURLSHOPT_\w+)/) { + push @curlshopt, $1; + } elsif ($_ =~ m/^\s*(CURL_LOCK_DATA_\w+)/) { + push @curllockopt, $1; + } + + } + close(CURL_H); + + # some things are ifdefed out... + foreach my $ifdef0 (qw(FLAGS PROGRESSMODE MOREDOCS)) { + delete $cinit_types{$ifdef0}; + delete $cinit_codes{$ifdef0}; + } + + print "Building curlopt-constants.c for your libcurl version\n"; + + open(CURL_XS, ">curlopt-constants.c") + or die "Can't write curlopt-constants.c\n"; + + # boilerplate xs constant function here + print CURL_XS <<HERE +static int +constant(char *name, int arg) +{ + errno = 0; + if (strncmp(name, "CURLINFO_", 9) == 0) { + name += 9; + switch (*name) { +HERE + ; + foreach my $next_initial ('A' .. 'Z') { + print CURL_XS " case '$next_initial':\n"; + my $count = 0; + foreach my $curlinfo_name (sort @curlinfo) { + my $initial = substr($curlinfo_name, 9, 1); + my $option = substr($curlinfo_name, 9); + if ($next_initial eq $initial) { + + print CURL_XS +" if (strEQ(name, \"$option\")) return CURLINFO_$option;\n"; + + $count++; + } + } + if ($count or $next_initial eq 'Z') { + print CURL_XS " break;\n"; + } + } + + print CURL_XS " };\n"; + print CURL_XS " }\n"; + + # CURLOPT_ + print CURL_XS <<HERE2 + + if (strncmp(name, "CURLOPT_", 8) == 0) { + name += 8; + switch (*name) { +HERE2 + ; + + foreach my $next_initial ('A' .. 'Z') { + print CURL_XS " case '$next_initial':\n"; + my $count = 0; + foreach my $option (sort keys %cinit_types) { + my $initial = substr($option, 0, 1); + if ($next_initial eq $initial) { + + print CURL_XS +" if (strEQ(name, \"$option\")) return CURLOPT_$cinit_types{$option};\n"; + + $count++; + } + } + if ($count or $next_initial eq 'Z') { + print CURL_XS " break;\n"; + } + } + + print CURL_XS " };\n"; + print CURL_XS " }\n"; + + # CURLSHOPT_ + print CURL_XS <<HERE2 + + if (strncmp(name, "CURLSHOPT_", 10) == 0) { + name += 10; + switch (*name) { +HERE2 + ; + + foreach my $next_initial ('A' .. 'Z') { + print CURL_XS " case '$next_initial':\n"; + my $count = 0; + foreach my $option (sort @curlshopt) { + my $initial = substr($option, 10, 1); + if ($next_initial eq $initial) { + my $optsuff = substr($option, 10); + print CURL_XS +" if (strEQ(name, \"$optsuff\")) return $option;\n"; + + $count++; + } + } + if ($count or $next_initial eq 'Z') { + print CURL_XS " break;\n"; + } + } + + print CURL_XS " };\n"; + print CURL_XS " }\n"; + + # CURL_LOCK_DATA_ + print CURL_XS <<HERE2 + if (strncmp(name, "CURL_LOCK_DATA_", 15) == 0) { + name += 15; + switch (*name) { +HERE2 + ; + + foreach my $next_initial ('A' .. 'Z') { + print CURL_XS " case '$next_initial':\n"; + my $count = 0; + foreach my $option (sort @curllockopt) { + my $initial = substr($option, 15, 1); + if ($next_initial eq $initial) { + my $optsuff = substr($option, 15); + print CURL_XS +" if (strEQ(name, \"$optsuff\")) return $option;\n"; + + $count++; + } + } + if ($count or $next_initial eq 'Z') { + print CURL_XS " break;\n"; + } + } + + print CURL_XS " };\n"; + print CURL_XS " }\n"; + + print CURL_XS <<HERE + + errno = EINVAL; + return 0; +} +HERE + ; + + close(CURL_XS); + + print "Building Easy.pm constants for your libcurl version\n"; + + open(EASY_PM, ">lib/WWW/Curl/Easy.pm") or die "Can't create lib/WWW/Curl/Easy.pm\n"; + open(EASY_PM_IN, "template/Easy.pm.tmpl") or die "Can't read template/Easy.pm.tmpl\n"; + while (my $line = <EASY_PM_IN>) { + if ($line !~ m/^\@CURLOPT_INCLUDE\@/) { + print EASY_PM $line; + } else { + foreach my $option (sort keys %cinit_types) { + next unless $option; # an empty CURLOPT_ + print EASY_PM "CURLOPT_$option\n"; + } + foreach my $option (sort @curlinfo) { + print EASY_PM $option . "\n"; + } + } + } + close(EASY_PM); + close(EASY_PM_IN); + + print "Building Share.pm constants for your libcurl version\n"; + + open(SHARE_PM, ">lib/WWW/Curl/Share.pm") or die "Can't create lib/WWW/Curl/Share.pm\n"; + open(SHARE_PM_IN, "template/Share.pm.tmpl") or die "Can't read template/Share.pm.tmpl\n"; + while (my $line = <SHARE_PM_IN>) { + if ($line !~ m/^(.*?)\@CURLSHOPT_INCLUDE\@/) { + print SHARE_PM $line; + } else { + foreach my $option (sort @curlshopt) { + print SHARE_PM $1 . $option . "\n"; + } + foreach my $option (sort @curllockopt) { + print SHARE_PM $1 . $option . "\n"; + } + } + } + close(SHARE_PM); + close(SHARE_PM_IN); +} + +# Let Module::Install generate META.yml and other necessary files. +WriteMakefile( + 'NAME' => 'WWW::Curl', + 'VERSION_FROM' => 'lib/WWW/Curl.pm', # finds $VERSION + 'LIBS' => "$ldflags $lflags", # e.g., '-lm' + 'INC' => $curl_d, # e.g., '-I/usr/include/other' + 'clean' => { FILES => "curlopt-constants.c head.out body.out" } +); + @@ -0,0 +1,59 @@ +README for Perl extension WWW::Curl + +The perl module WWW::Curl provides an interface to the cURL library "libcurl". +See http://curl.haxx.se/ for more information on cURL and libcurl. + +This module requires libcurl and the corresponding headerfiles to be +installed. You then may install this module via the usual way +(for installation on Windows please see README.Win32): + + perl Makefile.PL + make + make test + make install + +The Makefile.PL script will try to use the 'curl-config' command to find +the correct headers and libcurl path. If curl.h can't be found, +either through curl-config or the internal list of guesses, you can specify +an explicit path when building the Makefile: + + perl Makefile.PL /home/foo/curl/include + +Minimum version requirements: + +This module, starting from version 4 requires at least Perl 5.6 and libcurl 7.10.8. +These releases are more than 5 years old and they have multiple security vulnerabilities, +it is advised that you upgrade as soon as possible to a more recent, secure version. +Anything older than these versions of Perl and libcurl respectively are not supported. + +Windows specific fixes and patches are welcome as testing is mainly focused on linux. + +The module provides the same functionality, except as noted in the documentation, +as libcurl provides to C programs. Please refer to the documentation of libcurl for the +general interface description and the WWW::Curl POD for the differences. + +This software is distributed AS IS, WITHOUT WARRANTY OF ANY KIND, either +express or implied. + +History: + +The author of the original relase of this software is Georg Horn <horn at koblenz-net.de> + +Parts of the callback support were added Forrest Cahoon +<forrest.cahoon at merrillcorp.com> + +More callback support, many tests additional documentation and Makefile +features have been added by Cris Bailiff <c.bailiff+curl at devsecure.com> + +Curl multi support has been added by Sebastian Riedel <sri at oook.de> + +The current maintainer is Cris Bailiff <c.bailiff+curl at devsecure.com> + +The latest version can be downloaded from http://curl.haxx.se/libcurl/perl/ or +found on CPAN as the module WWW::Curl + +Copyright (C) 2000-2005, 2008 Daniel Stenberg, Cris Bailiff , et al. +You may opt to use, copy, modify, merge, publish, distribute and/or sell +copies of the Software, and permit persons to whom the Software is +furnished to do so, under the terms of the MPL or the MIT/X-derivate +licenses. You may pick one of these licenses. diff --git a/README.Win32 b/README.Win32 new file mode 100644 index 0000000..124b3bf --- /dev/null +++ b/README.Win32 @@ -0,0 +1,12 @@ +Installation on Windows need to be done manually, by editing Makefile.PL. + +1. Specify your curl include directory on the line "my @include = qw()". +2. Specify the following parameters on the line below, where <DIR> is your curl directory like this: + +my ($cflags,$ldflags,$lflags) = ('-I"<DIR>\\include"', '-L"<DIR>\\lib"','-lcurl -lcurldll'); + +<DIR> can be for example: "E:\\Perldev\\downloader\\curl-7.18.2-devel-mingw32" (without quotes); +3. Save Makefile.PL. +4. Execute "perl Makefile.PL"; +5. Execute "nmake" ( you may need nmake from Mircosoft, which can be downloaded from http://support.microsoft.com/default.aspx?scid=kb;en-us;Q132084 ); +6. Execute "nmake install". diff --git a/SIGNATURE b/SIGNATURE new file mode 100644 index 0000000..47e54c3 --- /dev/null +++ b/SIGNATURE @@ -0,0 +1,77 @@ +This file contains message digests of all files listed in MANIFEST, +signed via the Module::Signature module, version 0.55. + +To verify the content in this distribution, first make sure you have +Module::Signature installed, then type: + + % cpansign -v + +It will check each file's integrity, as well as the signature's +validity. If "==> Signature verified OK! <==" is not displayed, +the distribution may already have been compromised, and you should +not run its Makefile.PL or Build.PL. + +-----BEGIN PGP SIGNED MESSAGE----- +Hash: SHA1 + +SHA1 5e0b0a409e7a96524bfa071ca7f6e69b479191bd Changes +SHA1 94dc4a32bc5f04deb4784b7b43f0bdf75ace8ed8 Curl.xs +SHA1 94cbea5b3fb940e25cd4535d1c81bfd7d51dac3c LICENSE +SHA1 7b182375c7584c6edb02989e822acaf8eac0a2e6 MANIFEST +SHA1 667f7ccff205b983166e237ec8c30aacd3730684 META.yml +SHA1 09323cfc717a3723d07bdcef329725bdd5f53624 Makefile.PL +SHA1 322619607d1c95a9e29a13f74f0b1f1c92d0eed5 README +SHA1 ed6f9f399075307a33bd02902ebbadbbbfbd8bab README.Win32 +SHA1 f0577f8f88a6703e9bca2d10196cfd293f3d6f2f inc/Module/Install.pm +SHA1 5d574849849860b8cf06035cc6f1a306c66cb326 inc/Module/Install/Base.pm +SHA1 c30f50bc2a1542dff17f84a54d9316f3c3c6299e inc/Module/Install/Can.pm +SHA1 dd345661caea9a4f18c6f39cd50f22739cf2459d inc/Module/Install/External.pm +SHA1 c8b486eb7a38823afb92e4d5b00dbb57b43351d5 inc/Module/Install/MakeMaker.pm +SHA1 cd14c8de2a67b0f14df9bc20c27f3edabd359d1b inc/Module/Install/Makefile.pm +SHA1 a2162aec678d21988fce47ab805cf01773196292 inc/Module/Install/Metadata.pm +SHA1 5cd962de0a085f0ec7625c288df655d6d89dd2e7 lib/WWW/Curl.pm +SHA1 e536065e27b7621f04619a71c8fff63b28d0d3e2 lib/WWW/Curl/Easy.pm +SHA1 5909923d44832d435213746d562bf6b6075f5ef3 lib/WWW/Curl/Form.pm +SHA1 46e9ebfbe386bbf319f26e6d3eec7e17772026b5 lib/WWW/Curl/Multi.pm +SHA1 ab003199fd68eef6d58d382aded93c01a6efd9ae lib/WWW/Curl/Share.pm +SHA1 259c953ed6189b23fddd5d4afd2c6df0fbb24930 t/00constants.t +SHA1 553836d2318a3a2ff6982616b3237eb86c372194 t/01basic.t +SHA1 07b63b1baca142a0e34e79633d0eb57684524bed t/02callbacks.t +SHA1 905c848deb6492d539c5bdf89c49632a412af15a t/04abort-test.t +SHA1 f9c842503835908a0687ab41655042a16b8b5112 t/05progress.t +SHA1 6406f237b74c8b847d233e5570c2769d7445c307 t/06http-post.t +SHA1 a252ca35aaf428e566e8f24bb59f3b56e4c8511d t/07ftp-upload.t +SHA1 4811cc6d6af52f7adaf5e0a3332df980ea377d27 t/08ssl.t +SHA1 ec62c062c627e7f52df512eae496223bd49ad2f3 t/09times.t +SHA1 9499f362a6d06a19aa6bc41d3647dbd5dc5aca63 t/10errbuf.t +SHA1 0390b52a5cbebb2896f38aecc8602acb20199790 t/13slowleak.t +SHA1 f911c90eaf0fdd2ee60f913262ee6ca3236037f0 t/14duphandle.t +SHA1 62551de2e5da5df233b296b716093cea8d791d70 t/15duphandle-callback.t +SHA1 785507b3fa6f414298cdcf7ceaba1f9274aa07d2 t/16formpost.t +SHA1 e784a874eb36fd5b16a12fc58365cce697ecbbab t/17slist.t +SHA1 4246e503682d25acf461e539104d10b66e74889c t/18twinhandles.t +SHA1 2924361d0713031b92c6b888f11e860d357837f7 t/meta.t +SHA1 3cd20c1711b43058550922404f53a844fb2695e6 t/new/00constants.t +SHA1 d9863d2e71f618a58d419534867cda8bd97dcfbf t/new/01basic.t +SHA1 f4a3ea4777e0905d2cf0f6cdb18d04a39892c69d t/new/02header-callback.t +SHA1 4aa1ab99c68aa4069a37419f439520b639fdb1e6 t/new/03body-callback.t +SHA1 1470b63fda40ae09ce5faa891b6b30d804709c93 t/new/04abort.t +SHA1 0d80cbde8d56c32ada4284f4738357cce1346b2b t/new/05progress.t +SHA1 fda1cb27df8d45a6e00fb0f1ca664b815a5d9b47 t/new/06http-post.t +SHA1 66c9b543a13c328a5b49b79d29aaa6345702ec71 t/new/07errbuf.t +SHA1 63aecf6590d0d4268be8f23ba406d5b957710cde t/new/08duphandle.t +SHA1 a20c28c3e06ebf836e837da4c5d1afb2998d5cc7 t/new/09duphandle-callback.t +SHA1 eee30cfb57132e7c8bdd4a5dd2f32273ab222115 t/new/10multi-callback.t +SHA1 20ec0bd03ff2600505d38623153a6eb3087b5814 t/new/README +SHA1 ac25bfa56d36f19cbee72a968b06372e88602a61 t/pod-coverage.t +SHA1 0190346d7072d458c8a10a45c19f86db641dcc48 t/pod.t +SHA1 a049ec8232b28a1aedb130a67d992a63b8361a8d template/Easy.pm.tmpl +SHA1 b4841adcad866b70d9d72f171d3d0f8f9d5b3c79 template/Share.pm.tmpl +SHA1 468b011caaf4d54609b421027d7c6262a9260e89 typemap +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEARECAAYFAkhv9rgACgkQ+22TSbOiiI+IdwCfeIufWW3r0CeAaS4UX2DQO7J8 +AHQAoJLDA/poQi2NCqHF1Mnpprc/qafN +=w48a +-----END PGP SIGNATURE----- diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm new file mode 100644 index 0000000..8fb6b20 --- /dev/null +++ b/inc/Module/Install.pm @@ -0,0 +1,353 @@ +#line 1 +package Module::Install; + +# For any maintainers: +# The load order for Module::Install is a bit magic. +# It goes something like this... +# +# IF ( host has Module::Install installed, creating author mode ) { +# 1. Makefile.PL calls "use inc::Module::Install" +# 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install +# 3. The installed version of inc::Module::Install loads +# 4. inc::Module::Install calls "require Module::Install" +# 5. The ./inc/ version of Module::Install loads +# } ELSE { +# 1. Makefile.PL calls "use inc::Module::Install" +# 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install +# 3. The ./inc/ version of Module::Install loads +# } + +BEGIN { + require 5.004; +} +use strict 'vars'; + +use vars qw{$VERSION}; +BEGIN { + # All Module::Install core packages now require synchronised versions. + # This will be used to ensure we don't accidentally load old or + # different versions of modules. + # This is not enforced yet, but will be some time in the next few + # releases once we can make sure it won't clash with custom + # Module::Install extensions. + $VERSION = '0.75'; + + *inc::Module::Install::VERSION = *VERSION; + @inc::Module::Install::ISA = __PACKAGE__; + +} + + + + + +# Whether or not inc::Module::Install is actually loaded, the +# $INC{inc/Module/Install.pm} is what will still get set as long as +# the caller loaded module this in the documented manner. +# If not set, the caller may NOT have loaded the bundled version, and thus +# they may not have a MI version that works with the Makefile.PL. This would +# result in false errors or unexpected behaviour. And we don't want that. +my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; +unless ( $INC{$file} ) { die <<"END_DIE" } + +Please invoke ${\__PACKAGE__} with: + + use inc::${\__PACKAGE__}; + +not: + + use ${\__PACKAGE__}; + +END_DIE + + + + + +# If the script that is loading Module::Install is from the future, +# then make will detect this and cause it to re-run over and over +# again. This is bad. Rather than taking action to touch it (which +# is unreliable on some platforms and requires write permissions) +# for now we should catch this and refuse to run. +if ( -f $0 and (stat($0))[9] > time ) { die <<"END_DIE" } + +Your installer $0 has a modification time in the future. + +This is known to create infinite loops in make. + +Please correct this, then run $0 again. + +END_DIE + + + + + +# Build.PL was formerly supported, but no longer is due to excessive +# difficulty in implementing every single feature twice. +if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } + +Module::Install no longer supports Build.PL. + +It was impossible to maintain duel backends, and has been deprecated. + +Please remove all Build.PL files and only use the Makefile.PL installer. + +END_DIE + + + + + +# To save some more typing in Module::Install installers, every... +# use inc::Module::Install +# ...also acts as an implicit use strict. +$^H |= strict::bits(qw(refs subs vars)); + + + + + +use Cwd (); +use File::Find (); +use File::Path (); +use FindBin; + +sub autoload { + my $self = shift; + my $who = $self->_caller; + my $cwd = Cwd::cwd(); + my $sym = "${who}::AUTOLOAD"; + $sym->{$cwd} = sub { + my $pwd = Cwd::cwd(); + if ( my $code = $sym->{$pwd} ) { + # delegate back to parent dirs + goto &$code unless $cwd eq $pwd; + } + $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; + unshift @_, ( $self, $1 ); + goto &{$self->can('call')} unless uc($1) eq $1; + }; +} + +sub import { + my $class = shift; + my $self = $class->new(@_); + my $who = $self->_caller; + + unless ( -f $self->{file} ) { + require "$self->{path}/$self->{dispatch}.pm"; + File::Path::mkpath("$self->{prefix}/$self->{author}"); + $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); + $self->{admin}->init; + @_ = ($class, _self => $self); + goto &{"$self->{name}::import"}; + } + + *{"${who}::AUTOLOAD"} = $self->autoload; + $self->preload; + + # Unregister loader and worker packages so subdirs can use them again + delete $INC{"$self->{file}"}; + delete $INC{"$self->{path}.pm"}; + + return 1; +} + +sub preload { + my $self = shift; + unless ( $self->{extensions} ) { + $self->load_extensions( + "$self->{prefix}/$self->{path}", $self + ); + } + + my @exts = @{$self->{extensions}}; + unless ( @exts ) { + my $admin = $self->{admin}; + @exts = $admin->load_all_extensions; + } + + my %seen; + foreach my $obj ( @exts ) { + while (my ($method, $glob) = each %{ref($obj) . '::'}) { + next unless $obj->can($method); + next if $method =~ /^_/; + next if $method eq uc($method); + $seen{$method}++; + } + } + + my $who = $self->_caller; + foreach my $name ( sort keys %seen ) { + *{"${who}::$name"} = sub { + ${"${who}::AUTOLOAD"} = "${who}::$name"; + goto &{"${who}::AUTOLOAD"}; + }; + } +} + +sub new { + my ($class, %args) = @_; + + # ignore the prefix on extension modules built from top level. + my $base_path = Cwd::abs_path($FindBin::Bin); + unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { + delete $args{prefix}; + } + + return $args{_self} if $args{_self}; + + $args{dispatch} ||= 'Admin'; + $args{prefix} ||= 'inc'; + $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); + $args{bundle} ||= 'inc/BUNDLES'; + $args{base} ||= $base_path; + $class =~ s/^\Q$args{prefix}\E:://; + $args{name} ||= $class; + $args{version} ||= $class->VERSION; + unless ( $args{path} ) { + $args{path} = $args{name}; + $args{path} =~ s!::!/!g; + } + $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; + $args{wrote} = 0; + + bless( \%args, $class ); +} + +sub call { + my ($self, $method) = @_; + my $obj = $self->load($method) or return; + splice(@_, 0, 2, $obj); + goto &{$obj->can($method)}; +} + +sub load { + my ($self, $method) = @_; + + $self->load_extensions( + "$self->{prefix}/$self->{path}", $self + ) unless $self->{extensions}; + + foreach my $obj (@{$self->{extensions}}) { + return $obj if $obj->can($method); + } + + my $admin = $self->{admin} or die <<"END_DIE"; +The '$method' method does not exist in the '$self->{prefix}' path! +Please remove the '$self->{prefix}' directory and run $0 again to load it. +END_DIE + + my $obj = $admin->load($method, 1); + push @{$self->{extensions}}, $obj; + + $obj; +} + +sub load_extensions { + my ($self, $path, $top) = @_; + + unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) { + unshift @INC, $self->{prefix}; + } + + foreach my $rv ( $self->find_extensions($path) ) { + my ($file, $pkg) = @{$rv}; + next if $self->{pathnames}{$pkg}; + + local $@; + my $new = eval { require $file; $pkg->can('new') }; + unless ( $new ) { + warn $@ if $@; + next; + } + $self->{pathnames}{$pkg} = delete $INC{$file}; + push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); + } + + $self->{extensions} ||= []; +} + +sub find_extensions { + my ($self, $path) = @_; + + my @found; + File::Find::find( sub { + my $file = $File::Find::name; + return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; + my $subpath = $1; + return if lc($subpath) eq lc($self->{dispatch}); + + $file = "$self->{path}/$subpath.pm"; + my $pkg = "$self->{name}::$subpath"; + $pkg =~ s!/!::!g; + + # If we have a mixed-case package name, assume case has been preserved + # correctly. Otherwise, root through the file to locate the case-preserved + # version of the package name. + if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { + my $content = Module::Install::_read($subpath . '.pm'); + my $in_pod = 0; + foreach ( split //, $content ) { + $in_pod = 1 if /^=\w/; + $in_pod = 0 if /^=cut/; + next if ($in_pod || /^=cut/); # skip pod text + next if /^\s*#/; # and comments + if ( m/^\s*package\s+($pkg)\s*;/i ) { + $pkg = $1; + last; + } + } + } + + push @found, [ $file, $pkg ]; + }, $path ) if -d $path; + + @found; +} + + + + + +##################################################################### +# Utility Functions + +sub _caller { + my $depth = 0; + my $call = caller($depth); + while ( $call eq __PACKAGE__ ) { + $depth++; + $call = caller($depth); + } + return $call; +} + +sub _read { + local *FH; + open FH, "< $_[0]" or die "open($_[0]): $!"; + my $str = do { local $/; <FH> }; + close FH or die "close($_[0]): $!"; + return $str; +} + +sub _write { + local *FH; + open FH, "> $_[0]" or die "open($_[0]): $!"; + foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" } + close FH or die "close($_[0]): $!"; +} + +sub _version { + my $s = shift || 0; + $s =~ s/^(\d+)\.?//; + my $l = $1 || 0; + my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; + $l = $l . '.' . join '', @v if @v; + return $l + 0; +} + +1; + +# Copyright 2008 Adam Kennedy. diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm new file mode 100644 index 0000000..bd12f2b --- /dev/null +++ b/inc/Module/Install/Base.pm @@ -0,0 +1,70 @@ +#line 1 +package Module::Install::Base; + +$VERSION = '0.75'; + +# Suspend handler for "redefined" warnings +BEGIN { + my $w = $SIG{__WARN__}; + $SIG{__WARN__} = sub { $w }; +} + +### This is the ONLY module that shouldn't have strict on +# use strict; + +#line 41 + +sub new { + my ($class, %args) = @_; + + foreach my $method ( qw(call load) ) { + *{"$class\::$method"} = sub { + shift()->_top->$method(@_); + } unless defined &{"$class\::$method"}; + } + + bless( \%args, $class ); +} + +#line 61 + +sub AUTOLOAD { + my $self = shift; + local $@; + my $autoload = eval { $self->_top->autoload } or return; + goto &$autoload; +} + +#line 76 + +sub _top { $_[0]->{_top} } + +#line 89 + +sub admin { + $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; +} + +sub is_admin { + $_[0]->admin->VERSION; +} + +sub DESTROY {} + +package Module::Install::Base::FakeAdmin; + +my $Fake; +sub new { $Fake ||= bless(\@_, $_[0]) } + +sub AUTOLOAD {} + +sub DESTROY {} + +# Restore warning handler +BEGIN { + $SIG{__WARN__} = $SIG{__WARN__}->(); +} + +1; + +#line 138 diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm new file mode 100644 index 0000000..3f436c7 --- /dev/null +++ b/inc/Module/Install/Can.pm @@ -0,0 +1,82 @@ +#line 1 +package Module::Install::Can; + +use strict; +use Module::Install::Base; +use Config (); +### This adds a 5.005 Perl version dependency. +### This is a bug and will be fixed. +use File::Spec (); +use ExtUtils::MakeMaker (); + +use vars qw{$VERSION $ISCORE @ISA}; +BEGIN { + $VERSION = '0.75'; + $ISCORE = 1; + @ISA = qw{Module::Install::Base}; +} + +# check if we can load some module +### Upgrade this to not have to load the module if possible +sub can_use { + my ($self, $mod, $ver) = @_; + $mod =~ s{::|\\}{/}g; + $mod .= '.pm' unless $mod =~ /\.pm$/i; + + my $pkg = $mod; + $pkg =~ s{/}{::}g; + $pkg =~ s{\.pm$}{}i; + + local $@; + eval { require $mod; $pkg->VERSION($ver || 0); 1 }; +} + +# check if we can run some command +sub can_run { + my ($self, $cmd) = @_; + + my $_cmd = $cmd; + return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); + + for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { + my $abs = File::Spec->catfile($dir, $_[1]); + return $abs if (-x $abs or $abs = MM->maybe_command($abs)); + } + + return; +} + +# can we locate a (the) C compiler +sub can_cc { + my $self = shift; + my @chunks = split(/ /, $Config::Config{cc}) or return; + + # $Config{cc} may contain args; try to find out the program part + while (@chunks) { + return $self->can_run("@chunks") || (pop(@chunks), next); + } + + return; +} + +# Fix Cygwin bug on maybe_command(); +if ( $^O eq 'cygwin' ) { + require ExtUtils::MM_Cygwin; + require ExtUtils::MM_Win32; + if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { + *ExtUtils::MM_Cygwin::maybe_command = sub { + my ($self, $file) = @_; + if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { + ExtUtils::MM_Win32->maybe_command($file); + } else { + ExtUtils::MM_Unix->maybe_command($file); + } + } + } +} + +1; + +__END__ + +#line 157 diff --git a/inc/Module/Install/External.pm b/inc/Module/Install/External.pm new file mode 100644 index 0000000..cd12a0c --- /dev/null +++ b/inc/Module/Install/External.pm @@ -0,0 +1,66 @@ +#line 1 +package Module::Install::External; + +# Provides dependency declarations for external non-Perl things + +use strict; +use Module::Install::Base; + +use vars qw{$VERSION $ISCORE @ISA}; +BEGIN { + $VERSION = '0.75'; + $ISCORE = 1; + @ISA = qw{Module::Install::Base}; +} + +sub requires_external_cc { + my $self = shift; + + # We need a C compiler, use the can_cc method for this + unless ( $self->can_cc ) { + print "Unresolvable missing external dependency.\n"; + print "This package requires a C compiler.\n"; + print STDERR "NA: Unable to build distribution on this platform.\n"; + exit(0); + } + + # Unlike some of the other modules, while we need to specify a + # C compiler as a dep, it needs to be a build-time dependency. + + 1; +} + +sub requires_external_bin { + my ($self, $bin, $version) = @_; + if ( $version ) { + die "requires_external_bin does not support versions yet"; + } + + # Load the package containing can_run early, + # to avoid breaking the message below. + $self->load('can_run'); + + # Locate the bin + print "Locating required external dependency bin:$bin..."; + my $found_bin = $self->can_run( $bin ); + if ( $found_bin ) { + print " found at $found_bin.\n"; + } else { + print " missing.\n"; + print "Unresolvable missing external dependency.\n"; + print "Please install '$bin' seperately and try again.\n"; + print STDERR "NA: Unable to build distribution on this platform.\n"; + exit(0); + } + + # Once we have some way to specify external deps, do it here. + # In the mean time, continue as normal. + + 1; +} + +1; + +__END__ + +#line 138 diff --git a/inc/Module/Install/MakeMaker.pm b/inc/Module/Install/MakeMaker.pm new file mode 100644 index 0000000..5ea325a --- /dev/null +++ b/inc/Module/Install/MakeMaker.pm @@ -0,0 +1,50 @@ +#line 1 +package Module::Install::MakeMaker; + +use strict; +use Module::Install::Base; +use ExtUtils::MakeMaker (); + +use vars qw{$VERSION $ISCORE @ISA}; +BEGIN { + $VERSION = '0.75'; + $ISCORE = 1; + @ISA = qw{Module::Install::Base}; +} + +my $makefile; + +sub WriteMakefile { + my ($self, %args) = @_; + $makefile = $self->load('Makefile'); + + # mapping between MakeMaker and META.yml keys + $args{MODULE_NAME} = $args{NAME}; + unless ( $args{NAME} = $args{DISTNAME} or ! $args{MODULE_NAME} ) { + $args{NAME} = $args{MODULE_NAME}; + $args{NAME} =~ s/::/-/g; + } + + foreach my $key ( qw{name module_name version version_from abstract author installdirs} ) { + my $value = delete($args{uc($key)}) or next; + $self->$key($value); + } + + if (my $prereq = delete($args{PREREQ_PM})) { + while (my($k,$v) = each %$prereq) { + $self->requires($k,$v); + } + } + + # put the remaining args to makemaker_args + $self->makemaker_args(%args); +} + +END { + if ( $makefile ) { + $makefile->write; + $makefile->Meta->write; + } +} + +1; diff --git a/inc/Module/Install/Makefile.pm b/inc/Module/Install/Makefile.pm new file mode 100644 index 0000000..b7c2ba9 --- /dev/null +++ b/inc/Module/Install/Makefile.pm @@ -0,0 +1,245 @@ +#line 1 +package Module::Install::Makefile; + +use strict 'vars'; +use Module::Install::Base; +use ExtUtils::MakeMaker (); + +use vars qw{$VERSION $ISCORE @ISA}; +BEGIN { + $VERSION = '0.75'; + $ISCORE = 1; + @ISA = qw{Module::Install::Base}; +} + +sub Makefile { $_[0] } + +my %seen = (); + +sub prompt { + shift; + + # Infinite loop protection + my @c = caller(); + if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { + die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; + } + + # In automated testing, always use defaults + if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) { + local $ENV{PERL_MM_USE_DEFAULT} = 1; + goto &ExtUtils::MakeMaker::prompt; + } else { + goto &ExtUtils::MakeMaker::prompt; + } +} + +sub makemaker_args { + my $self = shift; + my $args = ($self->{makemaker_args} ||= {}); + %$args = ( %$args, @_ ) if @_; + $args; +} + +# For mm args that take multiple space-seperated args, +# append an argument to the current list. +sub makemaker_append { + my $self = sShift; + my $name = shift; + my $args = $self->makemaker_args; + $args->{name} = defined $args->{$name} + ? join( ' ', $args->{name}, @_ ) + : join( ' ', @_ ); +} + +sub build_subdirs { + my $self = shift; + my $subdirs = $self->makemaker_args->{DIR} ||= []; + for my $subdir (@_) { + push @$subdirs, $subdir; + } +} + +sub clean_files { + my $self = shift; + my $clean = $self->makemaker_args->{clean} ||= {}; + %$clean = ( + %$clean, + FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), + ); +} + +sub realclean_files { + my $self = shift; + my $realclean = $self->makemaker_args->{realclean} ||= {}; + %$realclean = ( + %$realclean, + FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), + ); +} + +sub libs { + my $self = shift; + my $libs = ref $_[0] ? shift : [ shift ]; + $self->makemaker_args( LIBS => $libs ); +} + +sub inc { + my $self = shift; + $self->makemaker_args( INC => shift ); +} + +my %test_dir = (); + +sub _wanted_t { + /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1; +} + +sub tests_recursive { + my $self = shift; + if ( $self->tests ) { + die "tests_recursive will not work if tests are already defined"; + } + my $dir = shift || 't'; + unless ( -d $dir ) { + die "tests_recursive dir '$dir' does not exist"; + } + %test_dir = (); + require File::Find; + File::Find::find( \&_wanted_t, $dir ); + $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir ); +} + +sub write { + my $self = shift; + die "&Makefile->write() takes no arguments\n" if @_; + + # Make sure we have a new enough + require ExtUtils::MakeMaker; + $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION ); + + # Generate the + my $args = $self->makemaker_args; + $args->{DISTNAME} = $self->name; + $args->{NAME} = $self->module_name || $self->name; + $args->{VERSION} = $self->version; + $args->{NAME} =~ s/-/::/g; + if ( $self->tests ) { + $args->{test} = { TESTS => $self->tests }; + } + if ($] >= 5.005) { + $args->{ABSTRACT} = $self->abstract; + $args->{AUTHOR} = $self->author; + } + if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) { + $args->{NO_META} = 1; + } + if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) { + $args->{SIGN} = 1; + } + unless ( $self->is_admin ) { + delete $args->{SIGN}; + } + + # merge both kinds of requires into prereq_pm + my $prereq = ($args->{PREREQ_PM} ||= {}); + %$prereq = ( %$prereq, + map { @$_ } + map { @$_ } + grep $_, + ($self->configure_requires, $self->build_requires, $self->requires) + ); + + # Remove any reference to perl, PREREQ_PM doesn't support it + delete $args->{PREREQ_PM}->{perl}; + + # merge both kinds of requires into prereq_pm + my $subdirs = ($args->{DIR} ||= []); + if ($self->bundles) { + foreach my $bundle (@{ $self->bundles }) { + my ($file, $dir) = @$bundle; + push @$subdirs, $dir if -d $dir; + delete $prereq->{$file}; + } + } + + if ( my $perl_version = $self->perl_version ) { + eval "use $perl_version; 1" + or die "ERROR: perl: Version $] is installed, " + . "but we need version >= $perl_version"; + } + + $args->{INSTALLDIRS} = $self->installdirs; + + my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args; + + my $user_preop = delete $args{dist}->{PREOP}; + if (my $preop = $self->admin->preop($user_preop)) { + $args{dist} = $preop; + } + + my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); + $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); +} + +sub fix_up_makefile { + my $self = shift; + my $makefile_name = shift; + my $top_class = ref($self->_top) || ''; + my $top_version = $self->_top->VERSION || ''; + + my $preamble = $self->preamble + ? "# Preamble by $top_class $top_version\n" + . $self->preamble + : ''; + my $postamble = "# Postamble by $top_class $top_version\n" + . ($self->postamble || ''); + + local *MAKEFILE; + open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; + my $makefile = do { local $/; <MAKEFILE> }; + close MAKEFILE or die $!; + + $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; + $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; + $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; + $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; + $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; + + # Module::Install will never be used to build the Core Perl + # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks + # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist + $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; + #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; + + # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. + $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; + + # XXX - This is currently unused; not sure if it breaks other MM-users + # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; + + open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; + print MAKEFILE "$preamble$makefile$postamble" or die $!; + close MAKEFILE or die $!; + + 1; +} + +sub preamble { + my ($self, $text) = @_; + $self->{preamble} = $text . $self->{preamble} if defined $text; + $self->{preamble}; +} + +sub postamble { + my ($self, $text) = @_; + $self->{postamble} ||= $self->admin->postamble; + $self->{postamble} .= $text if defined $text; + $self->{postamble} +} + +1; + +__END__ + +#line 371 diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm new file mode 100644 index 0000000..ce26bf6 --- /dev/null +++ b/inc/Module/Install/Metadata.pm @@ -0,0 +1,407 @@ +#line 1 +package Module::Install::Metadata; + +use strict 'vars'; +use Module::Install::Base; + +use vars qw{$VERSION $ISCORE @ISA}; +BEGIN { + $VERSION = '0.75'; + $ISCORE = 1; + @ISA = qw{Module::Install::Base}; +} + +my @scalar_keys = qw{ + name + module_name + abstract + author + version + license + distribution_type + perl_version + tests + installdirs +}; + +my @tuple_keys = qw{ + configure_requires + build_requires + requires + recommends + bundles + resources +}; + +sub Meta { shift } +sub Meta_ScalarKeys { @scalar_keys } +sub Meta_TupleKeys { @tuple_keys } + +foreach my $key (@scalar_keys) { + *$key = sub { + my $self = shift; + return $self->{values}{$key} if defined wantarray and !@_; + $self->{values}{$key} = shift; + return $self; + }; +} + +sub requires { + my $self = shift; + while ( @_ ) { + my $module = shift or last; + my $version = shift || 0; + push @{ $self->{values}->{requires} }, [ $module, $version ]; + } + $self->{values}{requires}; +} + +sub build_requires { + my $self = shift; + while ( @_ ) { + my $module = shift or last; + my $version = shift || 0; + push @{ $self->{values}->{build_requires} }, [ $module, $version ]; + } + $self->{values}{build_requires}; +} + +sub configure_requires { + my $self = shift; + while ( @_ ) { + my $module = shift or last; + my $version = shift || 0; + push @{ $self->{values}->{configure_requires} }, [ $module, $version ]; + } + $self->{values}->{configure_requires}; +} + +sub recommends { + my $self = shift; + while ( @_ ) { + my $module = shift or last; + my $version = shift || 0; + push @{ $self->{values}->{recommends} }, [ $module, $version ]; + } + $self->{values}->{recommends}; +} + +sub bundles { + my $self = shift; + while ( @_ ) { + my $module = shift or last; + my $version = shift || 0; + push @{ $self->{values}->{bundles} }, [ $module, $version ]; + } + $self->{values}->{bundles}; +} + +# Resource handling +sub resources { + my $self = shift; + while ( @_ ) { + my $resource = shift or last; + my $value = shift or next; + push @{ $self->{values}->{resources} }, [ $resource, $value ]; + } + $self->{values}->{resources}; +} + +sub repository { + my $self = shift; + $self->resources( repository => shift ); + return 1; +} + +# Aliases for build_requires that will have alternative +# meanings in some future version of META.yml. +sub test_requires { shift->build_requires(@_) } +sub install_requires { shift->build_requires(@_) } + +# Aliases for installdirs options +sub install_as_core { $_[0]->installdirs('perl') } +sub install_as_cpan { $_[0]->installdirs('site') } +sub install_as_site { $_[0]->installdirs('site') } +sub install_as_vendor { $_[0]->installdirs('vendor') } + +sub sign { + my $self = shift; + return $self->{'values'}{'sign'} if defined wantarray and ! @_; + $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 ); + return $self; +} + +sub dynamic_config { + my $self = shift; + unless ( @_ ) { + warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n"; + return $self; + } + $self->{values}{dynamic_config} = $_[0] ? 1 : 0; + return $self; +} + +sub all_from { + my ( $self, $file ) = @_; + + unless ( defined($file) ) { + my $name = $self->name + or die "all_from called with no args without setting name() first"; + $file = join('/', 'lib', split(/-/, $name)) . '.pm'; + $file =~ s{.*/}{} unless -e $file; + die "all_from: cannot find $file from $name" unless -e $file; + } + + # Some methods pull from POD instead of code. + # If there is a matching .pod, use that instead + my $pod = $file; + $pod =~ s/\.pm$/.pod/i; + $pod = $file unless -e $pod; + + # Pull the different values + $self->name_from($file) unless $self->name; + $self->version_from($file) unless $self->version; + $self->perl_version_from($file) unless $self->perl_version; + $self->author_from($pod) unless $self->author; + $self->license_from($pod) unless $self->license; + $self->abstract_from($pod) unless $self->abstract; + + return 1; +} + +sub provides { + my $self = shift; + my $provides = ( $self->{values}{provides} ||= {} ); + %$provides = (%$provides, @_) if @_; + return $provides; +} + +sub auto_provides { + my $self = shift; + return $self unless $self->is_admin; + unless (-e 'MANIFEST') { + warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; + return $self; + } + # Avoid spurious warnings as we are not checking manifest here. + local $SIG{__WARN__} = sub {1}; + require ExtUtils::Manifest; + local *ExtUtils::Manifest::manicheck = sub { return }; + + require Module::Build; + my $build = Module::Build->new( + dist_name => $self->name, + dist_version => $self->version, + license => $self->license, + ); + $self->provides( %{ $build->find_dist_packages || {} } ); +} + +sub feature { + my $self = shift; + my $name = shift; + my $features = ( $self->{values}{features} ||= [] ); + my $mods; + + if ( @_ == 1 and ref( $_[0] ) ) { + # The user used ->feature like ->features by passing in the second + # argument as a reference. Accomodate for that. + $mods = $_[0]; + } else { + $mods = \@_; + } + + my $count = 0; + push @$features, ( + $name => [ + map { + ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ + } @$mods + ] + ); + + return @$features; +} + +sub features { + my $self = shift; + while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { + $self->feature( $name, @$mods ); + } + return $self->{values}->{features} + ? @{ $self->{values}->{features} } + : (); +} + +sub no_index { + my $self = shift; + my $type = shift; + push @{ $self->{values}{no_index}{$type} }, @_ if $type; + return $self->{values}{no_index}; +} + +sub read { + my $self = shift; + $self->include_deps( 'YAML::Tiny', 0 ); + + require YAML::Tiny; + my $data = YAML::Tiny::LoadFile('META.yml'); + + # Call methods explicitly in case user has already set some values. + while ( my ( $key, $value ) = each %$data ) { + next unless $self->can($key); + if ( ref $value eq 'HASH' ) { + while ( my ( $module, $version ) = each %$value ) { + $self->can($key)->($self, $module => $version ); + } + } else { + $self->can($key)->($self, $value); + } + } + return $self; +} + +sub write { + my $self = shift; + return $self unless $self->is_admin; + $self->admin->write_meta; + return $self; +} + +sub version_from { + require ExtUtils::MM_Unix; + my ( $self, $file ) = @_; + $self->version( ExtUtils::MM_Unix->parse_version($file) ); +} + +sub abstract_from { + require ExtUtils::MM_Unix; + my ( $self, $file ) = @_; + $self->abstract( + bless( + { DISTNAME => $self->name }, + 'ExtUtils::MM_Unix' + )->parse_abstract($file) + ); +} + +# Add both distribution and module name +sub name_from { + my ($self, $file) = @_; + if ( + Module::Install::_read($file) =~ m/ + ^ \s* + package \s* + ([\w:]+) + \s* ; + /ixms + ) { + my ($name, $module_name) = ($1, $1); + $name =~ s{::}{-}g; + $self->name($name); + unless ( $self->module_name ) { + $self->module_name($module_name); + } + } else { + die "Cannot determine name from $file\n"; + } +} + +sub perl_version_from { + my $self = shift; + if ( + Module::Install::_read($_[0]) =~ m/ + ^ + (?:use|require) \s* + v? + ([\d_\.]+) + \s* ; + /ixms + ) { + my $perl_version = $1; + $perl_version =~ s{_}{}g; + $self->perl_version($perl_version); + } else { + warn "Cannot determine perl version info from $_[0]\n"; + return; + } +} + +sub author_from { + my $self = shift; + my $content = Module::Install::_read($_[0]); + if ($content =~ m/ + =head \d \s+ (?:authors?)\b \s* + ([^\n]*) + | + =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* + .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* + ([^\n]*) + /ixms) { + my $author = $1 || $2; + $author =~ s{E<lt>}{<}g; + $author =~ s{E<gt>}{>}g; + $self->author($author); + } else { + warn "Cannot determine author info from $_[0]\n"; + } +} + +sub license_from { + my $self = shift; + if ( + Module::Install::_read($_[0]) =~ m/ + ( + =head \d \s+ + (?:licen[cs]e|licensing|copyright|legal)\b + .*? + ) + (=head\\d.*|=cut.*|) + \z + /ixms ) { + my $license_text = $1; + my @phrases = ( + 'under the same (?:terms|license) as perl itself' => 'perl', 1, + 'GNU public license' => 'gpl', 1, + 'GNU lesser public license' => 'lgpl', 1, + 'BSD license' => 'bsd', 1, + 'Artistic license' => 'artistic', 1, + 'GPL' => 'gpl', 1, + 'LGPL' => 'lgpl', 1, + 'BSD' => 'bsd', 1, + 'Artistic' => 'artistic', 1, + 'MIT' => 'mit', 1, + 'proprietary' => 'proprietary', 0, + ); + while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { + $pattern =~ s{\s+}{\\s+}g; + if ( $license_text =~ /\b$pattern\b/i ) { + if ( $osi and $license_text =~ /All rights reserved/i ) { + print "WARNING: 'All rights reserved' in copyright may invalidate Open Source license.\n"; + } + $self->license($license); + return 1; + } + } + } + + warn "Cannot determine license info from $_[0]\n"; + return 'unknown'; +} + +sub install_script { + my $self = shift; + my $args = $self->makemaker_args; + my $exe = $args->{EXE_FILES} ||= []; + foreach ( @_ ) { + if ( -f $_ ) { + push @$exe, $_; + } elsif ( -d 'script' and -f "script/$_" ) { + push @$exe, "script/$_"; + } else { + die "Cannot find script '$_'"; + } + } +} + +1; diff --git a/lib/WWW/Curl.pm b/lib/WWW/Curl.pm new file mode 100644 index 0000000..cdb52c9 --- /dev/null +++ b/lib/WWW/Curl.pm @@ -0,0 +1,334 @@ +package WWW::Curl; + +use strict; +use warnings; +use vars qw(@ISA $VERSION); +use DynaLoader; + +BEGIN { + $VERSION = '4.05'; + @ISA = qw(DynaLoader); + __PACKAGE__->bootstrap; +} + +1; + +__END__ + +=head1 NAME + +WWW::Curl - Perl extension interface for libcurl + +=head1 SYNOPSIS + + use WWW::Curl; + print $WWW::Curl::VERSION; + + +=head1 DESCRIPTION + +WWW::Curl is a Perl extension interface for libcurl. + +=head1 DOCUMENTATION + +This module provides a Perl interface to libcurl. It is not intended to be a standalone module +and because of this, the main libcurl documentation should be consulted for API details at +L<http://curl.haxx.se>. The documentation you're reading right now only contains the Perl specific +details, some sample code and the differences between the C API and the Perl one. + +=head1 WWW::Curl::Easy + +The name might be confusing, it originates from libcurl. This is not an ::Easy module +in the sense normally used on CPAN. + +Here is a small snippet of making a request with WWW::Curl::Easy. + + use strict; + use warnings; + use WWW::Curl::Easy; + + # Setting the options + my $curl = new WWW::Curl::Easy; + + $curl->setopt(CURLOPT_HEADER,1); + $curl->setopt(CURLOPT_URL, 'http://example.com'); + my $response_body; + + # NOTE - do not use a typeglob here. A reference to a typeglob is okay though. + open (my $fileb, ">", \$response_body); + $curl->setopt(CURLOPT_WRITEDATA,$fileb); + + # Starts the actual request + my $retcode = $curl->perform; + + # Looking at the results... + if ($retcode == 0) { + print("Transfer went ok\n"); + my $response_code = $curl->getinfo(CURLINFO_HTTP_CODE); + # judge result and next action based on $response_code + print("Received response: $response_body\n"); + } else { + print("An error happened: ".$curl->strerror($retcode)." ($retcode)\n"); + } + + +=head1 WWW::Curl::Multi + + use strict; + use warnings; + use WWW::Curl::Easy; + use WWW::Curl::Multi; + + my %easy; + my $curl = WWW::Curl::Easy->new; + my $curl_id = '13'; # This should be a handle unique id. + $easy{$curl_id} = $curl; + my $active_handles = 0; + + $curl->setopt(CURLOPT_PRIVATE,$curl_id); + # do the usual configuration on the handle + ... + + my $curlm = WWW::Curl::Multi->new; + + # Add some easy handles + $curlm->add_handle($curl); + $active_handles++; + + while ($active_handles) { + my $active_transfers = $curlm->perform; + if ($active_transfers != $active_handles) { + while (my ($id,$return_value) = $curlm->info_read) { + if ($id) { + $active_handles--; + my $actual_easy_handle = $easy{$id}; + # do the usual result/error checking routine here + ... + # letting the curl handle get garbage collected, or we leak memory. + delete $easy{$id}; + } + } + } + } + +This interface is different than what the C API does. $curlm->perform is non-blocking and performs +requests in parallel. The method does a little work and then returns control, therefor it has to be called +periodically to get the job done. It's return value is the number of unfinished requests. + +When the number of unfinished requests changes compared to the number of active handles, $curlm->info_read +should be checked for finished requests. It returns one handle and it's return value at a time, or an empty list +if there are no more finished requests. $curlm->info_read calls remove_handle on the given easy handle automatically, +internally. The easy handle will still remain available until it goes out of scope, this action just detaches it from +multi. + +Please make sure that the easy handle does not get garbage collected until after the multi handle finishes processing it, +or bad things happen. + +The multi handle does not need to be cleaned up, when it goes out of scope it calls the required cleanup methods +automatically. + +It is possible to use $curlm->add_handle to add further requests to be processed after $curlm->perform has been called. +WWW::Curl::Multi doesn't care about the order. It is possible to process all requests for a multi handle and then add +a new batch of easy handles for processing. + +=head1 WWW::Curl::Share + + use WWW::CURL::Share; + my $curlsh = new WWW::Curl::Share; + $curlsh->setopt(CURLSHOPT_SHARE, CURL_LOCK_DATA_COOKIE); + $curlsh->setopt(CURLSHOPT_SHARE, CURL_LOCK_DATA_DNS); + $curl->setopt(CURLOPT_SHARE, $curlsh); + $curlsh->setopt(CURLSHOPT_UNSHARE, CURL_LOCK_DATA_COOKIE); + $curlsh->setopt(CURLSHOPT_UNSHARE, CURL_LOCK_DATA_DNS); + +WWW::Curl::Share is an extension to WWW::Curl::Easy which makes it possible +to use a single cookies/dns cache for several Easy handles. + +It's usable methods are: + + $curlsh = new WWW::Curl::Share + This method constructs a new WWW::Curl::Share object. + + $curlsh->setopt(CURLSHOPT_SHARE, $value ); + Enables share for: + CURL_LOCK_DATA_COOKIE use single cookies database + CURL_LOCK_DATA_DNS use single DNS cache + $curlsh->setopt(CURLSHOPT_UNSHARE, $value ); + Disable share for given $value (see CURLSHOPT_SHARE) + + $curlsh->strerror( ErrNo ) + This method returns a string describing the CURLSHcode error + code passed in the argument errornum. + +This is how you enable sharing for a specific WWW::Curl::Easy handle: + + $curl->setopt(CURLOPT_SHARE, $curlsh) + Attach share object to WWW::Curl::Easy instance + + +=head1 COMPATIBILITY + +=over + +=item curl_easy_setopt + +Most of the options should work, however some might not. Please send reports, tests and patches to fix +those. + +=item curl_easy_escape + +Not implemented. Since equivalent Perl code is easily produced, this method will only made +available for interface completeness, if ever. + +=item curl_easy_init + +Used only internally. The standard Perl way of initializing an object should be used, + C<< my $curl = WWW::Curl::Easy->new; >>. + +=item curl_easy_cleanup + +Used only internally. Curl object cleanup happens when the handle goes out of scope. + +=item curl_easy_duphandle + +Should be working for most cases, however do not change the value of options which accept +a list/arrayref value on a duped handle, otherwise memory leaks or crashes will happen. +This behaviour will be fixed in the future. + +=item curl_easy_pause + +Not implemented. + +=item curl_easy_reset + +Not implemented. + +=item curl_easy_unescape + +Not implemented. Trivial Perl replacements are available. + +=item curl_escape + +Not implemented and won't be as this method is considered deprecated. + +=item curl_formadd + +Not yet implemented. + +=item curl_formfree + +When WWW::Curl::Form support is added, this function will be used internally, +but won't be accessible from the public API. + +=item curl_free + +Used internally. Not exposed through the public API, as this call has no relevance +to Perl code. + +=item curl_getdate + +Not implemented. This function is easily replaced by Perl code and as such, most likely +it won't be implemented. + +=item curl_global_cleanup + +Only used internally, not exposed through the public API. + +=item curl_global_init + +Only used internally, not exposed through the public API. + +=item curl_global_init_mem + +Not implemented. + +=item curl_slist_append + +Only used internally, not exposed through the public API. + +=item curl_slist_free_all + +Only used internally, not exposed through the public API. + +=item curl_unescape + +Not implemented and won't be, as this method is considered deprecated. + +=item curl_version_info + +Not yet implemented. + +=item curl_multi_* + +Most methods are either not exposed through the WWW::Curl::Multi API or they behave differently +than it's C counterpart. Please see the section about WWW::Curl::Multi above. + +=back + +=head1 USAGE CASES + +The standard Perl WWW module, LWP should be used in most cases to work with +the HTTP or FTP protocol from Perl. However, there are some cases where LWP doesn't +perform well. One is speed and the other is paralellism. WWW::Curl is much faster, +uses much less CPU cycles and it's capable of non-blocking parallel requests. + +In some cases, for example when building a web crawler, cpu usage and parallel downloads are +important considerations. It can be desirable to use WWW::Curl to do the heavy-lifting of +a large number of downloads and wrap the resulting data into a Perl-friendly structure by +HTTP::Response. + +=head1 CHANGES + +Version 4.01 adds several bugfixes. See Changes file. + +Version 4.00 added new documentation, the build system changed to Module::Install, +the test suite was rewritten to use Test::More, a new calling syntax for WWW::Curl::Multi +was added, memory leak and other bugfixes added, Perl 5.6 and libcurl 7.10.8 as minimum +requirements for this module were set. + +Version 3.12 is a bugfix for a missing Share.pm.in file in the release. + +Version 3.11 added WWW::Curl::Share. + +Version 3.10 adds the WWW::Curl::Share interface by Anton Federov +and large file options after a contribution from Mark Hindley. + +Version 3.02 adds some backwards compatibility for scripts still using +'WWW::Curl::easy' names. + +Version 3.01 added some support for pre-multi versions of libcurl. + +Version 3.00 adds WWW::Curl::Multi interface, and a new module names +following perl conventions (WWW::Curl::Easy rather than WWW::Curl::easy), +by Sebastian Riedel <sri at cpan.org>. + +Version 2.00 of WWW::Curl::easy is a renaming of the previous version +(named Curl::easy), to follow CPAN naming guidelines, by Cris Bailiff. + +Versions 1.30, a (hopefully) threadable, object-oriented, +multiple-callback compatible version of Curl::easy was substantially +reworked from the previous Curl::easy release (1.21) by Cris Bailiff. + +=head1 AUTHORS + +Currently maintained by Cris Bailiff <c.bailiff+curl at devsecure.com> + +Original Author Georg Horn <horn@koblenz-net.de>, with additional callback, +pod and test work by Cris Bailiff <c.bailiff+curl@devsecure.com> and +Forrest Cahoon <forrest.cahoon@merrillcorp.com>. Sebastian Riedel added ::Multi +and Anton Fedorov (datacompboy <at> mail.ru) added ::Share. Balint Szilakszi +repackaged the module into a more modern form. + +=head1 COPYRIGHT + +Copyright (C) 2000-2005,2008 Daniel Stenberg, Cris Bailiff, +Sebastian Riedel, Balint Szilakszi et al. + +You may opt to use, copy, modify, merge, publish, distribute and/or sell +copies of the Software, and permit persons to whom the Software is furnished +to do so, under the terms of the MPL or the MIT/X-derivate licenses. You may +pick one of these licenses. + +=head1 SEE ALSO + +http://curl.haxx.se diff --git a/lib/WWW/Curl/Easy.pm b/lib/WWW/Curl/Easy.pm new file mode 100644 index 0000000..a636534 --- /dev/null +++ b/lib/WWW/Curl/Easy.pm @@ -0,0 +1,245 @@ +package WWW::Curl::Easy; + +use strict; +use warnings; +use Carp; +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD); + +$VERSION = '4.05'; + +require WWW::Curl; +require Exporter; +require AutoLoader; + +@ISA = qw(Exporter DynaLoader); + +# Items to export into callers namespace by default. Note: do not export +# names by default without a very good reason. Use EXPORT_OK instead. +# Do not simply export all your public functions/methods/constants. + +@EXPORT = qw( +CURLOPT_APPEND +CURLOPT_AUTOREFERER +CURLOPT_BUFFERSIZE +CURLOPT_CAINFO +CURLOPT_CAPATH +CURLOPT_CLOSEPOLICY +CURLOPT_CONNECTTIMEOUT +CURLOPT_CONNECTTIMEOUT_MS +CURLOPT_CONNECT_ONLY +CURLOPT_CONV_FROM_NETWORK_FUNCTION +CURLOPT_CONV_FROM_UTF8_FUNCTION +CURLOPT_CONV_TO_NETWORK_FUNCTION +CURLOPT_COOKIE +CURLOPT_COOKIEFILE +CURLOPT_COOKIEJAR +CURLOPT_COOKIELIST +CURLOPT_COOKIESESSION +CURLOPT_COPYPOSTFIELDS +CURLOPT_CRLF +CURLOPT_CUSTOMREQUEST +CURLOPT_DEBUGDATA +CURLOPT_DEBUGFUNCTION +CURLOPT_DIRLISTONLY +CURLOPT_DNS_CACHE_TIMEOUT +CURLOPT_DNS_USE_GLOBAL_CACHE +CURLOPT_EGDSOCKET +CURLOPT_ENCODING +CURLOPT_ERRORBUFFER +CURLOPT_FAILONERROR +CURLOPT_FILE +CURLOPT_FILETIME +CURLOPT_FOLLOWLOCATION +CURLOPT_FORBID_REUSE +CURLOPT_FRESH_CONNECT +CURLOPT_FTPAPPEND +CURLOPT_FTPLISTONLY +CURLOPT_FTPPORT +CURLOPT_FTPSSLAUTH +CURLOPT_FTP_ACCOUNT +CURLOPT_FTP_ALTERNATIVE_TO_USER +CURLOPT_FTP_CREATE_MISSING_DIRS +CURLOPT_FTP_FILEMETHOD +CURLOPT_FTP_RESPONSE_TIMEOUT +CURLOPT_FTP_SKIP_PASV_IP +CURLOPT_FTP_SSL +CURLOPT_FTP_SSL_CCC +CURLOPT_FTP_USE_EPRT +CURLOPT_FTP_USE_EPSV +CURLOPT_HEADER +CURLOPT_HEADERDATA +CURLOPT_HEADERFUNCTION +CURLOPT_HTTP200ALIASES +CURLOPT_HTTPAUTH +CURLOPT_HTTPGET +CURLOPT_HTTPHEADER +CURLOPT_HTTPPOST +CURLOPT_HTTPPROXYTUNNEL +CURLOPT_HTTP_CONTENT_DECODING +CURLOPT_HTTP_TRANSFER_DECODING +CURLOPT_HTTP_VERSION +CURLOPT_IGNORE_CONTENT_LENGTH +CURLOPT_INFILE +CURLOPT_INFILESIZE +CURLOPT_INFILESIZE_LARGE +CURLOPT_INTERFACE +CURLOPT_IOCTLDATA +CURLOPT_IOCTLFUNCTION +CURLOPT_IPRESOLVE +CURLOPT_KEYPASSWD +CURLOPT_KRB4LEVEL +CURLOPT_KRBLEVEL +CURLOPT_LOCALPORT +CURLOPT_LOCALPORTRANGE +CURLOPT_LOW_SPEED_LIMIT +CURLOPT_LOW_SPEED_TIME +CURLOPT_MAXCONNECTS +CURLOPT_MAXFILESIZE +CURLOPT_MAXFILESIZE_LARGE +CURLOPT_MAXREDIRS +CURLOPT_MAX_RECV_SPEED_LARGE +CURLOPT_MAX_SEND_SPEED_LARGE +CURLOPT_NETRC +CURLOPT_NETRC_FILE +CURLOPT_NEW_DIRECTORY_PERMS +CURLOPT_NEW_FILE_PERMS +CURLOPT_NOBODY +CURLOPT_NOPROGRESS +CURLOPT_NOSIGNAL +CURLOPT_OPENSOCKETDATA +CURLOPT_OPENSOCKETFUNCTION +CURLOPT_PORT +CURLOPT_POST +CURLOPT_POST301 +CURLOPT_POSTFIELDS +CURLOPT_POSTFIELDSIZE +CURLOPT_POSTFIELDSIZE_LARGE +CURLOPT_POSTQUOTE +CURLOPT_PREQUOTE +CURLOPT_PRIVATE +CURLOPT_PROGRESSDATA +CURLOPT_PROGRESSFUNCTION +CURLOPT_PROXY +CURLOPT_PROXYAUTH +CURLOPT_PROXYPORT +CURLOPT_PROXYTYPE +CURLOPT_PROXYUSERPWD +CURLOPT_PROXY_TRANSFER_MODE +CURLOPT_PUT +CURLOPT_QUOTE +CURLOPT_RANDOM_FILE +CURLOPT_RANGE +CURLOPT_READFUNCTION +CURLOPT_REFERER +CURLOPT_RESUME_FROM +CURLOPT_RESUME_FROM_LARGE +CURLOPT_SEEKDATA +CURLOPT_SEEKFUNCTION +CURLOPT_SHARE +CURLOPT_SOCKOPTDATA +CURLOPT_SOCKOPTFUNCTION +CURLOPT_SSH_AUTH_TYPES +CURLOPT_SSH_HOST_PUBLIC_KEY_MD5 +CURLOPT_SSH_PRIVATE_KEYFILE +CURLOPT_SSH_PUBLIC_KEYFILE +CURLOPT_SSLCERT +CURLOPT_SSLCERTPASSWD +CURLOPT_SSLCERTTYPE +CURLOPT_SSLENGINE +CURLOPT_SSLENGINE_DEFAULT +CURLOPT_SSLKEY +CURLOPT_SSLKEYPASSWD +CURLOPT_SSLKEYTYPE +CURLOPT_SSLVERSION +CURLOPT_SSL_CIPHER_LIST +CURLOPT_SSL_CTX_DATA +CURLOPT_SSL_CTX_FUNCTION +CURLOPT_SSL_SESSIONID_CACHE +CURLOPT_SSL_VERIFYHOST +CURLOPT_SSL_VERIFYPEER +CURLOPT_STDERR +CURLOPT_TCP_NODELAY +CURLOPT_TELNETOPTIONS +CURLOPT_TIMECONDITION +CURLOPT_TIMEOUT +CURLOPT_TIMEOUT_MS +CURLOPT_TIMEVALUE +CURLOPT_TRANSFERTEXT +CURLOPT_UNRESTRICTED_AUTH +CURLOPT_UPLOAD +CURLOPT_URL +CURLOPT_USERAGENT +CURLOPT_USERPWD +CURLOPT_USE_SSL +CURLOPT_VERBOSE +CURLOPT_WRITEDATA +CURLOPT_WRITEFUNCTION +CURLOPT_WRITEHEADER +CURLOPT_WRITEINFO +CURLINFO_CONNECT_TIME +CURLINFO_CONTENT_LENGTH_DOWNLOAD +CURLINFO_CONTENT_LENGTH_UPLOAD +CURLINFO_CONTENT_TYPE +CURLINFO_COOKIELIST +CURLINFO_DATA_IN +CURLINFO_DATA_OUT +CURLINFO_EFFECTIVE_URL +CURLINFO_END +CURLINFO_FILETIME +CURLINFO_FTP_ENTRY_PATH +CURLINFO_HEADER_IN +CURLINFO_HEADER_OUT +CURLINFO_HEADER_SIZE +CURLINFO_HTTPAUTH_AVAIL +CURLINFO_HTTP_CODE +CURLINFO_HTTP_CONNECTCODE +CURLINFO_LASTONE +CURLINFO_LASTSOCKET +CURLINFO_NAMELOOKUP_TIME +CURLINFO_NONE +CURLINFO_NUM_CONNECTS +CURLINFO_OS_ERRNO +CURLINFO_PRETRANSFER_TIME +CURLINFO_PRIVATE +CURLINFO_PROXYAUTH_AVAIL +CURLINFO_REDIRECT_COUNT +CURLINFO_REDIRECT_TIME +CURLINFO_REDIRECT_URL +CURLINFO_REQUEST_SIZE +CURLINFO_RESPONSE_CODE +CURLINFO_SIZE_DOWNLOAD +CURLINFO_SIZE_UPLOAD +CURLINFO_SPEED_DOWNLOAD +CURLINFO_SPEED_UPLOAD +CURLINFO_SSL_DATA_IN +CURLINFO_SSL_DATA_OUT +CURLINFO_SSL_ENGINES +CURLINFO_SSL_VERIFYRESULT +CURLINFO_STARTTRANSFER_TIME +CURLINFO_TEXT +CURLINFO_TOTAL_TIME +); + +$WWW::Curl::Easy::headers = ""; +$WWW::Curl::Easy::content = ""; + +sub AUTOLOAD { + + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. + + ( my $constname = $AUTOLOAD ) =~ s/.*:://; + return constant( $constname, 0 ); +} + +1; + +__END__ + +Copyright (C) 2000-2005,2008 Daniel Stenberg, Cris Bailiff, +Sebastian Riedel, et al. + +You may opt to use, copy, modify, merge, publish, distribute and/or sell +copies of the Software, and permit persons to whom the Software is furnished +to do so, under the terms of the MPL or the MIT/X-derivate licenses. You may +pick one of these licenses. diff --git a/lib/WWW/Curl/Form.pm b/lib/WWW/Curl/Form.pm new file mode 100644 index 0000000..dd69c68 --- /dev/null +++ b/lib/WWW/Curl/Form.pm @@ -0,0 +1,12 @@ +package WWW::Curl::Form; +use strict; + +# In development! +# +#require WWW::Curl; +#use vars qw(@ISA @EXPORT_OK); +#require Exporter; +#require AutoLoader; +# @ISA = qw(Exporter DynaLoader); + +1; diff --git a/lib/WWW/Curl/Multi.pm b/lib/WWW/Curl/Multi.pm new file mode 100644 index 0000000..cc64628 --- /dev/null +++ b/lib/WWW/Curl/Multi.pm @@ -0,0 +1,14 @@ +package WWW::Curl::Multi; + +use strict; +use WWW::Curl; + +1; +__END__ + +Copyright (C) 2004 Sebastian Riedel, et al. + +You may opt to use, copy, modify, merge, publish, distribute and/or sell +copies of the Software, and permit persons to whom the Software is furnished +to do so, under the terms of the MPL or the MIT/X-derivate licenses. You may +pick one of these licenses. diff --git a/lib/WWW/Curl/Share.pm b/lib/WWW/Curl/Share.pm new file mode 100644 index 0000000..4da2183 --- /dev/null +++ b/lib/WWW/Curl/Share.pm @@ -0,0 +1,49 @@ +package WWW::Curl::Share; + +use strict; +use warnings; +use Carp; +use vars qw(@ISA @EXPORT @EXPORT_OK $AUTOLOAD); + +use WWW::Curl; +require Exporter; +require AutoLoader; + +@ISA = qw(Exporter DynaLoader); + +@EXPORT = qw( +CURLSHOPT_LAST +CURLSHOPT_LOCKFUNC +CURLSHOPT_NONE +CURLSHOPT_SHARE +CURLSHOPT_UNLOCKFUNC +CURLSHOPT_UNSHARE +CURLSHOPT_USERDATA +CURL_LOCK_DATA_CONNECT +CURL_LOCK_DATA_COOKIE +CURL_LOCK_DATA_DNS +CURL_LOCK_DATA_LAST +CURL_LOCK_DATA_NONE +CURL_LOCK_DATA_SHARE +CURL_LOCK_DATA_SSL_SESSION +); + +sub AUTOLOAD { + + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. + + ( my $constname = $AUTOLOAD ) =~ s/.*:://; + return constant( $constname, 0 ); +} + +1; +__END__ + + +Copyright (C) 2008, Anton Fedorov (datacompboy <at> mail.ru) + +You may opt to use, copy, modify, merge, publish, distribute and/or sell +copies of the Software, and permit persons to whom the Software is furnished +to do so, under the terms of the MPL or the MIT/X-derivate licenses. You may +pick one of these licenses. diff --git a/packaging/perl-WWW-Curl.spec b/packaging/perl-WWW-Curl.spec new file mode 100644 index 0000000..048738e --- /dev/null +++ b/packaging/perl-WWW-Curl.spec @@ -0,0 +1,131 @@ +# +# - WWW::Curl - +# This spec file was automatically generated by cpan2rpm [ver: 2.028] +# The following arguments were used: +# --version 4.05 WWW-Curl +# For more information on cpan2rpm please visit: http://perl.arix.com/ +# + +%define pkgname WWW-Curl +%define filelist %{pkgname}-%{version}-filelist +%define NVR %{pkgname}-%{version}-%{release} +%define maketest 0 + +name: perl-WWW-Curl +summary: WWW::Curl is a Perl extension interface for libcurl +version: 4.05 +release: 4.1 +vendor: szbalint@cpan.org +packager: Arix International <cpan2rpm@arix.com> +license: Artistic +group: Applications/CPAN +url: http://www.cpan.org +buildroot: %{_tmppath}/%{name}-%{version}-%(id -u -n) +BuildRequires: pkgconfig(libcurl) +BuildRequires: pkgconfig(libcrypto) +BuildRequires: pkgconfig(libcares) +Requires: libcurl +BuildRequires: perl-Test-Pod-Coverage +prefix: %(echo %{_prefix}) +source: http://search.cpan.org//CPAN/authors/id/S/SZ/SZBALINT/WWW-Curl-4.05.tar.gz + +%description +This module provides a Perl interface to libcurl. It is not intended to be a standalone module +and because of this, the main libcurl documentation should be consulted for API details at +L<http://curl.haxx.se>. The documentation you're reading right now only contains the Perl specific +details, some sample code and the differences between the C API and the Perl one. + +# +# This package was generated automatically with the cpan2rpm +# utility. To get this software or for more information +# please visit: http://perl.arix.com/ +# + +%prep +%setup -q -n %{pkgname}-%{version} +chmod -R u+w %{_builddir}/%{pkgname}-%{version} + +%build +grep -rsl '^#!.*perl' . | +grep -v '.bak$' |xargs --no-run-if-empty \ +%__perl -MExtUtils::MakeMaker -e 'MY->fixin(@ARGV)' +CFLAGS="$RPM_OPT_FLAGS" +%{__perl} Makefile.PL `%{__perl} -MExtUtils::MakeMaker -e ' print qq|PREFIX=%{buildroot}%{_prefix}| if \$ExtUtils::MakeMaker::VERSION =~ /5\.9[1-6]|6\.0[0-5]/ '` +%{__make} +%if %maketest +%{__make} test +%endif + +%install +[ "%{buildroot}" != "/" ] && rm -rf %{buildroot} + +%{makeinstall} `%{__perl} -MExtUtils::MakeMaker -e ' print \$ExtUtils::MakeMaker::VERSION <= 6.05 ? qq|PREFIX=%{buildroot}%{_prefix}| : qq|DESTDIR=%{buildroot}| '` + +cmd=/usr/share/spec-helper/compress_files +[ -x $cmd ] || cmd=/usr/lib/rpm/brp-compress +[ -x $cmd ] && $cmd + +# SuSE Linux +if [ -e /etc/SuSE-release -o -e /etc/UnitedLinux-release ] +then + %{__mkdir_p} %{buildroot}/var/adm/perl-modules + %{__cat} `find %{buildroot} -name "perllocal.pod"` \ + | %{__sed} -e s+%{buildroot}++g \ + > %{buildroot}/var/adm/perl-modules/%{name} +fi + +# remove special files +find %{buildroot} -name "perllocal.pod" \ + -o -name ".packlist" \ + -o -name "*.bs" \ + |xargs -i rm -f {} + +# no empty directories +find %{buildroot}%{_prefix} \ + -type d -depth \ + -exec rmdir {} \; 2>/dev/null + +%{__perl} -MFile::Find -le ' + find({ wanted => \&wanted, no_chdir => 1}, "%{buildroot}"); + print "%doc README.Win32 template inc Changes README LICENSE"; + for my $x (sort @dirs, @files) { + push @ret, $x unless indirs($x); + } + print join "\n", sort @ret; + + sub wanted { + return if /auto$/; + + local $_ = $File::Find::name; + my $f = $_; s|^\Q%{buildroot}\E||; + return unless length; + return $files[@files] = $_ if -f $f; + + $d = $_; + /\Q$d\E/ && return for reverse sort @INC; + $d =~ /\Q$_\E/ && return + for qw|/etc %_prefix/man %_prefix/bin %_prefix/share|; + + $dirs[@dirs] = $_; + } + + sub indirs { + my $x = shift; + $x =~ /^\Q$_\E\// && $x ne $_ && return 1 for @dirs; + } + ' > %filelist + +[ -z %filelist ] && { + echo "ERROR: empty %files listing" + exit -1 + } + +%clean +[ "%{buildroot}" != "/" ] && rm -rf %{buildroot} + +%files -f %filelist +%defattr(-,root,root) + +%changelog +* Thu Dec 4 2008 root@vsltsus103 +- Initial build. diff --git a/t/00constants.t b/t/00constants.t new file mode 100644 index 0000000..fba9aba --- /dev/null +++ b/t/00constants.t @@ -0,0 +1,8 @@ +#!perl +use strict; +use warnings; +use Test::More tests => 2; + +BEGIN { use_ok( 'WWW::Curl::Easy' ); } + +ok (CURLOPT_URL == 10000+2, "Constant loaded ok"); diff --git a/t/01basic.t b/t/01basic.t new file mode 100644 index 0000000..5b4d175 --- /dev/null +++ b/t/01basic.t @@ -0,0 +1,48 @@ +#!perl + +use strict; +use warnings; +use Test::More tests => 14; +use File::Temp qw/tempfile/; + +BEGIN { use_ok( 'WWW::Curl::Easy' ); } + +my $url = $ENV{CURL_TEST_URL} || "http://www.google.com"; + +my $memfile = ''; +# Init the curl session +my $curl = WWW::Curl::Easy->new(); +ok($curl, 'Curl session initialize returns something'); +ok(ref($curl) eq 'WWW::Curl::Easy', 'Curl session looks like an object from the WWW::Curl::Easy module'); + +ok(! $curl->setopt(CURLOPT_NOPROGRESS, 1), "Setting CURLOPT_NOPROGRESS"); +ok(! $curl->setopt(CURLOPT_FOLLOWLOCATION, 1), "Setting CURLOPT_FOLLOWLOCATION"); +ok(! $curl->setopt(CURLOPT_TIMEOUT, 30), "Setting CURLOPT_TIMEOUT"); +$curl->setopt(CURLOPT_HEADER, 1); + +my $head = tempfile(); +ok(! $curl->setopt(CURLOPT_WRITEHEADER, $head), "Setting CURLOPT_WRITEHEADER"); + +my $body = tempfile(); +ok(! $curl->setopt(CURLOPT_WRITEDATA,$body), "Setting CURLOPT_WRITEDATA"); + +ok(! $curl->setopt(CURLOPT_URL, $url), "Setting CURLOPT_URL"); + +my @myheaders; +$myheaders[0] = "Server: www"; +$myheaders[1] = "User-Agent: Perl interface for libcURL"; +ok(! $curl->setopt(CURLOPT_HTTPHEADER, \@myheaders), "Setting CURLOPT_HTTPHEADER"); + +my $retcode = $curl->perform(); + +ok(! $retcode, "Curl return code ok"); + +my $bytes = $curl->getinfo(CURLINFO_SIZE_DOWNLOAD); +ok( $bytes, "getinfo returns non-zero number of bytes"); +my $realurl = $curl->getinfo(CURLINFO_EFFECTIVE_URL); +ok( $realurl, "getinfo returns CURLINFO_EFFECTIVE_URL"); +my $httpcode = $curl->getinfo(CURLINFO_HTTP_CODE); +ok( $httpcode, "getinfo returns CURLINFO_HTTP_CODE"); +#diag ("Bytes: $bytes"); +#diag ("realurl: $realurl"); +#diag ("httpcode: $httpcode"); diff --git a/t/02callbacks.t b/t/02callbacks.t new file mode 100644 index 0000000..76aff4f --- /dev/null +++ b/t/02callbacks.t @@ -0,0 +1,41 @@ +#!perl + +use strict; +use warnings; +use Test::More tests => 7; +use File::Temp qw/tempfile/; + +BEGIN { use_ok( 'WWW::Curl::Easy' ); } + +my $url = $ENV{CURL_TEST_URL} || "http://www.google.com"; + +# Init the curl session +my $curl = WWW::Curl::Easy->new(); +ok($curl, 'Curl session initialize returns something'); +ok(ref($curl) eq 'WWW::Curl::Easy', 'Curl session looks like an object from the WWW::Curl::Easy module'); + +$curl->setopt(CURLOPT_NOPROGRESS, 1); +$curl->setopt(CURLOPT_FOLLOWLOCATION, 1); +$curl->setopt(CURLOPT_TIMEOUT, 30); + +my $head = tempfile(); +$curl->setopt(CURLOPT_WRITEHEADER, $head); + +my $body = tempfile(); +$curl->setopt(CURLOPT_FILE,$body); + +$curl->setopt(CURLOPT_URL, $url); + +my $header_called = 0; +sub header_callback { $header_called = 1; return length($_[0]) }; +my $body_called = 0; +sub body_callback { $body_called++;return length($_[0]) }; + + + +ok (! $curl->setopt(CURLOPT_HEADERFUNCTION, \&header_callback), "CURLOPT_HEADERFUNCTION set"); +ok (! $curl->setopt(CURLOPT_WRITEFUNCTION, \&body_callback), "CURLOPT_WRITEFUNCTION set"); + +$curl->perform(); +ok($header_called, "CURLOPT_HEADERFUNCTION callback was used"); +ok($body_called, "CURLOPT_WRITEFUNCTION callback was used"); diff --git a/t/04abort-test.t b/t/04abort-test.t new file mode 100644 index 0000000..c653c49 --- /dev/null +++ b/t/04abort-test.t @@ -0,0 +1,36 @@ +#!perl + +use strict; +use warnings; +use Test::More tests => 8; +use File::Temp qw/tempfile/; + +BEGIN { use_ok( 'WWW::Curl::Easy' ); } + +my $url = $ENV{CURL_TEST_URL} || "http://www.google.com"; + +# Init the curl session +my $curl = WWW::Curl::Easy->new(); +ok($curl, 'Curl session initialize returns something'); +ok(ref($curl) eq 'WWW::Curl::Easy', 'Curl session looks like an object from the WWW::Curl::Easy module'); + +$curl->setopt(CURLOPT_NOPROGRESS, 1); +$curl->setopt(CURLOPT_FOLLOWLOCATION, 1); +$curl->setopt(CURLOPT_TIMEOUT, 30); + +my $head = tempfile(); +ok(! $curl->setopt(CURLOPT_WRITEHEADER, $head), "Setting CURLOPT_WRITEHEADER"); + +my $body = tempfile(); +ok(! $curl->setopt(CURLOPT_FILE,$body), "Setting CURLOPT_FILE"); + +ok(! $curl->setopt(CURLOPT_URL, $url), "Setting CURLOPT_URL"); + +my $body_abort_called = 0; +sub body_abort_callback { $body_abort_called++; return -1 }; + +$curl->setopt(CURLOPT_WRITEFUNCTION, \&body_abort_callback); + +ok( $curl->perform(), "Request fails, Abort succeeds"); + +ok( $body_abort_called, "Abort function was invoked"); diff --git a/t/05progress.t b/t/05progress.t new file mode 100644 index 0000000..52129ea --- /dev/null +++ b/t/05progress.t @@ -0,0 +1,54 @@ +#!perl + +use strict; +use warnings; +use Test::More tests => 16; +use File::Temp qw/tempfile/; + +BEGIN { use_ok( 'WWW::Curl::Easy' ); } + +my $url = $ENV{CURL_TEST_URL} || "http://www.google.com"; + +# Init the curl session +my $curl = WWW::Curl::Easy->new(); +ok($curl, 'Curl session initialize returns something'); +ok(ref($curl) eq 'WWW::Curl::Easy', 'Curl session looks like an object from the WWW::Curl::Easy module'); + +ok(! $curl->setopt(CURLOPT_NOPROGRESS, 0), "Setting CURLOPT_NOPROGRESS"); +ok(! $curl->setopt(CURLOPT_FOLLOWLOCATION, 1), "Setting CURLOPT_FOLLOWLOCATION"); +ok(! $curl->setopt(CURLOPT_TIMEOUT, 30), "Setting CURLOPT_TIMEOUT"); + +my $head = tempfile(); +ok(! $curl->setopt(CURLOPT_WRITEHEADER, $head), "Setting CURLOPT_WRITEHEADER"); + +my $body = tempfile(); +ok(! $curl->setopt(CURLOPT_FILE,$body), "Setting CURLOPT_FILE"); + +ok(! $curl->setopt(CURLOPT_URL, $url), "Setting CURLOPT_URL"); + +my @myheaders; +$myheaders[0] = "Server: www"; +$myheaders[1] = "User-Agent: Perl interface for libcURL"; +ok(! $curl->setopt(CURLOPT_HTTPHEADER, \@myheaders), "Setting CURLOPT_HTTPHEADER"); + +ok(! $curl->setopt(CURLOPT_PROGRESSDATA,"making progress!"), "Setting CURLOPT_PROGRESSDATA"); + +my $progress_called = 0; +my $last_dlnow = 0; +sub prog_callb +{ + my ($clientp,$dltotal,$dlnow,$ultotal,$ulnow)=@_; + $last_dlnow=$dlnow; + $progress_called++; + return 0; +} + +ok (! $curl->setopt(CURLOPT_PROGRESSFUNCTION, \&prog_callb), "Setting CURLOPT_PROGRESSFUNCTION"); + +ok (! $curl->setopt(CURLOPT_NOPROGRESS, 0), "Turning progress meter back on"); + +ok (! $curl->perform(), "Performing perform"); + +ok ($progress_called, "Progress callback called"); + +ok ($last_dlnow, "Last downloaded chunk non-zero"); diff --git a/t/06http-post.t b/t/06http-post.t new file mode 100644 index 0000000..fa1f1e7 --- /dev/null +++ b/t/06http-post.t @@ -0,0 +1,58 @@ +#!perl + +use strict; +use warnings; +use Test::More skip_all => "Not performing http POST/upload tests"; +use File::Temp qw/tempfile/; + +BEGIN { use_ok( 'WWW::Curl::Easy' ); } + +my $url = $ENV{CURL_TEST_URL} || "http://www.google.com"; + +# Init the curl session +my $curl = WWW::Curl::Easy->new(); +ok($curl, 'Curl session initialize returns something'); +ok(ref($curl) eq 'WWW::Curl::Easy', 'Curl session looks like an object from the WWW::Curl::Easy module'); + +ok(! $curl->setopt(CURLOPT_NOPROGRESS, 1), "Setting CURLOPT_NOPROGRESS"); +ok(! $curl->setopt(CURLOPT_FOLLOWLOCATION, 1), "Setting CURLOPT_FOLLOWLOCATION"); +ok(! $curl->setopt(CURLOPT_TIMEOUT, 30), "Setting CURLOPT_TIMEOUT"); + +my $head = tempfile(); +ok(! $curl->setopt(CURLOPT_WRITEHEADER, $head), "Setting CURLOPT_WRITEHEADER"); + +my $body = tempfile(); +ok(! $curl->setopt(CURLOPT_FILE, $body), "Setting CURLOPT_FILE"); + +ok(! $curl->setopt(CURLOPT_URL, $url), "Setting CURLOPT_URL"); + +my @myheaders; +$myheaders[0] = "Server: www"; +$myheaders[1] = "User-Agent: Perl interface for libcURL"; +ok(! $curl->setopt(CURLOPT_HTTPHEADER, \@myheaders), "Setting CURLOPT_HTTPHEADER"); + +my $read_max=1000; + +sub read_callb +{ + my ($maxlen,$sv)=@_; + if ($read_max > 0) { + my $len=int($read_max/3)+1; + my $data = chr(ord('A')+rand(26))x$len; + $read_max=$read_max-length($data); + return $data; + } else { + return ""; + } +} + +# +# XXX - Outdated POST mechanism! +# + +ok(! $curl->setopt(CURLOPT_READFUNCTION,\&read_callb), "Setting CURLOPT_READFUNCTION"); +ok(! $curl->setopt(CURLOPT_INFILESIZE,$read_max ), "Setting CURLOPT_INFILESIZE"); +ok(! $curl->setopt(CURLOPT_UPLOAD,1 ), "Setting CURLOPT_UPLOAD"); +ok(! $curl->setopt(CURLOPT_CUSTOMREQUEST,"POST" ), "Setting CURLOPT_CUSTOMREQUEST"); + +ok(! $curl->perform(), "Performing perform"); diff --git a/t/07ftp-upload.t b/t/07ftp-upload.t new file mode 100644 index 0000000..27a57e2 --- /dev/null +++ b/t/07ftp-upload.t @@ -0,0 +1,86 @@ +#!perl + +use strict; +use warnings; +use Test::More skip_all => "Not performing ftp upload tests"; + +BEGIN { use_ok( 'WWW::Curl::Easy' ); } + +my $count=1; + + +# Read URL to get, defaulting to environment variable if supplied +my $url=$ENV{CURL_TEST_URL_FTP} || ""; +if (!$url) { + print "1..0 # No test ftp URL supplied - skipping test\n"; + exit; +} + +print "1..8\n"; + +# Init the curl session +my $curl = WWW::Curl::Easy->new(); +if ($curl == 0) { + print "not "; +} +print "ok ".++$count."\n"; + +$curl->setopt(CURLOPT_NOPROGRESS, 1); +$curl->setopt(CURLOPT_FOLLOWLOCATION, 1); +$curl->setopt(CURLOPT_TIMEOUT, 30); + +open HEAD, ">head.out"; +$curl->setopt(CURLOPT_WRITEHEADER, \*HEAD); +print "ok ".++$count."\n"; + +open BODY, ">body.out"; +$curl->setopt(CURLOPT_FILE, \*body); +print "ok ".++$count."\n"; + +$curl->setopt(CURLOPT_URL, $url); + +print "ok ".++$count."\n"; + +# Now do an ftp upload: + +$curl->setopt(CURLOPT_UPLOAD, 1); + + +my $read_max=1000; +$curl->setopt(CURLOPT_INFILESIZE,$read_max ); +print "ok ".++$count."\n"; + +sub read_callb +{ + my ($maxlen,$sv)=@_; + print "# perl read_callback has been called!\n"; + print "# max data size: $maxlen - $read_max bytes needed\n"; + + if ($read_max > 0) { + my $len=int($read_max/3)+1; + my $data = chr(ord('A')+rand(26))x$len; + print "# generated max/3=", int($read_max/3)+1, " characters to be uploaded - $data.\n"; + $read_max=$read_max-length($data); + return $data; + } else { + return ""; + } +} + +# Use perl read callback to read data to be uploaded +$curl->setopt(CURLOPT_READFUNCTION, \&read_callb); + +# Use perl passwd callback to read password for login to ftp server +$curl->setopt(CURLOPT_USERPWD, "ftp\@"); + +print "ok ".++$count."\n"; + +# Go get it +my $code; +if (($code=$curl->perform()) == 0) { + my $bytes=$curl->getinfo(CURLINFO_SIZE_UPLOAD); + print "ok ".++$count." $bytes bytes transferred\n"; +} else { + # We can acces the error message in $errbuf here + print "not ok ".++$count." ftpcode= $code, errbuf=".$curl->errbuf."\n"; +} diff --git a/t/08ssl.t b/t/08ssl.t new file mode 100644 index 0000000..28759e5 --- /dev/null +++ b/t/08ssl.t @@ -0,0 +1,92 @@ +#!perl + +use strict; +use warnings; +use Test::More; +use File::Temp qw/tempfile/; +use WWW::Curl::Easy; + +# list of tests +# site-url, verifypeer(0,1), verifyhost(0,2), result(0=ok, 1=fail), result-openssl0.9.5 +my $url_list=[ + + [ 'https://65.205.248.243/', 0, 0, 0 , 0 ], # www.thawte.com +# [ 'https://65.205.248.243/', 0, 2, 1 , 1 ], # www.thawte.com + [ 'https://65.205.249.60/', 0, 0, 0 , 0 ], # www.verisign.com +# [ 'https://65.205.249.60/', 0, 2, 1 , 1 ], # www.verisign.com + [ 'https://www.microsoft.com/', 0, 0, 0 , 0 ], + [ 'https://www.microsoft.com/', 0, 0, 0 , 0 ], + [ 'https://www.verisign.com/', 1, 2, 0 , 0 ], # verisign have had broken ssl - do this first + [ 'https://www.verisign.com/', 0, 0, 0 , 0 ], + [ 'https://www.verisign.com/', 0, 0, 0 , 0 ], + [ 'https://www.verisign.com/', 0, 2, 0 , 0 ], + [ 'https://www.thawte.com/', 0, 0, 0 , 0 ], + [ 'https://www.thawte.com/', 0, 2, 0 , 0 ], + +# libcurl < 7.9.3 crashes with more than 5 ssl hosts per handle. + + [ 'https://www.rapidssl.com/', 0, 0, 0 , 0], + [ 'https://www.rapidssl.com/', 0, 2, 0 , 0], + [ 'https://www.rapidssl.com/', 1, 0, 1 , 0], + [ 'https://www.rapidssl.com/', 1, 2, 1 , 0], +]; + + +if (&WWW::Curl::Easy::version() !~ /ssl/i) { + plan skip_all => 'libcurl was compiled without ssl support, skipping ssl tests'; +} else { + plan tests => scalar(@{$url_list})+7; +} + +# Init the curl session +my $curl = WWW::Curl::Easy->new(); +ok($curl, 'Curl session initialize returns something'); #1 +ok(ref($curl) eq 'WWW::Curl::Easy', 'Curl session looks like an object from the WWW::Curl::Easy module'); #2 + +ok(! $curl->setopt(CURLOPT_NOPROGRESS, 1), "Setting CURLOPT_NOPROGRESS"); #3 +ok(! $curl->setopt(CURLOPT_FOLLOWLOCATION, 1), "Setting CURLOPT_FOLLOWLOCATION"); #4 +ok(! $curl->setopt(CURLOPT_TIMEOUT, 30), "Setting CURLOPT_TIMEOUT"); #5 + +my $head = tempfile(); +ok(! $curl->setopt(CURLOPT_WRITEHEADER, $head), "Setting CURLOPT_WRITEHEADER"); #6 + +my $body = tempfile(); +ok(! $curl->setopt(CURLOPT_FILE, $body), "Setting CURLOPT_FILE"); #7 + +my @myheaders; +$myheaders[0] = "User-Agent: Verifying SSL functions in WWW::Curl perl interface for libcURL"; +$curl->setopt(CURLOPT_HTTPHEADER, \@myheaders); + +$curl->setopt(CURLOPT_FORBID_REUSE, 1); +$curl->setopt(CURLOPT_FRESH_CONNECT, 1); +#$curl->setopt(CURLOPT_SSL_CIPHER_LIST, "HIGH:MEDIUM"); + +$curl->setopt(CURLOPT_CAINFO,"ca-bundle.crt"); +$curl->setopt(CURLOPT_DEBUGFUNCTION, \&silence); + +sub silence { return 0 } + +my $count = 1; + +my $sslversion95 = 0; +$sslversion95++ if (&WWW::Curl::Easy::version() =~ m/SSL 0.9.5/); # 0.9.5 has buggy connect with some ssl sites + +my $haveca = 0; +if (-f "ca-bundle.crt") { $haveca = 1; } + +for my $test_list (@$url_list) { + my ($url,$verifypeer,$verifyhost,$result,$result95)=@{$test_list}; + if ($verifypeer && !$haveca) { $result = 1 } # expect to fail if no ca-bundle file + if ($sslversion95) { $result=$result95 }; # change expectation + + + $curl->setopt(CURLOPT_SSL_VERIFYPEER,$verifypeer); # do verify + $curl->setopt(CURLOPT_SSL_VERIFYHOST,$verifyhost); # check name + my $retcode; + + $curl->setopt(CURLOPT_URL, $url); + + $retcode = $curl->perform(); + ok(($retcode != 0) == $result, "$url ssl test succeeds"); +} + diff --git a/t/09times.t b/t/09times.t new file mode 100644 index 0000000..6b3c43a --- /dev/null +++ b/t/09times.t @@ -0,0 +1,58 @@ +#!perl + +use strict; +use warnings; +use Test::More tests => 19; +use File::Temp qw/tempfile/; + +BEGIN { use_ok( 'WWW::Curl::Easy' ); } + +my $url = $ENV{CURL_TEST_URL} || "http://www.google.com"; + +# Init the curl session +my $curl = WWW::Curl::Easy->new(); +ok($curl, 'Curl session initialize returns something'); +ok(ref($curl) eq 'WWW::Curl::Easy', 'Curl session looks like an object from the WWW::Curl::Easy module'); + +ok(! $curl->setopt(CURLOPT_NOPROGRESS, 1), "Setting CURLOPT_NOPROGRESS"); +ok(! $curl->setopt(CURLOPT_FOLLOWLOCATION, 1), "Setting CURLOPT_FOLLOWLOCATION"); +ok(! $curl->setopt(CURLOPT_TIMEOUT, 30), "Setting CURLOPT_TIMEOUT"); + +my $head = tempfile(); +ok(! $curl->setopt(CURLOPT_WRITEHEADER, $head), "Setting CURLOPT_WRITEHEADER"); + +my $body = tempfile(); +ok(! $curl->setopt(CURLOPT_FILE, $body), "Setting CURLOPT_FILE"); + +ok(! $curl->setopt(CURLOPT_URL, $url), "Setting CURLOPT_URL"); + +my @myheaders; +$myheaders[0] = "Server: www"; +$myheaders[1] = "User-Agent: Perl interface for libcURL"; +ok(! $curl->setopt(CURLOPT_HTTPHEADER, \@myheaders), "Setting CURLOPT_HTTPHEADER"); + +my $retcode; +$retcode = $curl->perform(); +ok(! $retcode,"Checking perform return code"); + +if ($retcode == 0) { + my $bytes = $curl->getinfo(CURLINFO_SIZE_DOWNLOAD); + ok($bytes, "Non-zero bytesize check"); + my $realurl = $curl->getinfo(CURLINFO_EFFECTIVE_URL); + ok($realurl, "URL definedness check"); + my $httpcode = $curl->getinfo(CURLINFO_HTTP_CODE); + ok($httpcode, "HTTP status code check"); +} + +my $start = $curl->getinfo(CURLINFO_STARTTRANSFER_TIME); +ok ($start, "Valid transfer start time"); +my $total = $curl->getinfo(CURLINFO_TOTAL_TIME); +ok ($total, "defined total transfer time"); +my $dns = $curl->getinfo(CURLINFO_NAMELOOKUP_TIME); +ok ($dns, "NSLOOKUP time is defined"); +my $conn = $curl->getinfo(CURLINFO_CONNECT_TIME); +ok ($conn, "Connect time defined"); +my $pre = $curl->getinfo(CURLINFO_PRETRANSFER_TIME); +ok ($pre, "Pre-transfer time nonzero, defined"); + +exit; diff --git a/t/10errbuf.t b/t/10errbuf.t new file mode 100644 index 0000000..8349b1b --- /dev/null +++ b/t/10errbuf.t @@ -0,0 +1,40 @@ +#!perl + +use strict; +use warnings; +use Test::More tests => 12; +use File::Temp qw/tempfile/; + +BEGIN { use_ok( 'WWW::Curl::Easy' ); } + +my $url = $ENV{CURL_TEST_URL} || "http://www.google.com"; + +# Init the curl session +my $curl = WWW::Curl::Easy->new(); +ok($curl, 'Curl session initialize returns something'); +ok(ref($curl) eq 'WWW::Curl::Easy', 'Curl session looks like an object from the WWW::Curl::Easy module'); + +ok(! $curl->setopt(CURLOPT_NOPROGRESS, 1), "Setting CURLOPT_NOPROGRESS"); +ok(! $curl->setopt(CURLOPT_FOLLOWLOCATION, 1), "Setting CURLOPT_FOLLOWLOCATION"); +ok(! $curl->setopt(CURLOPT_TIMEOUT, 30), "Setting CURLOPT_TIMEOUT"); + +my $head = tempfile(); +ok(! $curl->setopt(CURLOPT_WRITEHEADER, $head), "Setting CURLOPT_WRITEHEADER"); + +my $body = tempfile(); +ok(! $curl->setopt(CURLOPT_FILE, $body), "Setting CURLOPT_FILE"); + +ok(! $curl->setopt(CURLOPT_URL, $url), "Setting CURLOPT_URL"); + +my $new_error = tempfile(); +ok(! $curl->setopt(CURLOPT_STDERR, $new_error), "Setting CURLOPT_STDERR"); + +# create a (hopefully) bad URL, so we get an error + +ok(! $curl->setopt(CURLOPT_URL, "badprotocol://127.0.0.1:2"), "Setting CURLOPT_URL succeeds, even with a bad protocol"); + +my $retcode = $curl->perform(); + +ok($retcode, "Non-zero return code indicates the expected failure"); + +exit; diff --git a/t/13slowleak.t b/t/13slowleak.t new file mode 100644 index 0000000..1bfbb21 --- /dev/null +++ b/t/13slowleak.t @@ -0,0 +1,43 @@ +#!perl + +use strict; +use warnings; +#use Test::More tests => 214; +use Test::More skip_all => "Not performing slow leakage regression test"; + +BEGIN { use_ok( 'WWW::Curl::Easy' ); } + +my $url = $ENV{CURL_TEST_URL} || "http://www.google.com"; + +# There was a slow leak per curl handle init/cleanup. Hopefully fixed. + +foreach my $j (1..200) { + +# Init the curl session +my $curl = WWW::Curl::Easy->new() or die "cannot curl"; + +$curl->setopt(CURLOPT_NOPROGRESS, 1); +$curl->setopt(CURLOPT_FOLLOWLOCATION, 1); +$curl->setopt(CURLOPT_TIMEOUT, 30); + +open (HEAD, "+>",undef); +WWW::Curl::Easy::setopt($curl, CURLOPT_WRITEHEADER, \*HEAD); +open (BODY, "+>, undef); +WWW::Curl::Easy::setopt($curl, CURLOPT_FILE, \*BODY); + +$curl->setopt(CURLOPT_URL, $url); + +my $httpcode = 0; + +my $retcode=$curl->perform(); +if ($retcode == 0) { + my bytes=$curl->getinfo(CURLINFO_SIZE_DOWNLOAD); + my $realurl=$curl->getinfo(CURLINFO_EFFECTIVE_URL); + my $httpcode=$curl->getinfo(CURLINFO_HTTP_CODE); +} else { + print "not ok $retcode / ".$curl->errbuf."\n"; +} + +} + +WWW::Curl::Easy::global_cleanup; #noop diff --git a/t/14duphandle.t b/t/14duphandle.t new file mode 100644 index 0000000..f56ac57 --- /dev/null +++ b/t/14duphandle.t @@ -0,0 +1,71 @@ +#!perl + +use strict; +use warnings; +use lib 'inc'; +use lib 'blib/lib'; +use lib 'blib/arch'; +use Test::More tests => 17; +use File::Temp qw/tempfile/; + +BEGIN { use_ok( 'WWW::Curl::Easy' ); } + +my $url = $ENV{CURL_TEST_URL} || "http://www.google.com"; + +{ +my $other_handle; +my $head = tempfile(); +my $body = tempfile(); + + { + # Init the curl session + my $curl = WWW::Curl::Easy->new(); + ok($curl, 'Curl session initialize returns something'); + ok(ref($curl) eq 'WWW::Curl::Easy', 'Curl session looks like an object from the WWW::Curl::Easy module'); + + ok(! $curl->setopt(CURLOPT_NOPROGRESS, 1), "Setting CURLOPT_NOPROGRESS"); + ok(! $curl->setopt(CURLOPT_FOLLOWLOCATION, 1), "Setting CURLOPT_FOLLOWLOCATION"); + ok(! $curl->setopt(CURLOPT_TIMEOUT, 30), "Setting CURLOPT_TIMEOUT"); + + ok(! $curl->setopt(CURLOPT_WRITEHEADER, $head), "Setting CURLOPT_WRITEHEADER"); + + ok(! $curl->setopt(CURLOPT_FILE, $body), "Setting CURLOPT_FILE"); + + ok(! $curl->setopt(CURLOPT_URL, $url), "Setting CURLOPT_URL"); + + my @myheaders; + $myheaders[0] = "Server: www"; + $myheaders[1] = "User-Agent: Perl interface for libcURL"; + ok(! $curl->setopt(CURLOPT_HTTPHEADER, \@myheaders), "Setting CURLOPT_HTTPHEADER"); + + # duplicate the handle + $other_handle = $curl->duphandle(); + ok ($other_handle && ref($other_handle) eq 'WWW::Curl::Easy', "Duplicated handle seems to be an object in the right namespace"); + + foreach my $x ($other_handle,$curl) { + my $retcode = $x->perform(); + ok(!$retcode, "Perform returns without an error"); + if ($retcode == 0) { + my $bytes = $x->getinfo(CURLINFO_SIZE_DOWNLOAD); + my $realurl = $x->getinfo(CURLINFO_EFFECTIVE_URL); + my $httpcode = $x->getinfo(CURLINFO_HTTP_CODE); + } + } + } + +ok(1, "Survived original curl handle DESTROY"); + +ok(! $other_handle->setopt(CURLOPT_URL, $url), "Setting CURLOPT_URL"); +my $retcode = $other_handle->perform(); +ok(!$retcode, "Perform returns without an error"); +if ($retcode == 0) { + my $bytes=$other_handle->getinfo(CURLINFO_SIZE_DOWNLOAD); + my $realurl=$other_handle->getinfo(CURLINFO_EFFECTIVE_URL); + my $httpcode=$other_handle->getinfo(CURLINFO_HTTP_CODE); +} + + + +} +ok(1, "Survived dup curl handle DESTROY"); +exit; diff --git a/t/15duphandle-callback.t b/t/15duphandle-callback.t new file mode 100644 index 0000000..3c5ecd0 --- /dev/null +++ b/t/15duphandle-callback.t @@ -0,0 +1,94 @@ +#!perl + +use strict; +use warnings; +use lib 'inc'; +use lib 'blib/lib'; +use lib 'blib/arch'; +use Test::More tests => 25; +use File::Temp qw/tempfile/; +use WWW::Curl::Easy; + +my $url = $ENV{CURL_TEST_URL} || "http://www.google.com"; +my $other_handle; +my $head = tempfile(); +my $hcall; +my $body_called = 0; +my $head_called = 0; +{ + # Init the curl session + my $curl = WWW::Curl::Easy->new(); + ok($curl, 'Curl session initialize returns something'); #1 + ok(ref($curl) eq 'WWW::Curl::Easy', 'Curl session looks like an object from the WWW::Curl::Easy module'); #2 + + ok(! $curl->setopt(CURLOPT_NOPROGRESS, 1), "Setting CURLOPT_NOPROGRESS"); #3 + ok(! $curl->setopt(CURLOPT_FOLLOWLOCATION, 1), "Setting CURLOPT_FOLLOWLOCATION"); #4 + ok(! $curl->setopt(CURLOPT_TIMEOUT, 30), "Setting CURLOPT_TIMEOUT"); #5 + + ok(! $curl->setopt(CURLOPT_WRITEHEADER, $head), "Setting CURLOPT_WRITEHEADER"); #6 + + my $body = tempfile(); + ok(! $curl->setopt(CURLOPT_FILE, $body), "Setting CURLOPT_FILE"); #7 + + + my @myheaders; + $myheaders[0] = "Server: www"; + $myheaders[1] = "User-Agent: Perl interface for libcURL"; + ok(! $curl->setopt(CURLOPT_HTTPHEADER, \@myheaders), "Setting CURLOPT_HTTPHEADER"); #8 + + + sub body_callback { + my ($chunk,$handle)=@_; + $body_called++; + return length($chunk); # OK + } + + sub head_callback { + my ($chunk,$handle)=@_; + $head_called++; + return length($chunk); # OK + } + + $hcall = \&head_callback; + ok(! $curl->setopt(CURLOPT_WRITEFUNCTION, \&body_callback), "Setting CURLOPT_WRITEFUNCTION callback"); #9 + ok(! $curl->setopt(CURLOPT_HEADERFUNCTION, $hcall), "Setting CURLOPT_HEADERFUNCTION callback"); #10 + + ok(! $curl->setopt(CURLOPT_URL, $url), "Setting CURLOPT_URL"); #11 + + # duplicate the handle + $other_handle = $curl->duphandle(); + ok($other_handle, 'duphandle seems to return something'); #12 + ok(ref($other_handle) eq 'WWW::Curl::Easy', 'Dup handle looks like an object from the WWW::Curl::Easy module'); #13 + + foreach my $x ($curl,$other_handle) { + my $retcode=$x->perform(); + ok(!$retcode, "Handle return code check"); #14-15 + if ($retcode == 0) { + my $bytes = $x->getinfo(CURLINFO_SIZE_DOWNLOAD); + my $realurl = $x->getinfo(CURLINFO_EFFECTIVE_URL); + my $httpcode = $x->getinfo(CURLINFO_HTTP_CODE); + } + } + ok( $head_called >= 2, "Header callback seems to have worked"); #16 + ok( $body_called >= 2, "Body callback seems to have worked"); #17 +} + +ok(! $other_handle->setopt(CURLOPT_URL, $url), "Setting CURLOPT_URL"); #18 + +my $retcode=$other_handle->perform(); +ok(!$retcode, "Handle return code check"); +ok( 1, "We survive DESTROY time for the original handle"); +ok( head_callback('1',undef), "We can still access the callbacks"); +my $third = $other_handle->duphandle(); +ok($third, 'duphandle seems to return something again'); +ok(ref($third) eq 'WWW::Curl::Easy', 'Dup handle looks like an object from the WWW::Curl::Easy module'); + +foreach my $x ($other_handle,$third) { + my $retcode=$x->perform(); + ok(!$retcode, "Handle return code check"); + if ($retcode == 0) { + my $bytes = $x->getinfo(CURLINFO_SIZE_DOWNLOAD); + my $realurl = $x->getinfo(CURLINFO_EFFECTIVE_URL); + my $httpcode = $x->getinfo(CURLINFO_HTTP_CODE); + } +} diff --git a/t/16formpost.t b/t/16formpost.t new file mode 100644 index 0000000..a5bcd45 --- /dev/null +++ b/t/16formpost.t @@ -0,0 +1,84 @@ +#!perl + +use Test::More skip_all => "Not performing POST"; + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +use strict; + +END {print "not ok 1\n" unless $::loaded;} +use WWW::Curl::Easy; + +$::loaded = 1; + +######################### End of black magic. + +my $count=0; + +use ExtUtils::MakeMaker qw(prompt); + +# Read URL to get, defaulting to environment variable if supplied +my $defurl=$ENV{CURL_TEST_URL} || "http://www.google.com/"; +my $url = prompt("# Please enter an URL to fetch",$defurl); +if (!$url) { + print "1..0 # No test URL supplied - skipping test\n"; + exit; +} +print "1..6\n"; +print "ok ".++$count."\n"; + +# Init the curl session +my $curl = WWW::Curl::Easy->new(); +if ($curl == 0) { + print "not "; +} +print "ok ".++$count."\n"; + +$curl->setopt(CURLOPT_NOPROGRESS, 1); +$curl->setopt(CURLOPT_FOLLOWLOCATION, 1); +$curl->setopt(CURLOPT_TIMEOUT, 30); + +open HEAD, ">head.out"; +$curl->setopt(CURLOPT_WRITEHEADER, *HEAD); +print "ok ".++$count."\n"; + +open BODY, ">body.out"; +$curl->setopt(CURLOPT_FILE,*BODY); +print "ok ".++$count."\n"; + +$curl->setopt(CURLOPT_URL, $url); + +print "ok ".++$count."\n"; + +my $read_max=1000; + +sub read_callb +{ + my ($maxlen,$sv)=@_; +# print STDERR "\nperl read_callback has been called!\n"; +# print STDERR "max data size: $maxlen - need $read_max bytes\n"; + if ($read_max > 0) { + my $len=int($read_max/3)+1; + my $data = chr(ord('A')+rand(26))x$len; +# print STDERR "generated max/3=", int($read_max/3)+1, " characters to be uploaded - $data.\n"; + $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->setopt(CURLOPT_READFUNCTION,\&read_callb); +$curl->setopt(CURLOPT_INFILESIZE,$read_max ); +$curl->setopt(CURLOPT_UPLOAD,1 ); +$curl->setopt(CURLOPT_CUSTOMREQUEST,"POST" ); + +if ($curl->perform() != 0) { + print "not "; +}; +print "ok ".++$count."\n"; diff --git a/t/17slist.t b/t/17slist.t new file mode 100644 index 0000000..e1da320 --- /dev/null +++ b/t/17slist.t @@ -0,0 +1,91 @@ +#!perl + +use Test::More skip_all => "Not performing printenv cgi tests"; + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +use strict; + +use WWW::Curl::Easy; + +######################### End of black magic. + +my $count=0; + +use ExtUtils::MakeMaker qw(prompt); + +# Read URL to get, defaulting to environment variable if supplied +my $defurl=$ENV{CURL_TEST_URL} || "http://www.google.com/"; +my $url = prompt("# Please enter an URL to fetch",$defurl); +if (!$url) { + print "1..0 # No test URL supplied - skipping test\n"; + exit; +} + +# we need the real printenv cgi for these tests, so skip if +# our test URL is not a printenv variant (or test.cgi from +# mdk apache2). We basically need something which will echo +# back sent headers in the output +# + + +if ($url !~ m/printenv|test.cgi/) { + print "1..0 # need a real 'printenv' cgi script for this test"; + exit; +} +print "1..5\n"; + + +# Init the curl session +my $curl = WWW::Curl::Easy->new(); +if ($curl == 0) { + print "not "; +} +print "ok ".++$count."\n"; + +$curl->setopt(CURLOPT_NOPROGRESS, 1); +$curl->setopt(CURLOPT_FOLLOWLOCATION, 1); +$curl->setopt(CURLOPT_TIMEOUT, 30); + +open HEAD, ">head.out"; +$curl->setopt(CURLOPT_WRITEHEADER, \*HEAD); +print "ok ".++$count."\n"; + + +sub body_callback { + my ($chunk,$handle)=@_; + ${$handle}.=$chunk; + return length($chunk); # OK +} +$curl->setopt(CURLOPT_WRITEFUNCTION, \&body_callback); + +my $body=""; +$curl->setopt(CURLOPT_FILE,\$body); +print "ok ".++$count."\n"; + +$curl->setopt(CURLOPT_URL, $url); + +print "ok ".++$count."\n"; +# Add some additional headers to the http-request: +# Check that the printenv script sends back FOO=bar somewhere +# This checks that all headers were sent. +my @myheaders; +$myheaders[0] = "Baz: xyzzy"; +$myheaders[1] = "Foo: bar"; +$curl->setopt(CURLOPT_HTTPHEADER, \@myheaders); + +# Go get it +my $retcode=$curl->perform(); +if ($retcode == 0) { + if ($body !~ m/FOO\s*=\s*"?bar"?/) { + print "not "; + } +} else { + # We can acces the error message in $errbuf here +# print STDERR "$retcode / ".$curl->errbuf."\n"; + print "not "; +} +print "ok ".++$count."\n"; + +exit; diff --git a/t/18twinhandles.t b/t/18twinhandles.t new file mode 100644 index 0000000..10423d3 --- /dev/null +++ b/t/18twinhandles.t @@ -0,0 +1,52 @@ +#!perl + +use strict; +use warnings; +use Test::More tests => 11; + +BEGIN { use_ok( 'WWW::Curl::Easy' ); } + +my $url = $ENV{CURL_TEST_URL} || "http://www.google.com"; + +my $header_called = 0; +sub header_callback { $header_called++; return length($_[0]) }; + +my $body_called = 0; +sub body_callback { + my ($chunk,$handle)=@_; + $body_called++; + return length($chunk); # OK +} + + +# Init the curl session +my $curl1 = WWW::Curl::Easy->new(); +ok($curl1, 'Curl1 session initialize returns something'); +ok(ref($curl1) eq 'WWW::Curl::Easy', 'Curl1 session looks like an object from the WWW::Curl::Easy module'); + +my $curl2 = WWW::Curl::Easy->new(); +ok($curl2, 'Curl2 session initialize returns something'); +ok(ref($curl2) eq 'WWW::Curl::Easy', 'Curl2 session looks like an object from the WWW::Curl::Easy module'); + +for my $handle ($curl1,$curl2) { + $handle->setopt(CURLOPT_NOPROGRESS, 1); + $handle->setopt(CURLOPT_FOLLOWLOCATION, 1); + $handle->setopt(CURLOPT_TIMEOUT, 30); + + my $body_ref=\&body_callback; + $handle->setopt(CURLOPT_WRITEFUNCTION, $body_ref); + $handle->setopt(CURLOPT_HEADERFUNCTION, \&header_callback); +} + + +ok(! $curl1->setopt(CURLOPT_URL, "error:bad-url"), "Setting deliberately bad url succeeds - should return error on perform"); # deliberate error +ok(! $curl2->setopt(CURLOPT_URL, $url), "Setting OK url"); + +my $code1=$curl1->perform(); +ok($code1 != 0, "Curl1 handle fails as expected"); + +my $code2=$curl2->perform(); +ok($code2 == 0, "Curl2 handle succeeds"); + +ok($header_called, "Header callback works"); +ok($body_called, "Body callback works"); diff --git a/t/meta.t b/t/meta.t new file mode 100644 index 0000000..924aea2 --- /dev/null +++ b/t/meta.t @@ -0,0 +1,4 @@ +use Test::More; +eval "use Test::CPAN::Meta"; +plan skip_all => "Test::CPAN::Meta required for testing META.yml" if $@; +meta_yaml_ok(); diff --git a/t/new/00constants.t b/t/new/00constants.t new file mode 100644 index 0000000..2b41d1e --- /dev/null +++ b/t/new/00constants.t @@ -0,0 +1,5 @@ +use strict; +use Test::Simple tests => 1; +use WWW::Curl::Easy; + +ok( CURLOPT_URL == 10000 + 2 ); diff --git a/t/new/01basic.t b/t/new/01basic.t new file mode 100644 index 0000000..9a96d54 --- /dev/null +++ b/t/new/01basic.t @@ -0,0 +1,13 @@ +use strict; +use Test::More tests => 1; +use WWW::Curl::Easy; + +SKIP: { + skip 'You need to set CURL_TEST_URL', 1 unless $ENV{CURL_TEST_URL}; + my $curl = new WWW::Curl::Easy; + $curl->setopt( CURLOPT_URL, $ENV{CURL_TEST_URL} ); + my @headers = ( 'Server: cURL', 'User-Agent: WWW::Curl/3.00' ); + $curl->setopt( CURLOPT_HTTPHEADER, \@headers ); + my $code = $curl->perform; + ok( $code == 0 ); +} diff --git a/t/new/02header-callback.t b/t/new/02header-callback.t new file mode 100644 index 0000000..497e2dd --- /dev/null +++ b/t/new/02header-callback.t @@ -0,0 +1,20 @@ +use strict; +use Test::More tests => 1; +use WWW::Curl::Easy; + +my $header; + +sub header_callback { + my $chunk = shift; + $header .= $chunk; + return length $chunk; +} + +SKIP: { + skip 'You need to set CURL_TEST_URL', 1 unless $ENV{CURL_TEST_URL}; + my $curl = new WWW::Curl::Easy; + $curl->setopt( CURLOPT_URL, $ENV{CURL_TEST_URL} ); + $curl->setopt( CURLOPT_HEADERFUNCTION, \&header_callback ); + $curl->perform; + ok($header); +} diff --git a/t/new/03body-callback.t b/t/new/03body-callback.t new file mode 100644 index 0000000..c91d585 --- /dev/null +++ b/t/new/03body-callback.t @@ -0,0 +1,20 @@ +use strict; +use Test::More tests => 1; +use WWW::Curl::Easy; + +my $body; + +sub body_callback { + my ( $chunk, $handle ) = @_; + $body .= $chunk; + return length $chunk; +} + +SKIP: { + skip 'You need to set CURL_TEST_URL', 1 unless $ENV{CURL_TEST_URL}; + my $curl = new WWW::Curl::Easy; + $curl->setopt( CURLOPT_URL, $ENV{CURL_TEST_URL} ); + $curl->setopt( CURLOPT_WRITEFUNCTION, \&body_callback ); + $curl->perform; + ok($body); +} diff --git a/t/new/04abort.t b/t/new/04abort.t new file mode 100644 index 0000000..77b21c1 --- /dev/null +++ b/t/new/04abort.t @@ -0,0 +1,17 @@ +use strict; +use Test::More tests => 1; +use WWW::Curl::Easy; + +sub body_callback { + my ( $chunk, $handle ) = @_; + return -1; +} + +SKIP: { + skip 'You need to set CURL_TEST_URL', 1 unless $ENV{CURL_TEST_URL}; + my $curl = new WWW::Curl::Easy; + $curl->setopt( CURLOPT_URL, $ENV{CURL_TEST_URL} ); + $curl->setopt( CURLOPT_WRITEFUNCTION, \&body_callback ); + my $code = $curl->perform; + ok($code); +} diff --git a/t/new/05progress.t b/t/new/05progress.t new file mode 100644 index 0000000..a8f2ceb --- /dev/null +++ b/t/new/05progress.t @@ -0,0 +1,25 @@ +use strict; +use Test::More tests => 3; +use WWW::Curl::Easy; + +my ( $progress, $last ); + +sub progress_callback { + my ( $clientp, $dltotal, $dlnow, $ultotal, $ulnow ) = @_; + $last = $dlnow; + $progress++; + return 0; +} + +SKIP: { + skip 'You need to set CURL_TEST_URL', 3 unless $ENV{CURL_TEST_URL}; + my $curl = new WWW::Curl::Easy; + $curl->setopt( CURLOPT_URL, $ENV{CURL_TEST_URL} ); + $curl->setopt( CURLOPT_NOPROGRESS, 1 ); + $curl->setopt( CURLOPT_NOPROGRESS, 0 ); + $curl->setopt( CURLOPT_PROGRESSFUNCTION, \&progress_callback ); + my $code = $curl->perform; + ok( $code == 0 ); + ok($progress); + ok($last); +} diff --git a/t/new/06http-post.t b/t/new/06http-post.t new file mode 100644 index 0000000..55990f2 --- /dev/null +++ b/t/new/06http-post.t @@ -0,0 +1,26 @@ +use strict; +use Test::More tests => 1; +use WWW::Curl::Easy; + +my $max = 1000; + +sub read_callback { + my ( $maxlen, $sv ) = @_; + + # Create some random data + my $data = chr( ord('A') + rand(26) ) x ( int( $max / 3 ) + 1 ); + $max = $max - length $data; + return $data; +} + +SKIP: { + skip 'You need to set CURL_TEST_URL', 1 unless $ENV{CURL_TEST_URL}; + my $curl = new WWW::Curl::Easy; + $curl->setopt( CURLOPT_URL, $ENV{CURL_TEST_URL} ); + $curl->setopt( CURLOPT_READFUNCTION, \&read_callback ); + $curl->setopt( CURLOPT_INFILESIZE, $max ); + $curl->setopt( CURLOPT_UPLOAD, 1 ); + $curl->setopt( CURLOPT_CUSTOMREQUEST, 'POST' ); + my $code = $curl->perform; + ok( $code == 0 ); +} diff --git a/t/new/07errbuf.t b/t/new/07errbuf.t new file mode 100644 index 0000000..9ecd4f4 --- /dev/null +++ b/t/new/07errbuf.t @@ -0,0 +1,9 @@ +use strict; +use Test::Simple tests => 1; +use WWW::Curl::Easy; + +my $curl = new WWW::Curl::Easy; +$curl->setopt( CURLOPT_URL, 'badprotocol://127.0.0.1:2' ); +$curl->perform; +my $err = $curl->errbuf; +ok($err); diff --git a/t/new/08duphandle.t b/t/new/08duphandle.t new file mode 100644 index 0000000..39381e8 --- /dev/null +++ b/t/new/08duphandle.t @@ -0,0 +1,14 @@ +use strict; +use Test::More tests => 1; +use WWW::Curl::Easy; + +SKIP: { + skip 'You need to set CURL_TEST_URL', 1 unless $ENV{CURL_TEST_URL}; + my $curl = new WWW::Curl::Easy; + $curl->setopt( CURLOPT_URL, $ENV{CURL_TEST_URL} ); + my @headers = ( 'Server: cURL', 'User-Agent: WWW::Curl/3.00' ); + $curl->setopt( CURLOPT_HTTPHEADER, \@headers ); + my $curl2 = $curl->duphandle; + my $code = $curl2->perform; + ok( $code == 0 ); +} diff --git a/t/new/09duphandle-callback.t b/t/new/09duphandle-callback.t new file mode 100644 index 0000000..db7d368 --- /dev/null +++ b/t/new/09duphandle-callback.t @@ -0,0 +1,21 @@ +use strict; +use Test::More tests => 1; +use WWW::Curl::Easy; + +my $body; + +sub body_callback { + my ( $chunk, $handle ) = @_; + $body .= $chunk; + return length $chunk; +} + +SKIP: { + skip 'You need to set CURL_TEST_URL', 1 unless $ENV{CURL_TEST_URL}; + my $curl = new WWW::Curl::Easy; + $curl->setopt( CURLOPT_URL, $ENV{CURL_TEST_URL} ); + $curl->setopt( CURLOPT_WRITEFUNCTION, \&body_callback ); + my $curl2 = $curl->duphandle; + $curl2->perform; + ok($body); +} diff --git a/t/new/10multi-callback.t b/t/new/10multi-callback.t new file mode 100644 index 0000000..ee887ad --- /dev/null +++ b/t/new/10multi-callback.t @@ -0,0 +1,54 @@ +use strict; +use Test::More tests => 4; +use WWW::Curl::Easy; +use WWW::Curl::Multi; + +my ( $header, $body, $header2, $body2 ); + +sub header_callback { + my $chunk = shift; + $header .= $chunk; + return length($chunk); +} + +sub body_callback { + my ( $chunk, $handle ) = @_; + $body .= $chunk; + return length($chunk); +} + +sub header_callback2 { + my $chunk = shift; + $header2 .= $chunk; + return length($chunk); +} + +sub body_callback2 { + my ( $chunk, $handle ) = @_; + $body2 .= $chunk; + return length($chunk); +} + +SKIP: { + skip 'You need to set CURL_TEST_URL', 4 unless $ENV{CURL_TEST_URL}; + + my $curl = new WWW::Curl::Easy; + $curl->setopt( CURLOPT_URL, $ENV{CURL_TEST_URL} ); + $curl->setopt( CURLOPT_HEADERFUNCTION, \&header_callback ); + $curl->setopt( CURLOPT_WRITEFUNCTION, \&body_callback ); + + my $curl2 = new WWW::Curl::Easy; + $curl2->setopt( CURLOPT_URL, $ENV{CURL_TEST_URL} ); + $curl2->setopt( CURLOPT_HEADERFUNCTION, \&header_callback2 ); + $curl2->setopt( CURLOPT_WRITEFUNCTION, \&body_callback2 ); + + my $curlm = new WWW::Curl::Multi; + $curlm->add_handle($curl); + $curlm->add_handle($curl2); + $curlm->perform; + + ok($header); + ok($body); + ok($header2); + ok($body2); +} diff --git a/t/new/README b/t/new/README new file mode 100644 index 0000000..7879eb1 --- /dev/null +++ b/t/new/README @@ -0,0 +1,8 @@ +These test scripts have been updated by Sebastian Riedel to use modern +features of the Test::Harness suite, such as Test::Simple and Test::More, +which makes them cleaner and more maintainable, but which are unfortunately +not natively supported by older perl versions. They are placed here reference, +and will become the standard test scripts once we drop support for perl5.005. + + + diff --git a/t/pod-coverage.t b/t/pod-coverage.t new file mode 100644 index 0000000..d1e1f34 --- /dev/null +++ b/t/pod-coverage.t @@ -0,0 +1,7 @@ +#!perl -T + +use Test::More; +eval "use Test::Pod::Coverage 1.04"; +plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; +plan tests => 1; +pod_coverage_ok('WWW::Curl','WWW::Curl has proper POD coverage'); @@ -0,0 +1,6 @@ +#!perl -T + +use Test::More; +eval "use Test::Pod 1.14"; +plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; +all_pod_files_ok(); diff --git a/template/Easy.pm.tmpl b/template/Easy.pm.tmpl new file mode 100644 index 0000000..04a0b3f --- /dev/null +++ b/template/Easy.pm.tmpl @@ -0,0 +1,46 @@ +package WWW::Curl::Easy; + +use strict; +use warnings; +use Carp; +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD); + +$VERSION = '4.05'; + +require WWW::Curl; +require Exporter; +require AutoLoader; + +@ISA = qw(Exporter DynaLoader); + +# Items to export into callers namespace by default. Note: do not export +# names by default without a very good reason. Use EXPORT_OK instead. +# Do not simply export all your public functions/methods/constants. + +@EXPORT = qw( +@CURLOPT_INCLUDE@ +); + +$WWW::Curl::Easy::headers = ""; +$WWW::Curl::Easy::content = ""; + +sub AUTOLOAD { + + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. + + ( my $constname = $AUTOLOAD ) =~ s/.*:://; + return constant( $constname, 0 ); +} + +1; + +__END__ + +Copyright (C) 2000-2005,2008 Daniel Stenberg, Cris Bailiff, +Sebastian Riedel, et al. + +You may opt to use, copy, modify, merge, publish, distribute and/or sell +copies of the Software, and permit persons to whom the Software is furnished +to do so, under the terms of the MPL or the MIT/X-derivate licenses. You may +pick one of these licenses. diff --git a/template/Share.pm.tmpl b/template/Share.pm.tmpl new file mode 100644 index 0000000..9149217 --- /dev/null +++ b/template/Share.pm.tmpl @@ -0,0 +1,36 @@ +package WWW::Curl::Share; + +use strict; +use warnings; +use Carp; +use vars qw(@ISA @EXPORT @EXPORT_OK $AUTOLOAD); + +use WWW::Curl; +require Exporter; +require AutoLoader; + +@ISA = qw(Exporter DynaLoader); + +@EXPORT = qw( +@CURLSHOPT_INCLUDE@ +); + +sub AUTOLOAD { + + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. + + ( my $constname = $AUTOLOAD ) =~ s/.*:://; + return constant( $constname, 0 ); +} + +1; +__END__ + + +Copyright (C) 2008, Anton Fedorov (datacompboy <at> mail.ru) + +You may opt to use, copy, modify, merge, publish, distribute and/or sell +copies of the Software, and permit persons to whom the Software is furnished +to do so, under the terms of the MPL or the MIT/X-derivate licenses. You may +pick one of these licenses. @@ -0,0 +1,5 @@ +TYPEMAP +WWW::Curl::Easy T_PTROBJ +WWW::Curl::Form T_PTROBJ +WWW::Curl::Multi T_PTROBJ +WWW::Curl::Share T_PTROBJ |