[memcached] bradfitz,
r304: first shot at some poor XS/C code to spe...
commits at code.sixapart.com
commits at code.sixapart.com
Tue Jul 18 04:20:16 UTC 2006
first shot at some poor XS/C code to speed up memcached client side.
A trunk/api/xs/
A trunk/api/xs/Cache-Memcached-GetParserXS/
A trunk/api/xs/Cache-Memcached-GetParserXS/Changes
A trunk/api/xs/Cache-Memcached-GetParserXS/GetParserXS.xs
A trunk/api/xs/Cache-Memcached-GetParserXS/MANIFEST
A trunk/api/xs/Cache-Memcached-GetParserXS/Makefile.PL
A trunk/api/xs/Cache-Memcached-GetParserXS/README
A trunk/api/xs/Cache-Memcached-GetParserXS/const-c.inc
A trunk/api/xs/Cache-Memcached-GetParserXS/const-xs.inc
A trunk/api/xs/Cache-Memcached-GetParserXS/fallback/
A trunk/api/xs/Cache-Memcached-GetParserXS/fallback/const-c.inc
A trunk/api/xs/Cache-Memcached-GetParserXS/fallback/const-xs.inc
A trunk/api/xs/Cache-Memcached-GetParserXS/lib/
A trunk/api/xs/Cache-Memcached-GetParserXS/lib/Cache/
A trunk/api/xs/Cache-Memcached-GetParserXS/lib/Cache/Memcached/
A trunk/api/xs/Cache-Memcached-GetParserXS/lib/Cache/Memcached/GetParserXS.pm
A trunk/api/xs/Cache-Memcached-GetParserXS/ppport.h
A trunk/api/xs/Cache-Memcached-GetParserXS/t/
A trunk/api/xs/Cache-Memcached-GetParserXS/t/Cache-Memcached-GetParserXS.t
Added: trunk/api/xs/Cache-Memcached-GetParserXS/Changes
===================================================================
--- trunk/api/xs/Cache-Memcached-GetParserXS/Changes 2006-07-18 04:16:10 UTC (rev 303)
+++ trunk/api/xs/Cache-Memcached-GetParserXS/Changes 2006-07-18 04:25:43 UTC (rev 304)
@@ -0,0 +1,6 @@
+Revision history for Perl extension Cache::Memcached::GetParserXS.
+
+0.01 Mon Jul 17 22:03:06 2006
+ - original version; created by h2xs 1.23 with options
+ -n Cache::Memcached::GetParserXS
+
Added: trunk/api/xs/Cache-Memcached-GetParserXS/GetParserXS.xs
===================================================================
--- trunk/api/xs/Cache-Memcached-GetParserXS/GetParserXS.xs 2006-07-18 04:16:10 UTC (rev 303)
+++ trunk/api/xs/Cache-Memcached-GetParserXS/GetParserXS.xs 2006-07-18 04:25:43 UTC (rev 304)
@@ -0,0 +1,260 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#include "ppport.h"
+
+#include "const-c.inc"
+
+#define DEST 0 /* destination hashref we're writing into */
+#define NSLEN 1 /* length of namespace to ignore on keys */
+#define ON_ITEM 2
+#define BUF 3 /* read buffer */
+#define STATE 4 /* 0 = waiting for a line, N = reading N bytes */
+#define OFFSET 5 /* offsets to read into buffers */
+#define FLAGS 6
+#define KEY 7 /* current key we're parsing (without the namespace prefix) */
+
+#define DEBUG 0
+
+int get_nslen (AV* self) {
+ SV** svp = av_fetch(self, NSLEN, 0);
+ if (svp)
+ return SvIV((SV*) *svp);
+ return 0;
+}
+
+void set_key (AV* self, const char *key) {
+ av_store(self, KEY, newSVpv(key, strlen(key)));
+}
+
+SV *get_key_sv (AV* self) {
+ SV** svp = av_fetch(self, KEY, 0);
+ if (svp)
+ return (SV*) *svp;
+ return 0;
+}
+
+SV *get_on_item (AV* self) {
+ SV** svp = av_fetch(self, ON_ITEM, 0);
+ if (svp)
+ return (SV*) *svp;
+ return 0;
+}
+
+void set_flags (AV* self, int flags) {
+ av_store(self, FLAGS, newSViv(flags));
+}
+
+void set_offset (AV* self, int offset) {
+ av_store(self, OFFSET, newSViv(offset));
+}
+
+void set_state (AV* self, int state) {
+ av_store(self, STATE, newSViv(state));
+}
+
+HV* get_dest (AV* self) {
+ SV** svp = av_fetch(self, DEST, 0);
+ if (svp)
+ return (HV*) SvRV(*svp);
+ return 0;
+}
+
+int get_state (AV* self) {
+ SV** svp = av_fetch(self, STATE, 0);
+ if (svp)
+ return SvIV((SV*) *svp);
+ return 0;
+}
+
+SV* get_buffer (AV* self) {
+ SV** svp = av_fetch(self, BUF, 0);
+ if (svp)
+ return *svp;
+ return 0;
+}
+
+/* returns an answer, but also unsets ON_ITEM */
+int final_answer (AV* self, int ans) {
+ av_store(self, ON_ITEM, newSV(0));
+ return ans;
+}
+
+int parse_buffer (SV* selfref) {
+ AV* self = (AV*) SvRV(selfref);
+ HV* ret = get_dest(self);
+ SV* bufsv = get_buffer(self);
+ STRLEN len;
+ char* buf;
+ char key[257];
+ unsigned int itemlen;
+ unsigned int flags;
+ int scanned;
+ int nslen = get_nslen(self);
+ SV* on_item = get_on_item(self);
+
+ if (DEBUG)
+ printf("get_buffer (nslen = %d)...\n", nslen);
+
+ while (1) {
+ int rv;
+ buf = SvPV(bufsv, len);
+
+ if (DEBUG)
+ printf(" buf (len=%d) = [%s]\n", len, buf);
+
+ scanned = 0;
+ rv = sscanf(buf, "VALUE %256s %u %u%n", key, &flags, &itemlen, &scanned);
+
+ if (DEBUG)
+ printf("rv=%d, scanned=%d, one=[%d], two=[%d]\n",
+ rv, scanned, buf[scanned], buf[scanned+1]);
+
+ if (rv >= 3 && scanned && buf[scanned] == '\r' && buf[scanned + 1] == '\n') {
+ int p = scanned + 2; /* 2 to skip \r\n */
+ int state = itemlen + 2; /* 2 to include reading final \r\n, a different \r\n */
+ int copy = len - p > state ? state : len - p;
+ char *barekey = key + nslen;
+
+ if (DEBUG)
+ printf("key=[%s], state=%d, copy=%d\n", key, state, copy);
+
+ if (copy) {
+ //SV* newSVpv(const char*, STRLEN);
+ //SV** hv_store(HV*, const char* key, U32 klen, SV* val, U32 hash);
+ /* $ret->{$self->[KEY]} = substr($self->[BUF], $p, $copy) */
+ hv_store(ret, barekey, strlen(barekey), newSVpv(buf + p, copy), 0);
+ buf[p + copy - 1] = '\0';
+
+ if (DEBUG)
+ printf("doing store: len=%d key=[%s] of data [%s]\n",
+ strlen(barekey), barekey,
+ buf + p);
+ }
+
+ /* delete the stuff we used */
+ sv_chop(bufsv, buf + p + copy);
+
+ if (copy == state) {
+ dSP ;
+
+ /* have it all? */
+ ENTER ;
+ SAVETMPS ;
+ PUSHMARK(SP) ;
+ XPUSHs(sv_2mortal(newSVpv(barekey, strlen(barekey))));
+ XPUSHs(sv_2mortal(newSViv(flags)));
+ PUTBACK ;
+ call_sv(on_item, G_VOID | G_DISCARD);
+ FREETMPS ;
+ LEAVE ;
+
+ set_offset(self, 0);
+ set_state(self, 0);
+ continue;
+ } else {
+ /* don't have it all... but buffer is now empty */
+ set_offset(self, copy);
+ set_flags(self, flags);
+ set_key(self, barekey);
+ set_state(self, state);
+
+ if (DEBUG)
+ printf("don't have it all.... have '%d' of '%d'\n",
+ copy, state);
+ return 0; /* return saying '0', not done */
+ }
+ }
+
+ if (strncmp(buf, "END\r\n", 5) == 0) {
+ /* we're done successfully, return 1 to finish */
+ return final_answer(self, 1);
+ }
+
+
+ /* # if we're here probably means we only have a partial VALUE
+ # or END line in the buffer. Could happen with multi-get,
+ # though probably very rarely. Exit the loop and let it read
+ # more.
+
+ # but first, make sure subsequent reads don't destroy our
+ # partial VALUE/END line.
+ */
+
+ set_offset(self, len);
+ return 0;
+ }
+}
+
+int parse_from_sock_xx (SV* selfref, SV* sock, int sockfd) {
+ int res;
+ AV* self = (AV*) SvRV(selfref);
+ HV* ret = get_dest(self);
+ int state = get_state(self);
+
+ if (state) {
+ //res = read(sockfd, *buf, state);
+ }
+
+ printf("fileno = %d\n", sockfd);
+
+ printf("got = %x, state = %d\n", ret, state);
+ return -1;
+
+ /*
+ # where are we reading into?
+ if ($self->[STATE]) { # reading value into $ret
+ $res = sysread($sock, $ret->{$self->[KEY]},
+ $self->[STATE] - $self->[OFFSET],
+ $self->[OFFSET]);
+
+ return 0
+ if !defined($res) and $!==EWOULDBLOCK;
+
+ if ($res == 0) { # catches 0=conn closed or undef=error
+ $self->[ON_ITEM] = undef;
+ return -1;
+ }
+
+ $self->[OFFSET] += $res;
+ if ($self->[OFFSET] == $self->[STATE]) { # finished reading
+ $self->[ON_ITEM]->($self->[KEY], $self->[FLAGS]);
+ $self->[OFFSET] = 0;
+ $self->[STATE] = 0;
+ # wait for another VALUE line or END...
+ }
+ return 0; # still working, haven't got to end yet
+ }
+
+ # we're reading a single line.
+ # first, read whatever's there, but be satisfied with 2048 bytes
+ $res = sysread($sock, $self->[BUF],
+ 2048, $self->[OFFSET]);
+ return 0
+ if !defined($res) and $!==EWOULDBLOCK;
+ if ($res == 0) {
+ $self->[ON_ITEM] = undef;
+ return -1;
+ }
+
+ $self->[OFFSET] += $res;
+
+ */
+}
+
+MODULE = Cache::Memcached::GetParserXS PACKAGE = Cache::Memcached::GetParserXS
+
+INCLUDE: const-xs.inc
+
+int
+parse_from_sock_xx ( self, sock, sockfd )
+ SV *self
+ SV *sock
+ int sockfd
+
+int
+parse_buffer ( self )
+ SV *self
+
+
Added: trunk/api/xs/Cache-Memcached-GetParserXS/MANIFEST
===================================================================
--- trunk/api/xs/Cache-Memcached-GetParserXS/MANIFEST 2006-07-18 04:16:10 UTC (rev 303)
+++ trunk/api/xs/Cache-Memcached-GetParserXS/MANIFEST 2006-07-18 04:25:43 UTC (rev 304)
@@ -0,0 +1,10 @@
+Changes
+GetParserXS.xs
+Makefile.PL
+MANIFEST
+ppport.h
+README
+t/Cache-Memcached-GetParserXS.t
+fallback/const-c.inc
+fallback/const-xs.inc
+lib/Cache/Memcached/GetParserXS.pm
Added: trunk/api/xs/Cache-Memcached-GetParserXS/Makefile.PL
===================================================================
--- trunk/api/xs/Cache-Memcached-GetParserXS/Makefile.PL 2006-07-18 04:16:10 UTC (rev 303)
+++ trunk/api/xs/Cache-Memcached-GetParserXS/Makefile.PL 2006-07-18 04:25:43 UTC (rev 304)
@@ -0,0 +1,41 @@
+use 5.008004;
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+ OPTIMIZE => '-g',
+ NAME => 'Cache::Memcached::GetParserXS',
+ VERSION_FROM => 'lib/Cache/Memcached/GetParserXS.pm', # finds $VERSION
+ PREREQ_PM => {}, # e.g., Module::Name => 1.1
+ ($] >= 5.005 ? ## Add these new keywords supported since 5.005
+ (ABSTRACT_FROM => 'lib/Cache/Memcached/GetParserXS.pm', # retrieve abstract from module
+ AUTHOR => 'LiveJournal user <lj@>') : ()),
+ LIBS => [''], # e.g., '-lm'
+ DEFINE => '', # e.g., '-DHAVE_SOMETHING'
+ INC => '-I.', # e.g., '-I. -I/usr/include/other'
+ # Un-comment this if you add C files to link with later:
+ # OBJECT => '$(O_FILES)', # link all the C files too
+);
+if (eval {require ExtUtils::Constant; 1}) {
+ # If you edit these definitions to change the constants used by this module,
+ # you will need to use the generated const-c.inc and const-xs.inc
+ # files to replace their "fallback" counterparts before distributing your
+ # changes.
+ my @names = (qw());
+ ExtUtils::Constant::WriteConstants(
+ NAME => 'Cache::Memcached::GetParserXS',
+ NAMES => \@names,
+ DEFAULT_TYPE => 'IV',
+ C_FILE => 'const-c.inc',
+ XS_FILE => 'const-xs.inc',
+ );
+
+}
+else {
+ use File::Copy;
+ use File::Spec;
+ foreach my $file ('const-c.inc', 'const-xs.inc') {
+ my $fallback = File::Spec->catfile('fallback', $file);
+ copy ($fallback, $file) or die "Can't copy $fallback to $file: $!";
+ }
+}
Added: trunk/api/xs/Cache-Memcached-GetParserXS/README
===================================================================
--- trunk/api/xs/Cache-Memcached-GetParserXS/README 2006-07-18 04:16:10 UTC (rev 303)
+++ trunk/api/xs/Cache-Memcached-GetParserXS/README 2006-07-18 04:25:43 UTC (rev 304)
@@ -0,0 +1,40 @@
+Cache-Memcached-GetParserXS version 0.01
+========================================
+
+The README is used to introduce the module and provide instructions on
+how to install the module, any machine dependencies it may have (for
+example C compilers and installed libraries) and any other information
+that should be provided before the module is installed.
+
+A README file is required for CPAN modules since CPAN extracts the
+README file from a module distribution so that people browsing the
+archive can use it get an idea of the modules uses. It is usually a
+good idea to provide version information here so that people can
+decide whether fixes for the module are worth downloading.
+
+INSTALLATION
+
+To install this module type the following:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+DEPENDENCIES
+
+This module requires these other modules and libraries:
+
+ blah blah blah
+
+COPYRIGHT AND LICENCE
+
+Put the correct copyright and licence information here.
+
+Copyright (C) 2006 by LiveJournal user
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.8.4 or,
+at your option, any later version of Perl 5 you may have available.
+
+
Added: trunk/api/xs/Cache-Memcached-GetParserXS/const-c.inc
===================================================================
--- trunk/api/xs/Cache-Memcached-GetParserXS/const-c.inc 2006-07-18 04:16:10 UTC (rev 303)
+++ trunk/api/xs/Cache-Memcached-GetParserXS/const-c.inc 2006-07-18 04:25:43 UTC (rev 304)
@@ -0,0 +1,55 @@
+#define PERL_constant_NOTFOUND 1
+#define PERL_constant_NOTDEF 2
+#define PERL_constant_ISIV 3
+#define PERL_constant_ISNO 4
+#define PERL_constant_ISNV 5
+#define PERL_constant_ISPV 6
+#define PERL_constant_ISPVN 7
+#define PERL_constant_ISSV 8
+#define PERL_constant_ISUNDEF 9
+#define PERL_constant_ISUV 10
+#define PERL_constant_ISYES 11
+
+#ifndef NVTYPE
+typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */
+#endif
+#ifndef aTHX_
+#define aTHX_ /* 5.6 or later define this for threading support. */
+#endif
+#ifndef pTHX_
+#define pTHX_ /* 5.6 or later define this for threading support. */
+#endif
+
+static int
+constant (pTHX_ const char *name, STRLEN len) {
+ /* Initially switch on the length of the name. */
+ /* When generated this function returned values for the list of names given
+ in this section of perl code. Rather than manually editing these functions
+ to add or remove constants, which would result in this comment and section
+ of code becoming inaccurate, we recommend that you edit this section of
+ code, and use it to regenerate a new set of constant functions which you
+ then use to replace the originals.
+
+ Regenerate these constant functions by feeding this entire source file to
+ perl -x
+
+#!/usr/bin/perl -w
+use ExtUtils::Constant qw (constant_types C_constant XS_constant);
+
+my $types = {map {($_, 1)} qw()};
+my @names = (qw());
+
+print constant_types(); # macro defs
+foreach (C_constant ("Cache::Memcached::GetParserXS", 'constant', 'IV', $types, undef, 3, @names) ) {
+ print $_, "\n"; # C constant subs
+}
+print "#### XS Section:\n";
+print XS_constant ("Cache::Memcached::GetParserXS", $types);
+__END__
+ */
+
+ switch (len) {
+ }
+ return PERL_constant_NOTFOUND;
+}
+
Added: trunk/api/xs/Cache-Memcached-GetParserXS/const-xs.inc
===================================================================
--- trunk/api/xs/Cache-Memcached-GetParserXS/const-xs.inc 2006-07-18 04:16:10 UTC (rev 303)
+++ trunk/api/xs/Cache-Memcached-GetParserXS/const-xs.inc 2006-07-18 04:25:43 UTC (rev 304)
@@ -0,0 +1,87 @@
+void
+constant(sv)
+ PREINIT:
+#ifdef dXSTARG
+ dXSTARG; /* Faster if we have it. */
+#else
+ dTARGET;
+#endif
+ STRLEN len;
+ int type;
+ /* IV iv; Uncomment this if you need to return IVs */
+ /* NV nv; Uncomment this if you need to return NVs */
+ /* const char *pv; Uncomment this if you need to return PVs */
+ INPUT:
+ SV * sv;
+ const char * s = SvPV(sv, len);
+ PPCODE:
+ type = constant(aTHX_ s, len);
+ /* Return 1 or 2 items. First is error message, or undef if no error.
+ Second, if present, is found value */
+ switch (type) {
+ case PERL_constant_NOTFOUND:
+ sv = sv_2mortal(newSVpvf("%s is not a valid Cache::Memcached::GetParserXS macro", s));
+ PUSHs(sv);
+ break;
+ case PERL_constant_NOTDEF:
+ sv = sv_2mortal(newSVpvf(
+ "Your vendor has not defined Cache::Memcached::GetParserXS macro %s, used", s));
+ PUSHs(sv);
+ break;
+ /* Uncomment this if you need to return IVs
+ case PERL_constant_ISIV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHi(iv);
+ break; */
+ /* Uncomment this if you need to return NOs
+ case PERL_constant_ISNO:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(&PL_sv_no);
+ break; */
+ /* Uncomment this if you need to return NVs
+ case PERL_constant_ISNV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHn(nv);
+ break; */
+ /* Uncomment this if you need to return PVs
+ case PERL_constant_ISPV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHp(pv, strlen(pv));
+ break; */
+ /* Uncomment this if you need to return PVNs
+ case PERL_constant_ISPVN:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHp(pv, iv);
+ break; */
+ /* Uncomment this if you need to return SVs
+ case PERL_constant_ISSV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(sv);
+ break; */
+ /* Uncomment this if you need to return UNDEFs
+ case PERL_constant_ISUNDEF:
+ break; */
+ /* Uncomment this if you need to return UVs
+ case PERL_constant_ISUV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHu((UV)iv);
+ break; */
+ /* Uncomment this if you need to return YESs
+ case PERL_constant_ISYES:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(&PL_sv_yes);
+ break; */
+ default:
+ sv = sv_2mortal(newSVpvf(
+ "Unexpected return type %d while processing Cache::Memcached::GetParserXS macro %s, used",
+ type, s));
+ PUSHs(sv);
+ }
Added: trunk/api/xs/Cache-Memcached-GetParserXS/fallback/const-c.inc
===================================================================
--- trunk/api/xs/Cache-Memcached-GetParserXS/fallback/const-c.inc 2006-07-18 04:16:10 UTC (rev 303)
+++ trunk/api/xs/Cache-Memcached-GetParserXS/fallback/const-c.inc 2006-07-18 04:25:43 UTC (rev 304)
@@ -0,0 +1,55 @@
+#define PERL_constant_NOTFOUND 1
+#define PERL_constant_NOTDEF 2
+#define PERL_constant_ISIV 3
+#define PERL_constant_ISNO 4
+#define PERL_constant_ISNV 5
+#define PERL_constant_ISPV 6
+#define PERL_constant_ISPVN 7
+#define PERL_constant_ISSV 8
+#define PERL_constant_ISUNDEF 9
+#define PERL_constant_ISUV 10
+#define PERL_constant_ISYES 11
+
+#ifndef NVTYPE
+typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */
+#endif
+#ifndef aTHX_
+#define aTHX_ /* 5.6 or later define this for threading support. */
+#endif
+#ifndef pTHX_
+#define pTHX_ /* 5.6 or later define this for threading support. */
+#endif
+
+static int
+constant (pTHX_ const char *name, STRLEN len) {
+ /* Initially switch on the length of the name. */
+ /* When generated this function returned values for the list of names given
+ in this section of perl code. Rather than manually editing these functions
+ to add or remove constants, which would result in this comment and section
+ of code becoming inaccurate, we recommend that you edit this section of
+ code, and use it to regenerate a new set of constant functions which you
+ then use to replace the originals.
+
+ Regenerate these constant functions by feeding this entire source file to
+ perl -x
+
+#!/usr/bin/perl -w
+use ExtUtils::Constant qw (constant_types C_constant XS_constant);
+
+my $types = {map {($_, 1)} qw()};
+my @names = (qw());
+
+print constant_types(); # macro defs
+foreach (C_constant ("Cache::Memcached::GetParserXS", 'constant', 'IV', $types, undef, 3, @names) ) {
+ print $_, "\n"; # C constant subs
+}
+print "#### XS Section:\n";
+print XS_constant ("Cache::Memcached::GetParserXS", $types);
+__END__
+ */
+
+ switch (len) {
+ }
+ return PERL_constant_NOTFOUND;
+}
+
Added: trunk/api/xs/Cache-Memcached-GetParserXS/fallback/const-xs.inc
===================================================================
--- trunk/api/xs/Cache-Memcached-GetParserXS/fallback/const-xs.inc 2006-07-18 04:16:10 UTC (rev 303)
+++ trunk/api/xs/Cache-Memcached-GetParserXS/fallback/const-xs.inc 2006-07-18 04:25:43 UTC (rev 304)
@@ -0,0 +1,87 @@
+void
+constant(sv)
+ PREINIT:
+#ifdef dXSTARG
+ dXSTARG; /* Faster if we have it. */
+#else
+ dTARGET;
+#endif
+ STRLEN len;
+ int type;
+ /* IV iv; Uncomment this if you need to return IVs */
+ /* NV nv; Uncomment this if you need to return NVs */
+ /* const char *pv; Uncomment this if you need to return PVs */
+ INPUT:
+ SV * sv;
+ const char * s = SvPV(sv, len);
+ PPCODE:
+ type = constant(aTHX_ s, len);
+ /* Return 1 or 2 items. First is error message, or undef if no error.
+ Second, if present, is found value */
+ switch (type) {
+ case PERL_constant_NOTFOUND:
+ sv = sv_2mortal(newSVpvf("%s is not a valid Cache::Memcached::GetParserXS macro", s));
+ PUSHs(sv);
+ break;
+ case PERL_constant_NOTDEF:
+ sv = sv_2mortal(newSVpvf(
+ "Your vendor has not defined Cache::Memcached::GetParserXS macro %s, used", s));
+ PUSHs(sv);
+ break;
+ /* Uncomment this if you need to return IVs
+ case PERL_constant_ISIV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHi(iv);
+ break; */
+ /* Uncomment this if you need to return NOs
+ case PERL_constant_ISNO:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(&PL_sv_no);
+ break; */
+ /* Uncomment this if you need to return NVs
+ case PERL_constant_ISNV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHn(nv);
+ break; */
+ /* Uncomment this if you need to return PVs
+ case PERL_constant_ISPV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHp(pv, strlen(pv));
+ break; */
+ /* Uncomment this if you need to return PVNs
+ case PERL_constant_ISPVN:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHp(pv, iv);
+ break; */
+ /* Uncomment this if you need to return SVs
+ case PERL_constant_ISSV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(sv);
+ break; */
+ /* Uncomment this if you need to return UNDEFs
+ case PERL_constant_ISUNDEF:
+ break; */
+ /* Uncomment this if you need to return UVs
+ case PERL_constant_ISUV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHu((UV)iv);
+ break; */
+ /* Uncomment this if you need to return YESs
+ case PERL_constant_ISYES:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(&PL_sv_yes);
+ break; */
+ default:
+ sv = sv_2mortal(newSVpvf(
+ "Unexpected return type %d while processing Cache::Memcached::GetParserXS macro %s, used",
+ type, s));
+ PUSHs(sv);
+ }
Added: trunk/api/xs/Cache-Memcached-GetParserXS/lib/Cache/Memcached/GetParserXS.pm
===================================================================
--- trunk/api/xs/Cache-Memcached-GetParserXS/lib/Cache/Memcached/GetParserXS.pm 2006-07-18 04:16:10 UTC (rev 303)
+++ trunk/api/xs/Cache-Memcached-GetParserXS/lib/Cache/Memcached/GetParserXS.pm 2006-07-18 04:25:43 UTC (rev 304)
@@ -0,0 +1,113 @@
+package Cache::Memcached::GetParserXS;
+
+use 5.006;
+use strict;
+use warnings;
+use Carp;
+
+require Exporter;
+use AutoLoader;
+
+our @ISA = qw(Exporter Cache::Memcached::GetParser);
+
+# 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.
+
+# This allows declaration use Cache::Memcached::GetParserXS ':all';
+# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
+# will save memory.
+our %EXPORT_TAGS = ( 'all' => [ qw(
+
+) ] );
+
+our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
+
+our @EXPORT = qw(
+
+);
+
+our $VERSION = '0.01';
+
+sub AUTOLOAD {
+ # This AUTOLOAD is used to 'autoload' constants from the constant()
+ # XS function.
+
+ my $constname;
+ our $AUTOLOAD;
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ croak "&Cache::Memcached::GetParserXS::constant not defined" if $constname eq 'constant';
+ my ($error, $val) = constant($constname);
+ if ($error) { croak $error; }
+ {
+ no strict 'refs';
+ # Fixed between 5.005_53 and 5.005_61
+#XXX if ($] >= 5.00561) {
+#XXX *$AUTOLOAD = sub () { $val };
+#XXX }
+#XXX else {
+ *$AUTOLOAD = sub { $val };
+#XXX }
+ }
+ goto &$AUTOLOAD;
+}
+
+require XSLoader;
+XSLoader::load('Cache::Memcached::GetParserXS', $VERSION);
+
+# Preloaded methods go here.
+
+# Autoload methods go after =cut, and are processed by the autosplit program.
+
+1;
+__END__
+# Below is stub documentation for your module. You'd better edit it!
+
+=head1 NAME
+
+Cache::Memcached::GetParserXS - Perl extension for blah blah blah
+
+=head1 SYNOPSIS
+
+ use Cache::Memcached::GetParserXS;
+ blah blah blah
+
+=head1 DESCRIPTION
+
+Stub documentation for Cache::Memcached::GetParserXS, created by h2xs. It looks like the
+author of the extension was negligent enough to leave the stub
+unedited.
+
+Blah blah blah.
+
+=head2 EXPORT
+
+None by default.
+
+
+
+=head1 SEE ALSO
+
+Mention other useful documentation such as the documentation of
+related modules or operating system documentation (such as man pages
+in UNIX), or any relevant external documentation such as RFCs or
+standards.
+
+If you have a mailing list set up for your module, mention it here.
+
+If you have a web site set up for your module, mention it here.
+
+=head1 AUTHOR
+
+LiveJournal user, E<lt>lj at E<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2006 by LiveJournal user
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.8.4 or,
+at your option, any later version of Perl 5 you may have available.
+
+
+=cut
Added: trunk/api/xs/Cache-Memcached-GetParserXS/ppport.h
===================================================================
--- trunk/api/xs/Cache-Memcached-GetParserXS/ppport.h 2006-07-18 04:16:10 UTC (rev 303)
+++ trunk/api/xs/Cache-Memcached-GetParserXS/ppport.h 2006-07-18 04:25:43 UTC (rev 304)
@@ -0,0 +1,1102 @@
+
+/* ppport.h -- Perl/Pollution/Portability Version 2.011
+ *
+ * Automatically Created by Devel::PPPort on Mon Jul 17 22:03:06 2006
+ *
+ * Do NOT edit this file directly! -- Edit PPPort.pm instead.
+ *
+ * Version 2.x, Copyright (C) 2001, Paul Marquess.
+ * Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
+ * This code may be used and distributed under the same license as any
+ * version of Perl.
+ *
+ * This version of ppport.h is designed to support operation with Perl
+ * installations back to 5.004, and has been tested up to 5.8.1.
+ *
+ * If this version of ppport.h is failing during the compilation of this
+ * module, please check if a newer version of Devel::PPPort is available
+ * on CPAN before sending a bug report.
+ *
+ * If you are using the latest version of Devel::PPPort and it is failing
+ * during compilation of this module, please send a report to perlbug at perl.com
+ *
+ * Include all following information:
+ *
+ * 1. The complete output from running "perl -V"
+ *
+ * 2. This file.
+ *
+ * 3. The name & version of the module you were trying to build.
+ *
+ * 4. A full log of the build that failed.
+ *
+ * 5. Any other information that you think could be relevant.
+ *
+ *
+ * For the latest version of this code, please retreive the Devel::PPPort
+ * module from CPAN.
+ *
+ */
+
+/*
+ * In order for a Perl extension module to be as portable as possible
+ * across differing versions of Perl itself, certain steps need to be taken.
+ * Including this header is the first major one, then using dTHR is all the
+ * appropriate places and using a PL_ prefix to refer to global Perl
+ * variables is the second.
+ *
+ */
+
+
+/* If you use one of a few functions that were not present in earlier
+ * versions of Perl, please add a define before the inclusion of ppport.h
+ * for a static include, or use the GLOBAL request in a single module to
+ * produce a global definition that can be referenced from the other
+ * modules.
+ *
+ * Function: Static define: Extern define:
+ * newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL
+ *
+ */
+
+
+/* To verify whether ppport.h is needed for your module, and whether any
+ * special defines should be used, ppport.h can be run through Perl to check
+ * your source code. Simply say:
+ *
+ * perl -x ppport.h *.c *.h *.xs foo/bar*.c [etc]
+ *
+ * The result will be a list of patches suggesting changes that should at
+ * least be acceptable, if not necessarily the most efficient solution, or a
+ * fix for all possible problems. It won't catch where dTHR is needed, and
+ * doesn't attempt to account for global macro or function definitions,
+ * nested includes, typemaps, etc.
+ *
+ * In order to test for the need of dTHR, please try your module under a
+ * recent version of Perl that has threading compiled-in.
+ *
+ */
+
+
+/*
+#!/usr/bin/perl
+ at ARGV = ("*.xs") if !@ARGV;
+%badmacros = %funcs = %macros = (); $replace = 0;
+foreach (<DATA>) {
+ $funcs{$1} = 1 if /Provide:\s+(\S+)/;
+ $macros{$1} = 1 if /^#\s*define\s+([a-zA-Z0-9_]+)/;
+ $replace = $1 if /Replace:\s+(\d+)/;
+ $badmacros{$2}=$1 if $replace and /^#\s*define\s+([a-zA-Z0-9_]+).*?\s+([a-zA-Z0-9_]+)/;
+ $badmacros{$1}=$2 if /Replace (\S+) with (\S+)/;
+}
+foreach $filename (map(glob($_), at ARGV)) {
+ unless (open(IN, "<$filename")) {
+ warn "Unable to read from $file: $!\n";
+ next;
+ }
+ print "Scanning $filename...\n";
+ $c = ""; while (<IN>) { $c .= $_; } close(IN);
+ $need_include = 0; %add_func = (); $changes = 0;
+ $has_include = ($c =~ /#.*include.*ppport/m);
+
+ foreach $func (keys %funcs) {
+ if ($c =~ /#.*define.*\bNEED_$func(_GLOBAL)?\b/m) {
+ if ($c !~ /\b$func\b/m) {
+ print "If $func isn't needed, you don't need to request it.\n" if
+ $changes += ($c =~ s/^.*#.*define.*\bNEED_$func\b.*\n//m);
+ } else {
+ print "Uses $func\n";
+ $need_include = 1;
+ }
+ } else {
+ if ($c =~ /\b$func\b/m) {
+ $add_func{$func} =1 ;
+ print "Uses $func\n";
+ $need_include = 1;
+ }
+ }
+ }
+
+ if (not $need_include) {
+ foreach $macro (keys %macros) {
+ if ($c =~ /\b$macro\b/m) {
+ print "Uses $macro\n";
+ $need_include = 1;
+ }
+ }
+ }
+
+ foreach $badmacro (keys %badmacros) {
+ if ($c =~ /\b$badmacro\b/m) {
+ $changes += ($c =~ s/\b$badmacro\b/$badmacros{$badmacro}/gm);
+ print "Uses $badmacros{$badmacro} (instead of $badmacro)\n";
+ $need_include = 1;
+ }
+ }
+
+ if (scalar(keys %add_func) or $need_include != $has_include) {
+ if (!$has_include) {
+ $inc = join('',map("#define NEED_$_\n", sort keys %add_func)).
+ "#include \"ppport.h\"\n";
+ $c = "$inc$c" unless $c =~ s/#.*include.*XSUB.*\n/$&$inc/m;
+ } elsif (keys %add_func) {
+ $inc = join('',map("#define NEED_$_\n", sort keys %add_func));
+ $c = "$inc$c" unless $c =~ s/^.*#.*include.*ppport.*$/$inc$&/m;
+ }
+ if (!$need_include) {
+ print "Doesn't seem to need ppport.h.\n";
+ $c =~ s/^.*#.*include.*ppport.*\n//m;
+ }
+ $changes++;
+ }
+
+ if ($changes) {
+ require POSIX; use Fcntl;
+ for(;;) {
+ $tmp = POSIX::tmpnam();
+ sysopen(OUT, $tmp, O_CREAT|O_WRONLY|O_EXCL, 0700) && last;
+ }
+
+ print OUT $c;
+ close(OUT);
+
+ open(DIFF, "diff -u $filename $tmp|");
+ while (<DIFF>) { s!$tmp!$filename.patched!; print STDOUT; }
+ close(DIFF);
+ unlink($tmp);
+ } else {
+ print "Looks OK\n";
+ }
+}
+__DATA__
+*/
+
+#ifndef _P_P_PORTABILITY_H_
+#define _P_P_PORTABILITY_H_
+
+#ifndef PERL_REVISION
+# ifndef __PATCHLEVEL_H_INCLUDED__
+# define PERL_PATCHLEVEL_H_IMPLICIT
+# include <patchlevel.h>
+# endif
+# if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL)))
+# include <could_not_find_Perl_patchlevel.h>
+# endif
+# ifndef PERL_REVISION
+# define PERL_REVISION (5)
+ /* Replace: 1 */
+# define PERL_VERSION PATCHLEVEL
+# define PERL_SUBVERSION SUBVERSION
+ /* Replace PERL_PATCHLEVEL with PERL_VERSION */
+ /* Replace: 0 */
+# endif
+#endif
+
+#define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION)
+
+/* It is very unlikely that anyone will try to use this with Perl 6
+ (or greater), but who knows.
+ */
+#if PERL_REVISION != 5
+# error ppport.h only works with Perl version 5
+#endif /* PERL_REVISION != 5 */
+
+#ifndef ERRSV
+# define ERRSV perl_get_sv("@",FALSE)
+#endif
+
+#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5))
+/* Replace: 1 */
+# define PL_Sv Sv
+# define PL_compiling compiling
+# define PL_copline copline
+# define PL_curcop curcop
+# define PL_curstash curstash
+# define PL_defgv defgv
+# define PL_dirty dirty
+# define PL_dowarn dowarn
+# define PL_hints hints
+# define PL_na na
+# define PL_perldb perldb
+# define PL_rsfp_filters rsfp_filters
+# define PL_rsfpv rsfp
+# define PL_stdingv stdingv
+# define PL_sv_no sv_no
+# define PL_sv_undef sv_undef
+# define PL_sv_yes sv_yes
+/* Replace: 0 */
+#endif
+
+#ifdef HASATTRIBUTE
+# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
+# define PERL_UNUSED_DECL
+# else
+# define PERL_UNUSED_DECL __attribute__((unused))
+# endif
+#else
+# define PERL_UNUSED_DECL
+#endif
+
+#ifndef dNOOP
+# define NOOP (void)0
+# define dNOOP extern int Perl___notused PERL_UNUSED_DECL
+#endif
+
+#ifndef dTHR
+# define dTHR dNOOP
+#endif
+
+#ifndef dTHX
+# define dTHX dNOOP
+# define dTHXa(x) dNOOP
+# define dTHXoa(x) dNOOP
+#endif
+
+#ifndef pTHX
+# define pTHX void
+# define pTHX_
+# define aTHX
+# define aTHX_
+#endif
+
+#ifndef dAX
+# define dAX I32 ax = MARK - PL_stack_base + 1
+#endif
+#ifndef dITEMS
+# define dITEMS I32 items = SP - MARK
+#endif
+
+/* IV could also be a quad (say, a long long), but Perls
+ * capable of those should have IVSIZE already. */
+#if !defined(IVSIZE) && defined(LONGSIZE)
+# define IVSIZE LONGSIZE
+#endif
+#ifndef IVSIZE
+# define IVSIZE 4 /* A bold guess, but the best we can make. */
+#endif
+
+#ifndef UVSIZE
+# define UVSIZE IVSIZE
+#endif
+
+#ifndef NVTYPE
+# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
+# define NVTYPE long double
+# else
+# define NVTYPE double
+# endif
+typedef NVTYPE NV;
+#endif
+
+#ifndef INT2PTR
+
+#if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
+# define PTRV UV
+# define INT2PTR(any,d) (any)(d)
+#else
+# if PTRSIZE == LONGSIZE
+# define PTRV unsigned long
+# else
+# define PTRV unsigned
+# endif
+# define INT2PTR(any,d) (any)(PTRV)(d)
+#endif
+#define NUM2PTR(any,d) (any)(PTRV)(d)
+#define PTR2IV(p) INT2PTR(IV,p)
+#define PTR2UV(p) INT2PTR(UV,p)
+#define PTR2NV(p) NUM2PTR(NV,p)
+#if PTRSIZE == LONGSIZE
+# define PTR2ul(p) (unsigned long)(p)
+#else
+# define PTR2ul(p) INT2PTR(unsigned long,p)
+#endif
+
+#endif /* !INT2PTR */
+
+#ifndef boolSV
+# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
+#endif
+
+#ifndef gv_stashpvn
+# define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
+#endif
+
+#ifndef newSVpvn
+# define newSVpvn(data,len) ((len) ? newSVpv ((data), (len)) : newSVpv ("", 0))
+#endif
+
+#ifndef newRV_inc
+/* Replace: 1 */
+# define newRV_inc(sv) newRV(sv)
+/* Replace: 0 */
+#endif
+
+/* DEFSV appears first in 5.004_56 */
+#ifndef DEFSV
+# define DEFSV GvSV(PL_defgv)
+#endif
+
+#ifndef SAVE_DEFSV
+# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
+#endif
+
+#ifndef newRV_noinc
+# ifdef __GNUC__
+# define newRV_noinc(sv) \
+ ({ \
+ SV *nsv = (SV*)newRV(sv); \
+ SvREFCNT_dec(sv); \
+ nsv; \
+ })
+# else
+# if defined(USE_THREADS)
+static SV * newRV_noinc (SV * sv)
+{
+ SV *nsv = (SV*)newRV(sv);
+ SvREFCNT_dec(sv);
+ return nsv;
+}
+# else
+# define newRV_noinc(sv) \
+ (PL_Sv=(SV*)newRV(sv), SvREFCNT_dec(sv), (SV*)PL_Sv)
+# endif
+# endif
+#endif
+
+/* Provide: newCONSTSUB */
+
+/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
+#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))
+
+#if defined(NEED_newCONSTSUB)
+static
+#else
+extern void newCONSTSUB(HV * stash, char * name, SV *sv);
+#endif
+
+#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
+void
+newCONSTSUB(stash,name,sv)
+HV *stash;
+char *name;
+SV *sv;
+{
+ U32 oldhints = PL_hints;
+ HV *old_cop_stash = PL_curcop->cop_stash;
+ HV *old_curstash = PL_curstash;
+ line_t oldline = PL_curcop->cop_line;
+ PL_curcop->cop_line = PL_copline;
+
+ PL_hints &= ~HINT_BLOCK_SCOPE;
+ if (stash)
+ PL_curstash = PL_curcop->cop_stash = stash;
+
+ newSUB(
+
+#if (PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22))
+ /* before 5.003_22 */
+ start_subparse(),
+#else
+# if (PERL_VERSION == 3) && (PERL_SUBVERSION == 22)
+ /* 5.003_22 */
+ start_subparse(0),
+# else
+ /* 5.003_23 onwards */
+ start_subparse(FALSE, 0),
+# endif
+#endif
+
+ newSVOP(OP_CONST, 0, newSVpv(name,0)),
+ newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
+ newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
+ );
+
+ PL_hints = oldhints;
+ PL_curcop->cop_stash = old_cop_stash;
+ PL_curstash = old_curstash;
+ PL_curcop->cop_line = oldline;
+}
+#endif
+
+#endif /* newCONSTSUB */
+
+#ifndef START_MY_CXT
+
+/*
+ * Boilerplate macros for initializing and accessing interpreter-local
+ * data from C. All statics in extensions should be reworked to use
+ * this, if you want to make the extension thread-safe. See ext/re/re.xs
+ * for an example of the use of these macros.
+ *
+ * Code that uses these macros is responsible for the following:
+ * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts"
+ * 2. Declare a typedef named my_cxt_t that is a structure that contains
+ * all the data that needs to be interpreter-local.
+ * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
+ * 4. Use the MY_CXT_INIT macro such that it is called exactly once
+ * (typically put in the BOOT: section).
+ * 5. Use the members of the my_cxt_t structure everywhere as
+ * MY_CXT.member.
+ * 6. Use the dMY_CXT macro (a declaration) in all the functions that
+ * access MY_CXT.
+ */
+
+#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \
+ defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT)
+
+/* This must appear in all extensions that define a my_cxt_t structure,
+ * right after the definition (i.e. at file scope). The non-threads
+ * case below uses it to declare the data as static. */
+#define START_MY_CXT
+
+#if (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 ))
+/* Fetches the SV that keeps the per-interpreter data. */
+#define dMY_CXT_SV \
+ SV *my_cxt_sv = perl_get_sv(MY_CXT_KEY, FALSE)
+#else /* >= perl5.004_68 */
+#define dMY_CXT_SV \
+ SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \
+ sizeof(MY_CXT_KEY)-1, TRUE)
+#endif /* < perl5.004_68 */
+
+/* This declaration should be used within all functions that use the
+ * interpreter-local data. */
+#define dMY_CXT \
+ dMY_CXT_SV; \
+ my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv))
+
+/* Creates and zeroes the per-interpreter data.
+ * (We allocate my_cxtp in a Perl SV so that it will be released when
+ * the interpreter goes away.) */
+#define MY_CXT_INIT \
+ dMY_CXT_SV; \
+ /* newSV() allocates one more than needed */ \
+ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
+ Zero(my_cxtp, 1, my_cxt_t); \
+ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
+
+/* This macro must be used to access members of the my_cxt_t structure.
+ * e.g. MYCXT.some_data */
+#define MY_CXT (*my_cxtp)
+
+/* Judicious use of these macros can reduce the number of times dMY_CXT
+ * is used. Use is similar to pTHX, aTHX etc. */
+#define pMY_CXT my_cxt_t *my_cxtp
+#define pMY_CXT_ pMY_CXT,
+#define _pMY_CXT ,pMY_CXT
+#define aMY_CXT my_cxtp
+#define aMY_CXT_ aMY_CXT,
+#define _aMY_CXT ,aMY_CXT
+
+#else /* single interpreter */
+
+#define START_MY_CXT static my_cxt_t my_cxt;
+#define dMY_CXT_SV dNOOP
+#define dMY_CXT dNOOP
+#define MY_CXT_INIT NOOP
+#define MY_CXT my_cxt
+
+#define pMY_CXT void
+#define pMY_CXT_
+#define _pMY_CXT
+#define aMY_CXT
+#define aMY_CXT_
+#define _aMY_CXT
+
+#endif
+
+#endif /* START_MY_CXT */
+
+#ifndef IVdf
+# if IVSIZE == LONGSIZE
+# define IVdf "ld"
+# define UVuf "lu"
+# define UVof "lo"
+# define UVxf "lx"
+# define UVXf "lX"
+# else
+# if IVSIZE == INTSIZE
+# define IVdf "d"
+# define UVuf "u"
+# define UVof "o"
+# define UVxf "x"
+# define UVXf "X"
+# endif
+# endif
+#endif
+
+#ifndef NVef
+# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \
+ defined(PERL_PRIfldbl) /* Not very likely, but let's try anyway. */
+# define NVef PERL_PRIeldbl
+# define NVff PERL_PRIfldbl
+# define NVgf PERL_PRIgldbl
+# else
+# define NVef "e"
+# define NVff "f"
+# define NVgf "g"
+# endif
+#endif
+
+#ifndef AvFILLp /* Older perls (<=5.003) lack AvFILLp */
+# define AvFILLp AvFILL
+#endif
+
+#ifdef SvPVbyte
+# if PERL_REVISION == 5 && PERL_VERSION < 7
+ /* SvPVbyte does not work in perl-5.6.1, borrowed version for 5.7.3 */
+# undef SvPVbyte
+# define SvPVbyte(sv, lp) \
+ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : my_sv_2pvbyte(aTHX_ sv, &lp))
+ static char *
+ my_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
+ {
+ sv_utf8_downgrade(sv,0);
+ return SvPV(sv,*lp);
+ }
+# endif
+#else
+# define SvPVbyte SvPV
+#endif
+
+#ifndef SvPV_nolen
+# define SvPV_nolen(sv) \
+ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ ? SvPVX(sv) : sv_2pv_nolen(sv))
+ static char *
+ sv_2pv_nolen(pTHX_ register SV *sv)
+ {
+ STRLEN n_a;
+ return sv_2pv(sv, &n_a);
+ }
+#endif
+
+#ifndef get_cv
+# define get_cv(name,create) perl_get_cv(name,create)
+#endif
+
+#ifndef get_sv
+# define get_sv(name,create) perl_get_sv(name,create)
+#endif
+
+#ifndef get_av
+# define get_av(name,create) perl_get_av(name,create)
+#endif
+
+#ifndef get_hv
+# define get_hv(name,create) perl_get_hv(name,create)
+#endif
+
+#ifndef call_argv
+# define call_argv perl_call_argv
+#endif
+
+#ifndef call_method
+# define call_method perl_call_method
+#endif
+
+#ifndef call_pv
+# define call_pv perl_call_pv
+#endif
+
+#ifndef call_sv
+# define call_sv perl_call_sv
+#endif
+
+#ifndef eval_pv
+# define eval_pv perl_eval_pv
+#endif
+
+#ifndef eval_sv
+# define eval_sv perl_eval_sv
+#endif
+
+#ifndef PERL_SCAN_GREATER_THAN_UV_MAX
+# define PERL_SCAN_GREATER_THAN_UV_MAX 0x02
+#endif
+
+#ifndef PERL_SCAN_SILENT_ILLDIGIT
+# define PERL_SCAN_SILENT_ILLDIGIT 0x04
+#endif
+
+#ifndef PERL_SCAN_ALLOW_UNDERSCORES
+# define PERL_SCAN_ALLOW_UNDERSCORES 0x01
+#endif
+
+#ifndef PERL_SCAN_DISALLOW_PREFIX
+# define PERL_SCAN_DISALLOW_PREFIX 0x02
+#endif
+
+#if (PERL_VERSION > 6) || ((PERL_VERSION == 6) && (PERL_SUBVERSION >= 1))
+#define I32_CAST
+#else
+#define I32_CAST (I32*)
+#endif
+
+#ifndef grok_hex
+static UV _grok_hex (char *string, STRLEN *len, I32 *flags, NV *result) {
+ NV r = scan_hex(string, *len, I32_CAST len);
+ if (r > UV_MAX) {
+ *flags |= PERL_SCAN_GREATER_THAN_UV_MAX;
+ if (result) *result = r;
+ return UV_MAX;
+ }
+ return (UV)r;
+}
+
+# define grok_hex(string, len, flags, result) \
+ _grok_hex((string), (len), (flags), (result))
+#endif
+
+#ifndef grok_oct
+static UV _grok_oct (char *string, STRLEN *len, I32 *flags, NV *result) {
+ NV r = scan_oct(string, *len, I32_CAST len);
+ if (r > UV_MAX) {
+ *flags |= PERL_SCAN_GREATER_THAN_UV_MAX;
+ if (result) *result = r;
+ return UV_MAX;
+ }
+ return (UV)r;
+}
+
+# define grok_oct(string, len, flags, result) \
+ _grok_oct((string), (len), (flags), (result))
+#endif
+
+#if !defined(grok_bin) && defined(scan_bin)
+static UV _grok_bin (char *string, STRLEN *len, I32 *flags, NV *result) {
+ NV r = scan_bin(string, *len, I32_CAST len);
+ if (r > UV_MAX) {
+ *flags |= PERL_SCAN_GREATER_THAN_UV_MAX;
+ if (result) *result = r;
+ return UV_MAX;
+ }
+ return (UV)r;
+}
+
+# define grok_bin(string, len, flags, result) \
+ _grok_bin((string), (len), (flags), (result))
+#endif
+
+#ifndef IN_LOCALE
+# define IN_LOCALE \
+ (PL_curcop == &PL_compiling ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME)
+#endif
+
+#ifndef IN_LOCALE_RUNTIME
+# define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE)
+#endif
+
+#ifndef IN_LOCALE_COMPILETIME
+# define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE)
+#endif
+
+
+#ifndef IS_NUMBER_IN_UV
+# define IS_NUMBER_IN_UV 0x01
+# define IS_NUMBER_GREATER_THAN_UV_MAX 0x02
+# define IS_NUMBER_NOT_INT 0x04
+# define IS_NUMBER_NEG 0x08
+# define IS_NUMBER_INFINITY 0x10
+# define IS_NUMBER_NAN 0x20
+#endif
+
+#ifndef grok_numeric_radix
+# define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(aTHX_ sp, send)
+
+#define grok_numeric_radix Perl_grok_numeric_radix
+
+bool
+Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send)
+{
+#ifdef USE_LOCALE_NUMERIC
+#if (PERL_VERSION > 6) || ((PERL_VERSION == 6) && (PERL_SUBVERSION >= 1))
+ if (PL_numeric_radix_sv && IN_LOCALE) {
+ STRLEN len;
+ char* radix = SvPV(PL_numeric_radix_sv, len);
+ if (*sp + len <= send && memEQ(*sp, radix, len)) {
+ *sp += len;
+ return TRUE;
+ }
+ }
+#else
+ /* pre5.6.0 perls don't have PL_numeric_radix_sv so the radix
+ * must manually be requested from locale.h */
+#include <locale.h>
+ struct lconv *lc = localeconv();
+ char *radix = lc->decimal_point;
+ if (radix && IN_LOCALE) {
+ STRLEN len = strlen(radix);
+ if (*sp + len <= send && memEQ(*sp, radix, len)) {
+ *sp += len;
+ return TRUE;
+ }
+ }
+#endif /* PERL_VERSION */
+#endif /* USE_LOCALE_NUMERIC */
+ /* always try "." if numeric radix didn't match because
+ * we may have data from different locales mixed */
+ if (*sp < send && **sp == '.') {
+ ++*sp;
+ return TRUE;
+ }
+ return FALSE;
+}
+#endif /* grok_numeric_radix */
+
+#ifndef grok_number
+
+#define grok_number Perl_grok_number
+
+int
+Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
+{
+ const char *s = pv;
+ const char *send = pv + len;
+ const UV max_div_10 = UV_MAX / 10;
+ const char max_mod_10 = UV_MAX % 10;
+ int numtype = 0;
+ int sawinf = 0;
+ int sawnan = 0;
+
+ while (s < send && isSPACE(*s))
+ s++;
+ if (s == send) {
+ return 0;
+ } else if (*s == '-') {
+ s++;
+ numtype = IS_NUMBER_NEG;
+ }
+ else if (*s == '+')
+ s++;
+
+ if (s == send)
+ return 0;
+
+ /* next must be digit or the radix separator or beginning of infinity */
+ if (isDIGIT(*s)) {
+ /* UVs are at least 32 bits, so the first 9 decimal digits cannot
+ overflow. */
+ UV value = *s - '0';
+ /* This construction seems to be more optimiser friendly.
+ (without it gcc does the isDIGIT test and the *s - '0' separately)
+ With it gcc on arm is managing 6 instructions (6 cycles) per digit.
+ In theory the optimiser could deduce how far to unroll the loop
+ before checking for overflow. */
+ if (++s < send) {
+ int digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ /* Now got 9 digits, so need to check
+ each time for overflow. */
+ digit = *s - '0';
+ while (digit >= 0 && digit <= 9
+ && (value < max_div_10
+ || (value == max_div_10
+ && digit <= max_mod_10))) {
+ value = value * 10 + digit;
+ if (++s < send)
+ digit = *s - '0';
+ else
+ break;
+ }
+ if (digit >= 0 && digit <= 9
+ && (s < send)) {
+ /* value overflowed.
+ skip the remaining digits, don't
+ worry about setting *valuep. */
+ do {
+ s++;
+ } while (s < send && isDIGIT(*s));
+ numtype |=
+ IS_NUMBER_GREATER_THAN_UV_MAX;
+ goto skip_value;
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ numtype |= IS_NUMBER_IN_UV;
+ if (valuep)
+ *valuep = value;
+
+ skip_value:
+ if (GROK_NUMERIC_RADIX(&s, send)) {
+ numtype |= IS_NUMBER_NOT_INT;
+ while (s < send && isDIGIT(*s)) /* optional digits after the radix */
+ s++;
+ }
+ }
+ else if (GROK_NUMERIC_RADIX(&s, send)) {
+ numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
+ /* no digits before the radix means we need digits after it */
+ if (s < send && isDIGIT(*s)) {
+ do {
+ s++;
+ } while (s < send && isDIGIT(*s));
+ if (valuep) {
+ /* integer approximation is valid - it's 0. */
+ *valuep = 0;
+ }
+ }
+ else
+ return 0;
+ } else if (*s == 'I' || *s == 'i') {
+ s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
+ s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
+ s++; if (s < send && (*s == 'I' || *s == 'i')) {
+ s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
+ s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
+ s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
+ s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
+ s++;
+ }
+ sawinf = 1;
+ } else if (*s == 'N' || *s == 'n') {
+ /* XXX TODO: There are signaling NaNs and quiet NaNs. */
+ s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
+ s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
+ s++;
+ sawnan = 1;
+ } else
+ return 0;
+
+ if (sawinf) {
+ numtype &= IS_NUMBER_NEG; /* Keep track of sign */
+ numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
+ } else if (sawnan) {
+ numtype &= IS_NUMBER_NEG; /* Keep track of sign */
+ numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
+ } else if (s < send) {
+ /* we can have an optional exponent part */
+ if (*s == 'e' || *s == 'E') {
+ /* The only flag we keep is sign. Blow away any "it's UV" */
+ numtype &= IS_NUMBER_NEG;
+ numtype |= IS_NUMBER_NOT_INT;
+ s++;
+ if (s < send && (*s == '-' || *s == '+'))
+ s++;
+ if (s < send && isDIGIT(*s)) {
+ do {
+ s++;
+ } while (s < send && isDIGIT(*s));
+ }
+ else
+ return 0;
+ }
+ }
+ while (s < send && isSPACE(*s))
+ s++;
+ if (s >= send)
+ return numtype;
+ if (len == 10 && memEQ(pv, "0 but true", 10)) {
+ if (valuep)
+ *valuep = 0;
+ return IS_NUMBER_IN_UV;
+ }
+ return 0;
+}
+#endif /* grok_number */
+
+#ifndef PERL_MAGIC_sv
+# define PERL_MAGIC_sv '\0'
+#endif
+
+#ifndef PERL_MAGIC_overload
+# define PERL_MAGIC_overload 'A'
+#endif
+
+#ifndef PERL_MAGIC_overload_elem
+# define PERL_MAGIC_overload_elem 'a'
+#endif
+
+#ifndef PERL_MAGIC_overload_table
+# define PERL_MAGIC_overload_table 'c'
+#endif
+
+#ifndef PERL_MAGIC_bm
+# define PERL_MAGIC_bm 'B'
+#endif
+
+#ifndef PERL_MAGIC_regdata
+# define PERL_MAGIC_regdata 'D'
+#endif
+
+#ifndef PERL_MAGIC_regdatum
+# define PERL_MAGIC_regdatum 'd'
+#endif
+
+#ifndef PERL_MAGIC_env
+# define PERL_MAGIC_env 'E'
+#endif
+
+#ifndef PERL_MAGIC_envelem
+# define PERL_MAGIC_envelem 'e'
+#endif
+
+#ifndef PERL_MAGIC_fm
+# define PERL_MAGIC_fm 'f'
+#endif
+
+#ifndef PERL_MAGIC_regex_global
+# define PERL_MAGIC_regex_global 'g'
+#endif
+
+#ifndef PERL_MAGIC_isa
+# define PERL_MAGIC_isa 'I'
+#endif
+
+#ifndef PERL_MAGIC_isaelem
+# define PERL_MAGIC_isaelem 'i'
+#endif
+
+#ifndef PERL_MAGIC_nkeys
+# define PERL_MAGIC_nkeys 'k'
+#endif
+
+#ifndef PERL_MAGIC_dbfile
+# define PERL_MAGIC_dbfile 'L'
+#endif
+
+#ifndef PERL_MAGIC_dbline
+# define PERL_MAGIC_dbline 'l'
+#endif
+
+#ifndef PERL_MAGIC_mutex
+# define PERL_MAGIC_mutex 'm'
+#endif
+
+#ifndef PERL_MAGIC_shared
+# define PERL_MAGIC_shared 'N'
+#endif
+
+#ifndef PERL_MAGIC_shared_scalar
+# define PERL_MAGIC_shared_scalar 'n'
+#endif
+
+#ifndef PERL_MAGIC_collxfrm
+# define PERL_MAGIC_collxfrm 'o'
+#endif
+
+#ifndef PERL_MAGIC_tied
+# define PERL_MAGIC_tied 'P'
+#endif
+
+#ifndef PERL_MAGIC_tiedelem
+# define PERL_MAGIC_tiedelem 'p'
+#endif
+
+#ifndef PERL_MAGIC_tiedscalar
+# define PERL_MAGIC_tiedscalar 'q'
+#endif
+
+#ifndef PERL_MAGIC_qr
+# define PERL_MAGIC_qr 'r'
+#endif
+
+#ifndef PERL_MAGIC_sig
+# define PERL_MAGIC_sig 'S'
+#endif
+
+#ifndef PERL_MAGIC_sigelem
+# define PERL_MAGIC_sigelem 's'
+#endif
+
+#ifndef PERL_MAGIC_taint
+# define PERL_MAGIC_taint 't'
+#endif
+
+#ifndef PERL_MAGIC_uvar
+# define PERL_MAGIC_uvar 'U'
+#endif
+
+#ifndef PERL_MAGIC_uvar_elem
+# define PERL_MAGIC_uvar_elem 'u'
+#endif
+
+#ifndef PERL_MAGIC_vstring
+# define PERL_MAGIC_vstring 'V'
+#endif
+
+#ifndef PERL_MAGIC_vec
+# define PERL_MAGIC_vec 'v'
+#endif
+
+#ifndef PERL_MAGIC_utf8
+# define PERL_MAGIC_utf8 'w'
+#endif
+
+#ifndef PERL_MAGIC_substr
+# define PERL_MAGIC_substr 'x'
+#endif
+
+#ifndef PERL_MAGIC_defelem
+# define PERL_MAGIC_defelem 'y'
+#endif
+
+#ifndef PERL_MAGIC_glob
+# define PERL_MAGIC_glob '*'
+#endif
+
+#ifndef PERL_MAGIC_arylen
+# define PERL_MAGIC_arylen '#'
+#endif
+
+#ifndef PERL_MAGIC_pos
+# define PERL_MAGIC_pos '.'
+#endif
+
+#ifndef PERL_MAGIC_backref
+# define PERL_MAGIC_backref '<'
+#endif
+
+#ifndef PERL_MAGIC_ext
+# define PERL_MAGIC_ext '~'
+#endif
+
+#endif /* _P_P_PORTABILITY_H_ */
+
+/* End of File ppport.h */
Added: trunk/api/xs/Cache-Memcached-GetParserXS/t/Cache-Memcached-GetParserXS.t
===================================================================
--- trunk/api/xs/Cache-Memcached-GetParserXS/t/Cache-Memcached-GetParserXS.t 2006-07-18 04:16:10 UTC (rev 303)
+++ trunk/api/xs/Cache-Memcached-GetParserXS/t/Cache-Memcached-GetParserXS.t 2006-07-18 04:25:43 UTC (rev 304)
@@ -0,0 +1,15 @@
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl Cache-Memcached-GetParserXS.t'
+
+#########################
+
+# change 'tests => 1' to 'tests => last_test_to_print';
+
+use Test::More tests => 1;
+BEGIN { use_ok('Cache::Memcached::GetParserXS') };
+
+#########################
+
+# Insert your test code below, the Test::More module is use()ed here so read
+# its man page ( perldoc Test::More ) for help writing this test script.
+
More information about the memcached-commits
mailing list