Feersum-1.410/000755 000765 000024 00000000000 13762625540 013757 5ustar00audreytstaff000000 000000 Feersum-1.410/bin/000755 000765 000024 00000000000 13762625540 014527 5ustar00audreytstaff000000 000000 Feersum-1.410/picohttpparser-git/000755 000765 000024 00000000000 13762625540 017607 5ustar00audreytstaff000000 000000 Feersum-1.410/Changes000644 000765 000024 00000013576 13762624756 015276 0ustar00audreytstaff000000 000000 Revision history for Perl extension Feersum 1.410 Sat Dec 5 14:32:22 2020 +0800 Features - Add unix domain socket support (vividsnow++) # for example: plackup -E production -l /tmp/app.sock -s Feersum --pre-fork N app.psgi feersum --native --listen /tmp/app.sock --pre-fork N ./app.feersum 1.407 Sun Jun 9 16:17:30 2019 +0800 Bugfixes - Fix interim test failures (snakpak++) 1.406 Fri Sep 21 08:15:32 2018 -0400 Bugfixes - Fix tests by depending on HTTP::Entity::Parser 0.20+ (ltriant++) 1.405 Sun Jun 18 00:55:56 2017 +0800 Features - Handle server_ready option in plack handler (haarg++) Bugfixes - Handle POST with empty content (hoytech++) 1.404 Tue Nov 1 22:52:42 2016 +0800 Features - Unix socket support (hoytech++) 1.403 Wed Aug 12 19:19:57 2015 +0800 Features - Add OPTIONS method support (mgreter++) 1.402 Fri Jul 31 12:02:30 2015 +0800 Bugfixes - memeory leak if request method is POST (fangyousong++) 1.401 Wed Nov 6 21:53:25 2013 +0800 Bugfixes - Fix tests for newer Plack::Test (@gfx++) - Suppress compilation warnings under clang. (@gfx++) 1.400 Wed Sep 7 20:00:00 2011 -0700 Features - Add flash socket policy support (au++) Bugfixes - mortal scalar leak (thanks bfg) - 400s on incremental request parsing (GH#12 thanks danmcc) Docs - policy support and other tunables - add some missed API - mark the --pre-fork option as Experimental Tests - a bunch of author tests - reduce the amount of parallelism in tests (makes them faster) 1.202 Thu Jun 30 00:45:00 2011 -0700 Fix double-plan test failures when Test::LeakTrace missing (au++) 1.201 Wed Jun 29 11:00:00 2011 -0700 Fix sockaddr memory leak (thanks bfg) 1.200 Fri Apr 15 12:00:00 2011 -0700 Fix major defect: corrupted large static files (thanks leedo) 1.101 Wed Apr 13 12:00:00 2011 -0700 Fix 62-plack-runner.t again (thanks cpantesters) 1.100 Mon Apr 11 12:40:00 2011 -0700 Fix major defect: truncated writes (fbb3664) Finish Solaris compatibility (thanks konobi) Fix t/11-runner.t failing when JSON::XS missing 1.002 Sat Apr 9 16:15:00 2011 -0700 Try to fix persistent failing of 62-plack-runner.t Update picohttpparser from upstream Fix printf warnings on Lucid 1.001 Mon Jan 31 10:00:00 2011 -0800 Address RT#65239 by making Plack a true dep. if present. Test::TCP is now a hard build dependency. Use Test::Fatal instead of Test::Exception. 1.000 Mon Nov 22 12:00:00 2010 -0800 Socialtext now runs Feersum in production, hence 1.000 Add write_array() to Writer handle (undoc'd Feersum extension) Be explicit about the EU::MM requirement (thanks au) Formally support PSGI 1.1 (thanks miyagawa) 0.986 Mon Oct 26 09:16:00 2010 -0700 Fix compilation for EV 4.00 (thanks au) 0.985 Mon Oct 25 16:18:00 2010 -0700 Require EV 4.00. Make two example scripts emit a constant Content-Length for ab. Code reworking and optimization. 0.984 Fri Oct 15 10:45:00 2010 -0700 Fix a misspelling of SvREFCNT_dec 0.983 Thu Oct 14 17:45:00 2010 -0700 Add a response_guard() method and psgix.output.guard 0.982 Tue Oct 12 10:55:00 2010 -0700 Initial pre-forking support via Feersum::Runner & Plack::Runner Fix: resource leak induced by header-read errors Fix: compilation on BSD & Solaris re: SOL_TCP 0.981 Wed Oct 9 04:30:00 2010 -0700 Support Web::Hippie (and psgix.io) Add missing JSON::XS test-dep. Fix: write() prototype was incorrect. Fix: writer not flushing on DESTROY. Fix: IO::Handle in PSGI streaming response. Fix: `use overload` PSGI callbacks in perl 5.8.x 0.971 Wed Oct 6 16:21:00 2010 -0700 Fix the feersum script. 0.97 Wed Oct 6 15:00:00 2010 -0700 Full Plack::Test::Suite compliance! Handle 304 responses properly. Don't manually steal TEMP vars. 0.961 Wed Oct 6 08:40:00 2010 -0700 Fix building under threaded perls. Work around a bug (?) in 5.12.1 when declaring -DDEBUGGING. 0.96 Fri Oct 1 15:30:00 2010 -0700 Support Tatsumaki running under Feersum. Content-Type is now in the CONTENT_TYPE env. 0.95 Fri Oct 1 13:45:00 2010 -0700 Specify Plack >= 0.995 version for testing & recommending Experiment with close() rather than shutdown() for ending connections. Actually install bin/feersum as a script Fix coredumps/hangs due to improper refcounting. Fix examples, Add a chat app example. 0.94 Thu Sep 30 22:45:00 2010 -0700 Major documentation rewrite. Deprecated the "delayed response" part of the Feersum API in favor of the "streamed response" API. Allow for tied variables in the response. Move the IO::Handle response reading code into XS. 0.93 Tue Sep 29 01:30:00 2010 -0700 First CPAN release. Redo PSGI streaming responses (mostly for code clarity). Fixes for Perl 5.8.x 0.92 Tue Sep 28 22:18:01 2010 -0700 Support "Connection:close" style streaming for 1.0 clients. Support IO::Handle-like responses for PSGI handlers. Add REMOTE_ADDR and REMOTE_PORT to env. 0.91 Sun Sep 19 15:33:39 2010 -0700 Support running Feersum under plackup. Remove AnyEvent::HTTP dependency. Make $r->env() calls faster. 0.90 Mon Sep 6 16:35:00 2010 Initial PSGI 1.03 support (except for IO::Handle-like responses) 0.02 Fri Apr 23 10:55:54 2010 Renamed a good chunk of the functions & classes. Made psgi.input and stream-writer objects separate from the main connection class. 0.01 Fri Apr 23 10:55:54 2010 Started project. Feersum-1.410/MANIFEST000644 000765 000024 00000002245 13762624365 015117 0ustar00audreytstaff000000 000000 Changes Feersum.xs MANIFEST MANIFEST.SKIP Makefile.PL README TODO bin/feersum eg/app.feersum eg/app.psgi eg/hello.pl eg/oneshot.pl eg/chat.feersum lib/Feersum.pm lib/Feersum/Connection.pm lib/Feersum/Connection/Handle.pm lib/Feersum/Runner.pm lib/Plack/Handler/Feersum.pm picohttpparser-git/bench.c picohttpparser-git/picohttpparser.c picohttpparser-git/picohttpparser.h picohttpparser-git/test.c picohttpparser-git/test_response.c ppport.h rinq.c t/01-simple.t t/02-array-body.t t/03-env-hash.t t/04-died.t t/05-streaming.t t/06-input.t t/07-graceful-shutdown.t t/08-read-timeout.t t/09-magic.t t/10-respond-304.t t/11-runner.t t/12-close-on-drop.t t/13-pre-fork.t t/14-guard.t t/15-write_array.t t/50-psgi-simple.t t/51-psgi-streaming.t t/52-psgi-iohandle.t t/53-psgi-overloaded.t t/54-psgix-io.t t/55-psgi-leak.t t/60-plack.t t/61-plack-suite.t t/62-plack-runner.t t/63-plack-apps.t t/99-critic.t t/99-fixme.t t/99-manifest.t t/99-pod-coverage.t t/99-pod.t t/Utils.pm typemap xt/50-psgi-simple-stress.t t/perlcriticrc META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Feersum-1.410/ppport.h000644 000765 000024 00000525406 13762624365 015474 0ustar00audreytstaff000000 000000 #if 0 <<'SKIP'; #endif /* ---------------------------------------------------------------------- ppport.h -- Perl/Pollution/Portability Version 3.19 Automatically created by Devel::PPPort running under perl 5.012000. 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.19 =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_parser NEED_PL_parser NEED_PL_parser_GLOBAL 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_sprintf() NEED_my_sprintf NEED_my_sprintf_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 newSV_type() NEED_newSV_type NEED_newSV_type_GLOBAL newSVpvn_flags() NEED_newSVpvn_flags NEED_newSVpvn_flags_GLOBAL newSVpvn_share() NEED_newSVpvn_share NEED_newSVpvn_share_GLOBAL pv_display() NEED_pv_display NEED_pv_display_GLOBAL pv_escape() NEED_pv_escape NEED_pv_escape_GLOBAL pv_pretty() NEED_pv_pretty NEED_pv_pretty_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-2009, 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.19; 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 CPERLscope|5.005000||p 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_set|5.011000||p 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_METHOD|5.006001||p G_NOARGS||| G_SCALAR||| G_VOID||5.004000| GetVars||| GvSVn|5.009003||p 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| HeUTF8||5.011000| HeVAL||5.004000| HvNAMELEN_get|5.009003||p HvNAME_get|5.009003||p 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.011000| 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_DUP||| PAD_RESTORE_LOCAL||| PAD_SAVE_LOCAL||| PAD_SAVE_SETNULLPAD||| PAD_SETSV||| PAD_SET_CUR_NOSAVE||| PAD_SET_CUR||| PAD_SVl||| PAD_SV||| PERLIO_FUNCS_CAST|5.009003||p PERLIO_FUNCS_DECL|5.009003||p PERL_ABS|5.008001||p PERL_BCDVERSION|5.011000||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.011000||p PERL_MAGIC_isaelem|5.007002||p PERL_MAGIC_isa|5.007002||p PERL_MAGIC_mutex|5.011000||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_PV_ESCAPE_ALL|5.009004||p PERL_PV_ESCAPE_FIRSTCHAR|5.009004||p PERL_PV_ESCAPE_NOBACKSLASH|5.009004||p PERL_PV_ESCAPE_NOCLEAR|5.009004||p PERL_PV_ESCAPE_QUOTE|5.009004||p PERL_PV_ESCAPE_RE|5.009005||p PERL_PV_ESCAPE_UNI_DETECT|5.009004||p PERL_PV_ESCAPE_UNI|5.009004||p PERL_PV_PRETTY_DUMP|5.009004||p PERL_PV_PRETTY_ELLIPSES|5.010000||p PERL_PV_PRETTY_LTGT|5.009004||p PERL_PV_PRETTY_NOCLEAR|5.010000||p PERL_PV_PRETTY_QUOTE|5.009004||p PERL_PV_PRETTY_REGPROP|5.009004||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_SYS_INIT3||5.006000| PERL_SYS_INIT||| PERL_SYS_TERM||5.011000| 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_bufend|5.011000||p PL_bufptr|5.011000||p PL_compiling|5.004050||p PL_copline|5.011000||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_error_count|5.011000||p PL_expect|5.011000||p PL_hexdigit|5.005000||p PL_hints|5.005000||p PL_in_my_stash|5.011000||p PL_in_my|5.011000||p PL_last_in_gv|||n PL_laststatval|5.005000||p PL_lex_state|5.011000||p PL_lex_stuff|5.011000||p PL_linestr|5.011000||p PL_modglobal||5.005000|n PL_na|5.004050||pn PL_no_modify|5.006000||p PL_ofsgv|||n PL_parser|5.009005||p 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 PL_tokenbuf|5.011000||p POP_MULTICALL||5.011000| 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 PTR2nat|5.009003||p PTR2ul|5.007001||p PTRV|5.006000||p PUSHMARK||| PUSH_MULTICALL||5.011000| 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 SVfARG|5.009005||p SVf_UTF8|5.006000||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_offset||5.011000| 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_renew|5.009003||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.011000||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 XSPROTO|5.010000||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.011000||p aTHXR|5.011000||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_fetch||| av_fill||| av_iter_p||5.011000| 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||| 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_each||| ck_eof||| ck_eval||| ck_exec||| ck_exists||| ck_exit||| ck_ftst||| ck_fun||| ck_glob||| ck_grep||| ck_index||| ck_join||| ck_lfun||| ck_listiob||| ck_match||| ck_method||| ck_null||| ck_open||| ck_readline||| ck_repeat||| ck_require||| 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_xs_usage||5.011000| croak|||v csighandler||5.009003|n curmad||| custom_op_desc||5.007003| custom_op_name||5.007003| cv_ckproto_len||| 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.011000||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_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||| doeval||| dofile||| dofindlabel||| doform||| doing_taint||5.008001|n dooneliner||| doopen_pm||| doparseform||| dopoptoeval||| dopoptogiven||| dopoptolabel||| dopoptoloop||| dopoptosub_at||| 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||| eval_pv|5.006000||p eval_sv|5.006000||p exec_failed||| expect_number||| fbm_compile||5.005000| fbm_instr||5.005000| feature_is_enabled||| fetch_cop_label||5.011000| 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_aux_mg||| 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_isa_hash||| 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_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_flags||5.011000| gv_fetchmethod||| gv_fetchmeth||| gv_fetchpvn_flags|5.009002||p gv_fetchpvs|5.009004||p gv_fetchpv||| gv_fetchsv||5.009002| gv_fullname3||5.004000| gv_fullname4||5.006001| gv_fullname||| gv_get_super_pkg||| gv_handler||5.007001| gv_init_sv||| gv_init||| gv_name_set||5.009004| gv_stashpvn|5.004000||p gv_stashpvs|5.009003||p gv_stashpv||| gv_stashsv||| he_dup||| hek_dup||| hfreeentries||| hsplit||| hv_assert||5.011000| hv_auxinit|||n hv_backreferences_p||| hv_clear_placeholders||5.009001| hv_clear||| hv_common_key_len||5.010000| hv_common||5.010000| 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_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||| 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||| incline||| incpush_if_exists||| incpush_use_sep||| 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||| isALNUMC|5.006000||p isALNUM||| isALPHA||| isASCII|5.006000||p isBLANK|5.006001||p isCNTRL|5.006000||p isDIGIT||| isGRAPH|5.006000||p isGV_with_GP|5.009004||p isLOWER||| isPRINT|5.004000||p isPSXSPC|5.006001||p isPUNCT|5.006000||p isSPACE||| isUPPER||| isXDIGIT|5.006000||p is_an_int||| is_gv_magical_sv||| 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 mPUSHs|5.011000||p mPUSHu|5.009002||p mXPUSHi|5.009002||p mXPUSHn|5.009002||p mXPUSHp|5.009002||p mXPUSHs|5.011000||p mXPUSHu|5.009002||p mad_free||| madlex||| madparse||| magic_clear_all_env||| magic_clearenv||| magic_clearhint||| magic_clearisa||| magic_clearpack||| magic_clearsig||| magic_dump||5.006000| magic_existspack||| magic_freearylen_p||| magic_freeovrld||| 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_setcollxfrm||| magic_setdbline||| magic_setdefelem||| magic_setenv||| 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||| make_matcher||| make_trie_failtable||| make_trie||| malloc_good_size|||n malloced_size|||n malloc||5.007002|n markstack_grow||| matcher_matches_sv||| measure_struct||| memEQ|5.004000||p memNE|5.004000||p mem_collxfrm||| mem_log_common|||n 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_from_name||5.011000| mro_get_linear_isa_dfs||| mro_get_linear_isa||5.009005| mro_get_private_data||5.011000| mro_isa_changed_in||| mro_meta_dup||| mro_meta_init||| mro_method_changed_in||5.009005| mro_register||5.011000| mro_set_mro||5.011000| mro_set_private_data||5.011000| 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||pvn 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 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||p newSVhek||5.009003| newSViv||| newSVnv||| newSVpvf_nocontext|||vn newSVpvf||5.004000|v newSVpvn_flags|5.011000||p newSVpvn_share|5.007001||p newSVpvn_utf8|5.011000||p newSVpvn|5.004050||p newSVpvs_flags|5.011000||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||| 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.011000| 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||| pregfree2||5.011000| 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||p pv_escape|5.009004||p pv_pretty|5.009004||p pv_uni_display||5.007003| qerror||| qsortsvu||| re_compile||5.009005| re_croak2||| re_dup_guts||| 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_common||| refcounted_he_new||| refcounted_he_value||| refkids||| refto||| ref||5.011000| 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_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_adelete||5.011000| 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_flags||5.011000| save_helem||5.004050| save_hints||| 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_and_mortalize||5.011000| save_pptr||| save_pushi32ptr||| save_pushptri32ptr||| save_pushptrptr||| save_pushptr||5.011000| 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| search_const||| seed||5.008001| sequence_num||| sequence_tail||| sequence||| set_context||5.006000|n set_numeric_local||5.006000| set_numeric_radix||5.006000| set_numeric_standard||5.006000| setdefout||| 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.011000| stdize_locale||| store_cop_label||| 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_2num||| 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_destroyable||5.010000| sv_does||5.009004| sv_dump||| sv_dup_inc_multiple||| 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_flags||5.011000| sv_insert||| sv_isa||| sv_isobject||| sv_iv||5.005000| sv_kill_backrefs||| sv_len_utf8||5.006000| sv_len||| sv_magic_portable|5.011000|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|5.005000|p sv_pvn||5.005000| 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_grow||5.011000| sv_utf8_upgrade_flags||5.007002| sv_utf8_upgrade_nomg||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_init3||5.010000|n sys_init||5.010000|n sys_intern_clear||| sys_intern_dup||| sys_intern_init||| sys_term||5.010000|n 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 $function; } 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*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { my @deps = map { s/\s+//g; $_ } split /,/, $3; my $d; for $d (map { s/\s+//g; $_ } split /,/, $1) { push @{$depends{$d}}, @deps; } } $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 (eval \$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 */ #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 #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 #endif #ifndef PTR2ul # if PTRSIZE == LONGSIZE # define PTR2ul(p) (unsigned long)(p) # else # define PTR2ul(p) INT2PTR(unsigned long,p) # endif #endif #ifndef PTR2nat # define PTR2nat(p) (PTRV)(p) #endif #ifndef NUM2PTR # define NUM2PTR(any,d) (any)PTR2nat(d) #endif #ifndef PTR2IV # define PTR2IV(p) INT2PTR(IV,p) #endif #ifndef PTR2UV # define PTR2UV(p) INT2PTR(UV,p) #endif #ifndef PTR2NV # define PTR2NV(p) NUM2PTR(NV,p) #endif #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 #ifndef DEFSV_set # define DEFSV_set(sv) (DEFSV = (sv)) #endif /* Older perls (<=5.003) lack AvFILLp */ #ifndef AvFILLp # define AvFILLp AvFILL #endif #ifndef ERRSV # define ERRSV get_sv("@",FALSE) #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 XSPROTO # define XSPROTO(name) void name(pTHX_ CV* cv) #endif #ifndef SVfARG # define SVfARG(p) ((void*)(p)) #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 CPERLscope # define CPERLscope(x) x #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 PERLIO_FUNCS_DECL # ifdef PERLIO_FUNCS_CONST # define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs # define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs) # else # define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs # define PERLIO_FUNCS_CAST(funcs) (funcs) # endif #endif /* provide these typedefs for older perls */ #if (PERL_BCDVERSION < 0x5009003) # ifdef ARGSproto typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto); # else typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX); # endif typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*); #endif #ifndef isPSXSPC # define isPSXSPC(c) (isSPACE(c) || (c) == '\v') #endif #ifndef isBLANK # define isBLANK(c) ((c) == ' ' || (c) == '\t') #endif #ifdef EBCDIC #ifndef isALNUMC # define isALNUMC(c) isalnum(c) #endif #ifndef isASCII # define isASCII(c) isascii(c) #endif #ifndef isCNTRL # define isCNTRL(c) iscntrl(c) #endif #ifndef isGRAPH # define isGRAPH(c) isgraph(c) #endif #ifndef isPRINT # define isPRINT(c) isprint(c) #endif #ifndef isPUNCT # define isPUNCT(c) ispunct(c) #endif #ifndef isXDIGIT # define isXDIGIT(c) isxdigit(c) #endif #else # if (PERL_BCDVERSION < 0x5010000) /* Hint: isPRINT * The implementation in older perl versions includes all of the * isSPACE() characters, which is wrong. The version provided by * Devel::PPPort always overrides a present buggy version. */ # undef isPRINT # endif #ifndef isALNUMC # define isALNUMC(c) (isALPHA(c) || isDIGIT(c)) #endif #ifndef isASCII # define isASCII(c) ((c) <= 127) #endif #ifndef isCNTRL # define isCNTRL(c) ((c) < ' ' || (c) == 127) #endif #ifndef isGRAPH # define isGRAPH(c) (isALNUM(c) || isPUNCT(c)) #endif #ifndef isPRINT # define isPRINT(c) (((c) >= 32 && (c) < 127)) #endif #ifndef isPUNCT # define isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126)) #endif #ifndef isXDIGIT # define isXDIGIT(c) (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F')) #endif #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_bufend bufend # define PL_bufptr bufptr # 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_error_count error_count # define PL_expect expect # define PL_hexdigit hexdigit # define PL_hints hints # define PL_in_my in_my # define PL_laststatval laststatval # define PL_lex_state lex_state # define PL_lex_stuff lex_stuff # define PL_linestr linestr # 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 # define PL_tokenbuf tokenbuf /* Replace: 0 */ #endif /* Warning: PL_parser * For perl versions earlier than 5.9.5, this is an always * non-NULL dummy. Also, it cannot be dereferenced. Don't * use it if you can avoid is and unless you absolutely know * what you're doing. * If you always check that PL_parser is non-NULL, you can * define DPPP_PL_parser_NO_DUMMY to avoid the creation of * a dummy parser structure. */ #if (PERL_BCDVERSION >= 0x5009005) # ifdef DPPP_PL_parser_NO_DUMMY # define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ (croak("panic: PL_parser == NULL in %s:%d", \ __FILE__, __LINE__), (yy_parser *) NULL))->var) # else # ifdef DPPP_PL_parser_NO_DUMMY_WARNING # define D_PPP_parser_dummy_warning(var) # else # define D_PPP_parser_dummy_warning(var) \ warn("warning: dummy PL_" #var " used in %s:%d", __FILE__, __LINE__), # endif # define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ (D_PPP_parser_dummy_warning(var) &DPPP_(dummy_PL_parser)))->var) #if defined(NEED_PL_parser) static yy_parser DPPP_(dummy_PL_parser); #elif defined(NEED_PL_parser_GLOBAL) yy_parser DPPP_(dummy_PL_parser); #else extern yy_parser DPPP_(dummy_PL_parser); #endif # endif /* PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf depends on PL_parser */ /* Warning: PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf * Do not use this variable unless you know exactly what you're * doint. It is internal to the perl parser and may change or even * be removed in the future. As of perl 5.9.5, you have to check * for (PL_parser != NULL) for this variable to have any effect. * An always non-NULL PL_parser dummy is provided for earlier * perl versions. * If PL_parser is NULL when you try to access this variable, a * dummy is being accessed instead and a warning is issued unless * you define DPPP_PL_parser_NO_DUMMY_WARNING. * If DPPP_PL_parser_NO_DUMMY is defined, the code trying to access * this variable will croak with a panic message. */ # define PL_expect D_PPP_my_PL_parser_var(expect) # define PL_copline D_PPP_my_PL_parser_var(copline) # define PL_rsfp D_PPP_my_PL_parser_var(rsfp) # define PL_rsfp_filters D_PPP_my_PL_parser_var(rsfp_filters) # define PL_linestr D_PPP_my_PL_parser_var(linestr) # define PL_bufptr D_PPP_my_PL_parser_var(bufptr) # define PL_bufend D_PPP_my_PL_parser_var(bufend) # define PL_lex_state D_PPP_my_PL_parser_var(lex_state) # define PL_lex_stuff D_PPP_my_PL_parser_var(lex_stuff) # define PL_tokenbuf D_PPP_my_PL_parser_var(tokenbuf) # define PL_in_my D_PPP_my_PL_parser_var(in_my) # define PL_in_my_stash D_PPP_my_PL_parser_var(in_my_stash) # define PL_error_count D_PPP_my_PL_parser_var(error_count) #else /* ensure that PL_parser != NULL and cannot be dereferenced */ # define PL_parser ((void *) 1) #endif #ifndef mPUSHs # define mPUSHs(s) PUSHs(sv_2mortal(s)) #endif #ifndef PUSHmortal # define PUSHmortal PUSHs(sv_newmortal()) #endif #ifndef mPUSHp # define mPUSHp(p,l) sv_setpvn(PUSHmortal, (p), (l)) #endif #ifndef mPUSHn # define mPUSHn(n) sv_setnv(PUSHmortal, (NV)(n)) #endif #ifndef mPUSHi # define mPUSHi(i) sv_setiv(PUSHmortal, (IV)(i)) #endif #ifndef mPUSHu # define mPUSHu(u) sv_setuv(PUSHmortal, (UV)(u)) #endif #ifndef mXPUSHs # define mXPUSHs(s) XPUSHs(sv_2mortal(s)) #endif #ifndef XPUSHmortal # define XPUSHmortal XPUSHs(sv_newmortal()) #endif #ifndef mXPUSHp # define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn(PUSHmortal, (p), (l)); } STMT_END #endif #ifndef mXPUSHn # define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv(PUSHmortal, (NV)(n)); } STMT_END #endif #ifndef mXPUSHi # define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv(PUSHmortal, (IV)(i)); } STMT_END #endif #ifndef mXPUSHu # define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv(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 /* Replace: 0 */ #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 #ifndef G_METHOD # define G_METHOD 64 # ifdef call_sv # undef call_sv # endif # if (PERL_BCDVERSION < 0x5006000) # define call_sv(sv, flags) ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \ (flags) & ~G_METHOD) : perl_call_sv(sv, flags)) # else # define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \ (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags)) # endif #endif /* 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) /* This is just a trick to avoid a dependency of newCONSTSUB on PL_parser */ /* (There's no PL_parser in perl < 5.005, so this is completely safe) */ #define D_PPP_PL_copline PL_copline 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 = D_PPP_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) && (PERL_BCDVERSION != 0x5006000) /* 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 #ifndef newSV_type #if defined(NEED_newSV_type) static SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); static #else extern SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); #endif #ifdef newSV_type # undef newSV_type #endif #define newSV_type(a) DPPP_(my_newSV_type)(aTHX_ a) #define Perl_newSV_type DPPP_(my_newSV_type) #if defined(NEED_newSV_type) || defined(NEED_newSV_type_GLOBAL) SV* DPPP_(my_newSV_type)(pTHX_ svtype const t) { SV* const sv = newSV(0); sv_upgrade(sv, t); return sv; } #endif #endif #if (PERL_BCDVERSION < 0x5006000) # define D_PPP_CONSTPV_ARG(x) ((char *) (x)) #else # define D_PPP_CONSTPV_ARG(x) (x) #endif #ifndef newSVpvn # define newSVpvn(data,len) ((data) \ ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ : newSV(0)) #endif #ifndef newSVpvn_utf8 # define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) #endif #ifndef SVf_UTF8 # define SVf_UTF8 0 #endif #ifndef newSVpvn_flags #if defined(NEED_newSVpvn_flags) static SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); static #else extern SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); #endif #ifdef newSVpvn_flags # undef newSVpvn_flags #endif #define newSVpvn_flags(a,b,c) DPPP_(my_newSVpvn_flags)(aTHX_ a,b,c) #define Perl_newSVpvn_flags DPPP_(my_newSVpvn_flags) #if defined(NEED_newSVpvn_flags) || defined(NEED_newSVpvn_flags_GLOBAL) SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags) { SV *sv = newSVpvn(D_PPP_CONSTPV_ARG(s), len); SvFLAGS(sv) |= (flags & SVf_UTF8); return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv; } #endif #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 #if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) ) # define DPPP_SVPV_NOLEN_LP_ARG &PL_na #else # define DPPP_SVPV_NOLEN_LP_ARG 0 #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, DPPP_SVPV_NOLEN_LP_ARG, 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, DPPP_SVPV_NOLEN_LP_ARG, 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, DPPP_SVPV_NOLEN_LP_ARG, 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, DPPP_SVPV_NOLEN_LP_ARG, 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 SvPV_renew # define SvPV_renew(sv,n) STMT_START { SvLEN_set(sv, n); \ SvPV_set((sv), (char *) saferealloc( \ (Malloc_t)SvPVX(sv), (MEM_SIZE)((n)))); \ } STMT_END #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 HvNAME_get # define HvNAME_get(hv) HvNAME(hv) #endif #ifndef HvNAMELEN_get # define HvNAMELEN_get(hv) (HvNAME_get(hv) ? (I32)strlen(HvNAME_get(hv)) : 0) #endif #ifndef GvSVn # define GvSVn(gv) GvSV(gv) #endif #ifndef isGV_with_GP # define isGV_with_GP(gv) isGV(gv) #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 newSVpvs_flags # define newSVpvs_flags(str, flags) newSVpvn_flags(str "", sizeof(str) - 1, flags) #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 gv_fetchpvn_flags # define gv_fetchpvn_flags(name, len, flags, svt) gv_fetchpv(name, flags, svt) #endif #ifndef gv_fetchpvs # define gv_fetchpvs(name, flags, svt) gv_fetchpvn_flags(name "", sizeof(name) - 1, flags, svt) #endif #ifndef gv_stashpvs # define gv_stashpvs(name, flags) gv_stashpvn(name "", sizeof(name) - 1, flags) #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 < 0 || (len > 0 && (Size_t)retval >= len)) Perl_croak(aTHX_ "panic: my_snprintf buffer overflow"); return retval; } #endif #endif #if !defined(my_sprintf) #if defined(NEED_my_sprintf) static int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); static #else extern int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); #endif #define my_sprintf DPPP_(my_my_sprintf) #define Perl_my_sprintf DPPP_(my_my_sprintf) #if defined(NEED_my_sprintf) || defined(NEED_my_sprintf_GLOBAL) int DPPP_(my_my_sprintf)(char *buffer, const char* pat, ...) { va_list args; va_start(args, pat); vsprintf(buffer, pat, args); va_end(args); return strlen(buffer); } #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 #ifndef PERL_PV_ESCAPE_QUOTE # define PERL_PV_ESCAPE_QUOTE 0x0001 #endif #ifndef PERL_PV_PRETTY_QUOTE # define PERL_PV_PRETTY_QUOTE PERL_PV_ESCAPE_QUOTE #endif #ifndef PERL_PV_PRETTY_ELLIPSES # define PERL_PV_PRETTY_ELLIPSES 0x0002 #endif #ifndef PERL_PV_PRETTY_LTGT # define PERL_PV_PRETTY_LTGT 0x0004 #endif #ifndef PERL_PV_ESCAPE_FIRSTCHAR # define PERL_PV_ESCAPE_FIRSTCHAR 0x0008 #endif #ifndef PERL_PV_ESCAPE_UNI # define PERL_PV_ESCAPE_UNI 0x0100 #endif #ifndef PERL_PV_ESCAPE_UNI_DETECT # define PERL_PV_ESCAPE_UNI_DETECT 0x0200 #endif #ifndef PERL_PV_ESCAPE_ALL # define PERL_PV_ESCAPE_ALL 0x1000 #endif #ifndef PERL_PV_ESCAPE_NOBACKSLASH # define PERL_PV_ESCAPE_NOBACKSLASH 0x2000 #endif #ifndef PERL_PV_ESCAPE_NOCLEAR # define PERL_PV_ESCAPE_NOCLEAR 0x4000 #endif #ifndef PERL_PV_ESCAPE_RE # define PERL_PV_ESCAPE_RE 0x8000 #endif #ifndef PERL_PV_PRETTY_NOCLEAR # define PERL_PV_PRETTY_NOCLEAR PERL_PV_ESCAPE_NOCLEAR #endif #ifndef PERL_PV_PRETTY_DUMP # define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE #endif #ifndef PERL_PV_PRETTY_REGPROP # define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE #endif /* Hint: pv_escape * Note that unicode functionality is only backported to * those perl versions that support it. For older perl * versions, the implementation will fall back to bytes. */ #ifndef pv_escape #if defined(NEED_pv_escape) static char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); static #else extern char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); #endif #ifdef pv_escape # undef pv_escape #endif #define pv_escape(a,b,c,d,e,f) DPPP_(my_pv_escape)(aTHX_ a,b,c,d,e,f) #define Perl_pv_escape DPPP_(my_pv_escape) #if defined(NEED_pv_escape) || defined(NEED_pv_escape_GLOBAL) char * DPPP_(my_pv_escape)(pTHX_ SV *dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags) { const char esc = flags & PERL_PV_ESCAPE_RE ? '%' : '\\'; const char dq = flags & PERL_PV_ESCAPE_QUOTE ? '"' : esc; char octbuf[32] = "%123456789ABCDF"; STRLEN wrote = 0; STRLEN chsize = 0; STRLEN readsize = 1; #if defined(is_utf8_string) && defined(utf8_to_uvchr) bool isuni = flags & PERL_PV_ESCAPE_UNI ? 1 : 0; #endif const char *pv = str; const char * const end = pv + count; octbuf[0] = esc; if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) sv_setpvs(dsv, ""); #if defined(is_utf8_string) && defined(utf8_to_uvchr) if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count)) isuni = 1; #endif for (; pv < end && (!max || wrote < max) ; pv += readsize) { const UV u = #if defined(is_utf8_string) && defined(utf8_to_uvchr) isuni ? utf8_to_uvchr((U8*)pv, &readsize) : #endif (U8)*pv; const U8 c = (U8)u & 0xFF; if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) { if (flags & PERL_PV_ESCAPE_FIRSTCHAR) chsize = my_snprintf(octbuf, sizeof octbuf, "%"UVxf, u); else chsize = my_snprintf(octbuf, sizeof octbuf, "%cx{%"UVxf"}", esc, u); } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) { chsize = 1; } else { if (c == dq || c == esc || !isPRINT(c)) { chsize = 2; switch (c) { case '\\' : /* fallthrough */ case '%' : if (c == esc) octbuf[1] = esc; else chsize = 1; break; case '\v' : octbuf[1] = 'v'; break; case '\t' : octbuf[1] = 't'; break; case '\r' : octbuf[1] = 'r'; break; case '\n' : octbuf[1] = 'n'; break; case '\f' : octbuf[1] = 'f'; break; case '"' : if (dq == '"') octbuf[1] = '"'; else chsize = 1; break; default: chsize = my_snprintf(octbuf, sizeof octbuf, pv < end && isDIGIT((U8)*(pv+readsize)) ? "%c%03o" : "%c%o", esc, c); } } else { chsize = 1; } } if (max && wrote + chsize > max) { break; } else if (chsize > 1) { sv_catpvn(dsv, octbuf, chsize); wrote += chsize; } else { char tmp[2]; my_snprintf(tmp, sizeof tmp, "%c", c); sv_catpvn(dsv, tmp, 1); wrote++; } if (flags & PERL_PV_ESCAPE_FIRSTCHAR) break; } if (escaped != NULL) *escaped= pv - str; return SvPVX(dsv); } #endif #endif #ifndef pv_pretty #if defined(NEED_pv_pretty) static char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); static #else extern char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); #endif #ifdef pv_pretty # undef pv_pretty #endif #define pv_pretty(a,b,c,d,e,f,g) DPPP_(my_pv_pretty)(aTHX_ a,b,c,d,e,f,g) #define Perl_pv_pretty DPPP_(my_pv_pretty) #if defined(NEED_pv_pretty) || defined(NEED_pv_pretty_GLOBAL) char * DPPP_(my_pv_pretty)(pTHX_ SV *dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags) { const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%'; STRLEN escaped; if (!(flags & PERL_PV_PRETTY_NOCLEAR)) sv_setpvs(dsv, ""); if (dq == '"') sv_catpvs(dsv, "\""); else if (flags & PERL_PV_PRETTY_LTGT) sv_catpvs(dsv, "<"); if (start_color != NULL) sv_catpv(dsv, D_PPP_CONSTPV_ARG(start_color)); pv_escape(dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR); if (end_color != NULL) sv_catpv(dsv, D_PPP_CONSTPV_ARG(end_color)); if (dq == '"') sv_catpvs(dsv, "\""); else if (flags & PERL_PV_PRETTY_LTGT) sv_catpvs(dsv, ">"); if ((flags & PERL_PV_PRETTY_ELLIPSES) && escaped < count) sv_catpvs(dsv, "..."); return SvPVX(dsv); } #endif #endif #ifndef pv_display #if defined(NEED_pv_display) static char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); static #else extern char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); #endif #ifdef pv_display # undef pv_display #endif #define pv_display(a,b,c,d,e) DPPP_(my_pv_display)(aTHX_ a,b,c,d,e) #define Perl_pv_display DPPP_(my_pv_display) #if defined(NEED_pv_display) || defined(NEED_pv_display_GLOBAL) char * DPPP_(my_pv_display)(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) { pv_pretty(dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP); if (len > cur && pv[cur] == '\0') sv_catpvs(dsv, "\\0"); return SvPVX(dsv); } #endif #endif #endif /* _P_P_PORTABILITY_H_ */ /* End of File ppport.h */ Feersum-1.410/t/000755 000765 000024 00000000000 13762625540 014222 5ustar00audreytstaff000000 000000 Feersum-1.410/xt/000755 000765 000024 00000000000 13762625540 014412 5ustar00audreytstaff000000 000000 Feersum-1.410/README000644 000765 000024 00000001464 13762624365 014650 0ustar00audreytstaff000000 000000 INSTALLATION If you downloaded this module from a git repository, be sure to run: git submodule init git submodule update You need to have EV 3.9 and at least ExtUtils::MakeMaker 6.50 installed to build and install this module. To install this module type the following: perl Makefile.PL make test make install Please report any bugs using the github issue tracker: http://github.com/stash/Feersum/issues/ COPYRIGHT AND LICENCE Copyright (C) 2010 by Jeremy Stashewsky & Socialtext Inc. 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.7 or, at your option, any later version of Perl 5 you may have available. picohttpparser is Copyright 2009 Kazuho Oku and is released under the same terms as Perl itself. Feersum-1.410/TODO000644 000765 000024 00000004371 13762624365 014460 0ustar00audreytstaff000000 000000 Timeouts * slow responses? (feasable? just let TCP do it?) psgi.input streaming * add a "poll_cb()" method to the psgi.input handle as an extension? EV gets to schedule the watcher in that case rather than bleeding the fd to the handler. * related: Connection: close bodies * related: Transfer-Encoding: chunked bodies IO::Handle-like responses * check if it's got a real file descriptor? optimize (libeio or similar for non-blocking sendfile?) (v1.1) * wait for readability using an ev watcher? (v1.1) streamed responses * instead of an implicit "low water mark" of 0 for the poll_cb writer-object callback, a configurable number of bytes can be used. Handle requests that don't require a body (optional entities). * Related: allow overriding the "if entity has a C-L, wait for it" during request start (not sure if there's a PSGI-compatible way to do this) * different request timeout logic will be needed. Optimize env-hash * allow Feersum apps to specify which vars will be needed (v1.1) ** will this even be a win? * maybe use uvar magic for PSGI if using Perl v5.10.0 (Variable::Magic style?) (v1.1) Perf idea: Un-corked reads - should newly accepted handles wait or just try read right away? multiple Feersum threads, one Perl thread? WebSocket support (v1.1) * http://www.whatwg.org/specs/web-socket-protocol/ * Support psgix.io and Web::Hippie already (0.981), but would be good to accelerate it. * Do the handshake in C/XS, call request_handler once request is complete. * I/O is done using the streaming interface (buffered) * requires random numbers (drand48?) and an MD5 implementation (link openssl? use the guts of Digest::MD5 somehow?) * make this a separate module since if it brings in an openssl deps. * will this work for PSGI? magic psgix.web_socket or something? Release t/Utils.pm's "simple_client" as "anyevent::anotherhttp" or something? accept4 * available on newer linuxes, saves calls to fcntl for setting NONBLOCK and CLOEXEC JSON accelleration? * can write_json() an element in an array of things? automagically call JSON::XS stuff? * middleware with XS-accellerator? True pre-forking support * serialize accept() calls Feersum-1.410/typemap000644 000765 000024 00000000555 13762624365 015372 0ustar00audreytstaff000000 000000 struct feer_conn * T_feer_conn feer_conn_handle * T_feer_conn_handle INPUT T_feer_conn $var = sv_2feer_conn($arg); T_feer_conn_handle SV *hdl_sv = SvRV($arg); $var = sv_2feer_conn_handle($arg,1); /* handle is really just a feer_conn struct: */ struct feer_conn *c = (struct feer_conn *)$var; OUTPUT T_feer_conn $arg = feer_conn_2sv($var); Feersum-1.410/rinq.c000644 000765 000024 00000004052 13762624365 015101 0ustar00audreytstaff000000 000000 // read "rinq" as "ring-queue" struct rinq { struct rinq *next; struct rinq *prev; void *ref; }; #define RINQ_IS_UNINIT(x_) ((x_)->next == NULL && (x_)->prev == NULL) #define RINQ_IS_DETACHED(x_) ((x_)->next == (x_)) #define RINQ_IS_ATTACHED(x_) ((x_)->next != (x_)) #define RINQ_NEW(x_,ref_) do { \ x_ = (struct rinq *)malloc(sizeof(struct rinq)); \ x_->next = x_->prev = x_; \ x_->ref = ref_; \ } while(0) #define RINQ_DETACH(x_) do { \ (x_)->next->prev = (x_)->prev; \ (x_)->prev->next = (x_)->next; \ (x_)->next = (x_)->prev = (x_); \ } while(0) // INLINE_UNLESS_DEBUG // static void // rinq_unshift(struct rinq **head, void *ref) // { // struct rinq *x; // RINQ_NEW(x,ref); // // if ((*head) != NULL) { // x->next = (*head)->next; // x->prev = (*head); // x->next->prev = x->prev->next = x; // } // (*head) = x; // } INLINE_UNLESS_DEBUG static void rinq_push (struct rinq **head, void *ref) { struct rinq *x; RINQ_NEW(x,ref); if ((*head) == NULL) { (*head) = x; } else { x->next = (*head); x->prev = (*head)->prev; x->next->prev = x->prev->next = x; } } // remove element from tail of rinq // not actually used // INLINE_UNLESS_DEBUG // static void * // rinq_pop (struct rinq **head) { // void *ref; // struct rinq *x; // // if ((*head) == NULL) return NULL; // // if (RINQ_IS_DETACHED((*head))) { // x = (*head); // (*head) = NULL; // } // else { // x = (*head)->prev; // RINQ_DETACH(x); // } // // ref = x->ref; // free(x); // return ref; // } // remove element from head of rinq INLINE_UNLESS_DEBUG static void * rinq_shift (struct rinq **head) { void *ref; struct rinq *x; if ((*head) == NULL) return NULL; if (RINQ_IS_DETACHED((*head))) { x = (*head); (*head) = NULL; } else { x = (*head); (*head) = (*head)->next; RINQ_DETACH(x); } ref = x->ref; free(x); return ref; } Feersum-1.410/MANIFEST.SKIP000644 000765 000024 00000000331 13762625526 015656 0ustar00audreytstaff000000 000000 .*\.git.* gmon\.out$ gcov gprof \.gcda$ \.gcno$ \..+\.sw[mnop]$ ^blib/ Feersum\.(?:o|bs|c)$ Feersum-.+\.tar(?:\.gz)? ^http_load \.patch$ Makefile$ Makefile\.old$ pm_to_blib ^fcgi ^timer/ ^bench MYMETA.yml MYMETA.json Feersum-1.410/META.yml000644 000765 000024 00000001644 13762625540 015235 0ustar00audreytstaff000000 000000 --- abstract: 'A PSGI engine for Perl based on EV/libev' author: - 'Jeremy Stashewsky ' build_requires: AnyEvent: '5.261' Guard: '1.012' Test::Fatal: '0.003' Test::LeakTrace: '0.13' Test::More: '0.94' Test::SharedFork: '0.25' Test::TCP: '1.12' configure_requires: EV: '4' ExtUtils::MakeMaker: '6.51' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Feersum no_index: directory: - t - inc - eg - picohttpparser-git recommends: JSON::XS: '2' requires: EV: '4' HTTP::Entity::Parser: '0.20' Plack: '0.995' Scalar::Util: '1.19' resources: license: http://dev.perl.org/licenses/ repository: git://github.com/stash/Feersum.git version: '1.410' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Feersum-1.410/Feersum.xs000644 000765 000024 00000232731 13762624365 015755 0ustar00audreytstaff000000 000000 #include "EVAPI.h" #include #include #include #include #include #include #include #include #include #include "ppport.h" /////////////////////////////////////////////////////////////// // "Compile Time Options" - See Feersum.pm POD for information #define MAX_HEADERS 64 #define MAX_HEADER_NAME_LEN 128 #define MAX_BODY_LEN 2147483647 #define READ_BUFSZ 4096 #define READ_INIT_FACTOR 2 #define READ_GROW_FACTOR 8 #define AUTOCORK_WRITES 1 #if 0 # define FLASH_SOCKET_POLICY_SUPPORT #endif #ifndef FLASH_SOCKET_POLICY # define FLASH_SOCKET_POLICY "\n\n\n\n\n\n" #endif // may be lower for your platform (e.g. Solaris is 16). See POD. #define FEERSUM_IOMATRIX_SIZE 64 // auto-detected in Makefile.PL by perl versions and ithread usage; override // that here. See POD for details. #if 0 # undef FEERSUM_STEAL #endif /////////////////////////////////////////////////////////////// #ifdef __GNUC__ # define likely(x) __builtin_expect(!!(x), 1) # define unlikely(x) __builtin_expect(!!(x), 0) #else # define likely(x) (x) # define unlikely(x) (x) #endif #ifndef CRLF #define CRLF "\015\012" #endif #define CRLFx2 CRLF CRLF // make darwin, solaris and bsd happy: #ifndef SOL_TCP #define SOL_TCP IPPROTO_TCP #endif // Wish-list: %z formats for perl sprintf. Would make compiling a lot less // noisy for systems that warn size_t and STRLEN are incompatible with // %d/%u/%x. #if Size_t_size == LONGSIZE # define Sz_f "l" # define Sz_t long #elif Size_t_size == 8 && defined HAS_QUAD && QUADKIND == QUAD_IS_LONG_LONG # define Sz_f "ll" # define Sz_t long long #else // hope "int" works. # define Sz_f "" # define Sz_t int #endif #define Sz_uf Sz_f"u" #define Sz_xf Sz_f"x" #define Ssz_df Sz_f"d" #define Sz unsigned Sz_t #define Ssz Sz_t #define WARN_PREFIX "Feersum: " #ifndef DEBUG #ifndef __inline #define __inline #endif #define INLINE_UNLESS_DEBUG __inline #else #define INLINE_UNLESS_DEBUG #endif #define trouble(f_, ...) warn(WARN_PREFIX f_, ##__VA_ARGS__); #ifdef DEBUG #define trace(f_, ...) warn("%s:%-4d [%d] " f_, __FILE__, __LINE__, (int)getpid(), ##__VA_ARGS__) #else #define trace(...) #endif #if DEBUG >= 2 #define trace2(f_, ...) trace(f_, ##__VA_ARGS__) #else #define trace2(...) #endif #if DEBUG >= 3 #define trace3(f_, ...) trace(f_, ##__VA_ARGS__) #else #define trace3(...) #endif #include "picohttpparser-git/picohttpparser.c" #include "rinq.c" // Check FEERSUM_IOMATRIX_SIZE against what's actually usable on this // platform. See Feersum.pm for an explanation #if defined(IOV_MAX) && FEERSUM_IOMATRIX_SIZE > IOV_MAX # undef FEERSUM_IOMATRIX_SIZE # define FEERSUM_IOMATRIX_SIZE IOV_MAX #elif defined(UIO_MAXIOV) && FEERSUM_IOMATRIX_SIZE > UIO_MAXIOV # undef FEERSUM_IOMATRIX_SIZE # define FEERSUM_IOMATRIX_SIZE UIO_MAXIOV #endif struct iomatrix { unsigned offset; unsigned count; struct iovec iov[FEERSUM_IOMATRIX_SIZE]; SV *sv[FEERSUM_IOMATRIX_SIZE]; }; struct feer_req { SV *buf; const char* method; size_t method_len; const char* path; size_t path_len; int minor_version; size_t num_headers; struct phr_header headers[MAX_HEADERS]; }; enum feer_respond_state { RESPOND_NOT_STARTED = 0, RESPOND_NORMAL = 1, RESPOND_STREAMING = 2, RESPOND_SHUTDOWN = 3 }; #define RESPOND_STR(_n,_s) do { \ switch(_n) { \ case RESPOND_NOT_STARTED: _s = "NOT_STARTED(0)"; break; \ case RESPOND_NORMAL: _s = "NORMAL(1)"; break; \ case RESPOND_STREAMING: _s = "STREAMING(2)"; break; \ case RESPOND_SHUTDOWN: _s = "SHUTDOWN(4)"; break; \ } \ } while (0) enum feer_receive_state { RECEIVE_HEADERS = 0, RECEIVE_BODY = 1, RECEIVE_STREAMING = 2, RECEIVE_SHUTDOWN = 3 }; #define RECEIVE_STR(_n,_s) do { \ switch(_n) { \ case RECEIVE_HEADERS: _s = "HEADERS(0)"; break; \ case RECEIVE_BODY: _s = "BODY(1)"; break; \ case RECEIVE_STREAMING: _s = "STREAMING(2)"; break; \ case RECEIVE_SHUTDOWN: _s = "SHUTDOWN(3)"; break; \ } \ } while (0) struct feer_conn { SV *self; int fd; struct sockaddr *sa; struct ev_io read_ev_io; struct ev_io write_ev_io; struct ev_timer read_ev_timer; SV *rbuf; struct rinq *wbuf_rinq; SV *poll_write_cb; SV *ext_guard; struct feer_req *req; ssize_t expected_cl; ssize_t received_cl; enum feer_respond_state responding; enum feer_receive_state receiving; int in_callback; int is_http11:1; int poll_write_cb_is_io_handle:1; int auto_cl:1; }; typedef struct feer_conn feer_conn_handle; // for typemap #define dCONN struct feer_conn *c = (struct feer_conn *)w->data #define IsArrayRef(_x) (SvROK(_x) && SvTYPE(SvRV(_x)) == SVt_PVAV) #define IsCodeRef(_x) (SvROK(_x) && SvTYPE(SvRV(_x)) == SVt_PVCV) static HV* feersum_env(pTHX_ struct feer_conn *c); static void feersum_start_response (pTHX_ struct feer_conn *c, SV *message, AV *headers, int streaming); static size_t feersum_write_whole_body (pTHX_ struct feer_conn *c, SV *body); static void feersum_handle_psgi_response( pTHX_ struct feer_conn *c, SV *ret, bool can_recurse); static int feersum_close_handle(pTHX_ struct feer_conn *c, bool is_writer); static SV* feersum_conn_guard(pTHX_ struct feer_conn *c, SV *guard); static void start_read_watcher(struct feer_conn *c); static void stop_read_watcher(struct feer_conn *c); static void restart_read_timer(struct feer_conn *c); static void stop_read_timer(struct feer_conn *c); static void start_write_watcher(struct feer_conn *c); static void stop_write_watcher(struct feer_conn *c); static void try_conn_write(EV_P_ struct ev_io *w, int revents); static void try_conn_read(EV_P_ struct ev_io *w, int revents); static void conn_read_timeout(EV_P_ struct ev_timer *w, int revents); static bool process_request_headers(struct feer_conn *c, int body_offset); static void sched_request_callback(struct feer_conn *c); static void call_died (pTHX_ struct feer_conn *c, const char *cb_type); static void call_request_callback(struct feer_conn *c); static void call_poll_callback (struct feer_conn *c, bool is_write); static void pump_io_handle (struct feer_conn *c, SV *io); static void conn_write_ready (struct feer_conn *c); static void respond_with_server_error(struct feer_conn *c, const char *msg, STRLEN msg_len, int code); static void update_wbuf_placeholder(struct feer_conn *c, SV *sv, struct iovec *iov); static STRLEN add_sv_to_wbuf (struct feer_conn *c, SV *sv); static STRLEN add_const_to_wbuf (struct feer_conn *c, const char *str, size_t str_len); #define add_crlf_to_wbuf(c) add_const_to_wbuf(c,CRLF,2) static void finish_wbuf (struct feer_conn *c); static void add_chunk_sv_to_wbuf (struct feer_conn *c, SV *sv); static void add_placeholder_to_wbuf (struct feer_conn *c, SV **sv, struct iovec **iov_ref); static void uri_decode_sv (SV *sv); static bool str_eq(const char *a, int a_len, const char *b, int b_len); static bool str_case_eq(const char *a, int a_len, const char *b, int b_len); static SV* fetch_av_normal (pTHX_ AV *av, I32 i); static const char *http_code_to_msg (int code); static int prep_socket (int fd, int is_tcp); static HV *feer_stash, *feer_conn_stash; static HV *feer_conn_reader_stash = NULL, *feer_conn_writer_stash = NULL; static MGVTBL psgix_io_vtbl; static SV *request_cb_cv = NULL; static bool request_cb_is_psgi = 0; static SV *shutdown_cb_cv = NULL; static bool shutting_down = 0; static int active_conns = 0; static double read_timeout = 5.0; static SV *feer_server_name = NULL; static SV *feer_server_port = NULL; static ev_io accept_w; static ev_prepare ep; static ev_check ec; struct ev_idle ei; static struct rinq *request_ready_rinq = NULL; static AV *psgi_ver; static SV *psgi_serv10, *psgi_serv11, *crlf_sv; // TODO: make this thread-local if and when there are multiple C threads: struct ev_loop *feersum_ev_loop = NULL; static HV *feersum_tmpl_env = NULL; INLINE_UNLESS_DEBUG static SV* fetch_av_normal (pTHX_ AV *av, I32 i) { SV **elt = av_fetch(av, i, 0); if (elt == NULL) return NULL; SV *sv = *elt; // copy to remove magic if (unlikely(SvMAGICAL(sv))) sv = sv_2mortal(newSVsv(sv)); if (unlikely(!SvOK(sv))) return NULL; // usually array ref elems aren't RVs (for PSGI anyway) if (unlikely(SvROK(sv))) sv = SvRV(sv); return sv; } INLINE_UNLESS_DEBUG static struct iomatrix * next_iomatrix (struct feer_conn *c) { bool add_iomatrix = 0; struct iomatrix *m; if (!c->wbuf_rinq) { trace3("next_iomatrix(%d): head\n", c->fd); add_iomatrix = 1; } else { // get the tail-end struct m = (struct iomatrix *)c->wbuf_rinq->prev->ref; trace3("next_iomatrix(%d): tail, count=%d, offset=%d\n", c->fd, m->count, m->offset); if (m->count >= FEERSUM_IOMATRIX_SIZE) { add_iomatrix = 1; } } if (add_iomatrix) { trace3("next_iomatrix(%d): malloc\n", c->fd); Newx(m,1,struct iomatrix); Poison(m,1,struct iomatrix); m->offset = m->count = 0; rinq_push(&c->wbuf_rinq, m); } trace3("next_iomatrix(%d): end, count=%d, offset=%d\n", c->fd, m->count, m->offset); return m; } INLINE_UNLESS_DEBUG static STRLEN add_sv_to_wbuf(struct feer_conn *c, SV *sv) { struct iomatrix *m = next_iomatrix(c); int idx = m->count++; STRLEN cur; if (unlikely(SvMAGICAL(sv))) { sv = newSVsv(sv); // copy to force it to be normal. } else if (unlikely(SvPADTMP(sv))) { // PADTMPs have their PVs re-used, so we can't simply keep a // reference. TEMPs maybe behave in a similar way and are potentially // stealable. If not stealing, we must make a copy. #ifdef FEERSUM_STEAL if (SvFLAGS(sv) == (SVs_PADTMP|SVf_POK|SVp_POK)) { trace3("STEALING\n"); SV *theif = newSV(0); sv_upgrade(theif, SVt_PV); SvPV_set(theif, SvPVX(sv)); SvLEN_set(theif, SvLEN(sv)); SvCUR_set(theif, SvCUR(sv)); // make the temp null (void)SvOK_off(sv); SvPV_set(sv, NULL); SvLEN_set(sv, 0); SvCUR_set(sv, 0); SvFLAGS(theif) |= SVf_READONLY|SVf_POK|SVp_POK; sv = theif; } else { sv = newSVsv(sv); } #else sv = newSVsv(sv); #endif } else { sv = SvREFCNT_inc(sv); } m->iov[idx].iov_base = SvPV(sv, cur); m->iov[idx].iov_len = cur; m->sv[idx] = sv; return cur; } INLINE_UNLESS_DEBUG static STRLEN add_const_to_wbuf(struct feer_conn *c, const char *str, size_t str_len) { struct iomatrix *m = next_iomatrix(c); int idx = m->count++; m->iov[idx].iov_base = (void*)str; m->iov[idx].iov_len = str_len; m->sv[idx] = NULL; return str_len; } INLINE_UNLESS_DEBUG static void add_placeholder_to_wbuf(struct feer_conn *c, SV **sv, struct iovec **iov_ref) { struct iomatrix *m = next_iomatrix(c); int idx = m->count++; *sv = newSV(31); SvPOK_on(*sv); m->sv[idx] = *sv; *iov_ref = &m->iov[idx]; } INLINE_UNLESS_DEBUG static void finish_wbuf(struct feer_conn *c) { if (!c->is_http11) return; // nothing required add_const_to_wbuf(c, "0\r\n\r\n", 5); // terminating chunk } INLINE_UNLESS_DEBUG static void update_wbuf_placeholder(struct feer_conn *c, SV *sv, struct iovec *iov) { STRLEN cur; // can't pass iov_len for cur; incompatible pointer type on some systems: iov->iov_base = SvPV(sv,cur); iov->iov_len = cur; } static void add_chunk_sv_to_wbuf(struct feer_conn *c, SV *sv) { SV *chunk; struct iovec *chunk_iov; add_placeholder_to_wbuf(c, &chunk, &chunk_iov); STRLEN cur = add_sv_to_wbuf(c, sv); add_crlf_to_wbuf(c); sv_setpvf(chunk, "%"Sz_xf CRLF, (Sz)cur); update_wbuf_placeholder(c, chunk, chunk_iov); } static const char * http_code_to_msg (int code) { // http://en.wikipedia.org/wiki/List_of_HTTP_status_codes switch (code) { case 100: return "Continue"; case 101: return "Switching Protocols"; case 102: return "Processing"; // RFC 2518 case 200: return "OK"; case 201: return "Created"; case 202: return "Accepted"; case 203: return "Non Authoritative Information"; case 204: return "No Content"; case 205: return "Reset Content"; case 206: return "Partial Content"; case 207: return "Multi-Status"; // RFC 4918 (WebDav) case 300: return "Multiple Choices"; case 301: return "Moved Permanently"; case 302: return "Found"; case 303: return "See Other"; case 304: return "Not Modified"; case 305: return "Use Proxy"; case 307: return "Temporary Redirect"; case 400: return "Bad Request"; case 401: return "Unauthorized"; case 402: return "Payment Required"; case 403: return "Forbidden"; case 404: return "Not Found"; case 405: return "Method Not Allowed"; case 406: return "Not Acceptable"; case 407: return "Proxy Authentication Required"; case 408: return "Request Timeout"; case 409: return "Conflict"; case 410: return "Gone"; case 411: return "Length Required"; case 412: return "Precondition Failed"; case 413: return "Request Entity Too Large"; case 414: return "Request URI Too Long"; case 415: return "Unsupported Media Type"; case 416: return "Requested Range Not Satisfiable"; case 417: return "Expectation Failed"; case 418: return "I'm a teapot"; case 421: return "Too Many Connections"; // Microsoft? case 422: return "Unprocessable Entity"; // RFC 4918 case 423: return "Locked"; // RFC 4918 case 424: return "Failed Dependency"; // RFC 4918 case 425: return "Unordered Collection"; // RFC 3648 case 426: return "Upgrade Required"; // RFC 2817 case 449: return "Retry With"; // Microsoft case 450: return "Blocked by Parental Controls"; // Microsoft case 500: return "Internal Server Error"; case 501: return "Not Implemented"; case 502: return "Bad Gateway"; case 503: return "Service Unavailable"; case 504: return "Gateway Timeout"; case 505: return "HTTP Version Not Supported"; case 506: return "Variant Also Negotiates"; // RFC 2295 case 507: return "Insufficient Storage"; // RFC 4918 case 509: return "Bandwidth Limit Exceeded"; // Apache mod case 510: return "Not Extended"; // RFC 2774 case 530: return "User access denied"; // ?? default: break; } // default to the Nxx group names in RFC 2616 if (100 <= code && code <= 199) { return "Informational"; } else if (200 <= code && code <= 299) { return "Success"; } else if (300 <= code && code <= 399) { return "Redirection"; } else if (400 <= code && code <= 499) { return "Client Error"; } else { return "Error"; } } static int prep_socket(int fd, int is_tcp) { int flags; // make it non-blocking flags = O_NONBLOCK; if (unlikely(fcntl(fd, F_SETFL, flags) < 0)) return -1; if (likely(is_tcp)) { // flush writes immediately flags = 1; if (unlikely(setsockopt(fd, SOL_TCP, TCP_NODELAY, &flags, sizeof(int)))) return -1; } // handle URG data inline flags = 1; if (unlikely(setsockopt(fd, SOL_SOCKET, SO_OOBINLINE, &flags, sizeof(int)))) return -1; // disable lingering struct linger linger = { .l_onoff = 0, .l_linger = 0 }; if (unlikely(setsockopt(fd, SOL_SOCKET, SO_LINGER, &linger, sizeof(linger)))) return -1; return 0; } INLINE_UNLESS_DEBUG static void safe_close_conn(struct feer_conn *c, const char *where) { if (unlikely(c->fd < 0)) return; // make it blocking fcntl(c->fd, F_SETFL, 0); if (unlikely(close(c->fd))) perror(where); c->fd = -1; } static struct feer_conn * new_feer_conn (EV_P_ int conn_fd, struct sockaddr *sa) { SV *self = newSV(0); SvUPGRADE(self, SVt_PVMG); // ensures sv_bless doesn't reallocate SvGROW(self, sizeof(struct feer_conn)); SvPOK_only(self); SvIOK_on(self); SvIV_set(self,conn_fd); struct feer_conn *c = (struct feer_conn *)SvPVX(self); Zero(c, 1, struct feer_conn); c->self = self; c->fd = conn_fd; c->sa = sa; c->responding = RESPOND_NOT_STARTED; c->receiving = RECEIVE_HEADERS; ev_io_init(&c->read_ev_io, try_conn_read, conn_fd, EV_READ); c->read_ev_io.data = (void *)c; ev_init(&c->read_ev_timer, conn_read_timeout); c->read_ev_timer.data = (void *)c; trace3("made conn fd=%d self=%p, c=%p, cur=%"Sz_uf", len=%"Sz_uf"\n", c->fd, self, c, (Sz)SvCUR(self), (Sz)SvLEN(self)); SV *rv = newRV_inc(c->self); sv_bless(rv, feer_conn_stash); // so DESTROY can get called on read errors SvREFCNT_dec(rv); SvREADONLY_on(self); // turn off later for blessing active_conns++; return c; } // for use in the typemap: INLINE_UNLESS_DEBUG static struct feer_conn * sv_2feer_conn (SV *rv) { if (unlikely(!sv_isa(rv,"Feersum::Connection"))) croak("object is not of type Feersum::Connection"); return (struct feer_conn *)SvPVX(SvRV(rv)); } INLINE_UNLESS_DEBUG static SV* feer_conn_2sv (struct feer_conn *c) { return newRV_inc(c->self); } static feer_conn_handle * sv_2feer_conn_handle (SV *rv, bool can_croak) { trace3("sv 2 conn_handle\n"); if (unlikely(!SvROK(rv))) croak("Expected a reference"); // do not allow subclassing SV *sv = SvRV(rv); if (likely( sv_isobject(rv) && (SvSTASH(sv) == feer_conn_writer_stash || SvSTASH(sv) == feer_conn_reader_stash) )) { UV uv = SvUV(sv); if (uv == 0) { if (can_croak) croak("Operation not allowed: Handle is closed."); return NULL; } return INT2PTR(feer_conn_handle*,uv); } if (can_croak) croak("Expected a Feersum::Connection::Writer or ::Reader object"); return NULL; } static SV * new_feer_conn_handle (pTHX_ struct feer_conn *c, bool is_writer) { SV *sv; SvREFCNT_inc_void_NN(c->self); sv = newRV_noinc(newSVuv(PTR2UV(c))); sv_bless(sv, is_writer ? feer_conn_writer_stash : feer_conn_reader_stash); return sv; } #if DEBUG # define change_responding_state(c, _to) do { \ enum feer_respond_state __to = (_to); \ enum feer_respond_state __from = c->responding; \ const char *_from_str, *_to_str; \ if (likely(__from != __to)) { \ RESPOND_STR(c->responding, _from_str); \ RESPOND_STR(__to, _to_str); \ trace2("==> responding state %d: %s to %s\n", \ c->fd,_from_str,_to_str); \ c->responding = __to; \ } \ } while (0) # define change_receiving_state(c, _to) do { \ enum feer_receive_state __to = (_to); \ enum feer_receive_state __from = c->receiving; \ const char *_from_str, *_to_str; \ if (likely(__from != __to)) { \ RECEIVE_STR(c->receiving, _from_str); \ RECEIVE_STR(__to, _to_str); \ trace2("==> receiving state %d: %s to %s\n", \ c->fd,_from_str,_to_str); \ c->receiving = __to; \ } \ } while (0) #else # define change_responding_state(c, _to) c->responding = _to # define change_receiving_state(c, _to) c->receiving = _to #endif INLINE_UNLESS_DEBUG static void start_read_watcher(struct feer_conn *c) { if (unlikely(ev_is_active(&c->read_ev_io))) return; trace("start read watcher %d\n",c->fd); ev_io_start(feersum_ev_loop, &c->read_ev_io); SvREFCNT_inc_void_NN(c->self); } INLINE_UNLESS_DEBUG static void stop_read_watcher(struct feer_conn *c) { if (unlikely(!ev_is_active(&c->read_ev_io))) return; trace("stop read watcher %d\n",c->fd); ev_io_stop(feersum_ev_loop, &c->read_ev_io); SvREFCNT_dec(c->self); } INLINE_UNLESS_DEBUG static void restart_read_timer(struct feer_conn *c) { if (likely(!ev_is_active(&c->read_ev_timer))) { trace("restart read timer %d\n",c->fd); c->read_ev_timer.repeat = read_timeout; SvREFCNT_inc_void_NN(c->self); } ev_timer_again(feersum_ev_loop, &c->read_ev_timer); } INLINE_UNLESS_DEBUG static void stop_read_timer(struct feer_conn *c) { if (unlikely(!ev_is_active(&c->read_ev_timer))) return; trace("stop read timer %d\n",c->fd); ev_timer_stop(feersum_ev_loop, &c->read_ev_timer); SvREFCNT_dec(c->self); } INLINE_UNLESS_DEBUG static void start_write_watcher(struct feer_conn *c) { if (unlikely(ev_is_active(&c->write_ev_io))) return; trace("start write watcher %d\n",c->fd); ev_io_start(feersum_ev_loop, &c->write_ev_io); SvREFCNT_inc_void_NN(c->self); } INLINE_UNLESS_DEBUG static void stop_write_watcher(struct feer_conn *c) { if (unlikely(!ev_is_active(&c->write_ev_io))) return; trace("stop write watcher %d\n",c->fd); ev_io_stop(feersum_ev_loop, &c->write_ev_io); SvREFCNT_dec(c->self); } static void process_request_ready_rinq (void) { while (request_ready_rinq) { struct feer_conn *c = (struct feer_conn *)rinq_shift(&request_ready_rinq); //trace("rinq shifted c=%p, head=%p\n", c, request_ready_rinq); call_request_callback(c); if (likely(c->wbuf_rinq)) { // this was deferred until after the perl callback conn_write_ready(c); } SvREFCNT_dec(c->self); // for the rinq } } static void prepare_cb (EV_P_ ev_prepare *w, int revents) { if (unlikely(revents & EV_ERROR)) { trouble("EV error in prepare, revents=0x%08x\n", revents); ev_break(EV_A, EVBREAK_ALL); return; } if (!ev_is_active(&accept_w) && !shutting_down) { ev_io_start(EV_A, &accept_w); } ev_prepare_stop(EV_A, w); } static void check_cb (EV_P_ ev_check *w, int revents) { if (unlikely(revents & EV_ERROR)) { trouble("EV error in check, revents=0x%08x\n", revents); ev_break(EV_A, EVBREAK_ALL); return; } trace3("check! head=%p\n", request_ready_rinq); if (request_ready_rinq) process_request_ready_rinq(); } static void idle_cb (EV_P_ ev_idle *w, int revents) { if (unlikely(revents & EV_ERROR)) { trouble("EV error in idle, revents=0x%08x\n", revents); ev_break(EV_A, EVBREAK_ALL); return; } trace3("idle! head=%p\n", request_ready_rinq); if (request_ready_rinq) process_request_ready_rinq(); ev_idle_stop(EV_A, w); } static void try_conn_write(EV_P_ struct ev_io *w, int revents) { dCONN; int i; struct iomatrix *m; SvREFCNT_inc_void_NN(c->self); // if it's marked writeable EV suggests we simply try write to it. // Otherwise it is stopped and we should ditch this connection. if (unlikely(revents & EV_ERROR && !(revents & EV_WRITE))) { trace("EV error on write, fd=%d revents=0x%08x\n", w->fd, revents); change_responding_state(c, RESPOND_SHUTDOWN); goto try_write_finished; } if (unlikely(!c->wbuf_rinq)) { if (unlikely(c->responding >= RESPOND_SHUTDOWN)) goto try_write_finished; if (!c->poll_write_cb) { // no callback and no data: wait for app to push to us. if (c->responding == RESPOND_STREAMING) goto try_write_paused; trace("tried to write with an empty buffer %d resp=%d\n",w->fd,c->responding); change_responding_state(c, RESPOND_SHUTDOWN); goto try_write_finished; } if (c->poll_write_cb_is_io_handle) pump_io_handle(c, c->poll_write_cb); else call_poll_callback(c, 1); // callback didn't write anything: if (unlikely(!c->wbuf_rinq)) goto try_write_again; } try_write_again_immediately: m = (struct iomatrix *)c->wbuf_rinq->ref; #if DEBUG >= 2 warn("going to write to %d:\n",c->fd); for (i=0; i < m->count; i++) { fprintf(stderr,"%.*s", (int)m->iov[i].iov_len, (char*)m->iov[i].iov_base); } #endif trace("going to write %d off=%d count=%d\n", w->fd, m->offset, m->count); errno = 0; ssize_t wrote = writev(w->fd, &m->iov[m->offset], m->count - m->offset); trace("wrote %"Ssz_df" bytes to %d, errno=%d\n", (Ssz)wrote, w->fd, errno); if (unlikely(wrote <= 0)) { if (unlikely(wrote == 0)) goto try_write_again; if (likely(errno == EAGAIN || errno == EINTR)) goto try_write_again; perror("Feersum try_conn_write"); change_responding_state(c, RESPOND_SHUTDOWN); goto try_write_finished; } for (i = m->offset; i < m->count && wrote > 0; i++) { struct iovec *v = &m->iov[i]; if (unlikely(v->iov_len > wrote)) { trace3("offset vector %d base=%p len=%"Sz_uf"\n", w->fd, v->iov_base, (Sz)v->iov_len); v->iov_base += wrote; v->iov_len -= wrote; // don't consume any more: wrote = 0; } else { trace3("consume vector %d base=%p len=%"Sz_uf" sv=%p\n", w->fd, v->iov_base, (Sz)v->iov_len, m->sv[i]); wrote -= v->iov_len; m->offset++; if (m->sv[i]) { SvREFCNT_dec(m->sv[i]); m->sv[i] = NULL; } } } if (likely(m->offset >= m->count)) { trace2("all done with iomatrix %d state=%d\n",w->fd,c->responding); rinq_shift(&c->wbuf_rinq); Safefree(m); if (!c->wbuf_rinq) goto try_write_finished; trace2("write again immediately %d state=%d\n",w->fd,c->responding); goto try_write_again_immediately; } // else, fallthrough: trace2("write fallthrough %d state=%d\n",w->fd,c->responding); try_write_again: trace("write again %d state=%d\n",w->fd,c->responding); start_write_watcher(c); goto try_write_cleanup; try_write_finished: // should always be responding, but just in case switch(c->responding) { case RESPOND_NOT_STARTED: // the write watcher shouldn't ever get called before starting to // respond. Shut it down if it does. trace("unexpected try_write when response not started %d\n",c->fd); goto try_write_shutdown; case RESPOND_NORMAL: goto try_write_shutdown; case RESPOND_STREAMING: if (c->poll_write_cb) goto try_write_again; else goto try_write_paused; case RESPOND_SHUTDOWN: goto try_write_shutdown; default: goto try_write_cleanup; } try_write_paused: trace3("write PAUSED %d, refcnt=%d, state=%d\n", c->fd, SvREFCNT(c->self), c->responding); stop_write_watcher(c); goto try_write_cleanup; try_write_shutdown: trace3("write SHUTDOWN %d, refcnt=%d, state=%d\n", c->fd, SvREFCNT(c->self), c->responding); change_responding_state(c, RESPOND_SHUTDOWN); stop_write_watcher(c); safe_close_conn(c, "close at write shutdown"); try_write_cleanup: SvREFCNT_dec(c->self); return; } static int try_parse_http(struct feer_conn *c, size_t last_read) { struct feer_req *req = c->req; if (likely(!req)) { Newxz(req,1,struct feer_req); c->req = req; } // GH#12 - incremental parsing sets num_headers to 0 each time; force it // back on every invocation req->num_headers = MAX_HEADERS; return phr_parse_request(SvPVX(c->rbuf), SvCUR(c->rbuf), &req->method, &req->method_len, &req->path, &req->path_len, &req->minor_version, req->headers, &req->num_headers, (SvCUR(c->rbuf)-last_read)); } static void try_conn_read(EV_P_ ev_io *w, int revents) { dCONN; SvREFCNT_inc_void_NN(c->self); // if it's marked readable EV suggests we simply try read it. Otherwise it // is stopped and we should ditch this connection. if (unlikely(revents & EV_ERROR && !(revents & EV_READ))) { trace("EV error on read, fd=%d revents=0x%08x\n", w->fd, revents); goto try_read_error; } if (unlikely(c->receiving == RECEIVE_SHUTDOWN)) goto dont_read_again; trace("try read %d\n",w->fd); if (likely(!c->rbuf)) { // likely = optimize for small requests trace("init rbuf for %d\n",w->fd); c->rbuf = newSV(READ_INIT_FACTOR*READ_BUFSZ + 1); SvPOK_on(c->rbuf); } ssize_t space_free = SvLEN(c->rbuf) - SvCUR(c->rbuf); if (unlikely(space_free < READ_BUFSZ)) { // unlikely = optimize for small size_t new_len = SvLEN(c->rbuf) + READ_GROW_FACTOR*READ_BUFSZ; trace("moar memory %d: %"Sz_uf" to %"Sz_uf"\n", w->fd, (Sz)SvLEN(c->rbuf), (Sz)new_len); SvGROW(c->rbuf, new_len); space_free += READ_GROW_FACTOR*READ_BUFSZ; } char *cur = SvPVX(c->rbuf) + SvCUR(c->rbuf); ssize_t got_n = read(w->fd, cur, space_free); if (unlikely(got_n <= 0)) { if (unlikely(got_n == 0)) { trace("EOF before complete request: %d\n",w->fd,SvCUR(c->rbuf)); goto try_read_error; } if (likely(errno == EAGAIN || errno == EINTR)) goto try_read_again; perror("try_conn_read error"); goto try_read_error; } trace("read %d %"Ssz_df"\n", w->fd, (Ssz)got_n); SvCUR(c->rbuf) += got_n; // likely = optimize for small requests if (likely(c->receiving == RECEIVE_HEADERS)) { #ifdef FLASH_SOCKET_POLICY_SUPPORT if (unlikely(*SvPVX(c->rbuf) == '<')) { if (likely(SvCUR(c->rbuf) >= 22)) { // length of vvv if (str_eq(SvPVX(c->rbuf), 22, "", 22)) { add_const_to_wbuf(c, STR_WITH_LEN(FLASH_SOCKET_POLICY)); conn_write_ready(c); stop_read_watcher(c); stop_read_timer(c); // TODO: keep-alives: be sure to remove the 22 bytes // out of the rbuf change_receiving_state(c, RECEIVE_SHUTDOWN); change_responding_state(c, RESPOND_SHUTDOWN); goto dont_read_again; } } // "if prefixed with" else if (likely(str_eq(SvPVX(c->rbuf), SvCUR(c->rbuf), "", SvCUR(c->rbuf)))) { goto try_read_again; } } #endif int ret = try_parse_http(c, (size_t)got_n); if (ret == -1) goto try_read_bad; if (ret == -2) goto try_read_again; if (process_request_headers(c, ret)) goto try_read_again_reset_timer; else goto dont_read_again; } else if (likely(c->receiving == RECEIVE_BODY)) { c->received_cl += got_n; if (c->received_cl < c->expected_cl) goto try_read_again_reset_timer; // body is complete sched_request_callback(c); goto dont_read_again; } else { trouble("unknown read state %d %d", w->fd, c->receiving); } // fallthrough: try_read_error: trace("READ ERROR %d, refcnt=%d\n", w->fd, SvREFCNT(c->self)); change_receiving_state(c, RECEIVE_SHUTDOWN); change_responding_state(c, RESPOND_SHUTDOWN); stop_read_watcher(c); stop_read_timer(c); stop_write_watcher(c); goto try_read_cleanup; try_read_bad: trace("bad request %d\n", w->fd); respond_with_server_error(c, "Malformed request.\n", 0, 400); // TODO: when keep-alive, close conn instead of fallthrough here. // fallthrough: dont_read_again: trace("done reading %d\n", w->fd); change_receiving_state(c, RECEIVE_SHUTDOWN); stop_read_watcher(c); stop_read_timer(c); goto try_read_cleanup; try_read_again_reset_timer: trace("(reset read timer) %d\n", w->fd); restart_read_timer(c); // fallthrough: try_read_again: trace("read again %d\n", w->fd); start_read_watcher(c); try_read_cleanup: SvREFCNT_dec(c->self); } static void conn_read_timeout (EV_P_ ev_timer *w, int revents) { dCONN; SvREFCNT_inc_void_NN(c->self); if (unlikely(!(revents & EV_TIMER) || c->receiving == RECEIVE_SHUTDOWN)) { // if there's no EV_TIMER then EV has stopped it on an error if (revents & EV_ERROR) trouble("EV error on read timer, fd=%d revents=0x%08x\n", c->fd,revents); goto read_timeout_cleanup; } trace("read timeout %d\n", c->fd); if (likely(c->responding == RESPOND_NOT_STARTED)) { const char *msg; if (c->receiving == RECEIVE_HEADERS) { msg = "Headers took too long."; } else { msg = "Timeout reading body."; } respond_with_server_error(c, msg, 0, 408); } else { // XXX as of 0.984 this appears to be dead code trace("read timeout while writing %d\n",c->fd); stop_write_watcher(c); stop_read_watcher(c); stop_read_timer(c); safe_close_conn(c, "close at read timeout"); change_responding_state(c, RESPOND_SHUTDOWN); } read_timeout_cleanup: stop_read_watcher(c); stop_read_timer(c); SvREFCNT_dec(c->self); } static void accept_cb (EV_P_ ev_io *w, int revents) { struct sockaddr_storage sa_buf; socklen_t sa_len; if (unlikely(shutting_down)) { // shouldn't get called, but be defensive ev_io_stop(EV_A, w); close(w->fd); return; } if (unlikely(revents & EV_ERROR)) { trouble("EV error in accept_cb, fd=%d, revents=0x%08x\n",w->fd,revents); ev_break(EV_A, EVBREAK_ALL); return; } trace2("accept! revents=0x%08x\n", revents); while (1) { sa_len = sizeof(struct sockaddr_storage); errno = 0; int fd = accept(w->fd, (struct sockaddr *)&sa_buf, &sa_len); trace("accepted fd=%d, errno=%d\n", fd, errno); if (fd == -1) break; int is_tcp = 1; #ifdef AF_UNIX if (unlikely(sa_buf.ss_family == AF_UNIX)) is_tcp = 0; #endif assert(sa_len <= sizeof(struct sockaddr_storage)); if (unlikely(prep_socket(fd, is_tcp))) { perror("prep_socket"); trouble("prep_socket failed for %d\n", fd); close(fd); continue; } struct sockaddr *sa = (struct sockaddr *)malloc(sa_len); memcpy(sa,&sa_buf,(size_t)sa_len); struct feer_conn *c = new_feer_conn(EV_A,fd,sa); start_read_watcher(c); restart_read_timer(c); assert(SvREFCNT(c->self) == 3); SvREFCNT_dec(c->self); } } static void sched_request_callback (struct feer_conn *c) { trace("sched req callback: %d c=%p, head=%p\n", c->fd, c, request_ready_rinq); rinq_push(&request_ready_rinq, c); SvREFCNT_inc_void_NN(c->self); // for the rinq if (!ev_is_active(&ei)) { ev_idle_start(feersum_ev_loop, &ei); } } // the unlikely/likely annotations here are trying to optimize for GET first // and POST second. Other entity-body requests are third in line. static bool process_request_headers (struct feer_conn *c, int body_offset) { int err_code; const char *err; struct feer_req *req = c->req; trace("processing headers %d minor_version=%d\n",c->fd,req->minor_version); bool body_is_required; bool next_req_follows = 0; c->is_http11 = (req->minor_version == 1); change_receiving_state(c, RECEIVE_BODY); if (likely(str_eq("GET", 3, req->method, req->method_len))) { // Not supposed to have a body. Additional bytes are either a // mistake, a websocket negotiation or pipelined requests under // HTTP/1.1 next_req_follows = 1; } else if (likely(str_eq("OPTIONS", 7, req->method, req->method_len))) { body_is_required = 1; next_req_follows = 1; } else if (likely(str_eq("POST", 4, req->method, req->method_len))) { body_is_required = 1; } else if (str_eq("PUT", 3, req->method, req->method_len)) { body_is_required = 1; } else if (str_eq("HEAD", 4, req->method, req->method_len) || str_eq("DELETE", 6, req->method, req->method_len)) { next_req_follows = 1; } else { err = "Feersum doesn't support that method yet\n"; err_code = 405; goto got_bad_request; } #if DEBUG >= 2 if (next_req_follows) trace2("next req follows fd=%d, boff=%d\n",c->fd,body_offset); if (body_is_required) trace2("body is required fd=%d, boff=%d\n",c->fd,body_offset); #endif // a body or follow-on data potentially follows the headers. Let feer_req // retain its pointers into rbuf and make a new scalar for more body data. STRLEN from_len; char *from = SvPV(c->rbuf,from_len); from += body_offset; int need = from_len - body_offset; int new_alloc = (need > READ_INIT_FACTOR*READ_BUFSZ) ? need : READ_INIT_FACTOR*READ_BUFSZ-1; trace("new rbuf for body %d need=%d alloc=%d\n",c->fd, need, new_alloc); SV *new_rbuf = newSVpvn(need ? from : "", need); req->buf = c->rbuf; c->rbuf = new_rbuf; SvCUR_set(req->buf, body_offset); if (likely(next_req_follows)) // optimize for GET goto got_it_all; // determine how much we need to read int i; UV expected = 0; for (i=0; i < req->num_headers; i++) { struct phr_header *hdr = &req->headers[i]; if (!hdr->name) continue; // XXX: ignore multiple C-L headers? if (unlikely( str_case_eq("content-length", 14, hdr->name, hdr->name_len))) { int g = grok_number(hdr->value, hdr->value_len, &expected); if (likely(g == IS_NUMBER_IN_UV)) { if (unlikely(expected > MAX_BODY_LEN)) { err_code = 413; err = "Content length exceeds maximum\n"; goto got_bad_request; } else goto got_cl; } else { err_code = 400; err = "invalid content-length\n"; goto got_bad_request; } } // TODO: support "Connection: close" bodies // TODO: support "Transfer-Encoding: chunked" bodies } if (body_is_required) { // Go the nginx route... err_code = 411; err = "Content-Length required\n"; } else { // XXX TODO support requests that don't require a body err_code = 418; err = "Feersum doesn't know how to handle optional-body requests yet\n"; } got_bad_request: respond_with_server_error(c, err, 0, err_code); return 0; got_cl: c->expected_cl = (ssize_t)expected; c->received_cl = SvCUR(c->rbuf); trace("expecting body %d size=%"Ssz_df" have=%"Ssz_df"\n", c->fd, (Ssz)c->expected_cl, (Ssz)c->received_cl); SvGROW(c->rbuf, c->expected_cl + 1); // don't have enough bytes to schedule immediately? // unlikely = optimize for short requests if (unlikely(c->expected_cl && c->received_cl < c->expected_cl)) { // TODO: schedule the callback immediately and support a non-blocking // ->read method. // sched_request_callback(c); // change_receiving_state(c, RECEIVE_STREAM); return 1; } // fallthrough: have enough bytes got_it_all: sched_request_callback(c); return 0; } static void conn_write_ready (struct feer_conn *c) { if (c->in_callback) return; // defer until out of callback if (c->write_ev_io.data == NULL) { ev_io_init(&c->write_ev_io, try_conn_write, c->fd, EV_WRITE); c->write_ev_io.data = (void *)c; } #if AUTOCORK_WRITES start_write_watcher(c); #else // attempt a non-blocking write immediately if we're not already // waiting for writability try_conn_write(feersum_ev_loop, &c->write_ev_io, EV_WRITE); #endif } static void respond_with_server_error (struct feer_conn *c, const char *msg, STRLEN msg_len, int err_code) { SV *tmp; if (unlikely(c->responding != RESPOND_NOT_STARTED)) { trouble("Tried to send server error but already responding!"); return; } if (!msg_len) msg_len = strlen(msg); assert(msg_len < INT_MAX); tmp = newSVpvf("HTTP/1.%d %d %s" CRLF "Content-Type: text/plain" CRLF "Connection: close" CRLF "Cache-Control: no-cache, no-store" CRLF "Content-Length: %"Ssz_df"" CRLFx2 "%.*s", c->is_http11 ? 1 : 0, err_code, http_code_to_msg(err_code), (Ssz)msg_len, (int)msg_len, msg); add_sv_to_wbuf(c, sv_2mortal(tmp)); stop_read_watcher(c); stop_read_timer(c); change_responding_state(c, RESPOND_SHUTDOWN); change_receiving_state(c, RECEIVE_SHUTDOWN); conn_write_ready(c); } INLINE_UNLESS_DEBUG bool str_eq(const char *a, int a_len, const char *b, int b_len) { if (a_len != b_len) return 0; if (a == b) return 1; int i; for (i=0; i= 2)) { int c1 = hex_decode(ptr[1]); int c2 = hex_decode(ptr[2]); if (likely(c1 != -1 && c2 != -1)) { *decoded++ = (c1 << 4) + c2; ptr += 2; continue; } } *decoded++ = *ptr; } *decoded = '\0'; // play nice with C ptr = SvPV_nolen(sv); SvCUR_set(sv, decoded-ptr); } static void feersum_init_tmpl_env(pTHX) { HV *e; e = newHV(); // constants hv_stores(e, "psgi.version", newRV((SV*)psgi_ver)); hv_stores(e, "psgi.url_scheme", newSVpvs("http")); hv_stores(e, "psgi.run_once", &PL_sv_no); hv_stores(e, "psgi.nonblocking", &PL_sv_yes); hv_stores(e, "psgi.multithread", &PL_sv_no); hv_stores(e, "psgi.multiprocess", &PL_sv_no); hv_stores(e, "psgi.streaming", &PL_sv_yes); hv_stores(e, "psgi.errors", newRV((SV*)PL_stderrgv)); hv_stores(e, "psgix.input.buffered", &PL_sv_yes); hv_stores(e, "psgix.output.buffered", &PL_sv_yes); hv_stores(e, "psgix.body.scalar_refs", &PL_sv_yes); hv_stores(e, "psgix.output.guard", &PL_sv_yes); hv_stores(e, "SCRIPT_NAME", newSVpvs("")); // placeholders that get defined for every request hv_stores(e, "SERVER_PROTOCOL", &PL_sv_undef); hv_stores(e, "SERVER_NAME", &PL_sv_undef); hv_stores(e, "SERVER_PORT", &PL_sv_undef); hv_stores(e, "REQUEST_URI", &PL_sv_undef); hv_stores(e, "REQUEST_METHOD", &PL_sv_undef); hv_stores(e, "PATH_INFO", &PL_sv_undef); hv_stores(e, "REMOTE_ADDR", &PL_sv_placeholder); hv_stores(e, "REMOTE_PORT", &PL_sv_placeholder); // defaults that get changed for some requests hv_stores(e, "psgi.input", &PL_sv_undef); hv_stores(e, "CONTENT_LENGTH", newSViv(0)); hv_stores(e, "QUERY_STRING", newSVpvs("")); // anticipated headers hv_stores(e, "CONTENT_TYPE", &PL_sv_placeholder); hv_stores(e, "HTTP_HOST", &PL_sv_placeholder); hv_stores(e, "HTTP_USER_AGENT", &PL_sv_placeholder); hv_stores(e, "HTTP_ACCEPT", &PL_sv_placeholder); hv_stores(e, "HTTP_ACCEPT_LANGUAGE", &PL_sv_placeholder); hv_stores(e, "HTTP_ACCEPT_CHARSET", &PL_sv_placeholder); hv_stores(e, "HTTP_KEEP_ALIVE", &PL_sv_placeholder); hv_stores(e, "HTTP_CONNECTION", &PL_sv_placeholder); hv_stores(e, "HTTP_REFERER", &PL_sv_placeholder); hv_stores(e, "HTTP_COOKIE", &PL_sv_placeholder); hv_stores(e, "HTTP_IF_MODIFIED_SINCE", &PL_sv_placeholder); hv_stores(e, "HTTP_IF_NONE_MATCH", &PL_sv_placeholder); hv_stores(e, "HTTP_CACHE_CONTROL", &PL_sv_placeholder); hv_stores(e, "psgix.io", &PL_sv_placeholder); feersum_tmpl_env = e; } static HV* feersum_env(pTHX_ struct feer_conn *c) { HV *e; SV **hsv; int i,j; struct feer_req *r = c->req; if (unlikely(!feersum_tmpl_env)) feersum_init_tmpl_env(aTHX); e = newHVhv(feersum_tmpl_env); trace("generating header (fd %d) %.*s\n", c->fd, (int)r->path_len, r->path); SV *path = newSVpvn(r->path, r->path_len); hv_stores(e, "SERVER_NAME", newSVsv(feer_server_name)); hv_stores(e, "SERVER_PORT", newSVsv(feer_server_port)); hv_stores(e, "REQUEST_URI", path); hv_stores(e, "REQUEST_METHOD", newSVpvn(r->method,r->method_len)); hv_stores(e, "SERVER_PROTOCOL", (r->minor_version == 1) ? newSVsv(psgi_serv11) : newSVsv(psgi_serv10)); SV *addr = &PL_sv_undef; SV *port = &PL_sv_undef; const char *str_addr; unsigned short s_port; if (c->sa->sa_family == AF_INET) { struct sockaddr_in *in = (struct sockaddr_in *)c->sa; addr = newSV(INET_ADDRSTRLEN); str_addr = inet_ntop(AF_INET,&in->sin_addr,SvPVX(addr),INET_ADDRSTRLEN); s_port = ntohs(in->sin_port); } #ifdef AF_INET6 else if (c->sa->sa_family == AF_INET6) { struct sockaddr_in6 *in6 = (struct sockaddr_in6 *)c->sa; addr = newSV(INET6_ADDRSTRLEN); str_addr = inet_ntop(AF_INET6,&in6->sin6_addr,SvPVX(addr),INET6_ADDRSTRLEN); s_port = ntohs(in6->sin6_port); } #endif #ifdef AF_UNIX else if (c->sa->sa_family == AF_UNIX) { str_addr = "unix"; addr = newSV(sizeof(str_addr)); memcpy(SvPVX(addr), str_addr, sizeof(str_addr)); s_port = 0; } #endif if (likely(str_addr)) { SvCUR(addr) = strlen(SvPVX(addr)); SvPOK_on(addr); port = newSViv(s_port); } hv_stores(e, "REMOTE_ADDR", addr); hv_stores(e, "REMOTE_PORT", port); if (unlikely(c->expected_cl > 0)) { hv_stores(e, "CONTENT_LENGTH", newSViv(c->expected_cl)); hv_stores(e, "psgi.input", new_feer_conn_handle(aTHX_ c,0)); } else if (request_cb_is_psgi) { // TODO: make psgi.input a valid, but always empty stream for PSGI mode? } if (request_cb_is_psgi) { SV *fake_fh = newSViv(c->fd); // just some random dummy value SV *selfref = sv_2mortal(feer_conn_2sv(c)); sv_magicext(fake_fh, selfref, PERL_MAGIC_ext, &psgix_io_vtbl, NULL, 0); hv_stores(e, "psgix.io", fake_fh); } { const char *qpos = r->path; SV *pinfo, *qstr; // rather than memchr, for speed: while (*qpos != '?' && qpos < r->path + r->path_len) qpos++; if (*qpos == '?') { pinfo = newSVpvn(r->path, (qpos - r->path)); qpos++; qstr = newSVpvn(qpos, r->path_len - (qpos - r->path)); } else { pinfo = newSVsv(path); qstr = NULL; // use template default } uri_decode_sv(pinfo); hv_stores(e, "PATH_INFO", pinfo); if (qstr != NULL) // hv template defaults QUERY_STRING to empty hv_stores(e, "QUERY_STRING", qstr); } SV *val = NULL; char *kbuf; size_t kbuflen = 64; Newx(kbuf, kbuflen, char); kbuf[0]='H'; kbuf[1]='T'; kbuf[2]='T'; kbuf[3]='P'; kbuf[4]='_'; for (i=0; inum_headers; i++) { struct phr_header *hdr = &(r->headers[i]); if (unlikely(hdr->name == NULL && val != NULL)) { trace("... multiline %.*s\n", (int)hdr->value_len, hdr->value); sv_catpvn(val, hdr->value, hdr->value_len); continue; } else if (unlikely(str_case_eq( STR_WITH_LEN("content-length"), hdr->name, hdr->name_len))) { // content length shouldn't show up as HTTP_CONTENT_LENGTH but // as CONTENT_LENGTH in the env-hash. continue; } else if (unlikely(str_case_eq( STR_WITH_LEN("content-type"), hdr->name, hdr->name_len))) { hv_stores(e, "CONTENT_TYPE",newSVpvn(hdr->value, hdr->value_len)); continue; } size_t klen = 5+hdr->name_len; if (kbuflen < klen) { kbuflen = klen; kbuf = Renew(kbuf, kbuflen, char); } char *key = kbuf + 5; for (j=0; jname_len; j++) { char n = hdr->name[j]; *key++ = (n == '-') ? '_' : toupper(n); } SV **val = hv_fetch(e, kbuf, klen, 1); trace("adding header to env (fd %d) %.*s: %.*s\n", c->fd, (int)klen, kbuf, (int)hdr->value_len, hdr->value); assert(val != NULL); // "fetch is store" flag should ensure this if (unlikely(SvPOK(*val))) { trace("... is multivalue\n"); // extend header with comma sv_catpvn(*val, ", ", 2); sv_catpvn(*val, hdr->value, hdr->value_len); } else { // change from undef to a real value sv_setpvn(*val, hdr->value, hdr->value_len); } } Safefree(kbuf); return e; } static void feersum_start_response (pTHX_ struct feer_conn *c, SV *message, AV *headers, int streaming) { const char *ptr; I32 i; trace("start_response fd=%d streaming=%d\n", c->fd, streaming); if (unlikely(c->responding != RESPOND_NOT_STARTED)) croak("already responding?!"); change_responding_state(c, streaming ? RESPOND_STREAMING : RESPOND_NORMAL); if (unlikely(!SvOK(message) || !(SvIOK(message) || SvPOK(message)))) { croak("Must define an HTTP status code or message"); } I32 avl = av_len(headers); if (unlikely(avl+1 % 2 == 1)) { croak("expected even-length array, got %d", avl+1); } // int or 3 chars? use a stock message UV code = 0; if (SvIOK(message)) code = SvIV(message); else if (SvUOK(message)) code = SvUV(message); else { const int numtype = grok_number(SvPVX_const(message),3,&code); if (unlikely(numtype != IS_NUMBER_IN_UV)) code = 0; } trace2("starting response fd=%d code=%"UVuf"\n",c->fd,code); if (unlikely(!code)) croak("first parameter is not a number or doesn't start with digits"); // for PSGI it's always just an IV so optimize for that if (likely(!SvPOK(message) || SvCUR(message) == 3)) { ptr = http_code_to_msg(code); message = sv_2mortal(newSVpvf("%"UVuf" %s",code,ptr)); } // don't generate or strip Content-Length headers for 304 or 1xx c->auto_cl = (code == 304 || (100 <= code && code <= 199)) ? 0 : 1; add_const_to_wbuf(c, c->is_http11 ? "HTTP/1.1 " : "HTTP/1.0 ", 9); add_sv_to_wbuf(c, message); add_crlf_to_wbuf(c); for (i=0; iauto_cl) && unlikely(str_case_eq("content-length",14,hp,hlen))) { trace("ignoring content-length header in the response\n"); continue; } add_sv_to_wbuf(c, *hdr); add_const_to_wbuf(c, ": ", 2); add_sv_to_wbuf(c, *val); add_crlf_to_wbuf(c); } if (streaming) { if (c->is_http11) add_const_to_wbuf(c, "Transfer-Encoding: chunked" CRLFx2, 30); else add_const_to_wbuf(c, "Connection: close" CRLFx2, 21); } conn_write_ready(c); } static size_t feersum_write_whole_body (pTHX_ struct feer_conn *c, SV *body) { size_t RETVAL; int i; bool body_is_string = 0; STRLEN cur; if (c->responding != RESPOND_NORMAL) croak("can't use write_whole_body when in streaming mode"); if (!SvOK(body)) { body = sv_2mortal(newSVpvs("")); body_is_string = 1; } else if (SvROK(body)) { SV *refd = SvRV(body); if (SvOK(refd) && !SvROK(refd)) { body = refd; body_is_string = 1; } else if (SvTYPE(refd) != SVt_PVAV) { croak("body must be a scalar, scalar reference or array reference"); } } else { body_is_string = 1; } SV *cl_sv; // content-length future struct iovec *cl_iov; if (likely(c->auto_cl)) add_placeholder_to_wbuf(c, &cl_sv, &cl_iov); else add_crlf_to_wbuf(c); if (body_is_string) { cur = add_sv_to_wbuf(c,body); RETVAL = cur; } else { AV *abody = (AV*)SvRV(body); I32 amax = av_len(abody); RETVAL = 0; for (i=0; i<=amax; i++) { SV *sv = fetch_av_normal(aTHX_ abody, i); if (unlikely(!sv)) continue; cur = add_sv_to_wbuf(c,sv); trace("body part i=%d sv=%p cur=%"Sz_uf"\n", i, sv, (Sz)cur); RETVAL += cur; } } if (likely(c->auto_cl)) { sv_setpvf(cl_sv, "Content-Length: %"Sz_uf"" CRLFx2, (Sz)RETVAL); update_wbuf_placeholder(c, cl_sv, cl_iov); } change_responding_state(c, RESPOND_SHUTDOWN); conn_write_ready(c); return RETVAL; } static void feersum_start_psgi_streaming(pTHX_ struct feer_conn *c, SV *streamer) { dSP; ENTER; SAVETMPS; PUSHMARK(SP); mXPUSHs(feer_conn_2sv(c)); XPUSHs(streamer); PUTBACK; call_method("_initiate_streaming_psgi", G_DISCARD|G_EVAL|G_VOID); SPAGAIN; if (unlikely(SvTRUE(ERRSV))) { call_died(aTHX_ c, "PSGI stream initiator"); } PUTBACK; FREETMPS; LEAVE; } static void feersum_handle_psgi_response( pTHX_ struct feer_conn *c, SV *ret, bool can_recurse) { if (unlikely(!SvOK(ret) || !SvROK(ret))) { sv_setpvs(ERRSV, "Invalid PSGI response (expected reference)"); call_died(aTHX_ c, "PSGI request"); return; } if (SvOK(ret) && unlikely(!IsArrayRef(ret))) { if (likely(can_recurse)) { trace("PSGI response non-array, c=%p ret=%p\n", c, ret); feersum_start_psgi_streaming(aTHX_ c, ret); } else { sv_setpvs(ERRSV, "PSGI attempt to recurse in a streaming callback"); call_died(aTHX_ c, "PSGI request"); } return; } AV *psgi_triplet = (AV*)SvRV(ret); if (unlikely(av_len(psgi_triplet)+1 != 3)) { sv_setpvs(ERRSV, "Invalid PSGI array response (expected triplet)"); call_died(aTHX_ c, "PSGI request"); return; } trace("PSGI response triplet, c=%p av=%p\n", c, psgi_triplet); // we know there's three elems so *should* be safe to de-ref SV *msg = *(av_fetch(psgi_triplet,0,0)); SV *hdrs = *(av_fetch(psgi_triplet,1,0)); SV *body = *(av_fetch(psgi_triplet,2,0)); AV *headers; if (IsArrayRef(hdrs)) headers = (AV*)SvRV(hdrs); else { sv_setpvs(ERRSV, "PSGI Headers must be an array-ref"); call_died(aTHX_ c, "PSGI request"); return; } if (likely(IsArrayRef(body))) { feersum_start_response(aTHX_ c, msg, headers, 0); feersum_write_whole_body(aTHX_ c, body); } else if (likely(SvROK(body))) { // probaby an IO::Handle-like object feersum_start_response(aTHX_ c, msg, headers, 1); c->poll_write_cb = newSVsv(body); c->poll_write_cb_is_io_handle = 1; conn_write_ready(c); } else { sv_setpvs(ERRSV, "Expected PSGI array-ref or IO::Handle-like body"); call_died(aTHX_ c, "PSGI request"); return; } } static int feersum_close_handle (pTHX_ struct feer_conn *c, bool is_writer) { int RETVAL; if (is_writer) { trace("close writer fd=%d, c=%p, refcnt=%d\n", c->fd, c, SvREFCNT(c->self)); if (c->poll_write_cb) { SvREFCNT_dec(c->poll_write_cb); c->poll_write_cb = NULL; } if (c->responding < RESPOND_SHUTDOWN) { finish_wbuf(c); conn_write_ready(c); change_responding_state(c, RESPOND_SHUTDOWN); } RETVAL = 1; } else { trace("close reader fd=%d, c=%p\n", c->fd, c); // TODO: ref-dec poll_read_cb if (c->rbuf) { SvREFCNT_dec(c->rbuf); c->rbuf = NULL; } RETVAL = shutdown(c->fd, SHUT_RD); change_receiving_state(c, RECEIVE_SHUTDOWN); } // disassociate the handle from the conn SvREFCNT_dec(c->self); return RETVAL; } static SV* feersum_conn_guard(pTHX_ struct feer_conn *c, SV *guard) { if (guard) { if (c->ext_guard) SvREFCNT_dec(c->ext_guard); c->ext_guard = SvOK(guard) ? newSVsv(guard) : NULL; } return c->ext_guard ? newSVsv(c->ext_guard) : &PL_sv_undef; } static void call_died (pTHX_ struct feer_conn *c, const char *cb_type) { dSP; #if DEBUG >= 1 trace("An error was thrown in the %s callback: %-p\n",cb_type,ERRSV); #endif PUSHMARK(SP); mXPUSHs(newSVsv(ERRSV)); PUTBACK; call_pv("Feersum::DIED", G_DISCARD|G_EVAL|G_VOID|G_KEEPERR); SPAGAIN; respond_with_server_error(c,"Request handler exception.\n",0,500); sv_setsv(ERRSV, &PL_sv_undef); } static void call_request_callback (struct feer_conn *c) { dTHX; dSP; int flags; c->in_callback++; SvREFCNT_inc_void_NN(c->self); trace("request callback c=%p\n", c); ENTER; SAVETMPS; PUSHMARK(SP); if (request_cb_is_psgi) { HV *env = feersum_env(aTHX_ c); mXPUSHs(newRV_noinc((SV*)env)); flags = G_EVAL|G_SCALAR; } else { mXPUSHs(feer_conn_2sv(c)); flags = G_DISCARD|G_EVAL|G_VOID; } PUTBACK; int returned = call_sv(request_cb_cv, flags); SPAGAIN; trace("called request callback, errsv? %d\n", SvTRUE(ERRSV) ? 1 : 0); if (unlikely(SvTRUE(ERRSV))) { call_died(aTHX_ c, "request"); returned = 0; // pretend nothing got returned } SV *psgi_response; if (request_cb_is_psgi && likely(returned >= 1)) { psgi_response = POPs; SvREFCNT_inc_void_NN(psgi_response); } trace("leaving request callback\n"); PUTBACK; if (request_cb_is_psgi && likely(returned >= 1)) { feersum_handle_psgi_response(aTHX_ c, psgi_response, 1); // can_recurse SvREFCNT_dec(psgi_response); } //fangyousong if (request_cb_is_psgi && c->expected_cl > 0) { SvREFCNT_dec(c->self); } c->in_callback--; SvREFCNT_dec(c->self); FREETMPS; LEAVE; } static void call_poll_callback (struct feer_conn *c, bool is_write) { dTHX; dSP; SV *cb = (is_write) ? c->poll_write_cb : NULL; if (unlikely(cb == NULL)) return; c->in_callback++; trace("%s poll callback c=%p cbrv=%p\n", is_write ? "write" : "read", c, cb); ENTER; SAVETMPS; PUSHMARK(SP); mXPUSHs(new_feer_conn_handle(aTHX_ c, is_write)); PUTBACK; call_sv(cb, G_DISCARD|G_EVAL|G_VOID); SPAGAIN; trace("called %s poll callback, errsv? %d\n", is_write ? "write" : "read", SvTRUE(ERRSV) ? 1 : 0); if (unlikely(SvTRUE(ERRSV))) { call_died(aTHX_ c, is_write ? "write poll" : "read poll"); } trace("leaving %s poll callback\n", is_write ? "write" : "read"); PUTBACK; FREETMPS; LEAVE; c->in_callback--; } static void pump_io_handle (struct feer_conn *c, SV *io) { dTHX; dSP; if (unlikely(io == NULL)) return; c->in_callback++; trace("pump io handle %d\n", c->fd); ENTER; SAVETMPS; // Emulate `local $/ = \4096;` SV *old_rs = PL_rs; PL_rs = sv_2mortal(newRV_noinc(newSViv(4096))); sv_setsv(get_sv("/", GV_ADD), PL_rs); PUSHMARK(SP); XPUSHs(c->poll_write_cb); PUTBACK; int returned = call_method("getline", G_SCALAR|G_EVAL); SPAGAIN; trace("called getline on io handle fd=%d errsv=%d returned=%d\n", c->fd, SvTRUE(ERRSV) ? 1 : 0, returned); if (unlikely(SvTRUE(ERRSV))) { call_died(aTHX_ c, "getline on io handle"); goto done_pump_io; } SV *ret = NULL; if (returned > 0) ret = POPs; if (ret && SvMAGICAL(ret)) ret = sv_2mortal(newSVsv(ret)); if (unlikely(!ret || !SvOK(ret))) { // returned undef, so call the close method out of niceity PUSHMARK(SP); XPUSHs(c->poll_write_cb); PUTBACK; call_method("close", G_VOID|G_DISCARD|G_EVAL); SPAGAIN; if (unlikely(SvTRUE(ERRSV))) { trouble("Couldn't close body IO handle: %-p",ERRSV); } SvREFCNT_dec(c->poll_write_cb); c->poll_write_cb = NULL; finish_wbuf(c); change_responding_state(c, RESPOND_SHUTDOWN); goto done_pump_io; } if (c->is_http11) add_chunk_sv_to_wbuf(c, ret); else add_sv_to_wbuf(c, ret); done_pump_io: trace("leaving pump io handle %d\n", c->fd); PUTBACK; FREETMPS; LEAVE; PL_rs = old_rs; sv_setsv(get_sv("/", GV_ADD), old_rs); c->in_callback--; } static int psgix_io_svt_get (pTHX_ SV *sv, MAGIC *mg) { dSP; struct feer_conn *c = sv_2feer_conn(mg->mg_obj); trace("invoking psgix.io magic for fd=%d\n", c->fd); sv_unmagic(sv, PERL_MAGIC_ext); ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(sv); mXPUSHs(newSViv(c->fd)); PUTBACK; call_pv("Feersum::Connection::_raw", G_VOID|G_DISCARD|G_EVAL); SPAGAIN; if (unlikely(SvTRUE(ERRSV))) { call_died(aTHX_ c, "psgix.io magic"); } else { SV *io_glob = SvRV(sv); GvSV(io_glob) = newRV_inc(c->self); // Put whatever remainder data into the socket buffer. // Optimizes for the websocket case. // // TODO: For keepalive support the opposite operation is required; // pull the data out of the socket buffer and back into feersum. if (likely(c->rbuf && SvOK(c->rbuf) && SvCUR(c->rbuf))) { STRLEN rbuf_len; const char *rbuf_ptr = SvPV(c->rbuf, rbuf_len); IO *io = GvIOp(io_glob); assert(io != NULL); PerlIO_unread(IoIFP(io), (const void *)rbuf_ptr, rbuf_len); sv_setpvs(c->rbuf, ""); } stop_read_watcher(c); stop_read_timer(c); // don't stop write watcher in case there's outstanding data. } PUTBACK; FREETMPS; LEAVE; return 0; } MODULE = Feersum PACKAGE = Feersum PROTOTYPES: ENABLE void set_server_name_and_port(SV *self, SV *name, SV *port) PPCODE: { if (feer_server_name) SvREFCNT_dec(feer_server_name); feer_server_name = newSVsv(name); SvREADONLY_on(feer_server_name); if (feer_server_port) SvREFCNT_dec(feer_server_port); feer_server_port = newSVsv(port); SvREADONLY_on(feer_server_port); } void accept_on_fd(SV *self, int fd) PPCODE: { trace("going to accept on %d\n",fd); feersum_ev_loop = EV_DEFAULT; signal(SIGPIPE, SIG_IGN); ev_prepare_init(&ep, prepare_cb); ev_prepare_start(feersum_ev_loop, &ep); ev_check_init(&ec, check_cb); ev_check_start(feersum_ev_loop, &ec); ev_idle_init(&ei, idle_cb); ev_io_init(&accept_w, accept_cb, fd, EV_READ); } void unlisten (SV *self) PPCODE: { trace("stopping accept\n"); ev_prepare_stop(feersum_ev_loop, &ep); ev_check_stop(feersum_ev_loop, &ec); ev_idle_stop(feersum_ev_loop, &ei); ev_io_stop(feersum_ev_loop, &accept_w); } void request_handler(SV *self, SV *cb) PROTOTYPE: $& ALIAS: psgi_request_handler = 1 PPCODE: { if (unlikely(!SvOK(cb) || !SvROK(cb))) croak("can't supply an undef handler"); if (request_cb_cv) SvREFCNT_dec(request_cb_cv); request_cb_cv = newSVsv(cb); // copy so 5.8.7 overload magic sticks. request_cb_is_psgi = ix; trace("assigned %s request handler %p\n", request_cb_is_psgi?"PSGI":"Feersum", request_cb_cv); } void graceful_shutdown (SV *self, SV *cb) PROTOTYPE: $& PPCODE: { if (!IsCodeRef(cb)) croak("must supply a code reference"); if (unlikely(shutting_down)) croak("already shutting down"); shutdown_cb_cv = newSVsv(cb); trace("shutting down, handler=%p, active=%d\n", SvRV(cb), active_conns); shutting_down = 1; ev_io_stop(feersum_ev_loop, &accept_w); close(accept_w.fd); if (active_conns <= 0) { trace("shutdown is immediate\n"); dSP; ENTER; SAVETMPS; PUSHMARK(SP); call_sv(shutdown_cb_cv, G_EVAL|G_VOID|G_DISCARD|G_NOARGS|G_KEEPERR); PUTBACK; trace3("called shutdown handler\n"); SvREFCNT_dec(shutdown_cb_cv); shutdown_cb_cv = NULL; FREETMPS; LEAVE; } } double read_timeout (SV *self, ...) PROTOTYPE: $;$ CODE: { if (items <= 1) { RETVAL = read_timeout; } else if (items == 2) { SV *duration = ST(1); NV new_read_timeout = SvNV(duration); if (!(new_read_timeout > 0.0)) { croak("must set a positive (non-zero) value for the timeout"); } read_timeout = (double) new_read_timeout; } } OUTPUT: RETVAL void DESTROY (SV *self) PPCODE: { trace3("DESTROY server\n"); if (request_cb_cv) SvREFCNT_dec(request_cb_cv); } MODULE = Feersum PACKAGE = Feersum::Connection::Handle PROTOTYPES: ENABLE int fileno (feer_conn_handle *hdl) CODE: RETVAL = c->fd; OUTPUT: RETVAL void DESTROY (SV *self) ALIAS: Feersum::Connection::Reader::DESTROY = 1 Feersum::Connection::Writer::DESTROY = 2 PPCODE: { feer_conn_handle *hdl = sv_2feer_conn_handle(self, 0); if (hdl == NULL) { trace3("DESTROY handle (closed) class=%s\n", HvNAME(SvSTASH(SvRV(self)))); } else { struct feer_conn *c = (struct feer_conn *)hdl; trace3("DESTROY handle fd=%d, class=%s\n", c->fd, HvNAME(SvSTASH(SvRV(self)))); if (ix == 2) // only close the writer on destruction feersum_close_handle(aTHX_ c, 1); } } SV* read (feer_conn_handle *hdl, SV *buf, size_t len, ...) PROTOTYPE: $$$;$ PPCODE: { STRLEN buf_len = 0, src_len = 0; ssize_t offset; char *buf_ptr, *src_ptr; // optimizes for the "read everything" case. if (unlikely(items == 4) && SvOK(ST(3)) && SvIOK(ST(3))) offset = SvIV(ST(3)); else offset = 0; trace("read fd=%d : request len=%"Sz_uf" off=%"Ssz_df"\n", c->fd, (Sz)len, (Ssz)offset); if (unlikely(c->receiving <= RECEIVE_HEADERS)) // XXX as of 0.984 this is dead code croak("can't call read() until the body begins to arrive"); if (!SvOK(buf) || !SvPOK(buf)) { // force to a PV and ensure buffer space sv_setpvn(buf,"",0); SvGROW(buf, len+1); } if (unlikely(SvREADONLY(buf))) croak("buffer must not be read-only"); if (unlikely(len == 0)) XSRETURN_IV(0); // assumes undef buffer got allocated to empty-string buf_ptr = SvPV(buf, buf_len); if (likely(c->rbuf)) src_ptr = SvPV(c->rbuf, src_len); if (unlikely(len < 0)) len = src_len; if (unlikely(offset < 0)) offset = (-offset >= c->received_cl) ? 0 : c->received_cl + offset; if (unlikely(len + offset > src_len)) len = src_len - offset; trace("read fd=%d : normalized len=%"Sz_uf" off=%"Ssz_df" src_len=%"Sz_uf"\n", c->fd, (Sz)len, (Ssz)offset, (Sz)src_len); if (unlikely(!c->rbuf || src_len == 0 || offset >= c->received_cl)) { trace2("rbuf empty during read %d\n", c->fd); if (c->receiving == RECEIVE_SHUTDOWN) { XSRETURN_IV(0); } else { errno = EAGAIN; XSRETURN_UNDEF; } } if (likely(len == src_len && offset == 0)) { trace2("appending entire rbuf fd=%d\n", c->fd); sv_2mortal(c->rbuf); // allow pv to be stolen if (likely(buf_len == 0)) { sv_setsv(buf, c->rbuf); } else { sv_catsv(buf, c->rbuf); } c->rbuf = NULL; } else { src_ptr += offset; trace2("appending partial rbuf fd=%d len=%"Sz_uf" off=%"Ssz_df" ptr=%p\n", c->fd, len, offset, src_ptr); SvGROW(buf, SvCUR(buf) + len); sv_catpvn(buf, src_ptr, len); if (likely(items == 3)) { // there wasn't an offset param, throw away beginning sv_chop(c->rbuf, SvPVX(c->rbuf) + len); } } XSRETURN_IV(len); } STRLEN write (feer_conn_handle *hdl, ...) PROTOTYPE: $;$ CODE: { if (unlikely(c->responding != RESPOND_STREAMING)) croak("can only call write in streaming mode"); SV *body = (items == 2) ? ST(1) : &PL_sv_undef; if (unlikely(!body || !SvOK(body))) XSRETURN_IV(0); trace("write fd=%d c=%p, body=%p\n", c->fd, c, body); if (SvROK(body)) { SV *refd = SvRV(body); if (SvOK(refd) && SvPOK(refd)) { body = refd; } else { croak("body must be a scalar, scalar ref or undef"); } } (void)SvPV(body, RETVAL); if (c->is_http11) add_chunk_sv_to_wbuf(c, body); else add_sv_to_wbuf(c, body); conn_write_ready(c); } OUTPUT: RETVAL void write_array (feer_conn_handle *hdl, AV *abody) PROTOTYPE: $$ PPCODE: { if (unlikely(c->responding != RESPOND_STREAMING)) croak("can only call write in streaming mode"); trace("write_array fd=%d c=%p, abody=%p\n", c->fd, c, abody); I32 amax = av_len(abody); int i; if (c->is_http11) { for (i=0; i<=amax; i++) { SV *sv = fetch_av_normal(aTHX_ abody, i); if (likely(sv)) add_chunk_sv_to_wbuf(c, sv); } } else { for (i=0; i<=amax; i++) { SV *sv = fetch_av_normal(aTHX_ abody, i); if (likely(sv)) add_sv_to_wbuf(c, sv); } } conn_write_ready(c); } int seek (feer_conn_handle *hdl, ssize_t offset, ...) PROTOTYPE: $$;$ CODE: { int whence = SEEK_CUR; if (items == 3 && SvOK(ST(2)) && SvIOK(ST(2))) whence = SvIV(ST(2)); trace("seek fd=%d offset=%"Ssz_df" whence=%d\n", c->fd, offset, whence); if (unlikely(!c->rbuf)) { // handle is effectively "closed" RETVAL = 0; } else if (offset == 0) { RETVAL = 1; // stay put for any whence } else if (offset > 0 && (whence == SEEK_CUR || whence == SEEK_SET)) { STRLEN len; const char *str = SvPV_const(c->rbuf, len); if (offset > len) offset = len; sv_chop(c->rbuf, str + offset); RETVAL = 1; } else if (offset < 0 && whence == SEEK_END) { STRLEN len; const char *str = SvPV_const(c->rbuf, len); offset += len; // can't be > len since block is offset<0 if (offset == 0) { RETVAL = 1; // no-op, but OK } else if (offset > 0) { sv_chop(c->rbuf, str + offset); RETVAL = 1; } else { // past beginning of string RETVAL = 0; } } else { // invalid seek RETVAL = 0; } } OUTPUT: RETVAL int close (feer_conn_handle *hdl) PROTOTYPE: $ ALIAS: Feersum::Connection::Reader::close = 1 Feersum::Connection::Writer::close = 2 CODE: { assert(ix); RETVAL = feersum_close_handle(aTHX_ c, (ix == 2)); SvUVX(hdl_sv) = 0; } OUTPUT: RETVAL void _poll_cb (feer_conn_handle *hdl, SV *cb) PROTOTYPE: $$ ALIAS: Feersum::Connection::Reader::poll_cb = 1 Feersum::Connection::Writer::poll_cb = 2 PPCODE: { if (unlikely(ix < 1 || ix > 2)) croak("can't call _poll_cb directly"); else if (unlikely(ix == 1)) croak("poll_cb for reading not yet supported"); // TODO poll_read_cb if (c->poll_write_cb != NULL) { SvREFCNT_dec(c->poll_write_cb); c->poll_write_cb = NULL; } if (!SvOK(cb)) { trace("unset poll_cb ix=%d\n", ix); return; } else if (unlikely(!IsCodeRef(cb))) croak("must supply a code reference to poll_cb"); c->poll_write_cb = newSVsv(cb); conn_write_ready(c); } SV* response_guard (feer_conn_handle *hdl, ...) PROTOTYPE: $;$ CODE: RETVAL = feersum_conn_guard(aTHX_ c, (items==2) ? ST(1) : NULL); OUTPUT: RETVAL MODULE = Feersum PACKAGE = Feersum::Connection PROTOTYPES: ENABLE SV * start_streaming (struct feer_conn *c, SV *message, AV *headers) PROTOTYPE: $$\@ CODE: feersum_start_response(aTHX_ c, message, headers, 1); RETVAL = new_feer_conn_handle(aTHX_ c, 1); // RETVAL gets mortalized OUTPUT: RETVAL size_t send_response (struct feer_conn *c, SV* message, AV *headers, SV *body) PROTOTYPE: $$\@$ CODE: feersum_start_response(aTHX_ c, message, headers, 0); if (unlikely(!SvOK(body))) croak("can't send_response with an undef body"); RETVAL = feersum_write_whole_body(aTHX_ c, body); OUTPUT: RETVAL SV* _continue_streaming_psgi (struct feer_conn *c, SV *psgi_response) PROTOTYPE: $\@ CODE: { AV *av; int len = 0; if (IsArrayRef(psgi_response)) { av = (AV*)SvRV(psgi_response); len = av_len(av) + 1; } if (len == 3) { // 0 is "don't recurse" (i.e. don't allow another code-ref) feersum_handle_psgi_response(aTHX_ c, psgi_response, 0); RETVAL = &PL_sv_undef; } else if (len == 2) { SV *message = *(av_fetch(av,0,0)); SV *headers = *(av_fetch(av,1,0)); if (unlikely(!IsArrayRef(headers))) croak("PSGI headers must be an array ref"); feersum_start_response(aTHX_ c, message, (AV*)SvRV(headers), 1); RETVAL = new_feer_conn_handle(aTHX_ c, 1); // RETVAL gets mortalized } else { croak("PSGI response starter expects a 2 or 3 element array-ref"); } } OUTPUT: RETVAL void force_http10 (struct feer_conn *c) PROTOTYPE: $ ALIAS: force_http11 = 1 PPCODE: c->is_http11 = ix; SV * env (struct feer_conn *c) PROTOTYPE: $ CODE: RETVAL = newRV_noinc((SV*)feersum_env(aTHX_ c)); OUTPUT: RETVAL int fileno (struct feer_conn *c) CODE: RETVAL = c->fd; OUTPUT: RETVAL SV* response_guard (struct feer_conn *c, ...) PROTOTYPE: $;$ CODE: RETVAL = feersum_conn_guard(aTHX_ c, (items == 2) ? ST(1) : NULL); OUTPUT: RETVAL void DESTROY (struct feer_conn *c) PPCODE: { int i; trace("DESTROY connection fd=%d c=%p\n", c->fd, c); if (likely(c->rbuf)) SvREFCNT_dec(c->rbuf); if (c->wbuf_rinq) { struct iomatrix *m; while ((m = (struct iomatrix *)rinq_shift(&c->wbuf_rinq)) != NULL) { for (i=0; i < m->count; i++) { if (m->sv[i]) SvREFCNT_dec(m->sv[i]); } Safefree(m); } } if (likely(c->req)) { if (c->req->buf) SvREFCNT_dec(c->req->buf); Safefree(c->req); } if (likely(c->sa)) free(c->sa); safe_close_conn(c, "close at destruction"); if (c->poll_write_cb) SvREFCNT_dec(c->poll_write_cb); if (c->ext_guard) SvREFCNT_dec(c->ext_guard); active_conns--; if (unlikely(shutting_down && active_conns <= 0)) { ev_idle_stop(feersum_ev_loop, &ei); ev_prepare_stop(feersum_ev_loop, &ep); ev_check_stop(feersum_ev_loop, &ec); trace3("... was last conn, going to try shutdown\n"); if (shutdown_cb_cv) { PUSHMARK(SP); call_sv(shutdown_cb_cv, G_EVAL|G_VOID|G_DISCARD|G_NOARGS|G_KEEPERR); PUTBACK; trace3("... ok, called that handler\n"); SvREFCNT_dec(shutdown_cb_cv); shutdown_cb_cv = NULL; } } } MODULE = Feersum PACKAGE = Feersum BOOT: { feer_stash = gv_stashpv("Feersum", 1); feer_conn_stash = gv_stashpv("Feersum::Connection", 1); feer_conn_writer_stash = gv_stashpv("Feersum::Connection::Writer",0); feer_conn_reader_stash = gv_stashpv("Feersum::Connection::Reader",0); I_EV_API("Feersum"); psgi_ver = newAV(); av_extend(psgi_ver, 2); av_push(psgi_ver, newSViv(1)); av_push(psgi_ver, newSViv(1)); SvREADONLY_on((SV*)psgi_ver); psgi_serv10 = newSVpvs("HTTP/1.0"); SvREADONLY_on(psgi_serv10); psgi_serv11 = newSVpvs("HTTP/1.1"); SvREADONLY_on(psgi_serv11); Zero(&psgix_io_vtbl, 1, MGVTBL); psgix_io_vtbl.svt_get = psgix_io_svt_get; trace3("Feersum booted, iomatrix %lu " "(IOV_MAX=%u, FEERSUM_IOMATRIX_SIZE=%u), " "feer_req %lu, " "feer_conn %lu\n", (long unsigned int)sizeof(struct iomatrix), (unsigned int)IOV_MAX, (unsigned int)FEERSUM_IOMATRIX_SIZE, (long unsigned int)sizeof(struct feer_req), (long unsigned int)sizeof(struct feer_conn) ); } Feersum-1.410/lib/000755 000765 000024 00000000000 13762625540 014525 5ustar00audreytstaff000000 000000 Feersum-1.410/Makefile.PL000644 000765 000024 00000006374 13762624365 015747 0ustar00audreytstaff000000 000000 use 5.008007; use ExtUtils::MakeMaker 6.51; use EV::MakeMaker qw/ev_args/; { package MY; sub test_via_harness { my($self, $perl, $tests) = @_; local $_ = $self->SUPER::test_via_harness($perl, $tests); s/PERL_DL_NONLAZY=1//g; return $_; } sub test_via_script { my($self, $perl, $tests) = @_; local $_ = $self->SUPER::test_via_script($perl, $tests); s/PERL_DL_NONLAZY=1//g; return $_; } } my $otherldflags = ''; my $convert_deps = 1; if ($ARGV[0] =~ /^-DEBUG=?(\d*)$/) { my $n = $1 || 1; my $opt = "OPTIMIZE=-DDEBUG=$n -g"; # with 5.12.1 and the -DDEBUGGING flag: # dyld: Symbol not found: _Perl_pad_sv $opt .= ($] >= 5.012_001) ? '' : ' -DDEBUGGING'; $ARGV[0] = $opt; } elsif ($ARGV[0] eq '-PROFILE') { shift @ARGV; $ARGV[0] = "OPTIMIZE=-g -fprofile-arcs -ftest-coverage"; $otherldflags = '-lgcov'; } elsif ($ARGV[0] eq '-PROFILEUSE') { $ARGV[0] = "OPTIMIZE=-g -O3 -fprofile-use"; $otherldflags = '-fprofile-use'; } elsif ($ARGV[0] eq '-CPAN') { $convert_deps = 0; } # Convert optional Plack and other dependencies to a real dependency if it's # present at build-time. (Fix: # https://rt.cpan.org/Public/Bug/Display.html?id=65239) my %want = ( 'Plack' => 0.995, 'JSON::XS' => 2.0, 'Test::LeakTrace' => 0.13, 'Test::TCP' => 1.12, 'Test::SharedFork'=> 0.25, ); my %have; if ($convert_deps) { local $@; while (my ($pkg,$ver) = each %want) { $have{$pkg} = eval "require $pkg; \$$pkg\::VERSION >= $ver"; } } # Set this to false if you get core-dumps. Gives a pretty good perf boost for # simple responses. Look for FEERSUM_STEAL in the code to see what this does. # In a nutshell: certain temporary values passed in as the body of a response # have their string-value "stolen". This very much doesn't work under threaded # perl (5.8.7 and 5.12.1 were tested) and probably doesn't work prior to # 5.12.0. use Config; my $steal = ($] >= 5.012 && !defined($Config{useithreads})); WriteMakefile(ev_args( NAME => 'Feersum', VERSION_FROM => 'lib/Feersum.pm', ABSTRACT_FROM => 'lib/Feersum.pm', AUTHOR => 'Jeremy Stashewsky ', LICENSE => 'perl', CONFIGURE_REQUIRES => { 'EV' => 4.00, 'ExtUtils::MakeMaker' => 6.51, }, BUILD_REQUIRES => { 'AnyEvent' => 5.261, 'Guard' => 1.012, 'Test::More' => 0.94, 'Test::Fatal' => 0.003, map { $_ => $want{$_} } grep { /^Test::/ && $have{$_} } keys %want }, PREREQ_PM => { 'EV' => 4.00, 'Scalar::Util' => 1.19, 'HTTP::Entity::Parser' => '0.20', map { $_ => $want{$_} } grep { !/^Test::/ && $have{$_} } keys %want }, META_MERGE => { recommends => { map { $_ => $want{$_} } grep { !$have{$_} } keys %want }, resources => { repository => 'git://github.com/stash/Feersum.git', license => 'http://dev.perl.org/licenses/', }, 'no_index' => {directory => ['eg','picohttpparser-git']}, }, LIBS => [''], EXE_FILES => ['bin/feersum'], DEFINE => ($steal ? '-DFEERSUM_STEAL' : ''), INC => '-I.', dynamic_lib => {OTHERLDFLAGS => $otherldflags}, )); Feersum-1.410/eg/000755 000765 000024 00000000000 13762625540 014352 5ustar00audreytstaff000000 000000 Feersum-1.410/META.json000644 000765 000024 00000003104 13762625540 015376 0ustar00audreytstaff000000 000000 { "abstract" : "A PSGI engine for Perl based on EV/libev", "author" : [ "Jeremy Stashewsky " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Feersum", "no_index" : { "directory" : [ "t", "inc", "eg", "picohttpparser-git" ] }, "prereqs" : { "build" : { "requires" : { "AnyEvent" : "5.261", "Guard" : "1.012", "Test::Fatal" : "0.003", "Test::LeakTrace" : "0.13", "Test::More" : "0.94", "Test::SharedFork" : "0.25", "Test::TCP" : "1.12" } }, "configure" : { "requires" : { "EV" : "4", "ExtUtils::MakeMaker" : "6.51" } }, "runtime" : { "recommends" : { "JSON::XS" : "2" }, "requires" : { "EV" : "4", "HTTP::Entity::Parser" : "0.20", "Plack" : "0.995", "Scalar::Util" : "1.19" } } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "type" : "git", "url" : "git://github.com/stash/Feersum.git" } }, "version" : "1.410", "x_serialization_backend" : "JSON::PP version 2.97001" } Feersum-1.410/eg/app.psgi000755 000765 000024 00000000422 13762624365 016023 0ustar00audreytstaff000000 000000 #!perl # # Compare and contrast to app.feersum # my $counter = 0; sub { my $env = shift; my $n = $counter++; return [200, [ 'Content-Type' => 'text/plain', 'Connection' => 'close', ], ["Hello customer number 0x",sprintf('%08x',$n),"\n"]]; }; Feersum-1.410/eg/hello.pl000755 000765 000024 00000001224 13762624365 016020 0ustar00audreytstaff000000 000000 #!/usr/bin/env perl use warnings; use strict; use blib; $SIG{PIPE} = 'IGNORE'; use Feersum; use IO::Socket::INET; my $socket = IO::Socket::INET->new( LocalAddr => 'localhost:5000', Proto => 'tcp', Listen => 1024, Blocking => 0, ReuseAddr => 1, ); my $counter = 0; my $evh = Feersum->new(); $evh->use_socket($socket); $evh->request_handler(sub { my $r = shift; my $n = $counter++; my $env = $r->env; $r->send_response("200 OK", [ 'Content-Type' => 'text/plain', 'Connection' => 'close', ], \"Hello customer number $n\n"); }); my $t = EV::timer 1, 1, sub { print "served $counter\n"; }; EV::run; Feersum-1.410/eg/oneshot.pl000755 000765 000024 00000001245 13762624365 016377 0ustar00audreytstaff000000 000000 #!/usr/bin/env perl use warnings; use strict; use blib; $SIG{PIPE} = 'IGNORE'; use Feersum; use IO::Socket::INET; my $socket = IO::Socket::INET->new( LocalAddr => 'localhost:5000', Proto => 'tcp', Listen => 1024, Blocking => 0, ReuseAddr => 1, ); my $evh = Feersum->new(); $evh->use_socket($socket); $evh->request_handler(sub { my $r = shift; my $n = "only"; my $w = $r->start_streaming("200 OK", [ 'Content-Type' => 'text/plain', 'Connection' => 'close', ]); $w->write("Hello customer number "); $w->write(\$n); $w->write("\n"); $w->close(); $evh->graceful_shutdown(sub { EV::break }); }); EV::run; Feersum-1.410/eg/app.feersum000755 000765 000024 00000000653 13762624365 016535 0ustar00audreytstaff000000 000000 #!perl # # Compare and contrast to app.psgi # my $counter = 0; sub { my $r = shift; my $n = $counter++; # loading the env is optional under Feersum. For a "fair" speed # comparison to app.psgi, uncomment this line: # my $env = $r->env(); $r->send_response(200, [ 'Content-Type' => 'text/plain', 'Connection' => 'close', ], [\"Hello customer number 0x",sprintf('%08x',$n),\"\n"]); }; Feersum-1.410/eg/chat.feersum000755 000765 000024 00000005160 13762624365 016672 0ustar00audreytstaff000000 000000 #!perl use warnings; use strict; use JSON::XS; use EV; use Scalar::Util qw/weaken/; use HTML::Entities qw/encode_entities/; use URI::Escape qw/uri_unescape/; my $clients = 0; my @handles; my @timers; my @html_hdrs = ( 'Content-Type' => 'text/html; charset=UTF-8', 'Cache-Control' => 'no-cache, no-store, private', 'Pragma' => 'no-cache', ); sub show_chat { my ($r,$client) = @_; $r->send_response(200, \@html_hdrs, < Chat! EOHTML } sub show_form { my ($r, $client, $nick) = @_; $r->send_response(200, \@html_hdrs, < Chat!
Nick:
Say:
EOHTML } sub start_stream { my ($r, $client) = @_; my $w = $r->start_streaming(200, \@html_hdrs); $handles[$client] = $w; weaken $w; $timers[$client] = EV::timer 1,1,sub { $w->write('') if $w; }; $w->write(<

Hello! (connection $client)

EOH } sub broadcast { my $kv = shift; my $client = $kv->{client}; $kv->{nick} ||= "anon$client"; $kv->{nick} = encode_entities(uri_unescape($kv->{nick})); $kv->{say} ||= '*wants to say something*'; $kv->{say} = encode_entities(uri_unescape($kv->{say})); my $msg = \"

$kv->{nick}: $kv->{say}

"; warn $$msg."\n"; for my $i (1 .. $clients) { my $w = $handles[$i]; next unless $w; eval { $w->write($msg) }; if ($@) { warn $@; $handles[$i] = undef } } } my $app = sub { my $r = shift; my $env = $r->env; my $path = $env->{PATH_INFO}; if ($path eq '/post' && $env->{REQUEST_METHOD} eq 'POST') { my $input = delete $env->{'psgi.input'}; my $body = ''; $input->read($body, $env->{CONTENT_LENGTH}); my %kv = map { split('=',$_,2) } split('&',$body); my $t; $t = EV::timer 0.00001, 0, sub{ broadcast(\%kv); undef $t; }; show_form($r,$kv{client},$kv{nick}); } elsif ($path =~ m{^/form/(\d+)$}) { my $client = $1; show_form($r,$client,''); } elsif ($path =~ m{^/chat/(\d+)$}) { my $client = $1; start_stream($r,$client); } else { my $client = ++$clients; show_chat($r,$client); } }; Feersum-1.410/lib/Feersum.pm000644 000765 000024 00000052566 13762624772 016515 0ustar00audreytstaff000000 000000 package Feersum; use 5.008007; use strict; use warnings; use EV (); use Carp (); our $VERSION = '1.410'; require Feersum::Connection; require Feersum::Connection::Handle; require XSLoader; XSLoader::load('Feersum', $VERSION); # numify as per # http://www.dagolden.com/index.php/369/version-numbers-should-be-boring/ $VERSION = eval $VERSION; ## no critic (StringyEval, ConstantVersion) our $INSTANCE; sub new { unless ($INSTANCE) { $INSTANCE = bless {}, __PACKAGE__; } $SIG{PIPE} = 'IGNORE'; return $INSTANCE; } *endjinn = *new; sub use_socket { my ($self, $sock) = @_; $self->{socket} = $sock; my $fd = fileno $sock; $self->accept_on_fd($fd); my $host = eval { $sock->sockhost() } || 'localhost'; my $port = eval { $sock->sockport() } || 80; ## no critic (MagicNumbers) $self->set_server_name_and_port($host,$port); return; } # overload this to catch Feersum errors and exceptions thrown by request # callbacks. sub DIED { Carp::confess "DIED: $@"; } 1; __END__ =head1 NAME Feersum - A PSGI engine for Perl based on EV/libev =head1 SYNOPSIS use Feersum; my $ngn = Feersum->endjinn; # singleton $ngn->use_socket($io_socket); # register a PSGI handler $ngn->psgi_request_handler(sub { my $env = shift; return [200, ['Content-Type'=>'text/plain'], ["You win one cryptosphere!\n"]]; }); # register a Feersum handler: $ngn->request_handler(sub { my $req = shift; my $t; $t = EV::timer 2, 0, sub { $req->send_response( 200, ['Content-Type' => 'text/plain'], \"You win one cryptosphere!\n" ); undef $t; }; }); =head1 DESCRIPTION Feersum is an HTTP server built on L. It fully supports the PSGI 1.03 spec including the C interface and is compatible with Plack. PSGI 1.1, which has yet to be published formally, is also supported. Feersum also has its own "native" interface which is similar in a lot of ways to PSGI, but is B with PSGI or PSGI middleware. Feersum uses a single-threaded, event-based programming architecture to scale and can handle many concurrent connections efficiently in both CPU and RAM. It skips doing a lot of sanity checking with the assumption that a "front-end" HTTP/HTTPS server is placed between it and the Internet. =head2 How It Works All of the request-parsing and I/O marshalling is done using C or XS code. HTTP parsing is done by picohttpparser, which is the core of L. The network I/O is done via the libev library. This is made possible by C, which allows extension writers to link against the same libev that C is using. This means that one can write an evented app using C or L from Perl that completely co-operates with the server's event loop. Since the Perl "app" (handler) is executed in the same thread as the event loop, one need to be careful to not block this thread. Standard techniques include using L or L idle and timer watchers, using L to multitask, and using sub-processes to do heavy lifting (e.g. L and L). Feersum also attempts to do as little copying of data as possible. Feersum uses the low-level C system call to avoid having to copy data into a buffer. For response data, references to scalars are kept in order to avoid copying the string values (once the data is written to the socket, the reference is dropped and the data is garbage collected). A trivial hello-world handler can process in excess of 5000 requests per second on a 4-core Intel(R) Xeon(R) E5335 @ 2.00GHz using TCPv4 on the loopback interface, OS Ubuntu 6.06LTS, Perl 5.8.7. Your mileage will likely vary. For even faster results, Feersum can support very simple pre-forking (See L, L or L for details). =head1 INTERFACE There are two handler interfaces for Feersum: The PSGI handler interface and the "Feersum-native" handler interface. The PSGI handler interface is fully PSGI 1.03 compatible and supports C. The C and C features of PSGI 1.1 are also supported. The Feersum-native handler interface is "inspired by" PSGI, but does some things differently for speed. Feersum will use "Transfer-Encoding: chunked" for HTTP/1.1 clients and "Connection: close" streaming as a fallback. Technically "Connection: close" streaming isn't part of the HTTP/1.0 or 1.1 spec, but many browsers and agents support it anyway. Currently POST/PUT does not stream input, but read() can be called on C to get the body (which has been buffered up before the request callback is called and therefore will never block). Likely C will change to raise EAGAIN responses and allow for a callback to be registered on the arrival of more data. (The C env var is set to reflect this). =head2 PSGI interface Feersum fully supports the PSGI 1.03 spec including C. See also L, which provides a way to use Feersum with L and L. Call C<< psgi_request_handler($app) >> to register C<$app> as a PSGI handler. my $app = do $filename; Feersum->endjinn->psgi_request_handler($app); The env hash passed in will always have the following keys in addition to dynamic ones: psgi.version => [1,0], psgi.nonblocking => 1, psgi.multithread => '', # i.e. false psgi.multiprocess => '', psgi.streaming => 1, psgi.errors => \*STDERR, SCRIPT_NAME => "", Feersum adds these extensions (see below for info) psgix.input.buffered => 1, psgix.output.buffered => 1, psgix.body.scalar_refs => 1, psgix.output.guard => 1, psgix.io => \$magical_io_socket, Note that SCRIPT_NAME is always blank (but defined). PATH_INFO will contain the path part of the requested URI. For requests with a body (e.g. POST) C will contain a valid file-handle. Feersum currently passes C for psgi.input when there is no body to avoid unnecessary work. my $r = delete $env->{'psgi.input'}; $r->read($body, $env->{CONTENT_LENGTH}); # optional: choose to stop receiving further input, discard buffers: $r->close(); The C interface is fully supported, including the writer-object C callback feature defined in PSGI 1.03. B. Feersum calls the poll_cb callback after all data has been flushed out and the socket is write-ready. The data is buffered until the callback returns at which point it will be immediately flushed to the socket. my $app = sub { my $env = shift; return sub { my $respond = shift; my $w = $respond->([ 200, ['Content-Type' => 'application/json'] ]); my $n = 0; $w->poll_cb(sub { $_[0]->write(get_next_chunk()); # will also unset the poll_cb: $_[0]->close if ($n++ >= 100); }); }; }; Note that C<< $w->close() >> will be called when the last reference to the writer is dropped. =head2 PSGI extensions =over 4 =item psgix.body.scalar_refs Scalar refs in the response body are supported, and is indicated as an via the B env variable. Passing by reference is B faster than copying a value onto the return stack or into an array. It's also very useful when broadcasting a message to many connected clients. This is a Feersum-native feature exposed to PSGI apps; very few other PSGI handlers will support this. =item psgix.output.buffered Calls to C<< $w->write() >> will never block. This behaviour is indicated by B in the PSGI env hash. =item psgix.input.buffered C is defined as part of PSGI 1.1. It means that calls to read on the input handle will never block because the complete input has been buffered in some way. Feersum currently buffers the entire input in memory calling the callback. B Likely, a C method similar to how the writer handle works could be registered to have input "pushed" to the app. =item psgix.output.guard The streaming responder has a C method that can be used to attach a guard to the request. When the request completes (all data has been written to the socket and the socket has been closed) the guard will trigger. This is an alternate means to doing a "write completion" callback via C that should be more efficient. An analogy is the "on_drain" handler in L. A "guard" in this context is some object that will do something interesting in its DESTROY/DEMOLISH method. For example, L. =item psgix.io The raw socket extension B is provided in order to support L and websockets. C is defined as part of PSGI 1.1. To obtain the L corresponding to this connection, read this environment variable. The underlying file descriptor will have C, C, C enabled and C disabled. PSGI apps B use a C response so that Feersum doesn't try to flush and close the connection. Additionally, the "respond" parameter to the streaming callback B be called for the same reason. my $env = shift; return sub { my $fh = $env->{'psgix.io'}; syswrite $fh, }; =back =head2 The Feersum-native interface The Feersum-native interface is inspired by PSGI, but is inherently B with it. Apps written against this API will not work as a PSGI app. B, at which point the interface API will become stable and will only change for bug fixes or new additions. The "stable" and will retain backwards compatibility until at least the next major release. The main entry point is a sub-ref passed to C. This sub is passed a reference to an object that represents an HTTP connection. Currently the request_handler is called during the "check" and "idle" phases of the EV event loop. The handler is always called after request headers have been read. Currently, the handler will B be called after a full request entity has been received for POST/PUT/etc. The simplest way to send a response is to use C: my $req = shift; $req->send_response(200, \@headers, ["body ", \"parts"]); Or, if the app has everything packed into a single scalar already, just pass it in by reference. my $req = shift; $req->send_response(200, \@headers, \"whole body"); Both of the above will generate C header (replacing any that were pre-defined in C<@headers>). An environment hash is easy to obtain, but is a method call instead of a parameter to the callback. (In PSGI, there is no $req object; the env hash is the first parameter to the callback). The hash contains the same items as it would for a PSGI handler (see above for those). my $req = shift; my $env = $req->env(); To read input from a POST/PUT, use the C item of the env hash. if ($req->{REQUEST_METHOD} eq 'POST') { my $body = ''; my $r = delete $env->{'psgi.input'}; $r->read($body, $env->{CONTENT_LENGTH}); # optional: $r->close(); } Starting a response in stream mode enables the C method (which really acts more like a buffered 'print'). Calls to C will never block. my $req = shift; my $w = $req->start_streaming(200, \@headers); $w->write(\"this is a reference to some shared chunk\n"); $w->write("regular scalars are OK too\n"); $w->close(); # close off the stream The writer object supports C as also specified in PSGI 1.03. Feersum will call the callback only when all data has been flushed out at the socket level. Use C or unset the handler (C<< $w->poll_cb(undef) >>) to stop the callback from getting called. my $req = shift; my $w = $req->start_streaming( "200 OK", ['Content-Type' => 'application/json']); my $n = 0; $w->poll_cb(sub { # $_[0] is a copy of $w so a closure doesn't need to be made $_[0]->write(get_next_chunk()); $_[0]->close if ($n++ >= 100); }); Note that C<< $w->close() >> will be called when the last reference to the writer is dropped. =head1 METHODS These are methods on the global Feersum singleton. =over 4 =item C<< new() >> =item C<< endjinn() >> Returns the C singleton. Takes no parameters. =item C<< use_socket($sock) >> Use the file-descriptor attached to a listen-socket to accept connections. TLS sockets are B supported nor are they detected. Feersum needs to use the socket at a low level and will ignore any encryption that has been established (data is always sent in the clear). The intented use of Feersum is over localhost-only sockets. A reference to C<$sock> is kept as C<< Feersum->endjinn->{socket} >>. =item C<< accept_on_fd($fileno) >> Use the specified fileno to accept connections. May be used as an alternative to C. =item C<< unlisten() >> Stop listening to the socket specified by use_socket or accept_on_fd. =item C<< request_handler(sub { my $req = shift; ... }) >> Sets the global request handler. Any previous handler is replaced. The handler callback is passed a L object. B: if the request has an entity body then the handler will be called B after receiving the body in its entirety. The headers *must* specify a Content-Length of the body otherwise the request will be rejected. The maximum size is hard coded to 2147483647 bytes (this may be considered a bug). =item C<< psgi_request_handler(sub { my $env = shift; ... }) >> Like request_handler, but assigns a PSGI handler instead. =item C<< read_timeout() >> =item C<< read_timeout($duration) >> Get or set the global read timeout. Feersum will wait about this long to receive all headers of a request (within the tollerances provided by libev). If an entity body is part of the request (e.g. POST or PUT) it will wait this long between successful C system calls. =item C<< graceful_shutdown(sub { .... }) >> Causes Feersum to initiate a graceful shutdown of all outstanding connections. No new connections will be accepted. The reference to the socket provided in use_socket() is kept. The sub parameter is a completion callback. It will be called when all connections have been flushed and closed. This allows one to do something like this: my $cv = AE::cv; my $death = AE::timer 2.5, 0, sub { fail "SHUTDOWN TOOK TOO LONG"; exit 1; }; Feersum->endjinn->graceful_shutdown(sub { pass "all gracefully shut down, supposedly"; undef $death; $cv->send; }); $cv->recv; =item C<< DIED >> Not really a method so much as a static function. Works similar to EV's/AnyEvent's error handler. To install a handler: no strict 'refs'; *{'Feersum::DIED'} = sub { warn "nuts $_[0]" }; Will get called for any errors that happen before the request handler callback is called, when the request handler callback throws an exception and potentially for other not-in-a-request-context errors. It will not get called for read timeouts that occur while waiting for a complete header (and also, until Feersum supports otherwise, time-outs while waiting for a request entity body). Any exceptions thrown in the handler will generate a warning and not propagated. =item C<< set_server_name_and_port($host,$port) >> Override Feersum's notion of what SERVER_HOST and SERVER_PORT should be. =back =cut =head1 GRITTY DETAILS =head2 Compile Time Options There are a number of constants at the top of Feersum.xs. If you change any of these, be sure to note that in any bug reports. =over 4 =item MAX_HEADERS Defaults to 64. Controls how many headers can be present in an HTTP request. If a request exceeds this limit, a 400 response is given and the app handler does not run. =item MAX_HEADER_NAME_LEN Defaults to 128. Controls how long the name of each header can be. If a request exceeds this limit, a 400 response is given and the app handler does not run. =item MAX_BODY_LEN Defaults to ~2GB. Controls how large the body of a POST/PUT/etc. can be when that request has a C header. If a request exceeds this limit, a 413 response is given and the app handler does not run. See also BUGS =item READ_BUFSZ =item READ_INIT_FACTOR =item READ_GROW_FACTOR READ_BUFSZ defaults to 4096, READ_INIT_FACTOR 2 and READ_GROW_FACTOR 8. Together, these tune how data is read for a request. Read buffers start out at READ_INIT_FACTOR * READ_BUFSZ bytes. If another read is needed and the buffer is under READ_BUFSZ bytes then the buffer gets an additional READ_GROW_FACTOR * READ_BUFSZ bytes. The trade-off with the grow factor is memory usage vs. system calls. =item AUTOCORK_WRITES Controls how response data is written to sockets. If enabled (the default) the event loop is used to wait until the socket is writable, otherwise a write is performed immediately. In either case, non-blocking writes are used. Using the event loop is "nicer" but perhaps introduces latency, hence this option. =item FLASH_SOCKET_POLICY_SUPPORT =item FLASH_SOCKET_POLICY FLASH_SOCKET_POLICY_SUPPORT defaults to disabled. When it's enabled, Feersum will detect a Flash C<< >> packet and respond with the FLASH_SOCKET_POLICY string. The default FLASH_SOCKET_POLICY string looks like this: Since that's fairly wide-open, you may not wish to enable FLASH_SOCKET_POLICY_SUPPORT. Note that this feature likely won't work if you use a front-end HTTP server (e.g. nginx) since the request isn't valid HTTP. =item FEERSUM_IOMATRIX_SIZE Controls the size of the main write-buffer structure in Feersum. Making this value lower will use slightly less memory per connection at the cost of speed (and vice-versa for raising the value). The effect is most noticeable when you're app is making a lot of sparce writes. The default of 64 generally keeps usage under 4k per connection on full 64-bit platforms when you take into account the other connection and request structures. B: FEERSUM_IOMATRIX_SIZE cannot exceed your OS's defined IOV_MAX or UIO_MAXIOV constant. Solaris defines IOV_MAX to be 16, making it the default on that platform. Linux and OSX seem to set this at 1024. =item FEERSUM_STEAL For non-threaded perls >= 5.12.0, this defaults to enabled. When enabled, Feersum will "steal" the contents of temporary lexical scalars used for response bodies. The scalars become C as a result, but due to them being temps they likely aren't used again anyway. Stealing saves the time and memory needed to make a copy of that scalar, resulting in a mild to moderate performance boost. This egregious hack only extends to non-magical, string, C scalars. If it breaks for your new version of perl, please send stash a note (or a pull request!) on github. Worth noting is that a similar zero-copy effect can be achieved by using the C feature. =back =head1 BUGS Please report bugs using http://github.com/stash/Feersum/issues/ Keep-alive is ignored completely. Currently there's no way to limit the request entity length of a B POST/PUT/etc. This could lead to a DoS attack on a Feersum server. Suggested remedy is to only run Feersum behind some other web server and to use that to limit the entity size. Although not explicitly a bug, the following may cause undesirable behavior. Feersum will have set SIGPIPE to be ignored by the time your handler gets called. If your handler needs to detect SIGPIPE, be sure to do a C (L) to make it active just during the necessary scope. =head1 SEE ALSO http://en.wikipedia.org/wiki/Feersum_Endjinn Feersum Git: C C picohttpparser Git: C C =head1 AUTHOR Jeremy Stashewsky, C<< stash@cpan.org >> =head1 THANKS Tatsuhiko Miyagawa for PSGI and Plack. Marc Lehmann for EV and AnyEvent (not to mention JSON::XS and Coro). Kazuho Oku for picohttpparser. Luke Closs (lukec), Scott McWhirter (konobi), socialtexters and van.pm for initial feedback and ideas. Audrey Tang and Graham Termarsch for XS advice. Hans Dieter Pearcey (confound) for docs and packaging guidance. For bug reports: Chia-liang Kao (clkao), Lee Aylward (leedo) Audrey Tang (au) for flash socket policy support. =head1 COPYRIGHT AND LICENSE Copyright (C) 2011 by Jeremy Stashewsky Portions Copyright (C) 2010 Socialtext Inc. 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.7 or, at your option, any later version of Perl 5 you may have available. picohttpparser is Copyright 2009 Kazuho Oku. It is released under the same terms as Perl itself. =cut Feersum-1.410/lib/Plack/000755 000765 000024 00000000000 13762625540 015557 5ustar00audreytstaff000000 000000 Feersum-1.410/lib/Feersum/000755 000765 000024 00000000000 13762625540 016133 5ustar00audreytstaff000000 000000 Feersum-1.410/lib/Feersum/Runner.pm000644 000765 000024 00000014551 13762624365 017754 0ustar00audreytstaff000000 000000 package Feersum::Runner; use warnings; use strict; use EV; use Feersum; use Socket qw/SOMAXCONN/; use POSIX (); use Scalar::Util qw/weaken/; use Carp qw/carp croak/; use constant DEATH_TIMER => 5.0; # seconds use constant DEATH_TIMER_INCR => 2.0; # seconds use constant DEFAULT_HOST => 'localhost'; use constant DEFAULT_PORT => 5000; our $INSTANCE; sub new { ## no critic (RequireArgUnpacking) my $c = shift; croak "Only one Feersum::Runner instance can be active at a time" if $INSTANCE && $INSTANCE->{running}; $INSTANCE = bless {quiet=>1, @_, running=>0}, $c; return $INSTANCE; } sub DESTROY { local $@; my $self = shift; if (my $f = $self->{endjinn}) { $f->request_handler(sub{}); $f->unlisten(); } $self->{_quit} = undef; return; } sub _prepare { my $self = shift; $self->{listen} ||= [ ($self->{host}||DEFAULT_HOST).':'.($self->{port}||DEFAULT_PORT) ]; croak "Feersum doesn't support multiple 'listen' directives yet" if @{$self->{listen}} > 1; my $listen = shift @{$self->{listen}}; my $sock; if ($listen =~ m#^/\w#) { require IO::Socket::UNIX; unlink $listen if -S $listen; my $saved = umask(0); $sock = IO::Socket::UNIX->new( Local => $listen, Listen => SOMAXCONN, ); umask($saved); croak "couldn't bind to socket: $!" unless $sock; $sock->blocking(0) || croak "couldn't unblock socket: $!"; } else { require IO::Socket::INET; $sock = IO::Socket::INET->new( LocalAddr => $listen, ReuseAddr => 1, Proto => 'tcp', Listen => SOMAXCONN, Blocking => 0, ); croak "couldn't bind to socket: $!" unless $sock; } $self->{sock} = $sock; my $f = Feersum->endjinn; $f->use_socket($sock); if ($self->{options}) { # Plack::Runner puts these here $self->{pre_fork} = delete $self->{options}{pre_fork}; } $self->{endjinn} = $f; return; } # for overriding: sub assign_request_handler { ## no critic (RequireArgUnpacking) return $_[0]->{endjinn}->request_handler($_[1]); } sub run { my $self = shift; weaken $self; $self->{quiet} or warn "Feersum [$$]: starting...\n"; $self->_prepare(); my $app = shift || delete $self->{app}; if (!$app && $self->{app_file}) { local ($@, $!); $app = do $self->{app_file}; warn "couldn't parse $self->{app_file}: $@" if $@; warn "couldn't do $self->{app_file}: $!" if ($! && !defined $app); warn "couldn't run $self->{app_file}: didn't return anything" unless $app; } die "app not defined or failed to compile" unless $app; $self->assign_request_handler($app); undef $app; $self->{_quit} = EV::signal 'QUIT', sub { $self->quit }; $self->_start_pre_fork if $self->{pre_fork}; EV::run; $self->{quiet} or warn "Feersum [$$]: done\n"; $self->DESTROY(); return; } sub _fork_another { my ($self, $slot) = @_; weaken $self; my $pid = fork; croak "failed to fork: $!" unless defined $pid; unless ($pid) { EV::default_loop()->loop_fork; $self->{quiet} or warn "Feersum [$$]: starting\n"; delete $self->{_kids}; delete $self->{pre_fork}; eval { EV::run; }; ## no critic (RequireCheckingReturnValueOfEval) carp $@ if $@; POSIX::exit($@ ? -1 : 0); ## no critic (ProhibitMagicNumbers) } $self->{_n_kids}++; $self->{_kids}[$slot] = EV::child $pid, 0, sub { my $w = shift; $self->{quiet} or warn "Feersum [$$]: child $pid exited ". "with rstatus ".$w->rstatus."\n"; $self->{_n_kids}--; if ($self->{_shutdown}) { EV::break(EV::BREAK_ALL()) unless $self->{_n_kids}; return; } $self->_fork_another(); }; return; } sub _start_pre_fork { my $self = shift; POSIX::setsid(); $self->{_kids} = []; $self->{_n_kids} = 0; $self->_fork_another($_) for (1 .. $self->{pre_fork}); $self->{endjinn}->unlisten(); return; } sub quit { my $self = shift; return if $self->{_shutdown}; $self->{_shutdown} = 1; $self->{quiet} or warn "Feersum [$$]: shutting down...\n"; my $death = DEATH_TIMER; if ($self->{_n_kids}) { # in parent, broadcast SIGQUIT to the group (not self) kill 3, -$$; ## no critic (ProhibitMagicNumbers) $death += DEATH_TIMER_INCR; } else { # in child or solo process $self->{endjinn}->graceful_shutdown(sub { POSIX::exit(0) }); } $self->{_death} = EV::timer $death, 0, sub { POSIX::exit(1) }; return; } 1; __END__ =head1 NAME Feersum::Runner - feersum script core =head1 SYNOPSIS use Feersum::Runner; my $runner = Feersum::Runner->new( listen => 'localhost:5000', pre_fork => 0, quiet => 1, app_file => 'app.feersum', ); $runner->run($feersum_app); =head1 DESCRIPTION Much like L, but with far fewer options. =head1 METHODS =over 4 =item C<< Feersum::Runner->new(%params) >> Returns a Feersum::Runner singleton. Params are only applied for the first invocation. =over 8 =item listen Listen on this TCP socket (C format). =item pre_fork Fork this many worker processes. The fork is run immediately at startup and after the app is loaded (i.e. in the C method). =item quiet Don't be so noisy. (default: on) =item app_file Load this filename as a native feersum app. =back =item C<< $runner->run($feersum_app) >> Run Feersum with the specified app code reference. Note that this is not a PSGI app, but a native Feersum app. =item C<< $runner->assign_request_handler($subref) >> For sub-classes to override, assigns an app handler. (e.g. L). By default, this assigns a Feersum-native (and not PSGI) handler. =item C<< $runner->quit() >> Initiate a graceful shutdown. A signal handler for SIGQUIT will call this method. =back =head1 AUTHOR Jeremy Stashewsky, C<< stash@cpan.org >> =head1 COPYRIGHT AND LICENSE Copyright (C) 2010 by Jeremy Stashewsky & Socialtext Inc. 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.7 or, at your option, any later version of Perl 5 you may have available. =cut Feersum-1.410/lib/Feersum/Connection/000755 000765 000024 00000000000 13762625540 020232 5ustar00audreytstaff000000 000000 Feersum-1.410/lib/Feersum/Connection.pm000644 000765 000024 00000012472 13762624365 020602 0ustar00audreytstaff000000 000000 package Feersum::Connection; use warnings; use strict; use Carp qw/croak/; use IO::Socket::INET; sub new { croak "Cannot instantiate Feersum::Connection directly"; } sub read_handle { croak "read_handle is deprecated; use psgi.input instead"; } sub write_handle { croak "write_handle is deprecated; ". "use return value from start_streaming instead"; } sub start_response { croak "start_response is deprecated; ". "use start_streaming() or start_whole_response() instead"; } sub initiate_streaming { croak "initiate_streaming is deprecated; ". "use start_streaming() and its return value instead"; } sub _initiate_streaming_psgi { my ($self, $streamer) = @_; return $streamer->(sub { $self->_continue_streaming_psgi(@_) }); } my $_pkg = "Feersum::"; sub _raw { ## no critic (RequireArgUnpacking) # don't shift; want to modify $_[0] directly. my $fileno = $_[1]; my $name = "RAW$fileno"; # Hack to make gensyms via new_from_fd() show up in the Feersum package. # This may or may not save memory (HEKs?) over true gensyms. no warnings 'redefine'; local *IO::Handle::gensym = sub { no strict; my $gv = \*{$_pkg.$name}; delete $$_pkg{$name}; $gv; }; # Replace $_[0] directly: $_[0] = IO::Socket::INET->new_from_fd($fileno, '+<'); # after this, Feersum will use PerlIO_unread to put any remainder data # into the socket. return; } 1; __END__ =head1 NAME Feersum::Connection - HTTP connection encapsulation =head1 SYNOPSIS For a streaming response: Feersum->endjinn->request_handler(sub { my $req = shift; # this is a Feersum::Connection object my $env = $req->env(); my $w = $req->start_streaming(200, ['Content-Type' => 'text/plain']); # then immediately or after some time: $w->write("Ergrates "); $w->write(\"FTW."); $w->close(); }); For a response with a Content-Length header: Feersum->endjinn->request_handler(sub { my $req = shift; # this is a Feersum::Connection object my $env = $req->env(); $req->start_whole_response(200, ['Content-Type' => 'text/plain']); $req->write_whole_body(\"Ergrates FTW."); }); =head1 DESCRIPTION Encapsulates an HTTP connection to Feersum. It's roughly analogous to an C or C object, but differs significantly in functionality. Until Keep-Alive functionality is supported (if ever) this means that a connection is B a request. See L for more examples on usage. =head1 METHODS =over 4 =item C<< my $env = $req->env() >> Obtain an environment hash. This hash contains the same entries as for a PSGI handler environment hash. See L for details on the contents. This is a method instead of a parameter so that future versions of Feersum can request a slice of the hash for speed. =item C<< my $w = $req->start_streaming($code, \@headers) >> A full HTTP header section is sent with "Transfer-Encoding: chunked" (or "Connection: close" for HTTP/1.0 clients). Returns a C handle which should be used to complete the response. See L for methods. =item C<< $req->send_response($code, \@headers, $body) >> =item C<< $req->send_response($code, \@headers, \@body) >> Respond with a full HTTP header (including C) and body. Returns the number of bytes calculated for the body. =item C<< $req->force_http10 >> =item C<< $req->force_http11 >> Force the response to use HTTP/1.0 or HTTP/1.1, respectively. Normally, if the request was made with 1.1 then Feersum uses HTTP/1.1 for the response, otherwise HTTP/1.0 is used (this includes requests made with the HTTP "0.9" non-declaration). For streaming under HTTP/1.1 C is used, otherwise a C stream-style is used (with the usual non-guarantees about delivery). You may know about certain user-agents that support/don't-support T-E:chunked, so this is how you can override that. Supposedly clients and a lot of proxies support the C stream-style, see support in Varnish at http://www.varnish-cache.org/trac/ticket/400 =item C<< $req->fileno >> The socket file-descriptor number for this connection. =item C<< $req->response_guard($guard) >> Register a guard to be triggered when the response is completely sent and the socket is closed. A "guard" in this context is some object that will do something interesting in its DESTROY/DEMOLISH method. For example, L. =back =begin comment =head2 Private and or Deprecated Methods =over 4 =item C<< new() >> No-op. Feersum will create these objects internally. =item C<< $req->read_handle >> use psgi.input instead =item C<< $req->write_handle >> =item C<< $req->start_response(...) >> use start_streaming() or start_whole_response() instead =item C<< $req->initiate_streaming(...) >> use start_streaming() and its return value instead =back =end comment =head1 AUTHOR Jeremy Stashewsky, C<< stash@cpan.org >> =head1 COPYRIGHT AND LICENSE Copyright (C) 2010 by Jeremy Stashewsky & Socialtext Inc. 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.7 or, at your option, any later version of Perl 5 you may have available. =cut Feersum-1.410/lib/Feersum/Connection/Handle.pm000644 000765 000024 00000013017 13762624365 021771 0ustar00audreytstaff000000 000000 package Feersum::Connection::Handle; use warnings; use strict; use Carp qw/croak/; sub new { Carp::croak "Cannot instantiate Feersum::Connection::Handles directly"; } package Feersum::Connection::Reader; use warnings; use strict; use base 'Feersum::Connection::Handle'; sub write { ## no critic (BuiltinHomonyms) Carp::croak "can't call write() on a read-only handle" } package Feersum::Connection::Writer; use warnings; use strict; use base 'Feersum::Connection::Handle'; sub read { ## no critic (BuiltinHomonyms) Carp::croak "can't call read() on a write-only handle" } sub seek { ## no critic (BuiltinHomonyms) Carp::croak "can't call seek() on a write-only handle" } package Feersum::Connection::Handle; 1; __END__ =head1 NAME Feersum::Connection::Handle - PSGI-style reader/writer objects. =head1 SYNOPSIS For read handles: my $buf; my $r = delete $env{'psgi.input'}; $r->read($buf, 1, 1); # read the second byte of input without moving offset $r->read($buf, $env{CONTENT_LENGTH}); # append the whole input $r->close(); # discards any un-read() data # assuming the handle is "open": $r->seek(2,SEEK_CUR); # returns 1, discards skipped bytes $r->seek(-1,SEEK_CUR); # returns 0, can't seek back # not yet supported, throws exception: # $r->poll_cb(sub { .... }); For write handles: $w->write("scalar"); $w->write(\"scalar ref"); $w->write_array(\@some_stuff); $w->poll_cb(sub { # use $_[0] instead of $w to avoid a closure $_[0]->write(\"some data"); # can close() or unregister the poll_cb in here $_[0]->close(); }); For both: $h->response_guard(guard { response_is_complete() }); =head1 DESCRIPTION See the L spec for more information on how read/write handles are used (The Delayed Response and Streaming Body section has details on the writer). =head1 METHODS =head2 Reader methods The reader is obtained via C<< $env->{'psgi.input'} >>. =over 4 =item C<< $r->read($buf, $len) >> Read the first C<$len> bytes of the request body into the buffer specified by C<$buf> (similar to how sysread works). The calls to C<< $r->read() >> will never block. Currently, the entire body is read into memory (or perhaps to a temp file) before the Feersum request handler is even called. This behaviour B change. Regardless, Feersum will be doing some buffering so C is set in the PSGI env hash. =item C<< $r->seek(...) >> Seeking is partially supported. Feersum discards skipped-over bytes to conserve memory. $r->seek(0,SEEK_CUR); # returns 1 $r->seek(-1,SEEK_CUR); # returns 0 $r->seek(-1,SEEK_SET); # returns 0 $r->seek(2,SEEK_CUR); # returns 1, discards skipped bytes $r->seek(42,SEEK_SET); # returns 1 if room, discards skipped bytes $r->seek(-8,SEEK_END); # returns 1 if room, discards skipped bytes =item C<< $r->close() >> Discards the remainder of the input buffer. =item C<< $r->poll_cb(sub { .... }) >> B. PSGI only defined poll_cb for the Writer object. =back =head2 Writer methods. The writer is obtained under PSGI by sending a code/headers pair to the "starter" callback. Under Feersum, calls to C<< $req->start_streaming >> return one. =over 4 =item C<< $w->write("scalar") >> Send the scalar as a "T-E: chunked" chunk. The calls to C<< $w->write() >> will never block and data is buffered until transmitted. This behaviour is indicated by C in the PSGI env hash (L supports this too, for example). =item C<< $w->write(\"scalar ref") >> Works just like C above. This extension is indicated by C in the PSGI env hash. =item C<< $w->write_array(\@array) >> Pass in an array-ref and it works much like the two C calls above, except it's way more efficient than calling C over and over. Undefined elements of the array are ignored. =item C<< $w->close() >> Close the HTTP response (which triggers the "T-E: chunked" terminating chunk to be sent). This method is implicitly called when the last reference to the writer is dropped. =item C<< $w->poll_cb(sub { .... }) >> Register a callback to be called when the write buffer is empty. Pass in C to unset. The sub can call C. A reference to the writer is passed in as the first and only argument to the sub. It's recommended that you use C<$_[0]> rather than closing-over on C<$w> to prevent a circular reference. =back =head2 Common methods. Methods in common to both types of handles. =begin comment =item C<< Feersum::Connection::Handle->new() >> Shouldn't be called directly; L will create these objects. =end comment =over 4 =item C<< $h->response_guard($guard) >> Register a guard to be triggered when the response is completely sent and the socket is closed. A "guard" in this context is some object that will do something interesting in its DESTROY/DEMOLISH method. For example, L. The guard is *not* attached to this handle object; the guard is attached to the response. C is the PSGI-env extension that indicates this method. =item C<< $h->fileno >> Returns the file descriptor number for this connection. =back =head1 AUTHOR Jeremy Stashewsky, C<< stash@cpan.org >> =head1 COPYRIGHT AND LICENSE Copyright (C) 2010 by Jeremy Stashewsky & Socialtext Inc. 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.7 or, at your option, any later version of Perl 5 you may have available. =cut Feersum-1.410/lib/Plack/Handler/000755 000765 000024 00000000000 13762625540 017134 5ustar00audreytstaff000000 000000 Feersum-1.410/lib/Plack/Handler/Feersum.pm000644 000765 000024 00000003752 13762624365 021113 0ustar00audreytstaff000000 000000 package Plack::Handler::Feersum; use warnings; use strict; use Feersum::Runner; use base 'Feersum::Runner'; use Scalar::Util qw/weaken/; sub assign_request_handler { my $self = shift; weaken $self; $self->{endjinn}->psgi_request_handler(shift); # Plack::Loader::Restarter will SIGTERM the parent $self->{_term} = EV::signal 'TERM', sub { $self->quit }; return; } sub _prepare { my $self = shift; $self->SUPER::_prepare(@_); $self->{server_ready}->($self) if $self->{server_ready}; return; } 1; __END__ =head1 NAME Plack::Handler::Feersum - plack adapter for Feersum =head1 SYNOPSIS plackup -s Feersum app.psgi plackup -s Feersum --listen localhost:8080 app.psgi plackup -s Feersum --pre-fork=4 -MMy::App -L delayed app.psgi =head1 DESCRIPTION This is a stub module that allows Feersum to be loaded up under C and other Plack tools. Set C<< $ENV{PLACK_SERVER} >> to 'Feersum' or use the -s parameter to plackup to use Feersum under Plack. =head2 Experimental Features A C<--pre-fork=N> parameter can be specified to put feersum into pre-forked mode where N is the number of child processes. The C<--preload-app> parameter that L supports isn't supported yet. The fork is run immediately after startup and after the app is loaded (i.e. in the C method). =head1 METHODS =over 4 =item C<< assign_request_handler($app) >> Assigns the PSGI request handler to Feersum. Also sets up a SIGTERM handler to call the C method so that L will work. =back =head1 SEE ALSO Most of the functionality is in L (the base class) =head1 AUTHOR Jeremy Stashewsky, C<< stash@cpan.org >> =head1 COPYRIGHT AND LICENSE Copyright (C) 2010 by Jeremy Stashewsky & Socialtext Inc. 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.7 or, at your option, any later version of Perl 5 you may have available. =cut Feersum-1.410/xt/50-psgi-simple-stress.t000644 000765 000024 00000004606 13762624365 020605 0ustar00audreytstaff000000 000000 #!perl use warnings; use strict; use constant PARALLEL => 15; use Test::More qw/no_plan/; use lib 't'; use Utils; use POSIX (); BEGIN { use_ok('Feersum') }; my ($socket,$port) = get_listen_socket(); ok $socket, "made listen socket"; my $APP = <<'EOAPP'; my $app = sub { my $env = shift; return [ 200, ['Content-Type' => 'text/plain'], ['Hello',' ','World'] ]; }; EOAPP my $app = eval $APP; ok $app, 'got an app' || diag $@; POSIX::setsid; my $ppid = $$; my $pid = fork(); if (!defined($pid)) { die "can't fork: $!"; } elsif ($pid == 0) { my $evh = Feersum->new(); { no warnings 'redefine'; *Feersum::DIED = sub { my $err = shift; warn "DIED: $err"; kill 9, -$ppid; POSIX::_exit(2); }; } $evh->use_socket($socket); $evh->psgi_request_handler($app); my $quit; $quit = AE::signal 'QUIT', sub { $evh->graceful_shutdown(); }; AE::cv->recv; scope_guard { POSIX::_exit(0) }; } sleep 1; my $cv = AE::cv; my $requests = 0; my $responses = 0; my $total_latency = 0.0; sub cli ($); sub cli ($) { my $n = shift; # diag "($n) starting req"; $cv->begin; my $r_start = AE::time; my $h; $h = simple_client GET => '/', name => "($n)", sub { my ($body, $headers) = @_; scope_guard { $cv->end }; # is $headers->{'Status'}, 200, "($n) Response OK"; # is $headers->{'content-type'}, 'text/plain', "... ($n) is text"; # is $body, 'Hello World', "... ($n) correct body"; # is $headers->{'content-length'}, 11; $total_latency += AE::time - $r_start; $cv->croak("extra crap!") if length($h->{rbuf}); undef $h; if ($headers->{'Status'}) { $responses++; cli $n; } }; $requests++; } for my $n (1 .. PARALLEL) { cli $n; } my $t; $t = AE::timer 15, 0, sub { $cv->croak("time's up!"); }; my $started = AE::time(); eval { $cv->recv }; diag $@ if $@; my $finished = AE::time(); pass "clients done, waitpid"; kill 9, $pid; waitpid $pid, 0; my $taken = $finished-$started; print "resp/sec: ".sprintf('%0.4f r/s',$responses/$taken)."\n"; print "overall/req ".sprintf('%0.2f ms/r',$taken*1000.0/$responses)."\n"; print "latency/req ".sprintf('%0.2f ms/r',$total_latency*1000.0/$responses)."\n"; pass "all done"; Feersum-1.410/t/99-critic.t000644 000765 000024 00000001231 13762624365 016124 0ustar00audreytstaff000000 000000 #!/usr/bin/perl # Test that the module passes perlcritic use strict; BEGIN { $| = 1; $^W = 1; } my @MODULES = ( 'Perl::Critic 1.098', 'Test::Perl::Critic 1.01', ); # Don't run tests during end-user installs use Test::More; plan( skip_all => 'Author tests not required for installation' ) unless ( $ENV{RELEASE_TESTING} ); # Load the testing modules foreach my $MODULE ( @MODULES ) { eval "use $MODULE"; if ( $@ ) { $ENV{RELEASE_TESTING} ? die( "Failed to load required release-testing module $MODULE" ) : plan( skip_all => "$MODULE not available for testing" ); } } Test::Perl::Critic->import(-profile => 't/perlcriticrc'); all_critic_ok(); 1; Feersum-1.410/t/05-streaming.t000644 000765 000024 00000011104 13762624365 016623 0ustar00audreytstaff000000 000000 #!perl use warnings; use strict; use constant HARDER => $ENV{RELEASE_TESTING} ? 10 : 1; use constant CLIENTS_11 => HARDER * 2; use constant CLIENTS_10 => HARDER * 2; use constant CLIENTS => CLIENTS_11 + CLIENTS_10; use Test::More tests => 7 + 21 * CLIENTS_11 + 22 * CLIENTS_10; use Test::Fatal; use lib 't'; use Utils; BEGIN { use_ok('Feersum') }; my ($socket,$port) = get_listen_socket(); ok $socket, "made listen socket"; ok $socket->fileno, "has a fileno"; my $evh = Feersum->new(); { no warnings 'redefine'; *Feersum::DIED = sub { my $err = shift; fail "Died during request handler: $err"; }; } my $cv = AE::cv; my $started = 0; my $finished = 0; $evh->request_handler(sub { my $r = shift; isa_ok $r, 'Feersum::Connection', 'got an object!'; my $env = $r->env(); ok $env && ref($env) eq 'HASH'; ok $env->{'psgi.streaming'}, 'got psgi.streaming'; my $cnum = $env->{HTTP_X_CLIENT}; ok $cnum, "got client number"; ok !$r->can('write'), "write method removed from connection object"; $cv->begin; my $w = $r->start_streaming("200 OK", ['Content-Type' => 'text/plain', 'X-Client' => $cnum, 'X-Fileno' => $r->fileno ]); $started++; isa_ok($w, 'Feersum::Connection::Writer', "got a writer $cnum"); isa_ok($w, 'Feersum::Connection::Handle', "... it's a handle $cnum"); my $n = 0; my $wrote_third = 0; my $t; $t = AE::timer rand()/5,rand()/5, sub { $n++; eval { if ($n == 1) { ok blessed($w), "still blessed? $cnum"; # cover PADTMP case $w->write("$cnum Hello streaming world! chunk ". ($n==1?"one":"WTF")."\n"); pass "wrote chunk $n $cnum"; } elsif ($n == 2) { ok blessed($w), "still blessed? $cnum"; # cover PADMY case my $d = "$cnum Hello streaming world! chunk ". ($n==1?"WTF":"'two'")."\n"; $w->write($d); pass "wrote chunk $n $cnum"; } elsif ($n == 3) { ok blessed($w), "still blessed? $cnum"; my $buf = "$cnum Hello streaming world! chunk three\n"; $w->poll_cb(sub { my $w2 = shift; isa_ok($w2, 'Feersum::Connection::Writer', "got another writer $cnum"); $w2->write($buf); $w2->poll_cb(undef); # unset $wrote_third = 1; }); } elsif ($wrote_third) { ok blessed($w), "still blessed? $cnum"; $w->close(); pass "async writer finished $cnum"; like exception { $w->write("after completion"); }, qr/closed/i, "can't write after completion $cnum"; $finished++; $cv->end; undef $t; # important ref } }; if ($@) { warn "oshit $cnum $@"; } }; }); is exception { $evh->use_socket($socket); }, undef, 'assigned socket'; sub client { my $cnum = sprintf("%04d",shift); my $is_chunked = shift || 0; $cv->begin; my $h; $h = simple_client GET => '/foo', name => $cnum, timeout => 15, proto => $is_chunked ? '1.1' : '1.0', headers => { "Accept" => "*/*", 'X-Client' => $cnum, }, sub { my ($body, $headers) = @_; is $headers->{Status}, 200, "$cnum got 200" or diag $headers->{Reason}; if ($is_chunked) { is $headers->{HTTPVersion}, '1.1'; is $headers->{'transfer-encoding'}, "chunked", "$cnum got chunked!"; } else { is $headers->{HTTPVersion}, '1.0'; ok !exists $headers->{'transfer-encoding'}, "$cnum not chunked!"; is $headers->{'connection'}, 'close', "$cnum conn closed"; } is_deeply [split /\n/,$body], [ "$cnum Hello streaming world! chunk one", "$cnum Hello streaming world! chunk 'two'", "$cnum Hello streaming world! chunk three", ], "$cnum got all three lines" or do { warn "descriptor ".$headers->{'x-fileno'}." failed!"; exit 2; }; $cv->end; undef $h; }; } client(1000+$_,1) for (1..CLIENTS_11); client(2000+$_,0) for (1..CLIENTS_10); # HTTP/1.0 style $cv->recv; is $started, CLIENTS, 'handlers started'; is $finished, CLIENTS, 'handlers finished'; pass "all done"; Feersum-1.410/t/54-psgix-io.t000644 000765 000024 00000011123 13762624365 016376 0ustar00audreytstaff000000 000000 #!perl use warnings; use strict; use constant CLIENTS => $ENV{RELEASE_TESTING} ? 10 : 2; use constant ROUNDS => $ENV{RELEASE_TESTING} ? 25 : 4; use Scalar::Util qw/refaddr/; use Test::More tests => 3 + ROUNDS*( CLIENTS*5 + # server setup CLIENTS*3 + # client setup CLIENTS + # server msg CLIENTS + # client send CLIENTS*CLIENTS + # client msg 4 # each round ); use lib 't'; use Utils; BEGIN { use_ok('Feersum') }; my ($socket,$port) = get_listen_socket(); ok $socket, "made listen socket"; my $evh = Feersum->new(); { no warnings 'redefine'; *Feersum::DIED = sub { my $err = shift; fail "Died during request handler: $err"; }; } $evh->use_socket($socket); our $CRLF = "\015\012"; my $app = sub { my $env = shift; is $env->{HTTP_UPGRADE}, 'chatz', "server setup: got an upgrade req"; my $n = $env->{HTTP_X_CLIENT}; return sub { my $respond = shift; do_chat($n,$env); }; }; $evh->psgi_request_handler($app); my $cv; # read lines, broadcast to other server-side handles my @ss_handles; sub do_chat { my ($n, $env, $strm) = @_; $cv->begin; my $fh = $env->{'psgix.io'}; isa_ok $fh, 'IO::Socket', "server setup: $n fh"; my $websocket_turd; read $fh, $websocket_turd, 8; is $websocket_turd, '12345678', "server setup: $n websocket turd"; my $fh2 = $env->{'psgix.io'}; is refaddr($fh), refaddr($fh2), "server setup: duplicated psgix.io read results in same handle"; # use AnyEvent::Handle here specifically as that's what Web::Hippie # uses. my $h = AnyEvent::Handle->new(fh => $fh); $ss_handles[$n] = $h; $h->{guard} = guard { pass "server setup: $n destroyed" }; $h->push_write("HTTP/1.1 101 Switching Protocols$CRLF$CRLF"); $h->push_read(line => sub { my $line = $_[1]; is $line, "hello from $n", "server msg: read a line for server $n"; $line .= "\n"; $ss_handles[$_]->push_write($line) for (1..CLIENTS); $cv->end; }); $h->on_error(sub { diag "server handle error: $_[2]"; $h->destroy; # important self-ref $cv->croak("server handle: ".$_[2]); }); } for my $round (1..ROUNDS) { $cv = AE::cv; # connect a number of clients, keeping the handle in a client-side handles # array. Once all of the clients are connected ($connect_cv synchronizes # them) send a "hello from" line for each client. Check that every client # gets every message. my @cs_handles; my $connect_cv = AE::cv(sub { pass "round $round : all clients connected, sending chats..."; eval { for my $n (1 .. CLIENTS) { my $h = $cs_handles[$n]; $h->push_write("hello from $n\n"); pass "client send: wrote to $n"; } }; warn "during connect cv: $@" if $@; }); $connect_cv->begin; for my $n (1 .. CLIENTS) { $connect_cv->begin; $cv->begin; my $h = AnyEvent::Handle->new( connect => ['127.0.0.1',$port], timeout => 3, ); $cs_handles[$n] = $h; $h->{guard} = guard { pass "client setup: $n destroyed" }; $h->on_error(sub { diag "client handle error: $_[2]"; $h->destroy; $connect_cv->croak("client handle: ".$_[2]); $cv->croak("client handle: ".$_[2]); }); $h->push_write("GET / HTTP/1.1$CRLF". "Upgrade: chatz$CRLF". "X-Client: $n$CRLF". $CRLF. "12345678" # extra websocket v76 hanshake turd ); # one line for the upgrade, CLIENTS lines for the chatting $h->push_read(line => qr/$CRLF$CRLF/, sub { my $line = $_[1]; is $line, 'HTTP/1.1 101 Switching Protocols', "client setup: client $n got upgraded"; $connect_cv->end; }); my $to_read = CLIENTS; $h->push_read(line => sub { my $line = $_[1]; $to_read--; like $line, qr/^hello from \d+$/, "client msg: $n got a chat, $to_read left"; unless ($to_read) { pass "client setup: client $n is done"; $cv->end; } }) for (1 .. CLIENTS); } $connect_cv->end; $connect_cv->recv; pass "round: all connected"; $cv->recv; pass "round: done round $round"; $_->destroy() for grep {defined} @cs_handles; @cs_handles = (); $_->destroy() for grep {defined} @ss_handles; @ss_handles = (); pass "round: cleaned up round $round"; } pass "all done"; done_testing; Feersum-1.410/t/perlcriticrc000644 000765 000024 00000000602 13762624365 016634 0ustar00audreytstaff000000 000000 severity = cruel exclude = RcsKeywords PodLinksIncludeText MultiplePackages InterpolationOfLiterals PodSections PostfixControls PunctuationVars UnlessBlocks ProhibitDoubleSigils RequireVersionVar ProhibitUnusedPrivateSubroutines ProhibitNoWarnings ProhibitNoStrict ProhibitEmptyQuotes RequireDotMatchAnything RequireExtendedFormatting RequireLineBoundaryMatching ProhibitConstantPragma Feersum-1.410/t/12-close-on-drop.t000644 000765 000024 00000002420 13762624365 017312 0ustar00audreytstaff000000 000000 #!perl use warnings; use strict; use Test::More tests => 14; use Test::Fatal; use lib 't'; use Utils; BEGIN { use_ok('Feersum') }; my ($socket,$port) = get_listen_socket(); ok $socket, "made listen socket"; my $evh = Feersum->new(); { no warnings 'redefine'; *Feersum::DIED = sub { my $err = shift; fail "Died during request handler: $err"; }; } $evh->request_handler(sub { my $r = shift; ok $r, 'got request'; my $w = $r->start_streaming(200, []); $w->write("hello "); $w->write("world!\n"); is exception { undef $w; }, undef, 'no death on undef'; }); is exception { $evh->use_socket($socket); }, undef, 'assigned socket'; my $cv = AE::cv; sub client { my $cnum = shift; my $is_chunked = shift || 0; $cv->begin; my $h; $h = simple_client GET => '/foo', name => "client $cnum", timeout => 15, proto => $is_chunked ? '1.1' : '1.0', headers => {"Accept" => "*/*"}, sub { my ($body, $headers) = @_; is $headers->{Status}, 200, "client $cnum got 200" or diag $headers->{Reason}; is $body, "hello world!\n", "client $cnum body"; $cv->end; undef $h; }; } client(1,'chunked'); client(2); $cv->recv; pass "all done"; Feersum-1.410/t/52-psgi-iohandle.t000644 000765 000024 00000011425 13762624365 017365 0ustar00audreytstaff000000 000000 #!perl use warnings; use strict; use Test::More tests => 41; use lib 't'; use Utils; use File::Temp qw/tempfile/; use Encode qw/decode_utf8/; BEGIN { use_ok('Feersum') }; my ($socket,$port) = get_listen_socket(); ok $socket, "made listen socket"; my $evh = Feersum->new(); { no warnings 'redefine'; *Feersum::DIED = sub { my $err = shift; fail "Died during request handler: $err"; }; } $evh->use_socket($socket); { package FakeIOHandle; sub new { return bless {lines => $_[1]}, __PACKAGE__ } sub getline { my $self = shift; Test::More::ok(ref($/) && ${$/} == 4096, '$/ is \4096'); return @{$self->{lines}} ? shift @{$self->{lines}} : undef; } sub close { Test::More::pass("called close"); } } my $APP = <<'EOAPP'; my $app = sub { my $env = shift; Test::More::pass "called app"; my $io = FakeIOHandle->new([ "line one\n", "line two\n" ]); return [200,['Content-Type'=>'text/plain'],$io]; }; EOAPP my $app = eval $APP; ok $app, 'got an app' || diag $@; $evh->psgi_request_handler($app); returning_mock: { my $cv = AE::cv; $cv->begin; my $h; $h = simple_client GET => '/', sub { my ($body, $headers) = @_; is $headers->{'Status'}, 200, "Response OK"; is $headers->{'content-type'}, 'text/plain'; is $body, qq(line one\nline two\n); $cv->end; undef $h; }; $cv->recv; pass "all done app 1"; } my ($tempfh, $tempname) = tempfile(UNLINK=>1); print $tempfh "temp line one\n"; print $tempfh "temp line two\n"; close $tempfh; my $APP2 = <<'EOAPP'; my $app2 = sub { my $env = shift; Test::More::pass "called app2"; open my $io, '<', $tempname; return [200,['Content-Type'=>'text/plain'],$io]; }; EOAPP my $app2 = eval $APP2; ok $app2, 'got app 2' || diag $@; $evh->psgi_request_handler($app2); returning_glob: { my $cv = AE::cv; $cv->begin; my $h; $h = simple_client GET => '/', sub { my ($body, $headers) = @_; is $headers->{'Status'}, 200, "Response OK"; is $headers->{'content-type'}, 'text/plain'; is $body, qq(temp line one\ntemp line two\n); $cv->end; undef $h; }; $cv->recv; } pass "all done app 2"; my $APP3 = <<'EOAPP'; my $app3 = sub { my $env = shift; Test::More::pass "called app3"; require IO::File; my $io = IO::File->new($tempname,"r"); return [200,['Content-Type'=>'text/plain'],$io]; }; EOAPP my $app3 = eval $APP3; ok $app3, 'got app 3' || diag $@; $evh->psgi_request_handler($app3); returning_io_file: { my $cv = AE::cv; $cv->begin; my $h; $h = simple_client GET => '/', sub { my ($body, $headers) = @_; is $headers->{'Status'}, 200, "Response OK"; is $headers->{'content-type'}, 'text/plain', "C-T"; is $body, qq(temp line one\ntemp line two\n), "body"; $cv->end; undef $h; }; $cv->recv; } pass "all done app 3"; { open my $fh, '>:encoding(UTF-16LE)',$tempname; print $fh "\x{2603}\n"; # U+2603 SNOWMAN, UTF-8: E2 98 83 close $fh; } my $APP4 = <<'EOAPP'; my $app4 = sub { my $env = shift; Test::More::pass "called app4"; open my $io, '<:encoding(UTF-16LE)',$tempname; return [200,['Content-Type'=>'text/plain; charset=UTF-8'],$io]; }; EOAPP my $app4 = eval $APP4; ok $app4, 'got app 4' || diag $@; $evh->psgi_request_handler($app4); returning_perlio_layer: { my $cv = AE::cv; $cv->begin; my $h; $h = simple_client GET => '/', sub { my ($body, $headers) = @_; is $headers->{'Status'}, 200, "Response OK"; is $headers->{'content-type'}, 'text/plain; charset=UTF-8', "C-T"; is decode_utf8($body), qq(\x{2603}\n), "utf8 body"; $cv->end; undef $h; }; $cv->recv; } pass "all done app 4"; my $APP5 = <<'EOAPP'; my $app5 = sub { my $env = shift; Test::More::pass "called app5"; return sub { my $responder = shift; open my $io, '<:encoding(UTF-16LE)',$tempname; $responder->([ 200,['Content-Type'=>'text/plain; charset=UTF-8'],$io ]); }; }; EOAPP my $app5 = eval $APP5; ok $app5, 'got app 5' || diag $@; $evh->psgi_request_handler($app5); returning_perlio_layer_from_stream: { my $cv = AE::cv; $cv->begin; my $h; $h = simple_client GET => '/', sub { my ($body, $headers) = @_; is $headers->{'Status'}, 200, "Response OK"; is $headers->{'content-type'}, 'text/plain; charset=UTF-8', "C-T"; is decode_utf8($body), qq(\x{2603}\n), "utf8 body from streamer"; $cv->end; undef $h; }; $cv->recv; } pass "all done app 5"; Feersum-1.410/t/09-magic.t000644 000765 000024 00000006125 13762624365 015725 0ustar00audreytstaff000000 000000 #!perl use warnings; use strict; use Test::More tests => 25; use Test::Fatal; use utf8; use lib 't'; use Utils; BEGIN { use_ok('Feersum') }; my ($socket,$port) = get_listen_socket(); ok $socket, "made listen socket"; ok $socket->fileno, "has a fileno"; my $evh = Feersum->new(); $evh->use_socket($socket); { package My::MagicScalar; use Tie::Scalar; use base 'Tie::StdScalar'; sub FETCH { my $self = shift; return uc($self->SUPER::FETCH(@_)); } } { package My::MagicArray; use Tie::Array; use base 'Tie::StdArray'; sub FETCH { my $self = shift; my $e = $self->SUPER::FETCH(@_); return ref($e) ? $e : uc($e); } sub SHIFT { my $self = shift; my $e = $self->SUPER::SHIFT(@_); return ref($e) ? $e : uc($e); } } $evh->request_handler(sub { my $r = shift; isa_ok $r, 'Feersum::Connection', 'got an object!'; my $env = $r->env(); ok $env, "got env"; my $type = $env->{HTTP_X_MAGIC_TYPE}; if ($type eq 'SCALAR') { # magic scalar tie my $ms, 'My::MagicScalar'; $ms = "foobar"; is exception { $r->send_response("200 OK", [ 'Content-Type' => 'text/plain', ], \$ms); }, undef, "sent response for $type"; } elsif ($type eq 'ARRAY') { # magic array tie my @ma, 'My::MagicArray'; @ma = ("aaaa","bbb"); is exception { $r->send_response("200 OK", [ 'Content-Type' => 'text/plain', ], \@ma); }, undef, "sent response for $type"; } else { tie my $ms, 'My::MagicScalar'; $ms = "dddd"; tie my @ma, 'My::MagicArray'; @ma = ("cccc",\$ms); is exception { $r->send_response("200 OK", [ 'Content-Type' => 'text/plain', ], \@ma); }, undef, "sent response for $type"; } }); my $cv = AE::cv; $cv->begin; my $w = simple_client GET => '/', name => 'scalar', headers => { 'X-Magic-Type' => 'SCALAR' }, timeout => 3, sub { my ($body, $hdr) = @_; is $hdr->{Status}, 200, "client 1 got 200"; is $hdr->{'content-length'}, 6, 'content-length was overwritten by the engine'; is $body, 'FOOBAR', "magic body used for scalar"; $cv->end; }; $cv->begin; my $w2 = simple_client GET => '/', name => 'array', headers => { 'X-Magic-Type' => 'ARRAY' }, timeout => 3, sub { my ($body, $hdr) = @_; is $hdr->{Status}, 200, "client 1 got 200"; is $hdr->{'content-length'}, 7, 'content-length'; is $body, 'AAAABBB', "magic body used for array"; $cv->end; }; $cv->begin; my $w3 = simple_client GET => '/', name => 'array', headers => { 'X-Magic-Type' => 'SCALAR-in-ARRAY' }, timeout => 3, sub { my ($body, $hdr) = @_; is $hdr->{Status}, 200, "client 1 got 200"; is $hdr->{'content-length'}, 8, 'content-length'; is $body, 'CCCCDDDD', "magic body used for scalar in array"; $cv->end; }; $cv->recv; pass "all done"; Feersum-1.410/t/61-plack-suite.t000644 000765 000024 00000000750 13762624365 017062 0ustar00audreytstaff000000 000000 #!perl use warnings; use strict; use blib; use Test::More; BEGIN { plan skip_all => "Need Plack >= 0.9950 to run this test" unless eval 'require Plack; $Plack::VERSION >= 0.995'; } use Feersum; { no warnings 'redefine'; *Feersum::DIED = sub { # for cleaner TAP output: return if $_[0] =~ /Server shouldn't crash/; diag "Feersum caught: ",@_; }; } use Plack::Test::Suite; Plack::Test::Suite->run_server_tests('Feersum'); done_testing; Feersum-1.410/t/04-died.t000644 000765 000024 00000001603 13762624365 015541 0ustar00audreytstaff000000 000000 #!perl use warnings; use strict; use Test::More tests => 10; use Test::Fatal; use lib 't'; use Utils; BEGIN { use_ok('Feersum') }; my ($socket,$port) = get_listen_socket(); ok $socket, "made listen socket"; ok $socket->fileno, "has a fileno"; my $evh = Feersum->new(); { no warnings 'redefine'; *Feersum::DIED = sub { my $err = shift; like $err, qr/holy crap/, 'DIED was called'; }; } $evh->request_handler(sub { my $r = shift; die "holy crap!"; }); is exception { $evh->use_socket($socket); }, undef, 'assigned socket'; my $cv = AE::cv; $cv->begin; my $w = simple_client GET => "/?blar", timeout => 3, sub { my ($body, $headers) = @_; is $headers->{Status}, 500, "client got 500"; is $headers->{'content-type'}, 'text/plain'; is $body, "Request handler exception.\n", 'got expected body'; $cv->end; }; $cv->recv; pass "all done"; Feersum-1.410/t/01-simple.t000644 000765 000024 00000004570 13762624365 016130 0ustar00audreytstaff000000 000000 #!perl use warnings; use strict; use Test::More tests => 31; use Test::Fatal; use utf8; use lib 't'; use Utils; BEGIN { use_ok('Feersum') }; my ($socket,$port) = get_listen_socket(); ok $socket, "made listen socket"; ok $socket->fileno, "has a fileno"; my $evh = Feersum->new(); is exception { $evh->use_socket($socket); }, undef, 'assigned socket'; my $cb; { my $g = guard { pass "cv recycled"; }; $cb = sub { $g = $g; fail "old callback" }; } is exception { $evh->request_handler($cb); }, undef, "can assign code block"; undef $cb; pass "after undef cb"; $cb = sub { pass "called back!"; my $r = shift; isa_ok $r, 'Feersum::Connection', 'got an object!'; # use Devel::Peek(); # Devel::Peek::Dump($r); my $env = $r->env(); ok $env, "got env"; is $env->{HTTP_USER_AGENT}, 'FeersumSimpleClient/1.0', 'got a ua!'; my $utf8 = exists $env->{HTTP_X_UNICODE_PLEASE}; eval { $r->send_response("200 OK", [ 'Content-Type' => 'text/plain'.($utf8 ? '; charset=UTF-8' : ''), 'Connection' => 'close', 'X-Client' => 1234, 'Content-Length' => 666, # should be ignored ], $utf8 ? 'Bāz!' : 'Baz!'); }; warn $@ if $@; pass "done request handler"; }; is exception { $evh->request_handler($cb); }, undef, "can assign another code block"; my $cv = AE::cv; $cv->begin; my $w = simple_client GET => '/?qqqqq', name => 'ascii', timeout => 3, sub { my ($body, $hdr) = @_; is $hdr->{Status}, 200, "client 1 got 200"; like $hdr->{'x-client'}, qr/^\d+$/, 'got a custom x-client header'; is $hdr->{'content-length'}, 4, 'content-length was overwritten by the engine'; is $hdr->{'content-type'}, 'text/plain'; is $body, 'Baz!', 'plain old body'; $cv->end; }; $cv->begin; my $w2 = simple_client GET => "/?zzzzz", name => 'unicode', headers => { 'X-Unicode-Please' => 1 }, timeout => 3, sub { my ($body, $hdr) = @_; is $hdr->{Status}, 200, "client 2 got 200"; like $hdr->{'x-client'}, qr/^\d+$/, 'got a custom x-client header'; is $hdr->{'content-length'}, 5, 'content-length was overwritten by the engine'; is $hdr->{'content-type'}, 'text/plain; charset=UTF-8'; is Encode::decode_utf8($body), 'Bāz!', 'unicode body!'; $cv->end; }; $cv->recv; pass "all done"; Feersum-1.410/t/13-pre-fork.t000644 000765 000024 00000002374 13762624365 016367 0ustar00audreytstaff000000 000000 #!perl use warnings; use strict; use constant HARDER => $ENV{RELEASE_TESTING} ? 1 : 0; use constant NUM_FORK => HARDER ? 4 : 2; use constant CLIENTS => HARDER ? 30 : 4; use Test::More tests => 4 + CLIENTS*3; use utf8; use lib 't'; use Utils; use_ok 'Feersum::Runner'; my (undef, $port) = get_listen_socket(); my $cv; my $test = 0; sub simple_get { my ($port, $n) = @_; $cv->begin; my $cli; $cli = simple_client GET => "/?q=$n", name => "client $n", sub { my ($body,$headers) = @_; is $headers->{Status}, 200, "client $n: http success"; like $body, qr/^Hello customer number 0x[0-9a-f]+$/, "client $n: looks good"; $cv->end; undef $cli; }; } my $pid = fork; die "can't fork: $!" unless defined $pid; if (!$pid) { require POSIX; eval { my $runner = Feersum::Runner->new( listen => ["localhost:$port"], server_starter => 1, app_file => 'eg/app.feersum', pre_fork => NUM_FORK, quiet => 1, ); $runner->run(); }; POSIX::exit(0); } $cv = AE::cv; simple_get($port, $_) for (1..CLIENTS); $cv->recv; pass "killing"; kill 3, $pid; # QUIT pass "killed"; waitpid $pid, 0; pass "reaped"; Feersum-1.410/t/03-env-hash.t000644 000765 000024 00000014663 13762624365 016356 0ustar00audreytstaff000000 000000 #!perl use warnings; use strict; use Test::More tests => 143; use utf8; use Test::Fatal; use lib 't'; use Utils; BEGIN { use_ok('Feersum') }; my ($socket, $port) = get_listen_socket(); ok $socket, "made listen socket"; ok $socket->fileno, "has a fileno"; my $evh = Feersum->new(); { no warnings 'redefine'; *Feersum::DIED = sub { my $err = shift; warn "Died during request handler: $err"; }; } $evh->request_handler(sub { local $@; my $r = shift; isa_ok $r, 'Feersum::Connection', 'connection'; my $env; is exception { $env = $r->env() }, undef, 'obtain env'; ok $env && ref($env) eq 'HASH', "env hash"; my $tn = $env->{HTTP_X_TEST_NUM} || 0; ok $tn, "got a test number header $tn"; is_deeply $env->{'psgi.version'}, [1,1], 'got psgi.version'; is $env->{'psgi.url_scheme'}, "http", 'got psgi.url_scheme'; ok exists $env->{'psgi.run_once'}, 'got psgi.run_once'; ok $env->{'psgi.nonblocking'}, 'got psgi.nonblocking'; is $env->{'psgi.multithread'}, '', 'got psgi.multithread'; is $env->{'psgi.multiprocess'}, '', 'got psgi.multiprocess'; ok $env->{'psgix.body.scalar_refs'}, 'Feersum supports scalar-refs in the body part of the response (psgix.body.scalar_refs)'; my $errfh = $env->{'psgi.errors'}; ok $errfh, 'got psgi.errors'; is exception { $errfh->print() }, undef, "errors fh can print()"; is $env->{REQUEST_METHOD}, ($tn == 5 ? 'POST' : 'GET'), "got req method"; like $env->{HTTP_USER_AGENT}, qr/FeersumSimpleClient/, "got UA"; ok !exists $env->{HTTP_CONTENT_LENGTH}, "C-L is a promoted header"; ok !exists $env->{HTTP_CONTENT_TYPE}, "C-T is a promoted header"; if ($tn == 1) { is $env->{CONTENT_LENGTH}, 0, "got zero C-L"; like $env->{HTTP_REFERER}, qr/wrong/, "got the Referer"; is $env->{QUERY_STRING}, 'blar', "got query string"; is $env->{PATH_INFO}, '/what is wrong?', "got decoded path info string"; is $env->{REQUEST_URI}, '/what%20is%20wrong%3f?blar', "got full URI string"; } elsif ($tn == 2) { is $env->{CONTENT_LENGTH}, 0, "got zero C-L"; like $env->{HTTP_REFERER}, qr/good/, "got a Referer"; is $env->{QUERY_STRING}, 'dlux=sonice', "got query string"; is $env->{PATH_INFO}, '/what% is good?%2', "got decoded path info string"; is $env->{REQUEST_URI}, '/what%%20is%20good%3F%2?dlux=sonice', "got full URI string"; } elsif ($tn == 3) { is $env->{CONTENT_LENGTH}, 0, "got zero C-L"; like $env->{HTTP_REFERER}, qr/ugly/, "got a Referer"; is $env->{QUERY_STRING}, '', "got query string"; is $env->{PATH_INFO}, '/no query', "got decoded path info string"; is $env->{REQUEST_URI}, '/no%20query', "got full URI string"; } elsif ($tn == 4) { is $env->{CONTENT_LENGTH}, 0, "got zero C-L"; } elsif ($tn == 5) { is $env->{CONTENT_LENGTH}, 9, "got zero C-L"; is $env->{CONTENT_TYPE}, 'text/plain; charset=US-ASCII', "C-T is a promoted header"; } is $env->{SERVER_NAME}, '127.0.0.1', "got server name"; is $env->{SERVER_PORT}, $port, "got server port"; ok $env->{REMOTE_ADDR}, "remote addr"; ok $env->{REMOTE_PORT}, "remote port"; ok !exists $env->{HTTP_ACCEPT_CHARSET}, "spot check that a placeholder Accept-Charset isn't there"; ok !exists $env->{HTTP_ACCEPT_LANGUAGE}, "spot check that a placeholder Accept-Language isn't there"; is exception { $r->send_response("200 OK", [ 'Content-Type' => 'text/plain; charset=UTF-8', 'Connection' => 'close', ], ["Oh Hai $env->{HTTP_X_TEST_NUM}\n"]); }, undef, 'sent response'; }); is exception { $evh->use_socket($socket); }, undef, 'assigned socket'; my $cv = AE::cv; $cv->begin; my $w = simple_client GET => "/what%20is%20wrong%3f?blar", headers => {'x-test-num' => 1, 'Referer' => '/wrong'}, timeout => 3, sub { my ($body, $headers) = @_; is $headers->{Status}, 200, "client 1 got 200"; is $headers->{'content-type'}, 'text/plain; charset=UTF-8'; $body = Encode::decode_utf8($body) unless Encode::is_utf8($body); is $headers->{'content-length'}, bytes::length($body), 'client 1 content-length was calculated correctly'; is $body, "Oh Hai 1\n", 'client 1 expected body'; $cv->end; }; $cv->begin; my $w2 = simple_client GET => "/what%%20is%20good%3F%2?dlux=sonice", headers => {'x-test-num' => 2, 'Referer' => 'good'}, timeout => 3, sub { my ($body, $headers) = @_; is $headers->{Status}, 200, "client 2 got 200"; is $headers->{'content-type'}, 'text/plain; charset=UTF-8'; $body = Encode::decode_utf8($body) unless Encode::is_utf8($body); is $headers->{'content-length'}, bytes::length($body), 'client 2 content-length was calculated correctly'; is $body, "Oh Hai 2\n", 'client 2 expected body'; $cv->end; }; $cv->begin; my $w3 = simple_client GET => "/no%20query", headers => {'x-test-num' => 3, 'Referer' => 'ugly'}, timeout => 3, sub { my ($body, $headers) = @_; is $headers->{Status}, 200, "client 3 got 200"; is $headers->{'content-type'}, 'text/plain; charset=UTF-8'; $body = Encode::decode_utf8($body) unless Encode::is_utf8($body); is $headers->{'content-length'}, bytes::length($body), 'client 3 content-length was calculated correctly'; is $body, "Oh Hai 3\n", 'client 3 expected body'; $cv->end; }; $cv->begin; my $w4 = simple_client GET => "/no spaces allowed", headers => {'x-test-num' => 4, 'Referer' => 'ugly'}, timeout => 3, sub { my ($body, $headers) = @_; is $headers->{Status}, 400, 'client 4 Bad Request'; is $headers->{Reason}, "Bad Request"; is $headers->{'content-type'}, 'text/plain'; is $body, "Malformed request.\n", 'client 4 expected error'; $cv->end; }; $cv->begin; my $w5 = simple_client POST => "/post", headers => { 'x-test-num' => 5, 'Content-Type' => 'text/plain; charset=US-ASCII', }, body => "The post\n", timeout => 3, sub { my ($body, $headers) = @_; is $headers->{Status}, 200, "client 5 got 200"; is $headers->{'content-type'}, 'text/plain; charset=UTF-8'; $body = Encode::decode_utf8($body) unless Encode::is_utf8($body); is $headers->{'content-length'}, bytes::length($body), 'client 5 content-length was calculated correctly'; is $body, "Oh Hai 5\n", 'client 5 expected body'; $cv->end; }; $cv->recv; pass "all done"; Feersum-1.410/t/99-pod-coverage.t000644 000765 000024 00000003001 13762624365 017217 0ustar00audreytstaff000000 000000 #!/usr/bin/perl # Ensure pod coverage in your distribution use strict; BEGIN { $| = 1; $^W = 1; } my @MODULES = ( 'Test::Pod::Coverage 1.08', 'File::Spec', ); # Don't run tests during end-user installs use Test::More; plan( skip_all => 'Author tests not required for installation' ) unless ( $ENV{RELEASE_TESTING} ); # Load the testing modules foreach my $MODULE ( @MODULES ) { eval "use $MODULE"; if ( $@ ) { $ENV{RELEASE_TESTING} ? die( "Failed to load required release-testing module $MODULE" ) : plan( skip_all => "$MODULE not available for testing" ); } } my %poded = ( 'Feersum::Connection::Handle' => { pod_from => 'blib/lib/Feersum/Connection/Handle.pm', }, 'Feersum::Connection::Writer' => { pod_from => 'blib/lib/Feersum/Connection/Handle.pm', }, 'Feersum::Connection::Reader' => { pod_from => 'blib/lib/Feersum/Connection/Handle.pm', }, 'Feersum::Connection' => { pod_from => 'blib/lib/Feersum/Connection.pm', }, 'Feersum::Runner' => { pod_from => 'blib/lib/Feersum/Runner.pm', }, 'Feersum' => { pod_from => 'blib/lib/Feersum.pm', }, 'Plack::Handler::Feersum' => { pod_from => 'blib/lib/Plack/Handler/Feersum.pm', }, 'feersum' => { pod_from => 'blib/script/feersum', }, ); plan tests => scalar keys %poded; while (my ($mod, $params) = each %poded) { $params->{pod_from} = File::Spec->catfile(split('/',$params->{pod_from})); pod_coverage_ok($mod, $params); } 1; Feersum-1.410/t/07-graceful-shutdown.t000644 000765 000024 00000005571 13762624365 020310 0ustar00audreytstaff000000 000000 #!perl use warnings; use strict; use constant HARDER => $ENV{RELEASE_TESTING} ? 10 : 1; use constant CLIENTS => HARDER * 3; use Test::More tests => 10 + 11 * CLIENTS; use Test::Fatal; use lib 't'; use Utils; BEGIN { use_ok('Feersum') }; my ($socket,$port) = get_listen_socket(); ok $socket, "made listen socket"; ok $socket->fileno, "has a fileno"; my $evh = Feersum->new(); { no warnings 'redefine'; *Feersum::DIED = sub { my $err = shift; fail "Died during request handler: $err"; }; } my $cv = AE::cv; my $started = 0; my $finished = 0; $evh->request_handler(sub { my $r = shift; isa_ok $r, 'Feersum::Connection', 'got an object!'; my $env = $r->env(); ok $env && ref($env) eq 'HASH'; ok $env->{'psgi.streaming'}, 'got psgi.streaming'; my $cnum = $env->{HTTP_X_CLIENT}; ok $cnum, "got client number"; $cv->begin; my $w = $r->start_streaming("200 OK", ['Content-Type' => 'text/plain']); $started++; isa_ok($w, 'Feersum::Connection::Writer', "got a writer $cnum"); isa_ok($w, 'Feersum::Connection::Handle', "... it's a handle $cnum"); my $t; $t = AE::timer 1.5+rand(0.5), 0, sub { is exception { $w->write("So graceful!\n"); $w->close(); }, undef, "wrote after waiting a little $cnum"; undef $t; # keep timer alive until it runs undef $w; $cv->end; $finished++; }; }); is exception { $evh->use_socket($socket); }, undef, 'assigned socket'; my @got; sub client { my $cnum = sprintf("%04d",shift); $cv->begin; my $h; $h = simple_client GET => '/foo', name => $cnum, timeout => 3, headers => { "Accept" => "*/*", 'X-Client' => $cnum, }, sub { my ($body, $headers) = @_; is $headers->{Status}, 200, "$cnum got 200"; is $headers->{'transfer-encoding'}, "chunked", "$cnum got chunked!"; is $body, "So graceful!\n", "$cnum got body"; $cv->end; undef $h; }; } client($_) for (1..CLIENTS); $cv->begin; my $death; my $grace_t = AE::timer 1.0, 0, sub { pass "calling for shutdown"; $death = AE::timer 2.5, 0, sub { fail "SHUTDOWN TOOK TOO LONG"; exit 1; }; $evh->graceful_shutdown(sub { pass "all gracefully shut down, supposedly"; undef $death; $cv->end; }); }; $cv->begin; my $try_connect = AE::timer 1.4, 0, sub { my $h; $h = AnyEvent::Handle->new( connect => ["localhost", $port], on_connect => sub { fail "boo, connected when shut down"; $cv->end; undef $h; }, on_error => sub { pass "cool, shouldn't be able to connect"; $cv->end; undef $h; } ); }; $cv->recv; is $started, CLIENTS, 'handlers started'; is $finished, CLIENTS, 'handlers finished'; pass "all done"; Feersum-1.410/t/99-pod.t000644 000765 000024 00000001202 13762624365 015427 0ustar00audreytstaff000000 000000 #!/usr/bin/perl # Test that the syntax of our POD documentation is valid use strict; BEGIN { $| = 1; $^W = 1; } my @MODULES = ( 'Pod::Simple 3.07', 'Test::Pod 1.26', ); # Don't run tests during end-user installs use Test::More; plan( skip_all => 'Author tests not required for installation' ) unless ( $ENV{RELEASE_TESTING} or $ENV{AUTOMATED_TESTING} ); # Load the testing modules foreach my $MODULE ( @MODULES ) { eval "use $MODULE"; if ( $@ ) { $ENV{RELEASE_TESTING} ? die( "Failed to load required release-testing module $MODULE" ) : plan( skip_all => "$MODULE not available for testing" ); } } all_pod_files_ok(); 1; Feersum-1.410/t/02-array-body.t000644 000765 000024 00000002443 13762624365 016706 0ustar00audreytstaff000000 000000 #!perl use warnings; use strict; use Test::More tests => 12; use Test::Fatal; use utf8; use lib 't'; use Utils; BEGIN { use_ok('Feersum') }; my ($socket,$port) = get_listen_socket(); ok $socket, "made listen socket"; ok $socket->fileno, "has a fileno"; my $evh = Feersum->new(); $evh->request_handler(sub { my $r = shift; isa_ok $r, 'Feersum::Connection', 'got an object!'; is exception { $r->send_response("200 OK", [ 'Content-Type' => 'text/plain; charset=UTF-8', 'Connection' => 'close', ], ['this ',\'should ',undef,'be ','cøncātenated.']); }, undef, 'sent response'; }); is exception { $evh->use_socket($socket); }, undef, 'assigned socket'; my $cv = AE::cv; $cv->begin; my $w = simple_client GET => '/?blar', timeout => 3, sub { my ($body, $headers) = @_; is $headers->{Status}, 200, "client got 200"; is $headers->{'content-type'}, 'text/plain; charset=UTF-8'; $body = Encode::decode_utf8($body) unless Encode::is_utf8($body); is $headers->{'content-length'}, bytes::length($body), 'content-length was calculated correctly'; is $body, 'this should be cøncātenated.', 'body was concatenated together'; $cv->end; }; $cv->recv; pass "all done"; Feersum-1.410/t/Utils.pm000644 000765 000024 00000014403 13762624365 015666 0ustar00audreytstaff000000 000000 package Utils; use strict; use base 'Exporter'; use Test::More (); use Socket qw/SOMAXCONN/; use IO::Socket::INET; use bytes; no bytes; use blib; use Carp qw(carp cluck confess croak); use Encode (); use AnyEvent (); use AnyEvent::Handle (); use Guard (); use Scalar::Util qw/blessed weaken/; use utf8; $SIG{PIPE} = 'IGNORE'; my $CRLF = "\015\012"; sub import { my ($pkg) = caller; no strict 'refs'; *{$pkg.'::carp'} = \&Carp::carp; *{$pkg.'::cluck'} = \&Carp::cluck; *{$pkg.'::confess'} = \&Carp::confess; *{$pkg.'::croak'} = \&Carp::croak; *{$pkg.'::guard'} = \&Guard::guard; *{$pkg.'::scope_guard'} = \&Guard::scope_guard; *{$pkg.'::weaken'} = \&Scalar::Util::weaken; *{$pkg.'::blessed'} = \&Scalar::Util::blessed; *{$pkg.'::get_listen_socket'} = \&get_listen_socket; *{$pkg.'::simple_client'} = \&simple_client; return 1; } our $last_port; sub get_listen_socket { my $start = shift || 10000; my $max = shift || $start + 10000; for (my $i=$start; $i <= $max; $i++) { my $socket = IO::Socket::INET->new( LocalAddr => "localhost:$i", ReuseAddr => 1, Proto => 'tcp', Listen => SOMAXCONN, Blocking => 0, ); if ($socket) { $last_port = $i; return $socket unless wantarray; return ($socket,$i); } } } sub _cb_ewrapper { my ($code, $name) = @_; return(sub {}) unless $code; return sub { eval { $code->(@_) }; if ($@) { Test::More::fail "$name callback failed"; Test::More::diag $@ } }; } sub simple_client ($$;@) { my $done_cb = pop; my $method = shift; my $uri = shift; my %opts = @_; my $name = delete $opts{name} || 'simple_client'; my $port = delete $opts{port} || $last_port; $done_cb = _cb_ewrapper($done_cb, "$name done"); my $conn_cb = _cb_ewrapper(delete $opts{on_connect}, "$name connect"); my $buf = ''; my %hdrs; my $err_cb = sub { my ($h,$fatal,$msg) = @_; $hdrs{Status} = 599; $hdrs{Reason} = $msg; $h->destroy; $done_cb->(undef,\%hdrs); }; require AnyEvent::Handle; my $h; $h = AnyEvent::Handle->new( connect => ['127.0.0.1',$port], on_connect => sub { my $h = shift; Test::More::pass("$name connected"); $conn_cb->($h); return; }, on_error => $err_cb, timeout => $opts{timeout} || 30, ); my $strong_h = $h; weaken($h); my $done = sub { $done_cb->($buf,\%hdrs); $h->destroy if $h; }; $h->on_read(sub { Test::More::fail "$name got extra bytes!"; }); $h->push_read(line => "$CRLF$CRLF", sub { { my @hdrs = split($CRLF, $_[1]); my $status_line = shift @hdrs; %hdrs = map { my ($k,$v) = split(/:\s+/,$_); (lc($k),$v); } @hdrs; # $hdrs{OrigHead} = $head; if ($status_line =~ m{HTTP/(1.\d) (\d{3}) +(.+)\s*}) { $hdrs{HTTPVersion} = $1; $hdrs{Status} = $2; $hdrs{Reason} = $3; } } $hdrs{'content-length'} = 0 if ($hdrs{Status} == 204); if ($hdrs{Status} == 304) { # should have no body $h->on_read(sub { $buf .= substr($_[0]->{rbuf},0,length($_[0]->{rbuf}),''); }); $h->on_eof($done); } elsif (exists $hdrs{'content-length'}) { return $done->() unless ($hdrs{'content-length'}); # Test::More::diag "$name waiting for C-L body"; $h->push_read(chunk => $hdrs{'content-length'}, sub { $buf = $_[1]; return $done->(); }); } elsif (($hdrs{'transfer-encoding'}||'') eq 'chunked') { # Test::More::diag "$name waiting for T-E:chunked body"; my $len = 0; my ($chunk_reader, $chunk_handler); $chunk_handler = sub { if ($len == 0) { undef $chunk_reader; undef $chunk_handler; return $done->(); } # remove CRLF at end of chunk: $buf .= substr($_[1],0,-2); $h->push_read(line => $CRLF, $chunk_reader); }; $chunk_reader = sub { my $hex = $_[1]; $len = hex $hex; if (!defined($len)) { $err_cb->($h,0,"invalid chunk length '$hex'"); undef $chunk_reader; undef $chunk_handler; return; } else { # add two for after-chunk CRLF $h->push_read(chunk => $len+2, $chunk_handler); } }; $h->push_read(line => $CRLF, $chunk_reader); } elsif ($hdrs{HTTPVersion} eq '1.0' or ($hdrs{connection}||'') eq 'close') { # Test::More::diag "$name waiting for conn:close body"; $h->on_read(sub { $buf .= substr($_[0]->{rbuf},0,length($_[0]->{rbuf}),''); }); $h->on_eof($done); } else { $err_cb->($h,0, "got a response that I don't know how to handle the body for"); return; } }); my $host = 'localhost'; #delete $opts{host} my $headers = delete $opts{headers}; my $proto = delete $opts{proto} || '1.1'; my $body = delete $opts{body} || ''; $headers->{'User-Agent'} ||= 'FeersumSimpleClient/1.0'; $headers->{'Host'} ||= $host.':'.$port; if (length($body)) { $headers->{'Content-Length'} ||= length($body); $headers->{'Content-Type'} ||= 'text/plain'; } # HTTP/1.1 default is 'keep-alive' $headers->{'Connection'} ||= 'close'; my $head = join($CRLF, map {$_.': '.$headers->{$_}} sort keys %$headers); my $http_req = "$method $uri HTTP/$proto$CRLF"; $strong_h->push_write($http_req); $strong_h->push_write($head.$CRLF.$CRLF.$body) unless $opts{skip_head}; # $http_req =~ s/$CRLF/\n/sg; # Test::More::diag($http_req); return $strong_h; } 1; Feersum-1.410/t/10-respond-304.t000644 000765 000024 00000003643 13762624365 016615 0ustar00audreytstaff000000 000000 #!perl use warnings; use strict; use Test::More tests => 21; use Test::Fatal; use utf8; use lib 't'; use Utils; BEGIN { use_ok('Feersum') }; my ($socket,$port) = get_listen_socket(); ok $socket, "made listen socket"; ok $socket->fileno, "has a fileno"; my $evh = Feersum->new(); $evh->request_handler(sub { my $r = shift; isa_ok $r, 'Feersum::Connection', 'got an object!'; my $env = $r->env; ok $env, 'got env'; is exception { if ($env->{HTTP_X_CLIENT} == 1) { $r->send_response("304", [], []); # explicit string, not num } else { $r->send_response("304 Not Modified", ['Content-Length'=>123], []); } }, undef, 'sent response for '.$env->{HTTP_X_CLIENT}; }); is exception { $evh->use_socket($socket); }, undef, 'assigned socket'; my $cv = AE::cv; $cv->begin; my $w = simple_client GET => '/?blef', headers => { 'X-Client' => 1 }, timeout => 3, sub { my ($body, $headers) = @_; is $headers->{Status}, 304, "client got 304"; ok !exists $headers->{'content-type'}, 'missing c-t'; # 304 not-modifieds shouldn't auto-generate a content-length header or # any other "entity" headers. These reflect the actual entity, and # can update cache's respresentation of the object. ok !exists $headers->{'content-length'},'no c-l generated'; ok !$body, 'no body'; $cv->end; }; $cv->begin; my $w2 = simple_client GET => '/?blef', headers => { 'X-Client' => 2 }, timeout => 3, sub { my ($body, $headers) = @_; is $headers->{Status}, 304, "2nd client got 304"; ok !exists $headers->{'content-type'}, 'missing c-t'; # If the app specified a C-L, we should respect it for the same # reasons. is $headers->{'content-length'}, 123, 'c-l not replaced'; ok !$body, 'no body'; $cv->end; }; $cv->recv; pass "all done"; Feersum-1.410/t/14-guard.t000644 000765 000024 00000004374 13762624365 015747 0ustar00audreytstaff000000 000000 #!perl use warnings; use strict; use Test::More tests => 22; use utf8; use lib 't'; use Utils; use Guard qw/guard/; BEGIN { use_ok('Feersum') }; my ($socket,$port) = get_listen_socket(); ok $socket, "made listen socket"; ok $socket->fileno, "has a fileno"; my $guard_fired = 0; my $cv; my $endjinn = Feersum->new(); $endjinn->use_socket($socket); $endjinn->request_handler(sub { my $r = shift; $r->response_guard(guard { $guard_fired++; fail "guard called (should get cancelled)"; }); $r->response_guard->cancel; is $guard_fired, 0, "guard didn't fire yet (cancelled)"; $r->response_guard(guard { $guard_fired++; $cv->end; pass "guard called"; }); $r->send_response(200,[],\"OK"); pass 'sent response'; }); $cv = AE::cv; $guard_fired = 0; $cv->begin; $cv->begin; # for the guard my $w1 = simple_client GET => '/simple', timeout => 3, sub { my ($body, $hdr) = @_; is $hdr->{Status}, 200, "client got 200"; is $body, 'OK', 'plain old body'; $cv->end; }; $cv->recv; is $guard_fired, 1, "guard fired only once"; pass 'done simple guard'; $endjinn->request_handler(sub { my $r = shift; my $env = $r->env; ok $env->{'psgix.output.guard'}, 'env says the writer has this guard'; scope_for_writer: { my $w = $r->start_streaming(200,[]); $w->response_guard(guard { $guard_fired++; fail "guard called (should get cancelled)"; }); $w->response_guard->cancel; is $guard_fired, 0, "guard didn't fire yet (cancelled)"; $w->response_guard(guard { $guard_fired++; pass "stream writer guard called"; }); $w->write("STREAM OK"); is $guard_fired, 0, "guard didn't fire yet (not closed)"; $w->close(); } is $guard_fired, 0, "guard didn't fire yet (closed, not gc)"; pass 'sent response'; }); $cv = AE::cv; $cv->begin; $guard_fired = 0; my $w2 = simple_client GET => '/streamer', timeout => 3, sub { my ($body, $hdr) = @_; is $hdr->{Status}, 200, "client got 200"; is $body, 'STREAM OK', 'plain old body'; $cv->end; }; $cv->recv; is $guard_fired, 1, "guard fired only once"; pass "all done"; Feersum-1.410/t/50-psgi-simple.t000644 000765 000024 00000002325 13762624365 017070 0ustar00audreytstaff000000 000000 #!perl use warnings; use strict; use constant CLIENTS => $ENV{RELEASE_TESTING} ? 15 : 2; use Test::More tests => 4 + 5*CLIENTS; use lib 't'; use Utils; BEGIN { use_ok('Feersum') }; my ($socket,$port) = get_listen_socket(); ok $socket, "made listen socket"; my $evh = Feersum->new(); { no warnings 'redefine'; *Feersum::DIED = sub { my $err = shift; fail "Died during request handler: $err"; }; } $evh->use_socket($socket); my $APP = <<'EOAPP'; my $app = sub { my $env = shift; Test::More::ok $env, "got an env in callback"; return [ 200, ['Content-Type' => 'text/plain'], ['Hello ','World'] ]; }; EOAPP my $app = eval $APP; ok $app, 'got an app' || diag $@; $evh->psgi_request_handler($app); my $cv = AE::cv; for my $n (1 .. CLIENTS) { $cv->begin; my $h; $h = simple_client GET => '/', name => "($n)", sub { my ($body, $headers) = @_; is $headers->{'Status'}, 200, "($n) Response OK"; is $headers->{'content-type'}, 'text/plain', "... ($n) is text"; is $body, 'Hello World', "... ($n) correct body"; $cv->end; undef $h; }; } $cv->recv; pass "all done"; Feersum-1.410/t/15-write_array.t000644 000765 000024 00000004754 13762624365 017200 0ustar00audreytstaff000000 000000 #!perl use warnings; use strict; use constant HARDER => $ENV{RELEASE_TESTING} ? 10 : 1; use constant CLIENTS => HARDER * 2; use Test::More tests => 4 + 10 * CLIENTS; use lib 't'; use Utils; BEGIN { use_ok('Feersum') }; my ($socket,$port) = get_listen_socket(); ok $socket, "made listen socket"; ok $socket->fileno, "has a fileno"; my $endjinn = Feersum->new(); $endjinn->use_socket($socket); { no warnings 'redefine'; *Feersum::DIED = sub { my $err = shift; fail "Died during request handler: $err"; }; } my $cv = AE::cv; my $started = 0; my $finished = 0; $endjinn->request_handler(sub { my $r = shift; isa_ok $r, 'Feersum::Connection', 'got an object!'; my $env = $r->env(); ok $env && ref($env) eq 'HASH'; my $cnum = $env->{'HTTP_X_CLIENT'}; $cv->begin; my $w = $r->start_streaming("200 OK", ['Content-Type' => 'text/plain', 'X-Client' => $cnum, 'X-Fileno' => $r->fileno ]); $started++; isa_ok($w, 'Feersum::Connection::Writer', "got a writer $cnum"); isa_ok($w, 'Feersum::Connection::Handle', "... it's a handle $cnum"); my @first = ( "$cnum Hello streaming world! chunk one\n", \"$cnum Hello streaming world! chunk two\n", undef, "$cnum Hello streaming world! chunk three\n", \"$cnum Hello streaming world! chunk four\n", ); $w->write_array(\@first); $w->close; $cv->end; pass "$cnum handler completed"; }); sub client { my $cnum = sprintf("%04d",shift); $cv->begin; my $h; $h = simple_client GET => '/foo', name => $cnum, timeout => 15, proto => '1.1', headers => { "Accept" => "*/*", 'X-Client' => $cnum, }, sub { my ($body, $headers) = @_; is $headers->{Status}, 200, "$cnum got 200" or diag $headers->{Reason}; is $headers->{HTTPVersion}, '1.1', "$cnum version"; is $headers->{'transfer-encoding'}, "chunked", "$cnum got chunked!"; is_deeply [split /\n/,$body], [ "$cnum Hello streaming world! chunk one", "$cnum Hello streaming world! chunk two", "$cnum Hello streaming world! chunk three", "$cnum Hello streaming world! chunk four", ], "$cnum got all four lines" or do { warn "descriptor ".$headers->{'x-fileno'}." failed!"; exit 2; }; $cv->end; undef $h; }; } client($_,1) for (1..CLIENTS); $cv->recv; pass "all done"; Feersum-1.410/t/60-plack.t000644 000765 000024 00000002220 13762624365 015724 0ustar00audreytstaff000000 000000 #!perl use strict; use Test::More; use blib; BEGIN { $Plack::Test::Impl = 'Server'; $ENV{PLACK_SERVER} = 'Feersum'; $ENV{PLACK_ENV} = 'development'; plan skip_all => "Need Plack >= 0.9950 to run this test" unless eval 'require Plack; $Plack::VERSION >= 0.995'; } use Plack::Test; use Plack::Loader; plan tests => 7; is(Plack::Loader->guess(), 'Feersum', "guess feersum"); loader_load: { my $svr = Plack::Loader->load('Feersum'); isa_ok $svr, 'Plack::Handler::Feersum', "explicit load"; } loader_auto: { my $svr = Plack::Loader->auto(host => 'ignored', port => '654321'); isa_ok $svr, 'Plack::Handler::Feersum', "auto-load"; } test_psgi( app => sub { my $env = shift; ok $env->{'psgix.body.scalar_refs'}, "seems to be Feersum"; is_deeply $env->{'psgi.version'}, [1,1], "is PSGI 1.1"; return [ 200, [ 'Content-Type' => 'text/plain' ], [ "Hello World" ] ], }, client => sub { my $cb = shift; my $req = HTTP::Request->new(GET => "http://localhost/hello"); my $res = $cb->($req); like $res->content, qr/Hello World/, "hello!"; } ); pass 'done'; Feersum-1.410/t/11-runner.t000644 000765 000024 00000005752 13762624365 016154 0ustar00audreytstaff000000 000000 #!perl use warnings; use strict; use Test::More; use utf8; use lib 't'; use Utils; BEGIN { plan skip_all => "Need Test::TCP 1.06 to run this test" unless eval 'require Test::TCP; $Test::TCP::VERSION >= 1.06'; } use Test::TCP; my $feersum_script; for my $dir (qw(blib/script blib/bin)) { if (-f "$dir/feersum") { $feersum_script = "$dir/feersum"; last; } } plan skip_all => "can't locate feersum starter script" unless $feersum_script; plan tests => 15; ok -f 'eg/app.feersum' && -r _, "found eg/app.feersum"; ok -f 'eg/chat.feersum' && -r _, "found eg/chat.feersum"; test_tcp( client => sub { my $port = shift; my $cv = AE::cv; $cv->begin; my $cli = simple_client GET => '/', port => $port, name => 'manual runner', sub { my ($body,$headers) = @_; is $headers->{Status}, 200, "http success"; like $body, qr/^Hello customer number 0x[0-9a-f]+$/; $cv->end; }; $cv->recv; }, server => sub { use_ok 'Feersum::Runner'; my $port = shift; my $runner; eval { my $app = do 'eg/app.feersum'; ok $app, "did the app"; $runner = Feersum::Runner->new( listen => ["localhost:$port"], app => $app ); ok $runner, "got a runner"; }; warn $@ if $@; eval { ok $runner->{app}, "still got the app"; $runner->run(); }; warn $@ if $@; }, ); test_tcp( client => sub { my $port = shift; my $cv = AE::cv; $cv->begin; my $cli = simple_client GET => '/', port => $port, name => 'script runner', sub { my ($body,$headers) = @_; is $headers->{Status}, 200, "script http success"; like $body, qr/^Hello customer number 0x[0-9a-f]+$/; $cv->end; }; $cv->recv; }, server => sub { my $port = shift; exec "$^X -Mblib $feersum_script --listen localhost:$port ". "--native eg/app.feersum"; }, ); SKIP: { skip "can't locate JSON::XS", 3 unless eval "require JSON::XS"; test_tcp( client => sub { my $port = shift; my $cv = AE::cv; $cv->begin; my $cli = simple_client GET => '/', port => $port, name => 'chat runner', sub { my ($body,$headers) = @_; is $headers->{Status}, 200, "chat http success"; like $body, qr{Chat!}; $cv->end; }; $cv->recv; }, server => sub { my $port = shift; exec "$^X -Mblib $feersum_script --listen localhost:$port ". "--native eg/chat.feersum"; }, ); } Feersum-1.410/t/62-plack-runner.t000644 000765 000024 00000004315 13762624365 017244 0ustar00audreytstaff000000 000000 #!perl use strict; use Test::More; use blib; use lib 't'; use Utils; BEGIN { plan skip_all => "Need Plack >= 0.9950 to run this test" unless eval 'require Plack; $Plack::VERSION >= 0.995'; plan skip_all => "Need Test::TCP 1.06 to run this test" unless eval 'require Test::TCP; $Test::TCP::VERSION >= 1.06'; } plan tests => 6; use Test::TCP; use Config; test_tcp( client => sub { my $port = shift; my $cv = AE::cv; $cv->begin; my $cli = simple_client GET => '/', port => $port, name => 'feersum runner', sub { my ($body,$headers) = @_; is $headers->{Status}, 200, "script http success"; like $body, qr/^Hello customer number 0x[0-9a-f]+$/; $cv->end; }; $cv->recv; }, server => sub { my $port = shift; exec "$^X -Mblib blib/script/feersum --listen localhost:$port ". "eg/app.psgi"; }, ); my $plackup; for my $key (qw(bin scriptdir sitebin sitescript vendbin vendscript)) { my $dir = $Config{$key.'exp'}; next unless $dir; my $pu = "$dir/plackup"; next unless (-e $pu && -x _); my $plackup_ver = `$^X $pu --version`; next unless ($plackup_ver =~ /Plack (\d.\d+)/ && $1 >= 0.995); $plackup = $pu; chomp $plackup_ver; diag "found plackup: $plackup ($plackup_ver)"; last; } SKIP: { skip "can't locate plackup in script/bin dirs", 3 unless $plackup; test_tcp( client => sub { my $port = shift; my $cv = AE::cv; $cv->begin; my $cli = simple_client GET => '/', port => $port, name => 'plackup runner', sub { my ($body,$headers) = @_; is $headers->{Status}, 200, "script http success"; like $body, qr/^Hello customer number 0x[0-9a-f]+$/; $cv->end; }; $cv->recv; }, server => sub { my $port = shift; exec "$^X -Mblib $plackup -E deployment ". "-s Feersum --listen localhost:$port eg/app.psgi"; }, ); } Feersum-1.410/t/55-psgi-leak.t000644 000765 000024 00000003203 13762624365 016514 0ustar00audreytstaff000000 000000 #!perl use warnings; use strict; use constant CLIENTS => 10; use Test::More; BEGIN { if (eval q{ require Test::LeakTrace; $Test::LeakTrace::VERSION >= 0.13 }) { plan tests => 7 + 4*CLIENTS; } else { plan skip_all => "Need Test::LeakTrace >= 0.13 to run this test" } } use lib 't'; use Utils; use Test::LeakTrace; BEGIN { use_ok('Feersum') }; my ($socket,$port) = get_listen_socket(); ok $socket, "made listen socket"; my $evh = Feersum->new(); { no warnings 'redefine'; *Feersum::DIED = sub { my $err = shift; fail "Died during request handler: $err"; }; } $evh->use_socket($socket); my $APP = <<'EOAPP'; my $app = sub { return [200, ['Content-Type' => 'text/plain'], ['Hello ','World']]; }; EOAPP my $app = eval $APP; ok $app, 'got an app' || diag $@; $evh->psgi_request_handler($app); my $cv = AE::cv; no_leaks_ok { return unless $cv; for my $n (1 .. CLIENTS) { $cv->begin; my $h; $h = simple_client GET => '/', name => "($n)", sub { my ($body, $headers) = @_; is $headers->{'Status'}, 200, "($n) Response OK"; is $headers->{'content-type'}, 'text/plain', "... ($n) is text"; is $body, 'Hello World', "... ($n) correct body"; $cv->end; undef $h; }; } $cv->recv; pass "done requests"; $cv = undef; } 'request leaks'; $cv = AE::cv; no_leaks_ok { return unless $cv; $evh->graceful_shutdown(sub { $cv->send }); $cv->recv; pass "done graceful shutdown"; undef $cv; undef $evh; } 'graceful shutdown leaks'; Feersum-1.410/t/06-input.t000644 000765 000024 00000007462 13762624365 016006 0ustar00audreytstaff000000 000000 #!perl use warnings; use strict; use Test::More tests => 53; use Test::Fatal; use Fcntl qw/SEEK_CUR SEEK_SET SEEK_END/; use lib 't'; use Utils; BEGIN { use_ok('Feersum') }; my ($socket,$port) = get_listen_socket(); ok $socket, "made listen socket"; ok $socket->fileno, "has a fileno"; my $evh = Feersum->new(); my $cv = AE::cv; $evh->use_socket($socket); $evh->request_handler(sub { my $r = shift; my $env = $r->env(); my $cl = $env->{CONTENT_LENGTH}; my $input = $env->{'psgi.input'}; ok blessed($input) && $input->can('read'), "got input handle"; my ($body,$read); $body = undef; if ($env->{HTTP_X_CLIENT} == 1) { $read = $input->read($body, 1); is $body, 't', "got first letter"; is $read, 1, "read just one byte"; $read = $input->read($body, $cl); is $body, 'testing partial reads', "buffer has whole body now"; is $read, $cl-1, "read the rest of the content"; $read = $input->read($body, 1); is $read, 0, "EOF"; } elsif ($env->{HTTP_X_CLIENT} == 2) { $read = $input->read($body, $env->{CONTENT_LENGTH}); is $read, $env->{CONTENT_LENGTH}, "read whole body"; is length($body), $env->{CONTENT_LENGTH}, "buffer has whole body"; is $body, 'testing slurp'; $read = $input->read($body, 1); is $read, 0, "EOF"; } elsif ($env->{HTTP_X_CLIENT} == 3) { $read = $input->read($body, 999, -6); is $read, 6, "read w/ too-big offset"; is $body, 'offset', "got the last word"; $body .= ' '; $read = $input->read($body, 7, 5); is $read, 7, "read again w/ offset"; is $body, 'offset testing', "got both words"; } elsif ($env->{HTTP_X_CLIENT} == 4) { ok $input->seek(0,SEEK_CUR), "can always seek to cur"; ok $input->seek(5, SEEK_SET); $read = $input->read($body, 3); is $read, 3; is $body, 'and', "seek_set worked"; ok !$input->seek(-1, SEEK_CUR), "can't seek back"; ok $input->seek(1, SEEK_CUR), "can seek forward"; ok $input->seek(-7, SEEK_END), "can seek from end"; # 'find it' ok !$input->seek(-8, SEEK_END), "can seek back from end"; $body = ''; $read = $input->read($body, 4); is $read, 4; is $body, 'find'; ok !$input->seek(-1, SEEK_CUR), "can't seek back"; $read = $input->read($body, 3); is $body, 'find it'; } else { fail "don't know about client $env->{HTTP_X_CLIENT}"; } is exception { $input->close(); }, undef, 'closed handle'; $r->send_response(200, ['Content-Type' => 'text/plain'], [uc $body]); pass "sent response"; }); $cv->begin; my $w = simple_client POST => "/uppercase", headers => { 'X-Client' => 1 }, body => 'testing partial reads', timeout => 3, sub { my ($body, $headers) = @_; is $headers->{Status}, 200, 'ok'; is $body, 'TESTING PARTIAL READS', 'uppercased partial'; $cv->end; }; $cv->begin; my $w2 = simple_client POST => "/uppercase", headers => { 'X-Client' => 2 }, body => 'testing slurp', timeout => 3, sub { my ($body, $headers) = @_; is $headers->{Status}, 200, 'ok'; is $body, 'TESTING SLURP', 'uppercased slurp'; $cv->end; }; $cv->begin; my $w3 = simple_client POST => "/uppercase", headers => { 'X-Client' => 3 }, body => 'blah testing offset', timeout => 3, sub { my ($body, $headers) = @_; is $headers->{Status}, 200, 'ok'; is $body, 'OFFSET TESTING', 'uppercased and reversed'; $cv->end; }; $cv->begin; my $w4 = simple_client POST => "/uppercase", headers => { 'X-Client' => 4 }, body => 'seek and you shall find it', timeout => 3, sub { my ($body, $headers) = @_; is $headers->{Status}, 200, 'ok'; is $body, 'FIND IT', 'uppercased seeking'; $cv->end; }; $cv->recv; pass "all done"; Feersum-1.410/t/51-psgi-streaming.t000644 000765 000024 00000007543 13762624365 017600 0ustar00audreytstaff000000 000000 #!perl use warnings; use strict; use Test::More tests => 36; use lib 't'; use Utils; BEGIN { use_ok('Feersum') }; my ($socket,$port) = get_listen_socket(); ok $socket, "made listen socket"; my $evh = Feersum->new(); { no warnings 'redefine'; *Feersum::DIED = sub { my $err = shift; fail "Died during request handler: $err"; }; } $evh->use_socket($socket); { package Message; my $n = 0; sub new { return bless {}, 'Message' } sub to_json { ++$n; return qq({"message":"O hai $n"}) } } sub wait_for_new_message { my $cb = shift; my $t; $t = AE::timer rand(0.5),0,sub { $cb->(Message->new()); undef $t; # cancel circular-ref }; return; } # from the PSGI::FAQ my $APP = <<'EOAPP'; my $app = sub { my $env = shift; unless ($env->{'psgi.streaming'}) { die "This application needs psgi.streaming support"; } Test::More::pass "called app"; return sub { Test::More::pass "called streamer"; my $respond = shift; wait_for_new_message(sub { my $message = shift; my $body = [ $message->to_json ]; Test::More::pass "sending response"; undef $env; $respond->([200, ['Content-Type', 'application/json'], $body]); Test::More::pass "sent response"; }); }; }; EOAPP my $app = eval $APP; ok $app, 'got an app' || diag $@; $evh->psgi_request_handler($app); returning_body: { my $cv = AE::cv; $cv->begin; my $h; $h = simple_client GET => '/', sub { my ($body, $headers) = @_; is $headers->{'Status'}, 200, "Response OK"; is $headers->{'content-type'}, 'application/json', "... is JSON"; ok !$headers->{'transfer-encoding'}, '... no T-E header'; is $body, q({"message":"O hai 1"}), '... correct body'; $cv->end; undef $h; }; $cv->recv; pass "all done app 1"; } my $APP2 = <<'EOAPP'; my $app2 = sub { my $env = shift; unless ($env->{'psgi.streaming'}) { die "This application needs psgi.streaming support"; } Test::More::pass "called app2"; return sub { Test::More::pass "called streamer2"; my $respond = shift; wait_for_new_message(sub { my $message = shift; Test::More::pass "sending response2"; my $w = $respond->([200, ['Content-Type', 'application/json']]); Test::More::pass "started response2"; $w->write($message->to_json); Test::More::pass "done response2"; $w->close; undef $env; }); }; }; EOAPP my $app2 = eval $APP2; ok $app2, 'got app 2' || diag $@; $evh->psgi_request_handler($app2); using_writer: { my $cv = AE::cv; $cv->begin; my $h; $h = simple_client GET => '/', sub { my ($body, $headers) = @_; is $headers->{'Status'}, 200, "Response OK"; is $headers->{'content-type'}, 'application/json', "... is JSON"; is $headers->{'transfer-encoding'}, 'chunked', '... was chunked'; is $body, q({"message":"O hai 2"}), "... correct de-chunked body"; $cv->end; undef $h; }; $cv->recv; } using_writer_and_1_0: { my $cv = AE::cv; $cv->begin; my $h2; $h2 = simple_client GET => '/', proto => '1.0', sub { my ($body, $headers) = @_; is $headers->{'Status'}, 200, "Response OK"; is $headers->{'content-type'}, 'application/json', "... is JSON"; ok !$headers->{'transfer-encoding'}, '... was not chunked'; is $headers->{'connection'}, 'close', '... got close'; is $body, q({"message":"O hai 3"}), "... correct body"; $cv->end; undef $h2; }; $cv->recv; } pass "all done app 2"; Feersum-1.410/t/99-manifest.t000644 000765 000024 00000001114 13762624365 016455 0ustar00audreytstaff000000 000000 #!/usr/bin/perl # Test that the module MANIFEST is up-to-date use strict; BEGIN { $| = 1; $^W = 1; } my @MODULES = ( 'Test::DistManifest 1.003', ); # Don't run tests during end-user installs use Test::More; plan( skip_all => 'Author tests not required for installation' ) unless ( $ENV{RELEASE_TESTING} ); # Load the testing modules foreach my $MODULE ( @MODULES ) { eval "use $MODULE"; if ( $@ ) { $ENV{RELEASE_TESTING} ? die( "Failed to load required release-testing module $MODULE" ) : plan( skip_all => "$MODULE not available for testing" ); } } manifest_ok(); 1; Feersum-1.410/t/63-plack-apps.t000644 000765 000024 00000005304 13762624365 016676 0ustar00audreytstaff000000 000000 #!perl use strict; use Test::More; use blib; use lib 't'; use Utils; BEGIN { $ENV{PLACK_TEST_IMPL} = 'Server'; $ENV{PLACK_SERVER} = 'Feersum'; $ENV{PLACK_ENV} = 'deployment'; plan skip_all => "Need Plack >= 0.9950 to run this test" unless eval 'require Plack; $Plack::VERSION >= 0.995'; } plan tests => 6; use Plack::Test; use Plack::Test; use Plack::Builder; use Plack::App::File; use Plack::App::Cascade; use Plack::Request; use Plack::LWPish; use Test::TCP; via_map: test_psgi( app => builder { mount '/' => Plack::App::File->new(root => 't'); }, client => sub { my $cb = shift; my $req = HTTP::Request->new(GET => "http://localhost/63-plack-apps.t"); my $res = $cb->($req); my $s = "# IS THIS FILE"." STATICALLY SERVED?"; is $res->code, 200; like $res->content, qr/^\Q$s\E$/m, "found static line"; } ); cascaded: test_psgi( app => builder { mount '/' => Plack::App::Cascade->new(apps => [ Plack::App::File->new(root => 'notfound')->to_app, Plack::App::File->new(root => 'me-neither')->to_app, Plack::App::File->new(root => 't')->to_app, ]); }, client => sub { my $cb = shift; my $req = HTTP::Request->new(GET => "http://localhost/63-plack-apps.t"); my $res = $cb->($req); my $s = "# IS THIS FILE"." STATICALLY SERVED?"; is $res->code, 200; like $res->content, qr/^\Q$s\E$/m, "found static line (cascade)"; } ); via_redirect: test_psgi( # these two tests fail randomly on some platforms with keep_alive on. # from the pod... # BUGS - Keep-alive is ignored completely. ua => Plack::LWPish->new( no_proxy => [qw/127.0.0.1/], keep_alive => 0 ), app => builder { mount '/static' => Plack::App::Cascade->new(apps => [ Plack::App::File->new(root => 'notfound')->to_app, Plack::App::File->new(root => 't')->to_app, ]); mount '/' => sub { my $env = shift; my $req = Plack::Request->new($env); my $res = $req->new_response(200); if ($req->path eq '/') { $res->redirect('/static/63-plack-apps.t'); } else { $res->code(404); } $res->finalize; }; }, client => sub { my $cb = shift; my $req = HTTP::Request->new(GET => "http://localhost/"); my $res = $cb->($req); my $s = "# IS THIS FILE"." STATICALLY SERVED?"; is $res->code, 200; like $res->content, qr/^\Q$s\E$/m, "found static line (cascade)"; } ); __END__ # IS THIS FILE STATICALLY SERVED? Feersum-1.410/t/08-read-timeout.t000644 000765 000024 00000007432 13762624365 017245 0ustar00audreytstaff000000 000000 #!perl use warnings; use strict; use constant HARDER => $ENV{RELEASE_TESTING} ? 10 : 1; use constant POST_CLIENTS => HARDER*1; use constant GET_CLIENTS => HARDER*1; use constant GOOD_CLIENTS => HARDER*1; use Test::More tests => 19 + 2*POST_CLIENTS + 2*GET_CLIENTS + 4*GOOD_CLIENTS; use Test::Fatal; use lib 't'; use Utils; BEGIN { use_ok('Feersum') }; my ($socket,$port) = get_listen_socket(); ok $socket, "made listen socket"; ok $socket->fileno, "has a fileno"; my $evh = Feersum->new(); is exception { $evh->use_socket($socket) }, undef,; $evh->request_handler(sub { my $r = shift; my $env = $r->env(); ok $env->{HTTP_X_GOOD_CLIENT}, "got a request from a good client"; $r->send_response(200, ["Content-Type" => "text/plain"], "thx."); }); my $default = $evh->read_timeout; is $default, 5.0, "default timeout is 5 seconds"; like exception { $evh->read_timeout(-1.0) }, qr/^must set a positive \(non-zero\) value for the timeout/, "can't set a negative number"; is $evh->read_timeout, 5.0; like exception { $evh->read_timeout(0) }, qr/^must set a positive \(non-zero\) value for the timeout/, "can't set a negative number"; is $evh->read_timeout, 5.0; like exception { no warnings 'numeric'; $evh->read_timeout("this isn't a number"); }, qr/^must set a positive \(non-zero\) value for the timeout/, "can't set a string as the timeout"; is $evh->read_timeout, 5.0; is exception { $evh->read_timeout(6+1) }, undef, "IV is OK"; is $evh->read_timeout, 7.0, "new timeout set"; is exception { $evh->read_timeout("8.0") }, undef, "NV-as-string is OK"; is $evh->read_timeout, 8.0, "new timeout set"; is exception { $evh->read_timeout($default) }, undef, "NV is OK"; is $evh->read_timeout, $default, "reset to default"; my $cv = AE::cv; sub timeout_get_client { my $n = shift; $cv->begin; my $ot; $ot = AE::timer rand(1), 0, sub { my $h; $h = simple_client GET => '/', name => "(get $n)", timeout => 10, skip_head => 1, sub { my ($body,$headers) = @_; is $headers->{Status}, 408, "(get $n) got timeout"; $cv->end; undef $h; }; undef $ot; }; } sub timeout_post_client { my $n = shift; $cv->begin; my $ot; $ot = AE::timer rand(1), 0, sub { my $h; $h = simple_client POST => '/', name => "(post $n)", timeout => 10, headers => { # C-L with no body puts simple_client into stream mode 'Content-Length' => 8, 'Content-Type' => 'text/plain', }, sub { my ($body,$headers) = @_; is $headers->{Status}, 408, "(post $n) got timeout"; $cv->end; undef $h; }; $h->push_write("o "); # 2 out of claimed 8 bytes my $t; $t = AE::timer rand(2.5),0,sub { $h->push_write("hai"); # 3 more out of claimed 8 bytes undef $t; # keep ref }; undef $ot; }; } sub good_client { my $n = "(good $_[0])"; $cv->begin; my $ot; $ot = AE::timer rand(1),0,sub { my $h; $h = simple_client POST => "/rad", name => $n, headers => {'X-Good-Client' => 1}, body => 'Here it is!', sub { my ($body,$headers) = @_; is $headers->{Status}, 200, "$n got 200"; is $body, "thx.", "$n got body"; $cv->end; undef $h; # keep ref }; undef $ot; }; } my $t; $t = AE::timer 20, 0, sub { $cv->croak("TOO LONG"); }; $cv->begin; timeout_get_client($_) for (1 .. GET_CLIENTS); timeout_post_client($_) for (1 .. POST_CLIENTS); good_client($_) for (1 .. GOOD_CLIENTS); $cv->end; is exception { $cv->recv }, undef, "no client errors"; pass "all done"; Feersum-1.410/t/53-psgi-overloaded.t000644 000765 000024 00000003332 13762624365 017725 0ustar00audreytstaff000000 000000 #!perl use warnings; use strict; use Test::More tests => 12; use lib 't'; use Utils; BEGIN { use_ok('Feersum') }; my ($socket,$port) = get_listen_socket(); ok $socket, "made listen socket"; my $evh = Feersum->new(); { no warnings 'redefine'; *Feersum::DIED = sub { my $err = shift; fail "Died during request handler: $err"; }; } $evh->use_socket($socket); { package Ovrldr; use overload q(&{}) => sub { shift->{the_code} }, fallback => 1; sub new { my $class = shift; my $the_code = shift; my $self = bless { the_code => $the_code }, $class; return $self; } } my $APP = <<'EOAPP'; my $app = Ovrldr->new(sub { my $env = shift; unless ($env->{'psgi.streaming'}) { die "This application needs psgi.streaming support"; } Test::More::pass "called app"; return Ovrldr->new(sub { Test::More::pass "called streamer"; my $respond = shift; my $msg = q({"message":"O hai 1"}); $respond->([200, ['Content-Type', 'application/json'], [$msg]]); Test::More::pass "sent response"; }); }); EOAPP my $app = eval $APP; ok $app, 'got an app' || diag $@; $evh->psgi_request_handler($app); returning_body: { my $cv = AE::cv; $cv->begin; my $h; $h = simple_client GET => '/', sub { my ($body, $headers) = @_; is $headers->{'Status'}, 200, "Response OK"; is $headers->{'content-type'}, 'application/json', "... is JSON"; ok !$headers->{'transfer-encoding'}, '... no T-E header'; is $body, q({"message":"O hai 1"}), '... correct body'; $cv->end; undef $h; }; $cv->recv; } pass "all done"; Feersum-1.410/t/99-fixme.t000644 000765 000024 00000001240 13762624365 015757 0ustar00audreytstaff000000 000000 #!/usr/bin/perl # Check source files for 'FIX'.'ME' statements use strict; BEGIN { $| = 1; $^W = 1; } my @MODULES = ( 'Test::Fixme 0.04', ); # Don't run tests during end-user installs use Test::More; plan( skip_all => 'Author tests not required for installation' ) unless ( $ENV{RELEASE_TESTING} or $ENV{AUTOMATED_TESTING} ); # Load the testing modules foreach my $MODULE ( @MODULES ) { eval "use $MODULE"; if ( $@ ) { $ENV{RELEASE_TESTING} ? die( "Failed to load required release-testing module $MODULE" ) : plan( skip_all => "$MODULE not available for testing" ); } } run_tests(where => [qw(lib bin eg t)], match => qr/[T]ODO|[F]IXME|[X]XX/); 1; Feersum-1.410/picohttpparser-git/picohttpparser.h000644 000765 000024 00000001722 13762624543 023033 0ustar00audreytstaff000000 000000 #ifndef picohttpparser_h #define picohttpparser_h /* $Id: e8df3d19ac99b0e989e41f8281fd710fa94d17d4 $ */ #ifdef __cplusplus extern "C" { #endif /* contains name and value of a header (name == NULL if is a continuing line * of a multiline header */ struct phr_header { const char* name; size_t name_len; const char* value; size_t value_len; }; /* returns number of bytes cosumed if successful, -2 if request is partial, * -1 if failed */ int phr_parse_request(const char* buf, size_t len, const char** method, size_t* method_len, const char** path, size_t* path_len, int* minor_version, struct phr_header* headers, size_t* num_headers, size_t last_len); /* ditto */ int phr_parse_response(const char* _buf, size_t len, int *minor_version, int *status, const char **msg, size_t *msg_len, struct phr_header* headers, size_t* num_headers, size_t last_len); #ifdef __cplusplus } #endif #endif Feersum-1.410/picohttpparser-git/test_response.c000644 000765 000024 00000010371 13762624543 022654 0ustar00audreytstaff000000 000000 #include #include #include "picohttpparser.h" void tests(int num) { printf("1..%d\n", num); } void ok(int ok, const char* msg) { static int testnum = 0; printf("%s %d - %s\n", ok ? "ok" : "not ok", ++testnum, msg); } int strrcmp(const char* s, size_t l, const char* t) { return strlen(t) == l && memcmp(s, t, l) == 0; } int main(void) { int minor_version; int status; const char *msg; size_t msg_len; struct phr_header headers[4]; size_t num_headers; tests(61); #define PARSE(s, last_len, exp, comment) \ num_headers = sizeof(headers) / sizeof(headers[0]); \ ok(phr_parse_response(s, strlen(s), &minor_version, &status, \ &msg, &msg_len, headers, \ &num_headers, last_len) \ == (exp == 0 ? strlen(s) : exp), \ comment) PARSE("HTTP/1.0 200 OK\r\n\r\n", 0, 0, "simple"); ok(num_headers == 0, "# of headers"); ok(status == 200, "http status code"); ok(minor_version = 1, "method"); ok(strrcmp(msg, msg_len, "OK"), "msg"); PARSE("HTTP/1.0 200 OK\r\n\r", 0, -2, "partial"); PARSE("HTTP/1.1 200 OK\r\nHost: example.com\r\nCookie: \r\n\r\n", 0, 0, "parse headers"); ok(num_headers == 2, "# of headers"); ok(minor_version == 1, "minor_version"); ok(status == 200, "status"); ok(strrcmp(msg, msg_len, "OK"), "msg"); ok(strrcmp(headers[0].name, headers[0].name_len, "Host"), "host"); ok(strrcmp(headers[0].value, headers[0].value_len, "example.com"), "host value"); ok(strrcmp(headers[1].name, headers[1].name_len, "Cookie"), "cookie"); ok(strrcmp(headers[1].value, headers[1].value_len, ""), "cookie value"); PARSE("HTTP/1.0 200 OK\r\nfoo: \r\nfoo: b\r\n \tc\r\n\r\n", 0, 0, "parse multiline"); ok(num_headers == 3, "# of headers"); ok(minor_version == 0, "minor_version"); ok(status == 200, "status"); ok(strrcmp(msg, msg_len, "OK"), "msg"); ok(strrcmp(headers[0].name, headers[0].name_len, "foo"), "header #1 name"); ok(strrcmp(headers[0].value, headers[0].value_len, ""), "header #1 value"); ok(strrcmp(headers[1].name, headers[1].name_len, "foo"), "header #2 name"); ok(strrcmp(headers[1].value, headers[1].value_len, "b"), "header #2 value"); ok(headers[2].name == NULL, "header #3"); ok(strrcmp(headers[2].value, headers[2].value_len, " \tc"), "header #3 value"); PARSE("HTTP/1.0 500 Internal Server Error\r\n\r\n", 0, 0, "internal server error"); ok(num_headers == 0, "# of headers"); ok(minor_version == 0, "minor_version"); ok(status == 500, "status"); ok(strrcmp(msg, msg_len, "Internal Server Error"), "msg"); ok(msg_len == sizeof("Internal Server Error")-1, "msg_len"); PARSE("H", 0, -2, "incomplete 1"); PARSE("HTTP/1.", 0, -2, "incomplete 2"); PARSE("HTTP/1.1", 0, -2, "incomplete 3"); ok(minor_version == -1, "minor_version not ready"); PARSE("HTTP/1.1 ", 0, -2, "incomplete 4"); ok(minor_version == 1, "minor_version ready"); PARSE("HTTP/1.1 2", 0, -2, "incomplete 5"); PARSE("HTTP/1.1 200", 0, -2, "incomplete 6"); ok(status == 0, "status not ready"); PARSE("HTTP/1.1 200 ", 0, -2, "incomplete 7"); ok(status == 200, "status ready"); PARSE("HTTP/1.1 200 O", 0, -2, "incomplete 8"); PARSE("HTTP/1.1 200 OK\r", 0, -2, "incomplete 9"); ok(msg == NULL, "message not ready"); PARSE("HTTP/1.1 200 OK\r\n", 0, -2, "incomplete 10"); ok(strrcmp(msg, msg_len, "OK"), "message ready"); PARSE("HTTP/1.1 200 OK\n", 0, -2, "incomplete 11"); ok(strrcmp(msg, msg_len, "OK"), "message ready 2"); PARSE("HTTP/1.1 200 OK\r\nA: 1\r", 0, -2, "incomplete 11"); ok(num_headers == 0, "header not ready"); PARSE("HTTP/1.1 200 OK\r\nA: 1\r\n", 0, -2, "incomplete 12"); ok(num_headers == 1, "header ready"); ok(strrcmp(headers[0].name, headers[0].name_len, "A"), "header #1 name"); ok(strrcmp(headers[0].value, headers[0].value_len, "1"), "header #1 value"); PARSE("HTTP/1.0 200 OK\r\n\r", strlen("GET /hoge HTTP/1.0\r\n\r") - 1, -2, "slowloris (incomplete)"); PARSE("HTTP/1.0 200 OK\r\n\r\n", strlen("HTTP/1.0 200 OK\r\n\r\n") - 1, 0, "slowloris (complete)"); PARSE("HTTP/1. 200 OK\r\n\r\n", 0, -1, "invalid http version"); PARSE("HTTP/1.2z 200 OK\r\n\r\n", 0, -1, "invalid http version 2"); PARSE("HTTP/1.1 OK\r\n\r\n", 0, -1, "no status code"); #undef PARSE return 0; } Feersum-1.410/picohttpparser-git/test.c000644 000765 000024 00000006421 13762624543 020737 0ustar00audreytstaff000000 000000 #include #include #include "picohttpparser.h" void tests(int num) { printf("1..%d\n", num); } void ok(int ok, const char* msg) { static int testnum = 0; printf("%s %d - %s\n", ok ? "ok" : "not ok", ++testnum, msg); } int strrcmp(const char* s, size_t l, const char* t) { return strlen(t) == l && memcmp(s, t, l) == 0; } int main(void) { const char* method; size_t method_len; const char* path; size_t path_len; int minor_version; struct phr_header headers[4]; size_t num_headers; tests(42); #define PARSE(s, last_len, exp, comment) \ num_headers = sizeof(headers) / sizeof(headers[0]); \ ok(phr_parse_request(s, strlen(s), &method, &method_len, &path, \ &path_len, &minor_version, headers, \ &num_headers, last_len) \ == (exp == 0 ? strlen(s) : exp), \ comment) PARSE("GET / HTTP/1.0\r\n\r\n", 0, 0, "simple"); ok(num_headers == 0, "# of headers"); ok(strrcmp(method, method_len, "GET"), "method"); ok(strrcmp(path, path_len, "/"), "path"); ok(minor_version == 0, "minor version"); PARSE("GET / HTTP/1.0\r\n\r", 0, -2, "partial"); PARSE("GET /hoge HTTP/1.1\r\nHost: example.com\r\nCookie: \r\n\r\n", 0, 0, "parse headers"); ok(num_headers == 2, "# of headers"); ok(strrcmp(method, method_len, "GET"), "method"); ok(strrcmp(path, path_len, "/hoge"), "path"); ok(minor_version == 1, "minor version"); ok(strrcmp(headers[0].name, headers[0].name_len, "Host"), "host"); ok(strrcmp(headers[0].value, headers[0].value_len, "example.com"), "host value"); ok(strrcmp(headers[1].name, headers[1].name_len, "Cookie"), "cookie"); ok(strrcmp(headers[1].value, headers[1].value_len, ""), "cookie value"); PARSE("GET / HTTP/1.0\r\nfoo: \r\nfoo: b\r\n \tc\r\n\r\n", 0, 0, "parse multiline"); ok(num_headers == 3, "# of headers"); ok(strrcmp(method, method_len, "GET"), "method"); ok(strrcmp(path, path_len, "/"), "path"); ok(minor_version == 0, "minor version"); ok(strrcmp(headers[0].name, headers[0].name_len, "foo"), "header #1 name"); ok(strrcmp(headers[0].value, headers[0].value_len, ""), "header #1 value"); ok(strrcmp(headers[1].name, headers[1].name_len, "foo"), "header #2 name"); ok(strrcmp(headers[1].value, headers[1].value_len, "b"), "header #2 value"); ok(headers[2].name == NULL, "header #3"); ok(strrcmp(headers[2].value, headers[2].value_len, " \tc"), "header #3 value"); PARSE("GET", 0, -2, "incomplete 1"); ok(method == NULL, "method not ready"); PARSE("GET ", 0, -2, "incomplete 2"); ok(strrcmp(method, method_len, "GET"), "method ready"); PARSE("GET /", 0, -2, "incomplete 3"); ok(path == NULL, "path not ready"); PARSE("GET / ", 0, -2, "incomplete 4"); ok(strrcmp(path, path_len, "/"), "path ready"); PARSE("GET / H", 0, -2, "incomplete 5"); PARSE("GET / HTTP/1.", 0, -2, "incomplete 6"); PARSE("GET / HTTP/1.0", 0, -2, "incomplete 7"); ok(minor_version == -1, "version not ready"); PARSE("GET / HTTP/1.0\r", 0, -2, "incomplete 8"); ok(minor_version == 0, "version is ready"); PARSE("GET /hoge HTTP/1.0\r\n\r", strlen("GET /hoge HTTP/1.0\r\n\r") - 1, -2, "slowloris (incomplete)"); PARSE("GET /hoge HTTP/1.0\r\n\r\n", strlen("GET /hoge HTTP/1.0\r\n\r\n") - 1, 0, "slowloris (complete)"); #undef PARSE return 0; } Feersum-1.410/picohttpparser-git/picohttpparser.c000644 000765 000024 00000017307 13762624543 023034 0ustar00audreytstaff000000 000000 #include #include "picohttpparser.h" /* $Id: 2bb2f4c32652b53c0f54838e068c05293c70cfd6 $ */ #if __GNUC__ >= 3 # define likely(x) __builtin_expect(!!(x), 1) # define unlikely(x) __builtin_expect(!!(x), 0) #else # define likely(x) (x) # define unlikely(x) (x) #endif #define CHECK_EOF() \ if (buf == buf_end) { \ *ret = -2; \ return NULL; \ } #define EXPECT_CHAR(ch) \ CHECK_EOF(); \ if (*buf++ != ch) { \ *ret = -1; \ return NULL; \ } #define ADVANCE_TOKEN(tok, toklen) do { \ const char* tok_start = buf; \ for (; ; ++buf) { \ CHECK_EOF(); \ if (*buf == ' ') { \ break; \ } else if (*buf == '\015' || *buf == '\012') { \ *ret = -1; \ return NULL; \ } \ } \ tok = tok_start; \ toklen = buf - tok_start; \ } while (0) static const char* get_token_to_eol(const char* buf, const char* buf_end, const char** token, size_t* token_len, int* ret) { const char* token_start = buf; while (1) { if (likely(buf_end - buf >= 16)) { unsigned i; for (i = 0; i < 16; i++, ++buf) { if (unlikely((unsigned char)*buf <= '\015') && (*buf == '\015' || *buf == '\012')) { goto EOL_FOUND; } } } else { for (; ; ++buf) { CHECK_EOF(); if (unlikely((unsigned char)*buf <= '\015') && (*buf == '\015' || *buf == '\012')) { goto EOL_FOUND; } } } } EOL_FOUND: if (*buf == '\015') { ++buf; EXPECT_CHAR('\012'); *token_len = buf - 2 - token_start; } else { /* should be: *buf == '\012' */ *token_len = buf - token_start; ++buf; } *token = token_start; return buf; } static const char* is_complete(const char* buf, const char* buf_end, size_t last_len, int* ret) { int ret_cnt = 0; buf = last_len < 3 ? buf : buf + last_len - 3; while (1) { CHECK_EOF(); if (*buf == '\015') { ++buf; CHECK_EOF(); EXPECT_CHAR('\012'); ++ret_cnt; } else if (*buf == '\012') { ++buf; ++ret_cnt; } else { ++buf; ret_cnt = 0; } if (ret_cnt == 2) { return buf; } } *ret = -2; return NULL; } /* *_buf is always within [buf, buf_end) upon success */ static const char* parse_int(const char* buf, const char* buf_end, int* value, int* ret) { int v; CHECK_EOF(); if (! ('0' <= *buf && *buf <= '9')) { *ret = -1; return NULL; } v = 0; for (; ; ++buf) { CHECK_EOF(); if ('0' <= *buf && *buf <= '9') { v = v * 10 + *buf - '0'; } else { break; } } *value = v; return buf; } /* returned pointer is always within [buf, buf_end), or null */ static const char* parse_http_version(const char* buf, const char* buf_end, int* minor_version, int* ret) { EXPECT_CHAR('H'); EXPECT_CHAR('T'); EXPECT_CHAR('T'); EXPECT_CHAR('P'); EXPECT_CHAR('/'); EXPECT_CHAR('1'); EXPECT_CHAR('.'); return parse_int(buf, buf_end, minor_version, ret); } static const char* parse_headers(const char* buf, const char* buf_end, struct phr_header* headers, size_t* num_headers, size_t max_headers, int* ret) { for (; ; ++*num_headers) { CHECK_EOF(); if (*buf == '\015') { ++buf; EXPECT_CHAR('\012'); break; } else if (*buf == '\012') { ++buf; break; } if (*num_headers == max_headers) { *ret = -1; return NULL; } if (*num_headers == 0 || ! (*buf == ' ' || *buf == '\t')) { /* parsing name, but do not discard SP before colon, see * http://www.mozilla.org/security/announce/2006/mfsa2006-33.html */ headers[*num_headers].name = buf; for (; ; ++buf) { CHECK_EOF(); if (*buf == ':') { break; } else if (*buf < ' ') { *ret = -1; return NULL; } } headers[*num_headers].name_len = buf - headers[*num_headers].name; ++buf; for (; ; ++buf) { CHECK_EOF(); if (! (*buf == ' ' || *buf == '\t')) { break; } } } else { headers[*num_headers].name = NULL; headers[*num_headers].name_len = 0; } if ((buf = get_token_to_eol(buf, buf_end, &headers[*num_headers].value, &headers[*num_headers].value_len, ret)) == NULL) { return NULL; } } return buf; } const char* parse_request(const char* buf, const char* buf_end, const char** method, size_t* method_len, const char** path, size_t* path_len, int* minor_version, struct phr_header* headers, size_t* num_headers, size_t max_headers, int* ret) { /* skip first empty line (some clients add CRLF after POST content) */ CHECK_EOF(); if (*buf == '\015') { ++buf; EXPECT_CHAR('\012'); } else if (*buf == '\012') { ++buf; } /* parse request line */ ADVANCE_TOKEN(*method, *method_len); ++buf; ADVANCE_TOKEN(*path, *path_len); ++buf; if ((buf = parse_http_version(buf, buf_end, minor_version, ret)) == NULL) { return NULL; } if (*buf == '\015') { ++buf; EXPECT_CHAR('\012'); } else if (*buf == '\012') { ++buf; } else { *ret = -1; return NULL; } return parse_headers(buf, buf_end, headers, num_headers, max_headers, ret); } int phr_parse_request(const char* buf_start, size_t len, const char** method, size_t* method_len, const char** path, size_t* path_len, int* minor_version, struct phr_header* headers, size_t* num_headers, size_t last_len) { const char * buf = buf_start, * buf_end = buf_start + len; size_t max_headers = *num_headers; int r; *method = NULL; *method_len = 0; *path = NULL; *path_len = 0; *minor_version = -1; *num_headers = 0; /* if last_len != 0, check if the request is complete (a fast countermeasure againt slowloris */ if (last_len != 0 && is_complete(buf, buf_end, last_len, &r) == NULL) { return r; } if ((buf = parse_request(buf, buf_end, method, method_len, path, path_len, minor_version, headers, num_headers, max_headers, &r)) == NULL) { return r; } return buf - buf_start; } static const char* parse_response(const char* buf, const char* buf_end, int* minor_version, int* status, const char** msg, size_t* msg_len, struct phr_header* headers, size_t* num_headers, size_t max_headers, int* ret) { /* parse "HTTP/1.x" */ if ((buf = parse_http_version(buf, buf_end, minor_version, ret)) == NULL) { return NULL; } /* skip space */ if (*buf++ != ' ') { *ret = -1; return NULL; } /* parse status code */ if ((buf = parse_int(buf, buf_end, status, ret)) == NULL) { return NULL; } /* skip space */ if (*buf++ != ' ') { *ret = -1; return NULL; } /* get message */ if ((buf = get_token_to_eol(buf, buf_end, msg, msg_len, ret)) == NULL) { return NULL; } return parse_headers(buf, buf_end, headers, num_headers, max_headers, ret); } int phr_parse_response(const char* buf_start, size_t len, int* minor_version, int* status, const char** msg, size_t* msg_len, struct phr_header* headers, size_t* num_headers, size_t last_len) { const char * buf = buf_start, * buf_end = buf + len; size_t max_headers = *num_headers; int r; *minor_version = -1; *status = 0; *msg = NULL; *msg_len = 0; *num_headers = 0; /* if last_len != 0, check if the response is complete (a fast countermeasure against slowloris */ if (last_len != 0 && is_complete(buf, buf_end, last_len, &r) == NULL) { return r; } if ((buf = parse_response(buf, buf_end, minor_version, status, msg, msg_len, headers, num_headers, max_headers, &r)) == NULL) { return r; } return buf - buf_start; } #undef CHECK_EOF #undef EXPECT_CHAR #undef ADVANCE_TOKEN Feersum-1.410/picohttpparser-git/bench.c000644 000765 000024 00000002417 13762624543 021040 0ustar00audreytstaff000000 000000 #include #include #include "picohttpparser.h" #define REQ "GET /wp-content/uploads/2010/03/hello-kitty-darth-vader-pink.jpg HTTP/1.1\r\nHost: www.kittyhell.com\r\nUser-Agent: Mozilla/5.0 (Macintosh; U; Intel Mac OS X 10.6; ja-JP-mac; rv:1.9.2.3) Gecko/20100401 Firefox/3.6.3 Pathtraq/0.9\r\nAccept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8\r\nAccept-Language: ja,en-us;q=0.7,en;q=0.3\r\nAccept-Encoding: gzip,deflate\r\nAccept-Charset: Shift_JIS,utf-8;q=0.7,*;q=0.7\r\nKeep-Alive: 115\r\nConnection: keep-alive\r\nCookie: wp_ozh_wsa_visits=2; wp_ozh_wsa_visit_lasttime=xxxxxxxxxx; __utma=xxxxxxxxx.xxxxxxxxxx.xxxxxxxxxx.xxxxxxxxxx.xxxxxxxxxx.x; __utmz=xxxxxxxxx.xxxxxxxxxx.x.x.utmccn=(referral)|utmcsr=reader.livedoor.com|utmcct=/reader/|utmcmd=referral\r\n\r\n" int main(void) { const char* method; size_t method_len; const char* path; size_t path_len; int minor_version; struct phr_header headers[32]; size_t num_headers; int i, ret; for (i = 0; i < 1000000; i++) { num_headers = sizeof(headers) / sizeof(headers[0]); ret = phr_parse_request(REQ, sizeof(REQ) - 1, &method, &method_len, &path, &path_len, &minor_version, headers, &num_headers, 0); assert(ret == sizeof(REQ) - 1); } return 0; } Feersum-1.410/bin/feersum000755 000765 000024 00000003314 13762624365 016130 0ustar00audreytstaff000000 000000 #!/usr/bin/env perl use warnings; use strict; use EV (); use Feersum (); require Getopt::Long; my $native = 0; Getopt::Long::Configure("no_ignore_case", "no_auto_abbrev", "pass_through"); Getopt::Long::GetOptions( "native!" => \$native, ); my $runner; if ($native) { my $listen = 'localhost:5000'; my $pre_fork = 0; my $verbose = 0; Getopt::Long::GetOptions( "listen=s" => \$listen, "pre-fork=i" => \$pre_fork, "verbose!" => \$verbose, ); require Feersum::Runner; my $app_file = pop @ARGV || 'app.feersum'; $runner = Feersum::Runner->new( 'listen' => [$listen], app_file => $app_file, pre_fork => $pre_fork, quiet => !$verbose, ); } else { my @args = ( server => 'Feersum', env => 'deployment', version_cb => sub { print "Feersum $Feersum::VERSION on EV $EV::VERSION\n"; } ); require Plack::Runner; $runner = Plack::Runner->new(@args); $runner->parse_options(@ARGV); } $runner->run; __END__ =head1 NAME feersum - feersum app loader =head1 SYNOPSIS feersum [plackup opts] [--pre-fork=N] [app.psgi] feersum --native [--listen host:port] [--pre-fork=N] [app.feersum] =head1 DESCRIPTION Loads the specified app file into a Feersum server. In both cases, if C<--pre-fork=N> is specified, that many worker processes are used to serve requests. See L for details. If in native mode (when running C), currently only a C<--listen> parameter is accepted. By default, the server will listen on localhost port 5000. When running in PSGI mode (non-native), L is used. See that module for documentation and defaults. =cut