Cache-Memcached-Fast-0.21/0000755000175000017500000000000012127763146014557 5ustar tomashtomashCache-Memcached-Fast-0.21/META.json0000664000175000017500000000161712127763146016207 0ustar tomashtomash{ "abstract" : "Perl client for B, in C language", "author" : [ "Tomash Brechko " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.120921", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Cache-Memcached-Fast", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Test::More" : "0" } } }, "release_status" : "stable", "version" : "0.21" } Cache-Memcached-Fast-0.21/META.yml0000664000175000017500000000101512127763146016027 0ustar tomashtomash--- abstract: 'Perl client for B, in C language' author: - 'Tomash Brechko ' build_requires: ExtUtils::MakeMaker: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.120921' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Cache-Memcached-Fast no_index: directory: - t - inc requires: Test::More: 0 version: 0.21 Cache-Memcached-Fast-0.21/README0000644000175000017500000000741212127763070015437 0ustar tomashtomashCache-Memcached-Fast version 0.21 ================================= Cache::Memcahced::Fast is a Perl client for memcached, a memory cache daemon (http://www.danga.com/memcached/). Module core is implemented in C and tries hard to minimize number of system calls and to avoid any key/value copying for speed. As a result, it has very low CPU consumption. API is largely compatible with Cache::Memcached, original pure Perl client, most users of the original module may start using this module by installing it and adding "::Fast" to the old name in their scripts (see "Compatibility with Cache::Memcached" section in the module documentation for full details). The module does not depend on any external library, it contains custom memcached client implementation in C designed for efficient interaction with Perl (actually client code has well defined generic API and may be used by itself). The module should compile and work on any Unix-derived system. Win32 support is based on the patch by Yasuhiro Matsumoto---thanks!, and is (expected to be) supported by community. Note: on Win32 below Windows Vista max number of memcached servers is 64. See comment on FD_SETSIZE in src/socket_win32.h to learn how to increase this value if you need to connect to more than 64 servers. Despite the low version number (which mainly reflects release history) the module is considered to be beta (see BUGS below on how to report bugs). See "Compatibility with Cache::Memcached" section in the module documentation for the description of what is missing compared to Cache::Memcached. INSTALLATION Latest release of this module is available from CPAN: http://search.cpan.org/dist/Cache-Memcached-Fast/ Latest development tree is available from project home: http://openhack.ru/Cache-Memcached-Fast To install this module type the following: perl Makefile.PL make make test make install Don't forget to start memcahced daemon on local host port 11211 (the default) before running 'make test'. DEPENDENCIES This module requires these other modules and software: ANSI C compiler to compile module core Test::More (required only to run tests) SUPPORT AND DOCUMENTATION After installing, you can find documentation for this module with the perldoc command. perldoc Cache::Memcached::Fast You can also look for information at: RT, CPAN's request tracker http://rt.cpan.org/NoAuth/Bugs.html?Dist=Cache-Memcached-Fast AnnoCPAN, Annotated CPAN documentation http://annocpan.org/dist/Cache-Memcached-Fast CPAN Ratings http://cpanratings.perl.org/d/Cache-Memcached-Fast Search CPAN http://search.cpan.org/dist/Cache-Memcached-Fast BUGS Please report any bugs or feature requests to bug-cache-memcached-fast at rt.cpan.org, or through the web interface at http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Cache-Memcached-Fast. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. COPYRIGHT AND LICENCE Copyright (C) 2007-2010 Tomash Brechko. All rights reserved. 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.8 or, at your option, any later version of Perl 5 you may have available. When C client is used as a standalone library: This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. Cache-Memcached-Fast-0.21/Makefile.PL0000644000175000017500000000133012127763070016522 0ustar tomashtomashuse 5.006; use strict; use warnings; use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( NAME => 'Cache::Memcached::Fast', VERSION_FROM => 'lib/Cache/Memcached/Fast.pm', PREREQ_PM => { 'Test::More' => 0 }, ABSTRACT_FROM => 'lib/Cache/Memcached/Fast.pm', AUTHOR => 'Tomash Brechko ', MYEXTLIB => 'src/libclient$(LIB_EXT)', ); sub MY::postamble { ' $(MYEXTLIB): src/Makefile cd src && $(MAKE) $(PASTHRU) bench: all $(PERL) -I./blib/lib -I./blib/arch script/benchmark.pl \ localhost:11211 127.0.0.1:11211 ' } Cache-Memcached-Fast-0.21/ppport.h0000644000175000017500000045651412127763070016267 0ustar tomashtomash#if 0 <<'SKIP'; #endif /* ---------------------------------------------------------------------- ppport.h -- Perl/Pollution/Portability Version 3.13 Automatically created by Devel::PPPort running under perl 5.008008. Do NOT edit this file directly! -- Edit PPPort_pm.PL and the includes in parts/inc/ instead. Use 'perldoc ppport.h' to view the documentation below. ---------------------------------------------------------------------- SKIP =pod =head1 NAME ppport.h - Perl/Pollution/Portability version 3.13 =head1 SYNOPSIS perl ppport.h [options] [source files] Searches current directory for files if no [source files] are given --help show short help --version show version --patch=file write one patch file with changes --copy=suffix write changed copies with suffix --diff=program use diff program and options --compat-version=version provide compatibility with Perl version --cplusplus accept C++ comments --quiet don't output anything except fatal errors --nodiag don't show diagnostics --nohints don't show hints --nochanges don't suggest changes --nofilter don't filter input files --strip strip all script and doc functionality from ppport.h --list-provided list provided API --list-unsupported list unsupported API --api-info=name show Perl API portability information =head1 COMPATIBILITY This version of F is designed to support operation with Perl installations back to 5.003, and has been tested up to 5.10.0. =head1 OPTIONS =head2 --help Display a brief usage summary. =head2 --version Display the version of F. =head2 --patch=I If this option is given, a single patch file will be created if any changes are suggested. This requires a working diff program to be installed on your system. =head2 --copy=I If this option is given, a copy of each file will be saved with the given suffix that contains the suggested changes. This does not require any external programs. Note that this does not automagially add a dot between the original filename and the suffix. If you want the dot, you have to include it in the option argument. If neither C<--patch> or C<--copy> are given, the default is to simply print the diffs for each file. This requires either C or a C program to be installed. =head2 --diff=I Manually set the diff program and options to use. The default is to use C, when installed, and output unified context diffs. =head2 --compat-version=I Tell F to check for compatibility with the given Perl version. The default is to check for compatibility with Perl version 5.003. You can use this option to reduce the output of F if you intend to be backward compatible only down to a certain Perl version. =head2 --cplusplus Usually, F will detect C++ style comments and replace them with C style comments for portability reasons. Using this option instructs F to leave C++ comments untouched. =head2 --quiet Be quiet. Don't print anything except fatal errors. =head2 --nodiag Don't output any diagnostic messages. Only portability alerts will be printed. =head2 --nohints Don't output any hints. Hints often contain useful portability notes. Warnings will still be displayed. =head2 --nochanges Don't suggest any changes. Only give diagnostic output and hints unless these are also deactivated. =head2 --nofilter Don't filter the list of input files. By default, files not looking like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped. =head2 --strip Strip all script and documentation functionality from F. This reduces the size of F dramatically and may be useful if you want to include F in smaller modules without increasing their distribution size too much. The stripped F will have a C<--unstrip> option that allows you to undo the stripping, but only if an appropriate C module is installed. =head2 --list-provided Lists the API elements for which compatibility is provided by F. Also lists if it must be explicitly requested, if it has dependencies, and if there are hints or warnings for it. =head2 --list-unsupported Lists the API elements that are known not to be supported by F and below which version of Perl they probably won't be available or work. =head2 --api-info=I Show portability information for API elements matching I. If I is surrounded by slashes, it is interpreted as a regular expression. =head1 DESCRIPTION In order for a Perl extension (XS) module to be as portable as possible across differing versions of Perl itself, certain steps need to be taken. =over 4 =item * Including this header is the first major one. This alone will give you access to a large part of the Perl API that hasn't been available in earlier Perl releases. Use perl ppport.h --list-provided to see which API elements are provided by ppport.h. =item * You should avoid using deprecated parts of the API. For example, using global Perl variables without the C prefix is deprecated. Also, some API functions used to have a C prefix. Using this form is also deprecated. You can safely use the supported API, as F will provide wrappers for older Perl versions. =item * If you use one of a few functions or variables that were not present in earlier versions of Perl, and that can't be provided using a macro, you have to explicitly request support for these functions by adding one or more C<#define>s in your source code before the inclusion of F. These functions or variables will be marked C in the list shown by C<--list-provided>. Depending on whether you module has a single or multiple files that use such functions or variables, you want either C or global variants. For a C function or variable (used only in a single source file), use: #define NEED_function #define NEED_variable For a global function or variable (used in multiple source files), use: #define NEED_function_GLOBAL #define NEED_variable_GLOBAL Note that you mustn't have more than one global request for the same function or variable in your project. Function / Variable Static Request Global Request ----------------------------------------------------------------------------------------- PL_signals NEED_PL_signals NEED_PL_signals_GLOBAL eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL grok_number() NEED_grok_number NEED_grok_number_GLOBAL grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL load_module() NEED_load_module NEED_load_module_GLOBAL my_snprintf() NEED_my_snprintf NEED_my_snprintf_GLOBAL my_strlcat() NEED_my_strlcat NEED_my_strlcat_GLOBAL my_strlcpy() NEED_my_strlcpy NEED_my_strlcpy_GLOBAL newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL newSVpvn_share() NEED_newSVpvn_share NEED_newSVpvn_share_GLOBAL sv_2pv_flags() NEED_sv_2pv_flags NEED_sv_2pv_flags_GLOBAL sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL sv_pvn_force_flags() NEED_sv_pvn_force_flags NEED_sv_pvn_force_flags_GLOBAL sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL vload_module() NEED_vload_module NEED_vload_module_GLOBAL vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL warner() NEED_warner NEED_warner_GLOBAL To avoid namespace conflicts, you can change the namespace of the explicitly exported functions / variables using the C macro. Just C<#define> the macro before including C: #define DPPP_NAMESPACE MyOwnNamespace_ #include "ppport.h" The default namespace is C. =back The good thing is that most of the above can be checked by running F on your source code. See the next section for details. =head1 EXAMPLES To verify whether F is needed for your module, whether you should make any changes to your code, and whether any special defines should be used, F can be run as a Perl script to check your source code. Simply say: perl ppport.h The result will usually 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. If you know that your XS module uses features only available in newer Perl releases, if you're aware that it uses C++ comments, and if you want all suggestions as a single patch file, you could use something like this: perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff If you only want your code to be scanned without any suggestions for changes, use: perl ppport.h --nochanges You can specify a different C program or options, using the C<--diff> option: perl ppport.h --diff='diff -C 10' This would output context diffs with 10 lines of context. If you want to create patched copies of your files instead, use: perl ppport.h --copy=.new To display portability information for the C function, use: perl ppport.h --api-info=newSVpvn Since the argument to C<--api-info> can be a regular expression, you can use perl ppport.h --api-info=/_nomg$/ to display portability information for all C<_nomg> functions or perl ppport.h --api-info=/./ to display information for all known API elements. =head1 BUGS If this version of F is causing failure during the compilation of this module, please check if newer versions of either this module or C are available on CPAN before sending a bug report. If F was generated using the latest version of C and is causing failure of this module, please file a bug report using the CPAN Request Tracker at L. Please include the following information: =over 4 =item 1. The complete output from running "perl -V" =item 2. This file. =item 3. The name and version of the module you were trying to build. =item 4. A full log of the build that failed. =item 5. Any other information that you think could be relevant. =back For the latest version of this code, please get the C module from CPAN. =head1 COPYRIGHT Version 3.x, Copyright (c) 2004-2007, Marcus Holland-Moritz. Version 2.x, Copyright (C) 2001, Paul Marquess. Version 1.x, Copyright (C) 1999, Kenneth Albanowski. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO See L. =cut use strict; # Disable broken TRIE-optimization BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 } my $VERSION = 3.13; my %opt = ( quiet => 0, diag => 1, hints => 1, changes => 1, cplusplus => 0, filter => 1, strip => 0, version => 0, ); my($ppport) = $0 =~ /([\w.]+)$/; my $LF = '(?:\r\n|[\r\n])'; # line feed my $HS = "[ \t]"; # horizontal whitespace # Never use C comments in this file! my $ccs = '/'.'*'; my $cce = '*'.'/'; my $rccs = quotemeta $ccs; my $rcce = quotemeta $cce; eval { require Getopt::Long; Getopt::Long::GetOptions(\%opt, qw( help quiet diag! filter! hints! changes! cplusplus strip version patch=s copy=s diff=s compat-version=s list-provided list-unsupported api-info=s )) or usage(); }; if ($@ and grep /^-/, @ARGV) { usage() if "@ARGV" =~ /^--?h(?:elp)?$/; die "Getopt::Long not found. Please don't use any options.\n"; } if ($opt{version}) { print "This is $0 $VERSION.\n"; exit 0; } usage() if $opt{help}; strip() if $opt{strip}; if (exists $opt{'compat-version'}) { my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) }; if ($@) { die "Invalid version number format: '$opt{'compat-version'}'\n"; } die "Only Perl 5 is supported\n" if $r != 5; die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000; $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; } else { $opt{'compat-version'} = 5; } my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ ? ( $1 => { ($2 ? ( base => $2 ) : ()), ($3 ? ( todo => $3 ) : ()), (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()), } ) : die "invalid spec: $_" } qw( AvFILLp|5.004050||p AvFILL||| CLASS|||n CX_CURPAD_SAVE||| CX_CURPAD_SV||| CopFILEAV|5.006000||p CopFILEGV_set|5.006000||p CopFILEGV|5.006000||p CopFILESV|5.006000||p CopFILE_set|5.006000||p CopFILE|5.006000||p CopSTASHPV_set|5.006000||p CopSTASHPV|5.006000||p CopSTASH_eq|5.006000||p CopSTASH_set|5.006000||p CopSTASH|5.006000||p CopyD|5.009002||p Copy||| CvPADLIST||| CvSTASH||| CvWEAKOUTSIDE||| DEFSV|5.004050||p END_EXTERN_C|5.005000||p ENTER||| ERRSV|5.004050||p EXTEND||| EXTERN_C|5.005000||p F0convert|||n FREETMPS||| GIMME_V||5.004000|n GIMME|||n GROK_NUMERIC_RADIX|5.007002||p G_ARRAY||| G_DISCARD||| G_EVAL||| G_NOARGS||| G_SCALAR||| G_VOID||5.004000| GetVars||| GvSV||| Gv_AMupdate||| HEf_SVKEY||5.004000| HeHASH||5.004000| HeKEY||5.004000| HeKLEN||5.004000| HePV||5.004000| HeSVKEY_force||5.004000| HeSVKEY_set||5.004000| HeSVKEY||5.004000| HeVAL||5.004000| HvNAME||| INT2PTR|5.006000||p IN_LOCALE_COMPILETIME|5.007002||p IN_LOCALE_RUNTIME|5.007002||p IN_LOCALE|5.007002||p IN_PERL_COMPILETIME|5.008001||p IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p IS_NUMBER_INFINITY|5.007002||p IS_NUMBER_IN_UV|5.007002||p IS_NUMBER_NAN|5.007003||p IS_NUMBER_NEG|5.007002||p IS_NUMBER_NOT_INT|5.007002||p IVSIZE|5.006000||p IVTYPE|5.006000||p IVdf|5.006000||p LEAVE||| LVRET||| MARK||| MULTICALL||5.009005| MY_CXT_CLONE|5.009002||p MY_CXT_INIT|5.007003||p MY_CXT|5.007003||p MoveD|5.009002||p Move||| NOOP|5.005000||p NUM2PTR|5.006000||p NVTYPE|5.006000||p NVef|5.006001||p NVff|5.006001||p NVgf|5.006001||p Newxc|5.009003||p Newxz|5.009003||p Newx|5.009003||p Nullav||| Nullch||| Nullcv||| Nullhv||| Nullsv||| ORIGMARK||| PAD_BASE_SV||| PAD_CLONE_VARS||| PAD_COMPNAME_FLAGS||| PAD_COMPNAME_GEN_set||| PAD_COMPNAME_GEN||| PAD_COMPNAME_OURSTASH||| PAD_COMPNAME_PV||| PAD_COMPNAME_TYPE||| PAD_RESTORE_LOCAL||| PAD_SAVE_LOCAL||| PAD_SAVE_SETNULLPAD||| PAD_SETSV||| PAD_SET_CUR_NOSAVE||| PAD_SET_CUR||| PAD_SVl||| PAD_SV||| PERL_ABS|5.008001||p PERL_BCDVERSION|5.009005||p PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p PERL_HASH|5.004000||p PERL_INT_MAX|5.004000||p PERL_INT_MIN|5.004000||p PERL_LONG_MAX|5.004000||p PERL_LONG_MIN|5.004000||p PERL_MAGIC_arylen|5.007002||p PERL_MAGIC_backref|5.007002||p PERL_MAGIC_bm|5.007002||p PERL_MAGIC_collxfrm|5.007002||p PERL_MAGIC_dbfile|5.007002||p PERL_MAGIC_dbline|5.007002||p PERL_MAGIC_defelem|5.007002||p PERL_MAGIC_envelem|5.007002||p PERL_MAGIC_env|5.007002||p PERL_MAGIC_ext|5.007002||p PERL_MAGIC_fm|5.007002||p PERL_MAGIC_glob|5.009005||p PERL_MAGIC_isaelem|5.007002||p PERL_MAGIC_isa|5.007002||p PERL_MAGIC_mutex|5.009005||p PERL_MAGIC_nkeys|5.007002||p PERL_MAGIC_overload_elem|5.007002||p PERL_MAGIC_overload_table|5.007002||p PERL_MAGIC_overload|5.007002||p PERL_MAGIC_pos|5.007002||p PERL_MAGIC_qr|5.007002||p PERL_MAGIC_regdata|5.007002||p PERL_MAGIC_regdatum|5.007002||p PERL_MAGIC_regex_global|5.007002||p PERL_MAGIC_shared_scalar|5.007003||p PERL_MAGIC_shared|5.007003||p PERL_MAGIC_sigelem|5.007002||p PERL_MAGIC_sig|5.007002||p PERL_MAGIC_substr|5.007002||p PERL_MAGIC_sv|5.007002||p PERL_MAGIC_taint|5.007002||p PERL_MAGIC_tiedelem|5.007002||p PERL_MAGIC_tiedscalar|5.007002||p PERL_MAGIC_tied|5.007002||p PERL_MAGIC_utf8|5.008001||p PERL_MAGIC_uvar_elem|5.007003||p PERL_MAGIC_uvar|5.007002||p PERL_MAGIC_vec|5.007002||p PERL_MAGIC_vstring|5.008001||p PERL_QUAD_MAX|5.004000||p PERL_QUAD_MIN|5.004000||p PERL_REVISION|5.006000||p PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p PERL_SCAN_DISALLOW_PREFIX|5.007003||p PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p PERL_SCAN_SILENT_ILLDIGIT|5.008001||p PERL_SHORT_MAX|5.004000||p PERL_SHORT_MIN|5.004000||p PERL_SIGNALS_UNSAFE_FLAG|5.008001||p PERL_SUBVERSION|5.006000||p PERL_UCHAR_MAX|5.004000||p PERL_UCHAR_MIN|5.004000||p PERL_UINT_MAX|5.004000||p PERL_UINT_MIN|5.004000||p PERL_ULONG_MAX|5.004000||p PERL_ULONG_MIN|5.004000||p PERL_UNUSED_ARG|5.009003||p PERL_UNUSED_CONTEXT|5.009004||p PERL_UNUSED_DECL|5.007002||p PERL_UNUSED_VAR|5.007002||p PERL_UQUAD_MAX|5.004000||p PERL_UQUAD_MIN|5.004000||p PERL_USE_GCC_BRACE_GROUPS|5.009004||p PERL_USHORT_MAX|5.004000||p PERL_USHORT_MIN|5.004000||p PERL_VERSION|5.006000||p PL_DBsignal|5.005000||p PL_DBsingle|||pn PL_DBsub|||pn PL_DBtrace|||pn PL_Sv|5.005000||p PL_compiling|5.004050||p PL_copline|5.009005||p PL_curcop|5.004050||p PL_curstash|5.004050||p PL_debstash|5.004050||p PL_defgv|5.004050||p PL_diehook|5.004050||p PL_dirty|5.004050||p PL_dowarn|||pn PL_errgv|5.004050||p PL_expect|5.009005||p PL_hexdigit|5.005000||p PL_hints|5.005000||p PL_last_in_gv|||n PL_laststatval|5.005000||p PL_modglobal||5.005000|n PL_na|5.004050||pn PL_no_modify|5.006000||p PL_ofs_sv|||n PL_perl_destruct_level|5.004050||p PL_perldb|5.004050||p PL_ppaddr|5.006000||p PL_rsfp_filters|5.004050||p PL_rsfp|5.004050||p PL_rs|||n PL_signals|5.008001||p PL_stack_base|5.004050||p PL_stack_sp|5.004050||p PL_statcache|5.005000||p PL_stdingv|5.004050||p PL_sv_arenaroot|5.004050||p PL_sv_no|5.004050||pn PL_sv_undef|5.004050||pn PL_sv_yes|5.004050||pn PL_tainted|5.004050||p PL_tainting|5.004050||p POP_MULTICALL||5.009005| POPi|||n POPl|||n POPn|||n POPpbytex||5.007001|n POPpx||5.005030|n POPp|||n POPs|||n PTR2IV|5.006000||p PTR2NV|5.006000||p PTR2UV|5.006000||p PTR2ul|5.007001||p PTRV|5.006000||p PUSHMARK||| PUSH_MULTICALL||5.009005| PUSHi||| PUSHmortal|5.009002||p PUSHn||| PUSHp||| PUSHs||| PUSHu|5.004000||p PUTBACK||| PerlIO_clearerr||5.007003| PerlIO_close||5.007003| PerlIO_context_layers||5.009004| PerlIO_eof||5.007003| PerlIO_error||5.007003| PerlIO_fileno||5.007003| PerlIO_fill||5.007003| PerlIO_flush||5.007003| PerlIO_get_base||5.007003| PerlIO_get_bufsiz||5.007003| PerlIO_get_cnt||5.007003| PerlIO_get_ptr||5.007003| PerlIO_read||5.007003| PerlIO_seek||5.007003| PerlIO_set_cnt||5.007003| PerlIO_set_ptrcnt||5.007003| PerlIO_setlinebuf||5.007003| PerlIO_stderr||5.007003| PerlIO_stdin||5.007003| PerlIO_stdout||5.007003| PerlIO_tell||5.007003| PerlIO_unread||5.007003| PerlIO_write||5.007003| Perl_signbit||5.009005|n PoisonFree|5.009004||p PoisonNew|5.009004||p PoisonWith|5.009004||p Poison|5.008000||p RETVAL|||n Renewc||| Renew||| SAVECLEARSV||| SAVECOMPPAD||| SAVEPADSV||| SAVETMPS||| SAVE_DEFSV|5.004050||p SPAGAIN||| SP||| START_EXTERN_C|5.005000||p START_MY_CXT|5.007003||p STMT_END|||p STMT_START|||p STR_WITH_LEN|5.009003||p ST||| SV_CONST_RETURN|5.009003||p SV_COW_DROP_PV|5.008001||p SV_COW_SHARED_HASH_KEYS|5.009005||p SV_GMAGIC|5.007002||p SV_HAS_TRAILING_NUL|5.009004||p SV_IMMEDIATE_UNREF|5.007001||p SV_MUTABLE_RETURN|5.009003||p SV_NOSTEAL|5.009002||p SV_SMAGIC|5.009003||p SV_UTF8_NO_ENCODING|5.008001||p SVf|5.006000||p SVt_IV||| SVt_NV||| SVt_PVAV||| SVt_PVCV||| SVt_PVHV||| SVt_PVMG||| SVt_PV||| Safefree||| Slab_Alloc||| Slab_Free||| Slab_to_rw||| StructCopy||| SvCUR_set||| SvCUR||| SvEND||| SvGAMAGIC||5.006001| SvGETMAGIC|5.004050||p SvGROW||| SvIOK_UV||5.006000| SvIOK_notUV||5.006000| SvIOK_off||| SvIOK_only_UV||5.006000| SvIOK_only||| SvIOK_on||| SvIOKp||| SvIOK||| SvIVX||| SvIV_nomg|5.009001||p SvIV_set||| SvIVx||| SvIV||| SvIsCOW_shared_hash||5.008003| SvIsCOW||5.008003| SvLEN_set||| SvLEN||| SvLOCK||5.007003| SvMAGIC_set|5.009003||p SvNIOK_off||| SvNIOKp||| SvNIOK||| SvNOK_off||| SvNOK_only||| SvNOK_on||| SvNOKp||| SvNOK||| SvNVX||| SvNV_set||| SvNVx||| SvNV||| SvOK||| SvOOK||| SvPOK_off||| SvPOK_only_UTF8||5.006000| SvPOK_only||| SvPOK_on||| SvPOKp||| SvPOK||| SvPVX_const|5.009003||p SvPVX_mutable|5.009003||p SvPVX||| SvPV_const|5.009003||p SvPV_flags_const_nolen|5.009003||p SvPV_flags_const|5.009003||p SvPV_flags_mutable|5.009003||p SvPV_flags|5.007002||p SvPV_force_flags_mutable|5.009003||p SvPV_force_flags_nolen|5.009003||p SvPV_force_flags|5.007002||p SvPV_force_mutable|5.009003||p SvPV_force_nolen|5.009003||p SvPV_force_nomg_nolen|5.009003||p SvPV_force_nomg|5.007002||p SvPV_force|||p SvPV_mutable|5.009003||p SvPV_nolen_const|5.009003||p SvPV_nolen|5.006000||p SvPV_nomg_const_nolen|5.009003||p SvPV_nomg_const|5.009003||p SvPV_nomg|5.007002||p SvPV_set||| SvPVbyte_force||5.009002| SvPVbyte_nolen||5.006000| SvPVbytex_force||5.006000| SvPVbytex||5.006000| SvPVbyte|5.006000||p SvPVutf8_force||5.006000| SvPVutf8_nolen||5.006000| SvPVutf8x_force||5.006000| SvPVutf8x||5.006000| SvPVutf8||5.006000| SvPVx||| SvPV||| SvREFCNT_dec||| SvREFCNT_inc_NN|5.009004||p SvREFCNT_inc_simple_NN|5.009004||p SvREFCNT_inc_simple_void_NN|5.009004||p SvREFCNT_inc_simple_void|5.009004||p SvREFCNT_inc_simple|5.009004||p SvREFCNT_inc_void_NN|5.009004||p SvREFCNT_inc_void|5.009004||p SvREFCNT_inc|||p SvREFCNT||| SvROK_off||| SvROK_on||| SvROK||| SvRV_set|5.009003||p SvRV||| SvRXOK||5.009005| SvRX||5.009005| SvSETMAGIC||| SvSHARED_HASH|5.009003||p SvSHARE||5.007003| SvSTASH_set|5.009003||p SvSTASH||| SvSetMagicSV_nosteal||5.004000| SvSetMagicSV||5.004000| SvSetSV_nosteal||5.004000| SvSetSV||| SvTAINTED_off||5.004000| SvTAINTED_on||5.004000| SvTAINTED||5.004000| SvTAINT||| SvTRUE||| SvTYPE||| SvUNLOCK||5.007003| SvUOK|5.007001|5.006000|p SvUPGRADE||| SvUTF8_off||5.006000| SvUTF8_on||5.006000| SvUTF8||5.006000| SvUVXx|5.004000||p SvUVX|5.004000||p SvUV_nomg|5.009001||p SvUV_set|5.009003||p SvUVx|5.004000||p SvUV|5.004000||p SvVOK||5.008001| SvVSTRING_mg|5.009004||p THIS|||n UNDERBAR|5.009002||p UTF8_MAXBYTES|5.009002||p UVSIZE|5.006000||p UVTYPE|5.006000||p UVXf|5.007001||p UVof|5.006000||p UVuf|5.006000||p UVxf|5.006000||p WARN_ALL|5.006000||p WARN_AMBIGUOUS|5.006000||p WARN_ASSERTIONS|5.009005||p WARN_BAREWORD|5.006000||p WARN_CLOSED|5.006000||p WARN_CLOSURE|5.006000||p WARN_DEBUGGING|5.006000||p WARN_DEPRECATED|5.006000||p WARN_DIGIT|5.006000||p WARN_EXEC|5.006000||p WARN_EXITING|5.006000||p WARN_GLOB|5.006000||p WARN_INPLACE|5.006000||p WARN_INTERNAL|5.006000||p WARN_IO|5.006000||p WARN_LAYER|5.008000||p WARN_MALLOC|5.006000||p WARN_MISC|5.006000||p WARN_NEWLINE|5.006000||p WARN_NUMERIC|5.006000||p WARN_ONCE|5.006000||p WARN_OVERFLOW|5.006000||p WARN_PACK|5.006000||p WARN_PARENTHESIS|5.006000||p WARN_PIPE|5.006000||p WARN_PORTABLE|5.006000||p WARN_PRECEDENCE|5.006000||p WARN_PRINTF|5.006000||p WARN_PROTOTYPE|5.006000||p WARN_QW|5.006000||p WARN_RECURSION|5.006000||p WARN_REDEFINE|5.006000||p WARN_REGEXP|5.006000||p WARN_RESERVED|5.006000||p WARN_SEMICOLON|5.006000||p WARN_SEVERE|5.006000||p WARN_SIGNAL|5.006000||p WARN_SUBSTR|5.006000||p WARN_SYNTAX|5.006000||p WARN_TAINT|5.006000||p WARN_THREADS|5.008000||p WARN_UNINITIALIZED|5.006000||p WARN_UNOPENED|5.006000||p WARN_UNPACK|5.006000||p WARN_UNTIE|5.006000||p WARN_UTF8|5.006000||p WARN_VOID|5.006000||p XCPT_CATCH|5.009002||p XCPT_RETHROW|5.009002||p XCPT_TRY_END|5.009002||p XCPT_TRY_START|5.009002||p XPUSHi||| XPUSHmortal|5.009002||p XPUSHn||| XPUSHp||| XPUSHs||| XPUSHu|5.004000||p XSRETURN_EMPTY||| XSRETURN_IV||| XSRETURN_NO||| XSRETURN_NV||| XSRETURN_PV||| XSRETURN_UNDEF||| XSRETURN_UV|5.008001||p XSRETURN_YES||| XSRETURN|||p XST_mIV||| XST_mNO||| XST_mNV||| XST_mPV||| XST_mUNDEF||| XST_mUV|5.008001||p XST_mYES||| XS_VERSION_BOOTCHECK||| XS_VERSION||| XSprePUSH|5.006000||p XS||| ZeroD|5.009002||p Zero||| _aMY_CXT|5.007003||p _pMY_CXT|5.007003||p aMY_CXT_|5.007003||p aMY_CXT|5.007003||p aTHXR_|5.009005||p aTHXR|5.009005||p aTHX_|5.006000||p aTHX|5.006000||p add_data|||n addmad||| allocmy||| amagic_call||| amagic_cmp_locale||| amagic_cmp||| amagic_i_ncmp||| amagic_ncmp||| any_dup||| ao||| append_elem||| append_list||| append_madprops||| apply_attrs_my||| apply_attrs_string||5.006001| apply_attrs||| apply||| atfork_lock||5.007003|n atfork_unlock||5.007003|n av_arylen_p||5.009003| av_clear||| av_create_and_push||5.009005| av_create_and_unshift_one||5.009005| av_delete||5.006000| av_exists||5.006000| av_extend||| av_fake||| av_fetch||| av_fill||| av_len||| av_make||| av_pop||| av_push||| av_reify||| av_shift||| av_store||| av_undef||| av_unshift||| ax|||n bad_type||| bind_match||| block_end||| block_gimme||5.004000| block_start||| boolSV|5.004000||p boot_core_PerlIO||| boot_core_UNIVERSAL||| boot_core_mro||| boot_core_xsutils||| bytes_from_utf8||5.007001| bytes_to_uni|||n bytes_to_utf8||5.006001| call_argv|5.006000||p call_atexit||5.006000| call_list||5.004000| call_method|5.006000||p call_pv|5.006000||p call_sv|5.006000||p calloc||5.007002|n cando||| cast_i32||5.006000| cast_iv||5.006000| cast_ulong||5.006000| cast_uv||5.006000| check_type_and_open||| check_uni||| checkcomma||| checkposixcc||| ckWARN|5.006000||p ck_anoncode||| ck_bitop||| ck_concat||| ck_defined||| ck_delete||| ck_die||| ck_eof||| ck_eval||| ck_exec||| ck_exists||| ck_exit||| ck_ftst||| ck_fun||| ck_glob||| ck_grep||| ck_index||| ck_join||| ck_lengthconst||| ck_lfun||| ck_listiob||| ck_match||| ck_method||| ck_null||| ck_open||| ck_readline||| ck_repeat||| ck_require||| ck_retarget||| ck_return||| ck_rfun||| ck_rvconst||| ck_sassign||| ck_select||| ck_shift||| ck_sort||| ck_spair||| ck_split||| ck_subr||| ck_substr||| ck_svconst||| ck_trunc||| ck_unpack||| ckwarn_d||5.009003| ckwarn||5.009003| cl_and|||n cl_anything|||n cl_init_zero|||n cl_init|||n cl_is_anything|||n cl_or|||n clear_placeholders||| closest_cop||| convert||| cop_free||| cr_textfilter||| create_eval_scope||| croak_nocontext|||vn croak|||v csighandler||5.009003|n curmad||| custom_op_desc||5.007003| custom_op_name||5.007003| cv_ckproto_len||| cv_ckproto||| cv_clone||| cv_const_sv||5.004000| cv_dump||| cv_undef||| cx_dump||5.005000| cx_dup||| cxinc||| dAXMARK|5.009003||p dAX|5.007002||p dITEMS|5.007002||p dMARK||| dMULTICALL||5.009003| dMY_CXT_SV|5.007003||p dMY_CXT|5.007003||p dNOOP|5.006000||p dORIGMARK||| dSP||| dTHR|5.004050||p dTHXR|5.009005||p dTHXa|5.006000||p dTHXoa|5.006000||p dTHX|5.006000||p dUNDERBAR|5.009002||p dVAR|5.009003||p dXCPT|5.009002||p dXSARGS||| dXSI32||| dXSTARG|5.006000||p deb_curcv||| deb_nocontext|||vn deb_stack_all||| deb_stack_n||| debop||5.005000| debprofdump||5.005000| debprof||| debstackptrs||5.007003| debstack||5.007003| debug_start_match||| deb||5.007003|v del_sv||| delete_eval_scope||| delimcpy||5.004000| deprecate_old||| deprecate||| despatch_signals||5.007001| destroy_matcher||| die_nocontext|||vn die_where||| die|||v dirp_dup||| div128||| djSP||| do_aexec5||| do_aexec||| do_aspawn||| do_binmode||5.004050| do_chomp||| do_chop||| do_close||| do_dump_pad||| do_eof||| do_exec3||| do_execfree||| do_exec||| do_gv_dump||5.006000| do_gvgv_dump||5.006000| do_hv_dump||5.006000| do_ipcctl||| do_ipcget||| do_join||| do_kv||| do_magic_dump||5.006000| do_msgrcv||| do_msgsnd||| do_oddball||| do_op_dump||5.006000| do_op_xmldump||| do_open9||5.006000| do_openn||5.007001| do_open||5.004000| do_pipe||| do_pmop_dump||5.006000| do_pmop_xmldump||| do_print||| do_readline||| do_seek||| do_semop||| do_shmio||| do_smartmatch||| do_spawn_nowait||| do_spawn||| do_sprintf||| do_sv_dump||5.006000| do_sysseek||| do_tell||| do_trans_complex_utf8||| do_trans_complex||| do_trans_count_utf8||| do_trans_count||| do_trans_simple_utf8||| do_trans_simple||| do_trans||| do_vecget||| do_vecset||| do_vop||| docatch_body||| docatch||| doeval||| dofile||| dofindlabel||| doform||| doing_taint||5.008001|n dooneliner||| doopen_pm||| doparseform||| dopoptoeval||| dopoptogiven||| dopoptolabel||| dopoptoloop||| dopoptosub_at||| dopoptosub||| dopoptowhen||| doref||5.009003| dounwind||| dowantarray||| dump_all||5.006000| dump_eval||5.006000| dump_exec_pos||| dump_fds||| dump_form||5.006000| dump_indent||5.006000|v dump_mstats||| dump_packsubs||5.006000| dump_sub||5.006000| dump_sv_child||| dump_trie_interim_list||| dump_trie_interim_table||| dump_trie||| dump_vindent||5.006000| dumpuntil||| dup_attrlist||| emulate_cop_io||| emulate_eaccess||| eval_pv|5.006000||p eval_sv|5.006000||p exec_failed||| expect_number||| fbm_compile||5.005000| fbm_instr||5.005000| fd_on_nosuid_fs||| feature_is_enabled||| filter_add||| filter_del||| filter_gets||| filter_read||| find_and_forget_pmops||| find_array_subscript||| find_beginning||| find_byclass||| find_hash_subscript||| find_in_my_stash||| find_runcv||5.008001| find_rundefsvoffset||5.009002| find_script||| find_uninit_var||| first_symbol|||n fold_constants||| forbid_setid||| force_ident||| force_list||| force_next||| force_version||| force_word||| forget_pmop||| form_nocontext|||vn form||5.004000|v fp_dup||| fprintf_nocontext|||vn free_global_struct||| free_tied_hv_pool||| free_tmps||| gen_constant_list||| get_arena||| get_av|5.006000||p get_context||5.006000|n get_cvn_flags||5.009005| get_cv|5.006000||p get_db_sub||| get_debug_opts||| get_hash_seed||| get_hv|5.006000||p get_mstats||| get_no_modify||| get_num||| get_op_descs||5.005000| get_op_names||5.005000| get_opargs||| get_ppaddr||5.006000| get_re_arg||| get_sv|5.006000||p get_vtbl||5.005030| getcwd_sv||5.007002| getenv_len||| glob_2number||| glob_2pv||| glob_assign_glob||| glob_assign_ref||| gp_dup||| gp_free||| gp_ref||| grok_bin|5.007003||p grok_hex|5.007003||p grok_number|5.007002||p grok_numeric_radix|5.007002||p grok_oct|5.007003||p group_end||| gv_AVadd||| gv_HVadd||| gv_IOadd||| gv_SVadd||| gv_autoload4||5.004000| gv_check||| gv_const_sv||5.009003| gv_dump||5.006000| gv_efullname3||5.004000| gv_efullname4||5.006001| gv_efullname||| gv_ename||| gv_fetchfile_flags||5.009005| gv_fetchfile||| gv_fetchmeth_autoload||5.007003| gv_fetchmethod_autoload||5.004000| gv_fetchmethod||| gv_fetchmeth||| gv_fetchpvn_flags||5.009002| gv_fetchpv||| gv_fetchsv||5.009002| gv_fullname3||5.004000| gv_fullname4||5.006001| gv_fullname||| gv_handler||5.007001| gv_init_sv||| gv_init||| gv_name_set||5.009004| gv_stashpvn|5.004000||p gv_stashpvs||5.009003| gv_stashpv||| gv_stashsv||| he_dup||| hek_dup||| hfreeentries||| hsplit||| hv_assert||5.009005| hv_auxinit|||n hv_backreferences_p||| hv_clear_placeholders||5.009001| hv_clear||| hv_copy_hints_hv||| hv_delayfree_ent||5.004000| hv_delete_common||| hv_delete_ent||5.004000| hv_delete||| hv_eiter_p||5.009003| hv_eiter_set||5.009003| hv_exists_ent||5.004000| hv_exists||| hv_fetch_common||| hv_fetch_ent||5.004000| hv_fetchs|5.009003||p hv_fetch||| hv_free_ent||5.004000| hv_iterinit||| hv_iterkeysv||5.004000| hv_iterkey||| hv_iternext_flags||5.008000| hv_iternextsv||| hv_iternext||| hv_iterval||| hv_kill_backrefs||| hv_ksplit||5.004000| hv_magic_check|||n hv_magic_uvar_xkey||| hv_magic||| hv_name_set||5.009003| hv_notallowed||| hv_placeholders_get||5.009003| hv_placeholders_p||5.009003| hv_placeholders_set||5.009003| hv_riter_p||5.009003| hv_riter_set||5.009003| hv_scalar||5.009001| hv_store_ent||5.004000| hv_store_flags||5.008000| hv_stores|5.009004||p hv_store||| hv_undef||| ibcmp_locale||5.004000| ibcmp_utf8||5.007003| ibcmp||| incl_perldb||| incline||| incpush_if_exists||| incpush||| ingroup||| init_argv_symbols||| init_debugger||| init_global_struct||| init_i18nl10n||5.006000| init_i18nl14n||5.006000| init_ids||| init_interp||| init_main_stash||| init_perllib||| init_postdump_symbols||| init_predump_symbols||| init_stacks||5.005000| init_tm||5.007002| instr||| intro_my||| intuit_method||| intuit_more||| invert||| io_close||| isALNUM||| isALPHA||| isDIGIT||| isLOWER||| isSPACE||| isUPPER||| is_an_int||| is_gv_magical_sv||| is_gv_magical||| is_handle_constructor|||n is_list_assignment||| is_lvalue_sub||5.007001| is_uni_alnum_lc||5.006000| is_uni_alnumc_lc||5.006000| is_uni_alnumc||5.006000| is_uni_alnum||5.006000| is_uni_alpha_lc||5.006000| is_uni_alpha||5.006000| is_uni_ascii_lc||5.006000| is_uni_ascii||5.006000| is_uni_cntrl_lc||5.006000| is_uni_cntrl||5.006000| is_uni_digit_lc||5.006000| is_uni_digit||5.006000| is_uni_graph_lc||5.006000| is_uni_graph||5.006000| is_uni_idfirst_lc||5.006000| is_uni_idfirst||5.006000| is_uni_lower_lc||5.006000| is_uni_lower||5.006000| is_uni_print_lc||5.006000| is_uni_print||5.006000| is_uni_punct_lc||5.006000| is_uni_punct||5.006000| is_uni_space_lc||5.006000| is_uni_space||5.006000| is_uni_upper_lc||5.006000| is_uni_upper||5.006000| is_uni_xdigit_lc||5.006000| is_uni_xdigit||5.006000| is_utf8_alnumc||5.006000| is_utf8_alnum||5.006000| is_utf8_alpha||5.006000| is_utf8_ascii||5.006000| is_utf8_char_slow|||n is_utf8_char||5.006000| is_utf8_cntrl||5.006000| is_utf8_common||| is_utf8_digit||5.006000| is_utf8_graph||5.006000| is_utf8_idcont||5.008000| is_utf8_idfirst||5.006000| is_utf8_lower||5.006000| is_utf8_mark||5.006000| is_utf8_print||5.006000| is_utf8_punct||5.006000| is_utf8_space||5.006000| is_utf8_string_loclen||5.009003| is_utf8_string_loc||5.008001| is_utf8_string||5.006001| is_utf8_upper||5.006000| is_utf8_xdigit||5.006000| isa_lookup||| items|||n ix|||n jmaybe||| join_exact||| keyword||| leave_scope||| lex_end||| lex_start||| linklist||| listkids||| list||| load_module_nocontext|||vn load_module|5.006000||pv localize||| looks_like_bool||| looks_like_number||| lop||| mPUSHi|5.009002||p mPUSHn|5.009002||p mPUSHp|5.009002||p mPUSHu|5.009002||p mXPUSHi|5.009002||p mXPUSHn|5.009002||p mXPUSHp|5.009002||p mXPUSHu|5.009002||p mad_free||| madlex||| madparse||| magic_clear_all_env||| magic_clearenv||| magic_clearhint||| magic_clearpack||| magic_clearsig||| magic_dump||5.006000| magic_existspack||| magic_freearylen_p||| magic_freeovrld||| magic_freeregexp||| magic_getarylen||| magic_getdefelem||| magic_getnkeys||| magic_getpack||| magic_getpos||| magic_getsig||| magic_getsubstr||| magic_gettaint||| magic_getuvar||| magic_getvec||| magic_get||| magic_killbackrefs||| magic_len||| magic_methcall||| magic_methpack||| magic_nextpack||| magic_regdata_cnt||| magic_regdatum_get||| magic_regdatum_set||| magic_scalarpack||| magic_set_all_env||| magic_setamagic||| magic_setarylen||| magic_setbm||| magic_setcollxfrm||| magic_setdbline||| magic_setdefelem||| magic_setenv||| magic_setfm||| magic_setglob||| magic_sethint||| magic_setisa||| magic_setmglob||| magic_setnkeys||| magic_setpack||| magic_setpos||| magic_setregexp||| magic_setsig||| magic_setsubstr||| magic_settaint||| magic_setutf8||| magic_setuvar||| magic_setvec||| magic_set||| magic_sizepack||| magic_wipepack||| magicname||| make_matcher||| make_trie_failtable||| make_trie||| malloced_size|||n malloc||5.007002|n markstack_grow||| matcher_matches_sv||| measure_struct||| memEQ|5.004000||p memNE|5.004000||p mem_collxfrm||| mess_alloc||| mess_nocontext|||vn mess||5.006000|v method_common||| mfree||5.007002|n mg_clear||| mg_copy||| mg_dup||| mg_find||| mg_free||| mg_get||| mg_length||5.005000| mg_localize||| mg_magical||| mg_set||| mg_size||5.005000| mini_mktime||5.007002| missingterm||| mode_from_discipline||| modkids||| mod||| more_bodies||| more_sv||| moreswitches||| mro_get_linear_isa_c3||5.009005| mro_get_linear_isa_dfs||5.009005| mro_get_linear_isa||5.009005| mro_isa_changed_in||| mro_meta_dup||| mro_meta_init||| mro_method_changed_in||5.009005| mul128||| mulexp10|||n my_atof2||5.007002| my_atof||5.006000| my_attrs||| my_bcopy|||n my_betoh16|||n my_betoh32|||n my_betoh64|||n my_betohi|||n my_betohl|||n my_betohs|||n my_bzero|||n my_chsize||| my_clearenv||| my_cxt_index||| my_cxt_init||| my_dirfd||5.009005| my_exit_jump||| my_exit||| my_failure_exit||5.004000| my_fflush_all||5.006000| my_fork||5.007003|n my_htobe16|||n my_htobe32|||n my_htobe64|||n my_htobei|||n my_htobel|||n my_htobes|||n my_htole16|||n my_htole32|||n my_htole64|||n my_htolei|||n my_htolel|||n my_htoles|||n my_htonl||| my_kid||| my_letoh16|||n my_letoh32|||n my_letoh64|||n my_letohi|||n my_letohl|||n my_letohs|||n my_lstat||| my_memcmp||5.004000|n my_memset|||n my_ntohl||| my_pclose||5.004000| my_popen_list||5.007001| my_popen||5.004000| my_setenv||| my_snprintf|5.009004||pvn my_socketpair||5.007003|n my_sprintf||5.009003|vn my_stat||| my_strftime||5.007002| my_strlcat|5.009004||pn my_strlcpy|5.009004||pn my_swabn|||n my_swap||| my_unexec||| my_vsnprintf||5.009004|n my||| need_utf8|||n newANONATTRSUB||5.006000| newANONHASH||| newANONLIST||| newANONSUB||| newASSIGNOP||| newATTRSUB||5.006000| newAVREF||| newAV||| newBINOP||| newCONDOP||| newCONSTSUB|5.004050||p newCVREF||| newDEFSVOP||| newFORM||| newFOROP||| newGIVENOP||5.009003| newGIVWHENOP||| newGP||| newGVOP||| newGVREF||| newGVgen||| newHVREF||| newHVhv||5.005000| newHV||| newIO||| newLISTOP||| newLOGOP||| newLOOPEX||| newLOOPOP||| newMADPROP||| newMADsv||| newMYSUB||| newNULLLIST||| newOP||| newPADOP||| newPMOP||| newPROG||| newPVOP||| newRANGE||| newRV_inc|5.004000||p newRV_noinc|5.004000||p newRV||| newSLICEOP||| newSTATEOP||| newSUB||| newSVOP||| newSVREF||| newSV_type||5.009005| newSVhek||5.009003| newSViv||| newSVnv||| newSVpvf_nocontext|||vn newSVpvf||5.004000|v newSVpvn_share|5.007001||p newSVpvn|5.004050||p newSVpvs_share||5.009003| newSVpvs|5.009003||p newSVpv||| newSVrv||| newSVsv||| newSVuv|5.006000||p newSV||| newTOKEN||| newUNOP||| newWHENOP||5.009003| newWHILEOP||5.009003| newXS_flags||5.009004| newXSproto||5.006000| newXS||5.006000| new_collate||5.006000| new_constant||| new_ctype||5.006000| new_he||| new_logop||| new_numeric||5.006000| new_stackinfo||5.005000| new_version||5.009000| new_warnings_bitfield||| next_symbol||| nextargv||| nextchar||| ninstr||| no_bareword_allowed||| no_fh_allowed||| no_op||| not_a_number||| nothreadhook||5.008000| nuke_stacks||| num_overflow|||n offer_nice_chunk||| oopsAV||| oopsCV||| oopsHV||| op_clear||| op_const_sv||| op_dump||5.006000| op_free||| op_getmad_weak||| op_getmad||| op_null||5.007002| op_refcnt_dec||| op_refcnt_inc||| op_refcnt_lock||5.009002| op_refcnt_unlock||5.009002| op_xmldump||| open_script||| pMY_CXT_|5.007003||p pMY_CXT|5.007003||p pTHX_|5.006000||p pTHX|5.006000||p packWARN|5.007003||p pack_cat||5.007003| pack_rec||| package||| packlist||5.008001| pad_add_anon||| pad_add_name||| pad_alloc||| pad_block_start||| pad_check_dup||| pad_compname_type||| pad_findlex||| pad_findmy||| pad_fixup_inner_anons||| pad_free||| pad_leavemy||| pad_new||| pad_peg|||n pad_push||| pad_reset||| pad_setsv||| pad_sv||5.009005| pad_swipe||| pad_tidy||| pad_undef||| parse_body||| parse_unicode_opts||| parser_dup||| parser_free||| path_is_absolute|||n peep||| pending_Slabs_to_ro||| perl_alloc_using|||n perl_alloc|||n perl_clone_using|||n perl_clone|||n perl_construct|||n perl_destruct||5.007003|n perl_free|||n perl_parse||5.006000|n perl_run|||n pidgone||| pm_description||| pmflag||| pmop_dump||5.006000| pmop_xmldump||| pmruntime||| pmtrans||| pop_scope||| pregcomp||5.009005| pregexec||| pregfree||| prepend_elem||| prepend_madprops||| printbuf||| printf_nocontext|||vn process_special_blocks||| ptr_table_clear||5.009005| ptr_table_fetch||5.009005| ptr_table_find|||n ptr_table_free||5.009005| ptr_table_new||5.009005| ptr_table_split||5.009005| ptr_table_store||5.009005| push_scope||| put_byte||| pv_display||5.006000| pv_escape||5.009004| pv_pretty||5.009004| pv_uni_display||5.007003| qerror||| qsortsvu||| re_compile||5.009005| re_croak2||| re_dup||| re_intuit_start||5.009005| re_intuit_string||5.006000| readpipe_override||| realloc||5.007002|n reentrant_free||| reentrant_init||| reentrant_retry|||vn reentrant_size||| ref_array_or_hash||| refcounted_he_chain_2hv||| refcounted_he_fetch||| refcounted_he_free||| refcounted_he_new||| refcounted_he_value||| refkids||| refto||| ref||5.009003| reg_check_named_buff_matched||| reg_named_buff_all||5.009005| reg_named_buff_exists||5.009005| reg_named_buff_fetch||5.009005| reg_named_buff_firstkey||5.009005| reg_named_buff_iter||| reg_named_buff_nextkey||5.009005| reg_named_buff_scalar||5.009005| reg_named_buff||| reg_namedseq||| reg_node||| reg_numbered_buff_fetch||| reg_numbered_buff_length||| reg_numbered_buff_store||| reg_qr_package||| reg_recode||| reg_scan_name||| reg_skipcomment||| reg_stringify||5.009005| reg_temp_copy||| reganode||| regatom||| regbranch||| regclass_swash||5.009004| regclass||| regcppop||| regcppush||| regcurly|||n regdump_extflags||| regdump||5.005000| regdupe_internal||| regexec_flags||5.005000| regfree_internal||5.009005| reghop3|||n reghop4|||n reghopmaybe3|||n reginclass||| reginitcolors||5.006000| reginsert||| regmatch||| regnext||5.005000| regpiece||| regpposixcc||| regprop||| regrepeat||| regtail_study||| regtail||| regtry||| reguni||| regwhite|||n reg||| repeatcpy||| report_evil_fh||| report_uninit||| require_pv||5.006000| require_tie_mod||| restore_magic||| rninstr||| rsignal_restore||| rsignal_save||| rsignal_state||5.004000| rsignal||5.004000| run_body||| run_user_filter||| runops_debug||5.005000| runops_standard||5.005000| rvpv_dup||| rxres_free||| rxres_restore||| rxres_save||| safesyscalloc||5.006000|n safesysfree||5.006000|n safesysmalloc||5.006000|n safesysrealloc||5.006000|n same_dirent||| save_I16||5.004000| save_I32||| save_I8||5.006000| save_aelem||5.004050| save_alloc||5.006000| save_aptr||| save_ary||| save_bool||5.008001| save_clearsv||| save_delete||| save_destructor_x||5.006000| save_destructor||5.006000| save_freeop||| save_freepv||| save_freesv||| save_generic_pvref||5.006001| save_generic_svref||5.005030| save_gp||5.004000| save_hash||| save_hek_flags|||n save_helem||5.004050| save_hints||5.005000| save_hptr||| save_int||| save_item||| save_iv||5.005000| save_lines||| save_list||| save_long||| save_magic||| save_mortalizesv||5.007001| save_nogv||| save_op||| save_padsv||5.007001| save_pptr||| save_re_context||5.006000| save_scalar_at||| save_scalar||| save_set_svflags||5.009000| save_shared_pvref||5.007003| save_sptr||| save_svref||| save_vptr||5.006000| savepvn||| savepvs||5.009003| savepv||| savesharedpvn||5.009005| savesharedpv||5.007003| savestack_grow_cnt||5.008001| savestack_grow||| savesvpv||5.009002| sawparens||| scalar_mod_type|||n scalarboolean||| scalarkids||| scalarseq||| scalarvoid||| scalar||| scan_bin||5.006000| scan_commit||| scan_const||| scan_formline||| scan_heredoc||| scan_hex||| scan_ident||| scan_inputsymbol||| scan_num||5.007001| scan_oct||| scan_pat||| scan_str||| scan_subst||| scan_trans||| scan_version||5.009001| scan_vstring||5.009005| scan_word||| scope||| screaminstr||5.005000| seed||5.008001| sequence_num||| sequence_tail||| sequence||| set_context||5.006000|n set_csh||| set_numeric_local||5.006000| set_numeric_radix||5.006000| set_numeric_standard||5.006000| setdefout||| setenv_getix||| share_hek_flags||| share_hek||5.004000| si_dup||| sighandler|||n simplify_sort||| skipspace0||| skipspace1||| skipspace2||| skipspace||| softref2xv||| sortcv_stacked||| sortcv_xsub||| sortcv||| sortsv_flags||5.009003| sortsv||5.007003| space_join_names_mortal||| ss_dup||| stack_grow||| start_force||| start_glob||| start_subparse||5.004000| stashpv_hvname_match||5.009005| stdize_locale||| strEQ||| strGE||| strGT||| strLE||| strLT||| strNE||| str_to_version||5.006000| strip_return||| strnEQ||| strnNE||| study_chunk||| sub_crush_depth||| sublex_done||| sublex_push||| sublex_start||| sv_2bool||| sv_2cv||| sv_2io||| sv_2iuv_common||| sv_2iuv_non_preserve||| sv_2iv_flags||5.009001| sv_2iv||| sv_2mortal||| sv_2nv||| sv_2pv_flags|5.007002||p sv_2pv_nolen|5.006000||p sv_2pvbyte_nolen|5.006000||p sv_2pvbyte|5.006000||p sv_2pvutf8_nolen||5.006000| sv_2pvutf8||5.006000| sv_2pv||| sv_2uv_flags||5.009001| sv_2uv|5.004000||p sv_add_arena||| sv_add_backref||| sv_backoff||| sv_bless||| sv_cat_decode||5.008001| sv_catpv_mg|5.004050||p sv_catpvf_mg_nocontext|||pvn sv_catpvf_mg|5.006000|5.004000|pv sv_catpvf_nocontext|||vn sv_catpvf||5.004000|v sv_catpvn_flags||5.007002| sv_catpvn_mg|5.004050||p sv_catpvn_nomg|5.007002||p sv_catpvn||| sv_catpvs|5.009003||p sv_catpv||| sv_catsv_flags||5.007002| sv_catsv_mg|5.004050||p sv_catsv_nomg|5.007002||p sv_catsv||| sv_catxmlpvn||| sv_catxmlsv||| sv_chop||| sv_clean_all||| sv_clean_objs||| sv_clear||| sv_cmp_locale||5.004000| sv_cmp||| sv_collxfrm||| sv_compile_2op||5.008001| sv_copypv||5.007003| sv_dec||| sv_del_backref||| sv_derived_from||5.004000| sv_does||5.009004| sv_dump||| sv_dup||| sv_eq||| sv_exp_grow||| sv_force_normal_flags||5.007001| sv_force_normal||5.006000| sv_free2||| sv_free_arenas||| sv_free||| sv_gets||5.004000| sv_grow||| sv_i_ncmp||| sv_inc||| sv_insert||| sv_isa||| sv_isobject||| sv_iv||5.005000| sv_kill_backrefs||| sv_len_utf8||5.006000| sv_len||| sv_magic_portable|5.009005|5.004000|p sv_magicext||5.007003| sv_magic||| sv_mortalcopy||| sv_ncmp||| sv_newmortal||| sv_newref||| sv_nolocking||5.007003| sv_nosharing||5.007003| sv_nounlocking||| sv_nv||5.005000| sv_peek||5.005000| sv_pos_b2u_midway||| sv_pos_b2u||5.006000| sv_pos_u2b_cached||| sv_pos_u2b_forwards|||n sv_pos_u2b_midway|||n sv_pos_u2b||5.006000| sv_pvbyten_force||5.006000| sv_pvbyten||5.006000| sv_pvbyte||5.006000| sv_pvn_force_flags|5.007002||p sv_pvn_force||| sv_pvn_nomg|5.007003||p sv_pvn||| sv_pvutf8n_force||5.006000| sv_pvutf8n||5.006000| sv_pvutf8||5.006000| sv_pv||5.006000| sv_recode_to_utf8||5.007003| sv_reftype||| sv_release_COW||| sv_replace||| sv_report_used||| sv_reset||| sv_rvweaken||5.006000| sv_setiv_mg|5.004050||p sv_setiv||| sv_setnv_mg|5.006000||p sv_setnv||| sv_setpv_mg|5.004050||p sv_setpvf_mg_nocontext|||pvn sv_setpvf_mg|5.006000|5.004000|pv sv_setpvf_nocontext|||vn sv_setpvf||5.004000|v sv_setpviv_mg||5.008001| sv_setpviv||5.008001| sv_setpvn_mg|5.004050||p sv_setpvn||| sv_setpvs|5.009004||p sv_setpv||| sv_setref_iv||| sv_setref_nv||| sv_setref_pvn||| sv_setref_pv||| sv_setref_uv||5.007001| sv_setsv_cow||| sv_setsv_flags||5.007002| sv_setsv_mg|5.004050||p sv_setsv_nomg|5.007002||p sv_setsv||| sv_setuv_mg|5.004050||p sv_setuv|5.004000||p sv_tainted||5.004000| sv_taint||5.004000| sv_true||5.005000| sv_unglob||| sv_uni_display||5.007003| sv_unmagic||| sv_unref_flags||5.007001| sv_unref||| sv_untaint||5.004000| sv_upgrade||| sv_usepvn_flags||5.009004| sv_usepvn_mg|5.004050||p sv_usepvn||| sv_utf8_decode||5.006000| sv_utf8_downgrade||5.006000| sv_utf8_encode||5.006000| sv_utf8_upgrade_flags||5.007002| sv_utf8_upgrade||5.007001| sv_uv|5.005000||p sv_vcatpvf_mg|5.006000|5.004000|p sv_vcatpvfn||5.004000| sv_vcatpvf|5.006000|5.004000|p sv_vsetpvf_mg|5.006000|5.004000|p sv_vsetpvfn||5.004000| sv_vsetpvf|5.006000|5.004000|p sv_xmlpeek||| svtype||| swallow_bom||| swap_match_buff||| swash_fetch||5.007002| swash_get||| swash_init||5.006000| sys_intern_clear||| sys_intern_dup||| sys_intern_init||| taint_env||| taint_proper||| tmps_grow||5.006000| toLOWER||| toUPPER||| to_byte_substr||| to_uni_fold||5.007003| to_uni_lower_lc||5.006000| to_uni_lower||5.007003| to_uni_title_lc||5.006000| to_uni_title||5.007003| to_uni_upper_lc||5.006000| to_uni_upper||5.007003| to_utf8_case||5.007003| to_utf8_fold||5.007003| to_utf8_lower||5.007003| to_utf8_substr||| to_utf8_title||5.007003| to_utf8_upper||5.007003| token_free||| token_getmad||| tokenize_use||| tokeq||| tokereport||| too_few_arguments||| too_many_arguments||| uiv_2buf|||n unlnk||| unpack_rec||| unpack_str||5.007003| unpackstring||5.008001| unshare_hek_or_pvn||| unshare_hek||| unsharepvn||5.004000| unwind_handler_stack||| update_debugger_info||| upg_version||5.009005| usage||| utf16_to_utf8_reversed||5.006001| utf16_to_utf8||5.006001| utf8_distance||5.006000| utf8_hop||5.006000| utf8_length||5.007001| utf8_mg_pos_cache_update||| utf8_to_bytes||5.006001| utf8_to_uvchr||5.007001| utf8_to_uvuni||5.007001| utf8n_to_uvchr||| utf8n_to_uvuni||5.007001| utilize||| uvchr_to_utf8_flags||5.007003| uvchr_to_utf8||| uvuni_to_utf8_flags||5.007003| uvuni_to_utf8||5.007001| validate_suid||| varname||| vcmp||5.009000| vcroak||5.006000| vdeb||5.007003| vdie_common||| vdie_croak_common||| vdie||| vform||5.006000| visit||| vivify_defelem||| vivify_ref||| vload_module|5.006000||p vmess||5.006000| vnewSVpvf|5.006000|5.004000|p vnormal||5.009002| vnumify||5.009000| vstringify||5.009000| vverify||5.009003| vwarner||5.006000| vwarn||5.006000| wait4pid||| warn_nocontext|||vn warner_nocontext|||vn warner|5.006000|5.004000|pv warn|||v watch||| whichsig||| write_no_mem||| write_to_stderr||| xmldump_all||| xmldump_attr||| xmldump_eval||| xmldump_form||| xmldump_indent|||v xmldump_packsubs||| xmldump_sub||| xmldump_vindent||| yyerror||| yylex||| yyparse||| yywarn||| ); if (exists $opt{'list-unsupported'}) { my $f; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $API{$f}{todo}; print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; } exit 0; } # Scan for possible replacement candidates my(%replace, %need, %hints, %warnings, %depends); my $replace = 0; my($hint, $define, $function); sub find_api { my $code = shift; $code =~ s{ / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) | "[^"\\]*(?:\\.[^"\\]*)*" | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx; grep { exists $API{$_} } $code =~ /(\w+)/mg; } while () { if ($hint) { my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings; if (m{^\s*\*\s(.*?)\s*$}) { for (@{$hint->[1]}) { $h->{$_} ||= ''; # suppress warning with older perls $h->{$_} .= "$1\n"; } } else { undef $hint } } $hint = [$1, [split /,?\s+/, $2]] if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$}; if ($define) { if ($define->[1] =~ /\\$/) { $define->[1] .= $_; } else { if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) { my @n = find_api($define->[1]); push @{$depends{$define->[0]}}, @n if @n } undef $define; } } $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)}; if ($function) { if (/^}/) { if (exists $API{$function->[0]}) { my @n = find_api($function->[1]); push @{$depends{$function->[0]}}, @n if @n } undef $define; } else { $function->[1] .= $_; } } $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)}; $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; if (m{^\s*$rccs\s+(\w+)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { push @{$depends{$1}}, map { s/\s+//g; $_ } split /,/, $2; } $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; } for (values %depends) { my %s; $_ = [sort grep !$s{$_}++, @$_]; } if (exists $opt{'api-info'}) { my $f; my $count = 0; my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$"; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $f =~ /$match/; print "\n=== $f ===\n\n"; my $info = 0; if ($API{$f}{base} || $API{$f}{todo}) { my $base = format_version($API{$f}{base} || $API{$f}{todo}); print "Supported at least starting from perl-$base.\n"; $info++; } if ($API{$f}{provided}) { my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003"; print "Support by $ppport provided back to perl-$todo.\n"; print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f}; print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f}; print "\n$hints{$f}" if exists $hints{$f}; print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f}; $info++; } print "No portability information available.\n" unless $info; $count++; } $count or print "Found no API matching '$opt{'api-info'}'."; print "\n"; exit 0; } if (exists $opt{'list-provided'}) { my $f; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $API{$f}{provided}; my @flags; push @flags, 'explicit' if exists $need{$f}; push @flags, 'depend' if exists $depends{$f}; push @flags, 'hint' if exists $hints{$f}; push @flags, 'warning' if exists $warnings{$f}; my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; print "$f$flags\n"; } exit 0; } my @files; my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc ); my $srcext = join '|', map { quotemeta $_ } @srcext; if (@ARGV) { my %seen; for (@ARGV) { if (-e) { if (-f) { push @files, $_ unless $seen{$_}++; } else { warn "'$_' is not a file.\n" } } else { my @new = grep { -f } glob $_ or warn "'$_' does not exist.\n"; push @files, grep { !$seen{$_}++ } @new; } } } else { eval { require File::Find; File::Find::find(sub { $File::Find::name =~ /($srcext)$/i and push @files, $File::Find::name; }, '.'); }; if ($@) { @files = map { glob "*$_" } @srcext; } } if (!@ARGV || $opt{filter}) { my(@in, @out); my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files; for (@files) { my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i; push @{ $out ? \@out : \@in }, $_; } if (@ARGV && @out) { warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out); } @files = @in; } die "No input files given!\n" unless @files; my(%files, %global, %revreplace); %revreplace = reverse %replace; my $filename; my $patch_opened = 0; for $filename (@files) { unless (open IN, "<$filename") { warn "Unable to read from $filename: $!\n"; next; } info("Scanning $filename ..."); my $c = do { local $/; }; close IN; my %file = (orig => $c, changes => 0); # Temporarily remove C/XS comments and strings from the code my @ccom; $c =~ s{ ( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]* | ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* ) | ( ^$HS*\#[^\r\n]* | "[^"\\]*(?:\\.[^"\\]*)*" | '[^'\\]*(?:\\.[^'\\]*)*' | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) ) }{ defined $2 and push @ccom, $2; defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex; $file{ccom} = \@ccom; $file{code} = $c; $file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m; my $func; for $func (keys %API) { my $match = $func; $match .= "|$revreplace{$func}" if exists $revreplace{$func}; if ($c =~ /\b(?:Perl_)?($match)\b/) { $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func}; $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; if (exists $API{$func}{provided}) { $file{uses_provided}{$func}++; if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { $file{uses}{$func}++; my @deps = rec_depend($func); if (@deps) { $file{uses_deps}{$func} = \@deps; for (@deps) { $file{uses}{$_} = 0 unless exists $file{uses}{$_}; } } for ($func, @deps) { $file{needs}{$_} = 'static' if exists $need{$_}; } } } if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { if ($c =~ /\b$func\b/) { $file{uses_todo}{$func}++; } } } } while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { if (exists $need{$2}) { $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; } else { warning("Possibly wrong #define $1 in $filename") } } for (qw(uses needs uses_todo needed_global needed_static)) { for $func (keys %{$file{$_}}) { push @{$global{$_}{$func}}, $filename; } } $files{$filename} = \%file; } # Globally resolve NEED_'s my $need; for $need (keys %{$global{needs}}) { if (@{$global{needs}{$need}} > 1) { my @targets = @{$global{needs}{$need}}; my @t = grep $files{$_}{needed_global}{$need}, @targets; @targets = @t if @t; @t = grep /\.xs$/i, @targets; @targets = @t if @t; my $target = shift @targets; $files{$target}{needs}{$need} = 'global'; for (@{$global{needs}{$need}}) { $files{$_}{needs}{$need} = 'extern' if $_ ne $target; } } } for $filename (@files) { exists $files{$filename} or next; info("=== Analyzing $filename ==="); my %file = %{$files{$filename}}; my $func; my $c = $file{code}; my $warnings = 0; for $func (sort keys %{$file{uses_Perl}}) { if ($API{$func}{varargs}) { unless ($API{$func}{nothxarg}) { my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); if ($changes) { warning("Doesn't pass interpreter argument aTHX to Perl_$func"); $file{changes} += $changes; } } } else { warning("Uses Perl_$func instead of $func"); $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*} {$func$1(}g); } } for $func (sort keys %{$file{uses_replace}}) { warning("Uses $func instead of $replace{$func}"); $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); } for $func (sort keys %{$file{uses_provided}}) { if ($file{uses}{$func}) { if (exists $file{uses_deps}{$func}) { diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); } else { diag("Uses $func"); } } $warnings += hint($func); } unless ($opt{quiet}) { for $func (sort keys %{$file{uses_todo}}) { print "*** WARNING: Uses $func, which may not be portable below perl ", format_version($API{$func}{todo}), ", even with '$ppport'\n"; $warnings++; } } for $func (sort keys %{$file{needed_static}}) { my $message = ''; if (not exists $file{uses}{$func}) { $message = "No need to define NEED_$func if $func is never used"; } elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') { $message = "No need to define NEED_$func when already needed globally"; } if ($message) { diag($message); $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg); } } for $func (sort keys %{$file{needed_global}}) { my $message = ''; if (not exists $global{uses}{$func}) { $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; } elsif (exists $file{needs}{$func}) { if ($file{needs}{$func} eq 'extern') { $message = "No need to define NEED_${func}_GLOBAL when already needed globally"; } elsif ($file{needs}{$func} eq 'static') { $message = "No need to define NEED_${func}_GLOBAL when only used in this file"; } } if ($message) { diag($message); $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg); } } $file{needs_inc_ppport} = keys %{$file{uses}}; if ($file{needs_inc_ppport}) { my $pp = ''; for $func (sort keys %{$file{needs}}) { my $type = $file{needs}{$func}; next if $type eq 'extern'; my $suffix = $type eq 'global' ? '_GLOBAL' : ''; unless (exists $file{"needed_$type"}{$func}) { if ($type eq 'global') { diag("Files [@{$global{needs}{$func}}] need $func, adding global request"); } else { diag("File needs $func, adding static request"); } $pp .= "#define NEED_$func$suffix\n"; } } if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) { $pp = ''; $file{changes}++; } unless ($file{has_inc_ppport}) { diag("Needs to include '$ppport'"); $pp .= qq(#include "$ppport"\n) } if ($pp) { $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms) || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m) || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m) || ($c =~ s/^/$pp/); } } else { if ($file{has_inc_ppport}) { diag("No need to include '$ppport'"); $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m); } } # put back in our C comments my $ix; my $cppc = 0; my @ccom = @{$file{ccom}}; for $ix (0 .. $#ccom) { if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) { $cppc++; $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/; } else { $c =~ s/$rccs$ix$rcce/$ccom[$ix]/; } } if ($cppc) { my $s = $cppc != 1 ? 's' : ''; warning("Uses $cppc C++ style comment$s, which is not portable"); } my $s = $warnings != 1 ? 's' : ''; my $warn = $warnings ? " ($warnings warning$s)" : ''; info("Analysis completed$warn"); if ($file{changes}) { if (exists $opt{copy}) { my $newfile = "$filename$opt{copy}"; if (-e $newfile) { error("'$newfile' already exists, refusing to write copy of '$filename'"); } else { local *F; if (open F, ">$newfile") { info("Writing copy of '$filename' with changes to '$newfile'"); print F $c; close F; } else { error("Cannot open '$newfile' for writing: $!"); } } } elsif (exists $opt{patch} || $opt{changes}) { if (exists $opt{patch}) { unless ($patch_opened) { if (open PATCH, ">$opt{patch}") { $patch_opened = 1; } else { error("Cannot open '$opt{patch}' for writing: $!"); delete $opt{patch}; $opt{changes} = 1; goto fallback; } } mydiff(\*PATCH, $filename, $c); } else { fallback: info("Suggested changes:"); mydiff(\*STDOUT, $filename, $c); } } else { my $s = $file{changes} == 1 ? '' : 's'; info("$file{changes} potentially required change$s detected"); } } else { info("Looks good"); } } close PATCH if $patch_opened; exit 0; sub try_use { eval "use @_;"; return $@ eq '' } sub mydiff { local *F = shift; my($file, $str) = @_; my $diff; if (exists $opt{diff}) { $diff = run_diff($opt{diff}, $file, $str); } if (!defined $diff and try_use('Text::Diff')) { $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' }); $diff = <
$tmp") { print F $str; close F; if (open F, "$prog $file $tmp |") { while () { s/\Q$tmp\E/$file.patched/; $diff .= $_; } close F; unlink $tmp; return $diff; } unlink $tmp; } else { error("Cannot open '$tmp' for writing: $!"); } return undef; } sub rec_depend { my($func, $seen) = @_; return () unless exists $depends{$func}; $seen = {%{$seen||{}}}; return () if $seen->{$func}++; my %s; grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}}; } sub parse_version { my $ver = shift; if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { return ($1, $2, $3); } elsif ($ver !~ /^\d+\.[\d_]+$/) { die "cannot parse version '$ver'\n"; } $ver =~ s/_//g; $ver =~ s/$/000000/; my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; $v = int $v; $s = int $s; if ($r < 5 || ($r == 5 && $v < 6)) { if ($s % 10) { die "cannot parse version '$ver'\n"; } } return ($r, $v, $s); } sub format_version { my $ver = shift; $ver =~ s/$/000000/; my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; $v = int $v; $s = int $s; if ($r < 5 || ($r == 5 && $v < 6)) { if ($s % 10) { die "invalid version '$ver'\n"; } $s /= 10; $ver = sprintf "%d.%03d", $r, $v; $s > 0 and $ver .= sprintf "_%02d", $s; return $ver; } return sprintf "%d.%d.%d", $r, $v, $s; } sub info { $opt{quiet} and return; print @_, "\n"; } sub diag { $opt{quiet} and return; $opt{diag} and print @_, "\n"; } sub warning { $opt{quiet} and return; print "*** ", @_, "\n"; } sub error { print "*** ERROR: ", @_, "\n"; } my %given_hints; my %given_warnings; sub hint { $opt{quiet} and return; my $func = shift; my $rv = 0; if (exists $warnings{$func} && !$given_warnings{$func}++) { my $warn = $warnings{$func}; $warn =~ s!^!*** !mg; print "*** WARNING: $func\n", $warn; $rv++; } if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) { my $hint = $hints{$func}; $hint =~ s/^/ /mg; print " --- hint for $func ---\n", $hint; } $rv; } sub usage { my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; my %M = ( 'I' => '*' ); $usage =~ s/^\s*perl\s+\S+/$^X $0/; $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; print < }; my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms; $copy =~ s/^(?=\S+)/ /gms; $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms; $self =~ s/^SKIP.*(?=^__DATA__)/SKIP if (\@ARGV && \$ARGV[0] eq '--unstrip') { eval { require Devel::PPPort }; \$@ and die "Cannot require Devel::PPPort, please install.\\n"; if (\$Devel::PPPort::VERSION < $VERSION) { die "$0 was originally generated with Devel::PPPort $VERSION.\\n" . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n" . "Please install a newer version, or --unstrip will not work.\\n"; } Devel::PPPort::WriteFile(\$0); exit 0; } print <$0" or die "cannot strip $0: $!\n"; print OUT "$pl$c\n"; exit 0; } __DATA__ */ #ifndef _P_P_PORTABILITY_H_ #define _P_P_PORTABILITY_H_ #ifndef DPPP_NAMESPACE # define DPPP_NAMESPACE DPPP_ #endif #define DPPP_CAT2(x,y) CAT2(x,y) #define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name) #ifndef PERL_REVISION # if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION)) # 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 _dpppDEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10)) #define PERL_BCDVERSION ((_dpppDEC2BCD(PERL_REVISION)<<24)|(_dpppDEC2BCD(PERL_VERSION)<<12)|_dpppDEC2BCD(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 */ #ifdef I_LIMITS # include #endif #ifndef PERL_UCHAR_MIN # define PERL_UCHAR_MIN ((unsigned char)0) #endif #ifndef PERL_UCHAR_MAX # ifdef UCHAR_MAX # define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) # else # ifdef MAXUCHAR # define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR) # else # define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) # endif # endif #endif #ifndef PERL_USHORT_MIN # define PERL_USHORT_MIN ((unsigned short)0) #endif #ifndef PERL_USHORT_MAX # ifdef USHORT_MAX # define PERL_USHORT_MAX ((unsigned short)USHORT_MAX) # else # ifdef MAXUSHORT # define PERL_USHORT_MAX ((unsigned short)MAXUSHORT) # else # ifdef USHRT_MAX # define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) # else # define PERL_USHORT_MAX ((unsigned short)~(unsigned)0) # endif # endif # endif #endif #ifndef PERL_SHORT_MAX # ifdef SHORT_MAX # define PERL_SHORT_MAX ((short)SHORT_MAX) # else # ifdef MAXSHORT /* Often used in */ # define PERL_SHORT_MAX ((short)MAXSHORT) # else # ifdef SHRT_MAX # define PERL_SHORT_MAX ((short)SHRT_MAX) # else # define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1)) # endif # endif # endif #endif #ifndef PERL_SHORT_MIN # ifdef SHORT_MIN # define PERL_SHORT_MIN ((short)SHORT_MIN) # else # ifdef MINSHORT # define PERL_SHORT_MIN ((short)MINSHORT) # else # ifdef SHRT_MIN # define PERL_SHORT_MIN ((short)SHRT_MIN) # else # define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3)) # endif # endif # endif #endif #ifndef PERL_UINT_MAX # ifdef UINT_MAX # define PERL_UINT_MAX ((unsigned int)UINT_MAX) # else # ifdef MAXUINT # define PERL_UINT_MAX ((unsigned int)MAXUINT) # else # define PERL_UINT_MAX (~(unsigned int)0) # endif # endif #endif #ifndef PERL_UINT_MIN # define PERL_UINT_MIN ((unsigned int)0) #endif #ifndef PERL_INT_MAX # ifdef INT_MAX # define PERL_INT_MAX ((int)INT_MAX) # else # ifdef MAXINT /* Often used in */ # define PERL_INT_MAX ((int)MAXINT) # else # define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1)) # endif # endif #endif #ifndef PERL_INT_MIN # ifdef INT_MIN # define PERL_INT_MIN ((int)INT_MIN) # else # ifdef MININT # define PERL_INT_MIN ((int)MININT) # else # define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3)) # endif # endif #endif #ifndef PERL_ULONG_MAX # ifdef ULONG_MAX # define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) # else # ifdef MAXULONG # define PERL_ULONG_MAX ((unsigned long)MAXULONG) # else # define PERL_ULONG_MAX (~(unsigned long)0) # endif # endif #endif #ifndef PERL_ULONG_MIN # define PERL_ULONG_MIN ((unsigned long)0L) #endif #ifndef PERL_LONG_MAX # ifdef LONG_MAX # define PERL_LONG_MAX ((long)LONG_MAX) # else # ifdef MAXLONG # define PERL_LONG_MAX ((long)MAXLONG) # else # define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1)) # endif # endif #endif #ifndef PERL_LONG_MIN # ifdef LONG_MIN # define PERL_LONG_MIN ((long)LONG_MIN) # else # ifdef MINLONG # define PERL_LONG_MIN ((long)MINLONG) # else # define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3)) # endif # endif #endif #if defined(HAS_QUAD) && (defined(convex) || defined(uts)) # ifndef PERL_UQUAD_MAX # ifdef ULONGLONG_MAX # define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX) # else # ifdef MAXULONGLONG # define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG) # else # define PERL_UQUAD_MAX (~(unsigned long long)0) # endif # endif # endif # ifndef PERL_UQUAD_MIN # define PERL_UQUAD_MIN ((unsigned long long)0L) # endif # ifndef PERL_QUAD_MAX # ifdef LONGLONG_MAX # define PERL_QUAD_MAX ((long long)LONGLONG_MAX) # else # ifdef MAXLONGLONG # define PERL_QUAD_MAX ((long long)MAXLONGLONG) # else # define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1)) # endif # endif # endif # ifndef PERL_QUAD_MIN # ifdef LONGLONG_MIN # define PERL_QUAD_MIN ((long long)LONGLONG_MIN) # else # ifdef MINLONGLONG # define PERL_QUAD_MIN ((long long)MINLONGLONG) # else # define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) # endif # endif # endif #endif /* This is based on code from 5.003 perl.h */ #ifdef HAS_QUAD # ifdef cray #ifndef IVTYPE # define IVTYPE int #endif #ifndef IV_MIN # define IV_MIN PERL_INT_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_INT_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_UINT_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_UINT_MAX #endif # ifdef INTSIZE #ifndef IVSIZE # define IVSIZE INTSIZE #endif # endif # else # if defined(convex) || defined(uts) #ifndef IVTYPE # define IVTYPE long long #endif #ifndef IV_MIN # define IV_MIN PERL_QUAD_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_QUAD_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_UQUAD_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_UQUAD_MAX #endif # ifdef LONGLONGSIZE #ifndef IVSIZE # define IVSIZE LONGLONGSIZE #endif # endif # else #ifndef IVTYPE # define IVTYPE long #endif #ifndef IV_MIN # define IV_MIN PERL_LONG_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_LONG_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_ULONG_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_ULONG_MAX #endif # ifdef LONGSIZE #ifndef IVSIZE # define IVSIZE LONGSIZE #endif # endif # endif # endif #ifndef IVSIZE # define IVSIZE 8 #endif #ifndef PERL_QUAD_MIN # define PERL_QUAD_MIN IV_MIN #endif #ifndef PERL_QUAD_MAX # define PERL_QUAD_MAX IV_MAX #endif #ifndef PERL_UQUAD_MIN # define PERL_UQUAD_MIN UV_MIN #endif #ifndef PERL_UQUAD_MAX # define PERL_UQUAD_MAX UV_MAX #endif #else #ifndef IVTYPE # define IVTYPE long #endif #ifndef IV_MIN # define IV_MIN PERL_LONG_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_LONG_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_ULONG_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_ULONG_MAX #endif #endif #ifndef IVSIZE # ifdef LONGSIZE # define IVSIZE LONGSIZE # else # define IVSIZE 4 /* A bold guess, but the best we can make. */ # endif #endif #ifndef UVTYPE # define UVTYPE unsigned IVTYPE #endif #ifndef UVSIZE # define UVSIZE IVSIZE #endif #ifndef sv_setuv # define sv_setuv(sv, uv) \ STMT_START { \ UV TeMpUv = uv; \ if (TeMpUv <= IV_MAX) \ sv_setiv(sv, TeMpUv); \ else \ sv_setnv(sv, (double)TeMpUv); \ } STMT_END #endif #ifndef newSVuv # define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv)) #endif #ifndef sv_2uv # define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) #endif #ifndef SvUVX # define SvUVX(sv) ((UV)SvIVX(sv)) #endif #ifndef SvUVXx # define SvUVXx(sv) SvUVX(sv) #endif #ifndef SvUV # define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) #endif #ifndef SvUVx # define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) #endif /* Hint: sv_uv * Always use the SvUVx() macro instead of sv_uv(). */ #ifndef sv_uv # define sv_uv(sv) SvUVx(sv) #endif #if !defined(SvUOK) && defined(SvIOK_UV) # define SvUOK(sv) SvIOK_UV(sv) #endif #ifndef XST_mUV # define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) #endif #ifndef XSRETURN_UV # define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END #endif #ifndef PUSHu # define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END #endif #ifndef XPUSHu # define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END #endif #ifdef HAS_MEMCMP #ifndef memNE # define memNE(s1,s2,l) (memcmp(s1,s2,l)) #endif #ifndef memEQ # define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) #endif #else #ifndef memNE # define memNE(s1,s2,l) (bcmp(s1,s2,l)) #endif #ifndef memEQ # define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) #endif #endif #ifndef MoveD # define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t)) #endif #ifndef CopyD # define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) #endif #ifdef HAS_MEMSET #ifndef ZeroD # define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t)) #endif #else #ifndef ZeroD # define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)), d) #endif #endif #ifndef PoisonWith # define PoisonWith(d,n,t,b) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t)) #endif #ifndef PoisonNew # define PoisonNew(d,n,t) PoisonWith(d,n,t,0xAB) #endif #ifndef PoisonFree # define PoisonFree(d,n,t) PoisonWith(d,n,t,0xEF) #endif #ifndef Poison # define Poison(d,n,t) PoisonFree(d,n,t) #endif #ifndef Newx # define Newx(v,n,t) New(0,v,n,t) #endif #ifndef Newxc # define Newxc(v,n,t,c) Newc(0,v,n,t,c) #endif #ifndef Newxz # define Newxz(v,n,t) Newz(0,v,n,t) #endif #ifndef PERL_UNUSED_DECL # 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 #endif #ifndef PERL_UNUSED_ARG # if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ # include # define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) # else # define PERL_UNUSED_ARG(x) ((void)x) # endif #endif #ifndef PERL_UNUSED_VAR # define PERL_UNUSED_VAR(x) ((void)x) #endif #ifndef PERL_UNUSED_CONTEXT # ifdef USE_ITHREADS # define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) # else # define PERL_UNUSED_CONTEXT # endif #endif #ifndef NOOP # define NOOP /*EMPTY*/(void)0 #endif #ifndef dNOOP # define dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL #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 */ #undef START_EXTERN_C #undef END_EXTERN_C #undef EXTERN_C #ifdef __cplusplus # define START_EXTERN_C extern "C" { # define END_EXTERN_C } # define EXTERN_C extern "C" #else # define START_EXTERN_C # define END_EXTERN_C # define EXTERN_C extern #endif #if defined(PERL_GCC_PEDANTIC) # ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN # define PERL_GCC_BRACE_GROUPS_FORBIDDEN # endif #endif #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) # ifndef PERL_USE_GCC_BRACE_GROUPS # define PERL_USE_GCC_BRACE_GROUPS # endif #endif #undef STMT_START #undef STMT_END #ifdef PERL_USE_GCC_BRACE_GROUPS # define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ # define STMT_END ) #else # if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) # define STMT_START if (1) # define STMT_END else (void)0 # else # define STMT_START do # define STMT_END while (0) # endif #endif #ifndef boolSV # define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) #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 /* Older perls (<=5.003) lack AvFILLp */ #ifndef AvFILLp # define AvFILLp AvFILL #endif #ifndef ERRSV # define ERRSV get_sv("@",FALSE) #endif #ifndef newSVpvn # define newSVpvn(data,len) ((data) \ ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ : newSV(0)) #endif /* Hint: gv_stashpvn * This function's backport doesn't support the length parameter, but * rather ignores it. Portability can only be ensured if the length * parameter is used for speed reasons, but the length can always be * correctly computed from the string argument. */ #ifndef gv_stashpvn # define gv_stashpvn(str,len,create) gv_stashpv(str,create) #endif /* Replace: 1 */ #ifndef get_cv # define get_cv perl_get_cv #endif #ifndef get_sv # define get_sv perl_get_sv #endif #ifndef get_av # define get_av perl_get_av #endif #ifndef get_hv # define get_hv perl_get_hv #endif /* Replace: 0 */ #ifndef dUNDERBAR # define dUNDERBAR dNOOP #endif #ifndef UNDERBAR # define UNDERBAR DEFSV #endif #ifndef dAX # define dAX I32 ax = MARK - PL_stack_base + 1 #endif #ifndef dITEMS # define dITEMS I32 items = SP - MARK #endif #ifndef dXSTARG # define dXSTARG SV * targ = sv_newmortal() #endif #ifndef dAXMARK # define dAXMARK I32 ax = POPMARK; \ register SV ** const mark = PL_stack_base + ax++ #endif #ifndef XSprePUSH # define XSprePUSH (sp = PL_stack_base + ax - 1) #endif #if (PERL_BCDVERSION < 0x5005000) # undef XSRETURN # define XSRETURN(off) \ STMT_START { \ PL_stack_sp = PL_stack_base + ax + ((off) - 1); \ return; \ } STMT_END #endif #ifndef PERL_ABS # define PERL_ABS(x) ((x) < 0 ? -(x) : (x)) #endif #ifndef dVAR # define dVAR dNOOP #endif #ifndef SVf # define SVf "_" #endif #ifndef UTF8_MAXBYTES # define UTF8_MAXBYTES UTF8_MAXLEN #endif #ifndef PERL_HASH # define PERL_HASH(hash,str,len) \ STMT_START { \ const char *s_PeRlHaSh = str; \ I32 i_PeRlHaSh = len; \ U32 hash_PeRlHaSh = 0; \ while (i_PeRlHaSh--) \ hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \ (hash) = hash_PeRlHaSh; \ } STMT_END #endif #ifndef PERL_SIGNALS_UNSAFE_FLAG #define PERL_SIGNALS_UNSAFE_FLAG 0x0001 #if (PERL_BCDVERSION < 0x5008000) # define D_PPP_PERL_SIGNALS_INIT PERL_SIGNALS_UNSAFE_FLAG #else # define D_PPP_PERL_SIGNALS_INIT 0 #endif #if defined(NEED_PL_signals) static U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; #elif defined(NEED_PL_signals_GLOBAL) U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; #else extern U32 DPPP_(my_PL_signals); #endif #define PL_signals DPPP_(my_PL_signals) #endif /* Hint: PL_ppaddr * Calling an op via PL_ppaddr requires passing a context argument * for threaded builds. Since the context argument is different for * 5.005 perls, you can use aTHXR (supplied by ppport.h), which will * automatically be defined as the correct argument. */ #if (PERL_BCDVERSION <= 0x5005005) /* Replace: 1 */ # define PL_ppaddr ppaddr # define PL_no_modify no_modify /* Replace: 0 */ #endif #if (PERL_BCDVERSION <= 0x5004005) /* Replace: 1 */ # define PL_DBsignal DBsignal # define PL_DBsingle DBsingle # define PL_DBsub DBsub # define PL_DBtrace DBtrace # define PL_Sv Sv # define PL_compiling compiling # define PL_copline copline # define PL_curcop curcop # define PL_curstash curstash # define PL_debstash debstash # define PL_defgv defgv # define PL_diehook diehook # define PL_dirty dirty # define PL_dowarn dowarn # define PL_errgv errgv # define PL_expect expect # define PL_hexdigit hexdigit # define PL_hints hints # define PL_laststatval laststatval # define PL_na na # define PL_perl_destruct_level perl_destruct_level # define PL_perldb perldb # define PL_rsfp_filters rsfp_filters # define PL_rsfp rsfp # define PL_stack_base stack_base # define PL_stack_sp stack_sp # define PL_statcache statcache # define PL_stdingv stdingv # define PL_sv_arenaroot sv_arenaroot # define PL_sv_no sv_no # define PL_sv_undef sv_undef # define PL_sv_yes sv_yes # define PL_tainted tainted # define PL_tainting tainting /* Replace: 0 */ #endif /* Warning: PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters * Do not use this variable. It is internal to the perl parser * and may change or even be removed in the future. Note that * as of perl 5.9.5 you cannot assign to this variable anymore. */ /* TODO: cannot assign to these vars; is it worth fixing? */ #if (PERL_BCDVERSION >= 0x5009005) # define PL_expect (PL_parser ? PL_parser->expect : 0) # define PL_copline (PL_parser ? PL_parser->copline : 0) # define PL_rsfp (PL_parser ? PL_parser->rsfp : (PerlIO *) 0) # define PL_rsfp_filters (PL_parser ? PL_parser->rsfp_filters : (AV *) 0) #endif #ifndef dTHR # define dTHR dNOOP #endif #ifndef dTHX # define dTHX dNOOP #endif #ifndef dTHXa # define dTHXa(x) dNOOP #endif #ifndef pTHX # define pTHX void #endif #ifndef pTHX_ # define pTHX_ #endif #ifndef aTHX # define aTHX #endif #ifndef aTHX_ # define aTHX_ #endif #if (PERL_BCDVERSION < 0x5006000) # ifdef USE_THREADS # define aTHXR thr # define aTHXR_ thr, # else # define aTHXR # define aTHXR_ # endif # define dTHXR dTHR #else # define aTHXR aTHX # define aTHXR_ aTHX_ # define dTHXR dTHX #endif #ifndef dTHXoa # define dTHXoa(x) dTHXa(x) #endif #ifndef PUSHmortal # define PUSHmortal PUSHs(sv_newmortal()) #endif #ifndef mPUSHp # define mPUSHp(p,l) sv_setpvn_mg(PUSHmortal, (p), (l)) #endif #ifndef mPUSHn # define mPUSHn(n) sv_setnv_mg(PUSHmortal, (NV)(n)) #endif #ifndef mPUSHi # define mPUSHi(i) sv_setiv_mg(PUSHmortal, (IV)(i)) #endif #ifndef mPUSHu # define mPUSHu(u) sv_setuv_mg(PUSHmortal, (UV)(u)) #endif #ifndef XPUSHmortal # define XPUSHmortal XPUSHs(sv_newmortal()) #endif #ifndef mXPUSHp # define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn_mg(PUSHmortal, (p), (l)); } STMT_END #endif #ifndef mXPUSHn # define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv_mg(PUSHmortal, (NV)(n)); } STMT_END #endif #ifndef mXPUSHi # define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv_mg(PUSHmortal, (IV)(i)); } STMT_END #endif #ifndef mXPUSHu # define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv_mg(PUSHmortal, (UV)(u)); } STMT_END #endif /* Replace: 1 */ #ifndef call_sv # define call_sv perl_call_sv #endif #ifndef call_pv # define call_pv perl_call_pv #endif #ifndef call_argv # define call_argv perl_call_argv #endif #ifndef call_method # define call_method perl_call_method #endif #ifndef eval_sv # define eval_sv perl_eval_sv #endif #ifndef PERL_LOADMOD_DENY # define PERL_LOADMOD_DENY 0x1 #endif #ifndef PERL_LOADMOD_NOIMPORT # define PERL_LOADMOD_NOIMPORT 0x2 #endif #ifndef PERL_LOADMOD_IMPORT_OPS # define PERL_LOADMOD_IMPORT_OPS 0x4 #endif /* Replace: 0 */ /* Replace perl_eval_pv with eval_pv */ #ifndef eval_pv #if defined(NEED_eval_pv) static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); static #else extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); #endif #ifdef eval_pv # undef eval_pv #endif #define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b) #define Perl_eval_pv DPPP_(my_eval_pv) #if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error) { dSP; SV* sv = newSVpv(p, 0); PUSHMARK(sp); eval_sv(sv, G_SCALAR); SvREFCNT_dec(sv); SPAGAIN; sv = POPs; PUTBACK; if (croak_on_error && SvTRUE(GvSV(errgv))) croak(SvPVx(GvSV(errgv), na)); return sv; } #endif #endif #ifndef vload_module #if defined(NEED_vload_module) static void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); static #else extern void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); #endif #ifdef vload_module # undef vload_module #endif #define vload_module(a,b,c,d) DPPP_(my_vload_module)(aTHX_ a,b,c,d) #define Perl_vload_module DPPP_(my_vload_module) #if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL) void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args) { dTHR; dVAR; OP *veop, *imop; OP * const modname = newSVOP(OP_CONST, 0, name); /* 5.005 has a somewhat hacky force_normal that doesn't croak on SvREADONLY() if PL_compling is true. Current perls take care in ck_require() to correctly turn off SvREADONLY before calling force_normal_flags(). This seems a better fix than fudging PL_compling */ SvREADONLY_off(((SVOP*)modname)->op_sv); modname->op_private |= OPpCONST_BARE; if (ver) { veop = newSVOP(OP_CONST, 0, ver); } else veop = NULL; if (flags & PERL_LOADMOD_NOIMPORT) { imop = sawparens(newNULLLIST()); } else if (flags & PERL_LOADMOD_IMPORT_OPS) { imop = va_arg(*args, OP*); } else { SV *sv; imop = NULL; sv = va_arg(*args, SV*); while (sv) { imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); sv = va_arg(*args, SV*); } } { const line_t ocopline = PL_copline; COP * const ocurcop = PL_curcop; const int oexpect = PL_expect; #if (PERL_BCDVERSION >= 0x5004000) utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), veop, modname, imop); #else utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), modname, imop); #endif PL_expect = oexpect; PL_copline = ocopline; PL_curcop = ocurcop; } } #endif #endif #ifndef load_module #if defined(NEED_load_module) static void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); static #else extern void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); #endif #ifdef load_module # undef load_module #endif #define load_module DPPP_(my_load_module) #define Perl_load_module DPPP_(my_load_module) #if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL) void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...) { va_list args; va_start(args, ver); vload_module(flags, name, ver, &args); va_end(args); } #endif #endif #ifndef newRV_inc # define newRV_inc(sv) newRV(sv) /* Replace */ #endif #ifndef newRV_noinc #if defined(NEED_newRV_noinc) static SV * DPPP_(my_newRV_noinc)(SV *sv); static #else extern SV * DPPP_(my_newRV_noinc)(SV *sv); #endif #ifdef newRV_noinc # undef newRV_noinc #endif #define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a) #define Perl_newRV_noinc DPPP_(my_newRV_noinc) #if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) SV * DPPP_(my_newRV_noinc)(SV *sv) { SV *rv = (SV *)newRV(sv); SvREFCNT_dec(sv); return rv; } #endif #endif /* Hint: newCONSTSUB * Returns a CV* as of perl-5.7.1. This return value is not supported * by Devel::PPPort. */ /* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ #if (PERL_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005) #if defined(NEED_newCONSTSUB) static void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); static #else extern void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); #endif #ifdef newCONSTSUB # undef newCONSTSUB #endif #define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) #define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) void DPPP_(my_newCONSTSUB)(HV *stash, const 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_BCDVERSION < 0x5003022) start_subparse(), #elif (PERL_BCDVERSION == 0x5003022) start_subparse(0), #else /* 5.003_23 onwards */ start_subparse(FALSE, 0), #endif newSVOP(OP_CONST, 0, newSVpv((char *) 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 /* * 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) #ifndef START_MY_CXT /* 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_BCDVERSION < 0x5004068) /* Fetches the SV that keeps the per-interpreter data. */ #define dMY_CXT_SV \ SV *my_cxt_sv = 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 #endif /* START_MY_CXT */ #ifndef MY_CXT_CLONE /* Clones the per-interpreter data. */ #define MY_CXT_CLONE \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) #endif #else /* single interpreter */ #ifndef START_MY_CXT #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 /* START_MY_CXT */ #ifndef MY_CXT_CLONE #define MY_CXT_CLONE NOOP #endif #endif #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 SvREFCNT_inc # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ if (_sv) \ (SvREFCNT(_sv))++; \ _sv; \ }) # else # define SvREFCNT_inc(sv) \ ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL) # endif #endif #ifndef SvREFCNT_inc_simple # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_simple(sv) \ ({ \ if (sv) \ (SvREFCNT(sv))++; \ (SV *)(sv); \ }) # else # define SvREFCNT_inc_simple(sv) \ ((sv) ? (SvREFCNT(sv)++,(SV*)(sv)) : NULL) # endif #endif #ifndef SvREFCNT_inc_NN # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_NN(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ SvREFCNT(_sv)++; \ _sv; \ }) # else # define SvREFCNT_inc_NN(sv) \ (PL_Sv=(SV*)(sv),++(SvREFCNT(PL_Sv)),PL_Sv) # endif #endif #ifndef SvREFCNT_inc_void # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_void(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ if (_sv) \ (void)(SvREFCNT(_sv)++); \ }) # else # define SvREFCNT_inc_void(sv) \ (void)((PL_Sv=(SV*)(sv)) ? ++(SvREFCNT(PL_Sv)) : 0) # endif #endif #ifndef SvREFCNT_inc_simple_void # define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END #endif #ifndef SvREFCNT_inc_simple_NN # define SvREFCNT_inc_simple_NN(sv) (++SvREFCNT(sv), (SV*)(sv)) #endif #ifndef SvREFCNT_inc_void_NN # define SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) #endif #ifndef SvREFCNT_inc_simple_void_NN # define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) #endif /* Backwards compatibility stuff... :-( */ #if !defined(NEED_sv_2pv_flags) && defined(NEED_sv_2pv_nolen) # define NEED_sv_2pv_flags #endif #if !defined(NEED_sv_2pv_flags_GLOBAL) && defined(NEED_sv_2pv_nolen_GLOBAL) # define NEED_sv_2pv_flags_GLOBAL #endif /* Hint: sv_2pv_nolen * Use the SvPV_nolen() or SvPV_nolen_const() macros instead of sv_2pv_nolen(). */ #ifndef sv_2pv_nolen # define sv_2pv_nolen(sv) SvPV_nolen(sv) #endif #ifdef SvPVbyte /* Hint: SvPVbyte * Does not work in perl-5.6.1, ppport.h implements a version * borrowed from perl-5.7.3. */ #if (PERL_BCDVERSION < 0x5007000) #if defined(NEED_sv_2pvbyte) static char * DPPP_(my_sv_2pvbyte)(pTHX_ SV * sv, STRLEN * lp); static #else extern char * DPPP_(my_sv_2pvbyte)(pTHX_ SV * sv, STRLEN * lp); #endif #ifdef sv_2pvbyte # undef sv_2pvbyte #endif #define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b) #define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte) #if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp) { sv_utf8_downgrade(sv,0); return SvPV(sv,*lp); } #endif /* Hint: sv_2pvbyte * Use the SvPVbyte() macro instead of sv_2pvbyte(). */ #undef SvPVbyte #define SvPVbyte(sv, lp) \ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) #endif #else # define SvPVbyte SvPV # define sv_2pvbyte sv_2pv #endif #ifndef sv_2pvbyte_nolen # define sv_2pvbyte_nolen(sv) sv_2pv_nolen(sv) #endif /* Hint: sv_pvn * Always use the SvPV() macro instead of sv_pvn(). */ /* Hint: sv_pvn_force * Always use the SvPV_force() macro instead of sv_pvn_force(). */ /* If these are undefined, they're not handled by the core anyway */ #ifndef SV_IMMEDIATE_UNREF # define SV_IMMEDIATE_UNREF 0 #endif #ifndef SV_GMAGIC # define SV_GMAGIC 0 #endif #ifndef SV_COW_DROP_PV # define SV_COW_DROP_PV 0 #endif #ifndef SV_UTF8_NO_ENCODING # define SV_UTF8_NO_ENCODING 0 #endif #ifndef SV_NOSTEAL # define SV_NOSTEAL 0 #endif #ifndef SV_CONST_RETURN # define SV_CONST_RETURN 0 #endif #ifndef SV_MUTABLE_RETURN # define SV_MUTABLE_RETURN 0 #endif #ifndef SV_SMAGIC # define SV_SMAGIC 0 #endif #ifndef SV_HAS_TRAILING_NUL # define SV_HAS_TRAILING_NUL 0 #endif #ifndef SV_COW_SHARED_HASH_KEYS # define SV_COW_SHARED_HASH_KEYS 0 #endif #if (PERL_BCDVERSION < 0x5007002) #if defined(NEED_sv_2pv_flags) static char * DPPP_(my_sv_2pv_flags)(pTHX_ SV * sv, STRLEN * lp, I32 flags); static #else extern char * DPPP_(my_sv_2pv_flags)(pTHX_ SV * sv, STRLEN * lp, I32 flags); #endif #ifdef sv_2pv_flags # undef sv_2pv_flags #endif #define sv_2pv_flags(a,b,c) DPPP_(my_sv_2pv_flags)(aTHX_ a,b,c) #define Perl_sv_2pv_flags DPPP_(my_sv_2pv_flags) #if defined(NEED_sv_2pv_flags) || defined(NEED_sv_2pv_flags_GLOBAL) char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) { STRLEN n_a = (STRLEN) flags; return sv_2pv(sv, lp ? lp : &n_a); } #endif #if defined(NEED_sv_pvn_force_flags) static char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV * sv, STRLEN * lp, I32 flags); static #else extern char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV * sv, STRLEN * lp, I32 flags); #endif #ifdef sv_pvn_force_flags # undef sv_pvn_force_flags #endif #define sv_pvn_force_flags(a,b,c) DPPP_(my_sv_pvn_force_flags)(aTHX_ a,b,c) #define Perl_sv_pvn_force_flags DPPP_(my_sv_pvn_force_flags) #if defined(NEED_sv_pvn_force_flags) || defined(NEED_sv_pvn_force_flags_GLOBAL) char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) { STRLEN n_a = (STRLEN) flags; return sv_pvn_force(sv, lp ? lp : &n_a); } #endif #endif #ifndef SvPV_const # define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_mutable # define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_flags # define SvPV_flags(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags)) #endif #ifndef SvPV_flags_const # define SvPV_flags_const(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \ (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN)) #endif #ifndef SvPV_flags_const_nolen # define SvPV_flags_const_nolen(sv, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX_const(sv) : \ (const char*) sv_2pv_flags(sv, 0, flags|SV_CONST_RETURN)) #endif #ifndef SvPV_flags_mutable # define SvPV_flags_mutable(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \ sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) #endif #ifndef SvPV_force # define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_force_nolen # define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC) #endif #ifndef SvPV_force_mutable # define SvPV_force_mutable(sv, lp) SvPV_force_flags_mutable(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_force_nomg # define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0) #endif #ifndef SvPV_force_nomg_nolen # define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0) #endif #ifndef SvPV_force_flags # define SvPV_force_flags(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags)) #endif #ifndef SvPV_force_flags_nolen # define SvPV_force_flags_nolen(sv, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? SvPVX(sv) : sv_pvn_force_flags(sv, 0, flags)) #endif #ifndef SvPV_force_flags_mutable # define SvPV_force_flags_mutable(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \ : sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) #endif #ifndef SvPV_nolen # define SvPV_nolen(sv) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX(sv) : sv_2pv_flags(sv, 0, SV_GMAGIC)) #endif #ifndef SvPV_nolen_const # define SvPV_nolen_const(sv) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX_const(sv) : sv_2pv_flags(sv, 0, SV_GMAGIC|SV_CONST_RETURN)) #endif #ifndef SvPV_nomg # define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0) #endif #ifndef SvPV_nomg_const # define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0) #endif #ifndef SvPV_nomg_const_nolen # define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0) #endif #ifndef SvMAGIC_set # define SvMAGIC_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END #endif #if (PERL_BCDVERSION < 0x5009003) #ifndef SvPVX_const # define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv))) #endif #ifndef SvPVX_mutable # define SvPVX_mutable(sv) (0 + SvPVX(sv)) #endif #ifndef SvRV_set # define SvRV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END #endif #else #ifndef SvPVX_const # define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv)) #endif #ifndef SvPVX_mutable # define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv) #endif #ifndef SvRV_set # define SvRV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ ((sv)->sv_u.svu_rv = (val)); } STMT_END #endif #endif #ifndef SvSTASH_set # define SvSTASH_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END #endif #if (PERL_BCDVERSION < 0x5004000) #ifndef SvUV_set # define SvUV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END #endif #else #ifndef SvUV_set # define SvUV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END #endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(vnewSVpvf) #if defined(NEED_vnewSVpvf) static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args); static #else extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args); #endif #ifdef vnewSVpvf # undef vnewSVpvf #endif #define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) #define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) #if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args) { register SV *sv = newSV(0); sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); return sv; } #endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf) # define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf) # define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg) #if defined(NEED_sv_catpvf_mg) static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...); static #else extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...); #endif #define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) #if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...) { va_list args; va_start(args, pat); sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #ifdef PERL_IMPLICIT_CONTEXT #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg_nocontext) #if defined(NEED_sv_catpvf_mg_nocontext) static void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...); static #else extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...); #endif #define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) #define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) #if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...) { dTHX; va_list args; va_start(args, pat); sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #endif /* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */ #ifndef sv_catpvf_mg # ifdef PERL_IMPLICIT_CONTEXT # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext # else # define sv_catpvf_mg Perl_sv_catpvf_mg # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf_mg) # define sv_vcatpvf_mg(sv, pat, args) \ STMT_START { \ sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ SvSETMAGIC(sv); \ } STMT_END #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg) #if defined(NEED_sv_setpvf_mg) static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...); static #else extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...); #endif #define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) #if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...) { va_list args; va_start(args, pat); sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #ifdef PERL_IMPLICIT_CONTEXT #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg_nocontext) #if defined(NEED_sv_setpvf_mg_nocontext) static void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...); static #else extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...); #endif #define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) #define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) #if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...) { dTHX; va_list args; va_start(args, pat); sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #endif /* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */ #ifndef sv_setpvf_mg # ifdef PERL_IMPLICIT_CONTEXT # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext # else # define sv_setpvf_mg Perl_sv_setpvf_mg # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf_mg) # define sv_vsetpvf_mg(sv, pat, args) \ STMT_START { \ sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ SvSETMAGIC(sv); \ } STMT_END #endif #ifndef newSVpvn_share #if defined(NEED_newSVpvn_share) static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); static #else extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); #endif #ifdef newSVpvn_share # undef newSVpvn_share #endif #define newSVpvn_share(a,b,c) DPPP_(my_newSVpvn_share)(aTHX_ a,b,c) #define Perl_newSVpvn_share DPPP_(my_newSVpvn_share) #if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL) SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash) { SV *sv; if (len < 0) len = -len; if (!hash) PERL_HASH(hash, (char*) src, len); sv = newSVpvn((char *) src, len); sv_upgrade(sv, SVt_PVIV); SvIVX(sv) = hash; SvREADONLY_on(sv); SvPOK_on(sv); return sv; } #endif #endif #ifndef SvSHARED_HASH # define SvSHARED_HASH(sv) (0 + SvUVX(sv)) #endif #ifndef WARN_ALL # define WARN_ALL 0 #endif #ifndef WARN_CLOSURE # define WARN_CLOSURE 1 #endif #ifndef WARN_DEPRECATED # define WARN_DEPRECATED 2 #endif #ifndef WARN_EXITING # define WARN_EXITING 3 #endif #ifndef WARN_GLOB # define WARN_GLOB 4 #endif #ifndef WARN_IO # define WARN_IO 5 #endif #ifndef WARN_CLOSED # define WARN_CLOSED 6 #endif #ifndef WARN_EXEC # define WARN_EXEC 7 #endif #ifndef WARN_LAYER # define WARN_LAYER 8 #endif #ifndef WARN_NEWLINE # define WARN_NEWLINE 9 #endif #ifndef WARN_PIPE # define WARN_PIPE 10 #endif #ifndef WARN_UNOPENED # define WARN_UNOPENED 11 #endif #ifndef WARN_MISC # define WARN_MISC 12 #endif #ifndef WARN_NUMERIC # define WARN_NUMERIC 13 #endif #ifndef WARN_ONCE # define WARN_ONCE 14 #endif #ifndef WARN_OVERFLOW # define WARN_OVERFLOW 15 #endif #ifndef WARN_PACK # define WARN_PACK 16 #endif #ifndef WARN_PORTABLE # define WARN_PORTABLE 17 #endif #ifndef WARN_RECURSION # define WARN_RECURSION 18 #endif #ifndef WARN_REDEFINE # define WARN_REDEFINE 19 #endif #ifndef WARN_REGEXP # define WARN_REGEXP 20 #endif #ifndef WARN_SEVERE # define WARN_SEVERE 21 #endif #ifndef WARN_DEBUGGING # define WARN_DEBUGGING 22 #endif #ifndef WARN_INPLACE # define WARN_INPLACE 23 #endif #ifndef WARN_INTERNAL # define WARN_INTERNAL 24 #endif #ifndef WARN_MALLOC # define WARN_MALLOC 25 #endif #ifndef WARN_SIGNAL # define WARN_SIGNAL 26 #endif #ifndef WARN_SUBSTR # define WARN_SUBSTR 27 #endif #ifndef WARN_SYNTAX # define WARN_SYNTAX 28 #endif #ifndef WARN_AMBIGUOUS # define WARN_AMBIGUOUS 29 #endif #ifndef WARN_BAREWORD # define WARN_BAREWORD 30 #endif #ifndef WARN_DIGIT # define WARN_DIGIT 31 #endif #ifndef WARN_PARENTHESIS # define WARN_PARENTHESIS 32 #endif #ifndef WARN_PRECEDENCE # define WARN_PRECEDENCE 33 #endif #ifndef WARN_PRINTF # define WARN_PRINTF 34 #endif #ifndef WARN_PROTOTYPE # define WARN_PROTOTYPE 35 #endif #ifndef WARN_QW # define WARN_QW 36 #endif #ifndef WARN_RESERVED # define WARN_RESERVED 37 #endif #ifndef WARN_SEMICOLON # define WARN_SEMICOLON 38 #endif #ifndef WARN_TAINT # define WARN_TAINT 39 #endif #ifndef WARN_THREADS # define WARN_THREADS 40 #endif #ifndef WARN_UNINITIALIZED # define WARN_UNINITIALIZED 41 #endif #ifndef WARN_UNPACK # define WARN_UNPACK 42 #endif #ifndef WARN_UNTIE # define WARN_UNTIE 43 #endif #ifndef WARN_UTF8 # define WARN_UTF8 44 #endif #ifndef WARN_VOID # define WARN_VOID 45 #endif #ifndef WARN_ASSERTIONS # define WARN_ASSERTIONS 46 #endif #ifndef packWARN # define packWARN(a) (a) #endif #ifndef ckWARN # ifdef G_WARN_ON # define ckWARN(a) (PL_dowarn & G_WARN_ON) # else # define ckWARN(a) PL_dowarn # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(warner) #if defined(NEED_warner) static void DPPP_(my_warner)(U32 err, const char *pat, ...); static #else extern void DPPP_(my_warner)(U32 err, const char *pat, ...); #endif #define Perl_warner DPPP_(my_warner) #if defined(NEED_warner) || defined(NEED_warner_GLOBAL) void DPPP_(my_warner)(U32 err, const char *pat, ...) { SV *sv; va_list args; PERL_UNUSED_ARG(err); va_start(args, pat); sv = vnewSVpvf(pat, &args); va_end(args); sv_2mortal(sv); warn("%s", SvPV_nolen(sv)); } #define warner Perl_warner #define Perl_warner_nocontext Perl_warner #endif #endif /* concatenating with "" ensures that only literal strings are accepted as argument * note that STR_WITH_LEN() can't be used as argument to macros or functions that * under some configurations might be macros */ #ifndef STR_WITH_LEN # define STR_WITH_LEN(s) (s ""), (sizeof(s)-1) #endif #ifndef newSVpvs # define newSVpvs(str) newSVpvn(str "", sizeof(str) - 1) #endif #ifndef sv_catpvs # define sv_catpvs(sv, str) sv_catpvn(sv, str "", sizeof(str) - 1) #endif #ifndef sv_setpvs # define sv_setpvs(sv, str) sv_setpvn(sv, str "", sizeof(str) - 1) #endif #ifndef hv_fetchs # define hv_fetchs(hv, key, lval) hv_fetch(hv, key "", sizeof(key) - 1, lval) #endif #ifndef hv_stores # define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0) #endif #ifndef SvGETMAGIC # define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END #endif #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 /* That's the best we can do... */ #ifndef sv_catpvn_nomg # define sv_catpvn_nomg sv_catpvn #endif #ifndef sv_catsv_nomg # define sv_catsv_nomg sv_catsv #endif #ifndef sv_setsv_nomg # define sv_setsv_nomg sv_setsv #endif #ifndef sv_pvn_nomg # define sv_pvn_nomg sv_pvn #endif #ifndef SvIV_nomg # define SvIV_nomg SvIV #endif #ifndef SvUV_nomg # define SvUV_nomg SvUV #endif #ifndef sv_catpv_mg # define sv_catpv_mg(sv, ptr) \ STMT_START { \ SV *TeMpSv = sv; \ sv_catpv(TeMpSv,ptr); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_catpvn_mg # define sv_catpvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_catpvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_catsv_mg # define sv_catsv_mg(dsv, ssv) \ STMT_START { \ SV *TeMpSv = dsv; \ sv_catsv(TeMpSv,ssv); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setiv_mg # define sv_setiv_mg(sv, i) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setiv(TeMpSv,i); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setnv_mg # define sv_setnv_mg(sv, num) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setnv(TeMpSv,num); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setpv_mg # define sv_setpv_mg(sv, ptr) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setpv(TeMpSv,ptr); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setpvn_mg # define sv_setpvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setpvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setsv_mg # define sv_setsv_mg(dsv, ssv) \ STMT_START { \ SV *TeMpSv = dsv; \ sv_setsv(TeMpSv,ssv); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setuv_mg # define sv_setuv_mg(sv, i) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setuv(TeMpSv,i); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_usepvn_mg # define sv_usepvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_usepvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef SvVSTRING_mg # define SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL) #endif /* Hint: sv_magic_portable * This is a compatibility function that is only available with * Devel::PPPort. It is NOT in the perl core. * Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when * it is being passed a name pointer with namlen == 0. In that * case, perl 5.8.0 and later store the pointer, not a copy of it. * The compatibility can be provided back to perl 5.004. With * earlier versions, the code will not compile. */ #if (PERL_BCDVERSION < 0x5004000) /* code that uses sv_magic_portable will not compile */ #elif (PERL_BCDVERSION < 0x5008000) # define sv_magic_portable(sv, obj, how, name, namlen) \ STMT_START { \ SV *SvMp_sv = (sv); \ char *SvMp_name = (char *) (name); \ I32 SvMp_namlen = (namlen); \ if (SvMp_name && SvMp_namlen == 0) \ { \ MAGIC *mg; \ sv_magic(SvMp_sv, obj, how, 0, 0); \ mg = SvMAGIC(SvMp_sv); \ mg->mg_len = -42; /* XXX: this is the tricky part */ \ mg->mg_ptr = SvMp_name; \ } \ else \ { \ sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \ } \ } STMT_END #else # define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e) #endif #ifdef USE_ITHREADS #ifndef CopFILE # define CopFILE(c) ((c)->cop_file) #endif #ifndef CopFILEGV # define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv) #endif #ifndef CopFILE_set # define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) #endif #ifndef CopFILESV # define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) #endif #ifndef CopFILEAV # define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) #endif #ifndef CopSTASHPV # define CopSTASHPV(c) ((c)->cop_stashpv) #endif #ifndef CopSTASHPV_set # define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) #endif #ifndef CopSTASH # define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) #endif #ifndef CopSTASH_set # define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) #endif #ifndef CopSTASH_eq # define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \ || (CopSTASHPV(c) && HvNAME(hv) \ && strEQ(CopSTASHPV(c), HvNAME(hv))))) #endif #else #ifndef CopFILEGV # define CopFILEGV(c) ((c)->cop_filegv) #endif #ifndef CopFILEGV_set # define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) #endif #ifndef CopFILE_set # define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) #endif #ifndef CopFILESV # define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) #endif #ifndef CopFILEAV # define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) #endif #ifndef CopFILE # define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) #endif #ifndef CopSTASH # define CopSTASH(c) ((c)->cop_stash) #endif #ifndef CopSTASH_set # define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) #endif #ifndef CopSTASHPV # define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) #endif #ifndef CopSTASHPV_set # define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) #endif #ifndef CopSTASH_eq # define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) #endif #endif /* USE_ITHREADS */ #ifndef IN_PERL_COMPILETIME # define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) #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 IN_LOCALE # define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) #endif #ifndef IS_NUMBER_IN_UV # define IS_NUMBER_IN_UV 0x01 #endif #ifndef IS_NUMBER_GREATER_THAN_UV_MAX # define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 #endif #ifndef IS_NUMBER_NOT_INT # define IS_NUMBER_NOT_INT 0x04 #endif #ifndef IS_NUMBER_NEG # define IS_NUMBER_NEG 0x08 #endif #ifndef IS_NUMBER_INFINITY # define IS_NUMBER_INFINITY 0x10 #endif #ifndef IS_NUMBER_NAN # define IS_NUMBER_NAN 0x20 #endif #ifndef GROK_NUMERIC_RADIX # define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) #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 #ifndef grok_numeric_radix #if defined(NEED_grok_numeric_radix) static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); static #else extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); #endif #ifdef grok_numeric_radix # undef grok_numeric_radix #endif #define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b) #define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix) #if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) bool DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send) { #ifdef USE_LOCALE_NUMERIC #ifdef PL_numeric_radix_sv 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 /* older perls don't have PL_numeric_radix_sv so the radix * must manually be requested from locale.h */ #include dTHR; /* needed for older threaded perls */ 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 #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 #endif #ifndef grok_number #if defined(NEED_grok_number) static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); static #else extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); #endif #ifdef grok_number # undef grok_number #endif #define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c) #define Perl_grok_number DPPP_(my_grok_number) #if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) int DPPP_(my_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 #endif /* * The grok_* routines have been modified to use warn() instead of * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit, * which is why the stack variable has been renamed to 'xdigit'. */ #ifndef grok_bin #if defined(NEED_grok_bin) static UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_bin # undef grok_bin #endif #define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d) #define Perl_grok_bin DPPP_(my_grok_bin) #if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) UV DPPP_(my_grok_bin)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_2 = UV_MAX / 2; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { /* strip off leading b or 0b. for compatibility silently suffer "b" and "0b" as valid binary numbers. */ if (len >= 1) { if (s[0] == 'b') { s++; len--; } else if (len >= 2 && s[0] == '0' && s[1] == 'b') { s+=2; len-=2; } } } for (; len-- && *s; s++) { char bit = *s; if (bit == '0' || bit == '1') { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. With gcc seems to be much straighter code than old scan_bin. */ redo: if (!overflowed) { if (value <= max_div_2) { value = (value << 1) | (bit - '0'); continue; } /* Bah. We're just overflowed. */ warn("Integer overflow in binary number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 2.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount. */ value_nv += (NV)(bit - '0'); continue; } if (bit == '_' && len && allow_underscores && (bit = s[1]) && (bit == '0' || bit == '1')) { --len; ++s; goto redo; } if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal binary digit '%c' ignored", *s); break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Binary number > 0b11111111111111111111111111111111 non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #ifndef grok_hex #if defined(NEED_grok_hex) static UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_hex # undef grok_hex #endif #define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d) #define Perl_grok_hex DPPP_(my_grok_hex) #if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) UV DPPP_(my_grok_hex)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_16 = UV_MAX / 16; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; const char *xdigit; if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { /* strip off leading x or 0x. for compatibility silently suffer "x" and "0x" as valid hex numbers. */ if (len >= 1) { if (s[0] == 'x') { s++; len--; } else if (len >= 2 && s[0] == '0' && s[1] == 'x') { s+=2; len-=2; } } } for (; len-- && *s; s++) { xdigit = strchr((char *) PL_hexdigit, *s); if (xdigit) { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. With gcc seems to be much straighter code than old scan_hex. */ redo: if (!overflowed) { if (value <= max_div_16) { value = (value << 4) | ((xdigit - PL_hexdigit) & 15); continue; } warn("Integer overflow in hexadecimal number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 16.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount of 16-tuples. */ value_nv += (NV)((xdigit - PL_hexdigit) & 15); continue; } if (*s == '_' && len && allow_underscores && s[1] && (xdigit = strchr((char *) PL_hexdigit, s[1]))) { --len; ++s; goto redo; } if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal hexadecimal digit '%c' ignored", *s); break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Hexadecimal number > 0xffffffff non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #ifndef grok_oct #if defined(NEED_grok_oct) static UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_oct # undef grok_oct #endif #define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d) #define Perl_grok_oct DPPP_(my_grok_oct) #if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) UV DPPP_(my_grok_oct)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_8 = UV_MAX / 8; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; for (; len-- && *s; s++) { /* gcc 2.95 optimiser not smart enough to figure that this subtraction out front allows slicker code. */ int digit = *s - '0'; if (digit >= 0 && digit <= 7) { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. */ redo: if (!overflowed) { if (value <= max_div_8) { value = (value << 3) | digit; continue; } /* Bah. We're just overflowed. */ warn("Integer overflow in octal number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 8.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount of 8-tuples. */ value_nv += (NV)digit; continue; } if (digit == ('_' - '0') && len && allow_underscores && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) { --len; ++s; goto redo; } /* Allow \octal to work the DWIM way (that is, stop scanning * as soon as non-octal characters are seen, complain only iff * someone seems to want to use the digits eight and nine). */ if (digit == 8 || digit == 9) { if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal octal digit '%c' ignored", *s); } break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Octal number > 037777777777 non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #if !defined(my_snprintf) #if defined(NEED_my_snprintf) static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); static #else extern int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); #endif #define my_snprintf DPPP_(my_my_snprintf) #define Perl_my_snprintf DPPP_(my_my_snprintf) #if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL) int DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...) { dTHX; int retval; va_list ap; va_start(ap, format); #ifdef HAS_VSNPRINTF retval = vsnprintf(buffer, len, format, ap); #else retval = vsprintf(buffer, format, ap); #endif va_end(ap); if (retval >= (int)len) Perl_croak(aTHX_ "panic: my_snprintf buffer overflow"); return retval; } #endif #endif #ifdef NO_XSLOCKS # ifdef dJMPENV # define dXCPT dJMPENV; int rEtV = 0 # define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0) # define XCPT_TRY_END JMPENV_POP; # define XCPT_CATCH if (rEtV != 0) # define XCPT_RETHROW JMPENV_JUMP(rEtV) # else # define dXCPT Sigjmp_buf oldTOP; int rEtV = 0 # define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0) # define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf); # define XCPT_CATCH if (rEtV != 0) # define XCPT_RETHROW Siglongjmp(top_env, rEtV) # endif #endif #if !defined(my_strlcat) #if defined(NEED_my_strlcat) static Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); static #else extern Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); #endif #define my_strlcat DPPP_(my_my_strlcat) #define Perl_my_strlcat DPPP_(my_my_strlcat) #if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL) Size_t DPPP_(my_my_strlcat)(char *dst, const char *src, Size_t size) { Size_t used, length, copy; used = strlen(dst); length = strlen(src); if (size > 0 && used < size - 1) { copy = (length >= size - used) ? size - used - 1 : length; memcpy(dst + used, src, copy); dst[used + copy] = '\0'; } return used + length; } #endif #endif #if !defined(my_strlcpy) #if defined(NEED_my_strlcpy) static Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); static #else extern Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); #endif #define my_strlcpy DPPP_(my_my_strlcpy) #define Perl_my_strlcpy DPPP_(my_my_strlcpy) #if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL) Size_t DPPP_(my_my_strlcpy)(char *dst, const char *src, Size_t size) { Size_t length, copy; length = strlen(src); if (size > 0) { copy = (length >= size) ? size - 1 : length; memcpy(dst, src, copy); dst[copy] = '\0'; } return length; } #endif #endif #endif /* _P_P_PORTABILITY_H_ */ /* End of File ppport.h */ Cache-Memcached-Fast-0.21/script/0000755000175000017500000000000012127763146016063 5ustar tomashtomashCache-Memcached-Fast-0.21/script/benchmark.pl0000755000175000017500000002216712127763070020361 0ustar tomashtomash#! /usr/bin/perl # # Copyright (C) 2007-2008 Tomash Brechko. All rights reserved. # # This program is free software; you can redistribute it and/or modify # it under the same terms as Perl itself, either Perl version 5.8.8 # or, at your option, any later version of Perl 5 you may have # available. # use warnings; use strict; # NOTE: at least on Linux (kernel 2.6.18.2) there is a certain # artifact that affects wallclock time (but not CPU time) of some # benchmarks: when send/receive rate changes dramatically, the system # doesn't adopt to it right away. Instead, for some time a lot of # small-range ACK packets are being sent, and this increases the # latency. Because of this '*_multi (%h)', which comes first, has # bigger wallclock time than '*_multi (@h)', which comes next. I # tried pre-warming the connection, but this doesn't help in all # cases. Seems like 'noreply' mode is also affected, and maybe # 'nowait'. use constant default_iteration_count => 1_000; use constant key_count => 100; use constant NOWAIT => 1; use constant NOREPLY => 1; my $value = 'x' x 40; use FindBin; @ARGV >= 1 or die("Usage: $FindBin::Script HOST:PORT... [COUNT] [\"compare\"]\n" . "\n" . "HOST:PORT... - list of memcached server addresses.\n" . "COUNT - number of iterations (default " . default_iteration_count . ").\n" . " (each iteration will process " . key_count . " keys).\n" . "\"compare\" - literal string to enable comparison with\n" . " Cache::Memcached.\n"); my $compare = ($ARGV[$#ARGV] =~ /^compare$/); pop @ARGV if $compare; my $count = ($ARGV[$#ARGV] =~ /^\d+$/ ? pop @ARGV : default_iteration_count); my $max_keys = $count * key_count / 2; my @addrs = @ARGV; use Cache::Memcached::Fast; use Benchmark qw(:hireswallclock timethese cmpthese timeit timesum timestr); my $old; my $old_method = qr/^(?:add|set|replace|incr|decr|delete|get)$/; my $old_method_multi = qr/^get$/; if ($compare) { require Cache::Memcached; $old = new Cache::Memcached { servers => [@addrs], namespace => "Cache::Memcached::bench/$$/", connect_timeout => 5, select_timeout => 5, }; $old->enable_compress(0); } my $new = new Cache::Memcached::Fast { servers => [@addrs], namespace => "Cache::Memcached::bench/$$/", ketama_points => 150, nowait => NOWAIT, connect_timeout => 5, io_timeout => 5, }; my $version = $new->server_versions; if (keys %$version != @addrs) { my @servers = map { if (ref($_) eq 'HASH') { $_->{address}; } elsif (ref($_) eq 'ARRAY') { $_->[0]; } else { $_; } } @addrs; warn "No server is running at " . join(', ', grep { not exists $version->{$_} } @servers) . "\n"; exit 1; } my $min_version = 2 ** 31; while (my ($s, $v) = each %$version) { if ($v =~ /(\d+)\.(\d+)\.(\d+)/) { my $n = $1 * 10000 + $2 * 100 + $3; $min_version = $n if $n < $min_version; } else { warn "Can't parse version of $s: $v"; exit 1; } } my $noreply = NOREPLY && $min_version >= 10205; @addrs = map { +{ address => $_, noreply => $noreply } } @addrs; my $new_noreply = new Cache::Memcached::Fast { servers => [@addrs], namespace => "Cache::Memcached::bench/$$/", ketama_points => 150, connect_timeout => 5, io_timeout => 5, }; sub get_key { int(rand($max_keys)); } sub merge_hash { my ($h1, $h2) = @_; while (my ($k, $v) = each %$h2) { $h1->{$k} = $v; } } sub bench_finalize { my ($title, $code, $finalize) = @_; print "Benchmark: timing $count iterations of $title...\n"; my $b1 = timeit($count, $code); # We call nowait_push here. Otherwise the time of gathering # the results would be added to the following commands. my $b2 = timeit(1, $finalize); my $res = timesum($b1, $b2); print "$title: ", timestr($res, 'auto'), "\n"; return { $title => $res }; } sub run { my ($method, $value, $cas) = @_; my $params = sub { my @params; push @params, $_[0] . '-' . get_key(); push @params, 0 if $cas; push @params, $value if defined $value; return @params; }; my $params_multi = sub { my @res; for (my $i = 0; $i < key_count; ++$i) { my @params; push @params, $_[0] . '-' . get_key(); if ($cas or defined $value) { push @params, 0 if $cas; push @params, $value if defined $value; push @res, \@params; } else { push @res, @params; } } return @res; }; my @test = ( "$method" => sub { my $res = $new->$method(&$params('p$')) foreach (1..key_count) }, ); push @test, ( "old $method" => sub { my $res = $old->$method(&$params('o$')) foreach (1..key_count) }, ) if defined $old and $method =~ /$old_method/o; my $bench = timethese($count, {@test}); if (defined $value and $noreply) { # We call get('no-such-key') here. Otherwise the time of # sending the requests might be added to the following # commands. my $res = bench_finalize("$method noreply", sub { $new_noreply->$method(&$params('pr')) foreach (1..key_count) }, sub { $new_noreply->get('no-such-key') }); merge_hash($bench, $res); if (defined $old and $method =~ /$old_method/o) { $res = bench_finalize("old $method noreply", sub { $old->$method(&$params('or')) foreach (1..key_count) }, sub { $old->get('no-such-key') }); merge_hash($bench, $res); } } if (defined $value and NOWAIT) { # We call nowait_push here. Otherwise the time of gathering # the results would be added to the following commands. my $res = bench_finalize("$method nowait", sub { $new->$method(&$params('pw')) foreach (1..key_count) }, sub { $new->nowait_push }); merge_hash($bench, $res); } my $method_multi = "${method}_multi"; @test = ( "$method_multi" . (defined $value ? ' (%h)' : '') => sub { my $res = $new->$method_multi(&$params_multi('m%')) }, ); # We use the same 'm%' prefix here as for the new module because # old module doesn't have set_multi, and we want to retrieve # something. push @test, ( "old $method_multi" => sub { my $res = $old->$method_multi(&$params_multi('m%')) }, ) if defined $old and $method =~ /$old_method_multi/o; push @test, ( "$method_multi (\@a)" => sub { my @res = $new->$method_multi(&$params_multi('m@')) }, ) if defined $value; merge_hash($bench, timethese($count, {@test})); if (defined $value and $noreply) { # We call get('no-such-key') here. Otherwise the time of # sending the requests might be added to the following # commands. my $res = bench_finalize("$method_multi noreply", sub { $new_noreply-> $method_multi(&$params_multi('mr')) }, sub { $new_noreply->get('no-such-key') }); merge_hash($bench, $res); } if (defined $value and NOWAIT) { # We call nowait_push here. Otherwise the time of gathering # the results would be added to the following commands. my $res = bench_finalize("$method_multi nowait", sub { $new->$method_multi(&$params_multi('mw')) }, sub { $new->nowait_push }); merge_hash($bench, $res); } cmpthese($bench); } my @methods = ( [add => \&run, $value], [set => \&run, $value], [append => \&run, $value], [prepend => \&run, $value], [replace => \&run, $value], [cas => \&run, $value, 'CAS'], [get => \&run], [gets => \&run], [incr => \&run, 1], [decr => \&run, 1], [delete => \&run, 0], ); print "Servers: @{[ keys %$version ]}\n"; print "Iteration count: $count\n"; print 'Keys per iteration: ', key_count, "\n"; print 'Value size: ', length($value), " bytes\n"; srand(1); foreach my $args (@methods) { my $sub = splice(@$args, 1, 1); &$sub(@$args); } # Benchmark latency issues. if ($noreply) { cmpthese(timethese($count, { "set noreply followed by get" => sub { foreach (1..key_count) { $new_noreply->set('snfbg', $value); my $res = $new_noreply->get('snfbg'); } } })); } Cache-Memcached-Fast-0.21/script/c-m-compat.pl0000755000175000017500000000356112127763070020361 0ustar tomashtomash#! /usr/bin/perl # # Copyright (C) 2008 Tomash Brechko. All rights reserved. # # This program is free software; you can redistribute it and/or modify # it under the same terms as Perl itself, either Perl version 5.8.8 # or, at your option, any later version of Perl 5 you may have # available. # use warnings; use strict; # NOTE: this test uses INSTANCE_COUNT x 2 file descriptors. This # means that normally spawning more than ~500 instances won't work. use FindBin; @ARGV >= 3 or die "Usage: $FindBin::Script MIN_PORT INSTANCE_COUNT KEY_COUNT [SEED]\n"; my ($min_port, $instance_count, $key_count, $seed) = @ARGV; $seed = time unless defined $seed; srand($seed); print "Instances: $instance_count, keys: $key_count, random seed: $seed\n"; my $host = '127.3.5.7'; use Cache::Memcached::Fast; use Cache::Memcached; my $max_port = $min_port + $instance_count - 1; my @children; END { kill 'SIGTERM', @children; } foreach my $port ($min_port..$max_port) { my $pid = fork; die "Can't fork: $!\n" unless defined $pid; if ($pid) { push @children, $pid; } else { exec('memcached', '-p', $port, '-m1') == 0 or die "Can't exec memcached on $host:$port: $!\n"; } } # Give memcached servers some time to become ready. sleep(1); my @addrs = map { "$host:$_" } ($min_port..$max_port); my $cm = new Cache::Memcached({ servers => \@addrs, select_timeout => 2 }); my $cmf = new Cache::Memcached::Fast({ servers => \@addrs, select_timeout => 2 }); foreach my $i (1..$key_count) { my $key = int(rand($key_count)); $cmf->set($key, $i) or die "Can't set key $key\n"; my $res = $cm->get($key); die "Fetch failed for key $key ($i), got @{[ defined $res ? $res : '(undef)' ]}\n" unless defined $res and $res == $i; } Cache-Memcached-Fast-0.21/script/ketama-distr.pl0000755000175000017500000000540512127763070021010 0ustar tomashtomash#! /usr/bin/perl # -*- cperl -*- # # Copyright (C) 2009 Tomash Brechko. All rights reserved. # # This program is free software; you can redistribute it and/or modify # it under the same terms as Perl itself, either Perl version 5.8.8 # or, at your option, any later version of Perl 5 you may have # available. # use warnings; use strict; =head1 NAME ketama-distr.pl - compute relative distribution of keys. =head1 SYNOPSIS ketama-distr.pl OPTIONS =head1 OPTIONS =over =item C<--ketama_points, -k NUM> B Number of ketama points per server of weight 1. =item C<--server, -s HOST:PORT[:WEIGHT]> B Specifies a server. May be given multiple times. Default I is 1. =back =cut use Getopt::Long qw(:config gnu_getopt); use Pod::Usage; my %options; if (! GetOptions(\%options, qw(ketama_points|k=i server|s=s@)) || @ARGV || grep({ not defined } @options{qw(ketama_points server)}) || $options{ketama_points} <= 0 || @{$options{server}} < 2) { pod2usage(1); } use String::CRC32; sub compute_old { my ($server, $index, $prev) = @_; $server =~ s/:/\0/; my $point = crc32($server . pack("V", $index)); return $point; } sub compute_new { my ($server, $index, $prev) = @_; $server =~ s/:/\0/; my $point = crc32($server . pack("V", $prev)); return $point; } sub compute { my ($compute_point) = @_; my @continuum; my $j = 0; foreach my $s (@{$options{server}}) { ++$j; my ($server, $weight) = $s =~ /^([^:]+:[^:]+)(?::(.+))?$/; die "$s should be HOST:PORT" unless defined $server; $weight = 1 unless defined $weight; my $prev = 0; for (my $i = 0; $i < $options{ketama_points} * $weight; ++$i) { my $point = $compute_point->($server, $i, $prev); push @continuum, [$point, "$j: $server"]; $prev = $point; } } use sort 'stable'; @continuum = sort {$a->[0] <=> $b->[0]} @continuum; my $prev_point = 0; my $first_server = ''; my %server_share; foreach my $c (@continuum) { $first_server = $c->[1] unless $first_server; $server_share{$c->[1]} += $c->[0] - $prev_point; $prev_point = $c->[0]; } # Wraparound case. $server_share{$first_server} += 2**32 - 1 - $prev_point; foreach my $s (sort keys %server_share) { my $share = $server_share{$s}; printf("server %s total = % 10u (%.2f%%)\n", $s, $share, $share * 100 / (2**32 - 1)); } return @continuum; } print "Old:\n"; compute(\&compute_old); print "\n"; print "New:\n"; my $total_points = compute(\&compute_new); print "\n"; my $int_size = 4; print "Continuum array size = ", $total_points * $int_size * 2, " bytes\n"; Cache-Memcached-Fast-0.21/typemap0000644000175000017500000000151212127763071016155 0ustar tomashtomash# Copyright (C) 2007-2008 Tomash Brechko. All rights reserved. # # This file is part of free software; you can redistribute it and/or # modify it under the same terms as Perl itself, either Perl version # 5.8.8 or, at your option, any later version of Perl 5 you may have # available. # TYPEMAP Cache_Memcached_Fast * T_CACHE_MEMCACHED_FAST INPUT T_CACHE_MEMCACHED_FAST /* We disable the derived check because it's kinda useless but slow. */ if (1 || sv_derived_from($arg, \"Cache::Memcached::Fast\")) { IV tmp = SvIV((SV *) SvRV($arg)); $var = INT2PTR(Cache_Memcached_Fast *, tmp); } else croak(\"$var is not of type Cache::Memcached::Fast\"); OUTPUT T_CACHE_MEMCACHED_FAST sv_setref_pv($arg, class, (void*) $var); Cache-Memcached-Fast-0.21/MANIFEST0000644000175000017500000000152312127763146015711 0ustar tomashtomashChanges Makefile.PL MANIFEST typemap Fast.xs ppport.h README script/benchmark.pl script/c-m-compat.pl script/ketama-distr.pl t/Memd.pm t/00-load.t t/01-connect.t t/02-isa.t t/big_value.t t/commands.t t/key_ref.t t/magic.t t/namespace.t t/nowait.t t/noreply.t t/serialize.t t/pod-coverage.t t/pod.t t/utf8.t t/threads.t lib/Cache/Memcached/Fast.pm src/Makefile.PL src/gencrc32.pl src/genparser.pl src/reply.kw src/array.h src/array.c src/client.h src/client.c src/connect.h src/connect.c src/dispatch_key.c src/dispatch_key.h src/socket_posix.c src/socket_posix.h src/socket_win32.c src/socket_win32.h src/poll_select.c src/poll_select.h src/addrinfo_hostent.c src/addrinfo_hostent.h META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Cache-Memcached-Fast-0.21/Fast.xs0000644000175000017500000010204312127763070016024 0ustar tomashtomash/* Copyright (C) 2007-2010 Tomash Brechko. All rights reserved. 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.8 or, at your option, any later version of Perl 5 you may have available. */ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "ppport.h" #include "src/client.h" #include #include #define F_STORABLE 0x1 #define F_COMPRESS 0x2 #define F_UTF8 0x4 struct xs_state { struct client *c; AV *servers; int compress_threshold; double compress_ratio; SV *compress_method; SV *decompress_method; SV *serialize_method; SV *deserialize_method; int utf8; size_t max_size; }; typedef struct xs_state Cache_Memcached_Fast; static void add_server(Cache_Memcached_Fast *memd, SV *addr_sv, double weight, int noreply) { struct client *c = memd->c; static const int delim = ':'; const char *host, *port; size_t host_len, port_len; STRLEN len; int res; av_push(memd->servers, newSVsv(addr_sv)); if (weight <= 0.0) croak("Server weight should be positive"); host = SvPV(addr_sv, len); /* NOTE: here we relay on the fact that host is zero-terminated. */ port = strrchr(host, delim); if (port) { host_len = port - host; ++port; port_len = len - host_len - 1; res = client_add_server(c, host, host_len, port, port_len, weight, noreply); } else { res = client_add_server(c, host, len, NULL, 0, weight, noreply); } if (res != MEMCACHED_SUCCESS) croak("Not enough memory"); } static void parse_server(Cache_Memcached_Fast *memd, SV *sv) { if (! SvROK(sv)) { add_server(memd, sv, 1.0, 0); } else { switch (SvTYPE(SvRV(sv))) { case SVt_PVHV: { HV *hv = (HV *) SvRV(sv); SV **addr_sv, **ps; double weight = 1.0; int noreply = 0; addr_sv = hv_fetch(hv, "address", 7, 0); if (addr_sv) SvGETMAGIC(*addr_sv); else croak("server should have { address => $addr }"); ps = hv_fetch(hv, "weight", 6, 0); if (ps) SvGETMAGIC(*ps); if (ps && SvOK(*ps)) weight = SvNV(*ps); ps = hv_fetch(hv, "noreply", 7, 0); if (ps) SvGETMAGIC(*ps); if (ps && SvOK(*ps)) noreply = SvTRUE(*ps); add_server(memd, *addr_sv, weight, noreply); } break; case SVt_PVAV: { AV *av = (AV *) SvRV(sv); SV **addr_sv, **weight_sv; double weight = 1.0; addr_sv = av_fetch(av, 0, 0); if (addr_sv) SvGETMAGIC(*addr_sv); else croak("server should be [$addr, $weight]"); weight_sv = av_fetch(av, 1, 0); if (weight_sv) weight = SvNV(*weight_sv); add_server(memd, *addr_sv, weight, 0); } break; default: croak("Not a hash or array reference"); break; } } } static void parse_serialize(Cache_Memcached_Fast *memd, HV *conf) { SV **ps; memd->utf8 = 0; memd->serialize_method = NULL; memd->deserialize_method = NULL; ps = hv_fetch(conf, "utf8", 4, 0); if (ps) SvGETMAGIC(*ps); if (ps && SvOK(*ps)) memd->utf8 = SvTRUE(*ps); ps = hv_fetch(conf, "serialize_methods", 17, 0); if (ps) SvGETMAGIC(*ps); if (ps && SvOK(*ps)) { AV *av = (AV *) SvRV(*ps); memd->serialize_method = newSVsv(*av_fetch(av, 0, 0)); memd->deserialize_method = newSVsv(*av_fetch(av, 1, 0)); } if (! memd->serialize_method) croak("Serialize method is not specified"); if (! memd->deserialize_method) croak("Deserialize method is not specified"); } static void parse_compress(Cache_Memcached_Fast *memd, HV *conf) { SV **ps; memd->compress_threshold = -1; memd->compress_ratio = 0.8; memd->compress_method = NULL; memd->decompress_method = NULL; ps = hv_fetch(conf, "compress_threshold", 18, 0); if (ps) SvGETMAGIC(*ps); if (ps && SvOK(*ps)) memd->compress_threshold = SvIV(*ps); ps = hv_fetch(conf, "compress_ratio", 14, 0); if (ps) SvGETMAGIC(*ps); if (ps && SvOK(*ps)) memd->compress_ratio = SvNV(*ps); ps = hv_fetch(conf, "compress_methods", 16, 0); if (ps) SvGETMAGIC(*ps); if (ps && SvOK(*ps)) { AV *av = (AV *) SvRV(*ps); memd->compress_method = newSVsv(*av_fetch(av, 0, 0)); memd->decompress_method = newSVsv(*av_fetch(av, 1, 0)); } else if (memd->compress_threshold > 0) { warn("Compression module was not found, disabling compression"); memd->compress_threshold = -1; } } static void parse_config(Cache_Memcached_Fast *memd, HV *conf) { struct client *c = memd->c; SV **ps; memd->servers = newAV(); ps = hv_fetch(conf, "ketama_points", 13, 0); if (ps) SvGETMAGIC(*ps); if (ps && SvOK(*ps)) { int res = client_set_ketama_points(c, SvIV(*ps)); if (res != MEMCACHED_SUCCESS) croak("client_set_ketama() failed"); } ps = hv_fetch(conf, "hash_namespace", 14, 0); if (ps) SvGETMAGIC(*ps); if (ps && SvOK(*ps)) client_set_hash_namespace(c, SvTRUE(*ps)); ps = hv_fetch(conf, "servers", 7, 0); if (ps) SvGETMAGIC(*ps); if (ps && SvOK(*ps)) { AV *a; int max_index, i; if (! SvROK(*ps) || SvTYPE(SvRV(*ps)) != SVt_PVAV) croak("Not an array reference"); a = (AV *) SvRV(*ps); max_index = av_len(a); for (i = 0; i <= max_index; ++i) { ps = av_fetch(a, i, 0); if (! ps) continue; SvGETMAGIC(*ps); parse_server(memd, *ps); } } ps = hv_fetch(conf, "namespace", 9, 0); if (ps) SvGETMAGIC(*ps); if (ps && SvOK(*ps)) { const char *ns; STRLEN len; ns = SvPV(*ps, len); if (client_set_prefix(c, ns, len) != MEMCACHED_SUCCESS) croak("Not enough memory"); } ps = hv_fetch(conf, "connect_timeout", 15, 0); if (ps) SvGETMAGIC(*ps); if (ps && SvOK(*ps)) client_set_connect_timeout(c, SvNV(*ps) * 1000.0); ps = hv_fetch(conf, "io_timeout", 10, 0); if (ps) SvGETMAGIC(*ps); if (ps && SvOK(*ps)) client_set_io_timeout(c, SvNV(*ps) * 1000.0); /* For compatibility with Cache::Memcached. */ ps = hv_fetch(conf, "select_timeout", 14, 0); if (ps) SvGETMAGIC(*ps); if (ps && SvOK(*ps)) client_set_io_timeout(c, SvNV(*ps) * 1000.0); ps = hv_fetch(conf, "max_failures", 12, 0); if (ps) SvGETMAGIC(*ps); if (ps && SvOK(*ps)) client_set_max_failures(c, SvIV(*ps)); ps = hv_fetch(conf, "failure_timeout", 15, 0); if (ps) SvGETMAGIC(*ps); if (ps && SvOK(*ps)) client_set_failure_timeout(c, SvIV(*ps)); ps = hv_fetch(conf, "close_on_error", 14, 0); if (ps) SvGETMAGIC(*ps); if (ps && SvOK(*ps)) client_set_close_on_error(c, SvTRUE(*ps)); ps = hv_fetch(conf, "nowait", 6, 0); if (ps) SvGETMAGIC(*ps); if (ps && SvOK(*ps)) client_set_nowait(c, SvTRUE(*ps)); ps = hv_fetch(conf, "max_size", 8, 0); if (ps) SvGETMAGIC(*ps); if (ps && SvOK(*ps)) memd->max_size = SvUV(*ps); else memd->max_size = 1024 * 1024; parse_compress(memd, conf); parse_serialize(memd, conf); } static inline SV * compress(Cache_Memcached_Fast *memd, SV *sv, flags_type *flags) { if (memd->compress_threshold > 0) { STRLEN len = sv_len(sv); SV *csv, *bsv; int count; dSP; if (len < (STRLEN) memd->compress_threshold) return sv; csv = newSV(0); PUSHMARK(SP); XPUSHs(sv_2mortal(newRV_inc(sv))); XPUSHs(sv_2mortal(newRV_noinc(csv))); PUTBACK; count = call_sv(memd->compress_method, G_SCALAR); SPAGAIN; if (count != 1) croak("Compress method returned nothing"); bsv = POPs; if (SvTRUE(bsv) && sv_len(csv) <= len * memd->compress_ratio) { sv = csv; *flags |= F_COMPRESS; } PUTBACK; } return sv; } static inline int decompress(Cache_Memcached_Fast *memd, SV **sv, flags_type flags) { int res = 1; if (flags & F_COMPRESS) { SV *rsv, *bsv; int count; dSP; rsv = newSV(0); PUSHMARK(SP); XPUSHs(sv_2mortal(newRV_inc(*sv))); XPUSHs(sv_2mortal(newRV_inc(rsv))); PUTBACK; count = call_sv(memd->decompress_method, G_SCALAR); SPAGAIN; if (count != 1) croak("Decompress method returned nothing"); bsv = POPs; if (SvTRUE(bsv)) { SvREFCNT_dec(*sv); *sv = rsv; } else { SvREFCNT_dec(rsv); res = 0; } PUTBACK; } return res; } static inline SV * serialize(Cache_Memcached_Fast *memd, SV *sv, flags_type *flags) { if (SvROK(sv)) { int count; dSP; PUSHMARK(SP); XPUSHs(sv); PUTBACK; count = call_sv(memd->serialize_method, G_SCALAR); SPAGAIN; if (count != 1) croak("Serialize method returned nothing"); sv = POPs; *flags |= F_STORABLE; PUTBACK; } else if (memd->utf8 && SvUTF8(sv)) { /* Copy the value because we will modify it in place. */ sv = sv_2mortal(newSVsv(sv)); sv_utf8_encode(sv); *flags |= F_UTF8; } return sv; } static inline int deserialize(Cache_Memcached_Fast *memd, SV **sv, flags_type flags) { int res = 1; if (flags & F_STORABLE) { SV *rsv; int count; dSP; PUSHMARK(SP); XPUSHs(*sv); PUTBACK; /* FIXME: do we need G_KEPEERR here? */ count = call_sv(memd->deserialize_method, G_SCALAR | G_EVAL); SPAGAIN; if (count != 1) croak("Deserialize method returned nothing"); rsv = POPs; if (! SvTRUE(ERRSV)) { SvREFCNT_dec(*sv); *sv = SvREFCNT_inc(rsv); } else { res = 0; } PUTBACK; } else if ((flags & F_UTF8) && memd->utf8) { res = sv_utf8_decode(*sv); } return res; } static void * alloc_value(value_size_type value_size, void **opaque) { SV *sv; char *res; sv = newSVpvn("", 0); res = SvGROW(sv, value_size + 1); /* FIXME: check OOM. */ res[value_size] = '\0'; SvCUR_set(sv, value_size); *opaque = sv; return (void *) res; } static void free_value(void *opaque) { SV *sv = (SV *) opaque; SvREFCNT_dec(sv); } struct xs_value_result { Cache_Memcached_Fast *memd; SV *vals; }; static void svalue_store(void *arg, void *opaque, int key_index, void *meta) { SV *value_sv = (SV *) opaque; struct xs_value_result *value_res = (struct xs_value_result *) arg; struct meta_object *m = (struct meta_object *) meta; /* Suppress warning about unused key_index. */ if (key_index) {} if (! decompress(value_res->memd, &value_sv, m->flags) || ! deserialize(value_res->memd, &value_sv, m->flags)) { free_value(value_sv); return; } if (! m->use_cas) { value_res->vals = value_sv; } else { AV *cas_val = newAV(); av_extend(cas_val, 1); av_push(cas_val, newSVuv(m->cas)); av_push(cas_val, value_sv); value_res->vals = newRV_noinc((SV *) cas_val); } } static void mvalue_store(void *arg, void *opaque, int key_index, void *meta) { SV *value_sv = (SV *) opaque; struct xs_value_result *value_res = (struct xs_value_result *) arg; struct meta_object *m = (struct meta_object *) meta; if (! decompress(value_res->memd, &value_sv, m->flags) || ! deserialize(value_res->memd, &value_sv, m->flags)) { free_value(value_sv); return; } if (! m->use_cas) { av_store((AV *) value_res->vals, key_index, value_sv); } else { AV *cas_val = newAV(); av_extend(cas_val, 1); av_push(cas_val, newSVuv(m->cas)); av_push(cas_val, value_sv); av_store((AV *) value_res->vals, key_index, newRV_noinc((SV *) cas_val)); } } static void result_store(void *arg, void *opaque, int key_index, void *meta) { AV *av = (AV *) arg; int res = (long) opaque; /* Suppress warning about unused meta. */ if (meta) {} if (res) av_store(av, key_index, newSViv(res)); else av_store(av, key_index, newSVpvn("", 0)); } static void embedded_store(void *arg, void *opaque, int key_index, void *meta) { AV *av = (AV *) arg; SV *sv = (SV *) opaque; /* Suppress warning about unused meta. */ if (meta) {} av_store(av, key_index, sv); } /* When SvPV() is called on a magic SV the result of mg_get() is cached in PV slot. Since we pass around pointers to this storage we have to avoid value refetch and reallocation that would happen if mg_get() is called again. Because any magic SV may be put to the argument list more than once we create a temporal copies of them, thus braking possible ties and ensuring that every argument is fetched exactly once. */ static inline char * SvPV_stable_storage(SV *sv, STRLEN *lp) { if (SvGAMAGIC(sv)) sv = sv_2mortal(newSVsv(sv)); return SvPV(sv, *lp); } MODULE = Cache::Memcached::Fast PACKAGE = Cache::Memcached::Fast Cache_Memcached_Fast * _new(class, conf) char * class SV * conf PROTOTYPE: $$ PREINIT: Cache_Memcached_Fast *memd; CODE: memd = (Cache_Memcached_Fast *) malloc(sizeof(Cache_Memcached_Fast)); memd->c = client_init(); if (! memd->c) croak("Not enough memory"); if (! SvROK(conf) || SvTYPE(SvRV(conf)) != SVt_PVHV) croak("Not a hash reference"); parse_config(memd, (HV *) SvRV(conf)); RETVAL = memd; OUTPUT: RETVAL void _destroy(memd) Cache_Memcached_Fast * memd PROTOTYPE: $ CODE: client_destroy(memd->c); if (memd->compress_method) { SvREFCNT_dec(memd->compress_method); SvREFCNT_dec(memd->decompress_method); } if (memd->serialize_method) { SvREFCNT_dec(memd->serialize_method); SvREFCNT_dec(memd->deserialize_method); } SvREFCNT_dec(memd->servers); free(memd); void enable_compress(memd, enable) Cache_Memcached_Fast * memd bool enable PROTOTYPE: $$ CODE: if (enable && ! memd->compress_method) warn("Compression module was not found, can't enable compression"); else if ((memd->compress_threshold > 0) != enable) memd->compress_threshold = -memd->compress_threshold; void set(memd, ...) Cache_Memcached_Fast * memd ALIAS: add = CMD_ADD replace = CMD_REPLACE append = CMD_APPEND prepend = CMD_PREPEND cas = CMD_CAS PROTOTYPE: $@ PREINIT: int noreply; struct result_object object = { NULL, result_store, NULL, NULL }; const char *key; STRLEN key_len; cas_type cas = 0; const void *buf; STRLEN buf_len; flags_type flags = 0; exptime_type exptime = 0; int arg = 1; SV *sv; PPCODE: object.arg = newAV(); sv_2mortal((SV *) object.arg); noreply = (GIMME_V == G_VOID); client_reset(memd->c, &object, noreply); key = SvPV_stable_storage(ST(arg), &key_len); ++arg; if (ix == CMD_CAS) { cas = SvUV(ST(arg)); ++arg; } sv = ST(arg); ++arg; sv = serialize(memd, sv, &flags); sv = compress(memd, sv, &flags); buf = (void *) SvPV_stable_storage(sv, &buf_len); if (buf_len > memd->max_size) XSRETURN_EMPTY; if (items > arg) { /* exptime doesn't have to be defined. */ sv = ST(arg); SvGETMAGIC(sv); if (SvOK(sv)) exptime = SvIV(sv); } if (ix != CMD_CAS) { client_prepare_set(memd->c, ix, 0, key, key_len, flags, exptime, buf, buf_len); } else { client_prepare_cas(memd->c, 0, key, key_len, cas, flags, exptime, buf, buf_len); } client_execute(memd->c); if (! noreply) { SV **val = av_fetch(object.arg, 0, 0); if (val) { PUSHs(*val); XSRETURN(1); } } void set_multi(memd, ...) Cache_Memcached_Fast * memd ALIAS: add_multi = CMD_ADD replace_multi = CMD_REPLACE append_multi = CMD_APPEND prepend_multi = CMD_PREPEND cas_multi = CMD_CAS PROTOTYPE: $@ PREINIT: int i, noreply; struct result_object object = { NULL, result_store, NULL, NULL }; PPCODE: object.arg = newAV(); sv_2mortal((SV *) object.arg); noreply = (GIMME_V == G_VOID); client_reset(memd->c, &object, noreply); for (i = 1; i < items; ++i) { SV *sv; AV *av; const char *key; STRLEN key_len; /* gcc-3.4.2 gives a warning about possibly uninitialized cas, so we set it to zero. */ cas_type cas = 0; const void *buf; STRLEN buf_len; flags_type flags = 0; exptime_type exptime = 0; int arg = 0; sv = ST(i); if (! (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV)) croak("Not an array reference"); av = (AV *) SvRV(sv); /* The following values should be defined, so we do not do any additional checks for speed. */ key = SvPV_stable_storage(*av_fetch(av, arg, 0), &key_len); ++arg; if (ix == CMD_CAS) { cas = SvUV(*av_fetch(av, arg, 0)); ++arg; } sv = *av_fetch(av, arg, 0); ++arg; sv = serialize(memd, sv, &flags); sv = compress(memd, sv, &flags); buf = (void *) SvPV_stable_storage(sv, &buf_len); if (buf_len > memd->max_size) continue; if (av_len(av) >= arg) { /* exptime doesn't have to be defined. */ SV **ps = av_fetch(av, arg, 0); if (ps) SvGETMAGIC(*ps); if (ps && SvOK(*ps)) exptime = SvIV(*ps); } if (ix != CMD_CAS) { client_prepare_set(memd->c, ix, i - 1, key, key_len, flags, exptime, buf, buf_len); } else { client_prepare_cas(memd->c, i - 1, key, key_len, cas, flags, exptime, buf, buf_len); } } client_execute(memd->c); if (! noreply) { if (GIMME_V == G_SCALAR) { HV *hv = newHV(); for (i = 0; i <= av_len(object.arg); ++i) { SV **val = av_fetch(object.arg, i, 0); if (val && SvOK(*val)) { SV *key = *av_fetch((AV *) SvRV(ST(i + 1)), 0, 0); HE *he = hv_store_ent(hv, key, SvREFCNT_inc(*val), 0); if (! he) SvREFCNT_dec(*val); } } PUSHs(sv_2mortal(newRV_noinc((SV *) hv))); XSRETURN(1); } else { I32 max_index = av_len(object.arg); EXTEND(SP, max_index + 1); for (i = 0; i <= max_index; ++i) { SV **val = av_fetch(object.arg, i, 0); if (val) PUSHs(*val); else PUSHs(&PL_sv_undef); } XSRETURN(max_index + 1); } } void get(memd, ...) Cache_Memcached_Fast * memd ALIAS: gets = CMD_GETS PROTOTYPE: $@ PREINIT: struct xs_value_result value_res; struct result_object object = { alloc_value, svalue_store, free_value, &value_res }; const char *key; STRLEN key_len; PPCODE: value_res.memd = memd; value_res.vals = NULL; client_reset(memd->c, &object, 0); key = SvPV(ST(1), key_len); client_prepare_get(memd->c, ix, 0, key, key_len); client_execute(memd->c); if (value_res.vals) { PUSHs(sv_2mortal(value_res.vals)); XSRETURN(1); } void get_multi(memd, ...) Cache_Memcached_Fast * memd ALIAS: gets_multi = CMD_GETS PROTOTYPE: $@ PREINIT: struct xs_value_result value_res; struct result_object object = { alloc_value, mvalue_store, free_value, &value_res }; int i, key_count; HV *hv; PPCODE: key_count = items - 1; value_res.memd = memd; value_res.vals = (SV *) newAV(); sv_2mortal(value_res.vals); av_extend((AV *) value_res.vals, key_count - 1); client_reset(memd->c, &object, 0); for (i = 0; i < key_count; ++i) { const char *key; STRLEN key_len; key = SvPV_stable_storage(ST(i + 1), &key_len); client_prepare_get(memd->c, ix, i, key, key_len); } client_execute(memd->c); hv = newHV(); for (i = 0; i <= av_len((AV *) value_res.vals); ++i) { SV **val = av_fetch((AV *) value_res.vals, i, 0); if (val && SvOK(*val)) { SV *key = ST(i + 1); HE *he = hv_store_ent(hv, key, SvREFCNT_inc(*val), 0); if (! he) SvREFCNT_dec(*val); } } PUSHs(sv_2mortal(newRV_noinc((SV *) hv))); XSRETURN(1); void incr(memd, ...) Cache_Memcached_Fast * memd ALIAS: decr = CMD_DECR PROTOTYPE: $@ PREINIT: struct result_object object = { alloc_value, embedded_store, NULL, NULL }; int noreply; const char *key; STRLEN key_len; arith_type arg = 1; PPCODE: object.arg = newAV(); sv_2mortal((SV *) object.arg); noreply = (GIMME_V == G_VOID); client_reset(memd->c, &object, noreply); key = SvPV_stable_storage(ST(1), &key_len); if (items > 2) { /* increment doesn't have to be defined. */ SV *sv = ST(2); SvGETMAGIC(sv); if (SvOK(sv)) arg = SvUV(sv); } client_prepare_incr(memd->c, ix, 0, key, key_len, arg); client_execute(memd->c); if (! noreply) { SV **val = av_fetch(object.arg, 0, 0); if (val) { PUSHs(*val); XSRETURN(1); } } void incr_multi(memd, ...) Cache_Memcached_Fast * memd ALIAS: decr_multi = CMD_DECR PROTOTYPE: $@ PREINIT: struct result_object object = { alloc_value, embedded_store, NULL, NULL }; int i, noreply; PPCODE: object.arg = newAV(); sv_2mortal((SV *) object.arg); noreply = (GIMME_V == G_VOID); client_reset(memd->c, &object, noreply); for (i = 1; i < items; ++i) { SV *sv; AV *av; const char *key; STRLEN key_len; arith_type arg = 1; sv = ST(i); if (! SvROK(sv)) { key = SvPV_stable_storage(sv, &key_len); } else { if (SvTYPE(SvRV(sv)) != SVt_PVAV) croak("Not an array reference"); av = (AV *) SvRV(sv); /* The following values should be defined, so we do not do any additional checks for speed. */ key = SvPV_stable_storage(*av_fetch(av, 0, 0), &key_len); if (av_len(av) >= 1) { /* increment doesn't have to be defined. */ SV **ps = av_fetch(av, 1, 0); if (ps) SvGETMAGIC(*ps); if (ps && SvOK(*ps)) arg = SvUV(*ps); } } client_prepare_incr(memd->c, ix, i - 1, key, key_len, arg); } client_execute(memd->c); if (! noreply) { if (GIMME_V == G_SCALAR) { HV *hv = newHV(); for (i = 0; i <= av_len(object.arg); ++i) { SV **val = av_fetch(object.arg, i, 0); if (val && SvOK(*val)) { SV *key; HE *he; key = ST(i + 1); if (SvROK(key)) key = *av_fetch((AV *) SvRV(key), 0, 0); he = hv_store_ent(hv, key, SvREFCNT_inc(*val), 0); if (! he) SvREFCNT_dec(*val); } } PUSHs(sv_2mortal(newRV_noinc((SV *) hv))); XSRETURN(1); } else { I32 max_index = av_len(object.arg); EXTEND(SP, max_index + 1); for (i = 0; i <= max_index; ++i) { SV **val = av_fetch(object.arg, i, 0); if (val) PUSHs(*val); else PUSHs(&PL_sv_undef); } XSRETURN(max_index + 1); } } void delete(memd, ...) Cache_Memcached_Fast * memd PROTOTYPE: $@ PREINIT: struct result_object object = { NULL, result_store, NULL, NULL }; int noreply; const char *key; STRLEN key_len; PPCODE: object.arg = newAV(); sv_2mortal((SV *) object.arg); noreply = (GIMME_V == G_VOID); client_reset(memd->c, &object, noreply); key = SvPV_stable_storage(ST(1), &key_len); if (items > 2) { /* Compatibility with old (key, delay) syntax. */ /* delay doesn't have to be defined. */ SV *sv = ST(2); SvGETMAGIC(sv); if (SvOK(sv) && SvUV(sv) != 0) warn("non-zero delete expiration time is ignored"); } client_prepare_delete(memd->c, 0, key, key_len); client_execute(memd->c); if (! noreply) { SV **val = av_fetch(object.arg, 0, 0); if (val) { PUSHs(*val); XSRETURN(1); } } void delete_multi(memd, ...) Cache_Memcached_Fast * memd PROTOTYPE: $@ PREINIT: struct result_object object = { NULL, result_store, NULL, NULL }; int i, noreply; PPCODE: object.arg = newAV(); sv_2mortal((SV *) object.arg); noreply = (GIMME_V == G_VOID); client_reset(memd->c, &object, noreply); for (i = 1; i < items; ++i) { SV *sv; const char *key; STRLEN key_len; sv = ST(i); if (! SvROK(sv)) { key = SvPV_stable_storage(sv, &key_len); } else { /* Compatibility with old [key, delay] syntax. */ AV *av; if (SvTYPE(SvRV(sv)) != SVt_PVAV) croak("Not an array reference"); av = (AV *) SvRV(sv); /* The following values should be defined, so we do not do any additional checks for speed. */ key = SvPV_stable_storage(*av_fetch(av, 0, 0), &key_len); if (av_len(av) >= 1) { /* delay doesn't have to be defined. */ SV **ps = av_fetch(av, 1, 0); if (ps) SvGETMAGIC(*ps); if (ps && SvOK(*ps) && SvUV(*ps) != 0) warn("non-zero delete expiration time is ignored"); } } client_prepare_delete(memd->c, i - 1, key, key_len); } client_execute(memd->c); if (! noreply) { if (GIMME_V == G_SCALAR) { HV *hv = newHV(); for (i = 0; i <= av_len(object.arg); ++i) { SV **val = av_fetch(object.arg, i, 0); if (val && SvOK(*val)) { SV *key; HE *he; key = ST(i + 1); if (SvROK(key)) key = *av_fetch((AV *) SvRV(key), 0, 0); he = hv_store_ent(hv, key, SvREFCNT_inc(*val), 0); if (! he) SvREFCNT_dec(*val); } } PUSHs(sv_2mortal(newRV_noinc((SV *) hv))); XSRETURN(1); } else { I32 max_index = av_len(object.arg); EXTEND(SP, max_index + 1); for (i = 0; i <= max_index; ++i) { SV **val = av_fetch(object.arg, i, 0); if (val) PUSHs(*val); else PUSHs(&PL_sv_undef); } XSRETURN(max_index + 1); } } HV * flush_all(memd, ...) Cache_Memcached_Fast * memd PROTOTYPE: $;$ PREINIT: delay_type delay = 0; struct result_object object = { NULL, result_store, NULL, NULL }; int noreply; CODE: RETVAL = newHV(); /* Why sv_2mortal() is needed is explained in perlxs. */ sv_2mortal((SV *) RETVAL); object.arg = sv_2mortal((SV *) newAV()); if (items > 1) { SV *sv = ST(1); SvGETMAGIC(sv); if (SvOK(sv)) delay = SvUV(sv); } noreply = (GIMME_V == G_VOID); client_flush_all(memd->c, delay, &object, noreply); if (! noreply) { int i; for (i = 0; i <= av_len(object.arg); ++i) { SV **server = av_fetch(memd->servers, i, 0); SV **version = av_fetch(object.arg, i, 0); if (version && SvOK(*version)) { HE *he = hv_store_ent(RETVAL, *server, SvREFCNT_inc(*version), 0); if (! he) SvREFCNT_dec(*version); } } } OUTPUT: RETVAL void nowait_push(memd) Cache_Memcached_Fast * memd PROTOTYPE: $ CODE: client_nowait_push(memd->c); HV * server_versions(memd) Cache_Memcached_Fast * memd PROTOTYPE: $ PREINIT: struct result_object object = { alloc_value, embedded_store, NULL, NULL }; int i; CODE: RETVAL = newHV(); /* Why sv_2mortal() is needed is explained in perlxs. */ sv_2mortal((SV *) RETVAL); object.arg = sv_2mortal((SV *) newAV()); client_server_versions(memd->c, &object); for (i = 0; i <= av_len(object.arg); ++i) { SV **server = av_fetch(memd->servers, i, 0); SV **version = av_fetch(object.arg, i, 0); if (version && SvOK(*version)) { HE *he = hv_store_ent(RETVAL, *server, SvREFCNT_inc(*version), 0); if (! he) SvREFCNT_dec(*version); } } OUTPUT: RETVAL SV * namespace(memd, ...) Cache_Memcached_Fast * memd PROTOTYPE: $;$ PREINIT: const char *ns; size_t len; CODE: ns = client_get_prefix(memd->c, &len); RETVAL = newSVpv(ns, len); if (items > 1) { ns = SvPV(ST(1), len); if (client_set_prefix(memd->c, ns, len) != MEMCACHED_SUCCESS) croak("Not enough memory"); } OUTPUT: RETVAL void disconnect_all(memd) Cache_Memcached_Fast * memd PROTOTYPE: $ CODE: client_reinit(memd->c); Cache-Memcached-Fast-0.21/lib/0000755000175000017500000000000012127763146015325 5ustar tomashtomashCache-Memcached-Fast-0.21/lib/Cache/0000755000175000017500000000000012127763146016330 5ustar tomashtomashCache-Memcached-Fast-0.21/lib/Cache/Memcached/0000755000175000017500000000000012127763146020176 5ustar tomashtomashCache-Memcached-Fast-0.21/lib/Cache/Memcached/Fast.pm0000644000175000017500000011755212127763070021440 0ustar tomashtomash# See the end of the file for copyright and license. # package Cache::Memcached::Fast; use 5.006; use strict; use warnings; =head1 NAME Cache::Memcached::Fast - Perl client for B, in C language =head1 VERSION Version 0.21. =cut our $VERSION = '0.21'; =head1 SYNOPSIS use Cache::Memcached::Fast; my $memd = new Cache::Memcached::Fast({ servers => [ { address => 'localhost:11211', weight => 2.5 }, '192.168.254.2:11211', { address => '/path/to/unix.sock', noreply => 1 } ], namespace => 'my:', connect_timeout => 0.2, io_timeout => 0.5, close_on_error => 1, compress_threshold => 100_000, compress_ratio => 0.9, compress_methods => [ \&IO::Compress::Gzip::gzip, \&IO::Uncompress::Gunzip::gunzip ], max_failures => 3, failure_timeout => 2, ketama_points => 150, nowait => 1, hash_namespace => 1, serialize_methods => [ \&Storable::freeze, \&Storable::thaw ], utf8 => ($^V ge v5.8.1 ? 1 : 0), max_size => 512 * 1024, }); # Get server versions. my $versions = $memd->server_versions; while (my ($server, $version) = each %$versions) { #... } # Store scalars. $memd->add('skey', 'text'); $memd->add_multi(['skey2', 'text2'], ['skey3', 'text3', 10]); $memd->replace('skey', 'val'); $memd->replace_multi(['skey2', 'val2'], ['skey3', 'val3']); $memd->set('nkey', 5); $memd->set_multi(['nkey2', 10], ['skey3', 'text', 5]); # Store arbitrary Perl data structures. my %hash = (a => 1, b => 2); my @list = (1, 2); $memd->set('hash', \%hash); $memd->set_multi(['scalar', 1], ['list', \@list]); # Add to strings. $memd->prepend('skey', 'This is a '); $memd->prepend_multi(['skey2', 'This is a '], ['skey3', 'prefix ']); $memd->append('skey', 'ue.'); $memd->append_multi(['skey2', 'ue.'], ['skey3', ' suffix']); # Do arithmetic. $memd->incr('nkey', 10); print "OK\n" if $memd->decr('nkey', 3) == 12; my @counters = qw(c1 c2); $memd->set_multi(map { [$_, 0] } @counters, 'c3', 'c4'); $memd->incr_multi(['c3', 2], @counters, ['c4', 10]); # Retrieve values. my $val = $memd->get('skey'); print "OK\n" if $val eq 'This is a value.'; my $href = $memd->get_multi('hash', 'nkey'); print "OK\n" if $href->{hash}->{b} == 2 and $href->{nkey} == 12; # Do atomic test-and-set operations. my $cas_val = $memd->gets('nkey'); $$cas_val[1] = 0 if $$cas_val[1] == 12; if ($memd->cas('nkey', @$cas_val)) { print "OK, value updated\n"; } else { print "Update failed, probably another client" . " has updated the value\n"; } # Delete some data. $memd->delete('skey'); my @keys = qw(k1 k2 k3); $memd->delete_multi(@keys); # Wait for all commands that were executed in nowait mode. $memd->nowait_push; # Wipe out all cached data. $memd->flush_all; =head1 DESCRIPTION B is a Perl client for B, a memory cache daemon (L). Module core is implemented in C and tries hard to minimize number of system calls and to avoid any key/value copying for speed. As a result, it has very low CPU consumption. API is largely compatible with L, original pure Perl client, most users of the original module may start using this module by installing it and adding I<"::Fast"> to the old name in their scripts (see L below for full details). =cut use Carp; use Storable; require XSLoader; XSLoader::load('Cache::Memcached::Fast', $VERSION); =head1 CONSTRUCTOR =over =item C my $memd = new Cache::Memcached::Fast($params); Create new client object. I<$params> is a reference to a hash with client parameters. Currently recognized keys are: =over =item I servers => [ { address => 'localhost:11211', weight => 2.5 }, '192.168.254.2:11211', { address => '/path/to/unix.sock', noreply => 1 } ], (default: none) The value is a reference to an array of server addresses. Each address is either a scalar, a hash reference, or an array reference (for compatibility with Cache::Memcached, deprecated). If hash reference, the keys are I
(scalar), I (positive rational number), and I (boolean flag). The server address is in the form I for network TCP connections, or F for local Unix socket connections. When weight is not given, 1 is assumed. Client will distribute keys across servers proportionally to server weights. If you want to get key distribution compatible with Cache::Memcached, all server weights should be integer, and their sum should be less than 32768. When I is enabled, commands executed in a void context will instruct the server to not send the reply. Compare with L below. B server implements I starting with version 1.2.5. If you enable I for earlier server versions, things will go wrongly, and the client will eventually block. Use with care. =item I namespace => 'my::' (default: '') The value is a scalar that will be prepended to all key names passed to the B server. By using different namespaces clients avoid interference with each other. =item I hash_namespace => 1 (default: disabled) The value is a boolean which enables (true) or disables (false) the hashing of the namespace key prefix. By default for compatibility with B namespace prefix is not hashed along with the key. Thus namespace => 'prefix/', ... $memd->set('key', $val); may use different B server than namespace => '', ... $memd->set('prefix/key', $val); because hash values of I<'key'> and I<'prefix/key'> may be different. However sometimes is it necessary to hash the namespace prefix, for instance for interoperability with other clients that do not have the notion of the namespace. When I is enabled, both examples above will use the same server, the one that I<'prefix/key'> is mapped to. Note that there's no performance penalty then, as namespace prefix is hashed only once. See L. =item I nowait => 1 (default: disabled) The value is a boolean which enables (true) or disables (false) I mode. If enabled, when you call a method that only returns its success status (like L), B>, it sends the request to the server and returns immediately, not waiting the reply. This avoids the round-trip latency at a cost of uncertain command outcome. Internally there is a counter of how many outstanding replies there should be, and on any command the client reads and discards any replies that have already arrived. When you later execute some method in a non-void context, all outstanding replies will be waited for, and then the reply for this command will be read and returned. =item I connect_timeout => 0.7 (default: 0.25 seconds) The value is a non-negative rational number of seconds to wait for connection to establish. Applies only to network connections. Zero disables timeout, but keep in mind that operating systems have their own heuristic connect timeout. Note that network connect process consists of several steps: destination host address lookup, which may return several addresses in general case (especially for IPv6, see L and L), then the attempt to connect to one of those addresses. I applies only to one such connect, i.e. to one I call. Thus overall connect process may take longer than I seconds, but this is unavoidable. =item I (or deprecated I) io_timeout => 0.5 (default: 1.0 seconds) The value is a non-negative rational number of seconds to wait before giving up on communicating with the server(s). Zero disables timeout. Note that for commands that communicate with more than one server (like L) the timeout applies per server set, not per each server. Thus it won't expire if one server is quick enough to communicate, even if others are silent. But if some servers are dead those alive will finish communication, and then dead servers would timeout. =item I close_on_error => 0 (default: enabled) The value is a boolean which enables (true) or disables (false) I mode. When enabled, any error response from the B server would make client close the connection. Note that such "error response" is different from "negative response". The latter means the server processed the command and yield negative result. The former means the server failed to process the command for some reason. I is enabled by default for safety. Consider the following scenario: =over =item 1 Client want to set some value, but mistakenly sends malformed command (this can't happen with current module of course ;)): set key 10\r\n value_data\r\n =item 2 Memcached server reads first line, 'set key 10', and can't parse it, because there's wrong number of tokens in it. So it sends ERROR\r\n =item 3 Then the server reads 'value_data' while it is in accept-command state! It can't parse it either (hopefully), and sends another ERROR\r\n =back But the client expects one reply per command, so after sending the next command it will think that the second 'ERROR' is a reply for this new command. This means that all replies will shift, including replies for L commands! By closing the connection we eliminate such possibility. When connection dies, or the client receives the reply that it can't understand, it closes the socket regardless the I setting. =item I compress_threshold => 10_000 (default: -1) The value is an integer. When positive it denotes the threshold size in bytes: data with the size equal or larger than this should be compressed. See L and L below. Negative value disables compression. =item I compress_ratio => 0.9 (default: 0.8) The value is a fractional number between 0 and 1. When L triggers the compression, compressed size should be less or equal to S<(original-size * I)>. Otherwise the data will be stored uncompressed. =item I compress_methods => [ \&IO::Compress::Gzip::gzip, \&IO::Uncompress::Gunzip::gunzip ] (default: [ sub { ${$_[1]} = Compress::Zlib::memGzip(${$_[0]}) }, sub { ${$_[1]} = Compress::Zlib::memGunzip(${$_[0]}) } ] when Compress::Zlib is available) The value is a reference to an array holding two code references for compression and decompression routines respectively. Compression routine is called when the size of the I<$value> passed to L method family is greater than or equal to L (also see L). The fact that compression was performed is remembered along with the data, and decompression routine is called on data retrieval with L method family. The interface of these routines should be the same as for B family (for instance see L and L). I.e. compression routine takes a reference to scalar value and a reference to scalar where compressed result will be stored. Decompression routine takes a reference to scalar with compressed data and a reference to scalar where uncompressed result will be stored. Both routines should return true on success, and false on error. By default we use L because as of this writing it appears to be much faster than L. =item I max_failures => 3 (default: 0) The value is a non-negative integer. When positive, if there happened I in I seconds, the client does not try to connect to this particular server for another I seconds. Value of zero disables this behaviour. =item I failure_timeout => 30 (default: 10 seconds) The value is a positive integer number of seconds. See L. =item I ketama_points => 150 (default: 0) The value is a non-negative integer. When positive, enables the B consistent hashing algorithm (L), and specifies the number of points the server with weight 1 will be mapped to. Thus each server will be mapped to S * I> points in continuum. Larger value will result in more uniform distribution. Note that the number of internal bucket structures, and hence memory consumption, will be proportional to sum of such products. But bucket structures themselves are small (two integers each), so you probably shouldn't worry. Zero value disables the Ketama algorithm. See also server weight in L above. =item I serialize_methods => [ \&Storable::freeze, \&Storable::thaw ], (default: [ \&Storable::nfreeze, \&Storable::thaw ]) The value is a reference to an array holding two code references for serialization and deserialization routines respectively. Serialization routine is called when the I<$value> passed to L method family is a reference. The fact that serialization was performed is remembered along with the data, and deserialization routine is called on data retrieval with L method family. The interface of these routines should be the same as for L and L. I.e. serialization routine takes a reference and returns a scalar string; it should not fail. Deserialization routine takes scalar string and returns a reference; if deserialization fails (say, wrong data format) it should throw an exception (call I). The exception will be caught by the module and L will then pretend that the key hasn't been found. =item I (B) utf8 => 1 (default: disabled) The value is a boolean which enables (true) or disables (false) the conversion of Perl character strings to octet sequences in UTF-8 encoding on store, and the reverse conversion on fetch (when the retrieved data is marked as being UTF-8 octet sequence). See L. =item I max_size => 512 * 1024 (default: 1024 * 1024) The value is a maximum size of an item to be stored in memcached. When trying to set a key to a value longer than I bytes (after serialization and compression) nothing is sent to the server, and I methods return I. Note that the real maximum on the server is less than 1MB, and depends on key length among other things. So some values in the range S>, where N is several hundreds, will still be sent to the server, and rejected there. You may set I to a smaller value to avoid this. =item I check_args => 'skip' (default: not 'skip') The value is a string. Currently the only recognized string is I<'skip'>. By default all constructor parameter names are checked to be recognized, and a warning is given for unknown parameter. This will catch spelling errors that otherwise might go unnoticed. When set to I<'skip'>, the check will be bypassed. This may be desired when you share the same argument hash among different client versions, or among different clients. =back =back =cut our %known_params = ( servers => [ { address => 1, weight => 1, noreply => 1 } ], namespace => 1, nowait => 1, hash_namespace => 1, connect_timeout => 1, io_timeout => 1, select_timeout => 1, close_on_error => 1, compress_threshold => 1, compress_ratio => 1, compress_methods => 1, compress_algo => sub { carp "compress_algo has been removed in 0.08," . " use compress_methods instead" }, max_failures => 1, failure_timeout => 1, ketama_points => 1, serialize_methods => 1, utf8 => 1, max_size => 1, check_args => 1, ); sub _check_args { my ($checker, $args, $level) = @_; $level = 0 unless defined $level; my @unknown; if (ref($args) ne 'HASH') { if (ref($args) eq 'ARRAY' and ref($checker) eq 'ARRAY') { foreach my $v (@$args) { push @unknown, _check_args($checker->[0], $v, $level + 1); } } return @unknown; } if (exists $args->{check_args} and lc($args->{check_args}) eq 'skip') { return; } while (my ($k, $v) = each %$args) { if (exists $checker->{$k}) { if (ref($checker->{$k}) eq 'CODE') { $checker->{$k}->($args, $k, $v); } elsif (ref($checker->{$k})) { push @unknown, _check_args($checker->{$k}, $v, $level + 1); } } else { push @unknown, $k; } } if ($level > 0) { return @unknown; } else { carp "Unknown parameter: @unknown" if @unknown; } } our %instance; sub new { my Cache::Memcached::Fast $class = shift; my ($conf) = @_; _check_args(\%known_params, $conf); if (not $conf->{compress_methods} and defined $conf->{compress_threshold} and $conf->{compress_threshold} >= 0 and eval "require Compress::Zlib") { # Note that the functions below can't return false when # operation succeed. This is because "" and "0" compress to a # longer values (because of additional format data), and # compress_ratio will force them to be stored uncompressed, # thus decompression will never return them. $conf->{compress_methods} = [ sub { ${$_[1]} = Compress::Zlib::memGzip(${$_[0]}) }, sub { ${$_[1]} = Compress::Zlib::memGunzip(${$_[0]}) } ]; } if ($conf->{utf8} and $^V lt v5.8.1) { carp "'utf8' may be enabled only for Perl >= 5.8.1, disabled"; undef $conf->{utf8}; } $conf->{serialize_methods} ||= [ \&Storable::nfreeze, \&Storable::thaw ]; my $memd = Cache::Memcached::Fast::_new($class, $conf); if (eval "require Scalar::Util") { my $context = [$memd, $conf]; Scalar::Util::weaken($context->[0]); $instance{$$memd} = $context; } return $memd; } sub CLONE { my ($class) = @_; my @contexts = values %instance; %instance = (); foreach my $context (@contexts) { my $memd = Cache::Memcached::Fast::_new($class, $context->[1]); ${$context->[0]} = $$memd; $instance{$$memd} = $context; $$memd = 0; } } sub DESTROY { my ($memd) = @_; return unless $$memd; delete $instance{$$memd}; Cache::Memcached::Fast::_destroy($memd); } =head1 METHODS =over =item C $memd->enable_compress($enable); Enable compression when boolean I<$enable> is true, disable when false. Note that you can enable compression only when you set L to some positive value and L is set. I none. =cut # See Fast.xs. =item C $memd->namespace; $memd->namespace($string); Without the argument return the current namespace prefix. With the argument set the namespace prefix to I<$string>, and return the old prefix. I scalar, the namespace prefix that was in effect before the call. =cut # See Fast.xs. =item C $memd->set($key, $value); $memd->set($key, $value, $expiration_time); Store the I<$value> on the server under the I<$key>. I<$key> should be a scalar. I<$value> should be defined and may be of any Perl data type. When it is a reference, the referenced Perl data structure will be transparently serialized by routines specified with L, which see. Optional I<$expiration_time> is a positive integer number of seconds after which the value will expire and wouldn't be accessible any longer. I boolean, true for positive server reply, false for negative server reply, or I in case of some error. =cut # See Fast.xs. =item C $memd->set_multi( [$key, $value], [$key, $value, $expiration_time], ... ); Like L, but operates on more than one key. Takes the list of references to arrays each holding I<$key>, I<$value> and optional I<$expiration_time>. Note that multi commands are not all-or-nothing, some operations may succeed, while others may fail. I in list context returns the list of results, each I<$list[$index]> is the result value corresponding to the argument at position I<$index>. In scalar context, hash reference is returned, where I<$href-E{$key}> holds the result value. See L to learn what the result value is. =cut # See Fast.xs. =item C $memd->cas($key, $cas, $value); $memd->cas($key, $cas, $value, $expiration_time); Store the I<$value> on the server under the I<$key>, but only if CAS (I) value associated with this key is equal to I<$cas>. I<$cas> is an opaque object returned with L or L. See L for I<$key>, I<$value>, I<$expiration_time> parameters description. I boolean, true for positive server reply, false for negative server reply, or I in case of some error. Thus if the key exists on the server, false would mean that some other client has updated the value, and L, L command sequence should be repeated. B command first appeared in B 1.2.4. =cut # See Fast.xs. =item C $memd->cas_multi( [$key, $cas, $value], [$key, $cas, $value, $expiration_time], ... ); Like L, but operates on more than one key. Takes the list of references to arrays each holding I<$key>, I<$cas>, I<$value> and optional I<$expiration_time>. Note that multi commands are not all-or-nothing, some operations may succeed, while others may fail. I in list context returns the list of results, each I<$list[$index]> is the result value corresponding to the argument at position I<$index>. In scalar context, hash reference is returned, where I<$href-E{$key}> holds the result value. See L to learn what the result value is. B command first appeared in B 1.2.4. =cut # See Fast.xs. =item C $memd->add($key, $value); $memd->add($key, $value, $expiration_time); Store the I<$value> on the server under the I<$key>, but only if the key B exists on the server. See L for I<$key>, I<$value>, I<$expiration_time> parameters description. I boolean, true for positive server reply, false for negative server reply, or I in case of some error. =cut # See Fast.xs. =item C $memd->add_multi( [$key, $value], [$key, $value, $expiration_time], ... ); Like L, but operates on more than one key. Takes the list of references to arrays each holding I<$key>, I<$value> and optional I<$expiration_time>. Note that multi commands are not all-or-nothing, some operations may succeed, while others may fail. I in list context returns the list of results, each I<$list[$index]> is the result value corresponding to the argument at position I<$index>. In scalar context, hash reference is returned, where I<$href-E{$key}> holds the result value. See L to learn what the result value is. =cut # See Fast.xs. =item C $memd->replace($key, $value); $memd->replace($key, $value, $expiration_time); Store the I<$value> on the server under the I<$key>, but only if the key B exists on the server. See L for I<$key>, I<$value>, I<$expiration_time> parameters description. I boolean, true for positive server reply, false for negative server reply, or I in case of some error. =cut # See Fast.xs. =item C $memd->replace_multi( [$key, $value], [$key, $value, $expiration_time], ... ); Like L, but operates on more than one key. Takes the list of references to arrays each holding I<$key>, I<$value> and optional I<$expiration_time>. Note that multi commands are not all-or-nothing, some operations may succeed, while others may fail. I in list context returns the list of results, each I<$list[$index]> is the result value corresponding to the argument at position I<$index>. In scalar context, hash reference is returned, where I<$href-E{$key}> holds the result value. See L to learn what the result value is. =cut # See Fast.xs. =item C $memd->append($key, $value); B the I<$value> to the current value on the server under the I<$key>. I<$key> and I<$value> should be scalars, as well as current value on the server. C doesn't affect expiration time of the value. I boolean, true for positive server reply, false for negative server reply, or I in case of some error. B command first appeared in B 1.2.4. =cut # See Fast.xs. =item C $memd->append_multi( [$key, $value], ... ); Like L, but operates on more than one key. Takes the list of references to arrays each holding I<$key>, I<$value>. Note that multi commands are not all-or-nothing, some operations may succeed, while others may fail. I in list context returns the list of results, each I<$list[$index]> is the result value corresponding to the argument at position I<$index>. In scalar context, hash reference is returned, where I<$href-E{$key}> holds the result value. See L to learn what the result value is. B command first appeared in B 1.2.4. =cut # See Fast.xs. =item C $memd->prepend($key, $value); B the I<$value> to the current value on the server under the I<$key>. I<$key> and I<$value> should be scalars, as well as current value on the server. C doesn't affect expiration time of the value. I boolean, true for positive server reply, false for negative server reply, or I in case of some error. B command first appeared in B 1.2.4. =cut # See Fast.xs. =item C $memd->prepend_multi( [$key, $value], ... ); Like L, but operates on more than one key. Takes the list of references to arrays each holding I<$key>, I<$value>. Note that multi commands are not all-or-nothing, some operations may succeed, while others may fail. I in list context returns the list of results, each I<$list[$index]> is the result value corresponding to the argument at position I<$index>. In scalar context, hash reference is returned, where I<$href-E{$key}> holds the result value. See L to learn what the result value is. B command first appeared in B 1.2.4. =cut # See Fast.xs. =item C $memd->get($key); Retrieve the value for a I<$key>. I<$key> should be a scalar. I value associated with the I<$key>, or nothing. =cut # See Fast.xs. =item C $memd->get_multi(@keys); Retrieve several values associated with I<@keys>. I<@keys> should be an array of scalars. I reference to hash, where I<$href-E{$key}> holds corresponding value. =cut # See Fast.xs. =item C $memd->gets($key); Retrieve the value and its CAS for a I<$key>. I<$key> should be a scalar. I reference to an array I<[$cas, $value]>, or nothing. You may conveniently pass it back to L with I<@$res>: my $cas_val = $memd->gets($key); # Update value. if (defined $cas_val) { $$cas_val[1] = 3; $memd->cas($key, @$cas_val); } B command first appeared in B 1.2.4. =cut # See Fast.xs. =item C $memd->gets_multi(@keys); Retrieve several values and their CASs associated with I<@keys>. I<@keys> should be an array of scalars. I reference to hash, where I<$href-E{$key}> holds a reference to an array I<[$cas, $value]>. Compare with L. B command first appeared in B 1.2.4. =cut # See Fast.xs. =item C $memd->incr($key); $memd->incr($key, $increment); Increment the value for the I<$key>. Starting with B 1.3.3 I<$key> should be set to a number or the command will fail. An optional I<$increment> should be a positive integer, when not given 1 is assumed. Note that the server doesn't check for overflow. I unsigned integer, new value for the I<$key>, or false for negative server reply, or I in case of some error. =cut # See Fast.xs. =item C $memd->incr_multi( @keys, [$key], [$key, $increment], ... ); Like L, but operates on more than one key. Takes the list of keys and references to arrays each holding I<$key> and optional I<$increment>. Note that multi commands are not all-or-nothing, some operations may succeed, while others may fail. I in list context returns the list of results, each I<$list[$index]> is the result value corresponding to the argument at position I<$index>. In scalar context, hash reference is returned, where I<$href-E{$key}> holds the result value. See L to learn what the result value is. =cut # See Fast.xs. =item C $memd->decr($key); $memd->decr($key, $decrement); Decrement the value for the I<$key>. Starting with B 1.3.3 I<$key> should be set to a number or the command will fail. An optional I<$decrement> should be a positive integer, when not given 1 is assumed. Note that the server I check for underflow, attempt to decrement the value below zero would set the value to zero. Similar to L, zero is returned as I<"0E0">, and evaluates to true in a boolean context. I unsigned integer, new value for the I<$key>, or false for negative server reply, or I in case of some error. =cut # See Fast.xs. =item C $memd->decr_multi( @keys, [$key], [$key, $decrement], ... ); Like L, but operates on more than one key. Takes the list of keys and references to arrays each holding I<$key> and optional I<$decrement>. Note that multi commands are not all-or-nothing, some operations may succeed, while others may fail. I in list context returns the list of results, each I<$list[$index]> is the result value corresponding to the argument at position I<$index>. In scalar context, hash reference is returned, where I<$href-E{$key}> holds the result value. See L to learn what the result value is. =cut # See Fast.xs. =item C $memd->delete($key); Delete I<$key> and its value from the cache. I boolean, true for positive server reply, false for negative server reply, or I in case of some error. =cut # See Fast.xs. =item C (B) Alias for L, for compatibility with B. =cut *remove = \&delete; =item C $memd->delete_multi(@keys); Like L, but operates on more than one key. Takes the list of keys. Note that multi commands are not all-or-nothing, some operations may succeed, while others may fail. I in list context returns the list of results, each I<$list[$index]> is the result value corresponding to the argument at position I<$index>. In scalar context, hash reference is returned, where I<$href-E{$key}> holds the result value. See L to learn what the result value is. =cut # See Fast.xs. =item C $memd->flush_all; $memd->flush_all($delay); Flush all caches the client knows about. This command invalidates all items in the caches, none of them will be returned on subsequent retrieval command. I<$delay> is an optional non-negative integer number of seconds to delay the operation. The delay will be distributed across the servers. For instance, when you have three servers, and call C, the servers would get 30, 15, 0 seconds delays respectively. When omitted, zero is assumed, i.e. flush immediately. I reference to hash, where I<$href-E{$server}> holds corresponding result value. I<$server> is either I or F, as described in L. Result value is a boolean, true for positive server reply, false for negative server reply, or I in case of some error. =cut # See Fast.xs. =item C $memd->nowait_push; Push all pending requests to the server(s), and wait for all replies. When L mode is enabled, the requests issued in a void context may not reach the server(s) immediately (because the reply is not waited for). Instead they may stay in the send queue on the local host, or in the receive queue on the remote host(s), for quite a long time. This method ensures that they are delivered to the server(s), processed there, and the replies have arrived (or some error has happened that caused some connection(s) to be closed). Destructor will call this method to ensure that all requests are processed before the connection is closed. I nothing. =cut # See Fast.xs. =item C $memd->server_versions; Get server versions. I reference to hash, where I<$href-E{$server}> holds corresponding server version. I<$server> is either I or F, as described in L. =cut # See Fast.xs. =item C $memd->disconnect_all; Closes all open sockets to memcached servers. Must be called after L if the parent process has open sockets to memcacheds (as the child process inherits the socket and thus two processes end up using the same socket which leads to protocol errors.) I nothing. =cut # See Fast.xs. 1; __END__ =back =head1 Compatibility with Cache::Memcached This module is designed to be a drop in replacement for L. Where constructor parameters are the same as in Cache::Memcached, the default values are also the same, and new parameters are disabled by default (the exception is L, which is absent in Cache::Memcached and enabled by default in this module, and L, which see). Internally Cache::Memcached::Fast uses the same hash function as Cache::Memcached, and thus should distribute the keys across several servers the same way. So both modules may be used interchangeably. Most users of the original module should be able to use this module after replacing I<"Cache::Memcached"> with I<"Cache::Memcached::Fast">, without further code modifications. However, as of this release, the following features of Cache::Memcached are not supported by Cache::Memcached::Fast (and some of them will never be): =head2 Constructor parameters =over =item I Current implementation never rehashes keys, instead L and L are used. If the client would rehash the keys, a consistency problem would arise: when the failure occurs the client can't tell whether the server is down, or there's a (transient) network failure. While some clients might fail to reach a particular server, others may still reach it, so some clients will start rehashing, while others will not, and they will no longer agree which key goes where. =item I Not supported. Easy to add. However I'm not sure about the demand for it, and it will slow down things a bit (because from design point of view it's better to add it on Perl side rather than on XS side). =item I Not supported. Since the implementation is different, there can't be any compatibility on I level. =back =head2 Methods =over =item Passing keys Every key should be a scalar. The syntax when key is a reference to an array I<[$precomputed_hash, $key]> is not supported. =item C Not supported. Server set should not change after client object construction. =item C Not supported. See L. =item C Not supported. See L. =item C Not supported. See L. =item C Not supported. Easy to add. Currently you specify I during client object construction. =item C Not supported. Perhaps will appear in the future releases. =back =head1 Tainted data In current implementation tainted flag is neither tested nor preserved, storing tainted data and retrieving it back would clear tainted flag. See L. =head1 Threads This module is thread-safe when used with Perl >= 5.7.2. As with other Perl data each thread gets its own copy of Cache::Memcached::Fast object that is in scope when the thread is created. Such copies share no state, and may be used concurrently. For example: use threads; my $memd = new Cache::Memcached::Fast({...}); sub thread_job { $memd->set("key", "thread value"); } threads->new(\&thread_job); $memd->set("key", "main value"); Here both Cs will be executed concurrently, and the value of I will be either I
or I, depending on the timing of operations. Note that C<$memd> inside C internally refers to a different Cache::Memcached::Fast object than C<$memd> from the outer scope. Each object has its own connections to servers, its own counter of outstanding replies for L mode, etc. New object copy is created with the same constructor arguments, but initially is not connected to any server (even when master copy has open connections). No file descriptor is allocated until the command is executed through this new object. You may safely create Cache::Memcached::Fast object from threads other than main thread, and/or pass them as parameters to threads::new(). However you can't return the object from top-level thread function. I.e., the following won't work: use threads; sub thread_job { return new Cache::Memcached::Fast({...}); } my $thread = threads->new(\&thread_job); my $memd = $thread->join; # The object will be destroyed here. This is a Perl limitation (see L). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Cache::Memcached::Fast You can also look for information at: =over 4 =item * Project home L =item * RT: CPAN's request tracker L =item * AnnoCPAN: Annotated CPAN documentation L =item * CPAN Ratings L =item * Search CPAN L =back =head1 SEE ALSO L - project home. Latest development tree can be found there. L - original pure Perl B client. L - B website. =head1 AUTHORS S, C<< >> - design and implementation. S, C<< >> - project management, design suggestions, testing. =head1 ACKNOWLEDGEMENTS Development of this module was sponsored by S Thanks to S for enlightening on UTF-8 support. Thanks to S for initial Win32 patch. =head1 WARRANTY There's B, neither explicit nor implied. But you knew it already ;). =head1 COPYRIGHT AND LICENSE Copyright (C) 2007-2010 Tomash Brechko. All rights reserved. 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.8 or, at your option, any later version of Perl 5 you may have available. =cut Cache-Memcached-Fast-0.21/Changes0000644000175000017500000005014712127763070016055 0ustar tomashtomashRevision history for Perl extension Cache::Memcached::Fast. 0.21 2013-04-06 - regenerate distribution archive to include META.json and META.yml. There's no need to upgrade as these files are used only by CPAN itself. Changes since 0.20: There are no changes since 0.20. CPAN::Meta hasn't been installed on the build host and this resulted in creation of 0.20 distribution missing META.json/META.yml without any warning. Turns out the absence of these files prevents the released module from being tested on CPAN tester network. 0.20 2013-04-03 - finally fix magic.t failure. Magic handling introduced in 0.18 wasn't correct until this release. Upgrade if you use Perl 'tie' feature or its derivatives like Readonly. Changes since 0.19: Fix RT#57150, RT#67106: magic.t failure. Thanks to for instructions on how to reproduce the problem. Fix RT#77254: typo in POD documentation. Tnanks to Alex . Fix RT#81782: Unnecessary string eval in constructor. Thanks to Andrew Holland for the patch. 0.19 2010-04-24 - revert SIGPIPE suppression change. Upgrade if you couldn't build 0.18. Changes since 0.18: Turned out some orthodox systems do not have sigtimedwait(). Since advanced systems that have sigtimedwait() also have MSG_NOSIGNAL and thus do not use SIGPIPE suppression code in question, and other systems have neither MSG_NOSIGNAL nor sigtimedwait(), the only option is to revert to the previous suppression code. It works correctly unless your program is multi-threaded. 0.18 2010-04-06 - make module thread-safe, and fix several bugs. No need to upgrade unless you experienced limitations mentioned below. Changes since 0.17: Fix RT#56142: handle Perl magic. Tied scalars, arrays and hashes are supported now, as well as Readonly variables and other magic stuff. Fix t/command.t failure on some Solaris distributions. Make module thread-safe with Perl >= 5.7.2. 0.17 2009-11-02 - remove delete expiration aka delay parameter. Upgrade is required for use with memcached >= 1.3.2. Changes since 0.16: Warn about ignoring non-zero delete expiration time. Expiration time for "delete" command has been optional in older versions of memcached, and was dropped in memcached 1.3.2 (in an incompatible manner). Not knowing server version it's impossible to tell whether the server will handle the parameter or not, so we simply do not send it at all. Explicit zero passed to delete() or delete_multi() is silently ignored, and a warning is given if you pass non-zero delete expiration time. Furthermore the syntax delete($key, $delay) and delete_multi([$key, $delay]) is obsoleted and no more documented. 0.16 2009-06-15 - add missing files. This is a fix for the previous release. Changes since 0.15: Add src/addrinfo_hostent.c and src/addrinfo_hostent.h to MANIFEST. Oops :(. 0.15 2009-06-15 - no need to upgrade for existing users. This release fixes issues that new users may encounter (lack of getaddrinfo() on some Windows systems; failing test case due to behaviour change in memcached 1.3.3 that would break automatic installation from CPAN). Changes since 0.14: Previous release (0.14) featured the change in the Ketama algorithm. While that was a necessary move to improve key distribution across servers, it introduced incompatibility with earlier versions, and provided no means for smooth transition for existing users of Ketama algorithm (i.e., without complete loss of cached data). The following workaround was suggested by Masahiro Nagano---thanks!: - apply the patch at http://limilic.com/entry/ljlt0sksbiqi16p3 - create two instances of C::M::F, one with enabled old_ketama_algo => 1. - for some time populate caches via both client instances, while serving gets through old_ketama_algo. For this you may use Cache::Migrate (http://gist.github.com/110981). - after some time (depends on cache refresh rate) you may drop old_ketama_algo, as new data is now distributed according to the new Ketama implementation as well (this doubles memory use though). I do not include the named patch in the distribution, because it's use is limited for one-time transition for existing Ketama users only. On systems lacking getaddrinfo() implement it with gethostbyname(). In particular this should fix the build on Win32 (Cygwin, Mingw32). Problem report (for Windows 2000 and below) and initial patch are by Yasuhiro Matsumoto. Fix t/commands.t: starting with memcached 1.3.3 incr/decr commands expect numeric value in the cache. Patch by Jason M. Mills (RT#46883). 0.14 2009-02-07 - improve Ketama distribution. The change is incompatible with Ketama implementation in previous versions. Changes since 0.13: Change calculation of Ketama points for a given server to get mapping ratios closer to server weight ratios. New Ketama mode is compatible with nginx's module memcached_hash (http://openhack.ru/nginx-patched/wiki/MemcachedHash) version 0.4, which has the same change, and is incompatible with earlier versions of both named and this module. Add script/ketama-distr.pl to compute server's share of continuum. Real-world example: script/ketama-distr.pl --ketama_points=150 \ --server=10.0.143.4:11211 \ --server=10.0.143.6:11211 \ --server=10.0.143.7:11211 \ --server=10.0.143.8:11211 outputs: Old: server 1: 10.0.143.4:11211 total = 671585356 (15.64%) server 2: 10.0.143.6:11211 total = 601117590 (14.00%) server 3: 10.0.143.7:11211 total = 1771239512 (41.24%) server 4: 10.0.143.8:11211 total = 1251024837 (29.13%) New: server 1: 10.0.143.4:11211 total = 1057134262 (24.61%) server 2: 10.0.143.6:11211 total = 1111432463 (25.88%) server 3: 10.0.143.7:11211 total = 1017280856 (23.69%) server 4: 10.0.143.8:11211 total = 1109119714 (25.82%) Continuum array size = 4800 bytes I.e. "Old" is what we were getting before the change, and "New" is what we are getting now. "Continuum array size" is how much memory is used to store the continuum array. Try this script on your servers to see your distribution, and possibly to tweak ketama_points and/or server weights to get a better one. Fix RT#41077 (http://rt.cpan.org/Ticket/Display.html?id=41077): implement disconnect_all(). Patch is by norbi.nix.hu, with minor corrections---thanks!. 0.13 2008-10-13 - introduce Win32 support (based on the patch by Yasuhiro Matsumoto---arigatou!), and use poll() instead of select() (suggested by Vladimir Timofeev). Changes since 0.12: Add support for Win32. I personally don't have the system nor compiler, so I can't even test the build. Win32 port is expected to be supported by community. Note: on Win32 below Windows Vista max number of memcached servers is 64. See comment on FD_SETSIZE in src/socket_win32.h to learn how to increase this value if you need to connect to more than 64 servers. Use poll() system call instead of select(). The latter has the limit on the file descriptor value. I.e. even when the number of memcached servers is low, but your application opens lots of other files, then after some point socket() returns fd value larger that select() can handle. poll() doesn't have this limitation. On a side note, we don't have to use advanced calls like epoll()/kqueue(), because number of memcached servers is normally not very large (and single request touches even a smaller subset). Add bench make target ('make bench'). You may change initial parameters at the top of script/benchmark.pl to benchmark different types of loads. Do not install libclient.a. Thanks to Vladimir Timofeev for finding out how to prevent the installation. 0.12 2008-07-21 - this release fixes compilation on Solaris broken in 0.11. If you were able to compile 0.11, then you weren't affected. Changes since 0.11: Fix compilation on Solaris. Ironically, 0.11 was supposed to fix unrecognized format problem on Solaris, but instead broke the compilation. Back in May the line return XSRETURN_EMPTY; has been introduced to the code, whereas it should be XSRETURN_EMPTY; It went unnoticed because expansion produces the code permitted by compilers like GCC that allow blocks to return a value. But Perl on Solaris has a different definition of this macro that is not an expression. Hence the problem. 0.11 2008-07-17 - this release fixes %zu problem on Solaris. Changes since 0.10: Replace size_t/%zu with unsigned long/%lu for benefit of systems that do not recognize the former format (Solaris 9). Thanks to Michael Vychizhanin! Add new parameter max_size (suggested by Alex Kapranoff, see RT#35588, http://rt.cpan.org/Ticket/Display.html?id=35588). Fix RT#36074 (http://rt.cpan.org/Ticket/Display.html?id=36074): ExtUtils::MakeMaker version 6.17 and below generated invalid Makefile. 0.10 2008-05-01 - this is a bugfix release fixing key distribution in compatible mode (reported by Anton Yuzhaninov---thanks!), and minor fixes in Ketama mode for collision case (very rare). Changes since 0.09: Fix key distribution bug in compatible mode. Because of accumulated rounding error some keys were mapped to the different server than with Cache::Memcached. Remove explicit OPTIMIZE setting from the makefiles. It ought to be set explicitly by the user. You can run 'perl -V:optimize' to learn the default. It is safe to increase optimization level to -O3. Fix hash_namespace parameter: it didn't work for the namespace specified in the constructor. Minor fixes in Ketama mode for rare collision case. 0.09 2008-03-06 - this release makes 'noreply' mode official, and improves latency for some command patterns by managing TCP_NODELAY flag. Changes since 0.08: Enable TCP_NODELAY to reduce latency of commands that wait for the reply, and disable it for throughput of commands that don't need any reply. t/encoding.t was removed from distribution. It doesn't work with Perl 5.6, which has no 'encoding' pragma, and I don't know how to fix it (beautifully, there's a number of ugly ways). 'noreply' mode is documented as the official feature of memcached 1.2.5. script/benchmark.pl uses it automatically when available. Add parameter 'hash_namespace' (see docs). Add method 'namespace' to get and/or set the namespace prefix. This is handy when you "lease" C::M::F object for different parts of your application that do unrelated things. 0.08 2008-01-24 - this is mostly a cleanup release, that also improves decompression speed. Changes since 0.07: compress_alog was replaced with more generic compress_methods. It turned out that IO::Uncompress::Gunzip is much (~4x) slower than Compress::Zlib, so the latter is used as the default for compress_methods. Besides, previous mechanism didn't scale well. Implemented the check of constructor arguments to catch various typos (enabled by default), and new 'check_args' parameter to disable it. Workaround "cast from integer to pointer of different size" warning on 64-bit platforms. Removed 127.0.0.x from test cases since not all hosts resolve such addresses when x is not 1. Use plain malloc()/free() instead of Newx()/Safefree() in XS. This should fix the build with Perl versions 5.6.0--5.8.6. 0.07 2008-01-18 - this is a major release that features a significant speed improvement and introduces multi update commands. It also fixes a bug in nowait mode that was introduced in 0.06. Upgrade is recommended if you are using nowait => 1, or want to employ new features and speed. Changes since 0.06: For performance reasons all Perl code was converted to XS. If you performed any benchmarks, you may want to repeat them ;). This change has a drawback that now you can't derive from C::M::F easily. Every update command now has its multi equivalent: set_multi, add_multi, replace_multi, append_multi, prepend_multi, incr_multi, decr_multi and delete_multi. By using multi commands you will reduce request latency: several requests would be sent in one packet, and the client would talk to all servers simultaneously. Improved results of update commands: commands that previously returned boolean value now return true for positive server reply, false for negative server reply, and undef on error. Similar to DBI, decr returns "0E0" for positive zero reply, which evaluates to true in a boolean context. flush_all now returns a hash 'server_name' => 'bool_result'. New commands 'server_versions' and 'nowait_push'. New 'utf8' and 'serialize_methods' parameters for constructor. script/compare.pl was removed. Instead script/benchmark.pl takes an optional last argument "compare". t/03-flush_all.t was removed. We use PID as a part of a namespace prefix now, so we don't need clear cache any more. And there are good reasons not to have flush_all: the user may flush a valuable cache by mistake, and "flush_all 0" doesn't work on memcached 1.2.2, so the outcome was uncertain anyway. Without flush_all it's possible to execute in parallel more than one 'make test'. Fixed bug in 'nowait' mode that could cause false negative replies to subsequent requests that you are waiting for. Workaround the loss of the last 'noreply' request on the server. 'noreply' is still an undocumented feature. To support multi commands the API of internal client implementation was changed. If you were using it as a standalone library---sorry :). After API will freeze C client library will likely be released on its own. 0.06 2007-12-20 - this release fixes a serious bug and features the 'nowait' mode. Upgrade is recommended. Changes since 0.05: Fix a subtle race bug present since 0.02 that could mix several values into one when you have more than one memcached server and executed get_multi or gets_multi. If you have seen the following in your logs or on the console: Attempt to free unreferenced scalar: SV 0x9e89d34 at /tmp/Cache-Memcached-Fast/blib/lib/Cache/Memcached/Fast.pm line 688. that was it. Added 'nowait' mode that allows the client to not wait the reply, and thus reduces the wallclock time. Run script/benchmark.pl and see how it affects wallclock time, especially over the wire. Made undocumented 'noreply' parameter a per-server setting. 0.05 2007-12-18 - more fixes to build and pass tests on different platforms. There's no functional changes again. Changes since 0.04: At least on Perl 5.6.2 SVREF typemap entry has the meaning of the class based on blessed SV. So instead of SVREF we use custom Ref_SV and custom typemap entry. Found by CPAN testers. Do not use AUTOLOAD for normal commands, only for undocumented ones. Add incr() and decr() to script/compare.pl and script/benchmark.pl. Test case is split into several files and cleaned a bit. Rename 'sun' -> 's_unix' in connect.c, because 'sun' is reserved on... guesses? Right, Sun systems! Found by CPAN testers. Fix test case for FreeBSD and derivatives: do not use localhost.localdomain address, which FreeBSD doesn't resolve by default. Added docs section "UTF-8 and tainted data". 0.04 2007-12-16 - CPAN testers found more issues on different platforms, fixing these. Changes since 0.03: const char * is missing from typemap in Perl 5.6.2, fixed by using plain char * for class name in new(). Use AI_ADDRCONFIG conditionally, some systems do not have it (NetBSD 3.1). 0.03 2007-12-16 - this release has no new functionality compared to 0.02. It only fixes some test and documentation problems that were discovered, as it always happens, after the upload to CPAN. Changes since 0.02: Fixed internal documentation references. Added missing docs for incr and decr. Fixed test case to test server version and use cas/gets/append/prepend only for 1.2.4 and up. Actually there's new _undocumented_ command server_versions, is has broken interface, you can't say which version corresponds to which server when some of them do not respond. This command is subject to change. 0.02 2007-12-15 - first public release. Changes since 0.01: Fully restartable code was replaced with classic fill-the-buffer-first approach: it turned out that restartability doesn't add much advantage. Lots of beautiful and ugly code gone away. Added support for multiple servers (select machine, CRC32, timeouts). Added script/compare.pl to compare this module to the original Cache::Memcached, and also to measure speed in general. Added Unix socket support, SIGPIPE handling (proper ignoring actually ;)). Added support for serialization of Perl data structures, and for compression. New commands: incr, decr, gets, gets_multi, cas, enable_compression, remove (alias to delete). New client parameters: connect_timeout, io_timeout (aka select_timeout), compress_threshold, compress_ratio, compress_algo, max_failure, failure_timeout. Finally added documentation! Added support for server weights. Added the Ketama consistent hashing algorithm. Added default tests as generated with Module::Starter. Main test case is still messy, should be split into several tests. There's also support for 'noreply'-enabled memcached, but those patches are not (yet) accepted to mainline, so 'noreply' is not an official feature and is not documented. 0.01 2007-11-26 - first internal release. Supported only one server connection (TCP). Commands are set(), add(), replace(), prepend(), append(), delete(), flush_all(), get(), get_multi(). Client parameters are 'servers', 'namespace', 'close_on_error'. There's no documentation. Test case is messy (but does its job). 0.00 2007-11-19 - original version; created by h2xs 1.23 with options -O --omit-autoload --compat-version=5.6.0 \ --use-new-tests --name=Cache::Memcached::Fast Cache-Memcached-Fast-0.21/src/0000755000175000017500000000000012127763146015346 5ustar tomashtomashCache-Memcached-Fast-0.21/src/addrinfo_hostent.h0000644000175000017500000000322612127763070021050 0ustar tomashtomash/* Copyright (C) 2009 Tomash Brechko. All rights reserved. When used to build Perl module: 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.8 or, at your option, any later version of Perl 5 you may have available. When used as a standalone library: This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. */ #ifndef ADDRINFO_HOSTENT_H #define ADDRINFO_HOSTENT_H 1 #ifndef WIN32 #include #else /* WIN32 */ #include #endif /* WIN32 */ #undef addrinfo #define addrinfo addrinfo_hostent #undef getaddrinfo #define getaddrinfo getaddrinfo_hostent #undef freeaddrinfo #define freeaddrinfo freeaddrinfo_hostent struct addrinfo_hostent { int ai_flags; int ai_family; int ai_socktype; int ai_protocol; size_t ai_addrlen; struct sockaddr *ai_addr; char *ai_canonname; struct addrinfo_hostent *ai_next; }; extern int getaddrinfo_hostent(const char *node, const char *service, const struct addrinfo_hostent *hints, struct addrinfo_hostent **res); extern void freeaddrinfo_hostent(struct addrinfo_hostent *res); #endif /* ! ADDRINFO_HOSTENT_H */ Cache-Memcached-Fast-0.21/src/connect.h0000644000175000017500000000211412127763070017142 0ustar tomashtomash/* Copyright (C) 2007 Tomash Brechko. All rights reserved. When used to build Perl module: 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.8 or, at your option, any later version of Perl 5 you may have available. When used as a standalone library: This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. */ #ifndef CONNECT_H #define CONNECT_H 1 #include extern int client_connect_inet(const char *host, const char *port, int timeout); extern int client_connect_unix(const char *path, size_t path_len); #endif /* ! CONNECT_H */ Cache-Memcached-Fast-0.21/src/dispatch_key.c0000644000175000017500000002041412127763070020156 0ustar tomashtomash/* Copyright (C) 2007-2009 Tomash Brechko. All rights reserved. When used to build Perl module: 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.8 or, at your option, any later version of Perl 5 you may have available. When used as a standalone library: This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. */ #include "dispatch_key.h" #include "compute_crc32.h" #include /* Note on rounding: C89 (which we are trying to be compatible with) doesn't have round-to-nearest function, only ceil() and floor(), so we add 0.5 to doubles before casting them to integers (and the cast always rounds toward zero). */ #define DISPATCH_MAX_POINT 0xffffffffU struct continuum_point { unsigned int point; int index; }; static struct continuum_point * dispatch_find_bucket(struct dispatch_state *state, unsigned int point) { struct continuum_point *beg, *end, *left, *right; beg = left = array_beg(state->buckets, struct continuum_point); end = right = array_end(state->buckets, struct continuum_point); while (left < right) { struct continuum_point *middle = left + (right - left) / 2; if (middle->point < point) { left = middle + 1; } else if (middle->point > point) { right = middle; } else { /* Find the first point for this value. */ while (middle != beg && (middle - 1)->point == point) --middle; return middle; } } /* Wrap around. */ if (left == end) left = beg; return left; } static inline int compatible_add_server(struct dispatch_state *state, double weight, int index) { /* For compatibility with Cache::Memcached we put each server in a continuum so that it occupies the space proportional to its weight. See the comment in compatible_get_server(). */ double scale; struct continuum_point *p; if (array_extend(state->buckets, struct continuum_point, 1, ARRAY_EXTEND_EXACT) == -1) return -1; state->total_weight += weight; scale = weight / state->total_weight; /* Note that during iterative scaling below the rounding error accumulates. However the offset to the smaller values is alright as long as it is smaller than the interval length, which is big enough for sane number of servers (thousands) and relative weight ratios. */ for (array_each(state->buckets, struct continuum_point, p)) p->point -= (double) p->point * scale; /* Here p points to array_end(). */ p->point = DISPATCH_MAX_POINT; p->index = index; array_push(state->buckets); ++state->server_count; return 0; } static inline int compatible_get_server(struct dispatch_state *state, const char *key, size_t key_len) { /* For compatibility with Cache::Memcached we do the following: first we compute 'hash' the same way the original module does. Since that module puts 'weight' copies of each server into buckets array, our '(unsigned int) (state->total_weight + 0.5)' is equal to the number of such buckets (0.5 is there for proper rounding). Then we scale 'point' to the continuum, and since each server occupies the space proportional to its weight, we get the same server index. */ struct continuum_point *p; unsigned int crc32 = compute_crc32_add(state->prefix_hash, key, key_len); unsigned int hash = (crc32 >> 16) & 0x00007fffU; unsigned int point = hash % (unsigned int) (state->total_weight + 0.5); point = (double) point / state->total_weight * DISPATCH_MAX_POINT + 0.5; /* Shift point one step forward to possibly get from the border point which belongs to the previous bucket. */ point += 1; p = dispatch_find_bucket(state, point); return p->index; } static inline int ketama_crc32_add_server(struct dispatch_state *state, const char *host, size_t host_len, const char *port, size_t port_len, double weight, int index) { static const char delim = '\0'; unsigned int crc32, point; int count, i; count = state->ketama_points * weight + 0.5; if (array_extend(state->buckets, struct continuum_point, count, ARRAY_EXTEND_EXACT) == -1) return -1; crc32 = compute_crc32(host, host_len); crc32 = compute_crc32_add(crc32, &delim, 1); crc32 = compute_crc32_add(crc32, port, port_len); point = 0; for (i = 0; i < count; ++i) { char buf[4]; struct continuum_point *p; /* We want the same result on all platforms, so we hardcode size of int as 4 8-bit bytes. */ buf[0] = point & 0xff; buf[1] = (point >> 8) & 0xff; buf[2] = (point >> 16) & 0xff; buf[3] = (point >> 24) & 0xff; point = compute_crc32_add(crc32, buf, 4); if (! array_empty(state->buckets)) { struct continuum_point *end = array_end(state->buckets, struct continuum_point); p = dispatch_find_bucket(state, point); /* Check if we wrapped around but actually have new max point. */ if (p == array_beg(state->buckets, struct continuum_point) && point > p->point) { p = end; } else { /* Even if there's a server for the same point already, we have to add ours, because the first one may be removed later. But we add ours after the old servers for not to change key distribution. */ while (p != end && p->point == point) ++p; /* Move the tail one position forward. */ if (p != end) memmove(p + 1, p, (end - p) * sizeof(*p)); } } else { p = array_beg(state->buckets, struct continuum_point); } p->point = point; p->index = index; array_push(state->buckets); } ++state->server_count; return 0; } static inline int ketama_crc32_get_server(struct dispatch_state *state, const char *key, size_t key_len) { unsigned int point = compute_crc32_add(state->prefix_hash, key, key_len); struct continuum_point *p = dispatch_find_bucket(state, point); return p->index; } void dispatch_init(struct dispatch_state *state) { array_init(&state->buckets); state->total_weight = 0.0; state->ketama_points = 0; state->prefix_hash = 0x0U; state->server_count = 0; } void dispatch_destroy(struct dispatch_state *state) { array_destroy(&state->buckets); } void dispatch_set_ketama_points(struct dispatch_state *state, int ketama_points) { state->ketama_points = ketama_points; } void dispatch_set_prefix(struct dispatch_state *state, const char *prefix, size_t prefix_len) { state->prefix_hash = compute_crc32(prefix, prefix_len); } int dispatch_add_server(struct dispatch_state *state, const char *host, size_t host_len, const char *port, size_t port_len, double weight, int index) { if (state->ketama_points > 0) return ketama_crc32_add_server(state, host, host_len, port, port_len, weight, index); else return compatible_add_server(state, weight, index); } int dispatch_key(struct dispatch_state *state, const char *key, size_t key_len) { if (state->server_count == 0) return -1; if (state->server_count == 1) { struct continuum_point *p = array_beg(state->buckets, struct continuum_point); return p->index; } else { if (state->ketama_points > 0) return ketama_crc32_get_server(state, key, key_len); else return compatible_get_server(state, key, key_len); } } Cache-Memcached-Fast-0.21/src/client.c0000644000175000017500000013312312127763070016767 0ustar tomashtomash/* Copyright (C) 2007-2010 Tomash Brechko. All rights reserved. When used to build Perl module: 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.8 or, at your option, any later version of Perl 5 you may have available. When used as a standalone library: This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. */ #include "client.h" #include "array.h" #include "connect.h" #include "parse_keyword.h" #include "dispatch_key.h" #include #include #include #ifndef WIN32 #include "socket_posix.h" #include #include #include #include #include #else /* WIN32 */ #include "socket_win32.h" #endif /* WIN32 */ /* REPLY_BUF_SIZE should be large enough to contain first reply line. */ #define REPLY_BUF_SIZE 1536 #define FLAGS_STUB "4294967295" #define EXPTIME_STUB "2147483647" #define DELAY_STUB "4294967295" #define VALUE_SIZE_STUB "18446744073709551615" #define CAS_STUB "18446744073709551615" #define ARITH_STUB "18446744073709551615" #define NOREPLY "noreply" static const char eol[2] = "\r\n"; typedef unsigned long long generation_type; struct value_state { void *opaque; void *ptr; value_size_type size; struct meta_object meta; }; struct embedded_state { void *opaque; void *ptr; }; struct command_state; typedef int (*parse_reply_func)(struct command_state *state); enum command_phase { PHASE_RECEIVE, PHASE_PARSE, PHASE_VALUE, PHASE_DONE }; enum socket_mode_e { NOT_TCP = -1, TCP_LATENCY, TCP_THROUGHPUT }; struct client; struct command_state { struct client *client; int fd; struct pollfd *pollfd; enum socket_mode_e socket_mode; int noreply; int last_cmd_noreply; struct array iov_buf; int str_step; generation_type generation; int phase; int nowait_count; int reply_count; char *buf; char *pos; char *end; char *eol; int match; struct iovec *iov; int iov_count; int write_offset; struct iovec *key; int key_count; int index; int index_head; int index_tail; parse_reply_func parse_reply; struct result_object *object; union { struct value_state value; struct embedded_state embedded; } u; }; static inline int command_state_init(struct command_state *state, struct client *c, int noreply) { state->client = c; state->fd = -1; state->noreply = noreply; state->last_cmd_noreply = 0; array_init(&state->iov_buf); state->generation = 0; state->nowait_count = 0; state->buf = (char *) malloc(REPLY_BUF_SIZE); if (! state->buf) return -1; state->pos = state->end = state->eol = state->buf; return 0; } static inline void command_state_destroy(struct command_state *state) { free(state->buf); array_destroy(&state->iov_buf); if (state->fd != -1) close(state->fd); } static inline void command_state_reinit(struct command_state *state) { if (state->fd != -1) close(state->fd); state->fd = -1; state->last_cmd_noreply = 0; array_clear(state->iov_buf); state->generation = 0; state->nowait_count = 0; state->pos = state->end = state->eol = state->buf; } struct server { char *host; size_t host_len; char *port; int failure_count; time_t failure_expires; struct command_state cmd_state; }; static inline int server_init(struct server *s, struct client *c, const char *host, size_t host_len, const char *port, size_t port_len, int noreply) { if (port) s->host = (char *) malloc(host_len + 1 + port_len + 1); else s->host = (char *) malloc(host_len + 1); if (! s->host) return MEMCACHED_FAILURE; memcpy(s->host, host, host_len); s->host[host_len] = '\0'; s->host_len = host_len; if (port) { s->port = s->host + host_len + 1; memcpy(s->port, port, port_len); s->port[port_len] = '\0'; } else { s->port = NULL; } s->failure_count = 0; s->failure_expires = 0; if (command_state_init(&s->cmd_state, c, noreply) != 0) return MEMCACHED_FAILURE; return MEMCACHED_SUCCESS; } static inline void server_destroy(struct server *s) { free(s->host); /* This also frees port string. */ command_state_destroy(&s->cmd_state); } static inline void server_reinit(struct server *s) { s->failure_count = 0; s->failure_expires = 0; command_state_reinit(&s->cmd_state); } struct index_node { int index; int next; }; struct client { struct array pollfds; struct array servers; struct dispatch_state dispatch; char *prefix; size_t prefix_len; int connect_timeout; /* 1/1000 sec. */ int io_timeout; /* 1/1000 sec. */ int max_failures; int failure_timeout; /* 1 sec. */ int close_on_error; int nowait; int hash_namespace; struct array index_list; struct array str_buf; int iov_max; generation_type generation; struct result_object *object; int noreply; }; static inline void command_state_reset(struct command_state *state, int str_step, parse_reply_func parse_reply) { state->reply_count = 0; state->str_step = str_step; state->key_count = 0; state->parse_reply = parse_reply; state->phase = PHASE_RECEIVE; array_clear(state->iov_buf); state->write_offset = 0; state->index_head = state->index_tail = -1; state->generation = state->client->generation; #if 0 /* No need to initialize the following. */ state->key = NULL; state->index = 0; state->match = NO_MATCH; state->iov_count = 0; state->iov = NULL; #endif } static inline int is_active(struct command_state *state) { return (state->generation == state->client->generation); } static inline void deactivate(struct command_state *state) { state->generation = state->client->generation - 1; } static inline int get_index(struct command_state *state) { struct index_node *node = array_elem(state->client->index_list, struct index_node, state->index_head); return node->index; } static inline void next_index(struct command_state *state) { struct index_node *node = array_elem(state->client->index_list, struct index_node, state->index_head); state->index_head = node->next; } struct client * client_init() { struct client *c; #ifdef WIN32 if (win32_socket_library_acquire() != 0) return NULL; #endif /* WIN32 */ c = malloc(sizeof(struct client)); if (! c) return NULL; array_init(&c->pollfds); array_init(&c->servers); array_init(&c->index_list); array_init(&c->str_buf); dispatch_init(&c->dispatch); c->connect_timeout = 250; c->io_timeout = 1000; c->prefix = " "; c->prefix_len = 1; c->max_failures = 0; c->failure_timeout = 10; c->close_on_error = 1; c->nowait = 0; c->hash_namespace = 0; c->iov_max = get_iov_max(); c->generation = 1; /* Different from initial command state. */ c->object = NULL; c->noreply = 0; return c; } static int client_noreply_push(struct client *c); void client_destroy(struct client *c) { struct server *s; client_nowait_push(c); client_noreply_push(c); for (array_each(c->servers, struct server, s)) server_destroy(s); dispatch_destroy(&c->dispatch); array_destroy(&c->servers); array_destroy(&c->pollfds); array_destroy(&c->index_list); array_destroy(&c->str_buf); if (c->prefix_len > 1) free(c->prefix); free(c); #ifdef WIN32 win32_socket_library_release(); #endif /* WIN32 */ } void client_reinit(struct client *c) { struct server *s; for (array_each(c->servers, struct server, s)) server_reinit(s); array_clear(c->str_buf); array_clear(c->index_list); c->generation = 1; /* Different from initial command state. */ c->object = NULL; } int client_set_ketama_points(struct client *c, int ketama_points) { /* Should be called before we added any server. */ if (! array_empty(c->servers) || ketama_points < 0) return MEMCACHED_FAILURE; dispatch_set_ketama_points(&c->dispatch, ketama_points); return MEMCACHED_SUCCESS; } void client_set_connect_timeout(struct client *c, int to) { c->connect_timeout = (to > 0 ? to : -1); } void client_set_io_timeout(struct client *c, int to) { c->io_timeout = (to > 0 ? to : -1); } void client_set_max_failures(struct client *c, int f) { c->max_failures = f; } void client_set_failure_timeout(struct client *c, int to) { c->failure_timeout = to; } void client_set_close_on_error(struct client *c, int enable) { c->close_on_error = enable; } void client_set_nowait(struct client *c, int enable) { c->nowait = enable; } void client_set_hash_namespace(struct client *c, int enable) { c->hash_namespace = enable; } int client_add_server(struct client *c, const char *host, size_t host_len, const char *port, size_t port_len, double weight, int noreply) { int res; if (weight <= 0.0) return MEMCACHED_FAILURE; if (array_extend(c->pollfds, struct pollfd, 1, ARRAY_EXTEND_EXACT) == -1) return MEMCACHED_FAILURE; if (array_extend(c->servers, struct server, 1, ARRAY_EXTEND_EXACT) == -1) return MEMCACHED_FAILURE; res = server_init(array_end(c->servers, struct server), c, host, host_len, port, port_len, noreply); if (res != MEMCACHED_SUCCESS) return res; res = dispatch_add_server(&c->dispatch, host, host_len, port, port_len, weight, array_size(c->servers)); if (res == -1) return MEMCACHED_FAILURE; array_push(c->pollfds); array_push(c->servers); return MEMCACHED_SUCCESS; } int client_set_prefix(struct client *c, const char *ns, size_t ns_len) { char *s; if (ns_len == 0) { if (c->prefix_len > 1) { free(c->prefix); c->prefix = " "; c->prefix_len = 1; } if (c->hash_namespace) dispatch_set_prefix(&c->dispatch, "", 0); return MEMCACHED_SUCCESS; } if (c->prefix_len == 1) c->prefix = NULL; s = (char *) realloc(c->prefix, 1 + ns_len + 1); if (! s) return MEMCACHED_FAILURE; s[0] = ' '; memcpy(s + 1, ns, ns_len); s[ns_len + 1] = '\0'; c->prefix = s; c->prefix_len = 1 + ns_len; if (c->hash_namespace) dispatch_set_prefix(&c->dispatch, ns, ns_len); return MEMCACHED_SUCCESS; } const char * client_get_prefix(struct client *c, size_t *ns_len) { *ns_len = c->prefix_len - 1; return (c->prefix + 1); } static inline ssize_t read_restart(int fd, void *buf, size_t size) { ssize_t res; do res = read(fd, buf, size); while (res == -1 && errno == EINTR); return res; } static inline ssize_t readv_restart(int fd, const struct iovec *iov, int count) { ssize_t res; do res = readv(fd, iov, count); while (res == -1 && errno == EINTR); return res; } #ifndef MSG_NOSIGNAL static inline ssize_t writev_restart(int fd, const struct iovec *iov, int count) { ssize_t res; do res = writev(fd, iov, count); while (res == -1 && errno == EINTR); return res; } #else /* MSG_NOSIGNAL */ static inline ssize_t writev_restart(int fd, const struct iovec *iov, int count) { struct msghdr msg; ssize_t res; memset(&msg, 0, sizeof(msg)); msg.msg_iov = (struct iovec *) iov; msg.msg_iovlen = count; do res = sendmsg(fd, &msg, MSG_NOSIGNAL); while (res == -1 && errno == EINTR); return res; } #endif /* MSG_NOSIGNAL */ /* parse_key() assumes that one key definitely matches. */ static int parse_key(struct command_state *state) { char *key_pos; /* Skip over the prefix. */ state->pos += state->client->prefix_len - 1; key_pos = (char *) state->key->iov_base; while (state->key_count > 1) { char *key_end, *prefix_key; size_t prefix_len; key_end = (char *) state->key->iov_base + state->key->iov_len; while (key_pos != key_end && *state->pos == *key_pos) { ++key_pos; ++state->pos; } if (key_pos == key_end && *state->pos == ' ') break; prefix_key = (char *) state->key->iov_base; prefix_len = key_pos - prefix_key; /* TODO: Below it might be faster to compare the tail of the key before comparing the head. */ do { next_index(state); state->key += 2; } while (--state->key_count > 1 && (state->key->iov_len < prefix_len || memcmp(state->key->iov_base, prefix_key, prefix_len) != 0)); key_pos = (char *) state->key->iov_base + prefix_len; } if (state->key_count == 1) { while (*state->pos != ' ') ++state->pos; } --state->key_count; state->key += 2; state->index = get_index(state); next_index(state); return MEMCACHED_SUCCESS; } static int read_value(struct command_state *state) { value_size_type size; size_t remains; size = state->end - state->pos; if (size > state->u.value.size) size = state->u.value.size; if (size > 0) { memcpy(state->u.value.ptr, state->pos, size); state->u.value.size -= size; state->u.value.ptr = (char *) state->u.value.ptr + size; state->pos += size; } remains = state->end - state->pos; if (remains < sizeof(eol)) { struct iovec iov[2], *piov; state->pos = memmove(state->buf, state->pos, remains); state->end = state->buf + remains; iov[0].iov_base = state->u.value.ptr; iov[0].iov_len = state->u.value.size; iov[1].iov_base = state->end; iov[1].iov_len = REPLY_BUF_SIZE - remains; piov = &iov[state->u.value.size > 0 ? 0 : 1]; do { ssize_t res; res = readv_restart(state->fd, piov, iov + 2 - piov); if (res <= 0) { state->u.value.ptr = iov[0].iov_base; state->u.value.size = iov[0].iov_len; state->end = iov[1].iov_base; if (res == -1 && (errno == EAGAIN || errno == EWOULDBLOCK)) return MEMCACHED_EAGAIN; state->object->free(state->u.value.opaque); return MEMCACHED_CLOSED; } if ((size_t) res >= piov->iov_len) { piov->iov_base = (char *) piov->iov_base + piov->iov_len; res -= piov->iov_len; piov->iov_len = 0; ++piov; } piov->iov_len -= res; piov->iov_base = (char *) piov->iov_base + res; } while ((size_t) ((char *) iov[1].iov_base - state->pos) < sizeof(eol)); state->end = iov[1].iov_base; } if (memcmp(state->pos, eol, sizeof(eol)) != 0) { state->object->free(state->u.value.opaque); return MEMCACHED_UNKNOWN; } state->pos += sizeof(eol); state->eol = state->pos; state->object->store(state->object->arg, state->u.value.opaque, state->index, &state->u.value.meta); return MEMCACHED_SUCCESS; } static inline int swallow_eol(struct command_state *state, int skip, int done) { if (! skip && state->eol - state->pos != sizeof(eol)) return MEMCACHED_UNKNOWN; state->pos = state->eol; if (done) state->phase = PHASE_DONE; return MEMCACHED_SUCCESS; } static int parse_ull(struct command_state *state, unsigned long long *result) { unsigned long long res = 0; const char *beg; while (*state->pos == ' ') ++state->pos; beg = state->pos; while (1) { switch (*state->pos) { case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': res = res * 10 + (*state->pos - '0'); ++state->pos; break; default: *result = res; return (beg != state->pos ? MEMCACHED_SUCCESS : MEMCACHED_UNKNOWN); } } } static int parse_get_reply(struct command_state *state) { unsigned long long num; int res; switch (state->match) { case MATCH_END: return swallow_eol(state, 0, 1); default: return MEMCACHED_UNKNOWN; case MATCH_VALUE: break; } while (*state->pos == ' ') ++state->pos; res = parse_key(state); if (res != MEMCACHED_SUCCESS) return res; res = parse_ull(state, &num); if (res != MEMCACHED_SUCCESS) return res; state->u.value.meta.flags = num; res = parse_ull(state, &num); if (res != MEMCACHED_SUCCESS) return res; state->u.value.size = num; if (state->u.value.meta.use_cas) { res = parse_ull(state, &num); if (res != MEMCACHED_SUCCESS) return res; state->u.value.meta.cas = num; } res = swallow_eol(state, 0, 0); if (res != MEMCACHED_SUCCESS) return res; state->u.value.ptr = state->object->alloc(state->u.value.size, &state->u.value.opaque); if (! state->u.value.ptr) return MEMCACHED_FAILURE; state->phase = PHASE_VALUE; return MEMCACHED_SUCCESS; } static inline void store_result(struct command_state *state, int res) { int index = get_index(state); next_index(state); state->object->store(state->object->arg, (void *) (long) res, index, NULL); } static int parse_set_reply(struct command_state *state) { switch (state->match) { case MATCH_STORED: store_result(state, 1); break; case MATCH_NOT_STORED: case MATCH_NOT_FOUND: case MATCH_EXISTS: store_result(state, 0); break; default: return MEMCACHED_UNKNOWN; } return swallow_eol(state, 0, 1); } static int parse_delete_reply(struct command_state *state) { switch (state->match) { case MATCH_DELETED: store_result(state, 1); break; case MATCH_NOT_FOUND: store_result(state, 0); break; default: return MEMCACHED_UNKNOWN; } return swallow_eol(state, 0, 1); } static int parse_arith_reply(struct command_state *state) { char *beg; size_t len; int zero; state->index = get_index(state); next_index(state); switch (state->match) { case MATCH_NOT_FOUND: /* On NOT_FOUND we store the defined empty string. */ state->u.embedded.ptr = state->object->alloc(0, &state->u.embedded.opaque); if (! state->u.embedded.ptr) return MEMCACHED_FAILURE; state->object->store(state->object->arg, state->u.embedded.opaque, state->index, NULL); return swallow_eol(state, 0, 1); default: return MEMCACHED_UNKNOWN; case MATCH_0: case MATCH_1: case MATCH_2: case MATCH_3: case MATCH_4: case MATCH_5: case MATCH_6: case MATCH_7: case MATCH_8: case MATCH_9: break; } beg = state->pos - 1; len = 0; while (len == 0) { switch (*state->pos) { case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': ++state->pos; break; default: len = state->pos - beg; break; } } zero = (*beg == '0' && len == 1); if (zero) len = 3; state->u.embedded.ptr = state->object->alloc(len, &state->u.embedded.opaque); if (! state->u.embedded.ptr) return MEMCACHED_FAILURE; if (! zero) memcpy(state->u.embedded.ptr, beg, len); else memcpy(state->u.embedded.ptr, "0E0", 3); state->object->store(state->object->arg, state->u.embedded.opaque, state->index, NULL); /* Value may be space padded. */ return swallow_eol(state, 1, 1); } static int parse_ok_reply(struct command_state *state) { switch (state->match) { case MATCH_OK: store_result(state, 1); return swallow_eol(state, 0, 1); default: return MEMCACHED_UNKNOWN; } } static int parse_version_reply(struct command_state *state) { const char *beg; size_t len; int res; state->index = get_index(state); next_index(state); switch (state->match) { default: return MEMCACHED_UNKNOWN; case MATCH_VERSION: break; } while (*state->pos == ' ') ++state->pos; beg = state->pos; res = swallow_eol(state, 1, 1); if (res != MEMCACHED_SUCCESS) return res; len = state->pos - sizeof(eol) - beg; state->u.embedded.ptr = state->object->alloc(len, &state->u.embedded.opaque); if (! state->u.embedded.ptr) return MEMCACHED_FAILURE; memcpy(state->u.embedded.ptr, beg, len); state->object->store(state->object->arg, state->u.embedded.opaque, state->index, NULL); return MEMCACHED_SUCCESS; } static int parse_nowait_reply(struct command_state *state) { int res; /* Cast to enum parse_keyword_e to get compiler warning when some match result is not handled. */ switch ((enum parse_keyword_e) state->match) { case MATCH_DELETED: case MATCH_OK: case MATCH_STORED: case MATCH_EXISTS: case MATCH_NOT_FOUND: case MATCH_NOT_STORED: return swallow_eol(state, 0, 1); case MATCH_0: case MATCH_1: case MATCH_2: case MATCH_3: case MATCH_4: case MATCH_5: case MATCH_6: case MATCH_7: case MATCH_8: case MATCH_9: case MATCH_VERSION: /* see client_noreply_push(). */ return swallow_eol(state, 1, 1); case MATCH_ERROR: res = swallow_eol(state, 0, 1); return (res == MEMCACHED_SUCCESS ? MEMCACHED_ERROR : res); case MATCH_CLIENT_ERROR: case MATCH_SERVER_ERROR: res = swallow_eol(state, 1, 1); return (res == MEMCACHED_SUCCESS ? MEMCACHED_ERROR : res); case NO_MATCH: case MATCH_VALUE: case MATCH_END: case MATCH_STAT: return MEMCACHED_UNKNOWN; } /* Never reach here. */ return MEMCACHED_UNKNOWN; } static void client_mark_failed(struct client *c, struct server *s) { if (s->cmd_state.fd != -1) { close(s->cmd_state.fd); s->cmd_state.fd = -1; s->cmd_state.nowait_count = 0; s->cmd_state.pos = s->cmd_state.end = s->cmd_state.eol = s->cmd_state.buf; } if (c->max_failures > 0) { time_t now = time(NULL); if (s->failure_expires < now) s->failure_count = 0; ++s->failure_count; /* Set timeout on first failure, and on max_failures. The idea is that if max_failures had happened during failure_timeout, we do not retry in another failure_timeout seconds. This is not entirely true: we remember the time of the first failure, but for exact accounting we would have to keep time of each failure. However such exact measurement is not necessary. */ if (s->failure_count == 1 || s->failure_count == c->max_failures) s->failure_expires = now + c->failure_timeout; } } static int send_request(struct command_state *state, struct server *s) { while (state->iov_count > 0) { int count; ssize_t res; size_t len; count = (state->iov_count < state->client->iov_max ? state->iov_count : state->client->iov_max); state->iov->iov_base = (char *) state->iov->iov_base + state->write_offset; state->iov->iov_len -= state->write_offset; len = state->iov->iov_len; res = writev_restart(state->fd, state->iov, count); state->iov->iov_base = (char *) state->iov->iov_base - state->write_offset; state->iov->iov_len += state->write_offset; if (res == -1 && (errno == EAGAIN || errno == EWOULDBLOCK)) return MEMCACHED_EAGAIN; if (res <= 0) { deactivate(state); client_mark_failed(state->client, s); return MEMCACHED_CLOSED; } while ((size_t) res >= len) { res -= len; ++state->iov; if (--state->iov_count == 0) break; len = state->iov->iov_len; state->write_offset = 0; } state->write_offset += res; } if (state->reply_count == 0) deactivate(state); return MEMCACHED_SUCCESS; } static int receive_reply(struct command_state *state) { while (state->eol != state->end && *state->eol != eol[sizeof(eol) - 1]) ++state->eol; /* When buffer is empty, move to the beginning of it for better CPU cache utilization. */ if (state->pos == state->end) state->pos = state->end = state->eol = state->buf; while (state->eol == state->end) { size_t size; ssize_t res; size = REPLY_BUF_SIZE - (state->end - state->buf); if (size == 0) { if (state->pos != state->buf) { size_t len = state->end - state->pos; state->pos = memmove(state->buf, state->pos, len); state->end -= REPLY_BUF_SIZE - len; state->eol -= REPLY_BUF_SIZE - len; size = REPLY_BUF_SIZE - len; } else { return MEMCACHED_UNKNOWN; } } res = read_restart(state->fd, state->end, size); if (res == -1 && (errno == EAGAIN || errno == EWOULDBLOCK)) return MEMCACHED_EAGAIN; if (res <= 0) return MEMCACHED_CLOSED; state->end += res; while (state->eol != state->end && *state->eol != eol[sizeof(eol) - 1]) ++state->eol; } if ((size_t) (state->eol - state->buf) < sizeof(eol) - 1 || memcmp(state->eol - (sizeof(eol) - 1), eol, sizeof(eol) - 1) != 0) return MEMCACHED_UNKNOWN; ++state->eol; return MEMCACHED_SUCCESS; } static int parse_reply(struct command_state *state) { int res, skip; switch (state->match) { case MATCH_ERROR: case MATCH_CLIENT_ERROR: case MATCH_SERVER_ERROR: skip = (state->match != MATCH_ERROR); res = swallow_eol(state, skip, 1); return (res == MEMCACHED_SUCCESS ? MEMCACHED_ERROR : res); default: if (state->nowait_count) return parse_nowait_reply(state); else return state->parse_reply(state); case NO_MATCH: return MEMCACHED_UNKNOWN; } } static int process_reply(struct command_state *state, struct server *s) { int res = 0; while (1) { switch (state->phase) { case PHASE_RECEIVE: res = receive_reply(state); if (res != MEMCACHED_SUCCESS) break; state->match = parse_keyword(&state->pos); state->phase = PHASE_PARSE; /* Fall into below. */ case PHASE_PARSE: res = parse_reply(state); if (res != MEMCACHED_SUCCESS) break; if (state->phase != PHASE_DONE) continue; /* Fall into below. */ case PHASE_DONE: res = MEMCACHED_SUCCESS; break; case PHASE_VALUE: res = read_value(state); if (res != MEMCACHED_SUCCESS) break; state->phase = PHASE_RECEIVE; continue; } switch (res) { case MEMCACHED_ERROR: if (! (state->client->close_on_error || state->noreply)) break; /* else fall into below. */ case MEMCACHED_UNKNOWN: case MEMCACHED_CLOSED: deactivate(state); client_mark_failed(state->client, s); /* Fall into below. */ case MEMCACHED_EAGAIN: return res; } if (state->nowait_count > 0) { --state->nowait_count; } else if (--state->reply_count == 0) { if (state->iov_count == 0) deactivate(state); return res; } state->phase = PHASE_RECEIVE; } } static inline void state_prepare(struct command_state *state) { state->key = array_elem(state->iov_buf, struct iovec, 2); state->iov = array_beg(state->iov_buf, struct iovec); state->iov_count = array_size(state->iov_buf); if (state->str_step > 0) { struct iovec *iov = state->iov; char *buf = array_beg(state->client->str_buf, char); int count = state->iov_count, step = state->str_step; if (state->key_count > 0) { iov += 3; count -= 3; } while (count > 0) { iov->iov_base = (void *) (buf + (long) (iov->iov_base)); iov += step; count -= step; } } } int client_execute(struct client *c) { int first_iter = 1; #if ! defined(MSG_NOSIGNAL) && ! defined(WIN32) struct sigaction orig, ignore; int res; ignore.sa_handler = SIG_IGN; sigemptyset(&ignore.sa_mask); ignore.sa_flags = 0; res = sigaction(SIGPIPE, &ignore, &orig); if (res == -1) return MEMCACHED_FAILURE; #endif /* ! defined(MSG_NOSIGNAL) && ! defined(WIN32) */ while (1) { struct server *s; struct pollfd *pollfd_beg, *pollfd; int res; pollfd_beg = array_beg(c->pollfds, struct pollfd); pollfd = pollfd_beg; for (array_each(c->servers, struct server, s)) { int may_write, may_read; struct command_state *state = &s->cmd_state; if (! is_active(state)) continue; if (first_iter) { state_prepare(state); may_write = 1; may_read = (state->reply_count > 0 || state->nowait_count > 0); } else { const short revents = state->pollfd->revents; may_write = revents & (POLLOUT | POLLERR | POLLHUP); may_read = revents & (POLLIN | POLLERR | POLLHUP); } if (may_read || may_write) { if (may_write) { int res; res = send_request(state, s); if (res == MEMCACHED_CLOSED) may_read = 0; } if (may_read) process_reply(state, s); if (! is_active(state)) continue; } pollfd->events = 0; if (state->iov_count > 0) pollfd->events |= POLLOUT; if (state->reply_count > 0 || state->nowait_count > 0) pollfd->events |= POLLIN; if (pollfd->events != 0) { pollfd->fd = state->fd; state->pollfd = pollfd; ++pollfd; } } if (pollfd == pollfd_beg) break; do res = poll(pollfd_beg, pollfd - pollfd_beg, c->io_timeout); while (res == -1 && errno == EINTR); /* On error or timeout close all active connections. Otherwise we might receive garbage on them later. */ if (res <= 0) { for (array_each(c->servers, struct server, s)) { struct command_state *state = &s->cmd_state; if (is_active(state)) { /* Ugly fix for possible memory leak. FIXME: requires redesign. */ if (state->phase == PHASE_VALUE) state->object->free(state->u.value.opaque); client_mark_failed(c, s); } } break; } first_iter = 0; } #if ! defined(MSG_NOSIGNAL) && ! defined(WIN32) /* Ignore return value of sigaction(), there's nothing we can do in the case of error. */ sigaction(SIGPIPE, &orig, NULL); #endif /* ! defined(MSG_NOSIGNAL) && ! defined(WIN32) */ return MEMCACHED_SUCCESS; } /* Is the following required for any platform? */ #if (! defined(IPPROTO_TCP) && defined(SOL_TCP)) #define IPPROTO_TCP SOL_TCP #endif static inline void tcp_optimize_latency(struct command_state *state) { #ifdef TCP_NODELAY if (state->socket_mode == TCP_THROUGHPUT) { static const int enable = 1; setsockopt(state->fd, IPPROTO_TCP, TCP_NODELAY, (void *) &enable, sizeof(enable)); state->socket_mode = TCP_LATENCY; } #endif /* TCP_NODELAY */ } static inline void tcp_optimize_throughput(struct command_state *state) { #ifdef TCP_NODELAY if (state->socket_mode == TCP_LATENCY) { static const int disable = 0; setsockopt(state->fd, IPPROTO_TCP, TCP_NODELAY, (void *) &disable, sizeof(disable)); state->socket_mode = TCP_THROUGHPUT; } #endif /* TCP_NODELAY */ } static int get_server_fd(struct client *c, struct server *s) { struct command_state *state; /* Do not try to try reconnect if had max_failures and failure_expires time is not reached yet. */ if (c->max_failures > 0 && s->failure_count >= c->max_failures) { if (time(NULL) <= s->failure_expires) return -1; else s->failure_count = 0; } state = &s->cmd_state; if (state->fd == -1) { if (s->port) { state->fd = client_connect_inet(s->host, s->port, c->connect_timeout); /* This is to trigger actual reset. */ state->socket_mode = TCP_THROUGHPUT; if (state->fd != -1) tcp_optimize_latency(state); } else { state->fd = client_connect_unix(s->host, s->host_len); state->socket_mode = NOT_TCP; } } if (state->fd == -1) client_mark_failed(c, s); return state->fd; } static inline void iov_push(struct command_state *state, const void *buf, size_t buf_size) { struct iovec *iov = array_end(state->iov_buf, struct iovec); iov->iov_base = (void *) buf; iov->iov_len = buf_size; array_push(state->iov_buf); } static int push_index(struct command_state *state, int index) { struct index_node *node; struct client *c; c = state->client; if (array_extend(c->index_list, struct index_node, 1, ARRAY_EXTEND_TWICE) == -1) return MEMCACHED_FAILURE; if (state->index_tail != -1) array_elem(c->index_list, struct index_node, state->index_tail)->next = array_size(c->index_list); else state->index_head = array_size(c->index_list); state->index_tail = array_size(c->index_list); node = array_elem(c->index_list, struct index_node, state->index_tail); node->index = index; node->next = -1; array_push(c->index_list); return MEMCACHED_SUCCESS; } static struct command_state * init_state(struct command_state *state, int index, size_t request_size, size_t str_size, parse_reply_func parse_reply) { if (! is_active(state)) { if (state->client->noreply) { if (state->client->nowait || state->noreply) { parse_reply = NULL; tcp_optimize_throughput(state); } state->last_cmd_noreply = state->noreply; } else { state->last_cmd_noreply = 0; tcp_optimize_latency(state); } state->object = state->client->object; command_state_reset(state, (str_size > 0 ? request_size : 0), parse_reply); } if (array_extend(state->iov_buf, struct iovec, request_size, ARRAY_EXTEND_EXACT) == -1) { deactivate(state); return NULL; } if (str_size > 0 && array_extend(state->client->str_buf, char, str_size, ARRAY_EXTEND_TWICE) == -1) { deactivate(state); return NULL; } if (push_index(state, index) != MEMCACHED_SUCCESS) { deactivate(state); return NULL; } if (state->parse_reply) ++state->reply_count; else if (! state->last_cmd_noreply) ++state->nowait_count; return state; } static struct command_state * get_state(struct client *c, int index, const char *key, size_t key_len, size_t request_size, size_t str_size, parse_reply_func parse_reply) { struct server *s; int server_index, fd; server_index = dispatch_key(&c->dispatch, key, key_len); if (server_index == -1) return NULL; s = array_elem(c->servers, struct server, server_index); fd = get_server_fd(c, s); if (fd == -1) return NULL; return init_state(&s->cmd_state, index, request_size, str_size, parse_reply); } static inline const char * get_noreply(struct command_state *state) { if (state->noreply && state->client->noreply) return " " NOREPLY; else return ""; } inline void client_reset(struct client *c, struct result_object *o, int noreply) { array_clear(c->index_list); array_clear(c->str_buf); ++c->generation; c->object = o; c->noreply = noreply; } #define STR_WITH_LEN(str) (str), (sizeof(str) - 1) int client_prepare_set(struct client *c, enum set_cmd_e cmd, int key_index, const char *key, size_t key_len, flags_type flags, exptime_type exptime, const void *value, value_size_type value_size) { static const size_t request_size = 6; static const size_t str_size = sizeof(" " FLAGS_STUB " " EXPTIME_STUB " " VALUE_SIZE_STUB " " NOREPLY "\r\n"); struct command_state *state; state = get_state(c, key_index, key, key_len, request_size, str_size, parse_set_reply); if (! state) return MEMCACHED_FAILURE; ++state->key_count; switch (cmd) { case CMD_SET: iov_push(state, STR_WITH_LEN("set")); break; case CMD_ADD: iov_push(state, STR_WITH_LEN("add")); break; case CMD_REPLACE: iov_push(state, STR_WITH_LEN("replace")); break; case CMD_APPEND: iov_push(state, STR_WITH_LEN("append")); break; case CMD_PREPEND: iov_push(state, STR_WITH_LEN("prepend")); break; case CMD_CAS: /* This can't happen. */ return MEMCACHED_FAILURE; } iov_push(state, c->prefix, c->prefix_len); iov_push(state, key, key_len); { char *buf = array_end(c->str_buf, char); size_t str_size = sprintf(buf, " " FMT_FLAGS " " FMT_EXPTIME " " FMT_VALUE_SIZE "%s\r\n", flags, exptime, value_size, get_noreply(state)); iov_push(state, (void *) (long) array_size(c->str_buf), str_size); array_append(c->str_buf, str_size); } iov_push(state, value, value_size); iov_push(state, STR_WITH_LEN("\r\n")); return MEMCACHED_SUCCESS; } int client_prepare_cas(struct client *c, int key_index, const char *key, size_t key_len, cas_type cas, flags_type flags, exptime_type exptime, const void *value, value_size_type value_size) { static const size_t request_size = 6; static const size_t str_size = sizeof(" " FLAGS_STUB " " EXPTIME_STUB " " VALUE_SIZE_STUB " " CAS_STUB " " NOREPLY "\r\n"); struct command_state *state; state = get_state(c, key_index, key, key_len, request_size, str_size, parse_set_reply); if (! state) return MEMCACHED_FAILURE; ++state->key_count; iov_push(state, STR_WITH_LEN("cas")); iov_push(state, c->prefix, c->prefix_len); iov_push(state, key, key_len); { char *buf = array_end(c->str_buf, char); size_t str_size = sprintf(buf, " " FMT_FLAGS " " FMT_EXPTIME " " FMT_VALUE_SIZE " " FMT_CAS "%s\r\n", flags, exptime, value_size, cas, get_noreply(state)); iov_push(state, (void *) (long) array_size(c->str_buf), str_size); array_append(c->str_buf, str_size); } iov_push(state, value, value_size); iov_push(state, STR_WITH_LEN("\r\n")); return MEMCACHED_SUCCESS; } int client_prepare_get(struct client *c, enum get_cmd_e cmd, int key_index, const char *key, size_t key_len) { static const size_t request_size = 4; struct command_state *state; state = get_state(c, key_index, key, key_len, request_size, 0, parse_get_reply); if (! state) return MEMCACHED_FAILURE; ++state->key_count; if (! array_empty(state->iov_buf)) { /* Pop off trailing \r\n because we are about to add another key. */ array_pop(state->iov_buf); /* get can't be in noreply mode, so reply_count is positive. */ --state->reply_count; } else { switch (cmd) { case CMD_GET: state->u.value.meta.use_cas = 0; iov_push(state, STR_WITH_LEN("get")); break; case CMD_GETS: state->u.value.meta.use_cas = 1; iov_push(state, STR_WITH_LEN("gets")); break; } } iov_push(state, c->prefix, c->prefix_len); iov_push(state, key, key_len); iov_push(state, STR_WITH_LEN("\r\n")); return MEMCACHED_SUCCESS; } int client_prepare_incr(struct client *c, enum arith_cmd_e cmd, int key_index, const char *key, size_t key_len, arith_type arg) { static const size_t request_size = 4; static const size_t str_size = sizeof(" " ARITH_STUB " " NOREPLY "\r\n"); struct command_state *state; state = get_state(c, key_index, key, key_len, request_size, str_size, parse_arith_reply); if (! state) return MEMCACHED_FAILURE; ++state->key_count; switch (cmd) { case CMD_INCR: iov_push(state, STR_WITH_LEN("incr")); break; case CMD_DECR: iov_push(state, STR_WITH_LEN("decr")); break; } iov_push(state, c->prefix, c->prefix_len); iov_push(state, key, key_len); { char *buf = array_end(c->str_buf, char); size_t str_size = sprintf(buf, " " FMT_ARITH "%s\r\n", arg, get_noreply(state)); iov_push(state, (void *) (long) array_size(c->str_buf), str_size); array_append(c->str_buf, str_size); } return MEMCACHED_SUCCESS; } int client_prepare_delete(struct client *c, int key_index, const char *key, size_t key_len) { static const size_t request_size = 4; static const size_t str_size = sizeof(" " NOREPLY "\r\n"); struct command_state *state; state = get_state(c, key_index, key, key_len, request_size, str_size, parse_delete_reply); if (! state) return MEMCACHED_FAILURE; ++state->key_count; iov_push(state, STR_WITH_LEN("delete")); iov_push(state, c->prefix, c->prefix_len); iov_push(state, key, key_len); { char *buf = array_end(c->str_buf, char); size_t str_size = sprintf(buf, "%s\r\n", get_noreply(state)); iov_push(state, (void *) (long) array_size(c->str_buf), str_size); array_append(c->str_buf, str_size); } return MEMCACHED_SUCCESS; } int client_flush_all(struct client *c, delay_type delay, struct result_object *o, int noreply) { static const size_t request_size = 1; static const size_t str_size = sizeof("flush_all " DELAY_STUB " " NOREPLY "\r\n"); struct server *s; double ddelay = delay, delay_step = 0.0; int i; client_reset(c, o, noreply); if (array_size(c->servers) > 1) delay_step = ddelay / (array_size(c->servers) - 1); ddelay += delay_step; for (i = 0, array_each(c->servers, struct server, s), ++i) { struct command_state *state; int fd; ddelay -= delay_step; fd = get_server_fd(c, s); if (fd == -1) continue; state = init_state(&s->cmd_state, i, request_size, str_size, parse_ok_reply); if (! state) continue; { char *buf = array_end(c->str_buf, char); size_t str_size = sprintf(buf, "flush_all " FMT_DELAY "%s\r\n", (delay_type) (ddelay + 0.5), get_noreply(state)); iov_push(state, (void *) (long) array_size(c->str_buf), str_size); array_append(c->str_buf, str_size); } } return client_execute(c); } int client_nowait_push(struct client *c) { struct server *s; if (! c->nowait) return MEMCACHED_SUCCESS; client_reset(c, NULL, 0); for (array_each(c->servers, struct server, s)) { struct command_state *state; int fd; state = &s->cmd_state; if (state->nowait_count == 0) continue; fd = get_server_fd(c, s); if (fd == -1) continue; /* In order to wait the final pending reply we pretend that one command was never a nowait command, and set parse function to parse_nowait_reply. */ --state->nowait_count; command_state_reset(state, 0, parse_nowait_reply); tcp_optimize_latency(state); ++state->reply_count; } return client_execute(c); } int client_server_versions(struct client *c, struct result_object *o) { static const size_t request_size = 1; struct server *s; int i; client_reset(c, o, 0); for (i = 0, array_each(c->servers, struct server, s), ++i) { struct command_state *state; int fd; fd = get_server_fd(c, s); if (fd == -1) continue; state = init_state(&s->cmd_state, i, request_size, 0, parse_version_reply); if (! state) continue; iov_push(state, STR_WITH_LEN("version\r\n")); } return client_execute(c); } /* When noreply mode is enabled the client may send the last noreply request and close the connection. The server will see that the connection is closed, and will discard all previously read data without processing it. To avoid this, we send "version" command and wait for the reply (discarding it). */ static int client_noreply_push(struct client *c) { static const size_t request_size = 1; struct server *s; int i; client_reset(c, NULL, 0); for (i = 0, array_each(c->servers, struct server, s), ++i) { struct command_state *state = &s->cmd_state; int fd; if (! state->last_cmd_noreply) continue; fd = get_server_fd(c, s); if (fd == -1) continue; state = init_state(state, i, request_size, 0, parse_nowait_reply); if (! state) continue; iov_push(state, STR_WITH_LEN("version\r\n")); } return client_execute(c); } Cache-Memcached-Fast-0.21/src/poll_select.c0000644000175000017500000000662612127763070020025 0ustar tomashtomash/* Copyright (C) 2008 Tomash Brechko. All rights reserved. When used to build Perl module: 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.8 or, at your option, any later version of Perl 5 you may have available. When used as a standalone library: This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. */ #include "poll_select.h" #ifndef WIN32 #include "socket_posix.h" #else /* WIN32 */ #include "socket_win32.h" #endif /* WIN32 */ int poll_select(struct pollfd *fds, int nfds, int timeout) { fd_set read_set, write_set, exception_set; struct timeval to, *pto; int max_fd = -1; int select_res, poll_res; int i; if (timeout >= 0) { pto = &to; pto->tv_sec = timeout / 1000; pto->tv_usec = (timeout % 1000) * 1000; } else { pto = NULL; } FD_ZERO(&read_set); FD_ZERO(&write_set); FD_ZERO(&exception_set); for (i = 0; i < nfds; ++i) { fds[i].revents = 0; /* POSIX requires skipping fd less than zero. */ if (fds[i].fd < 0) continue; /* To continue is the best we can do here, but we shouldn't be called with non-select()'able descriptor at the first place. */ if (! can_poll_fd(fds[i].fd)) continue; if (max_fd < fds[i].fd) max_fd = fds[i].fd; if (fds[i].events & POLLIN) FD_SET(fds[i].fd, &read_set); if (fds[i].events & POLLOUT) FD_SET(fds[i].fd, &write_set); /* poll() waits for error condition even when no other event is requested (events == 0). POSIX says that pending socket error should be an exceptional condition. However other exceptional conditions are protocol-specific. For instance for TCP out-of-band data is often also exceptional. So we enable exceptions unconditionally, and callers should treat returned POLLERR as "may read/write". */ FD_SET(fds[i].fd, &exception_set); } select_res = select(max_fd + 1, &read_set, &write_set, &exception_set, pto); if (select_res > 0) { /* select() returns number of bits set, but poll() returns number of flagged structures. */ poll_res = 0; for (i = 0; i < nfds; ++i) { if (FD_ISSET(fds[i].fd, &read_set)) { fds[i].revents |= POLLIN; --select_res; } if (FD_ISSET(fds[i].fd, &write_set)) { fds[i].revents |= POLLOUT; --select_res; } if (FD_ISSET(fds[i].fd, &exception_set)) { fds[i].revents |= POLLERR; --select_res; } if (fds[i].revents != 0) { ++poll_res; if (select_res == 0) break; } } } else { poll_res = select_res; } return poll_res; } Cache-Memcached-Fast-0.21/src/array.c0000644000175000017500000000262412127763070016630 0ustar tomashtomash/* Copyright (C) 2008 Tomash Brechko. All rights reserved. When used to build Perl module: 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.8 or, at your option, any later version of Perl 5 you may have available. When used as a standalone library: This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. */ #include "array.h" #include void array_init(struct array *a) { a->buf = NULL; a->capacity = a->elems = 0; } void array_destroy(struct array *a) { free(a->buf); } int array_resize(struct array *a, int elem_size, int elems, enum e_array_extend extend) { void *buf; if (elems <= a->capacity) return 0; if (extend == ARRAY_EXTEND_TWICE && elems < a->capacity * 2) elems = a->capacity * 2; buf = realloc(a->buf, elem_size * elems); if (! buf) return -1; a->buf = buf; a->capacity = elems; return 0; } Cache-Memcached-Fast-0.21/src/poll_select.h0000644000175000017500000000250512127763070020022 0ustar tomashtomash/* Copyright (C) 2008 Tomash Brechko. All rights reserved. When used to build Perl module: 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.8 or, at your option, any later version of Perl 5 you may have available. When used as a standalone library: This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. */ #ifndef POLL_SELECT_H #define POLL_SELECT_H 1 #undef POLLIN #define POLLIN 0x1 #undef POLLOUT #define POLLOUT 0x2 #undef POLLERR #define POLLERR 0x4 #undef POLLHUP #define POLLHUP 0x4 struct pollfd { int fd; /* File descriptor. */ short events; /* Requested events. */ short revents; /* Returned events. */ }; extern int poll_select(struct pollfd *fds, int nfds, int timeout); #endif /* ! POLL_SELECT_H */ Cache-Memcached-Fast-0.21/src/array.h0000644000175000017500000000374612127763070016643 0ustar tomashtomash/* Copyright (C) 2008 Tomash Brechko. All rights reserved. When used to build Perl module: 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.8 or, at your option, any later version of Perl 5 you may have available. When used as a standalone library: This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. */ #ifndef ARRAY_H #define ARRAY_H 1 struct array { void *buf; int capacity; int elems; }; extern void array_init(struct array *a); extern void array_destroy(struct array *a); enum e_array_extend { ARRAY_EXTEND_EXACT, ARRAY_EXTEND_TWICE }; extern int array_resize(struct array *a, int elem_size, int elems, enum e_array_extend extend); #define array_extend(array, type, add, extend) \ array_resize(&(array), sizeof(type), (array).elems + add, extend) #define array_push(array) ++(array).elems #define array_pop(array) --(array).elems #define array_append(array, add) (array).elems += add #define array_size(array) ((array).elems) #define array_empty(array) ((array).elems == 0) #define array_clear(array) (array).elems = 0 #define array_elem(array, type, index) ((type *) (array).buf + index) #define array_beg(array, type) ((type *) (array).buf) #define array_end(array, type) ((type *) (array).buf + (array).elems) #define array_each(array, type, p) \ (p) = array_beg(array, type); (p) != array_end(array, type); ++(p) #endif /* ! ARRAY_H */ Cache-Memcached-Fast-0.21/src/socket_win32.c0000644000175000017500000000364512127763070020030 0ustar tomashtomash/* Copyright (C) 2008 Tomash Brechko. All rights reserved. When used to build Perl module: 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.8 or, at your option, any later version of Perl 5 you may have available. When used as a standalone library: This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. */ #include "socket_win32.h" int win32_socket_library_acquire() { WSADATA wsaData; return WSAStartup(MAKEWORD(2, 2), &wsaData); } int set_nonblock(SOCKET fd) { u_long flags = 1; return ioctlsocket(fd, FIONBIO, &flags); } #undef connect int win32_connect(SOCKET fd, const struct sockaddr *addr, int addrlen) { int res; res = connect(fd, addr, addrlen); /* For non-blocking socket Win32 connect() sets error to WSAEWOULDBLOCK. We map it to WSAEINPROGRESS, because this is what we expect for non-blocking POSIX connect() in progress. */ if (res == -1 && WSAGetLastError() == WSAEWOULDBLOCK) WSASetLastError(WSAEINPROGRESS); return res; } ssize_t readv(SOCKET fd, const struct iovec *iov, int iovcnt) { DWORD count, flags = 0; int res; res = WSARecv(fd, (LPWSABUF) iov, iovcnt, &count, &flags, NULL, NULL); return (res == 0 ? count : -1); } ssize_t writev(SOCKET fd, const struct iovec *iov, int iovcnt) { DWORD count; int res; res = WSASend(fd, (LPWSABUF) iov, iovcnt, &count, 0, NULL, NULL); return (res == 0 ? count : -1); } Cache-Memcached-Fast-0.21/src/reply.kw0000644000175000017500000000122312127763070017036 0ustar tomashtomash# Input file for genparser.pl script. # Name of the parser function. parser_func = parse_keyword # When loose_match is enabled the parser matches only essential # characters. This is faster, but not future-compatible. For # instance, NOT_FOUND and NOT_STORED can be matched by testing first # and fifth character, but if, say, NOT_SET would be introduced, the # parser will match it to NOT_STORED until it knows the new keyword. loose_match = 0 %% # List keywords below (in any order). CLIENT_ERROR DELETED END ERROR EXISTS NOT_FOUND NOT_STORED OK SERVER_ERROR STAT STORED VALUE VERSION # incr and decr return non-negative number. 0 1 2 3 4 5 6 7 8 9 Cache-Memcached-Fast-0.21/src/socket_posix.c0000644000175000017500000000351512127763070020224 0ustar tomashtomash/* Copyright (C) 2008 Tomash Brechko. All rights reserved. When used to build Perl module: 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.8 or, at your option, any later version of Perl 5 you may have available. When used as a standalone library: This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. */ #include "socket_posix.h" #include #include #include /* http://www.opengroup.org/onlinepubs/009695399/basedefs/sys/un.h.html says 92 is a rather safe value. */ #define SAFE_UNIX_PATH_MAX 92 int set_nonblock(int fd) { int flags; flags = fcntl(fd, F_GETFL); return fcntl(fd, F_SETFL, flags | O_NONBLOCK); } int connect_unix(const char *path, size_t path_len) { int fd, res; struct sockaddr_un s_unix; if (path_len >= SAFE_UNIX_PATH_MAX) return -1; fd = socket(PF_UNIX, SOCK_STREAM, 0); if (fd == -1) return -1; if (! can_poll_fd(fd)) { close(fd); return -1; } s_unix.sun_family = AF_UNIX; memcpy(s_unix.sun_path, path, path_len); s_unix.sun_path[path_len] = '\0'; res = connect(fd, (const struct sockaddr *) &s_unix, sizeof(s_unix)); if (res != 0) { close(fd); return -1; } res = set_nonblock(fd); if (res != 0) { close(fd); return -1; } return fd; } Cache-Memcached-Fast-0.21/src/socket_posix.h0000644000175000017500000000336012127763070020227 0ustar tomashtomash/* Copyright (C) 2008, 2010 Tomash Brechko. All rights reserved. When used to build Perl module: 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.8 or, at your option, any later version of Perl 5 you may have available. When used as a standalone library: This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. */ #ifndef SOCKET_POSIX_H #define SOCKET_POSIX_H 1 #include #include #include #include #include #include #if defined(_SC_IOV_MAX) #define get_iov_max() sysconf(_SC_IOV_MAX) #elif defined(IOV_MAX) #define get_iov_max() IOV_MAX #else #define get_iov_max() 16 #endif #if defined(HAVE_POLL_H) #include #define can_poll_fd(fd) 1 #elif defined(HAVE_SYS_POLL_H) #include #define can_poll_fd(fd) 1 #else /* ! defined(HAVE_POLL_H) && ! defined(HAVE_SYS_POLL_H) */ #include "poll_select.h" #define poll(fds, nfds, timeout) poll_select(fds, nfds, timeout) #define can_poll_fd(fd) ((fd) < FD_SETSIZE) #endif /* ! defined(HAVE_POLL_H) && ! defined(HAVE_SYS_POLL_H) */ extern int set_nonblock(int fd); extern int connect_unix(const char *path, size_t path_len); #endif /* ! SOCKET_POSIX_H */ Cache-Memcached-Fast-0.21/src/socket_win32.h0000644000175000017500000000541412127763070020031 0ustar tomashtomash/* Copyright (C) 2008-2010 Tomash Brechko. All rights reserved. When used to build Perl module: 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.8 or, at your option, any later version of Perl 5 you may have available. When used as a standalone library: This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. */ #ifndef SOCKET_WIN32_H #define SOCKET_WIN32_H 1 #include #include #include #define get_iov_max() 64 #if _WIN32_WINNT >= 0x0501 #include #else /* ! (_WIN32_WINNT >= 0x0501) */ #include "addrinfo_hostent.h" #endif /* ! (_WIN32_WINNT >= 0x0501) */ #if _WIN32_WINNT >= 0x0600 #define poll(fds, nfds, timeout) WSAPoll(fds, nfds, timeout) #else /* ! (_WIN32_WINNT >= 0x0600) */ #include "poll_select.h" #define poll(fds, nfds, timeout) poll_select(fds, nfds, timeout) #endif /* ! (_WIN32_WINNT >= 0x0600) */ /* On Win32 FD_SETSIZE is not the limit on the max fd value, but instead the limit on the total number of fds that select() can handle. So can_poll_fd() should return 1 in any case, any fd is select()'able or WSAPoll()'able. By default FD_SETSIZE is 64. If you plan to use more memcached servers, you may redefine it to a larger value before including . */ #define can_poll_fd(fd) 1 #undef errno #define errno WSAGetLastError() #undef EINTR #define EINTR WSAEINTR #undef EWOULDBLOCK #define EWOULDBLOCK WSAEWOULDBLOCK #undef EAGAIN #define EAGAIN WSAEWOULDBLOCK #undef EINPROGRESS #define EINPROGRESS WSAEINPROGRESS #define connect_unix(path, path_len) -1 #define connect(fd, addr, addrlen) win32_connect(fd, addr, addrlen) #define read(fd, buf, size) recv(fd, buf, size, 0) #define close(fd) closesocket(fd) #define win32_socket_library_release WSACleanup extern int win32_socket_library_acquire(); extern int set_nonblock(SOCKET fd); extern int win32_connect(SOCKET fd, const struct sockaddr *addr, int addrlen); /* Define struct iovec the same way as WSABUF is defined. */ struct iovec { u_long iov_len; char FAR *iov_base; }; extern ssize_t readv(SOCKET fd, const struct iovec *iov, int iovcnt); extern ssize_t writev(SOCKET fd, const struct iovec *iov, int iovcnt); #endif /* ! SOCKET_WIN32_H */ Cache-Memcached-Fast-0.21/src/addrinfo_hostent.c0000644000175000017500000001134712127763070021046 0ustar tomashtomash/* Copyright (C) 2009 Tomash Brechko. All rights reserved. When used to build Perl module: 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.8 or, at your option, any later version of Perl 5 you may have available. When used as a standalone library: This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. */ #include "addrinfo_hostent.h" #ifndef WIN32 #include #include #endif /* ! WIN32 */ #include #include #ifdef h_addr #define ADDR(host, i) host->h_addr_list[i] #else /* ! h_addr */ #define ADDR(host, i) host->h_addr #endif /* ! h_addr */ #define FILL_SOCKADDR(AF_INET, sockaddr_in, sin, s, \ host, port, count, addrlen, addrs) \ do \ { \ struct sockaddr_in *addr; \ int i; \ \ addrlen = sizeof(struct sockaddr_in); \ \ addr = (struct sockaddr_in *) calloc(count, addrlen); \ for (i = 0; i < count; ++i) \ { \ addr[i].sin##_family = AF_INET; \ addr[i].sin##_port = port; \ memcpy(&addr[i].sin##_addr.s##_addr, \ ADDR(host, i), host->h_length); \ } \ \ addrs = (char *) addr; \ } \ while (0) #define fill_sockaddr(host, port, count, addrlen, addrs) \ FILL_SOCKADDR(AF_INET, sockaddr_in, sin, s, \ host, port, count, addrlen, addrs) #ifdef AF_INET6 #define fill_sockaddr6(host, port, count, addrlen, addrs) \ FILL_SOCKADDR(AF_INET6, sockaddr_in6, sin6, s6, \ host, port, count, addrlen, addrs) #endif /* AF_INET6 */ int getaddrinfo_hostent(const char *node, const char *service, const struct addrinfo_hostent *hints, struct addrinfo_hostent **res) { struct hostent *host; struct servent *serv; int count, i; int port; char *name; size_t addrlen; char *addrs; struct addrinfo_hostent *addrinfos; host = gethostbyname(node); if (! host || (hints->ai_family != AF_UNSPEC && host->h_addrtype != hints->ai_family)) return -1; count = 1; #ifdef h_addr while (host->h_addr_list[count]) ++count; #endif /* h_addr */ serv = getservbyname(service, (hints->ai_socktype == SOCK_STREAM ? "tcp" : "udp")); port = serv ? serv->s_port : htons(atoi(service)); if (host->h_name) { size_t name_len = strlen(host->h_name); name = (char *) malloc(name_len + 1); memcpy(name, host->h_name, name_len + 1); } else { name = NULL; } #ifdef AF_INET6 if (host->h_addrtype == AF_INET6) fill_sockaddr6(host, port, count, addrlen, addrs); else #endif /* AF_INET6 */ fill_sockaddr(host, port, count, addrlen, addrs); addrinfos = (struct addrinfo_hostent *) malloc(sizeof(*addrinfos) * count); addrinfos[0].ai_flags = hints->ai_flags; addrinfos[0].ai_family = host->h_addrtype; addrinfos[0].ai_socktype = hints->ai_socktype; addrinfos[0].ai_protocol = hints->ai_protocol; addrinfos[0].ai_addrlen = addrlen; addrinfos[0].ai_addr = (struct sockaddr *) addrs; addrinfos[0].ai_canonname = name; for (i = 1; i < count; ++i) { addrinfos[i] = addrinfos[0]; addrinfos[i].ai_addr = (struct sockaddr *) (addrs + addrlen * i); addrinfos[i - 1].ai_next = &addrinfos[i]; } addrinfos[i - 1].ai_next = NULL; *res = addrinfos; return 0; } void freeaddrinfo_hostent(struct addrinfo_hostent *res) { free(res->ai_addr); free(res->ai_canonname); free(res); } Cache-Memcached-Fast-0.21/src/dispatch_key.h0000644000175000017500000000335612127763070020171 0ustar tomashtomash/* Copyright (C) 2007-2008 Tomash Brechko. All rights reserved. When used to build Perl module: 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.8 or, at your option, any later version of Perl 5 you may have available. When used as a standalone library: This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. */ #ifndef DISPATCH_KEY_H #define DISPATCH_KEY_H 1 #include "array.h" #include struct dispatch_state { struct array buckets; double total_weight; int ketama_points; unsigned int prefix_hash; int server_count; }; extern void dispatch_init(struct dispatch_state *state); extern void dispatch_destroy(struct dispatch_state *state); extern void dispatch_set_ketama_points(struct dispatch_state *state, int ketama_points); extern void dispatch_set_prefix(struct dispatch_state *state, const char *prefix, size_t prefix_len); extern int dispatch_add_server(struct dispatch_state *state, const char *host, size_t host_len, const char *port, size_t port_len, double weight, int index); extern int dispatch_key(struct dispatch_state *state, const char *key, size_t key_len); #endif /* ! DISPATCH_KEY_H */ Cache-Memcached-Fast-0.21/src/gencrc32.pl0000755000175000017500000000416112127763070017312 0ustar tomashtomash#! /usr/bin/perl # # Copyright (C) 2007-2008 Tomash Brechko. All rights reserved. # # This program is free software; you can redistribute it and/or modify # it under the same terms as Perl itself, either Perl version 5.8.8 # or, at your option, any later version of Perl 5 you may have # available. # use warnings; use strict; use FindBin; @ARGV == 2 or die "Usage: $FindBin::Script FILE_C FILE_H\n"; my ($file_c, $file_h) = @ARGV; my $poly = 0xedb88320; my $init = 0x0; sub gen_lookup { my ($poly) = @_; my @lookup; for (my $i = 0; $i < 256; ++$i) { my $crc32 = $i; for (my $j = 8; $j > 0; --$j) { if ($crc32 & 0x1) { $crc32 = ($crc32 >> 1) ^ $poly; } else { $crc32 >>= 1; } } push @lookup, $crc32; } return \@lookup; } my $lookup = gen_lookup($poly); my $table; while (@$lookup) { $table .= join(', ', map { sprintf("0x%08xU", $_) } splice(@$lookup, 0, 6)); $table .= ",\n "; } $table =~ s/,\n \Z//; my $gen_comment = <<"EOF"; /* This file was generated with $FindBin::Script. Do not edit. */ EOF open(my $fc, '>', $file_c) or die "open(> $file_c): $!"; print $fc <<"EOF"; $gen_comment #include "$file_h" const unsigned int crc32lookup[256] = { $table }; EOF close($fc) or die "close($file_c): $!"; my $guard = uc $file_h; $guard =~ s/[^[:alnum:]_]/_/g; open(my $fh, '>', $file_h) or die "open(> $file_h): $!"; print $fh <<"EOF"; $gen_comment #ifndef $guard #define $guard 1 #include extern const unsigned int crc32lookup[]; #define compute_crc32(s, l) \\ compute_crc32_add(@{[ sprintf("0x%08xU", $init) ]}, (s), (l)) static inline unsigned int compute_crc32_add(unsigned int crc32, const char *s, size_t len) { const char *end = s + len; crc32 = ~crc32; while (s < end) { unsigned int index = (crc32 ^ (unsigned char) *s) & 0x000000ffU; crc32 = (crc32 >> 8) ^ crc32lookup[index]; ++s; } return (~crc32); } #endif /* ! $guard */ EOF close($fh) or die "close($file_h): $!"; Cache-Memcached-Fast-0.21/src/connect.c0000644000175000017500000000555512127763070017151 0ustar tomashtomash/* Copyright (C) 2007-2009 Tomash Brechko. All rights reserved. When used to build Perl module: 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.8 or, at your option, any later version of Perl 5 you may have available. When used as a standalone library: This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. */ #include "connect.h" #include #ifndef WIN32 #include "socket_posix.h" #include #else /* WIN32 */ #include "socket_win32.h" #endif /* WIN32 */ int client_connect_inet(const char *host, const char *port, int timeout) { struct addrinfo hint, *addr, *a; int fd = -1, res; memset(&hint, 0, sizeof(hint)); hint.ai_family = AF_UNSPEC; hint.ai_socktype = SOCK_STREAM; #ifdef AI_ADDRCONFIG /* NetBSD 3.1 doesn't have this. */ hint.ai_flags = AI_ADDRCONFIG; #endif /* AI_ADDRCONFIG */ res = getaddrinfo(host, port, &hint, &addr); if (res != 0) { #if 0 if (res != EAI_SYSTEM) GAI error else system error #endif return -1; } for (a = addr; a != NULL; a = a->ai_next) { struct pollfd pollfd; int socket_error; socklen_t socket_error_len; fd = socket(a->ai_family, a->ai_socktype, a->ai_protocol); if (fd == -1) break; if (! can_poll_fd(fd)) { close(fd); fd = -1; break; } res = set_nonblock(fd); if (res != 0) { close(fd); fd = -1; continue; } do res = connect(fd, a->ai_addr, a->ai_addrlen); while (res == -1 && errno == EINTR); if (res == -1 && errno != EINPROGRESS) { close(fd); fd = -1; continue; } pollfd.fd = fd; pollfd.events = POLLOUT; do res = poll(&pollfd, 1, timeout); while (res == -1 && errno == EINTR); if (res <= 0) { close(fd); fd = -1; continue; } socket_error_len = sizeof(socket_error); res = getsockopt(fd, SOL_SOCKET, SO_ERROR, (void *) &socket_error, &socket_error_len); if (res == 0 && socket_error == 0) break; close(fd); fd = -1; } freeaddrinfo(addr); return fd; } int client_connect_unix(const char *path, size_t path_len) { return connect_unix(path, path_len); } Cache-Memcached-Fast-0.21/src/genparser.pl0000755000175000017500000000732312127763070017675 0ustar tomashtomash#! /usr/bin/perl # # Copyright (C) 2007 Tomash Brechko. All rights reserved. # # This program is free software; you can redistribute it and/or modify # it under the same terms as Perl itself, either Perl version 5.8.8 # or, at your option, any later version of Perl 5 you may have # available. # use warnings; use strict; use FindBin; @ARGV == 3 or die "Usage: $FindBin::Script KEYWORD_FILE FILE_C FILE_H\n"; my ($keyword_file, $file_c, $file_h) = @ARGV; my %C; my @keywords; open(my $kw, '<', $keyword_file) or die "open(< $keyword_file): $!"; my $section = 0; while (my $line = <$kw>) { chomp $line; if ($line =~ /^\s*(?:#.*)?$/) { next; } elsif ($line =~ /^\s*%%\s*$/) { ++$section; next; } if ($section == 0 and $line =~ /^\s*(\S+)\s*=\s*(\S+)\s*$/) { $C{$1} = $2; } elsif ($section == 1) { push @keywords, $line; } else { die "Can't parse line: $line"; } } close($kw); sub dispatch_keywords { my ($words) = @_; return $words if @$words <= 1; my $len = 0; my $common = 1; while ($common) { ++$len; my $prefix = substr($$words[0], 0, $len); $common = ! grep(!/^$prefix/, @$words); } --$len; my $prefix = substr($$words[0], 0, $len); my %subtree; foreach my $word (@$words) { my $key = substr($word, $len, 1); my $val = substr($word, $len + 1); push @{$subtree{$key}}, $val; } foreach my $val (values %subtree) { $val = dispatch_keywords($val); } return [$prefix, \%subtree]; } my $tree = dispatch_keywords(\@keywords); my @external_enum = qw(NO_MATCH); sub create_switch { my ($depth, $prefix, $common, $hash) = @_; my $I = ' ' x ($depth * 4); my @keys = sort keys %$hash; (my $common_ident = $common) =~ s/[^A-Z_]//g; my $phase = $prefix . $common_ident; my $res = ''; if ($common) { if ($C{loose_match}) { $res .= <<"EOF"; $I *pos += @{[ length $common ]}; EOF } else { $res .= <<"EOF"; $I match_pos = "$common"; $I do $I { $I if (**pos != *match_pos) $I return NO_MATCH; $I ++*pos; $I ++match_pos; $I } $I while (*match_pos != '\\0'); EOF } } if ($common or $depth) { if (! @keys) { push @external_enum, $phase; $res .= <<"EOF"; $I return $phase; EOF return $res; } } $res .= <<"EOF"; $I switch (*(*pos)++) $I { EOF foreach my $key (@keys) { my $subphase = $phase . $key; $res .= <<"EOF"; $I case '$key': EOF $res .= create_switch($depth + 1, $subphase, @{$$hash{$key}}); } $res .= <<"EOF"; $I default: $I return NO_MATCH; $I } EOF return $res; } my $switch = create_switch(0, 'MATCH_', @$tree); my $gen_comment = <<"EOF"; /* This file was generated with $FindBin::Script from $keyword_file. Instead of editing this file edit the keyword file and regenerate. */ EOF open(my $fc, '>', $file_c) or die "open(> $file_c): $!"; my $i = 0; print $fc <<"EOF"; $gen_comment #include "$file_h" enum $C{parser_func}_e $C{parser_func}(char **pos) { EOF unless ($C{loose_match}) { print $fc <<"EOF"; char *match_pos; EOF } print $fc <<"EOF"; $switch /* Never reach here. */ } EOF close($fc) or die "close($file_c): $!"; my $guard = uc $file_h; $guard =~ s/[^[:alnum:]_]/_/g; open(my $fh, '>', $file_h) or die "open(> $file_h): $!"; print $fh <<"EOF"; $gen_comment #ifndef $guard #define $guard 1 enum $C{parser_func}_e { @{[ join ",\n ", @external_enum ]} }; extern enum $C{parser_func}_e $C{parser_func}(char **pos); #endif /* ! $guard */ EOF close($fh) or die "close($file_h): $!"; Cache-Memcached-Fast-0.21/src/client.h0000644000175000017500000001074612127763070017001 0ustar tomashtomash/* Copyright (C) 2007-2008 Tomash Brechko. All rights reserved. When used to build Perl module: 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.8 or, at your option, any later version of Perl 5 you may have available. When used as a standalone library: This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. */ #ifndef CLIENT_H #define CLIENT_H 1 #include struct client; enum server_status { MEMCACHED_SUCCESS, MEMCACHED_FAILURE, MEMCACHED_EAGAIN, MEMCACHED_ERROR, MEMCACHED_UNKNOWN, MEMCACHED_CLOSED }; enum set_cmd_e { CMD_SET, CMD_ADD, CMD_REPLACE, CMD_APPEND, CMD_PREPEND, CMD_CAS }; enum get_cmd_e { CMD_GET, CMD_GETS }; enum arith_cmd_e { CMD_INCR, CMD_DECR }; typedef unsigned int flags_type; #define FMT_FLAGS "%u" typedef int exptime_type; #define FMT_EXPTIME "%d" typedef unsigned int delay_type; #define FMT_DELAY "%u" typedef unsigned long value_size_type; #define FMT_VALUE_SIZE "%lu" typedef unsigned long long cas_type; #define FMT_CAS "%llu" typedef unsigned long long arith_type; #define FMT_ARITH "%llu" typedef void *(*alloc_value_func)(value_size_type value_size, void **opaque); typedef void (*store_value_func)(void *arg, void *opaque, int key_index, void *meta); typedef void (*free_value_func)(void *opaque); struct result_object { alloc_value_func alloc; store_value_func store; free_value_func free; void *arg; }; struct meta_object { flags_type flags; int use_cas; cas_type cas; }; extern struct client * client_init(); extern void client_destroy(struct client *c); extern void client_reinit(struct client *c); /* client_set_ketama_points() should be called before adding any server. */ extern int client_set_ketama_points(struct client *c, int ketama_points); /* client_set_hash_namespace() should be called before setting the namespace. */ extern void client_set_hash_namespace(struct client *c, int enable); extern int client_add_server(struct client *c, const char *host, size_t host_len, const char *port, size_t port_len, double weight, int noreply); extern int client_set_prefix(struct client *c, const char *ns, size_t ns_len); extern const char * client_get_prefix(struct client *c, size_t *ns_len); extern void client_set_connect_timeout(struct client *c, int to); extern void client_set_io_timeout(struct client *c, int to); extern void client_set_max_failures(struct client *c, int f); extern void client_set_failure_timeout(struct client *c, int to); extern void client_set_close_on_error(struct client *c, int enable); extern void client_set_nowait(struct client *c, int enable); extern void client_reset(struct client *c, struct result_object *o, int noreply); extern int client_prepare_set(struct client *c, enum set_cmd_e cmd, int key_index, const char *key, size_t key_len, flags_type flags, exptime_type exptime, const void *value, value_size_type value_size); extern int client_prepare_cas(struct client *c, int key_index, const char *key, size_t key_len, cas_type cas, flags_type flags, exptime_type exptime, const void *value, value_size_type value_size); extern int client_prepare_get(struct client *c, enum get_cmd_e cmd, int key_index, const char *key, size_t key_len); extern int client_prepare_incr(struct client *c, enum arith_cmd_e cmd, int key_index, const char *key, size_t key_len, arith_type arg); extern int client_prepare_delete(struct client *c, int key_index, const char *key, size_t key_len); extern int client_execute(struct client *c); extern int client_flush_all(struct client *c, delay_type delay, struct result_object *o, int noreply); extern int client_nowait_push(struct client *c); extern int client_server_versions(struct client *c, struct result_object *o); #endif /* ! CLIENT_H */ Cache-Memcached-Fast-0.21/src/Makefile.PL0000644000175000017500000000352112127763070017315 0ustar tomashtomashuse 5.006; use strict; use warnings; use ExtUtils::MakeMaker; my $includes = '/usr/include'; my @define; my @c = ('parse_keyword.c', 'compute_crc32.c', <*.c>); my %exclude; if ($^O eq 'MSWin32') { ++$exclude{'socket_posix.c'}; } else { ++$exclude{'socket_win32.c'}; ++$exclude{'addrinfo_hostent.c'}; if (-f "$includes/poll.h") { push @define, '-DHAVE_POLL_H'; ++$exclude{'poll_select.c'}; } elsif (-f "$includes/sys/poll.h") { push @define, '-DHAVE_SYS_POLL_H'; ++$exclude{'poll_select.c'}; } } my @object = grep { not exists $exclude{$_} } @c; map { s/\.c$/\$(OBJ_EXT)/ } @object; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( NAME => 'Cache::Memcached::Fast::libclient', VERSION_FROM => '../lib/Cache/Memcached/Fast.pm', AUTHOR => 'Tomash Brechko ', LIBS => [''], # e.g., '-lm' DEFINE => "@define", # e.g., '-DHAVE_SOMETHING' INC => '-I.', # e.g., '-I. -I/usr/include/other' OBJECT => "@object", # The following line prevents installation of libclient.a. SKIP => [qw(all static static_lib dynamic dynamic_lib)], clean => { FILES => 'compute_crc32.c compute_crc32.h' . ' parse_keyword.c parse_keyword.h' }, ); sub MY::top_targets { ' all :: static pure_all :: static static :: libclient$(LIB_EXT) libclient$(LIB_EXT): $(OBJECT) $(AR) cr libclient$(LIB_EXT) $(OBJECT) $(RANLIB) libclient$(LIB_EXT) parse_keyword.c parse_keyword.h :: genparser.pl reply.kw $(PERL) genparser.pl reply.kw parse_keyword.c parse_keyword.h compute_crc32.c compute_crc32.h :: gencrc32.pl $(PERL) gencrc32.pl compute_crc32.c compute_crc32.h ' } Cache-Memcached-Fast-0.21/t/0000755000175000017500000000000012127763146015022 5ustar tomashtomashCache-Memcached-Fast-0.21/t/key_ref.t0000644000175000017500000000105012127763071016624 0ustar tomashtomashuse warnings; use strict; use Test::More; use FindBin; use lib "$FindBin::Bin"; use Memd; if ($Memd::memd) { plan tests => 5; } else { plan skip_all => 'Not connected'; } my $key = "key_ref"; my $value = "value ref check"; ok($Memd::memd->set($key, $value), 'Store'); my $h = $Memd::memd->get_multi($key); is($h->{$key}, $value, 'Fetch'); my $old_key = $key; substr($key, 3, 4, ""); is($h->{$old_key}, $value, 'Access with the old key'); ok(! exists $h->{$key}, 'Access with modified key'); ok($Memd::memd->delete($old_key), 'Delete'); Cache-Memcached-Fast-0.21/t/02-isa.t0000644000175000017500000000034712127763071016203 0ustar tomashtomashuse warnings; use strict; use Test::More; use FindBin; use lib "$FindBin::Bin"; use Memd; if ($Memd::memd) { plan tests => 1; } else { plan skip_all => 'Not connected'; } isa_ok($Memd::memd, 'Cache::Memcached::Fast'); Cache-Memcached-Fast-0.21/t/01-connect.t0000644000175000017500000000101312127763071017046 0ustar tomashtomashuse warnings; use strict; use Test::More; use FindBin; use lib "$FindBin::Bin"; use Memd; if ($Memd::memd) { diag("Connected to " . scalar @Memd::addr . " memcached servers, lowest version $Memd::version_str"); plan tests => 2; pass('connected'); my $server_versions = $Memd::memd->server_versions; $Memd::memd->disconnect_all; is_deeply($Memd::memd->server_versions, $server_versions, "server_versions still works after disconnect_all"); } else { plan skip_all => $Memd::error; } Cache-Memcached-Fast-0.21/t/big_value.t0000644000175000017500000000436112127763071017145 0ustar tomashtomashuse warnings; use strict; use Test::More; use FindBin; use lib "$FindBin::Bin"; use Memd; if ($Memd::memd) { plan tests => 13; } else { plan skip_all => 'Not connected'; } use constant THRESHOLD => 1024 * 1024 - 1024; my $key = 'big_value'; my $value = 'x' x THRESHOLD; my $small_value = 'x' x (THRESHOLD - 2048); my $big_value = 'x' x (THRESHOLD + 2048); my %smaller_params = %Memd::params; $smaller_params{max_size} = THRESHOLD - 2048; $smaller_params{namespace} .= 'smaller/'; my $smaller_memd = new Cache::Memcached::Fast(\%smaller_params); my %bigger_params = %Memd::params; $bigger_params{max_size} = THRESHOLD + 2048; $bigger_params{namespace} .= 'bigger/'; my $bigger_memd = new Cache::Memcached::Fast(\%bigger_params); $Memd::memd->enable_compress(0); $smaller_memd->enable_compress(0); $bigger_memd->enable_compress(0); ok($Memd::memd->set($key, $value), 'Store value uncompressed'); ok($Memd::memd->get($key) eq $value, 'Fetch'); ok(! $smaller_memd->set($key, $value), 'Values equal to or greater than THRESHOLD should be rejected by module'); ok(! $bigger_memd->set($key, $big_value), 'Values greater than 1MB should be rejected by server'); my @res = $smaller_memd->set_multi(["$key-1", $small_value], ["$key-2", $big_value], ["$key-3", $small_value]); ok($res[0] and not defined $res[1] and $res[2]); ok($smaller_memd->delete_multi("$key-1", "$key-3")); SKIP: { my $warning; { local $SIG{__WARN__} = sub { die $_[0] }; eval { $Memd::memd->enable_compress(1); $smaller_memd->enable_compress(1); $bigger_memd->enable_compress(1); } } if ($@) { if ($@ =~ /^Compression module was not found/) { skip $@, 6; } else { warn "$@\n"; } } ok($smaller_memd->set($key, $value), 'Store compressed value'); ok($bigger_memd->set($key, $big_value), 'Store compressed value'); ok($smaller_memd->get($key) eq $value, 'Fetch and uncompress'); ok($bigger_memd->get($key) eq $big_value, 'Fetch and uncompress'); ok($smaller_memd->delete($key), 'Delete'); ok($bigger_memd->delete($key), 'Delete'); } ok($Memd::memd->delete($key), 'Delete'); Cache-Memcached-Fast-0.21/t/namespace.t0000644000175000017500000000077212127763071017146 0ustar tomashtomashuse warnings; use strict; use Test::More; use FindBin; use lib "$FindBin::Bin"; use Memd; if ($Memd::memd) { plan tests => 2; } else { plan skip_all => 'Not connected'; } $Memd::memd->set('namespace', 1); my $ns = $Memd::memd->namespace(); $Memd::memd->set('namespace', 2); my $new_ns = "$ns*new_ns*"; is($Memd::memd->namespace($new_ns), $ns); $Memd::memd->set('namespace', 3); is($Memd::memd->namespace($ns), $new_ns); $Memd::memd->set('namespace', 4); $Memd::memd->delete('namespace'); Cache-Memcached-Fast-0.21/t/threads.t0000644000175000017500000000130712127763071016637 0ustar tomashtomashuse warnings; use strict; use Test::More; use FindBin; use lib "$FindBin::Bin"; use Memd; if ($^V lt v5.7.2) { plan skip_all => 'Perl >= 5.7.2 is required'; } use Config; unless ($Config{useithreads}) { plan skip_all => 'ithreads are not configured'; } use constant COUNT => 5; if ($Memd::memd) { plan tests => COUNT * 2; } else { plan skip_all => 'Not connected'; } require threads; sub job { my ($num) = @_; $Memd::memd->set($num, $num); } my @threads; for my $num (1..COUNT) { push @threads, threads->new(\&job, $num); } for my $num (1..COUNT) { $threads[$num - 1]->join; my $n = $Memd::memd->get($num); is($n, $num); ok($Memd::memd->delete($num)); } Cache-Memcached-Fast-0.21/t/commands.t0000644000175000017500000001122612127763071017007 0ustar tomashtomashuse warnings; use strict; use Test::More; use FindBin; use lib "$FindBin::Bin"; use Memd; if ($Memd::memd) { plan tests => 68; } else { plan skip_all => 'Not connected'; } # count should be >= 4. use constant count => 100; my $key = 'commands'; my @keys = map { "commands-$_" } (1..count); $Memd::memd->delete($key); ok($Memd::memd->add($key, 'v1', undef), 'Add'); is($Memd::memd->get($key), 'v1', 'Fetch'); ok($Memd::memd->set($key, 'v2', undef), 'Set'); is($Memd::memd->get($key), 'v2', 'Fetch'); ok($Memd::memd->replace($key, 'v3'), 'Replace'); is($Memd::memd->get($key), 'v3', 'Fetch'); ok($Memd::memd->replace($key, 0), 'replace with numeric'); ok($Memd::memd->incr($key), 'Incr'); ok($Memd::memd->get($key) == 1, 'Fetch'); ok($Memd::memd->incr($key, 5), 'Incr'); ok((not $Memd::memd->incr('no-such-key', 5)), 'Incr no_such_key'); ok((defined $Memd::memd->incr('no-such-key', 5)), 'Incr no_such_key returns defined value'); ok($Memd::memd->get($key) == 6, 'Fetch'); ok($Memd::memd->decr($key), 'Decr'); ok($Memd::memd->get($key) == 5, 'Fetch'); ok($Memd::memd->decr($key, 2), 'Decr'); ok($Memd::memd->get($key) == 3, 'Fetch'); ok($Memd::memd->decr($key, 100) == 0, 'Decr below zero'); ok($Memd::memd->decr($key, 100), 'Decr below zero returns true value'); ok($Memd::memd->get($key) == 0, 'Fetch'); ok($Memd::memd->get_multi(), 'get_multi() with empty list'); my $res = $Memd::memd->set_multi(); isa_ok($res, 'HASH'); is(scalar keys %$res, 0); my @res = $Memd::memd->set_multi(); is(@res, 0); @res = $Memd::memd->set_multi(map { [$_, $_] } @keys); is(@res, count); is((grep { not $_ } @res), 0); $res = $Memd::memd->set_multi(map { [$_, $_] } @keys); isa_ok($res, 'HASH'); is(keys %$res, count); is((grep { not $_ } values %$res), 0); my @extra_keys = @keys; for (1..count) { splice(@extra_keys, int(rand(@extra_keys + 1)), 0, "no_such_key-$_"); } $res = $Memd::memd->get_multi(@extra_keys); isa_ok($res, 'HASH'); is(scalar keys %$res, scalar @keys, 'Number of entries in result'); my $count = 0; foreach my $k (@keys) { ++$count if exists $res->{$k} and $res->{$k} eq $k; } is($count, count); SKIP: { skip "memcached 1.2.4 is required for cas/gets/append/prepend commands", 27 if $Memd::version_num < 10204; ok($Memd::memd->set($key, 'value'), 'Store'); ok($Memd::memd->append($key, '-append'), 'Append'); is($Memd::memd->get($key), 'value-append', 'Fetch'); ok($Memd::memd->prepend($key, 'prepend-'), 'Prepend'); is($Memd::memd->get($key), 'prepend-value-append', 'Fetch'); $res = $Memd::memd->gets($key); ok($res, 'Gets'); isa_ok($res, 'ARRAY'); is(scalar @$res, 2, 'Gets result is an array of two elements'); ok($res->[0], 'CAS opaque defined'); is($res->[1], 'prepend-value-append', 'Match value'); $res->[1] = 'new value'; ok($Memd::memd->cas($key, @$res), 'First update success'); ok(! $Memd::memd->cas($key, @$res), 'Second update failure'); is($Memd::memd->get($key), 'new value', 'Fetch'); $res = $Memd::memd->gets_multi(@extra_keys); isa_ok($res, 'HASH'); is(scalar keys %$res, scalar @keys, 'Number of entries in result'); $count = 0; foreach my $k (@keys) { ++$count if ref($res->{$k}) eq 'ARRAY'; ++$count if @{$res->{$k}} == 2; ++$count if defined $res->{$k}->[0]; ++$count if $res->{$k}->[1] eq $k; } is($count, count * 4); my $hash = $res; $res = $Memd::memd->cas_multi([$keys[0], @{$hash->{$keys[0]}}], ['no-such-key', 123, 'value', 10], [$keys[1], @{$hash->{$keys[1]}}, 1000]); isa_ok($res, 'HASH'); is(scalar keys %$res, 3); ok($res->{$keys[0]}); ok(defined $res->{'no-such-key'} and not $res->{'no-such-key'}); ok($res->{$keys[1]}); my @res = $Memd::memd->cas_multi([$keys[2], @{$hash->{$keys[2]}}], ['no-such-key', 123, 'value', 10], [$keys[3], @{$hash->{$keys[3]}}, 1000]); is(@res, 3); ok($res[0]); ok(not $res[1]); ok($res[2]); $res = $Memd::memd->cas_multi(); isa_ok($res, 'HASH'); is(scalar keys %$res, 0); } ok($Memd::memd->replace_multi(map { [$_,0] } @keys),'replace_multi to reset to numeric'); $res = $Memd::memd->incr_multi([$keys[0], 2], [$keys[1]], @keys[2..$#keys]); ok(values %$res == @keys); is((grep { $_ != 1 } values %$res), 1); is($res->{$keys[0]}, 2); $res = $Memd::memd->delete_multi($key); ok($res->{$key}); $res = $Memd::memd->delete_multi([$keys[0]], $keys[1]); ok($res->{$keys[0]} and $res->{$keys[1]}); ok($Memd::memd->remove($keys[2])); @res = $Memd::memd->delete_multi(@keys); is(@res, count); is((grep { not $_ } @res), 3); Cache-Memcached-Fast-0.21/t/pod.t0000644000175000017500000000033512127763070015766 0ustar tomashtomashuse strict; use warnings; use Test::More; # Ensure a recent version of Test::Pod my $min_tp = 1.22; eval "use Test::Pod $min_tp"; plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; all_pod_files_ok(); Cache-Memcached-Fast-0.21/t/00-load.t0000644000175000017500000000030012127763071016331 0ustar tomashtomashuse warnings; use strict; use Test::More tests => 1; BEGIN { use_ok( 'Cache::Memcached::Fast' ); } diag( "Testing Cache::Memcached::Fast $Cache::Memcached::Fast::VERSION, Perl $], $^X" ); Cache-Memcached-Fast-0.21/t/pod-coverage.t0000644000175000017500000000104712127763071017561 0ustar tomashtomashuse strict; use warnings; use Test::More; # Ensure a recent version of Test::Pod::Coverage my $min_tpc = 1.08; eval "use Test::Pod::Coverage $min_tpc"; plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" if $@; # Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, # but older versions don't recognize some common documentation styles my $min_pc = 0.18; eval "use Pod::Coverage $min_pc"; plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@; all_pod_coverage_ok(); Cache-Memcached-Fast-0.21/t/serialize.t0000644000175000017500000000205712127763071017177 0ustar tomashtomashuse warnings; use strict; use Test::More; use FindBin; use lib "$FindBin::Bin"; use Memd; if ($Memd::memd) { plan tests => 12; } else { plan skip_all => 'Not connected'; } my %hash = ( a => 'a', b => 2, c => [ 'a', 1 ], d => { a => 1, b => [] } ); is_deeply(\%hash, \%hash, 'Check that is_deeply works'); my $key = 'serialize'; ok($Memd::memd->set($key, \%hash), 'Serialize and store'); my $res = $Memd::memd->get($key); ok($res, 'Fetch'); is_deeply($res, \%hash, 'De-serialization'); $res = $Memd::memd->get_multi($key); isa_ok($res, 'HASH'); ok(exists $res->{$key}, 'Fetch'); is_deeply($res->{$key}, \%hash, 'De-serialization'); SKIP: { skip "memcached 1.2.4 is required for prepend command", 4 if $Memd::version_num < 10204; ok($Memd::memd->prepend($key, 'garbage'), 'Prepend garbage'); $res = $Memd::memd->get($key); ok(! $res, 'Check that fetch fails'); $res = $Memd::memd->get_multi($key); isa_ok($res, 'HASH'); ok(! exists $res->{$key}, 'Check that fetch fails'); } ok($Memd::memd->delete($key), 'Delete'); Cache-Memcached-Fast-0.21/t/Memd.pm0000644000175000017500000000437612127763071016251 0ustar tomashtomashpackage Memd; use warnings; use strict; use Cache::Memcached::Fast; use Storable; #use IO::Compress::Gzip; #use IO::Uncompress::Gunzip; our (@addr, %params, $memd, $version_str, $version_num, $error); BEGIN { # Use differently spelled host addresses to enable Ketama to hash # names differently. Note that not all hosts resolve 127.x.y.z # other than 127.0.0.1. @addr = ( { address => 'localhost:11211', weight => 1.5 }, '127.0.0.1:11211', # { address => '127.0.0.2:11211' }, # [ '127.0.0.3:11211', 2 ] ); %params = ( servers => [ @addr ], namespace => "Cache::Memcached::Fast/$$/", connect_timeout => 5, io_timeout => 5, close_on_error => 0, compress_threshold => 1000, # compress_methods => [ \&IO::Compress::Gzip::gzip, # \&IO::Uncompress::Gunzip::gunzip ], max_failures => 3, failure_timeout => 2, ketama_points => 150, nowait => 1, serialize_methods => [ \&Storable::freeze, \&Storable::thaw ], utf8 => ($^V ge v5.8.1 ? 1 : 0), ); $memd = Cache::Memcached::Fast->new(\%params); # Test what server version we have. server_versions() is # currently undocumented. We know that all servers are the same, # so test only the first version. my $version = $memd->server_versions; if (keys %$version == @addr) { $version_num = 2 ** 31; while (my ($s, $v) = each %$version) { if ($v =~ /(\d+)\.(\d+)\.(\d+)/) { my $n = $1 * 10000 + $2 * 100 + $3; if ($n < $version_num) { $version_str = $v; $version_num = $n; } } else { $error = "Can't parse version of $s: $v"; undef $memd; last; } } } else { my @servers = map { if (ref($_) eq 'HASH') { $_->{address}; } elsif (ref($_) eq 'ARRAY') { $_->[0]; } else { $_; } } @addr; $error = "No server is running at " . join(', ', grep { not exists $version->{$_} } @servers); undef $memd; } } 1; Cache-Memcached-Fast-0.21/t/magic.t0000644000175000017500000000272612127763071016273 0ustar tomashtomashuse warnings; use strict; use Test::More; use FindBin; use lib "$FindBin::Bin"; use Memd; if ($Memd::memd) { plan tests => 9; } else { plan skip_all => 'Not connected'; } use Tie::Scalar; use Tie::Array; use Tie::Hash; tie my $scalar, 'Tie::StdScalar'; tie my @array, 'Tie::StdArray'; tie my %hash, 'Tie::StdHash'; %hash = %Memd::params; @array = @{$hash{servers}}; $hash{servers} = \@array; my $memd = new Cache::Memcached::Fast(\%hash); use utf8; my $key = "Кириллица.в.UTF-8"; $scalar = $key; ok($memd->set($scalar, $scalar)); ok(exists $memd->get_multi($scalar)->{$scalar}); is($memd->get($scalar), $key); is($memd->get($key), $scalar); package MyScalar; use base 'Tie::StdScalar'; sub FETCH { "Другой.ключ" } package main; tie my $scalar2, 'MyScalar'; ok($memd->set($scalar2, $scalar2)); ok(exists $memd->get_multi($scalar2)->{$scalar2}); SKIP: { eval { require Readonly }; skip "Skipping Readonly tests because the module is not present", 3 if $@; # 'require Readonly' as above can be used to test if the module is # present, but won't actually work. So below we 'use Readonly', # but in a string eval. eval q{ use Readonly; Readonly my $expires => 3; Readonly my $key2 => "Третий.ключ"; ok($memd->set($key2, $key2, $expires)); ok(exists $memd->get_multi($key2)->{$key2}); sleep(4); ok(! exists $memd->get_multi($key2)->{$key2}); }; } Cache-Memcached-Fast-0.21/t/utf8.t0000644000175000017500000000072012127763071016071 0ustar tomashtomashuse warnings; use strict; use Test::More; use FindBin; use lib "$FindBin::Bin"; use Memd; if ($Memd::memd) { if ($Memd::params{utf8}) { plan tests => 1; } else { plan skip_all => "'utf8' is disabled"; } } else { plan skip_all => 'Not connected'; } use utf8; my $value = "Кириллица в UTF-8"; $Memd::memd->set('utf8', $value); my $value2 = $Memd::memd->get('utf8'); is($value2, $value); $Memd::memd->delete('utf8'); Cache-Memcached-Fast-0.21/t/noreply.t0000644000175000017500000000160412127763070016674 0ustar tomashtomashuse warnings; use strict; use Test::More; use FindBin; use lib "$FindBin::Bin"; use Memd; if ($Memd::memd) { if ($Memd::version_num >= 10205) { plan tests => 3; } else { plan skip_all => 'memcached 1.2.5 is required for noreply mode'; } } else { plan skip_all => 'Not connected'; } use constant count => 100; my %params = %Memd::params; foreach my $h (@{$params{servers}}) { $h->{noreply} = 1 if ref($h) eq 'HASH'; } my $another_memd = new Cache::Memcached::Fast(\%params); my @keys = map { "noreply-$_" } (1..count); $another_memd->set_multi(map { [$_, $_] } @keys); my $res = $another_memd->get_multi(@keys); isa_ok($res, 'HASH'); is(scalar keys %$res, scalar @keys, 'Number of entries in result'); my $count = 0; foreach my $k (@keys) { ++$count if exists $res->{$k} and $res->{$k} eq $k; } is($count, count); $another_memd->delete_multi(@keys); Cache-Memcached-Fast-0.21/t/nowait.t0000644000175000017500000000174012127763071016507 0ustar tomashtomashuse warnings; use strict; use Test::More; use FindBin; use lib "$FindBin::Bin"; use Memd; if ($Memd::memd) { plan tests => 5; } else { plan skip_all => 'Not connected'; } use constant count => 1000; my $another_memd = new Cache::Memcached::Fast(\%Memd::params); my @keys = map { "nowait-$_" } (1..count); foreach my $k (@keys) { $Memd::memd->set($k, $k); } $Memd::memd->replace('no-such-key', 1); $Memd::memd->replace('no-such-key', 1); my @extra_keys = @keys; for (1..count) { splice(@extra_keys, int(rand(@extra_keys + 1)), 0, "no_such_key-$_"); } my $res = $Memd::memd->get_multi(@extra_keys); isa_ok($res, 'HASH'); is(scalar keys %$res, count, 'Fetched all keys'); my $count = 0; while (my ($k, $v) = each %$res) { ++$count if $k eq $v; } is($count, count, 'Match results'); is($another_memd->get($keys[$#keys]), $keys[$#keys]); foreach my $k (@keys) { $Memd::memd->delete($k); } $Memd::memd->nowait_push; ok(not $another_memd->get($keys[$#keys]));