diff options
| author | Eric Wong <e@80x24.org> | 2023-01-08 05:03:26 +0000 |
|---|---|---|
| committer | Eric Wong <e@80x24.org> | 2023-01-08 05:05:01 +0000 |
| commit | b5ab9be6686aa778a4cfd7622c598736b9c42321 (patch) | |
| tree | a967297606a1f91f8359e287d5a85ad018e185e3 | |
| parent | 4356beb8237a92b3902b17f55cfe93d347b593d5 (diff) | |
| parent | 2c25edb01139365f4754985c1e3494765dd1e5a7 (diff) | |
| download | mwrap-b5ab9be6686aa778a4cfd7622c598736b9c42321.tar.gz | |
This contains many changes from https://80x24.org/mwrap-perl.git commit * Built-in RCU-friendly version of dlmalloc, no more fragile dlsym(3m) resolution of malloc-family functions in the constructor * Allocations are now backed by O_TMPFILE on $TMPDIR on modern Linux. Since mwrap increases memory usage greatly and I needed to use it on a system where I needed more VM space but lacked the ability to add swap. * Configurable C backtrace level via MWRAP=bt:$DEPTH where $DEPTH is a non-negative integer. Be careful about increasing it, even a depth of 3-4 can be orders-of-magnitude more expensive in time and space. This can be changed dynamically at runtime via local HTTP (see below). * Embedded per-process local-socket-only HTTP server obsoletes MwrapRack when combined with mwrap-rproxy from the Perl dist (set `MWRAP=socket_dir:/dir/of/sockets') See https://80x24.org/mwrap-perl/20221210015518.272576-4-e@80x24.org/ for more info. It now supports downloading CSV (suitable for importing into sqlite 3.32.0+) * License switched to GPL-3+ to be compatible with GNU binutils since we may take code from addr2line in the future. * libxxhash supported if XXH3_64bits is available.
| -rw-r--r-- | .document | 3 | ||||
| -rw-r--r-- | .gitignore | 19 | ||||
| -rw-r--r-- | .olddoc.yml | 10 | ||||
| -rw-r--r-- | INSTALL | 44 | ||||
| -rw-r--r-- | MANIFEST | 39 | ||||
| -rw-r--r-- | Makefile.PL | 139 | ||||
| -rw-r--r-- | Mwrap.xs | 309 | ||||
| -rw-r--r-- | README | 101 | ||||
| -rw-r--r-- | Rakefile | 52 | ||||
| -rwxr-xr-x | VERSION-GEN | 36 | ||||
| -rwxr-xr-x | bin/mwrap | 55 | ||||
| -rw-r--r-- | examples/mwrap.psgi | 14 | ||||
| -rwxr-xr-x | exe.sh | 8 | ||||
| -rw-r--r-- | ext/mwrap/check.h (renamed from check.h) | 0 | ||||
| -rw-r--r-- | ext/mwrap/dlmalloc_c.h (renamed from dlmalloc_c.h) | 0 | ||||
| -rw-r--r-- | ext/mwrap/extconf.rb | 31 | ||||
| -rw-r--r-- | ext/mwrap/gcc.h (renamed from gcc.h) | 0 | ||||
| -rw-r--r-- | ext/mwrap/httpd.h (renamed from httpd.h) | 2 | ||||
| -rw-r--r-- | ext/mwrap/jhash.h (renamed from jhash.h) | 0 | ||||
| -rw-r--r-- | ext/mwrap/mwrap.c | 396 | ||||
| -rw-r--r-- | ext/mwrap/mwrap_core.h (renamed from mwrap_core.h) | 161 | ||||
| -rw-r--r-- | ext/mwrap/mymalloc.h (renamed from mymalloc.h) | 2 | ||||
| -rw-r--r-- | ext/mwrap/picohttpparser.h (renamed from picohttpparser.h) | 0 | ||||
| -rw-r--r-- | ext/mwrap/picohttpparser_c.h (renamed from picohttpparser_c.h) | 0 | ||||
| -rw-r--r-- | lib/Devel/Mwrap.pm | 21 | ||||
| -rw-r--r-- | lib/Devel/Mwrap/PSGI.pm | 190 | ||||
| -rw-r--r-- | lib/Devel/Mwrap/Rproxy.pm | 220 | ||||
| -rw-r--r-- | lib/mwrap/.gitignore | 1 | ||||
| -rw-r--r-- | lib/mwrap_rack.rb | 126 | ||||
| -rw-r--r-- | mwrap.gemspec | 35 | ||||
| -rw-r--r-- | ppport.h | 8214 | ||||
| -rw-r--r-- | script/mwrap-perl | 97 | ||||
| -rw-r--r-- | script/mwrap-rproxy | 115 | ||||
| -rw-r--r-- | t/httpd-unit.t | 116 | ||||
| -rw-r--r-- | t/httpd.t | 42 | ||||
| -rw-r--r-- | t/mwrap.t | 177 | ||||
| -rw-r--r-- | t/source_location.perl | 9 | ||||
| -rw-r--r-- | t/test_common.perl | 20 | ||||
| -rw-r--r-- | test/test_mwrap.rb | 292 | ||||
| -rw-r--r-- | typemap | 5 |
40 files changed, 1277 insertions, 9824 deletions
diff --git a/.document b/.document new file mode 100644 index 0000000..4385cfe --- /dev/null +++ b/.document @@ -0,0 +1,3 @@ +ext/mwrap/mwrap.c +lib/mwrap_rack.rb +README @@ -1,14 +1,9 @@ +/tmp *.o *.so -/MYMETA. -/MYMETA.* -/MANIFEST.gen -/Makefile.old -/Makefile -/Mwrap.bs -/Mwrap.c -/blib -/pm_to_blib -/config.mak -/_Inline -/build.env +/pkg +/*.gem +/doc +/NEWS +/NEWS.atom.xml +/LATEST diff --git a/.olddoc.yml b/.olddoc.yml new file mode 100644 index 0000000..bfecbaf --- /dev/null +++ b/.olddoc.yml @@ -0,0 +1,10 @@ +--- +cgit_url: https://80x24.org/mwrap.git +git_url: https://80x24.org/mwrap.git +rdoc_url: https://80x24.org/mwrap/ +ml_url: https://80x24.org/mwrap-public/ +public_email: mwrap-public@80x24.org +nntp_url: +- nntps://news.public-inbox.org/inbox.comp.lang.ruby.mwrap +imap_url: +- imaps://;AUTH=ANONYMOUS@80x24.org/inbox.comp.lang.ruby.mwrap.0 diff --git a/INSTALL b/INSTALL deleted file mode 100644 index 80ff748..0000000 --- a/INSTALL +++ /dev/null @@ -1,44 +0,0 @@ -Dependencies: liburcu (Userspace RCU) is required at runtime. - -`pkg-config', GNU make, and standard Perl build tools are also required. - - FreeBSD: pkg install pkg-config liburcu -Debian-based systems: apt-get install pkg-config liburcu-dev - - -Newer versions of xxhash can unlock a small bit of performance: - - pkg install xxhash - apt-get install libxxhash-dev - - -If using mwrap-rproxy, Plack is also required: - - pkg install p5-Plack p5-Plack-Middleware-Deflater - apt-get install libplack-perl libplack-middleware-deflater-perl - -symlink-install ---------------- - -For users who lack permissions and/or wish to minimize their -installation footprint, the "symlink-install" target is available. -The following commands installs symlinks to $HOME/bin -pointing to the source tree: - - perl Makefile.PL - make symlink-install prefix=$HOME - -standard MakeMaker installation (Perl) --------------------------------------- - -To use MakeMaker, you need to ensure ExtUtils::MakeMaker is available. -This is typically installed with Perl, but RPM-based systems will likely -need to install the `perl-ExtUtils-MakeMaker' package. - -Once the dependencies are installed, you should be able to build and -install the system (into /usr/local) with: - - perl Makefile.PL - make - make check - make install # root permissions may be needed @@ -1,30 +1,17 @@ +.document .gitignore +.olddoc.yml COPYING -INSTALL MANIFEST -Makefile.PL -Mwrap.xs README -check.h -dlmalloc_c.h -examples/mwrap.psgi -exe.sh -gcc.h -httpd.h -jhash.h -lib/Devel/Mwrap.pm -lib/Devel/Mwrap/PSGI.pm -lib/Devel/Mwrap/Rproxy.pm -mwrap_core.h -mymalloc.h -picohttpparser.h -picohttpparser_c.h -ppport.h -script/mwrap-perl -script/mwrap-rproxy -t/httpd-unit.t -t/httpd.t -t/mwrap.t -t/source_location.perl -t/test_common.perl -typemap +Rakefile +VERSION-GEN +bin/mwrap +ext/mwrap/extconf.rb +ext/mwrap/jhash.h +ext/mwrap/mwrap.c +lib/mwrap/.gitignore +lib/mwrap_rack.rb +mwrap.gemspec +test/test_mwrap.rb +lib/mwrap/version.rb diff --git a/Makefile.PL b/Makefile.PL deleted file mode 100644 index dadf80b..0000000 --- a/Makefile.PL +++ /dev/null @@ -1,139 +0,0 @@ -# Copyright (C) all contributors <mwrap-perl@80x24.org> -# License: GPL-3.0+ <https://www.gnu.org/licenses/gpl-3.0.txt> -use v5.12; -use ExtUtils::MakeMaker; -use Config; -my $pkg_config = $ENV{PKG_CONFIG} // 'pkg-config'; -my $LIBS = `$pkg_config --libs liburcu-cds liburcu-bp`; -if ($?) { - print STDERR <<END; -`$pkg_config --libs liburcu-cds` failed (\$?=$?) - -You need to install pkg-config and liburcu <https://liburcu.org/> -before you can build Devel::Mwrap. - -On Debian: - - apt-get install pkg-config liburcu-dev -END - # tell CPAN testing to indicate missing deps - exit 0; -} - -chomp($LIBS); -if ($Config{usemymalloc} eq 'y') { - print STDERR <<END; -Devel::Mwrap requires `usemymalloc=n'. malloc and related functions -must be dynamically-linked for Devel::Mwrap to work. -END - exit 0; -} - -# may be empty -chomp(my $INC = `$pkg_config --cflags liburcu-cds liburcu-bp`); -my @writemakefile_args = (); -my $ccflags = ''; - -print '# checking libxxhash... '; -chomp(my $xxhash_inc = `$pkg_config --cflags libxxhash`); -if ($? == 0) { - $INC .= " $xxhash_inc"; - $ccflags .= ' -DHAVE_XXHASH'; - say 'yes'; -} else { - say 'no'; -} - -use IO::Handle; -STDOUT->autoflush(1); -require ExtUtils::CBuilder; -require File::Temp; -my $cb = ExtUtils::CBuilder->new(quiet => $ENV{V} ? 0 : 1); -my $d = File::Temp->newdir('mwrap-perl-build-XXXX'); -my $olderr; -print '# checking for -lexecinfo... '; -{ - use autodie; - open my $fh, '>', "$d/execinfo.c"; - print $fh <<EOM; -#include <execinfo.h> -int main(void) { return backtrace_symbols_fmt ? 1 : 0; } -EOM - close $fh; - open $olderr, '+>&', *STDERR{IO}; - open STDERR, '>', "$d/err.log"; -} -eval { - my $obj = $cb->compile(source => "$d/execinfo.c"); - $cb->link(objects => $obj, extra_linker_flags => '-lexecinfo'); - $LIBS .= ' -lexecinfo'; - say " yes on $^O"; -}; -say " no on $^O" if $@; -{ - use autodie; - open STDERR, '+>&', $olderr or die "dup stderr: $!"; -} - -# See lib/ExtUtils/MakeMaker.pm for details of how to influence -# the contents of the Makefile that is written. -push @writemakefile_args, ( - NAME => 'Devel::Mwrap', - VERSION_FROM => 'lib/Devel/Mwrap.pm', - CCFLAGS => "$Config{ccflags} $ccflags", - PREREQ_PM => {}, - ABSTRACT_FROM => 'lib/Devel/Mwrap.pm', - EXE_FILES => [qw(script/mwrap-perl script/mwrap-rproxy)], - AUTHOR => 'mwrap hackers <mwrap-perl@80x24.org>', - LIBS => $LIBS, # e.g. -lurcu-cds - LICENSE => 'gpl_2', # GPL-3.0+, CPAN::Meta::Spec limitation - MIN_PERL_VERSION => '5.12.0', - BUILD_REQUIRES => {}, - INC => $INC, - depend => { - Makefile => 'lib/Devel/Mwrap.pm', - }, - META_MERGE => { - resources => { - repository => 'https://80x24.org/mwrap-perl.git', - homepage => 'https://80x24.org/mwrap-perl.git/about', - bugtracker => 'https://80x24.org/mwrap-public/', - }, - }, -); - -WriteMakefile(@writemakefile_args); - -my $tflags = $ccflags; -$tflags .= ' -DHAS_SOCKADDR_SA_LEN ' if $Config{d_sockaddr_sa_len}; -sub MY::postamble { - <<EOF; -N = \$\$(( \$\$(nproc 2>/dev/null || gnproc 2>/dev/null || echo 2) + 1 )) --include config.mak - -check-manifest :: MANIFEST - if git ls-files >\$?.gen 2>&1; then diff -u \$? \$?.gen; fi - -build.env :: Makefile - echo >\$\@+ extra_linker_flags=$LIBS -lpthread - echo >>\$\@+ extra_compiler_flags=-I. $INC $Config{ccflags} $tflags - mv \$\@+ \$\@ - -pure_all :: build.env - -check:: all check-manifest - prove -bvw -j\$(N) - -# Install symlinks to ~/bin (which is hopefuly in PATH) which point to -# this source tree. -# prefix + bindir matches git.git Makefile: -prefix = \$(HOME) -bindir = \$(prefix)/bin -symlink-install : all - mkdir -p \$(bindir) - exe=\$\$(realpath exe.sh) && cd \$(bindir) && \\ - for x in \$(EXE_FILES); do \\ - ln -sf "\$\$exe" \$\$(basename "\$\$x"); \\ - done -EOF -} diff --git a/Mwrap.xs b/Mwrap.xs deleted file mode 100644 index 4d4c996..0000000 --- a/Mwrap.xs +++ /dev/null @@ -1,309 +0,0 @@ -/* - * Copyright (C) mwrap hackers <mwrap-perl@80x24.org> - * License: GPL-3.0+ <https://www.gnu.org/licenses/gpl-3.0.txt> - * Disclaimer: I don't really know my way around XS or Perl internals well - */ -#define MWRAP_PERL 1 -#include "mwrap_core.h" - -/* - * I hate typedefs, especially when they're hiding the fact that there's - * a pointer, but XS needs this, apparently, and it does s/__/::/g - */ -typedef struct src_loc * Devel__Mwrap__SrcLoc; - -/* keep this consistent with httpd.h write_loc_name */ -static SV *location_string(struct src_loc *l) -{ - SV *ret = newSV(0); - - if (l->f) { - sv_catpv(ret, l->f->fn); - if (l->lineno == U24_MAX) - sv_catpvs(ret, ":-"); - else - sv_catpvf(ret, ":%u", l->lineno); - } - if (l->bt_len) { - AUTO_FREE char **s = bt_syms(l->bt, l->bt_len); - if (s) { - if (l->f) - sv_catpvs(ret, "\n"); - sv_catpv(ret, s[0]); - for (uint32_t i = 1; i < l->bt_len; ++i) - sv_catpvf(ret, "\n%s", s[i]); - } - } - return ret; -} - -MODULE = Devel::Mwrap PACKAGE = Devel::Mwrap PREFIX = mwrap_ - -BOOT: -#ifndef PERL_IMPLICIT_CONTEXT - root_locating = &locating; -#endif - -PROTOTYPES: ENABLE - -size_t -mwrap_quiet(int on_off) -CODE: - RETVAL = on_off ? locating++ : locating--; -OUTPUT: - RETVAL - -size_t -mwrap_current_age() -CODE: - RETVAL = uatomic_read(&total_bytes_inc); -OUTPUT: - RETVAL - -size_t -mwrap_total_bytes_allocated() -CODE: - RETVAL = uatomic_read(&total_bytes_inc); -OUTPUT: - RETVAL - -size_t -mwrap_total_bytes_freed() -CODE: - RETVAL = uatomic_read(&total_bytes_dec); -OUTPUT: - RETVAL - -void -mwrap_each(min, cb, arg = &PL_sv_undef) - size_t min; - SV *cb; - SV *arg; -PREINIT: - struct cds_lfht *t; - struct cds_lfht_iter iter; - struct src_loc *l; -CODE: - ++locating; - rcu_read_lock(); - t = CMM_LOAD_SHARED(totals); - if (t) { - bool err = false; - - cds_lfht_for_each_entry(t, &iter, l, hnode) { - size_t total = uatomic_read(&l->total); - - if (total > min) { - SV *loc; - dSP; - ENTER; - SAVETMPS; - - PUSHMARK(SP); - loc = sv_newmortal(); - sv_setref_pv(loc, "Devel::Mwrap::SrcLoc", l); - XPUSHs(arg); - XPUSHs(loc); - PUTBACK; - - call_sv(cb, G_DISCARD|G_EVAL); - - SPAGAIN; - if (SvTRUE(ERRSV)) - err = true; - - FREETMPS; - LEAVE; - } - if (err) - break; - mwrap_assert(rcu_read_ongoing()); - } - } - if (SvTRUE(ERRSV)) - croak(NULL); -CLEANUP: - rcu_read_unlock(); - --locating; - - -void -mwrap_reset() -CODE: - mwrap_reset(); - -unsigned -mwrap_bt_depth(arg = &PL_sv_undef) - SV *arg; -CODE: - if (SvOK(arg)) { - UV n = SvUVx(arg); - if (n > MWRAP_BT_MAX) - n = MWRAP_BT_MAX; - CMM_STORE_SHARED(bt_req_depth, (uint32_t)n); - RETVAL = n; - } else { - RETVAL = CMM_LOAD_SHARED(bt_req_depth); - } -OUTPUT: - RETVAL - -Devel::Mwrap::SrcLoc -mwrap_get(loc) - SV *loc; -PREINIT: - STRLEN len; - const char *str; - struct src_loc *l; -CODE: - ++locating; - if (!SvPOK(loc)) - XSRETURN_UNDEF; - str = SvPV(loc, len); - l = mwrap_get(str, len); - if (!l) - XSRETURN_UNDEF; - RETVAL = l; -OUTPUT: - RETVAL -CLEANUP: - --locating; - -MODULE = Devel::Mwrap PACKAGE = Devel::Mwrap::SrcLoc PREFIX = src_loc_ - -PROTOTYPES: ENABLE - -size_t -src_loc_frees(self) - Devel::Mwrap::SrcLoc self -PREINIT: -CODE: - ++locating; - RETVAL = uatomic_read(&self->frees); -OUTPUT: - RETVAL -CLEANUP: - --locating; - -size_t -src_loc_freed_bytes(self) - Devel::Mwrap::SrcLoc self -PREINIT: -CODE: - ++locating; - RETVAL = uatomic_read(&self->freed_bytes); -OUTPUT: - RETVAL -CLEANUP: - --locating; - -size_t -src_loc_allocations(self) - Devel::Mwrap::SrcLoc self -PREINIT: -CODE: - ++locating; - RETVAL = uatomic_read(&self->allocations); -OUTPUT: - RETVAL -CLEANUP: - --locating; - -size_t -src_loc_total(self) - Devel::Mwrap::SrcLoc self -PREINIT: -CODE: - ++locating; - RETVAL = uatomic_read(&self->total); -OUTPUT: - RETVAL -CLEANUP: - --locating; - -double -src_loc_mean_lifespan(self) - Devel::Mwrap::SrcLoc self -PREINIT: - size_t tot, frees; -CODE: - ++locating; - frees = uatomic_read(&self->frees); - tot = uatomic_read(&self->age_total); - RETVAL = frees ? ((double)tot/(double)frees) : HUGE_VAL; -OUTPUT: - RETVAL -CLEANUP: - --locating; - -double -src_loc_max_lifespan(self) - Devel::Mwrap::SrcLoc self -CODE: - ++locating; - RETVAL = uatomic_read(&self->max_lifespan); -OUTPUT: - RETVAL -CLEANUP: - --locating; - -SV * -src_loc_name(self) - Devel::Mwrap::SrcLoc self -CODE: - ++locating; - RETVAL = location_string(self); -OUTPUT: - RETVAL -CLEANUP: - --locating; - -void -src_loc_each(self, min, cb, arg = &PL_sv_undef) - Devel::Mwrap::SrcLoc self; - size_t min; - SV *cb; - SV *arg; -PREINIT: - struct alloc_hdr *h; - bool err = false; -CODE: - ++locating; - rcu_read_lock(); - cds_list_for_each_entry_rcu(h, &self->allocs, anode) { - size_t size = uatomic_read(&h->size); - if (size > min) { - dSP; - ENTER; - SAVETMPS; - - PUSHMARK(SP); - - /* - * note: we MUST NOT expose alloc_hdr to Perl code - * since that opens us up to use-after-free - */ - XPUSHs(arg); - XPUSHs(sv_2mortal(newSVuv(size))); - XPUSHs(sv_2mortal(newSVuv(h->as.live.gen))); - XPUSHs(sv_2mortal(newSVuv((uintptr_t)h->real))); - PUTBACK; - - call_sv(cb, G_DISCARD|G_EVAL); - - SPAGAIN; - if (SvTRUE(ERRSV)) - err = true; - - FREETMPS; - LEAVE; - if (err) - break; - mwrap_assert(rcu_read_ongoing()); - } - } - if (SvTRUE(ERRSV)) - croak(NULL); -CLEANUP: - rcu_read_unlock(); - --locating; @@ -1,92 +1,97 @@ -Devel::Mwrap - LD_PRELOAD malloc wrapper + malloc line stats for Perl += mwrap - LD_PRELOAD malloc wrapper + line stats for Ruby -Devel::Mwrap is designed to answer the question: +mwrap is designed to answer the question: - Which lines of Perl are hitting malloc the most? + Which lines of Ruby are hitting malloc the most? -Devel::Mwrap wraps all malloc-family calls to trace the Perl source -location of such calls and bytes allocated at each callsite. It -can also function as a leak detector and show live allocations -at every call site. Depending on your application and workload, -the overhead is roughly a 50%-100% increase memory and runtime. +mwrap wraps all malloc-family calls to trace the Ruby source +location of such calls and bytes allocated at each callsite. +As of mwrap 2.0.0, it can also function as a leak detector +and show live allocations at every call site. Depending on +your application and workload, the overhead is roughly a 50% +increase memory and runtime. -It is thread-safe and requires the concurrent lock-free hash table -from the Userspace RCU project: https://liburcu.org/ +It works best for allocations under GVL, but tries to track +numeric caller addresses for allocations made without GVL so you +can get an idea of how much memory usage certain extensions and +native libraries use. -It relies on dynamic linking to a malloc(3) implementation. If -you got Perl from your OS distribution, this typically does not -require rebuilding Perl. +It requires the concurrent lock-free hash table from the +Userspace RCU project: https://liburcu.org/ -Tested on the `perl' package distributed with: +It does not require recompiling or rebuilding Ruby, but only +supports Ruby 2.7.0 or later on a few platforms: -* Debian GNU/Linux 10 and 11 - -* FreeBSD 12.x +* GNU/Linux +* FreeBSD It may work on NetBSD, OpenBSD and DragonFly BSD. == Install -See `INSTALL' document + # FreeBSD: pkg install liburcu + + # Debian-based systems: apt-get liburcu-dev + + # Install mwrap via RubyGems.org + gem install mwrap == Usage -Devel::Mwrap works as an LD_PRELOAD and supplies a mwrap-perl script to +mwrap works as an LD_PRELOAD and supplies a mwrap RubyGem executable to improve ease-of-use. You can set dump_path: in the MWRAP environment variable to append the results to a log file: - MWRAP=dump_path:/path/to/log mwrap-perl PERL_COMMAND + MWRAP=dump_path:/path/to/log mwrap RUBY_COMMAND # And to display the locations with the most allocations: sort -k1,1rn </path/to/log | $PAGER -You may also `use Devel::Mwrap' in your Perl code and use -Devel::Mwrap->dump, Devel::Mwrap->reset, Devel::Mwrap->each, etc. +You may also `require "mwrap"' in your Ruby code and use +Mwrap.dump, Mwrap.reset, Mwrap.each, etc. -However, Devel::Mwrap MUST be loaded via LD_PRELOAD to have any +However, mwrap MUST be loaded via LD_PRELOAD to have any effect in tracking malloc use. However, it is safe to keep -"use Devel::Mwrap" in performance-critical deployments, +"require 'mwrap'" in performance-critical deployments, as overhead is only incurred when used as an LD_PRELOAD. -The output of the Devel::Mwrap->dump is a text file with 3 columns: +The output of the mwrap dump is a text file with 3 columns: total_bytes call_count location -Where location is a Perl source location or an address retrieved -by backtrace_symbols(3). It is recommended to use the sort(1) -command on either of the first two columns to find the hottest -malloc locations. +Where location is a Ruby source location (if made under GVL) +or an address retrieved by backtrace_symbols(3). It is +recommended to use the sort(1) command on either of the +first two columns to find the hottest malloc locations. -== Known problems +mwrap 2.0.0+ also supports a Rack application endpoint, +it is documented at: -* 32-bit machines are prone to overflow (WONTFIX) +https://80x24.org/mwrap/MwrapRack.html -* signalfd(2)-reliant code will need latest URCU with commit - ea3a28a3f71dd02f (Disable signals in URCU background threads, 2022-09-23) +== Known problems -* Perl source files over 16.7 million lines long are not supported :P +* 32-bit machines are prone to overflow (WONTFIX) -== Public mail archives (HTTP, Atom feeds, IMAP mailbox, NNTP group): +== Public mail archives and contact info: - https://80x24.org/mwrap-perl/ - imaps://80x24.org/inbox.comp.lang.perl.mwrap.0 - nntps://80x24.org/inbox.comp.lang.perl.mwrap +* https://80x24.org/mwrap-public/ +* nntps://80x24.org/inbox.comp.lang.ruby.mwrap +* imaps://;AUTH=ANONYMOUS@80x24.org/inbox.comp.lang.ruby.mwrap.0 +* https://80x24.org/mwrap-public/_/text/help/#pop3 -No subscription nor real identities will ever be required to -obtain support. Memory usage reductions start with you; only send -plain-text mail to us and do not top-post. HTML mail and top-posting -costs everybody memory and bandwidth. +No subscription will ever be required to post, but HTML mail +will be rejected: - mwrap-perl@80x24.org + mwrap-public@80x24.org == Hacking - git clone https://80x24.org/mwrap-perl.git + git clone https://80x24.org/mwrap.git -Send all patches ("git format-patch" + "git send-email") and -pull requests (use "git request-pull" to format) via email -to mwrap-perl@80x24.org. We do not and will not use -proprietary messaging systems. +Send all patches and pull requests (use "git request-pull" to format) to +mwrap-public@80x24.org. We do not use centralized or proprietary messaging +systems. == License diff --git a/Rakefile b/Rakefile new file mode 100644 index 0000000..cf4311e --- /dev/null +++ b/Rakefile @@ -0,0 +1,52 @@ +# Copyright (C) mwrap hackers <mwrap-public@80x24.org> +# License: GPL-2.0+ <https://www.gnu.org/licenses/gpl-2.0.txt> +require 'rake/testtask' +begin + require 'rake/extensiontask' + Rake::ExtensionTask.new('mwrap') +rescue LoadError + warn 'rake-compiler not available, cross compiling disabled' +end + +Rake::TestTask.new(:test) +task 'test-ruby' => :compile +task :default => :compile + +task 'test-httpd': 'lib/mwrap.so' do + require 'rbconfig' + ENV['RUBY'] = RbConfig.ruby + sh "#{ENV['PROVE'] || 'prove'} -v" +end + +task test: %w(test-ruby test-httpd) + +c_files = File.readlines('MANIFEST').grep(%r{ext/.*\.[ch]$}).map!(&:chomp!) +task 'compile:mwrap' => c_files + +olddoc = ENV['OLDDOC'] || 'olddoc' +rdoc = ENV['RDOC'] || 'rdoc' +task :rsync_docs do + require 'fileutils' + top = %w(README COPYING LATEST NEWS NEWS.atom.xml) + system("git", "set-file-times") + dest = ENV["RSYNC_DEST"] || "80x24.org:/srv/80x24/mwrap/" + FileUtils.rm_rf('doc') + sh "#{olddoc} prepare" + sh "#{rdoc} -f dark216" # dark216 requires olddoc 1.7+ + File.unlink('doc/created.rid') rescue nil + File.unlink('doc/index.html') rescue nil + FileUtils.cp(top, 'doc') + sh "#{olddoc} merge" + + Dir['doc/**/*'].each do |txt| + st = File.stat(txt) + if st.file? + gz = "#{txt}.gz" + tmp = "#{gz}.#$$" + sh("gzip --rsyncable -9 <#{txt} >#{tmp}") + File.utime(st.atime, st.mtime, tmp) # make nginx gzip_static happy + File.rename(tmp, gz) + end + end + sh("rsync --chmod=Fugo=r #{ENV['RSYNC_OPT']} -av doc/ #{dest}/") +end diff --git a/VERSION-GEN b/VERSION-GEN new file mode 100755 index 0000000..ae66e94 --- /dev/null +++ b/VERSION-GEN @@ -0,0 +1,36 @@ +#!/bin/sh +VF=lib/mwrap/version.rb +DEF_VER=v2.3.0 +VN=$(git describe HEAD 2>/dev/null) +if test $? -eq 0 +then + case "$VN" in + v[0-9]*) + set -e + git update-index -q --refresh + set +e + git diff-index --quiet HEAD -- || VN="$VN-dirty" + set -e + VN=$(echo $VN | tr '-' '.') + ;; + esac +fi +set -e + +case $VN in +'') VN="$DEF_VER" ;; +esac + +VN=$(expr "$VN" : v*'\(.*\)') +VC=unset +if test -r $VF +then + VC="$(cat $VF)" +fi + +new="module Mwrap; VERSION = '$VN'.freeze; end" +if test x"$new" != x"$VC" +then + echo "$new" >$VF +fi +echo $VN diff --git a/bin/mwrap b/bin/mwrap new file mode 100755 index 0000000..054b3a3 --- /dev/null +++ b/bin/mwrap @@ -0,0 +1,55 @@ +#!/usr/bin/ruby +# frozen_string_literal: true +# Copyright (C) mwrap hackers <mwrap-public@80x24.org> +# License: GPL-2.0+ <https://www.gnu.org/licenses/gpl-2.0.txt> +help = <<EOM +usage: mwrap COMMAND [ARGS] +see https://80x24.org/mwrap/README.html for more info +EOM +ARGV.empty? and abort help +ARGV.each do |x| + case x + when '--version', '-v' + require 'mwrap/version' + puts "mwrap #{Mwrap::VERSION} - #{RUBY_DESCRIPTION}" + exit 0 + when '--help', '-h' + puts help + exit 0 + else # don't intercept --version/--help intended for commands we wrap + break + end +end + +require 'mwrap' +mwrap_so = $".grep(%r{/mwrap\.so\z})[0] or abort "mwrap.so not loaded" +cur = ENV['LD_PRELOAD'] +if cur + cur = cur.split(/[:\s]+/) + if !cur.include?(mwrap_so) + # drop old versions + cur.delete_if { |path| path.end_with?('/mwrap.so') } + cur.unshift(mwrap_so) + ENV['LD_PRELOAD'] = cur.join(':') + end +else + ENV['LD_PRELOAD'] = mwrap_so +end + +# work around close-on-exec by default behavior in Ruby: +opts = {} +if ENV['MWRAP'] =~ /dump_fd:(\d+)/ + dump_fd = $1.to_i + if dump_fd > 2 + dump_io = IO.new(dump_fd) + opts[dump_fd] = dump_io + end +end + +# allow inheriting FDs from systemd +n = ENV['LISTEN_FDS'] +if n && ENV['LISTEN_PID'].to_i == $$ + n = 3 + n.to_i + (3...n).each { |fd| opts[fd] = IO.new(fd) } +end +exec *ARGV, opts diff --git a/examples/mwrap.psgi b/examples/mwrap.psgi deleted file mode 100644 index b4fcafb..0000000 --- a/examples/mwrap.psgi +++ /dev/null @@ -1,14 +0,0 @@ -# Copyright (C) all contributors <mwrap-perl@80x24.org> -# License: GPL-3.0+ <https://www.gnu.org/licenses/gpl-3.0.txt> -# A startup command for development: -# plackup -I ./blib/lib -I ./blib/arch -o 127.0.0.1 examples/mwrap.psgi -use v5.12; -use Devel::Mwrap::PSGI; -use Plack::Builder; -my $mw = Devel::Mwrap::PSGI->new; -delete $ENV{LD_PRELOAD}; # don't impose in subprocesses - -builder { - enable 'Head'; - sub { $mw->call($_[0]) }; -} @@ -1,8 +0,0 @@ -#!/bin/sh -e -# symlink this file to a directory in PATH to run anything in script/* -# without needing perms to install globally. Used by "make symlink-install" -p=$(realpath "$0" || readlink "$0") # neither is POSIX, but common -p=$(dirname "$p") c=$(basename "$0") # both are POSIX -exec ${PERL-perl} -w -I"$p"/blib/lib -I"$p"/blib/arch \ - "$p"/script/"${c%.sh}" "$@" -: this script is too short to copyright diff --git a/check.h b/ext/mwrap/check.h index f4f4ac5..f4f4ac5 100644 --- a/check.h +++ b/ext/mwrap/check.h diff --git a/dlmalloc_c.h b/ext/mwrap/dlmalloc_c.h index 38a0846..38a0846 100644 --- a/dlmalloc_c.h +++ b/ext/mwrap/dlmalloc_c.h diff --git a/ext/mwrap/extconf.rb b/ext/mwrap/extconf.rb new file mode 100644 index 0000000..3336548 --- /dev/null +++ b/ext/mwrap/extconf.rb @@ -0,0 +1,31 @@ +# frozen_string_literal: true +# Copyright (C) mwrap hackers <mwrap-public@80x24.org> +# License: GPL-2.0+ <https://www.gnu.org/licenses/gpl-2.0.txt> +require 'mkmf' + +have_func 'mempcpy' +have_library 'urcu-cds' or abort 'userspace RCU not installed' +have_header 'urcu/rculfhash.h' or abort 'rculfhash.h not found' +have_library 'urcu-bp' or abort 'liburcu-bp not found' +have_library 'dl' +have_library 'c' +have_library 'execinfo' # FreeBSD +$defs << '-DHAVE_XXHASH' if have_header('xxhash.h') + +have_struct_member('struct sockaddr_un', 'sun_len', %w(sys/socket sys/un.h)) + +if try_link(<<EOC) +int main(void) { return __builtin_add_overflow_p(0,0,(int)1); } +EOC + $defs << '-DHAVE_BUILTIN_ADD_OVERFLOW_P' +end + +if try_link(<<EOC) +int main(int a) { return __builtin_add_overflow(0,0,&a); } +EOC + $defs << '-DHAVE_BUILTIN_ADD_OVERFLOW_P' +else + abort 'missing __builtin_add_overflow' +end + +create_makefile 'mwrap' diff --git a/httpd.h b/ext/mwrap/httpd.h index 36e487d..03aef9f 100644 --- a/httpd.h +++ b/ext/mwrap/httpd.h @@ -1145,7 +1145,7 @@ static void h1d_unlink(struct mw_h1d *h1d, bool do_close) static int h1d_init(struct mw_h1d *h1d, const char *menv) { union mw_sockaddr sa = { .un = { .sun_family = AF_UNIX } }; -#ifdef HAS_SOCKADDR_SA_LEN +#if defined(HAS_SOCKADDR_SA_LEN) || defined(HAVE_STRUCT_SOCKADDR_UN_SUN_LEN) sa.un.sun_len = (unsigned char)sizeof(struct sockaddr_un); #endif const char *env = strstr(menv, "socket_dir:"); diff --git a/jhash.h b/ext/mwrap/jhash.h index 69666f3..69666f3 100644 --- a/jhash.h +++ b/ext/mwrap/jhash.h diff --git a/ext/mwrap/mwrap.c b/ext/mwrap/mwrap.c new file mode 100644 index 0000000..d88fee6 --- /dev/null +++ b/ext/mwrap/mwrap.c @@ -0,0 +1,396 @@ +/* + * Copyright (C) mwrap hackers <mwrap-public@80x24.org> + * License: GPL-2.0+ <https://www.gnu.org/licenses/gpl-2.0.txt> + */ +#define MWRAP_RUBY 1 +#include "mwrap_core.h" + +static ID id_uminus; +extern VALUE __attribute__((weak)) rb_cObject; +extern VALUE __attribute__((weak)) rb_eTypeError; +extern VALUE __attribute__((weak)) rb_yield(VALUE); + +/* + * call-seq: + * + * Mwrap.dump([[io] [, min]] -> nil + * + * Dumps the current totals to +io+ which must be an IO object + * (StringIO and similar are not supported). Total sizes smaller + * than or equal to +min+ are skipped. + * + * The output is space-delimited by 3 columns: + * + * total_size call_count location + */ +static VALUE mwrap_dump(int argc, VALUE *argv, VALUE mod) +{ + VALUE io, min; + struct dump_arg a; + rb_io_t *fptr; + + rb_scan_args(argc, argv, "02", &io, &min); + + if (NIL_P(io)) + /* library may be linked w/o Ruby */ + io = *((VALUE *)dlsym(RTLD_DEFAULT, "rb_stderr")); + + a.min = NIL_P(min) ? 0 : NUM2SIZET(min); + io = rb_io_get_io(io); + io = rb_io_get_write_io(io); + GetOpenFile(io, fptr); + a.fp = rb_io_stdio_file(fptr); + + rb_thread_call_without_gvl((void *(*)(void *))dump_to_file, &a, 0, 0); + RB_GC_GUARD(io); + return Qnil; +} + +/* The whole operation is not remotely atomic... */ +static void *totals_reset(void *ign) +{ + mwrap_reset(); + return NULL; +} + +/* + * call-seq: + * + * Mwrap.reset -> nil + * + * Resets the the total tables by zero-ing all counters. + * This resets all statistics. This is not an atomic operation + * as other threads (outside of GVL) may increment counters. + */ +static VALUE reset_m(VALUE mod) +{ + rb_thread_call_without_gvl(totals_reset, 0, 0, 0); + return Qnil; +} + +static VALUE rcu_unlock_ensure(VALUE ignored) +{ + rcu_read_unlock(); + --locating; + return Qfalse; +} + +static VALUE location_string(const struct src_loc *l) +{ + VALUE tmp = rb_str_new(NULL, 0); + + if (l->f) { + rb_str_cat(tmp, l->f->fn, l->f->fn_len); + if (l->lineno == U24_MAX) + rb_str_cat_cstr(tmp, ":-"); + else + rb_str_catf(tmp, ":%u", l->lineno); + } + if (l->bt_len) { + AUTO_FREE char **s = bt_syms(l->bt, l->bt_len); + + if (s) { + if (l->f) + rb_str_cat_cstr(tmp, "\n"); + rb_str_cat_cstr(tmp, s[0]); + for (uint32_t i = 1; i < l->bt_len; ++i) + rb_str_catf(tmp, "\n%s", s[i]); + } + } + + /* deduplicate and try to free up some memory */ + VALUE ret = rb_funcall(tmp, id_uminus, 0); + if (!OBJ_FROZEN_RAW(tmp)) + rb_str_resize(tmp, 0); + + return ret; +} + +static VALUE dump_each_rcu(VALUE x) +{ + struct dump_arg *a = (struct dump_arg *)x; + struct cds_lfht *t; + struct cds_lfht_iter iter; + struct src_loc *l; + + t = CMM_LOAD_SHARED(totals); + cds_lfht_for_each_entry(t, &iter, l, hnode) { + VALUE v[6]; + if (l->total <= a->min) continue; + + v[0] = location_string(l); + v[1] = SIZET2NUM(l->total); + v[2] = SIZET2NUM(l->allocations); + v[3] = SIZET2NUM(l->frees); + v[4] = SIZET2NUM(l->age_total); + v[5] = SIZET2NUM(l->max_lifespan); + + rb_yield_values2(6, v); + assert(rcu_read_ongoing()); + } + return Qnil; +} + +/* + * call-seq: + * + * Mwrap.each([min]) do |location,total,allocations,frees,age_total,max_lifespan| + * ... + * end + * + * Yields each entry of the of the table to a caller-supplied block. + * +min+ may be specified to filter out lines with +total+ bytes + * equal-to-or-smaller-than the supplied minimum. + */ +static VALUE mwrap_each(int argc, VALUE * argv, VALUE mod) +{ + VALUE min; + struct dump_arg a; + + rb_scan_args(argc, argv, "01", &min); + a.min = NIL_P(min) ? 0 : NUM2SIZET(min); + + ++locating; + rcu_read_lock(); + + return rb_ensure(dump_each_rcu, (VALUE)&a, rcu_unlock_ensure, 0); +} + +static size_t +src_loc_memsize(const void *p) +{ + return sizeof(struct src_loc); +} + +static const rb_data_type_t src_loc_type = { + "source_location", + /* no marking, no freeing */ + { 0, 0, src_loc_memsize, /* reserved */ }, + /* parent, data, [ flags ] */ +}; + +static VALUE cSrcLoc; + +/* + * call-seq: + * Mwrap[location] -> Mwrap::SourceLocation + * + * Returns the associated Mwrap::SourceLocation given the +location+ + * String. +location+ is either a Ruby source location path:line + * (e.g. "/path/to/foo.rb:5") or a hexadecimal memory address with + * square-braces part yielded by Mwrap.dump (e.g. "[0xdeadbeef]") + */ +static VALUE mwrap_aref(VALUE mod, VALUE loc) +{ + const char *str = StringValueCStr(loc); + long len = RSTRING_LEN(loc); + assert(len >= 0); + struct src_loc *l = mwrap_get(str, (size_t)len); + + return l ? TypedData_Wrap_Struct(cSrcLoc, &src_loc_type, l) : Qnil; +} + +static VALUE src_loc_each_i(VALUE p) +{ + struct alloc_hdr *h; + struct src_loc *l = (struct src_loc *)p; + + cds_list_for_each_entry_rcu(h, &l->allocs, anode) { + size_t gen = uatomic_read(&h->as.live.gen); + size_t size = uatomic_read(&h->size); + + if (size) { + VALUE v[2]; + v[0] = SIZET2NUM(size); + v[1] = SIZET2NUM(gen); + + rb_yield_values2(2, v); + } + } + + return Qfalse; +} + +static struct src_loc *src_loc_of(VALUE self) +{ + struct src_loc *l; + TypedData_Get_Struct(self, struct src_loc, &src_loc_type, l); + assert(l); + return l; +} + +/* + * call-seq: + * loc = Mwrap[location] + * loc.each { |size,generation| ... } + * + * Iterates through live allocations for a given Mwrap::SourceLocation, + * yielding the +size+ (in bytes) and +generation+ of each allocation. + * The +generation+ is the value of the GC.count method at the time + * the allocation was made. + * + * This functionality is only available in mwrap 2.0.0+ + */ +static VALUE src_loc_each(VALUE self) +{ + struct src_loc *l = src_loc_of(self); + + assert(locating == 0 && "forgot to clear locating"); + ++locating; + rcu_read_lock(); + rb_ensure(src_loc_each_i, (VALUE)l, rcu_unlock_ensure, 0); + return self; +} + +/* + * The the mean lifespan (in GC generations) of allocations made from this + * location. This does not account for live allocations. + */ +static VALUE src_loc_mean_lifespan(VALUE self) +{ + struct src_loc *l = src_loc_of(self); + size_t tot, frees; + + frees = uatomic_read(&l->frees); + tot = uatomic_read(&l->age_total); + return DBL2NUM(frees ? ((double)tot/(double)frees) : HUGE_VAL); +} + +/* The number of frees made from this location */ +static VALUE src_loc_frees(VALUE self) +{ + return SIZET2NUM(uatomic_read(&src_loc_of(self)->frees)); +} + +/* The number of allocations made from this location */ +static VALUE src_loc_allocations(VALUE self) +{ + return SIZET2NUM(uatomic_read(&src_loc_of(self)->allocations)); +} + +/* The total number of bytes allocated from this location */ +static VALUE src_loc_total(VALUE self) +{ + return SIZET2NUM(uatomic_read(&src_loc_of(self)->total)); +} + +/* + * The maximum age (in GC generations) of an allocation before it was freed. + * This does not account for live allocations. + */ +static VALUE src_loc_max_lifespan(VALUE self) +{ + return SIZET2NUM(uatomic_read(&src_loc_of(self)->max_lifespan)); +} + +/* + * Returns a frozen String location of the given SourceLocation object. + */ +static VALUE src_loc_name(VALUE self) +{ + struct src_loc *l = src_loc_of(self); + VALUE ret; + + ++locating; + ret = location_string(l); + --locating; + return ret; +} + +static VALUE reset_locating(VALUE ign) { --locating; return Qfalse; } + +/* + * call-seq: + * + * Mwrap.quiet do |depth| + * # expensive sort/calculate/emitting results of Mwrap.each + * # affecting statistics of the rest of the app + * end + * + * Stops allocation tracking inside the block. This is useful for + * monitoring code which calls other Mwrap (or ObjectSpace/GC) + * functions which unavoidably allocate memory. + * + * This feature was added in mwrap 2.0.0+ + */ +static VALUE mwrap_quiet(VALUE mod) +{ + size_t cur = ++locating; + return rb_ensure(rb_yield, SIZET2NUM(cur), reset_locating, 0); +} + +/* + * total bytes allocated as tracked by mwrap + */ +static VALUE total_inc(VALUE mod) +{ + return SIZET2NUM(total_bytes_inc); +} + +/* + * total bytes freed as tracked by mwrap + */ +static VALUE total_dec(VALUE mod) +{ + return SIZET2NUM(total_bytes_dec); +} + +/* + * Document-module: Mwrap + * + * require 'mwrap' + * + * Mwrap has a dual function as both a Ruby C extension and LD_PRELOAD + * wrapper. As a Ruby C extension, it exposes a limited Ruby API. + * To be effective at gathering status, mwrap must be loaded as a + * LD_PRELOAD (using the mwrap(1) executable makes it easy) + * + * ENVIRONMENT + * + * The "MWRAP" environment variable contains a comma-delimited list + * of key:value options for automatically dumping at program exit. + * + * * dump_fd: a writable FD to dump to + * * dump_path: a path to dump to, the file is opened in O_APPEND mode + * * dump_min: the minimum allocation size (total) to dump + * + * If both `dump_fd' and `dump_path' are specified, dump_path takes + * precedence. + */ +void Init_mwrap(void) +{ + VALUE mod; + + ++locating; + mod = rb_define_module("Mwrap"); + id_uminus = rb_intern("-@"); + + /* + * Represents a location in source code or library + * address which calls a memory allocation. It is + * updated automatically as allocations are made, so + * there is no need to reload or reread it from Mwrap#[]. + * This class is only available since mwrap 2.0.0+. + */ + cSrcLoc = rb_define_class_under(mod, "SourceLocation", rb_cObject); + rb_undef_alloc_func(cSrcLoc); + rb_define_singleton_method(mod, "dump", mwrap_dump, -1); + rb_define_singleton_method(mod, "reset", reset_m, 0); + rb_define_singleton_method(mod, "clear", reset_m, 0); + rb_define_singleton_method(mod, "each", mwrap_each, -1); + rb_define_singleton_method(mod, "[]", mwrap_aref, 1); + rb_define_singleton_method(mod, "quiet", mwrap_quiet, 0); + rb_define_singleton_method(mod, "total_bytes_allocated", total_inc, 0); + rb_define_singleton_method(mod, "total_bytes_freed", total_dec, 0); + + + rb_define_method(cSrcLoc, "each", src_loc_each, 0); + rb_define_method(cSrcLoc, "frees", src_loc_frees, 0); + rb_define_method(cSrcLoc, "allocations", src_loc_allocations, 0); + rb_define_method(cSrcLoc, "total", src_loc_total, 0); + rb_define_method(cSrcLoc, "mean_lifespan", src_loc_mean_lifespan, 0); + rb_define_method(cSrcLoc, "max_lifespan", src_loc_max_lifespan, 0); + rb_define_method(cSrcLoc, "name", src_loc_name, 0); + + --locating; +} diff --git a/mwrap_core.h b/ext/mwrap/mwrap_core.h index 02b60f3..c0eea2f 100644 --- a/mwrap_core.h +++ b/ext/mwrap/mwrap_core.h @@ -4,13 +4,14 @@ * Disclaimer: I don't really know my way around XS or Perl internals well */ #define _LGPL_SOURCE /* allows URCU to inline some stuff */ +#define _GNU_SOURCE #include "mymalloc.h" /* includes dlmalloc_c.h */ #ifndef MWRAP_PERL # define MWRAP_PERL 0 #endif -#if !MWRAP_PERL -typedef void COP; +#ifndef MWRAP_RUBY +# define MWRAP_RUBY 0 #endif /* set a sensible max to avoid stack overflows */ @@ -18,15 +19,9 @@ typedef void COP; # define MWRAP_BT_MAX 32 #endif - -#if MWRAP_PERL -# include "EXTERN.h" -# include "perl.h" -# include "XSUB.h" -# include "embed.h" -# include "ppport.h" +#ifndef _GNU_SOURCE +# define _GNU_SOURCE #endif - #include <execinfo.h> #include <stdio.h> #include <stdlib.h> @@ -44,6 +39,21 @@ typedef void COP; #include <urcu/rculist.h> #include <limits.h> +#if MWRAP_PERL +# include "EXTERN.h" +# include "perl.h" +# include "XSUB.h" +# include "embed.h" +# include "ppport.h" +#endif + +#if MWRAP_RUBY +# undef _GNU_SOURCE /* ruby.h redefines it */ +# include <ruby.h> /* defines HAVE_RUBY_RACTOR_H on 3.0+ */ +# include <ruby/thread.h> +# include <ruby/io.h> +#endif + /* * XXH3 (truncated to 32-bits) seems to provide a ~2% speedup. * XXH32 doesn't show improvements over jhash despite rculfhash @@ -75,12 +85,56 @@ static uint32_t bt_req_depth; #if MWRAP_PERL extern pthread_key_t __attribute__((weak)) PL_thr_key; extern const char __attribute__((weak)) PL_memory_wrap[]; /* needed for -O0 */ -#endif +# if !defined(PERL_IMPLICIT_CONTEXT) +static size_t *root_locating; /* determines if PL_curcop is our thread */ +# endif +#endif /* MWRAP_PERL */ + +#if MWRAP_RUBY +const char *rb_source_location_cstr(int *line); /* requires 2.6.0dev or later */ + +# ifdef HAVE_RUBY_RACTOR_H /* Ruby 3.0+ */ +extern MWRAP_TSD void * __attribute__((weak)) ruby_current_ec; +# else /* Ruby 2.6-2.7 */ +extern void * __attribute__((weak)) ruby_current_execution_context_ptr; +# define ruby_current_ec ruby_current_execution_context_ptr +# endif /* HAVE_RUBY_RACTOR_H */ + +extern void * __attribute__((weak)) ruby_current_vm_ptr; /* for rb_gc_count */ +extern size_t __attribute__((weak)) rb_gc_count(void); +int __attribute__((weak)) ruby_thread_has_gvl_p(void); + +/* + * rb_source_location_cstr relies on GET_EC(), and it's possible + * to have a native thread but no EC during the early and late + * (teardown) phases of the Ruby process + */ +static int has_ec_p(void) +{ + return ruby_thread_has_gvl_p && ruby_thread_has_gvl_p() && + ruby_current_vm_ptr && ruby_current_ec; +} +static void set_generation(size_t *gen, size_t size) +{ + if (rb_gc_count) { + uatomic_add_return(&total_bytes_inc, size); + if (has_ec_p()) + *gen = rb_gc_count(); + } else { + *gen = uatomic_add_return(&total_bytes_inc, size); + } +} +# define SET_GENERATION(gen, size) set_generation(gen, size) +#endif /* MWRAP_RUBY */ + +#ifndef SET_GENERATION +# define SET_GENERATION(gen, size) \ + *gen = uatomic_add_return(&total_bytes_inc, size) +#endif /* !SET_GENERATION */ + +/* generic stuff: */ static MWRAP_TSD size_t locating; -#if MWRAP_PERL && !defined(PERL_IMPLICIT_CONTEXT) -static size_t *root_locating; /* determines if PL_curcop is our thread */ -#endif static struct cds_lfht *files, *totals; union padded_mutex { pthread_mutex_t mtx; @@ -142,6 +196,7 @@ static void *my_mempcpy(void *dest, const void *src, size_t n) /* * only for interpreted sources (Perl/Ruby/etc), not backtrace_symbols* files + * Allocated via real_malloc / real_free */ struct src_file { struct cds_lfht_node nd; /* <=> files table */ @@ -179,7 +234,7 @@ struct alloc_hdr { struct cds_list_head anode; /* <=> src_loc.allocs */ union { struct { - size_t gen; /* global age */ + size_t gen; /* global age || rb_gc_count() */ struct src_loc *loc; } live; struct rcu_head dead; @@ -319,20 +374,6 @@ again: return l; } -static const COP *mwp_curcop(void) -{ -#if MWRAP_PERL - if (&PL_thr_key) { /* are we even in a Perl process? */ -# ifdef PERL_IMPLICIT_CONTEXT - if (aTHX) return PL_curcop; -# else /* !PERL_IMPLICIT_CONTEXT */ - if (&locating == root_locating) return PL_curcop; -# endif /* PERL_IMPLICIT_CONTEXT */ - } -#endif /* MWRAP_PERL */ - return NULL; -} - static uint32_t do_hash(const void *p, size_t len) { #if defined(XXH3_64bits) @@ -372,18 +413,50 @@ static struct src_file *src_file_get(struct cds_lfht *t, struct src_file *k, return cur ? caa_container_of(cur, struct src_file, nd) : NULL; } -#if !MWRAP_PERL -# define CopFILE(cop) NULL -# define CopLINE(cop) 0 -#endif -static struct src_loc *assign_line(size_t size, const COP *cop, - struct src_loc *sl) +#if MWRAP_PERL +static const COP *mwp_curcop(void) { - /* avoid vsnprintf or anything which could call malloc here: */ + if (&PL_thr_key) { /* are we even in a Perl process? */ +# ifdef PERL_IMPLICIT_CONTEXT + if (aTHX) return PL_curcop; +# else /* !PERL_IMPLICIT_CONTEXT */ + if (&locating == root_locating) return PL_curcop; +# endif /* PERL_IMPLICIT_CONTEXT */ + } + return NULL; +} + +static const char *mw_perl_src_file_cstr(unsigned *lineno) +{ + const COP *cop = mwp_curcop(); if (!cop) return NULL; const char *fn = CopFILE(cop); if (!fn) return NULL; - unsigned lineno = CopLINE(cop); + *lineno = CopLINE(cop); + return fn; +} +# define SRC_FILE_CSTR(lineno) mw_perl_src_file_cstr(lineno) +#endif /* MWRAP_PERL */ + +#if MWRAP_RUBY +static const char *mw_ruby_src_file_cstr(unsigned *lineno) +{ + if (!has_ec_p()) return NULL; + int line; + const char *fn = rb_source_location_cstr(&line); + *lineno = line < 0 ? UINT_MAX : (unsigned)line; + return fn; +} +# define SRC_FILE_CSTR(lineno) mw_ruby_src_file_cstr(lineno) +#endif /* MWRAP_RUBY */ + +#ifndef SRC_FILE_CSTR /* for C-only compilation */ +# define SRC_FILE_CSTR(lineno) (NULL) +#endif /* !SRC_FILE_CSTR */ + +static struct src_loc *assign_line(size_t size, struct src_loc *sl, + const char *fn, unsigned lineno) +{ struct src_file *f; union stk_sf sf; struct cds_lfht_node *cur; @@ -430,7 +503,7 @@ again: } static struct src_loc * -update_stats_rcu_lock(size_t *generation, size_t size, struct src_loc *sl) +update_stats_rcu_lock(size_t *gen, size_t size, struct src_loc *sl) { struct cds_lfht *t = CMM_LOAD_SHARED(totals); struct src_loc *ret = NULL; @@ -438,11 +511,15 @@ update_stats_rcu_lock(size_t *generation, size_t size, struct src_loc *sl) if (caa_unlikely(!t)) return 0; /* not initialized */ if (locating++) goto out; /* do not recurse into another *alloc */ - *generation = uatomic_add_return(&total_bytes_inc, size); - const COP *cop = mwp_curcop(); + SET_GENERATION(gen, size); + + unsigned lineno; + const char *fn = SRC_FILE_CSTR(&lineno); + rcu_read_lock(); - ret = assign_line(size, cop, sl); - if (!ret) { /* no associated Perl code, just C/C++ */ + if (fn) + ret = assign_line(size, sl, fn, lineno); + if (!ret) { /* no associated Perl|Ruby code, just C/C++ */ sl->total = size; sl->f = NULL; sl->lineno = 0; diff --git a/mymalloc.h b/ext/mwrap/mymalloc.h index 6b5a22d..196ccc0 100644 --- a/mymalloc.h +++ b/ext/mwrap/mymalloc.h @@ -100,6 +100,8 @@ static void *my_mmap(size_t size) #endif #include "dlmalloc_c.h" #undef ABORT /* conflicts with Perl */ +#undef NOINLINE /* conflicts with Ruby, defined by dlmalloc_c.h */ +#undef HAVE_MREMAP /* conflicts with Ruby 3.2 */ static MWRAP_TSD mstate ms_tsd; diff --git a/picohttpparser.h b/ext/mwrap/picohttpparser.h index 0927985..0927985 100644 --- a/picohttpparser.h +++ b/ext/mwrap/picohttpparser.h diff --git a/picohttpparser_c.h b/ext/mwrap/picohttpparser_c.h index c5e345d..c5e345d 100644 --- a/picohttpparser_c.h +++ b/ext/mwrap/picohttpparser_c.h diff --git a/lib/Devel/Mwrap.pm b/lib/Devel/Mwrap.pm deleted file mode 100644 index 2691802..0000000 --- a/lib/Devel/Mwrap.pm +++ /dev/null @@ -1,21 +0,0 @@ -# Copyright (C) all contributors <mwrap-perl@80x24.org> -# License: GPL-3.0+ <https://www.gnu.org/licenses/gpl-3.0.txt> -package Devel::Mwrap; -use v5.12; -our $VERSION = '0.0.0'; -use XSLoader; -XSLoader::load(__PACKAGE__, $VERSION); - -# allow using via the "-d:Mwrap" switch on the command-line: -package # hide the package from the PAUSE indexer - DB; - -sub DB {} # noop, just keeps "-d:Mwrap" happy - -1; -__END__ -=pod - -=head1 NAME - -Devel::Mwrap - LD_PRELOAD malloc wrapper + line stats for Perl diff --git a/lib/Devel/Mwrap/PSGI.pm b/lib/Devel/Mwrap/PSGI.pm deleted file mode 100644 index 3a3a29b..0000000 --- a/lib/Devel/Mwrap/PSGI.pm +++ /dev/null @@ -1,190 +0,0 @@ -# Copyright (C) all contributors <mwrap@80x24.org> -# License: GPL-3.0+ <https://www.gnu.org/licenses/gpl-3.0.txt> -# -# Note: this is deprecated, use httpd.h instead -package Devel::Mwrap::PSGI; -use v5.12; # strict -use warnings; -use Devel::Mwrap; -use Fcntl qw(SEEK_SET); - -sub new { - my ($class) = @_; - bless {}, $class; -} - -my %HTML_ESC = ( - '&' => '&', - '>' => '>', - '<' => '<', - '"' => '"', - "'" => ''' -); - -sub encode_html { - my ($str) = @_; - $str =~ s/[&><"']/$HTML_ESC{$1}/sge; - $str; -} - -my %URI_ESC; -for (0..255) { $URI_ESC{chr($_)} = sprintf('%%%02X', $_) } -sub uri_escape { - my ($str) = @_; - $str =~ s/([^A-Za-z0-9\-\._~])/$URI_ESC{$1}/sge; - $str; -} - -sub uri_unescape { - my ($str) = @_; - $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/sge; - $str; -} - -my @FIELDS = qw(bytes allocations frees live - mean_life max_life location); -my $HDR = '<tr><th>' . join('</th><th>', @FIELDS) . '</th></tr>'; - -sub accumulate_i { # callback for Devel::Mwrap::each - my ($all, $src_loc) = @_; - my $alloc = $src_loc->allocations; - my $frees = $src_loc->frees; - push @$all, [ $src_loc->total - $src_loc->freed_bytes, - $alloc, $frees, $alloc - $frees, - $src_loc->mean_lifespan, $src_loc->max_lifespan, - $src_loc->name ]; -} - -sub fh_response { - my ($fh) = @_; - $fh->flush or die "flush: $!"; - seek($fh, 0, SEEK_SET) or die "seek: $!"; - [ 200, [ - 'Expires' => 'Fri, 01 Jan 1980 00:00:00 GMT', - 'Pragma' => 'no-cache', - 'Cache-Control' => 'no-cache, max-age=0, must-revalidate', - 'Content-Type' => 'text/html; charset=UTF-8', - 'Content-Length' => -s $fh - ], $fh]; -} - -sub each_gt { - my ($env, $min) = @_; - my ($sort) = ($env->{QUERY_STRING} =~ /\bsort=(\w+)\b/a); - open my $fh, '+>', undef or die "open: $!"; - $sort //= 'bytes'; - my $sn = $env->{SCRIPT_NAME}; - my $t = "Devel::Mwrap::each($min)"; - my $all = []; - my @f = @FIELDS; - my $sc = 0; - for (my $i = 0; $i <= $#FIELDS; $i++) { - if ($FIELDS[$i] eq $sort) { - $sc = $i; - last; - } - } - $f[$sc] = "<b>$f[$sc]</b>"; - @f = (join('</th><th>', map {; - if (substr($_, 0, 1) eq '<') { - $_; - } else { - qq(<a\nhref="$sn/each/$min?sort=$_">$_</a>); - } - } @f)); - my @all; - Devel::Mwrap::each($min, \&accumulate_i, \@all); - if ($sc eq $#FIELDS) { # locations are sorted alphabetically - @all = sort { $a->[$sc] cmp $b->[$sc] } @all; - } else { # everything else is numeric - @all = sort { $b->[$sc] <=> $a->[$sc] } @all; - } - my $age = Devel::Mwrap::current_age(); - my $live = $age - Devel::Mwrap::total_bytes_freed(); - print $fh <<EOM; -<html><head><title>$t</title></head><body><p>$t -<p>Current age: $age (live: $live) -<table><tr><th>@f</th></tr> -EOM - while (my $cols = shift @all) { - # cols: [ bytes , allocations, frees, mean_lifespan, - # max_lifespan, name ] - my $loc_name = pop @$cols; - $cols->[4] = sprintf('%0.3f', $cols->[4]); # mean_life - my $href = "$sn/at/".uri_escape($loc_name); - print $fh '<tr><td>', join('</td><td>', @$cols), - qq(<td><a\nhref="), - encode_html($href), - qq(">), encode_html($loc_name), - "</a></td></tr>\n"; - } - print $fh "</table></body></html>\n"; - fh_response($fh); -} - -sub each_at_i { - my ($fh, $size, $gen, $addr) = @_; - print $fh "<tr><td>$size</td><td>$gen</td><td>"; - printf $fh "0x%lx</td></tr>\n", $addr; -} - -sub each_at { - my ($env, $src_loc) = @_; - my $t = encode_html($src_loc->name); - open my $fh, '+>', undef or die "open: $!"; - my $age = Devel::Mwrap::current_age(); - my $live = $age - Devel::Mwrap::total_bytes_freed(); - print $fh <<EOM; -<html><head><title>$t</title></head><body><p>live allocations at $t -<p>Current age: $age (live: $live)\n<table> -<tr><th>size</th><th>generation</th><th>address</th></tr> -EOM - $src_loc->each(0, \&each_at_i, $fh); - print $fh "</table></body></html>\n"; - fh_response($fh); -} - -sub r404 { - my $t404 = "Not Found\n"; - [ 404, [ qw(Content-Type text/plain - Content-Length), length($t404) ], [ $t404 ] ]; -} - -my $default_min = 2000; -my $url = 'https://80x24.org/mwrap-perl.git/about'; -chomp(my $root = <<EOM); -<html><head><title>Mwrap demo</title></head><body><p><a -href="each/$default_min">allocations >$default_min bytes</a><p><a -href="$url">$url</a></body></html> -EOM - -sub call { # PSGI entry point - Devel::Mwrap::quiet(1); - my (undef, $env) = @_; - my $ret; - my $path_info = $env->{PATH_INFO}; - if ($env->{REQUEST_METHOD} eq 'GET') { - if ($path_info =~ m!\A/each/([0-9]+)\z!) { - $ret = each_gt($env, $1 + 0); - } elsif ($path_info =~ m!\A/at/(.*)\z!) { - my $src_loc = Devel::Mwrap::get(uri_unescape($1)); - $ret = $src_loc ? each_at($env, $src_loc) : r404(); - } elsif ($path_info eq '/') { - $ret = [ 200, [ qw(Content-Type text/html - Content-Length), length($root) ], - [ $root ] ] - } - } elsif ($env->{REQUEST_METHOD} eq 'POST') { - if ($path_info eq '/reset') { - Devel::Mwrap::reset(); - $ret = [ 200, [ qw(Content-Type text/html - Content-Length 5) ], - [ "done\n" ] ]; - } - } - $ret //= r404(); - Devel::Mwrap::quiet(0); - $ret; -} - -1; diff --git a/lib/Devel/Mwrap/Rproxy.pm b/lib/Devel/Mwrap/Rproxy.pm deleted file mode 100644 index d5a9d9d..0000000 --- a/lib/Devel/Mwrap/Rproxy.pm +++ /dev/null @@ -1,220 +0,0 @@ -# Copyright (C) mwrap hackers <mwrap-perl@80x24.org> -# License: GPL-3.0+ <https://www.gnu.org/licenses/gpl-3.0.txt> - -# minimal reverse proxy to expose the embedded httpd.h UNIX sockets -# via PSGI (and thus TCP HTTP/1.x). This does not have a hard dependency -# on Mwrap.so. -# -# Warning: this has a synchronous wait dependency, so isn't suited for -# non-blocking async HTTP servers. -package Devel::Mwrap::Rproxy; -use v5.12; # strict -use Fcntl qw(SEEK_SET); -use IO::Socket::UNIX; -use Plack::Util; - -sub new { bless { socket_dir => $_[1]}, $_[0] } - -sub r { - [ $_[0], [ - 'Expires' => 'Fri, 01 Jan 1980 00:00:00 GMT', - 'Pragma' => 'no-cache', - 'Cache-Control' => 'no-cache, max-age=0, must-revalidate', - 'Content-Type' => 'text/html; charset=UTF-8', - 'Content-Length' => length($_[1]), - ], [ $_[1] ] ]; -} - -my $valid_pid = $^O eq 'linux' ? sub { - my ($pid) = @_; - if (open(my $fh, '<', "/proc/$pid/cmdline")) { - local $/; - my $str = <$fh> // return; - $str =~ tr/\0/ /; - Plack::Util::encode_html($str); - } -} : sub { kill(0, $_[0]) ? "PID: $_[0]" : undef }; - -sub list { - my ($self, $env) = @_; - state $t = 'mwrap reverse proxy endpoints'; - open(my $fh, '+>', \(my $str)) or die "open: $!"; - print $fh '<html><head><title>', $t, '</title></head><body><pre>', $t, - "\n\n"; - my $dir = $self->{socket_dir}; - opendir(my $dh, $dir) or return r(500, "socket_dir: $!"); - my @socks = grep(/\A[0-9]+\.sock\z/, readdir($dh)); - my %o = (Type => SOCK_STREAM, Peer => undef); - for (@socks) { - $o{Peer} = "$dir/$_"; - substr($_, -5, 5, ''); # chop off .sock - my $cmd = $valid_pid->($_) // next; - my $c = IO::Socket::UNIX->new(%o) // next; - print $fh qq(<a\nhref="./$_/">$_</a>/); - $_ .= '/each/2000'; - say $fh qq(<a\nhref="./), $_, qq(">each/2000</a>\t), $cmd; - } - print $fh '</pre></body></html>'; - r(200, $str); -} - -our %addr2line; # { exe|lib => Devel::Mwrap::Rproxy::A2L } -my %cache; # "$exe\0$addr$st_ctime$st_size" => $line -my $cache_exp = 0; -my $cache_time = 1800; - -sub resolve_exe ($$) { - my ($exe, $st) = @_; - # n.b. this assumes PATH is identical across the rproxy and - # mwrap-httpd process, which may not always be the case: - if (index($exe, '/') < 0 && !-r $exe) { - for my $p (split(/:/, $ENV{PATH})) { - $p .= "/$exe"; - if (-x $p) { - $exe = $p; - last; - } - } - } - my $fh; - if (-T $exe && open($fh, '<', $exe)) { # is it text? use shebang - my $l = readline($fh); - $exe = ($l =~ /\A\#\![ \t]*(\S+)/) ? $1 : $^X; - } - return unless -e $exe; - my @st = stat(_); - - # Debian `perl-debug' is special: - if ($exe eq '/usr/bin/perl' && -x '/usr/bin/debugperl') { - @st = stat(_); - $exe = '/usr/bin/debugperl'; - } - $$st = pack('dd', $st[10], $st[7]); # ctime + size - $exe; -} - -# addr2line bidirectional pipe wrapper -sub a2l { - my ($exe, $addr) = @_; - $exe = resolve_exe($exe, \(my $st)) // return "$exe($addr)"; - $cache{"$addr\0$exe$st"} //= do { - my $a2l = $addr2line{$exe} //= - Devel::Mwrap::Rproxy::A2L->new($exe); - - $a2l ? do { - chomp(my $line = $a2l->lookup($addr)); - $line =~ s/\Q?? at ??:0\E//; # FreeBSD - $line = Plack::Util::encode_html($line); - $line =~ /\?\?/ ? "$line $exe($addr)" : - ($line =~ /\S/ ? $line : "$exe($addr)"); - } : "$exe($addr)" - } -} - -sub call { # PSGI entry point - my ($self, $env) = @_; - my $uri = $env->{REQUEST_URI}; - $uri =~ s!\A\Q$env->{SCRIPT_NAME}\E!!; - my $method = $env->{REQUEST_METHOD}; - return list(@_) if $uri eq '/' && $method eq 'GET'; - - # must have /$PID/ prefix to map socket - $uri =~ m!\A/([0-9]+)/! or return r(404, 'not found'); - my $s = "$self->{socket_dir}/$1.sock"; - my %o = (Peer => $s, Type => SOCK_STREAM); - my $c = IO::Socket::UNIX->new(%o) or return r(500, "connect: $!"); - my $h = "$method $uri HTTP/1.0\n\n"; - $s = send($c, $h, MSG_NOSIGNAL) // return r(500, "send: $!"); - $s == length($h) or return r(500, "send $s <".length($h)); - # this only expects httpd.h output, so no continuation lines: - $h = do { local $/ = "\r\n\r\n"; <$c> } // return r(500, "read: $!"); - my ($code, @hdr) = split(/\r\n/, $h); - @hdr = grep(!/^Content-Length:/i, @hdr); # addr2line changes length - my $csv = grep(m!^Content-Type: text/csv!i, @hdr); - (undef, $code, undef) = split(/ /, $code); - @hdr = map { split(/: /, $_, 2) } @hdr; - sub { - my ($wcb) = @_; - my $http_out = $wcb->([$code, \@hdr]); - my $now = time; - if ($now > $cache_exp) { - undef %cache; - $cache_exp = $now + $cache_time; - } - - # GNU addr2line is slow with high bt:, and FreeBSD addr2line - # seems less capable. And we can't see addr2line in this - # anyways since we kill them at the end of this scope. - # So just disable MWRAP, here: - delete local $ENV{MWRAP}; - delete local $ENV{LD_PRELOAD}; - eval { - local %addr2line; - # extract executable|library(address) - if ($csv) { - while (<$c>) { - s/\\n/\0\0/g; - s!(["\0]) - ([^\("\0]+) # exe - \(([^\)"\0]+)\) # addr - (["\0])! - $1.a2l($2,$3).$4!gex; - s/\0\0/\\n/g; - $http_out->write($_); - } - } else { - while (<$c>) { - s!> - ([^\(<]+) # exe - \(([^\)<]+)\) # addr - <! - '>'.a2l($1,$2).'<'!gex; - $http_out->write($_); - } - } - close $c; - }; - warn "E: $@" if $@; - $http_out->close; - } -} - -# requires GNU addr2line for stdin/stdout support -package Devel::Mwrap::Rproxy::A2L; -use v5.12; - -sub new { - my ($cls, $exe) = @_; - pipe(my ($rd, $_wr)) or die "pipe: $!"; - pipe(my ($_rd, $wr)) or die "pipe: $!"; - # -f/--functions needs -p/--pretty-print to go with it - my $addr2line = $ENV{ADDR2LINE} // 'addr2line -i -p -f'; - my @addr2line = split(/\s+/, $addr2line); - my $pid = fork // die "fork: $!"; - if ($pid == 0) { - close $rd; - close $wr; - open STDIN, '<&', $_rd or die "STDIN: $!"; - open STDOUT, '>&', $_wr or die "STDOUT: $!"; - exec @addr2line, '-e', $exe; - die "exec @addr2line -e $exe: $!"; - } - $_rd = $_wr = undef; - $wr->autoflush(1); - bless { rd => $rd, wr => $wr, pid => $pid }, __PACKAGE__; -} - -sub lookup { - my ($self, $addr) = @_; - $addr =~ s/\A\+//; - say { $self->{wr} } $addr; - readline($self->{rd}); -} - -sub DESTROY { - my ($self) = @_; - close($_) for (delete @$self{qw(wr rd)}); - waitpid(delete $self->{pid}, 0); -} - -1; diff --git a/lib/mwrap/.gitignore b/lib/mwrap/.gitignore new file mode 100644 index 0000000..07c0394 --- /dev/null +++ b/lib/mwrap/.gitignore @@ -0,0 +1 @@ +version.rb diff --git a/lib/mwrap_rack.rb b/lib/mwrap_rack.rb new file mode 100644 index 0000000..6cc6d31 --- /dev/null +++ b/lib/mwrap_rack.rb @@ -0,0 +1,126 @@ +# Copyright (C) all contributors <mwrap-public@80x24.org> +# License: GPL-2.0+ <https://www.gnu.org/licenses/gpl-2.0.txt> +# frozen_string_literal: true +require 'mwrap' +require 'rack' +require 'cgi' + +# MwrapRack is an obsolete standalone Rack application which can be +# mounted to run within your application process. +# +# The embedded mwrap-httpd for Unix sockets and mwrap-rproxy for TCP +# from the Perl version <https://80x24.org/mwrap-perl.git/> replaces +# this in a non-obtrusive way for code which can't handle Ruby-level +# threads. +# +# The remaining documentation remains for historical purposes: +# +# Using the Rack::Builder API in config.ru, you can map it to +# the "/MWRAP/" endpoint. As with the rest of the Mwrap API, +# your Rack server needs to be spawned with the mwrap(1) +# wrapper to enable the LD_PRELOAD. +# +# require 'mwrap_rack' +# map('/MWRAP') { run(MwrapRack.new) } +# map('/') { run(your_normal_app) } +# +# This module is only available in mwrap 2.0.0+ +class MwrapRack + module HtmlResponse # :nodoc: + def response + [ 200, { + 'expires' => 'Fri, 01 Jan 1980 00:00:00 GMT', + 'pragma' => 'no-cache', + 'cache-control' => 'no-cache, max-age=0, must-revalidate', + 'content-type' => 'text/html; charset=UTF-8', + }, self ] + end + end + + class Each < Struct.new(:script_name, :min, :sort) # :nodoc: + include HtmlResponse + HEADER = '<tr><th>' + %w(total allocations frees mean_life max_life + location).join('</th><th>') + '</th></tr>' + FIELDS = %w(total allocations frees mean_life max_life location) + def each + Mwrap.quiet do + t = -"Mwrap.each(#{min})" + sn = script_name + all = [] + f = FIELDS.dup + sc = FIELDS.index(sort || 'total') || 0 + f[sc] = -"<b>#{f[sc]}</b>" + f.map! do |hdr| + if hdr.start_with?('<b>') + hdr + else + -%Q(<a\nhref="#{sn}/each/#{min}?sort=#{hdr}">#{hdr}</a>) + end + end + Mwrap.each(min) do |loc, total, allocations, frees, age_sum, max_life| + mean_life = frees == 0 ? Float::INFINITY : age_sum/frees.to_f + all << [total,allocations,frees,mean_life,max_life,loc] + end + all.sort_by! { |cols| -cols[sc] } + + yield(-"<html><head><title>#{t}</title></head>" \ + "<body><h1>#{t}</h1>\n" \ + "<h2>Current generation: #{GC.count}</h2>\n<table>\n" \ + "<tr><th>#{f.join('</th><th>')}</th></tr>\n") + all.each do |cols| + loc = cols.pop + cols[3] = sprintf('%0.3f', cols[3]) # mean_life + href = -(+"#{sn}/at/#{CGI.escape(loc)}").encode!(xml: :attr) + yield(%Q(<tr><td>#{cols.join('</td><td>')}<td><a\nhref=#{ + href}>#{-loc.encode(xml: :text)}</a></td></tr>\n)) + cols.clear + end.clear + yield "</table></body></html>\n" + end + end + end + + class EachAt < Struct.new(:loc) # :nodoc: + include HtmlResponse + HEADER = '<tr><th>size</th><th>generation</th></tr>' + + def each + t = loc.name.encode(xml: :text) + yield(-"<html><head><title>#{t}</title></head>" \ + "<body><h1>live allocations at #{t}</h1>" \ + "<h2>Current generation: #{GC.count}</h2>\n<table>#{HEADER}") + loc.each do |size, generation| + yield("<tr><td>#{size}</td><td>#{generation}</td></tr>\n") + end + yield "</table></body></html>\n" + end + end + + def r404 # :nodoc: + [404,{'content-type'=>'text/plain'},["Not found\n"]] + end + + # The standard Rack application endpoint for MwrapRack + def call(env) + case env['PATH_INFO'] + when %r{\A/each/(\d+)\z} + min = $1.to_i + m = env['QUERY_STRING'].match(/\bsort=(\w+)/) + Each.new(env['SCRIPT_NAME'], min, m ? m[1] : nil).response + when %r{\A/at/(.*)\z} + loc = -CGI.unescape($1) + loc = Mwrap[loc] or return r404 + EachAt.new(loc).response + when '/' + n = 2000 + u = 'https://80x24.org/mwrap/README.html' + b = -('<html><head><title>Mwrap demo</title></head>' \ + "<body><p><a href=\"each/#{n}\">allocations >#{n} bytes</a>" \ + "<p><a href=\"#{u}\">#{u}</a>" \ + "</body></html>\n") + [ 200, {'content-type'=>'text/html','content-length'=>-b.size.to_s},[b]] + else + r404 + end + end +end diff --git a/mwrap.gemspec b/mwrap.gemspec new file mode 100644 index 0000000..dc99924 --- /dev/null +++ b/mwrap.gemspec @@ -0,0 +1,35 @@ +git_manifest = `git ls-files 2>/dev/null`.split("\n") +git_ok = $?.success? +git_manifest << 'lib/mwrap/version.rb'.freeze # generated by ./VERSION-GEN +manifest = File.exist?('MANIFEST') ? + File.readlines('MANIFEST').map!(&:chomp).delete_if(&:empty?) : git_manifest +if git_ok && manifest != git_manifest + tmp = "MANIFEST.#$$.tmp" + File.open(tmp, 'w') { |fp| fp.puts(git_manifest.join("\n")) } + File.rename(tmp, 'MANIFEST') + system('git add MANIFEST') +end + +version = `./VERSION-GEN`.chomp +$?.success? or abort './VERSION-GEN failed' + +Gem::Specification.new do |s| + s.name = 'mwrap' + s.version = version + s.homepage = 'https://80x24.org/mwrap/' + s.authors = ["mwrap hackers"] + s.summary = 'LD_PRELOAD malloc wrapper for Ruby' + s.executables = %w(mwrap) + s.files = manifest + s.description = <<~EOF +mwrap wraps all malloc, calloc, and realloc calls to trace the Ruby +source location of such calls and bytes allocated at each callsite. + EOF + s.email = %q{e@80x24.org} + s.test_files = Dir['test/test_*.rb'] + s.extensions = %w(ext/mwrap/extconf.rb) + + s.add_development_dependency('test-unit', '~> 3.0') + s.add_development_dependency('rake-compiler', '~> 1.0') + s.licenses = %w(GPL-3.0+) +end diff --git a/ppport.h b/ppport.h deleted file mode 100644 index 208fb41..0000000 --- a/ppport.h +++ /dev/null @@ -1,8214 +0,0 @@ -#if 0 -<<'SKIP'; -#endif -/* ----------------------------------------------------------------------- - - ppport.h -- Perl/Pollution/Portability Version 3.40 - - Automatically created by Devel::PPPort running under perl 5.028001. - - 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.40 - -=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<ppport.h> is designed to support operation with Perl -installations back to 5.003, and has been tested up to 5.20. - -=head1 OPTIONS - -=head2 --help - -Display a brief usage summary. - -=head2 --version - -Display the version of F<ppport.h>. - -=head2 --patch=I<file> - -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<suffix> - -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 -automagically 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<Text::Diff> or a C<diff> program to be installed. - -=head2 --diff=I<program> - -Manually set the diff program and options to use. The default -is to use C<Text::Diff>, when installed, and output unified -context diffs. - -=head2 --compat-version=I<version> - -Tell F<ppport.h> 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<ppport.h> if you intend to be backward compatible only -down to a certain Perl version. - -=head2 --cplusplus - -Usually, F<ppport.h> will detect C++ style comments and -replace them with C style comments for portability reasons. -Using this option instructs F<ppport.h> 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<ppport.h>. -This reduces the size of F<ppport.h> dramatically and may be useful -if you want to include F<ppport.h> in smaller modules without -increasing their distribution size too much. - -The stripped F<ppport.h> will have a C<--unstrip> option that allows -you to undo the stripping, but only if an appropriate C<Devel::PPPort> -module is installed. - -=head2 --list-provided - -Lists the API elements for which compatibility is provided by -F<ppport.h>. 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<ppport.h> and below which version of Perl they probably -won't be available or work. - -=head2 --api-info=I<name> - -Show portability information for API elements matching I<name>. -If I<name> 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<PL_> prefix is deprecated. Also, -some API functions used to have a C<perl_> prefix. Using this form is -also deprecated. You can safely use the supported API, as F<ppport.h> -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<ppport.h>. - -These functions or variables will be marked C<explicit> 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<static> or global -variants. - -For a C<static> 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 - SvRX() NEED_SvRX NEED_SvRX_GLOBAL - caller_cx() NEED_caller_cx NEED_caller_cx_GLOBAL - croak_xs_usage() NEED_croak_xs_usage NEED_croak_xs_usage_GLOBAL - die_sv() NEED_die_sv NEED_die_sv_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 - gv_fetchpvn_flags() NEED_gv_fetchpvn_flags NEED_gv_fetchpvn_flags_GLOBAL - load_module() NEED_load_module NEED_load_module_GLOBAL - mess() NEED_mess NEED_mess_GLOBAL - mess_nocontext() NEED_mess_nocontext NEED_mess_nocontext_GLOBAL - mess_sv() NEED_mess_sv NEED_mess_sv_GLOBAL - mg_findext() NEED_mg_findext NEED_mg_findext_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 - sv_unmagicext() NEED_sv_unmagicext NEED_sv_unmagicext_GLOBAL - vload_module() NEED_vload_module NEED_vload_module_GLOBAL - vmess() NEED_vmess NEED_vmess_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<DPPP_NAMESPACE> -macro. Just C<#define> the macro before including C<ppport.h>: - - #define DPPP_NAMESPACE MyOwnNamespace_ - #include "ppport.h" - -The default namespace is C<DPPP_>. - -=back - -The good thing is that most of the above can be checked by running -F<ppport.h> on your source code. See the next section for -details. - -=head1 EXAMPLES - -To verify whether F<ppport.h> is needed for your module, whether you -should make any changes to your code, and whether any special defines -should be used, F<ppport.h> 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<diff> 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<newSVpvn> 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<ppport.h> is causing failure during -the compilation of this module, please check if newer versions -of either this module or C<Devel::PPPort> are available on CPAN -before sending a bug report. - -If F<ppport.h> was generated using the latest version of -C<Devel::PPPort> and is causing failure of this module, please -send a bug report to L<perlbug@perl.org|mailto:perlbug@perl.org>. - -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<Devel::PPPort> -module from CPAN. - -=head1 COPYRIGHT - -Version 3.x, Copyright (c) 2004-2013, 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<Devel::PPPort>. - -=cut - -use strict; - -# Disable broken TRIE-optimization -BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 } - -my $VERSION = 3.40; - -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( -ASCII_TO_NEED||5.007001|n -AvFILLp|5.004050||p -AvFILL||| -BhkDISABLE||5.024000| -BhkENABLE||5.024000| -BhkENTRY_set||5.024000| -BhkENTRY||| -BhkFLAGS||| -CALL_BLOCK_HOOKS||| -CLASS|||n -CPERLscope|5.005000||p -CX_CURPAD_SAVE||| -CX_CURPAD_SV||| -C_ARRAY_END|5.013002||p -C_ARRAY_LENGTH|5.008001||p -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|5.004050|p -Copy||| -CvPADLIST||5.008001| -CvSTASH||| -CvWEAKOUTSIDE||| -DECLARATION_FOR_LC_NUMERIC_MANIPULATION||5.021010|n -DEFSV_set|5.010001||p -DEFSV|5.004050||p -DO_UTF8||5.006000| -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||| -GvAV||| -GvCV||| -GvHV||| -GvSV||| -Gv_AMupdate||5.011000| -HEf_SVKEY|5.003070||p -HeHASH||5.003070| -HeKEY||5.003070| -HeKLEN||5.003070| -HePV||5.004000| -HeSVKEY_force||5.003070| -HeSVKEY_set||5.004000| -HeSVKEY||5.003070| -HeUTF8|5.010001|5.008000|p -HeVAL||5.003070| -HvENAMELEN||5.015004| -HvENAMEUTF8||5.015004| -HvENAME||5.013007| -HvNAMELEN_get|5.009003||p -HvNAMELEN||5.015004| -HvNAMEUTF8||5.015004| -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||| -LINKLIST||5.013006| -LVRET||| -MARK||| -MULTICALL||5.024000| -MUTABLE_PTR|5.010001||p -MUTABLE_SV|5.010001||p -MY_CXT_CLONE|5.009002||p -MY_CXT_INIT|5.007003||p -MY_CXT|5.007003||p -MoveD|5.009002|5.004050|p -Move||| -NATIVE_TO_NEED||5.007001|n -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||| -OP_CLASS||5.013007| -OP_DESC||5.007003| -OP_NAME||5.007003| -OP_TYPE_IS_OR_WAS||5.019010| -OP_TYPE_IS||5.019007| -ORIGMARK||| -OpHAS_SIBLING|5.021007||p -OpLASTSIB_set|5.021011||p -OpMAYBESIB_set|5.021011||p -OpMORESIB_set|5.021011||p -OpSIBLING|5.021007||p -PAD_BASE_SV||| -PAD_CLONE_VARS||| -PAD_COMPNAME_FLAGS||| -PAD_COMPNAME_GEN_set||| -PAD_COMPNAME_GEN||| -PAD_COMPNAME_OURSTASH||| -PAD_COMPNAME_PV||| -PAD_COMPNAME_TYPE||| -PAD_RESTORE_LOCAL||| -PAD_SAVE_LOCAL||| -PAD_SAVE_SETNULLPAD||| -PAD_SETSV||| -PAD_SET_CUR_NOSAVE||| -PAD_SET_CUR||| -PAD_SVl||| -PAD_SV||| -PERLIO_FUNCS_CAST|5.009003||p -PERLIO_FUNCS_DECL|5.009003||p -PERL_ABS|5.008001||p -PERL_ARGS_ASSERT_CROAK_XS_USAGE|||p -PERL_BCDVERSION|5.024000||p -PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p -PERL_HASH|5.003070||p -PERL_INT_MAX|5.003070||p -PERL_INT_MIN|5.003070||p -PERL_LONG_MAX|5.003070||p -PERL_LONG_MIN|5.003070||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.024000||p -PERL_MAGIC_isaelem|5.007002||p -PERL_MAGIC_isa|5.007002||p -PERL_MAGIC_mutex|5.024000||p -PERL_MAGIC_nkeys|5.007002||p -PERL_MAGIC_overload_elem|5.024000||p -PERL_MAGIC_overload_table|5.007002||p -PERL_MAGIC_overload|5.024000||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.003070||p -PERL_QUAD_MIN|5.003070||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.003070||p -PERL_SHORT_MIN|5.003070||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.024000| -PERL_UCHAR_MAX|5.003070||p -PERL_UCHAR_MIN|5.003070||p -PERL_UINT_MAX|5.003070||p -PERL_UINT_MIN|5.003070||p -PERL_ULONG_MAX|5.003070||p -PERL_ULONG_MIN|5.003070||p -PERL_UNUSED_ARG|5.009003||p -PERL_UNUSED_CONTEXT|5.009004||p -PERL_UNUSED_DECL|5.007002||p -PERL_UNUSED_RESULT|5.021001||p -PERL_UNUSED_VAR|5.007002||p -PERL_UQUAD_MAX|5.003070||p -PERL_UQUAD_MIN|5.003070||p -PERL_USE_GCC_BRACE_GROUPS|5.009004||p -PERL_USHORT_MAX|5.003070||p -PERL_USHORT_MIN|5.003070||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.024000||p -PL_bufptr|5.024000||p -PL_check||5.006000| -PL_compiling|5.004050||p -PL_comppad_name||5.017004| -PL_comppad||5.008001| -PL_copline|5.024000||p -PL_curcop|5.004050||p -PL_curpad||5.005000| -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.024000||p -PL_expect|5.024000||p -PL_hexdigit|5.005000||p -PL_hints|5.005000||p -PL_in_my_stash|5.024000||p -PL_in_my|5.024000||p -PL_keyword_plugin||5.011002| -PL_last_in_gv|||n -PL_laststatval|5.005000||p -PL_lex_state|5.024000||p -PL_lex_stuff|5.024000||p -PL_linestr|5.024000||p -PL_modglobal||5.005000|n -PL_na|5.004050||pn -PL_no_modify|5.006000||p -PL_ofsgv|||n -PL_opfreehook||5.011000|n -PL_parser|5.009005||p -PL_peepp||5.007003|n -PL_perl_destruct_level|5.004050||p -PL_perldb|5.004050||p -PL_ppaddr|5.006000||p -PL_rpeepp||5.013005|n -PL_rsfp_filters|5.024000||p -PL_rsfp|5.024000||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.024000||p -POP_MULTICALL||5.024000| -POPi|||n -POPl|||n -POPn|||n -POPpbytex||5.007001|n -POPpx||5.005030|n -POPp|||n -POPs|||n -POPul||5.006000|n -POPu||5.004000|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.024000| -PUSHi||| -PUSHmortal|5.009002||p -PUSHn||| -PUSHp||| -PUSHs||| -PUSHu|5.004000||p -PUTBACK||| -PadARRAY||5.024000| -PadMAX||5.024000| -PadlistARRAY||5.024000| -PadlistMAX||5.024000| -PadlistNAMESARRAY||5.024000| -PadlistNAMESMAX||5.024000| -PadlistNAMES||5.024000| -PadlistREFCNT||5.017004| -PadnameIsOUR||| -PadnameIsSTATE||| -PadnameLEN||5.024000| -PadnameOURSTASH||| -PadnameOUTER||| -PadnamePV||5.024000| -PadnameREFCNT_dec||5.024000| -PadnameREFCNT||5.024000| -PadnameSV||5.024000| -PadnameTYPE||| -PadnameUTF8||5.021007| -PadnamelistARRAY||5.024000| -PadnamelistMAX||5.024000| -PadnamelistREFCNT_dec||5.024000| -PadnamelistREFCNT||5.024000| -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_restore_errno||| -PerlIO_save_errno||| -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 -READ_XDIGIT||5.017006| -RESTORE_LC_NUMERIC||5.024000| -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 -STORE_LC_NUMERIC_FORCE_TO_UNDERLYING||5.024000| -STORE_LC_NUMERIC_SET_TO_NEEDED||5.024000| -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_INVLIST||5.019002| -SVt_IV||| -SVt_NULL||| -SVt_NV||| -SVt_PVAV||| -SVt_PVCV||| -SVt_PVFM||| -SVt_PVGV||| -SVt_PVHV||| -SVt_PVIO||| -SVt_PVIV||| -SVt_PVLV||| -SVt_PVMG||| -SVt_PVNV||| -SVt_PV||| -SVt_REGEXP||5.011000| -Safefree||| -Slab_Alloc||| -Slab_Free||| -Slab_to_ro||| -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_nomg||5.013002| -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_nolen|5.013007||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_NN||5.017007| -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||p -SvRX|5.009005||p -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||| -SvTHINKFIRST||| -SvTRUE_nomg||5.013006| -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 -UTF8SKIP||5.006000| -UTF8_MAXBYTES|5.009002||p -UVCHR_SKIP||5.022000| -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.024000||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 -WIDEST_UTYPE|5.015004||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_APIVERSION_BOOTCHECK||5.024000| -XS_EXTERNAL||5.024000| -XS_INTERNAL||5.024000| -XS_VERSION_BOOTCHECK||5.024000| -XS_VERSION||| -XSprePUSH|5.006000||p -XS||| -XopDISABLE||5.024000| -XopENABLE||5.024000| -XopENTRYCUSTOM||5.024000| -XopENTRY_set||5.024000| -XopENTRY||5.024000| -XopFLAGS||5.013007| -ZeroD|5.009002||p -Zero||| -_aMY_CXT|5.007003||p -_add_range_to_invlist||| -_append_range_to_invlist||| -_core_swash_init||| -_get_encoding||| -_get_regclass_nonbitmap_data||| -_get_swash_invlist||| -_invlistEQ||| -_invlist_array_init|||n -_invlist_contains_cp|||n -_invlist_dump||| -_invlist_intersection_maybe_complement_2nd||| -_invlist_intersection||| -_invlist_invert||| -_invlist_len|||n -_invlist_populate_swatch|||n -_invlist_search|||n -_invlist_subtract||| -_invlist_union_maybe_complement_2nd||| -_invlist_union||| -_is_cur_LC_category_utf8||| -_is_in_locale_category||5.021001| -_is_uni_FOO||5.017008| -_is_uni_perl_idcont||5.017008| -_is_uni_perl_idstart||5.017007| -_is_utf8_FOO||5.017008| -_is_utf8_char_slow||5.021001|n -_is_utf8_idcont||5.021001| -_is_utf8_idstart||5.021001| -_is_utf8_mark||5.017008| -_is_utf8_perl_idcont||5.017008| -_is_utf8_perl_idstart||5.017007| -_is_utf8_xidcont||5.021001| -_is_utf8_xidstart||5.021001| -_load_PL_utf8_foldclosures||| -_make_exactf_invlist||| -_new_invlist_C_array||| -_new_invlist||| -_pMY_CXT|5.007003||p -_setlocale_debug_string|||n -_setup_canned_invlist||| -_swash_inversion_hash||| -_swash_to_invlist||| -_to_fold_latin1||| -_to_uni_fold_flags||5.014000| -_to_upper_title_latin1||| -_to_utf8_case||| -_to_utf8_fold_flags||5.019009| -_to_utf8_lower_flags||5.019009| -_to_utf8_title_flags||5.019009| -_to_utf8_upper_flags||5.019009| -_warn_problematic_locale|||n -aMY_CXT_|5.007003||p -aMY_CXT|5.007003||p -aTHXR_|5.024000||p -aTHXR|5.024000||p -aTHX_|5.006000||p -aTHX|5.006000||p -add_above_Latin1_folds||| -add_cp_to_invlist||| -add_data|||n -add_multi_match||| -add_utf16_textfilter||| -adjust_size_and_find_bucket|||n -advance_one_LB||| -advance_one_SB||| -advance_one_WB||| -alloc_maybe_populate_EXACT||| -alloccopstash||| -allocmy||| -amagic_call||| -amagic_cmp_locale||| -amagic_cmp||| -amagic_deref_call||5.013007| -amagic_i_ncmp||| -amagic_is_enabled||| -amagic_ncmp||| -anonymise_cv_maybe||| -any_dup||| -ao||| -append_utf8_from_native_byte||5.019004|n -apply_attrs_my||| -apply_attrs_string||5.006001| -apply_attrs||| -apply||| -assert_uft8_cache_coherent||| -assignment_type||| -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_guts||| -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_tindex||5.017009| -av_top_index||5.017009| -av_undef||| -av_unshift||| -ax|||n -backup_one_LB||| -backup_one_SB||| -backup_one_WB||| -bad_type_gv||| -bad_type_pv||| -bind_match||| -block_end||5.004000| -block_gimme||5.004000| -block_start||5.004000| -blockhook_register||5.013003| -boolSV|5.004000||p -boot_core_PerlIO||| -boot_core_UNIVERSAL||| -boot_core_mro||| -bytes_cmp_utf8||5.013007| -bytes_from_utf8||5.007001| -bytes_to_utf8||5.006001| -cBOOL|5.013000||p -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 -caller_cx|5.013005|5.006000|p -calloc||5.007002|n -cando||| -cast_i32||5.006000|n -cast_iv||5.006000|n -cast_ulong||5.006000|n -cast_uv||5.006000|n -check_locale_boundary_crossing||| -check_type_and_open||| -check_uni||| -check_utf8_print||| -checkcomma||| -ckWARN|5.006000||p -ck_entersub_args_core||| -ck_entersub_args_list||5.013006| -ck_entersub_args_proto_or_list||5.013006| -ck_entersub_args_proto||5.013006| -ck_warner_d||5.011001|v -ck_warner||5.011001|v -ckwarn_common||| -ckwarn_d||5.009003| -ckwarn||5.009003| -clear_defarray||5.023008| -clear_placeholders||| -clear_special_blocks||| -clone_params_del|||n -clone_params_new|||n -closest_cop||| -cntrl_to_mnemonic|||n -compute_EXACTish|||n -construct_ahocorasick_from_trie||| -cop_fetch_label||5.015001| -cop_free||| -cop_hints_2hv||5.013007| -cop_hints_fetch_pvn||5.013007| -cop_hints_fetch_pvs||5.013007| -cop_hints_fetch_pv||5.013007| -cop_hints_fetch_sv||5.013007| -cop_store_label||5.015001| -cophh_2hv||5.013007| -cophh_copy||5.013007| -cophh_delete_pvn||5.013007| -cophh_delete_pvs||5.013007| -cophh_delete_pv||5.013007| -cophh_delete_sv||5.013007| -cophh_fetch_pvn||5.013007| -cophh_fetch_pvs||5.013007| -cophh_fetch_pv||5.013007| -cophh_fetch_sv||5.013007| -cophh_free||5.013007| -cophh_new_empty||5.024000| -cophh_store_pvn||5.013007| -cophh_store_pvs||5.013007| -cophh_store_pv||5.013007| -cophh_store_sv||5.013007| -core_prototype||| -coresub_op||| -cr_textfilter||| -create_eval_scope||| -croak_memory_wrap|5.019003||pn -croak_no_mem|||n -croak_no_modify|5.013003||pn -croak_nocontext|||pvn -croak_popstack|||n -croak_sv|5.013001||p -croak_xs_usage|5.010001||pn -croak|||v -csighandler||5.009003|n -current_re_engine||| -curse||| -custom_op_desc||5.007003| -custom_op_get_field||| -custom_op_name||5.007003| -custom_op_register||5.013007| -custom_op_xop||5.013007| -cv_ckproto_len_flags||| -cv_clone_into||| -cv_clone||| -cv_const_sv_or_av|||n -cv_const_sv||5.003070|n -cv_dump||| -cv_forget_slab||| -cv_get_call_checker||5.013006| -cv_name||5.021005| -cv_set_call_checker_flags||5.021004| -cv_set_call_checker||5.013006| -cv_undef_flags||| -cv_undef||| -cvgv_from_hek||| -cvgv_set||| -cvstash_set||| -cx_dump||5.005000| -cx_dup||| -cx_popblock||5.023008| -cx_popeval||5.023008| -cx_popformat||5.023008| -cx_popgiven||5.023008| -cx_poploop||5.023008| -cx_popsub_args||5.023008| -cx_popsub_common||5.023008| -cx_popsub||5.023008| -cx_popwhen||5.023008| -cx_pushblock||5.023008| -cx_pusheval||5.023008| -cx_pushformat||5.023008| -cx_pushgiven||5.023008| -cx_pushloop_for||5.023008| -cx_pushloop_plain||5.023008| -cx_pushsub||5.023008| -cx_pushwhen||5.023008| -cx_topblock||5.023008| -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.024000||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 -defelem_target||| -del_sv||| -delete_eval_scope||| -delimcpy||5.004000|n -deprecate_commaless_var_list||| -despatch_signals||5.007001| -destroy_matcher||| -die_nocontext|||vn -die_sv|5.013001||p -die_unwind||| -die|||v -dirp_dup||| -div128||| -djSP||| -do_aexec5||| -do_aexec||| -do_aspawn||| -do_binmode||5.004050| -do_chomp||| -do_close||| -do_delete_local||| -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_magic_dump||5.006000| -do_msgrcv||| -do_msgsnd||| -do_ncmp||| -do_oddball||| -do_op_dump||5.006000| -do_open6||| -do_open9||5.006000| -do_open_raw||| -do_openn||5.007001| -do_open||5.003070| -do_pmop_dump||5.006000| -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_compile||| -dofile||| -dofindlabel||| -doform||| -doing_taint||5.008001|n -dooneliner||| -doopen_pm||| -doparseform||| -dopoptoeval||| -dopoptogivenfor||| -dopoptolabel||| -dopoptoloop||| -dopoptosub_at||| -dopoptowhen||| -doref||5.009003| -dounwind||| -dowantarray||| -drand48_init_r|||n -drand48_r|||n -dtrace_probe_call||| -dtrace_probe_load||| -dtrace_probe_op||| -dtrace_probe_phase||| -dump_all_perl||| -dump_all||5.006000| -dump_c_backtrace||| -dump_eval||5.006000| -dump_exec_pos||| -dump_form||5.006000| -dump_indent||5.006000|v -dump_mstats||| -dump_packsubs_perl||| -dump_packsubs||5.006000| -dump_sub_perl||| -dump_sub||5.006000| -dump_sv_child||| -dump_trie_interim_list||| -dump_trie_interim_table||| -dump_trie||| -dump_vindent||5.006000| -dumpuntil||| -dup_attrlist||| -edit_distance|||n -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||| -filter_add||| -filter_del||| -filter_gets||| -filter_read||| -finalize_optree||| -finalize_op||| -find_and_forget_pmops||| -find_array_subscript||| -find_beginning||| -find_byclass||| -find_default_stash||| -find_hash_subscript||| -find_in_my_stash||| -find_lexical_cv||| -find_runcv_where||| -find_runcv||5.008001| -find_rundefsvoffset||5.009002| -find_rundefsv||5.013002| -find_script||| -find_uninit_var||| -first_symbol|||n -fixup_errno_string||| -foldEQ_latin1||5.013008|n -foldEQ_locale||5.013002|n -foldEQ_utf8_flags||5.013010| -foldEQ_utf8||5.013002| -foldEQ||5.013002|n -fold_constants||| -forbid_setid||| -force_ident_maybe_lex||| -force_ident||| -force_list||| -force_next||| -force_strict_version||| -force_version||| -force_word||| -forget_pmop||| -form_nocontext|||vn -form_short_octal_warning||| -form||5.004000|v -fp_dup||| -fprintf_nocontext|||vn -free_c_backtrace||| -free_global_struct||| -free_tied_hv_pool||| -free_tmps||| -gen_constant_list||| -get_ANYOF_cp_list_for_ssc||| -get_and_check_backslash_N_name||| -get_aux_mg||| -get_av|5.006000||p -get_c_backtrace_dump||| -get_c_backtrace||| -get_context||5.006000|n -get_cvn_flags||| -get_cvs|5.011000||p -get_cv|5.006000||p -get_db_sub||| -get_debug_opts||| -get_hash_seed||| -get_hv|5.006000||p -get_invlist_iter_addr|||n -get_invlist_offset_addr|||n -get_invlist_previous_index_addr|||n -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||| -gp_dup||| -gp_free||| -gp_ref||| -grok_atoUV|||n -grok_bin|5.007003||p -grok_bslash_N||| -grok_bslash_c||| -grok_bslash_o||| -grok_bslash_x||| -grok_hex|5.007003||p -grok_infnan||5.021004| -grok_number_flags||5.021002| -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_add_by_type||5.011000| -gv_autoload4||5.004000| -gv_autoload_pvn||5.015004| -gv_autoload_pv||5.015004| -gv_autoload_sv||5.015004| -gv_check||| -gv_const_sv||5.009003| -gv_dump||5.006000| -gv_efullname3||5.003070| -gv_efullname4||5.006001| -gv_efullname||| -gv_fetchfile_flags||5.009005| -gv_fetchfile||| -gv_fetchmeth_autoload||5.007003| -gv_fetchmeth_internal||| -gv_fetchmeth_pv_autoload||5.015004| -gv_fetchmeth_pvn_autoload||5.015004| -gv_fetchmeth_pvn||5.015004| -gv_fetchmeth_pv||5.015004| -gv_fetchmeth_sv_autoload||5.015004| -gv_fetchmeth_sv||5.015004| -gv_fetchmethod_autoload||5.004000| -gv_fetchmethod_pv_flags||5.015004| -gv_fetchmethod_pvn_flags||5.015004| -gv_fetchmethod_sv_flags||5.015004| -gv_fetchmethod||| -gv_fetchmeth||| -gv_fetchpvn_flags|5.009002||p -gv_fetchpvs|5.009004||p -gv_fetchpv||| -gv_fetchsv||| -gv_fullname3||5.003070| -gv_fullname4||5.006001| -gv_fullname||| -gv_handler||5.007001| -gv_init_pvn||| -gv_init_pv||5.015004| -gv_init_svtype||| -gv_init_sv||5.015004| -gv_init||| -gv_is_in_main||| -gv_magicalize_isa||| -gv_magicalize||| -gv_name_set||5.009004| -gv_override||| -gv_setref||| -gv_stashpvn_internal||| -gv_stashpvn|5.003070||p -gv_stashpvs|5.009003||p -gv_stashpv||| -gv_stashsvpvn_cached||| -gv_stashsv||| -gv_try_downgrade||| -handle_named_backref||| -handle_possible_posix||| -handle_regex_sets||| -he_dup||| -hek_dup||| -hfree_next_entry||| -hsplit||| -hv_assert||| -hv_auxinit_internal|||n -hv_auxinit||| -hv_backreferences_p||| -hv_clear_placeholders||5.009001| -hv_clear||| -hv_common_key_len||5.010000| -hv_common||5.010000| -hv_copy_hints_hv||5.009004| -hv_delayfree_ent||5.004000| -hv_delete_common||| -hv_delete_ent||5.003070| -hv_delete||| -hv_eiter_p||5.009003| -hv_eiter_set||5.009003| -hv_ename_add||| -hv_ename_delete||| -hv_exists_ent||5.003070| -hv_exists||| -hv_fetch_ent||5.003070| -hv_fetchs|5.009003||p -hv_fetch||| -hv_fill||5.013002| -hv_free_ent_ret||| -hv_free_entries||| -hv_free_ent||5.004000| -hv_iterinit||| -hv_iterkeysv||5.003070| -hv_iterkey||| -hv_iternext_flags||5.008000| -hv_iternextsv||| -hv_iternext||| -hv_iterval||| -hv_kill_backrefs||| -hv_ksplit||5.003070| -hv_magic_check|||n -hv_magic||| -hv_name_set||5.009003| -hv_notallowed||| -hv_placeholders_get||5.009003| -hv_placeholders_p||| -hv_placeholders_set||5.009003| -hv_rand_set||5.018000| -hv_riter_p||5.009003| -hv_riter_set||5.009003| -hv_scalar||5.009001| -hv_store_ent||5.003070| -hv_store_flags||5.008000| -hv_stores|5.009004||p -hv_store||| -hv_undef_flags||| -hv_undef||| -ibcmp_locale||5.004000| -ibcmp_utf8||5.007003| -ibcmp||| -incline||| -incpush_if_exists||| -incpush_use_sep||| -incpush||| -ingroup||| -init_argv_symbols||| -init_constants||| -init_dbargs||| -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| -inplace_aassign||| -instr|||n -intro_my||5.004000| -intuit_method||| -intuit_more||| -invert||| -invlist_array|||n -invlist_clear||| -invlist_clone||| -invlist_contents||| -invlist_extend||| -invlist_highest|||n -invlist_is_iterating|||n -invlist_iterfinish|||n -invlist_iterinit|||n -invlist_iternext|||n -invlist_max|||n -invlist_previous_index|||n -invlist_replace_list_destroys_src||| -invlist_set_len||| -invlist_set_previous_index|||n -invlist_trim|||n -invoke_exception_hook||| -io_close||| -isALNUMC|5.006000||p -isALNUM_lazy||5.021001| -isALPHANUMERIC||5.017008| -isALPHA||| -isASCII|5.006000||p -isBLANK|5.006001||p -isCNTRL|5.006000||p -isDIGIT||| -isFOO_lc||| -isFOO_utf8_lc||| -isGCB|||n -isGRAPH|5.006000||p -isIDCONT||5.017008| -isIDFIRST_lazy||5.021001| -isIDFIRST||| -isLB||| -isLOWER||| -isOCTAL||5.013005| -isPRINT|5.004000||p -isPSXSPC|5.006001||p -isPUNCT|5.006000||p -isSB||| -isSPACE||| -isUPPER||| -isUTF8_CHAR||5.021001| -isWB||| -isWORDCHAR||5.013006| -isXDIGIT|5.006000||p -is_an_int||| -is_ascii_string||5.011000| -is_handle_constructor|||n -is_invariant_string||5.021007|n -is_lvalue_sub||5.007001| -is_safe_syscall||5.019004| -is_ssc_worth_it|||n -is_uni_alnum_lc||5.006000| -is_uni_alnumc_lc||5.017007| -is_uni_alnumc||5.017007| -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_blank_lc||5.017002| -is_uni_blank||5.017002| -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.017007| -is_utf8_alnum||5.006000| -is_utf8_alpha||5.006000| -is_utf8_ascii||5.006000| -is_utf8_blank||5.017002| -is_utf8_char_buf||5.015008|n -is_utf8_char||5.006000|n -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_perl_space||5.011001| -is_utf8_perl_word||5.011001| -is_utf8_posix_digit||5.011001| -is_utf8_print||5.006000| -is_utf8_punct||5.006000| -is_utf8_space||5.006000| -is_utf8_string_loclen||5.009003|n -is_utf8_string_loc||5.008001|n -is_utf8_string||5.006001|n -is_utf8_upper||5.006000| -is_utf8_xdigit||5.006000| -is_utf8_xidcont||5.013010| -is_utf8_xidfirst||5.013010| -isa_lookup||| -isinfnansv||| -isinfnan||5.021004|n -items|||n -ix|||n -jmaybe||| -join_exact||| -keyword_plugin_standard||| -keyword||| -leave_adjust_stacks||5.023008| -leave_scope||| -lex_bufutf8||5.011002| -lex_discard_to||5.011002| -lex_grow_linestr||5.011002| -lex_next_chunk||5.011002| -lex_peek_unichar||5.011002| -lex_read_space||5.011002| -lex_read_to||5.011002| -lex_read_unichar||5.011002| -lex_start||5.009005| -lex_stuff_pvn||5.011002| -lex_stuff_pvs||5.013005| -lex_stuff_pv||5.013006| -lex_stuff_sv||5.011002| -lex_unstuff||5.011002| -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.010001||p -mPUSHu|5.009002||p -mXPUSHi|5.009002||p -mXPUSHn|5.009002||p -mXPUSHp|5.009002||p -mXPUSHs|5.010001||p -mXPUSHu|5.009002||p -magic_clear_all_env||| -magic_cleararylen_p||| -magic_clearenv||| -magic_clearhints||| -magic_clearhint||| -magic_clearisa||| -magic_clearpack||| -magic_clearsig||| -magic_copycallchecker||| -magic_dump||5.006000| -magic_existspack||| -magic_freearylen_p||| -magic_freeovrld||| -magic_getarylen||| -magic_getdebugvar||| -magic_getdefelem||| -magic_getnkeys||| -magic_getpack||| -magic_getpos||| -magic_getsig||| -magic_getsubstr||| -magic_gettaint||| -magic_getuvar||| -magic_getvec||| -magic_get||| -magic_killbackrefs||| -magic_methcall1||| -magic_methcall|||v -magic_methpack||| -magic_nextpack||| -magic_regdata_cnt||| -magic_regdatum_get||| -magic_regdatum_set||| -magic_scalarpack||| -magic_set_all_env||| -magic_setarylen||| -magic_setcollxfrm||| -magic_setdbline||| -magic_setdebugvar||| -magic_setdefelem||| -magic_setenv||| -magic_sethint||| -magic_setisa||| -magic_setlvref||| -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||| -malloc_good_size|||n -malloced_size|||n -malloc||5.007002|n -markstack_grow||5.021001| -matcher_matches_sv||| -maybe_multimagic_gv||| -mayberelocate||| -measure_struct||| -memEQs|5.009005||p -memEQ|5.004000||p -memNEs|5.009005||p -memNE|5.004000||p -mem_collxfrm||| -mem_log_alloc|||n -mem_log_common|||n -mem_log_free|||n -mem_log_realloc|||n -mess_alloc||| -mess_nocontext|||pvn -mess_sv|5.013001||p -mess|5.006000||pv -mfree||5.007002|n -mg_clear||| -mg_copy||| -mg_dup||| -mg_find_mglob||| -mg_findext|5.013008||pn -mg_find|||n -mg_free_type||5.013006| -mg_free||| -mg_get||| -mg_length||5.005000| -mg_localize||| -mg_magical|||n -mg_set||| -mg_size||5.005000| -mini_mktime||5.007002|n -minus_v||| -missingterm||| -mode_from_discipline||| -modkids||| -more_bodies||| -more_sv||| -moreswitches||| -move_proto_attr||| -mro_clean_isarev||| -mro_gather_and_rename||| -mro_get_from_name||5.010001| -mro_get_linear_isa_dfs||| -mro_get_linear_isa||5.009005| -mro_get_private_data||5.010001| -mro_isa_changed_in||| -mro_meta_dup||| -mro_meta_init||| -mro_method_changed_in||5.009005| -mro_package_moved||| -mro_register||5.010001| -mro_set_mro||5.010001| -mro_set_private_data||5.010001| -mul128||| -mulexp10|||n -multideref_stringify||| -my_atof2||5.007002| -my_atof||5.006000| -my_attrs||| -my_bcopy||5.004050|n -my_bytes_to_utf8|||n -my_bzero|||n -my_chsize||| -my_clearenv||| -my_cxt_index||| -my_cxt_init||| -my_dirfd||5.009005|n -my_exit_jump||| -my_exit||| -my_failure_exit||5.004000| -my_fflush_all||5.006000| -my_fork||5.007003|n -my_kid||| -my_lstat_flags||| -my_lstat||5.024000| -my_memcmp|||n -my_memset|||n -my_pclose||5.003070| -my_popen_list||5.007001| -my_popen||5.003070| -my_setenv||| -my_setlocale||| -my_snprintf|5.009004||pvn -my_socketpair||5.007003|n -my_sprintf|5.009003||pvn -my_stat_flags||| -my_stat||5.024000| -my_strerror||5.021001| -my_strftime||5.007002| -my_strlcat|5.009004||pn -my_strlcpy|5.009004||pn -my_unexec||| -my_vsnprintf||5.009004|n -need_utf8|||n -newANONATTRSUB||5.006000| -newANONHASH||| -newANONLIST||| -newANONSUB||| -newASSIGNOP||| -newATTRSUB_x||| -newATTRSUB||5.006000| -newAVREF||| -newAV||| -newBINOP||| -newCONDOP||| -newCONSTSUB_flags||5.015006| -newCONSTSUB|5.004050||p -newCVREF||| -newDEFSVOP||5.021006| -newFORM||| -newFOROP||5.013007| -newGIVENOP||5.009003| -newGIVWHENOP||| -newGP||| -newGVOP||| -newGVREF||| -newGVgen_flags||5.015004| -newGVgen||| -newHVREF||| -newHVhv||5.005000| -newHV||| -newIO||| -newLISTOP||| -newLOGOP||| -newLOOPEX||| -newLOOPOP||| -newMETHOP_internal||| -newMETHOP_named||5.021005| -newMETHOP||5.021005| -newMYSUB||5.017004| -newNULLLIST||| -newOP||| -newPADNAMELIST||5.021007|n -newPADNAMEouter||5.021007|n -newPADNAMEpvn||5.021007|n -newPADOP||| -newPMOP||| -newPROG||| -newPVOP||| -newRANGE||| -newRV_inc|5.004000||p -newRV_noinc|5.004000||p -newRV||| -newSLICEOP||| -newSTATEOP||| -newSTUB||| -newSUB||| -newSVOP||| -newSVREF||| -newSV_type|5.009005||p -newSVavdefelem||| -newSVhek||5.009003| -newSViv||| -newSVnv||| -newSVpadname||5.017004| -newSVpv_share||5.013006| -newSVpvf_nocontext|||vn -newSVpvf||5.004000|v -newSVpvn_flags|5.010001||p -newSVpvn_share|5.007001||p -newSVpvn_utf8|5.010001||p -newSVpvn|5.004050||p -newSVpvs_flags|5.010001||p -newSVpvs_share|5.009003||p -newSVpvs|5.009003||p -newSVpv||| -newSVrv||| -newSVsv||| -newSVuv|5.006000||p -newSV||| -newUNOP_AUX||5.021007| -newUNOP||| -newWHENOP||5.009003| -newWHILEOP||5.013007| -newXS_deffile||| -newXS_flags||5.009004| -newXS_len_flags||| -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|||n -no_bareword_allowed||| -no_fh_allowed||| -no_op||| -noperl_die|||vn -not_a_number||| -not_incrementable||| -nothreadhook||5.008000| -nuke_stacks||| -num_overflow|||n -oopsAV||| -oopsHV||| -op_append_elem||5.013006| -op_append_list||5.013006| -op_clear||| -op_contextualize||5.013006| -op_convert_list||5.021006| -op_dump||5.006000| -op_free||| -op_integerize||| -op_linklist||5.013006| -op_lvalue_flags||| -op_lvalue||5.013007| -op_null||5.007002| -op_parent|||n -op_prepend_elem||5.013006| -op_refcnt_dec||| -op_refcnt_inc||| -op_refcnt_lock||5.009002| -op_refcnt_unlock||5.009002| -op_relocate_sv||| -op_scope||5.013007| -op_sibling_splice||5.021002|n -op_std_init||| -op_unscope||| -open_script||| -openn_cleanup||| -openn_setup||| -opmethod_stash||| -opslab_force_free||| -opslab_free_nopad||| -opslab_free||| -output_or_return_posix_warnings||| -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_version||| -package||| -packlist||5.008001| -pad_add_anon||5.008001| -pad_add_name_pvn||5.015001| -pad_add_name_pvs||5.015001| -pad_add_name_pv||5.015001| -pad_add_name_sv||5.015001| -pad_add_weakref||| -pad_alloc_name||| -pad_alloc||| -pad_block_start||| -pad_check_dup||| -pad_compname_type||5.009003| -pad_findlex||| -pad_findmy_pvn||5.015001| -pad_findmy_pvs||5.015001| -pad_findmy_pv||5.015001| -pad_findmy_sv||5.015001| -pad_fixup_inner_anons||| -pad_free||| -pad_leavemy||| -pad_new||5.008001| -pad_push||| -pad_reset||| -pad_setsv||| -pad_sv||| -pad_swipe||| -pad_tidy||5.008001| -padlist_dup||| -padlist_store||| -padname_dup||| -padname_free||| -padnamelist_dup||| -padnamelist_fetch||5.021007|n -padnamelist_free||| -padnamelist_store||5.021007| -parse_arithexpr||5.013008| -parse_barestmt||5.013007| -parse_block||5.013007| -parse_body||| -parse_fullexpr||5.013008| -parse_fullstmt||5.013005| -parse_gv_stash_name||| -parse_ident||| -parse_label||5.013007| -parse_listexpr||5.013008| -parse_lparen_question_flags||| -parse_stmtseq||5.013006| -parse_subsignature||| -parse_termexpr||5.013008| -parse_unicode_opts||| -parser_dup||| -parser_free_nexttoke_ops||| -parser_free||| -path_is_searchable|||n -peep||| -pending_ident||| -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||| -pmop_dump||5.006000| -pmruntime||| -pmtrans||| -pop_scope||| -populate_ANYOF_from_invlist||| -populate_isa|||v -pregcomp||5.009005| -pregexec||| -pregfree2||5.011000| -pregfree||| -prescan_version||5.011004| -printbuf||| -printf_nocontext|||vn -process_special_blocks||| -ptr_hash|||n -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_charclass_bitmap_innards_common||| -put_charclass_bitmap_innards_invlist||| -put_charclass_bitmap_innards||| -put_code_point||| -put_range||| -pv_display|5.006000||p -pv_escape|5.009004||p -pv_pretty|5.009004||p -pv_uni_display||5.007003| -qerror||| -qsortsvu||| -quadmath_format_needed|||n -quadmath_format_single|||n -re_compile||5.009005| -re_croak2||| -re_dup_guts||| -re_exec_indentf|||v -re_indentf|||v -re_intuit_start||5.019001| -re_intuit_string||5.006000| -re_op_compile||| -re_printf|||v -realloc||5.007002|n -reentrant_free||5.024000| -reentrant_init||5.024000| -reentrant_retry||5.024000|vn -reentrant_size||5.024000| -ref_array_or_hash||| -refcounted_he_chain_2hv||| -refcounted_he_fetch_pvn||| -refcounted_he_fetch_pvs||| -refcounted_he_fetch_pv||| -refcounted_he_fetch_sv||| -refcounted_he_free||| -refcounted_he_inc||| -refcounted_he_new_pvn||| -refcounted_he_new_pvs||| -refcounted_he_new_pv||| -refcounted_he_new_sv||| -refcounted_he_value||| -refkids||| -refto||| -ref||5.024000| -reg2Lanode||| -reg_check_named_buff_matched|||n -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_node||| -reg_numbered_buff_fetch||| -reg_numbered_buff_length||| -reg_numbered_buff_store||| -reg_qr_package||| -reg_recode||| -reg_scan_name||| -reg_skipcomment|||n -reg_temp_copy||| -reganode||| -regatom||| -regbranch||| -regclass_swash||5.009004| -regclass||| -regcppop||| -regcppush||| -regcurly|||n -regdump_extflags||| -regdump_intflags||| -regdump||5.005000| -regdupe_internal||| -regex_set_precedence|||n -regexec_flags||5.005000| -regfree_internal||5.009005| -reghop3|||n -reghop4|||n -reghopmaybe3|||n -reginclass||| -reginitcolors||5.006000| -reginsert||| -regmatch||| -regnext||5.005000| -regnode_guts||| -regpiece||| -regprop||| -regrepeat||| -regtail_study||| -regtail||| -regtry||| -reg||| -repeatcpy|||n -report_evil_fh||| -report_redefined_cv||| -report_uninit||| -report_wrongway_fh||| -require_pv||5.006000| -require_tie_mod||| -restore_magic||| -rninstr|||n -rpeep||| -rsignal_restore||| -rsignal_save||| -rsignal_state||5.004000| -rsignal||5.004000| -run_body||| -run_user_filter||| -runops_debug||5.005000| -runops_standard||5.005000| -rv2cv_op_cv||5.013006| -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_flags||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_hdelete||5.011000| -save_hek_flags|||n -save_helem_flags||5.011000| -save_helem||5.004050| -save_hints||5.010001| -save_hptr||| -save_int||| -save_item||| -save_iv||5.005000| -save_lines||| -save_list||| -save_long||| -save_magic_flags||| -save_mortalizesv||5.007001| -save_nogv||| -save_op||5.005000| -save_padsv_and_mortalize||5.010001| -save_pptr||| -save_pushi32ptr||5.010001| -save_pushptri32ptr||| -save_pushptrptr||5.010001| -save_pushptr||5.010001| -save_re_context||5.006000| -save_scalar_at||| -save_scalar||| -save_set_svflags||5.009000| -save_shared_pvref||5.007003| -save_sptr||| -save_strlen||| -save_svref||| -save_vptr||5.006000| -savepvn||| -savepvs||5.009003| -savepv||| -savesharedpvn||5.009005| -savesharedpvs||5.013006| -savesharedpv||5.007003| -savesharedsvpv||5.013006| -savestack_grow_cnt||5.008001| -savestack_grow||| -savesvpv||5.009002| -savetmps||5.023008| -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||| -search_const||| -seed||5.008001| -sequence_num||| -set_ANYOF_arg||| -set_caret_X||| -set_context||5.006000|n -set_numeric_local||5.006000| -set_numeric_radix||5.006000| -set_numeric_standard||5.006000| -set_padlist|||n -setdefout||| -share_hek_flags||| -share_hek||5.004000| -should_warn_nl|||n -si_dup||| -sighandler|||n -simplify_sort||| -skip_to_be_ignored_text||| -skipspace_flags||| -softref2xv||| -sortcv_stacked||| -sortcv_xsub||| -sortcv||| -sortsv_flags||5.009003| -sortsv||5.007003| -space_join_names_mortal||| -ss_dup||| -ssc_add_range||| -ssc_and||| -ssc_anything||| -ssc_clear_locale|||n -ssc_cp_and||| -ssc_finalize||| -ssc_init||| -ssc_intersection||| -ssc_is_anything|||n -ssc_is_cp_posixl_init|||n -ssc_or||| -ssc_union||| -stack_grow||| -start_glob||| -start_subparse||5.004000| -stdize_locale||| -strEQ||| -strGE||| -strGT||| -strLE||| -strLT||| -strNE||| -str_to_version||5.006000| -strip_return||| -strnEQ||| -strnNE||| -study_chunk||| -sub_crush_depth||| -sublex_done||| -sublex_push||| -sublex_start||| -sv_2bool_flags||5.013006| -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_flags||5.013001| -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|||n -sv_bless||| -sv_buf_to_ro||| -sv_buf_to_rw||| -sv_cat_decode||5.008001| -sv_catpv_flags||5.013006| -sv_catpv_mg|5.004050||p -sv_catpv_nomg||5.013006| -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_flags||5.013006| -sv_catpvs_mg||5.013006| -sv_catpvs_nomg||5.013006| -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_chop||| -sv_clean_all||| -sv_clean_objs||| -sv_clear||| -sv_cmp_flags||5.013006| -sv_cmp_locale_flags||5.013006| -sv_cmp_locale||5.004000| -sv_cmp||| -sv_collxfrm_flags||5.013006| -sv_collxfrm||| -sv_copypv_flags||5.017002| -sv_copypv_nomg||5.017002| -sv_copypv||| -sv_dec_nomg||5.013002| -sv_dec||| -sv_del_backref||| -sv_derived_from_pvn||5.015004| -sv_derived_from_pv||5.015004| -sv_derived_from_sv||5.015004| -sv_derived_from||5.004000| -sv_destroyable||5.010000| -sv_display||| -sv_does_pvn||5.015004| -sv_does_pv||5.015004| -sv_does_sv||5.015004| -sv_does||5.009004| -sv_dump||| -sv_dup_common||| -sv_dup_inc_multiple||| -sv_dup_inc||| -sv_dup||| -sv_eq_flags||5.013006| -sv_eq||| -sv_exp_grow||| -sv_force_normal_flags||5.007001| -sv_force_normal||5.006000| -sv_free2||| -sv_free_arenas||| -sv_free||| -sv_get_backrefs||5.021008|n -sv_gets||5.003070| -sv_grow||| -sv_i_ncmp||| -sv_inc_nomg||5.013002| -sv_inc||| -sv_insert_flags||5.010001| -sv_insert||| -sv_isa||| -sv_isobject||| -sv_iv||5.005000| -sv_kill_backrefs||| -sv_len_utf8_nomg||| -sv_len_utf8||5.006000| -sv_len||| -sv_magic_portable|5.024000|5.004000|p -sv_magicext_mglob||| -sv_magicext||5.007003| -sv_magic||| -sv_mortalcopy_flags||| -sv_mortalcopy||| -sv_ncmp||| -sv_newmortal||| -sv_newref||| -sv_nolocking||5.007003| -sv_nosharing||5.007003| -sv_nounlocking||| -sv_nv||5.005000| -sv_only_taint_gmagic|||n -sv_or_pv_pos_u2b||| -sv_peek||5.005000| -sv_pos_b2u_flags||5.019003| -sv_pos_b2u_midway||| -sv_pos_b2u||5.006000| -sv_pos_u2b_cached||| -sv_pos_u2b_flags||5.011005| -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_ref||5.015004| -sv_replace||| -sv_report_used||| -sv_resetpvn||| -sv_reset||| -sv_rvweaken||5.006000| -sv_sethek||| -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_mg||5.013006| -sv_setpvs|5.009004||p -sv_setpv||| -sv_setref_iv||| -sv_setref_nv||| -sv_setref_pvn||| -sv_setref_pvs||5.024000| -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_unmagicext|5.013008||p -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_flags||5.017002| -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 -svtype||| -swallow_bom||| -swash_fetch||5.007002| -swash_init||5.006000| -swash_scan_list_line||| -swatch_get||| -sync_locale||5.021004| -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||| -tied_method|||v -tmps_grow_p||| -toFOLD_utf8||5.019001| -toFOLD_uvchr||5.023009| -toFOLD||5.019001| -toLOWER_L1||5.019001| -toLOWER_LC||5.004000| -toLOWER_utf8||5.015007| -toLOWER_uvchr||5.023009| -toLOWER||| -toTITLE_utf8||5.015007| -toTITLE_uvchr||5.023009| -toTITLE||5.019001| -toUPPER_utf8||5.015007| -toUPPER_uvchr||5.023009| -toUPPER||| -to_byte_substr||| -to_lower_latin1|||n -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.015007| -to_utf8_lower||5.015007| -to_utf8_substr||| -to_utf8_title||5.015007| -to_utf8_upper||5.015007| -tokenize_use||| -tokeq||| -tokereport||| -too_few_arguments_pv||| -too_many_arguments_pv||| -translate_substr_offsets|||n -try_amagic_bin||| -try_amagic_un||| -uiv_2buf|||n -unlnk||| -unpack_rec||| -unpack_str||5.007003| -unpackstring||5.008001| -unreferenced_to_tmp_stack||| -unshare_hek_or_pvn||| -unshare_hek||| -unsharepvn||5.003070| -unwind_handler_stack||| -update_debugger_info||| -upg_version||5.009005| -usage||| -utf16_textfilter||| -utf16_to_utf8_reversed||5.006001| -utf16_to_utf8||5.006001| -utf8_distance||5.006000| -utf8_hop||5.006000|n -utf8_length||5.007001| -utf8_mg_len_cache_update||| -utf8_mg_pos_cache_update||| -utf8_to_bytes||5.006001| -utf8_to_uvchr_buf||5.015009| -utf8_to_uvchr||5.007001| -utf8_to_uvuni_buf||5.015009| -utf8_to_uvuni||5.007001| -utf8n_to_uvchr||5.007001| -utf8n_to_uvuni||5.007001| -utilize||| -uvchr_to_utf8_flags||5.007003| -uvchr_to_utf8||5.007001| -uvoffuni_to_utf8_flags||5.019004| -uvuni_to_utf8_flags||5.007003| -uvuni_to_utf8||5.007001| -valid_utf8_to_uvchr||5.015009| -valid_utf8_to_uvuni||5.015009| -validate_proto||| -validate_suid||| -varname||| -vcmp||5.009000| -vcroak||5.006000| -vdeb||5.007003| -vform||5.006000| -visit||| -vivify_defelem||| -vivify_ref||| -vload_module|5.006000||p -vmess|5.006000||p -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|||pvn -warn_sv|5.013001||p -warner_nocontext|||vn -warner|5.006000|5.004000|pv -warn|||v -was_lvalue_sub||| -watch||| -whichsig_pvn||5.015004| -whichsig_pv||5.015004| -whichsig_sv||5.015004| -whichsig||| -win32_croak_not_implemented|||n -with_queued_errors||| -wrap_op_checker||5.015008| -write_to_stderr||| -xs_boot_epilog||| -xs_handshake|||vn -xs_version_bootcheck||| -yyerror_pvn||| -yyerror_pv||| -yyerror||| -yylex||| -yyparse||| -yyunlex||| -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 (<DATA>) { - 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 $/; <IN> }; - 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 = <<HEADER . $diff; ---- $file -+++ $file.patched -HEADER - } - - if (!defined $diff) { - $diff = run_diff('diff -u', $file, $str); - } - - if (!defined $diff) { - $diff = run_diff('diff', $file, $str); - } - - if (!defined $diff) { - error("Cannot generate a diff. Please install Text::Diff or use --copy."); - return; - } - - print F $diff; -} - -sub run_diff -{ - my($prog, $file, $str) = @_; - my $tmp = 'dppptemp'; - my $suf = 'aaa'; - my $diff = ''; - local *F; - - while (-e "$tmp.$suf") { $suf++ } - $tmp = "$tmp.$suf"; - - if (open F, ">$tmp") { - print F $str; - close F; - - if (open F, "$prog $file $tmp |") { - while (<F>) { - 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 <<ENDUSAGE; - -Usage: $usage - -See perldoc $0 for details. - -ENDUSAGE - - exit 2; -} - -sub strip -{ - my $self = do { local(@ARGV,$/)=($0); <> }; - 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 <<END; - -Sorry, but this is a stripped version of \$0. - -To be able to use its original script and doc functionality, -please try to regenerate this file using: - - \$^X \$0 --unstrip - -END -/ms; - my($pl, $c) = $self =~ /(.*^__DATA__)(.*)/ms; - $c =~ s{ - / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) - | ( "[^"\\]*(?:\\.[^"\\]*)*" - | '[^'\\]*(?:\\.[^'\\]*)*' ) - | ($HS+) }{ defined $2 ? ' ' : ($1 || '') }gsex; - $c =~ s!\s+$!!mg; - $c =~ s!^$LF!!mg; - $c =~ s!^\s*#\s*!#!mg; - $c =~ s!^\s+!!mg; - - open OUT, ">$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 <patchlevel.h> -# endif -# if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) -# include <could_not_find_Perl_patchlevel.h> -# endif -# ifndef PERL_REVISION -# define PERL_REVISION (5) - /* Replace: 1 */ -# define PERL_VERSION PATCHLEVEL -# define PERL_SUBVERSION SUBVERSION - /* Replace PERL_PATCHLEVEL with PERL_VERSION */ - /* Replace: 0 */ -# endif -#endif - -#define D_PPP_DEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10)) -#define PERL_BCDVERSION ((D_PPP_DEC2BCD(PERL_REVISION)<<24)|(D_PPP_DEC2BCD(PERL_VERSION)<<12)|D_PPP_DEC2BCD(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 <limits.h> -#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 <values.h> */ -# 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 <values.h> */ -# 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 LONGSIZE -# define LONGSIZE 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 LONGSIZE -# define LONGSIZE 4 -#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 memEQs -# define memEQs(s1, l, s2) \ - (sizeof(s2)-1 == l && memEQ(s1, (s2 ""), (sizeof(s2)-1))) -#endif - -#ifndef memNEs -# define memNEs(s1, l, s2) !memEQs(s1, l, s2) -#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 SvGETMAGIC -# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END -#endif - -/* Some random bits for sv_unmagicext. These should probably be pulled in for - real and organized at some point */ -#ifndef HEf_SVKEY -# define HEf_SVKEY -2 -#endif - -#ifndef MUTABLE_PTR -#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) -# define MUTABLE_PTR(p) ({ void *_p = (p); _p; }) -#else -# define MUTABLE_PTR(p) ((void *) (p)) -#endif -#endif -#ifndef MUTABLE_SV -# define MUTABLE_SV(p) ((SV *)MUTABLE_PTR(p)) -#endif - -/* end of random bits */ -#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 - -#if !defined(mg_findext) -#if defined(NEED_mg_findext) -static MAGIC * DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl); -static -#else -extern MAGIC * DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl); -#endif - -#if defined(NEED_mg_findext) || defined(NEED_mg_findext_GLOBAL) - -#define mg_findext DPPP_(my_mg_findext) -#define Perl_mg_findext DPPP_(my_mg_findext) - - -MAGIC * -DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl) { - if (sv) { - MAGIC *mg; - -#ifdef AvPAD_NAMELIST - assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv))); -#endif - - for (mg = SvMAGIC (sv); mg; mg = mg->mg_moremagic) { - if (mg->mg_type == type && mg->mg_virtual == vtbl) - return mg; - } - } - - return NULL; -} - -#endif -#endif - -#if !defined(sv_unmagicext) -#if defined(NEED_sv_unmagicext) -static int DPPP_(my_sv_unmagicext)(pTHX_ SV * const sv, const int type, MGVTBL * vtbl); -static -#else -extern int DPPP_(my_sv_unmagicext)(pTHX_ SV * const sv, const int type, MGVTBL * vtbl); -#endif - -#if defined(NEED_sv_unmagicext) || defined(NEED_sv_unmagicext_GLOBAL) - -#ifdef sv_unmagicext -# undef sv_unmagicext -#endif -#define sv_unmagicext(a,b,c) DPPP_(my_sv_unmagicext)(aTHX_ a,b,c) -#define Perl_sv_unmagicext DPPP_(my_sv_unmagicext) - - -int -DPPP_(my_sv_unmagicext)(pTHX_ SV *const sv, const int type, MGVTBL *vtbl) -{ - MAGIC* mg; - MAGIC** mgp; - - if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv)) - return 0; - mgp = &(SvMAGIC(sv)); - for (mg = *mgp; mg; mg = *mgp) { - const MGVTBL* const virt = mg->mg_virtual; - if (mg->mg_type == type && virt == vtbl) { - *mgp = mg->mg_moremagic; - if (virt && virt->svt_free) - virt->svt_free(aTHX_ sv, mg); - if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { - if (mg->mg_len > 0) - Safefree(mg->mg_ptr); - else if (mg->mg_len == HEf_SVKEY) /* Questionable on older perls... */ - SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr)); - else if (mg->mg_type == PERL_MAGIC_utf8) - Safefree(mg->mg_ptr); - } - if (mg->mg_flags & MGf_REFCOUNTED) - SvREFCNT_dec(mg->mg_obj); - Safefree(mg); - } - else - mgp = &mg->mg_moremagic; - } - if (SvMAGIC(sv)) { - if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */ - mg_magical(sv); /* else fix the flags now */ - } - else { - SvMAGICAL_off(sv); - SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; - } - return 0; -} - -#endif -#endif -#ifndef cBOOL -# define cBOOL(cbool) ((cbool) ? (bool)1 : (bool)0) -#endif - -#ifndef OpHAS_SIBLING -# define OpHAS_SIBLING(o) (cBOOL((o)->op_sibling)) -#endif - -#ifndef OpSIBLING -# define OpSIBLING(o) (0 + (o)->op_sibling) -#endif - -#ifndef OpMORESIB_set -# define OpMORESIB_set(o, sib) ((o)->op_sibling = (sib)) -#endif - -#ifndef OpLASTSIB_set -# define OpLASTSIB_set(o, parent) ((o)->op_sibling = NULL) -#endif - -#ifndef OpMAYBESIB_set -# define OpMAYBESIB_set(o, sib, parent) ((o)->op_sibling = (sib)) -#endif - -#ifndef SvRX -#if defined(NEED_SvRX) -static void * DPPP_(my_SvRX)(pTHX_ SV *rv); -static -#else -extern void * DPPP_(my_SvRX)(pTHX_ SV *rv); -#endif - -#if defined(NEED_SvRX) || defined(NEED_SvRX_GLOBAL) - -#ifdef SvRX -# undef SvRX -#endif -#define SvRX(a) DPPP_(my_SvRX)(aTHX_ a) - - -void * -DPPP_(my_SvRX)(pTHX_ SV *rv) -{ - if (SvROK(rv)) { - SV *sv = SvRV(rv); - if (SvMAGICAL(sv)) { - MAGIC *mg = mg_find(sv, PERL_MAGIC_qr); - if (mg && mg->mg_obj) { - return mg->mg_obj; - } - } - } - return 0; -} -#endif -#endif -#ifndef SvRXOK -# define SvRXOK(sv) (!!SvRX(sv)) -#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 <note.h> -# 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 PERL_UNUSED_RESULT -# if defined(__GNUC__) && defined(HASATTRIBUTE_WARN_UNUSED_RESULT) -# define PERL_UNUSED_RESULT(v) STMT_START { __typeof__(v) z = (v); (void)sizeof(z); } STMT_END -# else -# define PERL_UNUSED_RESULT(v) ((void)(v)) -# 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 WIDEST_UTYPE -# ifdef QUADKIND -# ifdef U64TYPE -# define WIDEST_UTYPE U64TYPE -# else -# define WIDEST_UTYPE Quad_t -# endif -# else -# define WIDEST_UTYPE U32 -# endif -#endif -#ifndef isALNUMC -# define isALNUMC(c) (isALPHA(c) || isDIGIT(c)) -#endif - -#ifndef isASCII -# define isASCII(c) ((WIDEST_UTYPE) (c) <= 127) -#endif - -#ifndef isCNTRL -# define isCNTRL(c) ((WIDEST_UTYPE) (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 - -/* Until we figure out how to support this in older perls... */ -#if (PERL_BCDVERSION >= 0x5008000) -#ifndef HeUTF8 -# define HeUTF8(he) ((HeKLEN(he) == HEf_SVKEY) ? \ - SvUTF8(HeKEY_sv(he)) : \ - (U32)HeKUTF8(he)) -#endif - -#endif -#ifndef C_ARRAY_LENGTH -# define C_ARRAY_LENGTH(a) (sizeof(a)/sizeof((a)[0])) -#endif - -#ifndef C_ARRAY_END -# define C_ARRAY_END(a) ((a) + C_ARRAY_LENGTH(a)) -#endif - -#ifndef IVdf -# if IVSIZE == LONGSIZE -# define IVdf "ld" -# define UVuf "lu" -# define UVof "lo" -# define UVxf "lx" -# define UVXf "lX" -# elif IVSIZE == INTSIZE -# define IVdf "d" -# define UVuf "u" -# define UVof "o" -# define UVxf "x" -# define UVXf "X" -# else -# error "cannot define IV/UV formats" -# 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 - -#ifdef NEED_mess_sv -#define NEED_mess -#endif - -#ifdef NEED_mess -#define NEED_mess_nocontext -#define NEED_vmess -#endif - -#ifndef croak_sv -#if (PERL_BCDVERSION >= 0x5007003) || ( (PERL_BCDVERSION >= 0x5006001) && (PERL_BCDVERSION < 0x5007000) ) -# if ( (PERL_BCDVERSION >= 0x5008000) && (PERL_BCDVERSION < 0x5008009) ) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5010001) ) -# define D_PPP_FIX_UTF8_ERRSV(errsv, sv) \ - STMT_START { \ - if (sv != ERRSV) \ - SvFLAGS(ERRSV) = (SvFLAGS(ERRSV) & ~SVf_UTF8) | \ - (SvFLAGS(sv) & SVf_UTF8); \ - } STMT_END -# else -# define D_PPP_FIX_UTF8_ERRSV(errsv, sv) STMT_START {} STMT_END -# endif -# define croak_sv(sv) \ - STMT_START { \ - if (SvROK(sv)) { \ - sv_setsv(ERRSV, sv); \ - croak(NULL); \ - } else { \ - D_PPP_FIX_UTF8_ERRSV(ERRSV, sv); \ - croak("%" SVf, SVfARG(sv)); \ - } \ - } STMT_END -#elif (PERL_BCDVERSION >= 0x5004000) -# define croak_sv(sv) croak("%" SVf, SVfARG(sv)) -#else -# define croak_sv(sv) croak("%s", SvPV_nolen(sv)) -#endif -#endif - -#ifndef die_sv -#if defined(NEED_die_sv) -static OP * DPPP_(my_die_sv)(pTHX_ SV *sv); -static -#else -extern OP * DPPP_(my_die_sv)(pTHX_ SV *sv); -#endif - -#if defined(NEED_die_sv) || defined(NEED_die_sv_GLOBAL) - -#ifdef die_sv -# undef die_sv -#endif -#define die_sv(a) DPPP_(my_die_sv)(aTHX_ a) -#define Perl_die_sv DPPP_(my_die_sv) - -OP * -DPPP_(my_die_sv)(pTHX_ SV *sv) -{ - croak_sv(sv); - return (OP *)NULL; -} -#endif -#endif - -#ifndef warn_sv -#if (PERL_BCDVERSION >= 0x5004000) -# define warn_sv(sv) warn("%" SVf, SVfARG(sv)) -#else -# define warn_sv(sv) warn("%s", SvPV_nolen(sv)) -#endif -#endif - -#ifndef vmess -#if defined(NEED_vmess) -static SV * DPPP_(my_vmess)(pTHX_ const char * pat, va_list * args); -static -#else -extern SV * DPPP_(my_vmess)(pTHX_ const char * pat, va_list * args); -#endif - -#if defined(NEED_vmess) || defined(NEED_vmess_GLOBAL) - -#ifdef vmess -# undef vmess -#endif -#define vmess(a,b) DPPP_(my_vmess)(aTHX_ a,b) -#define Perl_vmess DPPP_(my_vmess) - -SV* -DPPP_(my_vmess)(pTHX_ const char* pat, va_list* args) -{ - mess(pat, args); - return PL_mess_sv; -} -#endif -#endif - -#if (PERL_BCDVERSION < 0x5006000) -#undef mess -#endif - -#if !defined(mess_nocontext) && !defined(Perl_mess_nocontext) -#if defined(NEED_mess_nocontext) -static SV * DPPP_(my_mess_nocontext)(const char * pat, ...); -static -#else -extern SV * DPPP_(my_mess_nocontext)(const char * pat, ...); -#endif - -#if defined(NEED_mess_nocontext) || defined(NEED_mess_nocontext_GLOBAL) - -#define mess_nocontext DPPP_(my_mess_nocontext) -#define Perl_mess_nocontext DPPP_(my_mess_nocontext) - -SV* -DPPP_(my_mess_nocontext)(const char* pat, ...) -{ - dTHX; - SV *sv; - va_list args; - va_start(args, pat); - sv = vmess(pat, &args); - va_end(args); - return sv; -} -#endif -#endif - -#ifndef mess -#if defined(NEED_mess) -static SV * DPPP_(my_mess)(pTHX_ const char * pat, ...); -static -#else -extern SV * DPPP_(my_mess)(pTHX_ const char * pat, ...); -#endif - -#if defined(NEED_mess) || defined(NEED_mess_GLOBAL) - -#define Perl_mess DPPP_(my_mess) - -SV* -DPPP_(my_mess)(pTHX_ const char* pat, ...) -{ - SV *sv; - va_list args; - va_start(args, pat); - sv = vmess(pat, &args); - va_end(args); - return sv; -} -#ifdef mess_nocontext -#define mess mess_nocontext -#else -#define mess Perl_mess_nocontext -#endif -#endif -#endif - -#ifndef mess_sv -#if defined(NEED_mess_sv) -static SV * DPPP_(my_mess_sv)(pTHX_ SV * basemsg, bool consume); -static -#else -extern SV * DPPP_(my_mess_sv)(pTHX_ SV * basemsg, bool consume); -#endif - -#if defined(NEED_mess_sv) || defined(NEED_mess_sv_GLOBAL) - -#ifdef mess_sv -# undef mess_sv -#endif -#define mess_sv(a,b) DPPP_(my_mess_sv)(aTHX_ a,b) -#define Perl_mess_sv DPPP_(my_mess_sv) - -SV * -DPPP_(my_mess_sv)(pTHX_ SV *basemsg, bool consume) -{ - SV *tmp; - SV *ret; - - if (SvPOK(basemsg) && SvCUR(basemsg) && *(SvEND(basemsg)-1) == '\n') { - if (consume) - return basemsg; - ret = mess(""); - SvSetSV_nosteal(ret, basemsg); - return ret; - } - - if (consume) { - sv_catsv(basemsg, mess("")); - return basemsg; - } - - ret = mess(""); - tmp = newSVsv(ret); - SvSetSV_nosteal(ret, basemsg); - sv_catsv(ret, tmp); - sv_dec(tmp); - return ret; -} -#endif -#endif - -#ifndef warn_nocontext -#define warn_nocontext warn -#endif - -#ifndef croak_nocontext -#define croak_nocontext croak -#endif - -#ifndef croak_no_modify -#define croak_no_modify() croak_nocontext("%s", PL_no_modify) -#define Perl_croak_no_modify() croak_no_modify() -#endif - -#ifndef croak_memory_wrap -#if (PERL_BCDVERSION >= 0x5009002) || ( (PERL_BCDVERSION >= 0x5008006) && (PERL_BCDVERSION < 0x5009000) ) -# define croak_memory_wrap() croak_nocontext("%s", PL_memory_wrap) -#else -# define croak_memory_wrap() croak_nocontext("panic: memory wrap") -#endif -#endif - -#ifndef croak_xs_usage -#if defined(NEED_croak_xs_usage) -static void DPPP_(my_croak_xs_usage)(const CV * const cv, const char * const params); -static -#else -extern void DPPP_(my_croak_xs_usage)(const CV * const cv, const char * const params); -#endif - -#if defined(NEED_croak_xs_usage) || defined(NEED_croak_xs_usage_GLOBAL) - -#define croak_xs_usage DPPP_(my_croak_xs_usage) -#define Perl_croak_xs_usage DPPP_(my_croak_xs_usage) - - -#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE -#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params) -#endif - -void -DPPP_(my_croak_xs_usage)(const CV *const cv, const char *const params) -{ - dTHX; - const GV *const gv = CvGV(cv); - - PERL_ARGS_ASSERT_CROAK_XS_USAGE; - - if (gv) { - const char *const gvname = GvNAME(gv); - const HV *const stash = GvSTASH(gv); - const char *const hvname = stash ? HvNAME(stash) : NULL; - - if (hvname) - croak("Usage: %s::%s(%s)", hvname, gvname, params); - else - croak("Usage: %s(%s)", gvname, params); - } else { - /* Pants. I don't think that it should be possible to get here. */ - croak("Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params); - } -} -#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 - * doing. 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 - -#if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) - -#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) - - -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 && SvTRUEx(ERRSV)) - croak_sv(ERRSV); - - 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 - -#if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL) - -#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) - - -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); -#elif (PERL_BCDVERSION > 0x5003000) - utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), - 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 - -#if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL) - -#ifdef load_module -# undef load_module -#endif -#define load_module DPPP_(my_load_module) -#define Perl_load_module DPPP_(my_load_module) - - -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 - -#if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) - -#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) - -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 - -#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) - -#ifdef newCONSTSUB -# undef newCONSTSUB -#endif -#define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) -#define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) - - -/* 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 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 - -#if defined(NEED_newSV_type) || defined(NEED_newSV_type_GLOBAL) - -#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) - - -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 - -#if defined(NEED_newSVpvn_flags) || defined(NEED_newSVpvn_flags_GLOBAL) - -#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) - - -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 - -#if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) - -#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) - - -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 - -#if defined(NEED_sv_2pv_flags) || defined(NEED_sv_2pv_flags_GLOBAL) - -#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) - - -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 - -#if defined(NEED_sv_pvn_force_flags) || defined(NEED_sv_pvn_force_flags_GLOBAL) - -#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) - - -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 D_PPP_SVPV_NOLEN_LP_ARG &PL_na -#else -# define D_PPP_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, D_PPP_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, D_PPP_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, D_PPP_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, D_PPP_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_nomg_nolen -# define SvPV_nomg_nolen(sv) ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ - ? SvPVX(sv) : sv_2pv_flags(sv, D_PPP_SVPV_NOLEN_LP_ARG, 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 - -#if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) - -#ifdef vnewSVpvf -# undef vnewSVpvf -#endif -#define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) -#define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) - - -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 - -#if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) - -#define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) - - -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 - -#if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) - -#define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) -#define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) - - -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 - -#if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) - -#define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) - - -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 - -#if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) - -#define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) -#define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) - - -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 - -/* Hint: newSVpvn_share - * The SVs created by this function only mimic the behaviour of - * shared PVs without really being shared. Only use if you know - * what you're doing. - */ - -#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 - -#if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL) - -#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) - - -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 gv_fetchpvn_flags -#if defined(NEED_gv_fetchpvn_flags) -static GV* DPPP_(my_gv_fetchpvn_flags)(pTHX_ const char* name, STRLEN len, int flags, int types); -static -#else -extern GV* DPPP_(my_gv_fetchpvn_flags)(pTHX_ const char* name, STRLEN len, int flags, int types); -#endif - -#if defined(NEED_gv_fetchpvn_flags) || defined(NEED_gv_fetchpvn_flags_GLOBAL) - -#ifdef gv_fetchpvn_flags -# undef gv_fetchpvn_flags -#endif -#define gv_fetchpvn_flags(a,b,c,d) DPPP_(my_gv_fetchpvn_flags)(aTHX_ a,b,c,d) -#define Perl_gv_fetchpvn_flags DPPP_(my_gv_fetchpvn_flags) - - -GV* -DPPP_(my_gv_fetchpvn_flags)(pTHX_ const char* name, STRLEN len, int flags, int types) { - char *namepv = savepvn(name, len); - GV* stash = gv_fetchpv(namepv, TRUE, SVt_PVHV); - Safefree(namepv); - return stash; -} - -#endif -#endif -#ifndef GvSVn -# define GvSVn(gv) GvSV(gv) -#endif - -#ifndef isGV_with_GP -# define isGV_with_GP(gv) isGV(gv) -#endif - -#ifndef gv_fetchsv -# define gv_fetchsv(name, flags, svt) gv_fetchpv(SvPV_nolen_const(name), flags, svt) -#endif -#ifndef get_cvn_flags -# define get_cvn_flags(name, namelen, flags) get_cv(name, flags) -#endif - -#ifndef gv_init_pvn -# define gv_init_pvn(gv, stash, ptr, len, flags) gv_init(gv, stash, ptr, len, flags & GV_ADDMULTI ? TRUE : FALSE) -#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 - -#if defined(NEED_warner) || defined(NEED_warner_GLOBAL) - -#define Perl_warner DPPP_(my_warner) - - -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 newSVpvs_share -# define newSVpvs_share(str) newSVpvn_share(str "", sizeof(str) - 1, 0) -#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_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 get_cvs -# define get_cvs(name, flags) get_cvn_flags(name "", sizeof(name)-1, flags) -#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 */ - -#if (PERL_BCDVERSION >= 0x5006000) -#ifndef caller_cx - -# if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL) -static I32 -DPPP_dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) -{ - I32 i; - - for (i = startingblock; i >= 0; i--) { - register const PERL_CONTEXT * const cx = &cxstk[i]; - switch (CxTYPE(cx)) { - default: - continue; - case CXt_EVAL: - case CXt_SUB: - case CXt_FORMAT: - return i; - } - } - return i; -} -# endif - -# if defined(NEED_caller_cx) -static const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 count, const PERL_CONTEXT **dbcxp); -static -#else -extern const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 count, const PERL_CONTEXT **dbcxp); -#endif - -#if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL) - -#ifdef caller_cx -# undef caller_cx -#endif -#define caller_cx(a,b) DPPP_(my_caller_cx)(aTHX_ a,b) -#define Perl_caller_cx DPPP_(my_caller_cx) - - -const PERL_CONTEXT * -DPPP_(my_caller_cx)(pTHX_ I32 count, const PERL_CONTEXT **dbcxp) -{ - register I32 cxix = DPPP_dopoptosub_at(cxstack, cxstack_ix); - register const PERL_CONTEXT *cx; - register const PERL_CONTEXT *ccstack = cxstack; - const PERL_SI *top_si = PL_curstackinfo; - - for (;;) { - /* we may be in a higher stacklevel, so dig down deeper */ - while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { - top_si = top_si->si_prev; - ccstack = top_si->si_cxstack; - cxix = DPPP_dopoptosub_at(ccstack, top_si->si_cxix); - } - if (cxix < 0) - return NULL; - /* caller() should not report the automatic calls to &DB::sub */ - if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 && - ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) - count++; - if (!count--) - break; - cxix = DPPP_dopoptosub_at(ccstack, cxix - 1); - } - - cx = &ccstack[cxix]; - if (dbcxp) *dbcxp = cx; - - if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { - const I32 dbcxix = DPPP_dopoptosub_at(ccstack, cxix - 1); - /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the - field below is defined for any cx. */ - /* caller() should not report the automatic calls to &DB::sub */ - if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) - cx = &ccstack[dbcxix]; - } - - return cx; -} - -# endif -#endif /* caller_cx */ -#endif /* 5.6.0 */ -#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 - -#if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) - -#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) - -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 <locale.h> - 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 - -#if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) - -#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) - -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 - -#if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) - -#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) - -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 - -#if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) - -#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) - -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 - -#if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) - -#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) - -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 - -#if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL) - -#define my_snprintf DPPP_(my_my_snprintf) -#define Perl_my_snprintf DPPP_(my_my_snprintf) - - -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 - -#if defined(NEED_my_sprintf) || defined(NEED_my_sprintf_GLOBAL) - -#define my_sprintf DPPP_(my_my_sprintf) -#define Perl_my_sprintf DPPP_(my_my_sprintf) - - -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 - -#if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL) - -#define my_strlcat DPPP_(my_my_strlcat) -#define Perl_my_strlcat DPPP_(my_my_strlcat) - - -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 - -#if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL) - -#define my_strlcpy DPPP_(my_my_strlcpy) -#define Perl_my_strlcpy DPPP_(my_my_strlcpy) - - -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 - -#if defined(NEED_pv_escape) || defined(NEED_pv_escape_GLOBAL) - -#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) - - -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 - -#if defined(NEED_pv_pretty) || defined(NEED_pv_pretty_GLOBAL) - -#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) - - -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 - -#if defined(NEED_pv_display) || defined(NEED_pv_display_GLOBAL) - -#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) - - -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 */ diff --git a/script/mwrap-perl b/script/mwrap-perl deleted file mode 100644 index 82629b4..0000000 --- a/script/mwrap-perl +++ /dev/null @@ -1,97 +0,0 @@ -#!/usr/bin/perl -w -# Copyright (C) mwrap hackers <mwrap-perl@80x24.org> -# License: GPL-3.0+ <https://www.gnu.org/licenses/gpl-3.0.txt> -use v5.12; -use Devel::Mwrap; -my ($so) = grep(m!/Mwrap\.so\z!, @DynaLoader::dl_shared_objects); -defined($so) or die 'Mwrap.so not loaded'; -my $cur = $ENV{LD_PRELOAD}; -if (!@ARGV || ($ARGV[0] // '') =~ /\A(?:-h|--help)\z/) { - require Pod::Usage; - Pod::Usage::pod2usage(@ARGV ? 0 : 1); -} -if (defined $cur) { - my @cur = split(/[: \t]+/, $cur); - if (!grep(/\A\Q$so\E\z/, @cur)) { - # drop old redundant versions - my @keep = grep(!m!/Mwrap\.so$!, @cur); - $ENV{LD_PRELOAD} = join(':', $so, @keep); - } -} else { - $ENV{LD_PRELOAD} = $so; -} -exec @ARGV; -__END__ -=head1 NAME - -mwrap-perl - run any command under mwrap - -=head1 SYNOPSIS - - # to trace a long-running program and access it via $DIRECTORY/$PID.sock: - MWRAP=socket_dir:$DIRECTORY mwrap-perl COMMAND - - # to trace a short-lived command and dump its output to a log: - MWRAP=dump_path:$FILENAME mwrap-perl COMMAND - -=head1 DESCRIPTION - -mwrap-perl is a command-line to automatically add Mwrap.so as an -LD_PRELOAD for any command. It will resolve malloc-family calls -to a Perl file and line number, and it can also provide a backtrace -of native (C/C++) functions for non-Perl programs. - -=head1 ENVIRONMENT - -C<MWRAP> is the only environment variable read. It contains multiple -options delimited by C<,> with names and values delimited by C<:> - -=item socket_dir:$DIRECTORY - -This launches an embedded HTTP server in each process and binds it -to C<$DIRECTORY/$PID.sock>. C<curl --unix-socket $DIRECTORY/$PID.sock> -or L<mwrap-rproxy(1p)> may be used to access various endpoints in -the HTTP server. - -=item: bt:$DEPTH - -The backtrace depth for L<backtrace(3)> in addition to the Perl -file and line number where C<$DEPTH> is a non-negative number. - -The maximum allowed value is 32, though values of 5 or less are -typically useful. Increasing this to even 2 or 3 can significantly -increase the amount of memory mwrap (and liburcu) itself uses. - -This is only useful in conjunction with C<socket_dir> - -Default: 0 - -=item dump_path:$FILENAME - -Dumps the output - - total_bytes call_count location - -In the future, dumping to a self-describing CSV will be supported - -=back - -=head1 CONTACT - -Feedback welcome via plain-text mail to L<mailto:mwrap-perl@80x24.org> - -Mail archives are hosted at L<https://80x24.org/mwrap-perl/> - -=head1 COPYRIGHT - -Copyright all contributors L<mailto:mwrap-perl@80x24.org> - -License: GPL-3.0+ L<https://www.gnu.org/licenses/gpl-3.0.txt> - -Source code is at L<https://80x24.org/mwrap-perl.git/> - -=head1 SEE ALSO - -L<mwrap-rproxy(1)>, L<Devel::Mwrap(3pm)> - -=cut diff --git a/script/mwrap-rproxy b/script/mwrap-rproxy deleted file mode 100644 index 2498bc3..0000000 --- a/script/mwrap-rproxy +++ /dev/null @@ -1,115 +0,0 @@ -#!perl -w -# Copyright (C) mwrap hackers <mwrap-perl@80x24.org> -# License: GPL-3.0+ <https://www.gnu.org/licenses/gpl-3.0.txt> -# thin wrapper for Devel::Mwrap::Rproxy -use v5.12; # strict -eval { require Plack::Runner } or die "Plack not installed: $@\n"; -use Getopt::Long qw(:config no_ignore_case no_auto_abbrev pass_through); -my $usage = "$0 --socket-dir=/path/to/socket-dir [PLACKUP_OPTIONS]\n"; -my %opt = (deflate => 1); -GetOptions(\%opt, 'socket-dir=s', 'deflate!', 'help|h') or do { - require Pod::Usage; Pod::Usage::pod2usage(1); -}; -if ($opt{help}) { require Pod::Usage; Pod::Usage::pod2usage(0) } -my $socket_dir = delete $opt{'socket-dir'}; -$socket_dir //= ($ENV{MWRAP} // '') =~ m!\bsocket_dir:([^,]+)! ? $1 : undef; -$socket_dir // die $usage; -require Devel::Mwrap::Rproxy; -my $rproxy = Devel::Mwrap::Rproxy->new($socket_dir); -my $app = sub { $rproxy->call(@_) }; -my $runner = Plack::Runner->new; -$runner->parse_options(@ARGV); -if (($ENV{LISTEN_PID} // 0) == $$) { - my $fds = $ENV{LISTEN_FDS} // ''; - die "only one LISTEN_FDS=1 supported (got `$fds')\n" if $fds ne '1'; - if (open(my $s, '<&=', 3)) { - my $prev_was_blocking = $s->blocking(1); - warn <<"" unless $prev_was_blocking; -Inherited socket (fd=3) is non-blocking, making it blocking. - - bless $s, 'IO::Socket::INET'; - $runner->set_options(listen_sock => $s); - } -} -if ($opt{deflate} && eval { require Plack::Middleware::Deflater } and !$@) { - $app = Plack::Middleware::Deflater->wrap($app); -} - -# ensure mwrap_dtor() runs if running under mwrap-perl, ourselves -sub sigexit { exit 0 } -$SIG{$_} = \&sigexit for (qw(INT TERM)); - -$runner->run($app); -__END__ -=head1 NAME - -mwrap-rproxy - reverse proxy for embedded per-process mwrap httpd - -=head1 SYNOPSIS - - # start the long-running COMMAND you wish to trace: - MWRAP=socket_dir:$DIRECTORY mwrap-perl COMMAND - - # in a different terminal, point mwrap-proxy to the mwrap-perl socket_dir - mwrap-rproxy --socket-dir=$DIRECTORY -l 127.0.0.1:8080 - - # open http://127.0.0.1:8080/ in your favorite web browser: - w3m http://127.0.0.1:8080/ - -=head1 DESCRIPTION - -B<mwrap-rproxy> is a PSGI reverse proxy to provide access -via TCP to the native, Unix-socket-only httpd embedded inside -mwrap core. It provides a listing of process IDs of each process -traced via mwrap. - -B<mwrap-rproxy> does not have a hard dependency on mwrap-perl itself, -it exists to provide a convenient interface to programs being -traced by mwrap-perl. - -=head1 OPTIONS - -=over 4 - -=item --socket-dir=DIRECTORY - -If unset, it will attempt to parse C<socket_dir:> from the C<MWRAP> -environment (see L<mwrap-perl(1p)>). - -=item --no-deflate - -L<Plack::Middleware::Deflater(3pm)> is loaded by default if available. -Using C<--no-deflate> will save CPU cycles at the expense of bandwidth. - -=back - -Additionally, all options in L<plackup(1p)> are supported. Notably, -C<-l>/C<--listen> and C<--path=/prefix> may be useful. - -=head1 ENVIRONMENT - -mwrap-rproxy supports systemd (and compatible) socket activation via -C<LISTEN_PID> and C<LISTEN_FDS> variables. See L<systemd.socket(5)> -and L<sd_listen_fds(3)>. - -C<PLACK_ENV> is also supported as described by L<plackup(1p)> - -=head1 CONTACT - -Feedback welcome via plain-text mail to L<mailto:mwrap-perl@80x24.org> - -Mail archives are hosted at L<https://80x24.org/mwrap-perl/> - -=head1 COPYRIGHT - -Copyright all contributors L<mailto:mwrap-perl@80x24.org> - -License: GPL-3.0+ L<https://www.gnu.org/licenses/gpl-3.0.txt> - -Source code is at L<https://80x24.org/mwrap-perl.git/> - -=head1 SEE ALSO - -L<mwrap-perl(1p)> - -=cut diff --git a/t/httpd-unit.t b/t/httpd-unit.t deleted file mode 100644 index e16be1d..0000000 --- a/t/httpd-unit.t +++ /dev/null @@ -1,116 +0,0 @@ -#!perl -w -# Copyright (C) mwrap hackers <mwrap-perl@80x24.org> -# License: GPL-3.0+ <https://www.gnu.org/licenses/gpl-3.0.txt> -use v5.12; -use autodie; -use Test::More; -use ExtUtils::CBuilder; -use File::Spec; -use File::Temp; -use File::Path; -my ($n) = (__FILE__ =~ m!/([^/]+)\.t\z!); -open my $fh, '<', 'build.env'; -my %build_env = map { chomp; ( split(/=/, $_, 2) ) } (<$fh>); -my $tmp = File::Temp->newdir("$n-XXXX"); -my $err = "$tmp/err.log"; -open my $olderr, '+>&', *STDERR{IO}; -my $end_err = sub { - STDERR->autoflush(1); - open STDERR, '+>&', $olderr; - open my $eh, '+<', $err; - local $/; - my $buf = <$eh> // BAIL_OUT "$!"; - truncate($eh, 0); - diag "err=$buf" if $ENV{V}; - $buf; -}; - -my @vg = split(/ /, $ENV{VALGRIND} // ''); - -# using predictable pathnames but outside of working directory. -# This gives ccache-friendliness while staying clear of MakeMaker -# aggressively trying to include every *.c file -my $d = File::Spec->tmpdir . "/$>.mwrap-test"; -if (!-d $d) { - diag "# mkdir $d"; - mkdir($d, 0700); -} -my $f = "$d/$n.c"; -open $fh, '>', $f; -print $fh <<C; -#include <sys/types.h> -#include <unistd.h> -#define getpid() my_getpid() -static pid_t my_getpid(void) -{ - return TEST_PID; -} -#include "mwrap_core.h" - -int main(int argc, const char *argv[]) -{ - struct mw_h1d h1d; - return h1d_init(&h1d, argv[1]); -} -C -close $fh; -my $TEST_PID = 10; -my $cb = ExtUtils::CBuilder->new(quiet => $ENV{V} ? 0 : 1); -my ($obj, $exe); -{ - my %be = %build_env; - $be{extra_compiler_flags} .= " -DTEST_PID=$TEST_PID -Wall "; - $obj = $cb->compile(source => $f, %be); - $exe = $cb->link_executable(exe_file => "$d/$n", objects => $obj, %be); -} -open STDERR, '>', $err; -is(system(@vg, $exe, "socket_dir:$d"), 0, "$exe"); -is($end_err->(), '', 'silence is golden'); - -my $s = "$d/$TEST_PID.sock"; -ok(-S $s, 'sock created'); -unlink($s); - -mkdir($s); -open STDERR, '>', $err; -isnt(system(@vg, $exe, "socket_dir:$d"), 0, "won't clobber dir"); -like($end_err->(), qr/unlink/, 'unlink fails for dir'); -rmdir($s); - -open STDERR, '>', $err; -is(system(@vg, $exe, "socket_dir:$d/"), 0, "listen again"); -is($end_err->(), '', 'silence is golden'); - -{ - my $t_mkdir = "$d/mkdir"; - File::Path::rmtree($t_mkdir) if -d $t_mkdir; - open STDERR, '>', $err; - is(system(@vg, $exe, "socket_dir:$t_mkdir"), 0, "listen in new dir"); - is($end_err->(), '', 'listened quietly on extra dir'); - File::Path::rmtree($t_mkdir); -} - -ok(-S $s, 'socket untouched'); -open STDERR, '>', $err; -isnt(system(@vg, $exe, "socket_dir:$s"), 0, "listen dir on socket fails"); -like($end_err->(), qr/stat.*directory/, 'stat failure shown'); - -# check for fencepost errors -my $len; -if ($^O eq 'linux') { $len = 108 } -elsif ($^O eq 'freebsd') { $len = 104 } -SKIP: { - skip "length unknown on $^O OS", 2 if !defined($len); - $len -= length("$tmp"); - $len -= length("\0//$TEST_PID.sock"); - my $max = "$tmp/".('x'x$len); - open STDERR, '>', $err; - is(system(@vg, $exe, "socket_dir:$max"), 0, "listen dir on max"); - is($end_err->(), '', 'nothing in stderr on max'); - - open STDERR, '>', $err; - isnt(system(@vg, $exe, "socket_dir:$max+"), 0, "listen dir too long"); - isnt($end_err->(), '', 'stderr contains error when too long'); -} - -done_testing; @@ -11,8 +11,10 @@ my $f1 = "$mwrap_tmp/f1"; my $f2 = "$mwrap_tmp/f2"; mkfifo($f1, 0600) // plan(skip_all => "mkfifo: $!"); mkfifo($f2, 0600) // plan(skip_all => "mkfifo: $!"); -my $pid = mwrap_run('httpd test', $env, '-e', - "open my \$f1, '>', '$f1'; close \$f1; open my \$f2, '<', '$f2'"); +my $src = $mwrap_src ? # $mwrap_src is Perl-only, Ruby otherwise + "open my \$f1, '>', '$f1'; close \$f1; open my \$f2, '<', '$f2'" : + "File.open('$f1', 'w').close; File.open('$f2', 'r').close"; +my $pid = mwrap_run('httpd test', $env, '-e', $src); my $spid; my $mw_exit; my $cleanup = sub { @@ -85,9 +87,21 @@ SKIP: { } SKIP: { + my (@rproxy, @missing); + if (-e 'script/mwrap-rproxy') { # Perl version + @rproxy = ($^X, '-w', './blib/script/mwrap-rproxy'); + } else { + my $exe = `which mwrap-rproxy`; + if ($? == 0 && defined($exe)) { + chomp($rproxy[0] = $exe); + } else { + push @missing, 'mwrap-rproxy'; + } + } for my $m (qw(Plack::Util HTTP::Tiny)) { - eval "require $m" or skip "$m missing", 1; + eval "require $m" or push(@missing, $m); } + skip join(', ', @missing).' missing', 1 if @missing; my $srv = IO::Socket::INET->new(LocalAddr => '127.0.0.1', ReuseAddr => 1, Proto => 'tcp', Type => SOCK_STREAM, @@ -103,8 +117,7 @@ SKIP: { } local $ENV{PLACK_ENV} = 'deployment' if !$ENV{V}; no warnings 'exec'; - exec $^X, '-w', './blib/script/mwrap-rproxy', - "--socket-dir=$mwrap_tmp"; + exec @rproxy, "--socket-dir=$mwrap_tmp"; _exit(1); } my $http = HTTP::Tiny->new; @@ -135,19 +148,28 @@ SKIP: { SKIP: { skip 'no reset w/o curl --unix-socket', 1 if !$curl_unix; - + my ($sqlite_v) = (`sqlite3 --version` =~ /([\d+\.]+)/); + if ($?) { + diag 'sqlite3 missing or broken'; + $sqlite_v = 0; + } else { + my @v = split(/\./, $sqlite_v); + $sqlite_v = ($v[0] << 16) | ($v[1] << 8) | $v[2]; + diag 'sqlite_v='.sprintf('0x%x', $sqlite_v); + } $rc = system(@curl, "http://0/$pid/each/100.csv"); is($rc, 0, '.csv retrieved') or skip 'CSV failed', 1; my $db = "$mwrap_tmp/t.sqlite3"; - $rc = system(qw(sqlite3), $db, ".import --csv $cout mwrap_each"); - if ($rc == -1) { - diag 'sqlite3 missing'; - } else { + + if ($sqlite_v >= 0x32000) { + $rc = system(qw(sqlite3), $db,".import --csv $cout mwrap_each"); is($rc, 0, 'sqlite3 import'); my $n = `sqlite3 $db 'SELECT COUNT(*) FROM mwrap_each'`; is($?, 0, 'sqlite3 count'); my $exp = split(/\n/, slurp($cout)); is($n + 1, $exp, 'imported all rows into sqlite'); + } else { + diag "sqlite 3.32.0+ needed for `.import --csv'"; } $rc = system(@curl, qw(-d x=y), "http://0/$pid/reset"); diff --git a/t/mwrap.t b/t/mwrap.t deleted file mode 100644 index 6f99715..0000000 --- a/t/mwrap.t +++ /dev/null @@ -1,177 +0,0 @@ -#!perl -w -# Copyright (C) mwrap hackers <mwrap-perl@80x24.org> -# License: GPL-3.0+ <https://www.gnu.org/licenses/gpl-3.0.txt> -use v5.12; -BEGIN { require './t/test_common.perl' }; -use_ok 'Devel::Mwrap'; -my $dump = "$mwrap_tmp/dump"; - -{ - my $env = { MWRAP => "dump_path:$dump,dump_min:10000" }; - my $nr = 1000; - mwrap_run('dump test', $env, '-e', '$x = "hello world" x '.$nr); - ok(-s $dump, "dump file written to"); - my $s = slurp($dump); - truncate($dump, 0); - my $re = qr/([0-9]+)[ \t]+([0-9]+)[ \t]+-e:1[ \t]*\n/sm; - my ($bytes, $n); - if ($s =~ $re) { - ($bytes, $n) = ($1, $2); - ok($bytes >= (length('hello world') * $nr), - "counted 'hello world' x $nr"); - ok($n >= 1, 'allocation counted'); - } else { - fail("$s failed to match $re"); - } -} - -SKIP: { # C++ program which uses malloc via "new" - my $exp = `cmake -h`; - skip 'cmake missing', 2 if $?; - skip "`cmake -h' gave no output", 2 unless $exp =~ /\S/s; - mwrap_run('cmake (C++ new)', {}, '-e', 'system(qw(cmake -h)); exit $?'); - my $res = slurp($mwrap_out); - is($res, $exp, "`cmake -h' works"); - diag slurp($mwrap_err); -}; - -{ - mwrap_run('total_bytes*', {}, '-e', <<'E1'); -my $A = Devel::Mwrap::total_bytes_allocated(); -my $f = Devel::Mwrap::total_bytes_freed(); -print("$A - $f\n"); -E1 - my $o = slurp($mwrap_out); - like($o, qr/^([0-9]+) - ([0-9]+)\n/s, 'got allocated & freed bytes'); -} - -{ - mwrap_run('source location', {}, 't/source_location.perl'); - mwrap_run('source location via -d:', {}, - '-d:Mwrap', 't/source_location.perl'); -} - -mwrap_run('Devel::Mwrap::each', {}, '-e', <<'EOF'); -open my $zero, '<', '/dev/zero' or die "open /dev/zero: $!"; -my $nbytes = 1024 * 512; -sysread($zero, my $before, $nbytes); -my (@keep, @uargs); -my $uarg = 'user-arg'; -eval { - Devel::Mwrap::each(0, sub { - my $ua = shift; - push @uargs, $ua; - die "died in each"; - push @keep, @_; - }, $uarg) }; -"$@" =~ /died in each at -e line \d+/ or die "did not propagate die in each"; -scalar(@keep) == 0 or die "nothing if died in sub"; -$uarg eq join('-', @uargs) or die "uarg passed to sub"; -my %h; -my $iter; -my $arg = "FOO"; -Devel::Mwrap::each(1, sub { - my ($argh, $src_loc, @more) = @_; - my $name = $src_loc->name; - $h{$name} = $src_loc; - sysread($zero, my $iter, $nbytes); - die 'extra args from ::each' if @more; - die "arg mismatch $arg / $argh" if $argh ne $arg; -}, $arg); -my $src_loc = $h{"-e:3"} or die "missing src_loc for -e:3"; -$src_loc->total >= $nbytes or die "allocated <= $nbytes"; -$src_loc = Devel::Mwrap::get("-e:8"); -if ($src_loc && $src_loc->total >= $nbytes) { - die "large allocation inside :each should not be tracked"; -} -my $nr = 0; -Devel::Mwrap::each($nbytes, sub { - $foo += shift; - push @keep, @_; -}, 1); -scalar(@keep) == 1 or die "got multiple matches for > $nbytes"; -$keep[0]->name eq '-e:3' or die "unexpected location for > $nbytes"; -@keep = (); -Devel::Mwrap::reset(); -Devel::Mwrap::each($nbytes, sub { push @keep, @_ }); -scalar(@keep) == 0 or die "::reset did not work"; -EOF - -mwrap_run('Devel::Mwrap::SrcLoc::each', {}, '-e', <<'EOF'); -open my $zero, '<', '/dev/zero' or die "open /dev/zero: $!"; -my @keep; -my $nr = 10; -my $nbytes = 1024 * 10; -sub do_read () { - sysread($zero, my $buf, $nbytes); - # this forces us to allocate a new buf with every call - pop @keep; - push @keep, $buf; -} -for (1..$nr) { do_read() } -my $loc = Devel::Mwrap::get('-e:6'); -$loc && $loc->total >= ($nbytes * $nr) or die "wrong line or bad stats"; -my $ml = $loc->mean_lifespan; -$ml >= 0.0 or die "mean_lifespan broken"; -my @sl_each; -$loc->each($nbytes, sub { shift; push @sl_each, \@_ }); -my $n = scalar(@sl_each); -$n == 1 or die "SrcLoc::each returned unexpected: $n"; -$sl_each[0]->[0] >= $nbytes or die "$sl_each[0]->[0] < $nbytes"; - -my $age_before = $sl_each[0]->[1]; -$nbytes = 1024 * 1024 * 8; -do_read() until Devel::Mwrap::current_age() > ($age_before + $nbytes); -@sl_each = (); -$loc->each($nbytes, sub { shift; push @sl_each, \@_ }); -$n = scalar(@sl_each); -$n == 1 or die "SrcLoc::each returned unexpected: $n"; -$sl_each[0]->[0] >= $nbytes or die "$sl_each[0]->[0] < $nbytes"; -my $age_after = $sl_each[0]->[1]; -$age_after >= $age_before or die "age did not increment"; -EOF -diag slurp($mwrap_out); - -is(Devel::Mwrap::quiet(1), 0, 'was not quiet, before'); -is(Devel::Mwrap::quiet(0), 1, 'was quiet, before'); - -SKIP: { - eval { require Inline::C } or skip 'Inline::C not available', 1; - $ENV{TEST_ALIASES} or skip 'TEST_ALIASES unset', 1; - my $c_src = <<'EOM'; -#include <stdlib.h> -void cfree(void *); /* lold glibc version */ -int test_aliases() -{ - size_t i; - void *p; - for (i = 0; i < 100; i++) { - if (i % 3 == 0) - p = aligned_alloc(64, i); - else - p = malloc(i); - if (i % 2 == 0) - cfree(p); - else - free(p); - } - return 3; -} -EOM - eval <<'EOM'; -use Inline C => $c_src, BUILD_NOISY => 1 -EOM - BAIL_OUT "cannot build $@" if $@; - is(test_aliases(), 3, - 'aligned_alloc + cfree function ran w/o crashing'); -}; - -is(Devel::Mwrap::bt_depth(), 0, 'default bt depth is zero'); -is(Devel::Mwrap::bt_depth(5), 5, 'set depth to reasonable level'); -is(Devel::Mwrap::bt_depth(), 5, 'depth stays at 5'); -is(Devel::Mwrap::bt_depth(500), 32, 'depth clamped to 32 when 500 attempted'); -is(Devel::Mwrap::bt_depth(), 32, 'depth stayed clamped at 32'); -is(Devel::Mwrap::bt_depth(undef), 32, 'depth stayed clamped at 32'); -is(Devel::Mwrap::bt_depth(-1), 32, 'depth stayed clamped at 32'); - -done_testing; diff --git a/t/source_location.perl b/t/source_location.perl deleted file mode 100644 index ed81ed8..0000000 --- a/t/source_location.perl +++ /dev/null @@ -1,9 +0,0 @@ -use Devel::Mwrap; -my $foo = ('hello world' x 10000); -my $k = __FILE__ . ":2"; -my $loc = Devel::Mwrap::get($k) or die; -$loc->name eq $k or die; -$loc->total >= 10000 or die; -$loc->allocations >= 1 or die; -$loc->frees >= 0 or die; -exit 0; diff --git a/t/test_common.perl b/t/test_common.perl index 8827362..3a073cf 100644 --- a/t/test_common.perl +++ b/t/test_common.perl @@ -6,8 +6,9 @@ use v5.12; use parent qw(Exporter); use Test::More; use File::Temp 0.19 (); # 0.19 for ->newdir -our $mwrap_src = slurp('blib/script/mwrap-perl'); -our $mwrap_tmp = File::Temp->newdir('mwrap-perl-XXXX', TMPDIR => 1); +our $mwrap_src; +$mwrap_src = slurp('blib/script/mwrap-perl') if -e 'script/mwrap-perl'; +our $mwrap_tmp = File::Temp->newdir('mwrap-XXXX', TMPDIR => 1); our $mwrap_out = "$mwrap_tmp/out"; our $mwrap_err = "$mwrap_tmp/err"; our @EXPORT = qw(mwrap_run slurp $mwrap_err $mwrap_out $mwrap_src $mwrap_tmp); @@ -20,9 +21,6 @@ sub slurp { sub mwrap_run { my ($msg, $env, @args) = @_; - unless (grep(/\A-.+\bMwrap\b/, @args)) { - unshift @args, '-MDevel::Mwrap'; - } my $pid = fork; if ($pid == 0) { while (my ($k, $v) = each %$env) { @@ -30,8 +28,16 @@ sub mwrap_run { } open STDERR, '>', $mwrap_err or die "open: $!"; open STDOUT, '>', $mwrap_out or die "open: $!"; - @ARGV = ($^X, @args); - eval $mwrap_src; + if (defined $mwrap_src) { + unless (grep(/\A-.+\bMwrap\b/, @args)) { + unshift @args, '-MDevel::Mwrap'; + } + @ARGV = ($^X, @args); + eval $mwrap_src; + } else { + my $ruby = $ENV{RUBY} // 'ruby'; + exec $ruby, '-Ilib', 'bin/mwrap', $ruby, @args; + } die "fail: $! ($@)"; } if (defined(wantarray)) { diff --git a/test/test_mwrap.rb b/test/test_mwrap.rb new file mode 100644 index 0000000..29bbdd2 --- /dev/null +++ b/test/test_mwrap.rb @@ -0,0 +1,292 @@ +# frozen_string_literal: true +# Copyright (C) mwrap hackers <mwrap-public@80x24.org> +# License: GPL-2.0+ <https://www.gnu.org/licenses/gpl-2.0.txt> +require 'test/unit' +require 'mwrap' +require 'rbconfig' +require 'tempfile' + +class TestMwrap < Test::Unit::TestCase + RB = "#{RbConfig::CONFIG['bindir']}/#{RbConfig::CONFIG['RUBY_INSTALL_NAME']}" + + mwrap_so = $".grep(%r{/mwrap\.so\z})[0] + env = ENV.to_hash + cur = env['LD_PRELOAD'] + env['LD_PRELOAD'] = cur ? "#{mwrap_so}:#{cur}".freeze : mwrap_so + @@env = env.freeze + inc = File.dirname(mwrap_so) + @@cmd = %W(#{RB} -w --disable=gems -I#{inc} -rmwrap).freeze + + def test_mwrap_preload + cmd = @@cmd + %w( + -e ("helloworld"*1000).clear + -e Mwrap.dump + ) + Tempfile.create('junk') do |tmp| + tmp.sync = true + res = system(@@env, *cmd, err: tmp) + assert res, $?.inspect + tmp.rewind + lines = tmp.readlines + line_1 = lines.grep(/\s-e:1\b/)[0].strip + bytes = line_1.split(/\s+/)[0].to_i + assert_operator bytes, :>=, 10001 + end + end + + def test_dump_via_destructor + env = @@env.dup + env['MWRAP'] = 'dump_fd:5' + cmd = @@cmd + %w(-e ("0"*10000).clear) + Tempfile.create('junk') do |tmp| + tmp.sync = true + res = system(env, *cmd, { 5 => tmp }) + assert res, $?.inspect + tmp.rewind + assert_match(/\b1\d{4}\s+[1-9]\d*\s+-e:1$/, tmp.read) + + env['MWRAP'] = 'dump_fd:1,dump_min:10000' + tmp.rewind + tmp.truncate(0) + res = system(env, *cmd, { 1 => tmp }) + assert res, $?.inspect + tmp.rewind + assert_match(/\b1\d{4}\s+[1-9]\d*\s+-e:1$/, tmp.read) + + tmp.rewind + tmp.truncate(0) + env['MWRAP'] = "dump_path:#{tmp.path},dump_min:10000" + res = system(env, *cmd) + assert res, $?.inspect + assert_match(/\b1\d{4}\s+[1-9]\d*\s+-e:1$/, tmp.read) + end + end + + def test_cmake + begin + exp = `cmake -h` + rescue Errno::ENOENT + warn 'cmake missing' + return + end + assert_not_predicate exp.strip, :empty? + env = @@env.merge('MWRAP' => 'dump_fd:1') + out = IO.popen(env, %w(cmake -h), &:read) + assert out.start_with?(exp), 'original help exists' + assert_not_equal exp, out, 'includes dump output' + dump = out.delete_prefix(exp) + assert_match(/\b0x[a-f0-9]+\b/s, dump, 'dump output has addresses') + end + + def test_clear + cmd = @@cmd + %w( + -e ("0"*10000).clear + -e Mwrap.clear + -e ("0"*20000).clear + -e Mwrap.dump($stdout,9999) + ) + Tempfile.create('junk') do |tmp| + tmp.sync = true + res = system(@@env, *cmd, { 1 => tmp }) + assert res, $?.inspect + tmp.rewind + buf = tmp.read + assert_not_match(/\s+-e:1$/, buf) + assert_match(/\b2\d{4}\s+[0-9]\d*\s+-e:3$/, buf) + end + end + + # make sure we don't break commands spawned by an mwrap-ed Ruby process: + def test_non_ruby_exec + IO.pipe do |r, w| + th = Thread.new { r.read } + Tempfile.create('junk') do |tmp| + tmp.sync = true + env = @@env.merge('MWRAP' => "dump_path:#{tmp.path}") + cmd = %w(perl -e print("HELLO_WORLD")) + res = system(env, *cmd, out: w) + w.close + assert res, $?.inspect + assert_match(/0x[a-f0-9]+\b/, tmp.read) + end + assert_equal "HELLO_WORLD", th.value + end + end + + # some URCU flavors use USR1, ensure the one we choose does not + def test_sigusr1_works + cmd = @@cmd + %w( + -e STDOUT.sync=true + -e trap(:USR1){p("HELLO_WORLD")} + -e END{Mwrap.dump} + -e puts -e STDIN.read) + IO.pipe do |r, w| + IO.pipe do |r2, w2| + pid = spawn(@@env, *cmd, in: r2, out: w, err: '/dev/null') + r2.close + w.close + assert_equal "\n", r.gets + buf = +'' + 10.times { Process.kill(:USR1, pid) } + while IO.select([r], nil, nil, 0.1) + case tmp = r.read_nonblock(1000, exception: false) + when String + buf << tmp + end + end + w2.close + Process.wait(pid) + assert_predicate $?, :success?, $?.inspect + assert_equal(["\"HELLO_WORLD\"\n"], buf.split(/^/).uniq) + end + end + end + + def test_reset + assert_nil Mwrap.reset + end + + def test_each + cmd = @@cmd + %w( + -e ("0"*10000).clear + -e h={} + -e Mwrap.each(1000){|a,b,c|h[a]=[b,c]} + -e puts(Marshal.dump(h)) + ) + r = IO.popen(@@env, cmd, 'r') + h = Marshal.load(r.read) + assert_not_predicate h, :empty? + h.each_key { |k| assert_kind_of String, k } + h.each_value do |total,calls| + assert_operator total, :>, 0 + assert_operator calls, :>, 0 + assert_operator total, :>=, calls + end + end + + def test_aref_each + cmd = @@cmd + %w( + -e count=GC.count + -e GC.disable + -e keep=("0"*10000) + -e loc=Mwrap["-e:3"] + -e + ) + [ 'loc.each{|size,gen|p([size,gen,count]) if size > 10000}' ] + buf = IO.popen(@@env, cmd, &:read) + assert_predicate $?, :success? + assert_match(/\A\[\s*\d+,\s*\d+,\s*\d+\]\s*\z/s, buf) + size, gen, count = eval(buf) + assert_operator size, :>=, 10000 + assert_operator gen, :>=, count + + cmd = @@cmd + %w( + -e count=GC.count + -e locs="" + -e Mwrap.each(1){|loc,tot,calls|locs<<loc} + -e m=locs.match(/(\[0x[a-f0-9]+\])/i) + -e m||=locs.match(/\b(0x[a-f0-9]+)\b/i) + -e p(loc=Mwrap["bobloblaw\t#{m[1]}"]) + -e loc.each{|size,gen|p([size,gen,count])} + ) + buf = IO.popen(@@env, cmd, &:read) + assert_predicate $?, :success? + assert_match(/\bMwrap::SourceLocation\b/, buf) + end + + def test_benchmark + cmd = @@cmd + %w(-rbenchmark + -e puts(Benchmark.measure{1000000.times{Time.now}})) + r = IO.popen(@@env, cmd, 'r') + require 'benchmark' + warn Benchmark::Tms::CAPTION + warn r.read + end if ENV['BENCHMARK'] + + def test_mwrap_dump_check + assert_raise(TypeError) { Mwrap.dump(:bogus) } + end + + def assert_separately(src, *opts) + Tempfile.create(%w(mwrap .rb)) do |tmp| + tmp.write(src.lstrip!) + tmp.flush + assert(system(@@env, *@@cmd, tmp.path, *opts)) + end + end + + def test_source_location + assert_separately(+"#{<<~"begin;"}\n#{<<~'end;'}") + begin; + require 'mwrap' + foo = '0' * 10000 + k = -"#{__FILE__}:2" + loc = Mwrap[k] + loc.name == k or abort 'SourceLocation#name broken' + loc.total >= 10000 or abort 'SourceLocation#total broken' + loc.frees == 0 or abort 'SourceLocation#frees broken' + loc.allocations >= 1 or + abort "SourceLocation#allocations broken: #{loc.allocations}" + seen = false + loc.each do |*x| seen = x end + seen[1] == loc.total or 'SourceLocation#each broken' + foo.clear + + # wait for call_rcu to perform real_free + freed = false + until freed + freed = true + loc.each do |size, gen| + freed = false if size >= 10000 + end + end + loc.frees == 1 or abort 'SourceLocation#frees broken (after free)' + Float === loc.mean_lifespan or abort 'mean_lifespan broken' + Integer === loc.max_lifespan or abort 'max_lifespan broken' + + addr = false + Mwrap.each do |a,| + if a =~ /0x[a-f0-9]+/ + addr = a + break + end + end + addr or abort 'Mwrap.each did not see any addresses' + addr.frozen? or abort 'Mwrap.each returned unfrozen address' + loc = Mwrap[addr] or abort "Mwrap[#{addr}] broken" + addr == loc.name or abort 'SourceLocation#name works on address' + loc.name.frozen? or abort 'SourceLocation#name not frozen' + end; + end + + def test_quiet + assert_separately(+"#{<<~"begin;"}\n#{<<~'end;'}") + begin; + require 'mwrap' + before = nil + res = Mwrap.quiet do |depth| + before = __LINE__ + depth == 1 or abort 'depth is not 1' + ('a' * 10000).clear + Mwrap.quiet { |d| d == 2 or abort 'depth is not 2' } + :foo + end + after = __LINE__ - 1 + (before..after).each do |lineno| + Mwrap["#{__FILE__}:#{lineno}"] and + abort "unexpectedly tracked allocation at line #{lineno}" + end + res == :foo or abort 'Mwrap.quiet did not return block result' + end; + end + + def test_total_bytes + assert_separately(+"#{<<~"begin;"}\n#{<<~'end;'}") + begin; + require 'mwrap' + Mwrap.total_bytes_allocated > 0 or abort 'nothing allocated' + Mwrap.total_bytes_freed > 0 or abort 'nothing freed' + Mwrap.total_bytes_allocated > Mwrap.total_bytes_freed or + abort 'freed more than allocated' + end; + end +end diff --git a/typemap b/typemap deleted file mode 100644 index 0b0e4a3..0000000 --- a/typemap +++ /dev/null @@ -1,5 +0,0 @@ -TYPEMAP -size_t T_UV -const char * T_PV -Devel::Mwrap::SrcLoc T_PTROBJ -double T_DOUBLE |