Cache-Memcached-GetParserXS-0.01/0000755000175000017500000000000010616751726015515 5ustar ljlj00000000000000Cache-Memcached-GetParserXS-0.01/ppport.h0000644000175000017500000007224510616221614017210 0ustar ljlj00000000000000 /* 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@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 @ARGV = ("*.xs") if !@ARGV; %badmacros = %funcs = %macros = (); $replace = 0; foreach () { $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($_),@ARGV)) { unless (open(IN, "<$filename")) { warn "Unable to read from $file: $!\n"; next; } print "Scanning $filename...\n"; $c = ""; while () { $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 () { 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 # endif # if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) # include # 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 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 */ Cache-Memcached-GetParserXS-0.01/t/0000755000175000017500000000000010616751726015760 5ustar ljlj00000000000000Cache-Memcached-GetParserXS-0.01/t/Cache-Memcached-GetParserXS.t0000644000175000017500000000120410616221614023142 0ustar ljlj00000000000000#!/usr/bi/perl use Test::More tests => 6; BEGIN { use_ok('Cache::Memcached::GetParserXS') }; use Data::Dumper; my $fin; my $p = new_parser(); ok($p, "Parser object was created"); # simple case $p->t_parse_buf("VALUE foo 0 3 bar END "); is_deeply($fin, { foo => 0 }, "got foo"); # in chunks... $p = new_parser(); $p->t_parse_buf("VALUE foo 0 3 bar VALUE bar 1 3 baz "); is($fin, undef, "nothing yet"); $p->t_parse_buf("END"); is($fin, undef, "nothing yet"); $p->t_parse_buf("\n"); is_deeply($fin, { foo => 0, bar => 1 }, "got 'em"); sub new_parser { $fin = undef; Cache::Memcached::GetParserXS->new({}, 0, sub { $fin = $_[0] }); } Cache-Memcached-GetParserXS-0.01/Changes0000644000175000017500000000027610616221614017001 0ustar ljlj00000000000000Revision 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 Cache-Memcached-GetParserXS-0.01/lib/0000755000175000017500000000000010616751726016263 5ustar ljlj00000000000000Cache-Memcached-GetParserXS-0.01/lib/Cache/0000755000175000017500000000000010616751726017266 5ustar ljlj00000000000000Cache-Memcached-GetParserXS-0.01/lib/Cache/Memcached/0000755000175000017500000000000010616751726021134 5ustar ljlj00000000000000Cache-Memcached-GetParserXS-0.01/lib/Cache/Memcached/GetParserXS.pm0000644000175000017500000001040610616751717023642 0ustar ljlj00000000000000package Cache::Memcached::GetParserXS; =head1 NAME Cache::Memcached::GetParserXS - GetParser implementation in XS for use with Cache::Memcached =head1 SYNOPSIS use Cache::Memcached::GetParserXS; use Cache::Memcached; # Everything else is the same as Cache::Memcached has documented it. # Seriously. =head1 DESCRIPTION This module implements the same function as Cache::Memcached::GetParser, except it's written in C/XS. Initial benchmarks have shown it to be possibly twice as fast as the original perl version. =cut use 5.006; use strict; use warnings; # We don't want to inherit from this, because our constants may be different. # use base 'Cache::Memcached::GetParser'; use Carp; use Errno qw( EINPROGRESS EWOULDBLOCK EISCONN ); use Cache::Memcached 1.21; our $VERSION = '0.01'; require XSLoader; XSLoader::load('Cache::Memcached::GetParserXS', $VERSION); sub DEST; sub NSLEN; sub ON_ITEM; sub BUF; sub STATE; sub OFFSET; sub FLAGS; sub KEY; sub FINISHED; sub new { my ($class, $dest, $nslen, $on_item) = @_; my $self = bless [], (ref $class || $class); $self->[DEST] = $dest; $self->[NSLEN] = $nslen; $self->[ON_ITEM] = $on_item; $self->[BUF] = ''; $self->[STATE] = 0; $self->[OFFSET] = 0; $self->[FLAGS] = undef; $self->[KEY] = undef; $self->[FINISHED] = {}; return $self } sub current_key { return $_[0][KEY]; } sub t_parse_buf { my ($self, $buf) = @_; # force buf into \r\n format $buf =~ s/\n/\r\n/g; $buf =~ s/\r\r/\r/g; $self->[BUF] .= $buf; $self->[OFFSET] += length $buf; my $rv = $self->parse_buffer; if ($rv > 0) { $self->[ON_ITEM]->($self->[FINISHED]); $self->[ON_ITEM] = undef; } return $rv; } # returns 1 on success, -1 on failure, and 0 if still working. sub parse_from_sock { my ($self, $sock) = @_; my $res; # where are we reading into? if ($self->[STATE]) { # reading value into $ret my $ret = $self->[DEST]; $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->[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], 128*1024, $self->[OFFSET]); return 0 if !defined($res) and $!==EWOULDBLOCK; if ($res == 0) { $self->[ON_ITEM] = undef; return -1; } $self->[OFFSET] += $res; my $answer = $self->parse_buffer; if ($answer > 0) { $self->[ON_ITEM]->($self->[FINISHED]); $self->[ON_ITEM] = undef; } return $answer; } sub DESTROY {} # Empty definition, so AUTOLOAD doesn't catch it # sub parse_buffer is defined in XS 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; } 1; __END__ =head1 SEE ALSO Cache::Memcached =head1 AUTHORS Jonathan Steinert Ehachi@cpan.orgE - Current maintainer Aaron Emigh Brad Fitzpatrick =head1 COPYRIGHT AND LICENSE Copyright (C) 2007 Six Apart Ltd. 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 Cache-Memcached-GetParserXS-0.01/MANIFEST0000644000175000017500000000031610616751726016646 0ustar ljlj00000000000000Changes GetParserXS.xs Makefile.PL MANIFEST ppport.h README t/Cache-Memcached-GetParserXS.t lib/Cache/Memcached/GetParserXS.pm META.yml Module meta-data (added by MakeMaker) Cache-Memcached-GetParserXS-0.01/GetParserXS.xs0000644000175000017500000001543210616221614020231 0ustar ljlj00000000000000#include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "ppport.h" #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 FINISHED 8 /* hashref of keys and flags to be finalized at any time */ #define DEBUG 0 #include "const-c.inc" int get_nslen (AV* self) { SV** svp = av_fetch(self, NSLEN, 0); if (svp) return SvIV((SV*) *svp); return 0; } inline void set_key (AV* self, const char *key, int len) { av_store(self, KEY, newSVpv(key, len)); } inline SV *get_key_sv (AV* self) { SV** svp = av_fetch(self, KEY, 0); if (svp) return (SV*) *svp; return 0; } inline SV *get_on_item (AV* self) { SV** svp = av_fetch(self, ON_ITEM, 0); if (svp) return (SV*) *svp; return 0; } inline SV *get_offset_sv (AV* self) { SV** svp = av_fetch(self, OFFSET, 0); if (svp) return (SV*) *svp; *svp = newSViv(0); av_store(self, OFFSET, *svp); return (SV*) *svp; } inline void clear_on_item (AV* self) { SV** svp = av_store(self, ON_ITEM, newSV(0) ); } inline void set_flags (AV* self, int flags) { av_store(self, FLAGS, newSViv(flags)); } inline void set_offset (AV* self, int offset) { av_store(self, OFFSET, newSViv(offset)); } inline void set_state (AV* self, int state) { av_store(self, STATE, newSViv(state)); } inline HV* get_dest (AV* self) { SV** svp = av_fetch(self, DEST, 0); if (svp) return (HV*) SvRV(*svp); return 0; } inline HV* get_finished (AV* self) { SV** svp = av_fetch(self, FINISHED, 0); if (svp) return (HV*) SvRV(*svp); return 0; } inline IV get_state (AV* self) { SV** svp = av_fetch(self, STATE, 0); if (svp) return SvIV((SV*) *svp); return 0; } inline 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; unsigned int itemlen; unsigned int flags; int scanned; int nslen = get_nslen(self); SV* on_item = get_on_item(self); register signed char c; char *key; register char *p; int key_len, barelen; int state, copy, new_p; char *barekey; HV* finished = get_finished(self); if (DEBUG) printf("get_buffer (nslen = %d)...\n", nslen); while (1) { int rv; buf = SvPV(bufsv, len); p = buf; if (DEBUG) { char first_line[1000]; int i; char *end; for (i = 0, end = buf; *end && *end != '\n' && i++ < 900; end++) ; end += 10; strncpy (first_line, buf, end - buf + 1); first_line[end - buf + 1] = '\0'; printf("GOT buf (len=%d)\nFirst line: %s\n", len, first_line); } if ((c = *p++) == 'V') { if (*p++ != 'A' || *p++ != 'L' || *p++ != 'U' || *p++ != 'E' || *p++ != ' ') { if (DEBUG) puts ("ERROR: Illegal command beginning with V"); goto recover_from_partial_line; } // Parsing VALUE %s %u %u for (key = p; *p++ > ' ';) ; key_len = p - key - 1; if (*(p - 1) != ' ') { if (DEBUG) printf ("ERROR: key not space-terminated: key %s, char %c\n", key, *(p - 1)); goto recover_from_partial_line; } // Note that key just points into the buffer and is not null-terminated // yet. Leave it that way in case we're dealing with a partial line. // Get flags and itemlen as integers. Note invalid characters // are not caught and will result in strange numbers. for (flags = 0; (c = *p++ - '0') >= 0; flags = flags * 10 + c) ; if (c != (signed char)' ' - '0') { if (DEBUG) puts ("ERROR: Flags not space terminated"); goto recover_from_partial_line; } for (itemlen = 0; (c = *p++ - '0') >= 0; itemlen = itemlen * 10 + c) ; if (c != (signed char)'\r' - '0' || *p++ != '\n') { if (DEBUG) puts ("ERROR: byte count not CRLF-terminated"); goto recover_from_partial_line; } // p is left at the start of the value data. new_p = p - buf; state = itemlen + 2; /* 2 to include reading final \r\n, a different \r\n */ copy = len - new_p > state ? state : len - new_p; barekey = key + nslen; barelen = key_len - nslen; if (DEBUG) { char temp_key[256]; strncpy (temp_key, key, key_len); temp_key[key_len] = '\0'; printf("key=[%s], state=%d, copy=%d\n", key, state, copy); } if (copy) { *(key + key_len) = '\0'; // Null-terminate the key in-buffer hv_store(ret, barekey, barelen, newSVpv(buf + new_p, copy), 0); buf[new_p + copy - 1] = '\0'; if (DEBUG) printf("doing store: len=%d key=[%s] of data [%c]\n", strlen(barekey), barekey, *(buf + new_p)); } /* delete the stuff we used */ sv_chop(bufsv, buf + new_p + copy); if (copy == state) { hv_store(finished, barekey, barelen, newSViv(flags), 0); set_offset(self, 0); set_state(self, 0); continue; } else { /* don't have it all... but buffer is now empty */ hv_store(finished, barekey, barelen, newSViv(flags), 0); set_offset(self, copy); set_flags(self, flags); set_key(self, barekey, barelen); 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 */ } } else if (c == 'E') { // Parsing END if (*p++ == 'N' && *p++ == 'D' && *p++ == '\r' && *p == '\n') return final_answer(self, 1); } // Just fall through if after 'E' was not "ND\r\n" else ; // Unknown command: not 'E' or 'V' at [0] /* # 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. */ recover_from_partial_line: set_offset(self, len); return 0; } } MODULE = Cache::Memcached::GetParserXS PACKAGE = Cache::Memcached::GetParserXS INCLUDE: const-xs.inc int parse_buffer ( self ) SV *self Cache-Memcached-GetParserXS-0.01/Makefile.PL0000644000175000017500000000315310616751654017471 0ustar ljlj00000000000000use 5.006; use ExtUtils::Constant; 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 => { 'Cache::Memcached' => 1.21, 'ExtUtils::Constant' => 0, }, # e.g., Module::Name => 1.1 ABSTRACT_FROM => 'lib/Cache/Memcached/GetParserXS.pm', # retrieve abstract from module AUTHOR => 'Jonathan Steinert ', 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 clean => { FILES => "const-c.inc const-xs.inc" }, ); my @names = (qw(DEST NSLEN ON_ITEM BUF STATE OFFSET FLAGS KEY FINISHED)); ExtUtils::Constant::WriteConstants( NAME => 'Cache::Memcached::GetParserXS', NAMES => \@names, DEFAULT_TYPE => 'IV', C_FILE => 'const-c.inc', XS_FILE => 'const-xs.inc', ); Cache-Memcached-GetParserXS-0.01/README0000644000175000017500000000227410616221614016366 0ustar ljlj00000000000000Cache-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. Cache-Memcached-GetParserXS-0.01/META.yml0000644000175000017500000000064210616751726016770 0ustar ljlj00000000000000# http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: Cache-Memcached-GetParserXS version: 0.01 version_from: lib/Cache/Memcached/GetParserXS.pm installdirs: site requires: Cache::Memcached: 1.21 ExtUtils::Constant: 0 distribution_type: module generated_by: ExtUtils::MakeMaker version 6.30_01