From 745572e2b96df5bc2a54264c2f26dcd5afc501fd Mon Sep 17 00:00:00 2001 From: Packit Date: Sep 16 2020 12:26:57 +0000 Subject: perl-Filter-1.58 base --- diff --git a/.appveyor.yml b/.appveyor.yml new file mode 100644 index 0000000..2d84a98 --- /dev/null +++ b/.appveyor.yml @@ -0,0 +1,16 @@ +skip_tags: true + +cache: + - C:\strawberry + +install: + - if not exist "C:\strawberry" cinst strawberryperl -y + - set PATH=C:\strawberry\perl\bin;C:\strawberry\perl\site\bin;C:\strawberry\c\bin;%PATH% + - cd C:\projects\%APPVEYOR_PROJECT_NAME% + +build_script: + - perl Makefile.PL MAKE=gmake + - gmake + +test_script: + - gmake test TEST_VERBOSE=1 diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..68dc630 --- /dev/null +++ b/.gitignore @@ -0,0 +1,48 @@ +000*.patch +Call/Call.bs +Call/Call.c +Call/Call.o +Call/MYMETA.json +Call/MYMETA.yml +Call/Makefile +Call/pm_to_blib +Exec/Exec.bs +Exec/Exec.c +Exec/Exec.o +Exec/MYMETA.json +Exec/MYMETA.yml +Exec/Makefile +Exec/pm_to_blib +Filter-*.tar.gz +Debian_CPANTS.txt +META.yml +MYMETA.json +MYMETA.yml +Makefile +blib/ +decrypt/MYMETA.json +decrypt/MYMETA.yml +decrypt/Makefile +decrypt/decrypt.bs +decrypt/decrypt.c +decrypt/decrypt.o +decrypt/pm_to_blib +pm_to_blib +tee/MYMETA.json +tee/MYMETA.yml +tee/Makefile +tee/pm_to_blib +tee/tee.bs +tee/tee.c +tee/tee.o +t/FilterTry.pm +/Filter-*.patch +/Makefile.old +/log.test-* +/log.make* +*.c.gcov +*.xs.gcov +inline.h.gcov +*/*.gcda +*/*.gcno +/cover_db diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..6d75aa0 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,61 @@ +language: "perl" +sudo: false +# travis-perl filters out cperl, perlbrew does support it +perl: + - "5.6.2" + - "5.8" + - "5.10" + - "5.12" + - "5.14" + - "5.16" + - "5.18" + - "5.20" + - "5.22" + - "5.24" + #- "5.24-thr" + - "5.26" + - "dev" + - "blead" + +# slows down already cached versions by 3 (33s => 1m45s) +# (i.e. cache download: 9s, setup: 45s-130s) +# but speeds up building the non-cached versions (5.24-*) by 2 (3m50s => 1m45s) +# overall: 25min => 35min, so disable the perl cache +#cache: +# directories: +# - /home/travis/perl5/perlbrew/ + +# blead and 5.6 stumble over YAML and more missing dependencies +# for Devel::Cover::Report::Coveralls +# cpanm does not do 5.6 +before_install: + - mkdir /home/travis/bin || true + - ln -s `which true` /home/travis/bin/cpansign + - eval $(curl https://travis-perl.github.io/init) --auto +install: + - export AUTOMATED_TESTING=1 HARNESS_TIMER=1 AUTHOR_TESTING=0 RELEASE_TESTING=0 + #- cpan-install --deps # installs prereqs, including recommends + #- cpan-install Test::LeakTrace + - cpan-install --coverage # installs converage prereqs, if enabled + +before_script: + - coverage-setup + +notifications: + email: + on_success: change + on_failure: always + +matrix: + fast_finish: true + include: + - perl: "5.18" + env: COVERAGE=1 AUTHOR_TESTING=1 # enables coverage+coveralls reporting + allow_failures: + - env: COVERAGE=1 AUTHOR_TESTING=1 + - perl: "blead" + +# Hack to not run on tag pushes: +branches: + except: + - /^v?[0-9]+\.[0-9]+/ diff --git a/Call/Call.pm b/Call/Call.pm new file mode 100644 index 0000000..cfe9cb7 --- /dev/null +++ b/Call/Call.pm @@ -0,0 +1,538 @@ +# Call.pm +# +# Copyright (c) 1995-2011 Paul Marquess. All rights reserved. +# Copyright (c) 2011-2014 Reini Urban. All rights reserved. +# Copyright (c) 2014-2017 cPanel Inc. All rights reserved. +# +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package Filter::Util::Call ; + +require 5.006 ; # our +require Exporter; + +use XSLoader (); +use strict; +use warnings; + +our @ISA = qw(Exporter); +our @EXPORT = qw( filter_add filter_del filter_read filter_read_exact) ; +our $VERSION = "1.58" ; +our $XS_VERSION = $VERSION; +$VERSION = eval $VERSION; + +sub filter_read_exact($) +{ + my ($size) = @_ ; + my ($left) = $size ; + my ($status) ; + + unless ( $size > 0 ) { + require Carp; + Carp::croak("filter_read_exact: size parameter must be > 0"); + } + + # try to read a block which is exactly $size bytes long + while ($left and ($status = filter_read($left)) > 0) { + $left = $size - length $_ ; + } + + # EOF with pending data is a special case + return 1 if $status == 0 and length $_ ; + + return $status ; +} + +sub filter_add($) +{ + my($obj) = @_ ; + + # Did we get a code reference? + my $coderef = (ref $obj eq 'CODE'); + + # If the parameter isn't already a reference, make it one. + if (!$coderef and (!ref($obj) or ref($obj) =~ /^ARRAY|HASH$/)) { + $obj = bless (\$obj, (caller)[0]); + } + + # finish off the installation of the filter in C. + Filter::Util::Call::real_import($obj, (caller)[0], $coderef) ; +} + +XSLoader::load('Filter::Util::Call'); + +1; +__END__ + +=head1 NAME + +Filter::Util::Call - Perl Source Filter Utility Module + +=head1 SYNOPSIS + + use Filter::Util::Call ; + +=head1 DESCRIPTION + +This module provides you with the framework to write I +in Perl. + +An alternate interface to Filter::Util::Call is now available. See +L for more details. + +A I is implemented as a Perl module. The structure +of the module can take one of two broadly similar formats. To +distinguish between them, the first will be referred to as I and the second as I. + +Here is a skeleton for the I: + + package MyFilter ; + + use Filter::Util::Call ; + + sub import + { + my($type, @arguments) = @_ ; + filter_add([]) ; + } + + sub filter + { + my($self) = @_ ; + my($status) ; + + $status = filter_read() ; + $status ; + } + + 1 ; + +and this is the equivalent skeleton for the I: + + package MyFilter ; + + use Filter::Util::Call ; + + sub import + { + my($type, @arguments) = @_ ; + + filter_add( + sub + { + my($status) ; + $status = filter_read() ; + $status ; + } ) + } + + 1 ; + +To make use of either of the two filter modules above, place the line +below in a Perl source file. + + use MyFilter; + +In fact, the skeleton modules shown above are fully functional I, albeit fairly useless ones. All they does is filter the +source stream without modifying it at all. + +As you can see both modules have a broadly similar structure. They both +make use of the C module and both have an C +method. The difference between them is that the I +requires a I method, whereas the I gets the +equivalent of a I method with the anonymous sub passed to +I. + +To make proper use of the I shown above you need to +have a good understanding of the concept of a I. See +L for more details on the mechanics of I. + +=head2 B + +The following functions are exported by C: + + filter_add() + filter_read() + filter_read_exact() + filter_del() + +=head2 B + +The C method is used to create an instance of the filter. It is +called indirectly by Perl when it encounters the C line +in a source file (See L for more details on +C). + +It will always have at least one parameter automatically passed by Perl +- this corresponds to the name of the package. In the example above it +will be C<"MyFilter">. + +Apart from the first parameter, import can accept an optional list of +parameters. These can be used to pass parameters to the filter. For +example: + + use MyFilter qw(a b c) ; + +will result in the C<@_> array having the following values: + + @_ [0] => "MyFilter" + @_ [1] => "a" + @_ [2] => "b" + @_ [3] => "c" + +Before terminating, the C function must explicitly install the +filter by calling C. + +=head2 B + +The function, C, actually installs the filter. It takes one +parameter which should be a reference. The kind of reference used will +dictate which of the two filter types will be used. + +If a CODE reference is used then a I will be assumed. + +If a CODE reference is not used, a I will be assumed. +In a I, the reference can be used to store context +information. The reference will be I into the package by +C, unless the reference was already blessed. + +See the filters at the end of this documents for examples of using +context information using both I and I. + +=head2 B + +Both the C method used with a I and the +anonymous sub used with a I is where the main +processing for the filter is done. + +The big difference between the two types of filter is that the I uses the object passed to the method to store any context data, +whereas the I uses the lexical variables that are +maintained by the closure. + +Note that the single parameter passed to the I, +C<$self>, is the same reference that was passed to C +blessed into the filter's package. See the example filters later on for +details of using C<$self>. + +Here is a list of the common features of the anonymous sub and the +C method. + +=over 5 + +=item B<$_> + +Although C<$_> doesn't actually appear explicitly in the sample filters +above, it is implicitly used in a number of places. + +Firstly, when either C or the anonymous sub are called, a local +copy of C<$_> will automatically be created. It will always contain the +empty string at this point. + +Next, both C and C will append any +source data that is read to the end of C<$_>. + +Finally, when C or the anonymous sub are finished processing, +they are expected to return the filtered source using C<$_>. + +This implicit use of C<$_> greatly simplifies the filter. + +=item B<$status> + +The status value that is returned by the user's C method or +anonymous sub and the C and C functions take +the same set of values, namely: + + < 0 Error + = 0 EOF + > 0 OK + +=item B and B + +These functions are used by the filter to obtain either a line or block +from the next filter in the chain or the actual source file if there +aren't any other filters. + +The function C takes two forms: + + $status = filter_read() ; + $status = filter_read($size) ; + +The first form is used to request a I, the second requests a +I. + +In line mode, C will append the next source line to the +end of the C<$_> scalar. + +In block mode, C will append a block of data which is <= +C<$size> to the end of the C<$_> scalar. It is important to emphasise +the that C will not necessarily read a block which is +I C<$size> bytes. + +If you need to be able to read a block which has an exact size, you can +use the function C. It works identically to +C in block mode, except it will try to read a block which +is exactly C<$size> bytes in length. The only circumstances when it +will not return a block which is C<$size> bytes long is on EOF or +error. + +It is I important to check the value of C<$status> after I +call to C or C. + +=item B + +The function, C, is used to disable the current filter. It +does not affect the running of the filter. All it does is tell Perl not +to call filter any more. + +See L for details. + +=item I + +Internal function which adds the filter, based on the L +argument type. + +=item I + +May be used to disable a filter, but is rarely needed. See L. + +=back + +=head1 LIMITATIONS + +See L for an overview of the general problems +filtering code in a textual line-level only. + +=over + +=item __DATA__ is ignored + +The content from the __DATA__ block is not filtered. +This is a serious limitation, e.g. for the L module. +See L for more. + +=item Max. codesize limited to 32-bit + +Currently internal buffer lengths are limited to 32-bit only. + +=back + +=head1 EXAMPLES + +Here are a few examples which illustrate the key concepts - as such +most of them are of little practical use. + +The C sub-directory has copies of all these filters +implemented both as I and as I. + +=head2 Example 1: A simple filter. + +Below is a I which is hard-wired to replace all +occurrences of the string C<"Joe"> to C<"Jim">. Not particularly +Useful, but it is the first example and I wanted to keep it simple. + + package Joe2Jim ; + + use Filter::Util::Call ; + + sub import + { + my($type) = @_ ; + + filter_add(bless []) ; + } + + sub filter + { + my($self) = @_ ; + my($status) ; + + s/Joe/Jim/g + if ($status = filter_read()) > 0 ; + $status ; + } + + 1 ; + +Here is an example of using the filter: + + use Joe2Jim ; + print "Where is Joe?\n" ; + +And this is what the script above will print: + + Where is Jim? + +=head2 Example 2: Using the context + +The previous example was not particularly useful. To make it more +general purpose we will make use of the context data and allow any +arbitrary I and I strings to be used. This time we will use a +I. To reflect its enhanced role, the filter is called +C. + + package Subst ; + + use Filter::Util::Call ; + use Carp ; + + sub import + { + croak("usage: use Subst qw(from to)") + unless @_ == 3 ; + my ($self, $from, $to) = @_ ; + filter_add( + sub + { + my ($status) ; + s/$from/$to/ + if ($status = filter_read()) > 0 ; + $status ; + }) + } + 1 ; + +and is used like this: + + use Subst qw(Joe Jim) ; + print "Where is Joe?\n" ; + + +=head2 Example 3: Using the context within the filter + +Here is a filter which a variation of the C filter. As well as +substituting all occurrences of C<"Joe"> to C<"Jim"> it keeps a count +of the number of substitutions made in the context object. + +Once EOF is detected (C<$status> is zero) the filter will insert an +extra line into the source stream. When this extra line is executed it +will print a count of the number of substitutions actually made. +Note that C<$status> is set to C<1> in this case. + + package Count ; + + use Filter::Util::Call ; + + sub filter + { + my ($self) = @_ ; + my ($status) ; + + if (($status = filter_read()) > 0 ) { + s/Joe/Jim/g ; + ++ $$self ; + } + elsif ($$self >= 0) { # EOF + $_ = "print q[Made ${$self} substitutions\n]" ; + $status = 1 ; + $$self = -1 ; + } + + $status ; + } + + sub import + { + my ($self) = @_ ; + my ($count) = 0 ; + filter_add(\$count) ; + } + + 1 ; + +Here is a script which uses it: + + use Count ; + print "Hello Joe\n" ; + print "Where is Joe\n" ; + +Outputs: + + Hello Jim + Where is Jim + Made 2 substitutions + +=head2 Example 4: Using filter_del + +Another variation on a theme. This time we will modify the C +filter to allow a starting and stopping pattern to be specified as well +as the I and I patterns. If you know the I editor, it is +the equivalent of this command: + + :/start/,/stop/s/from/to/ + +When used as a filter we want to invoke it like this: + + use NewSubst qw(start stop from to) ; + +Here is the module. + + package NewSubst ; + + use Filter::Util::Call ; + use Carp ; + + sub import + { + my ($self, $start, $stop, $from, $to) = @_ ; + my ($found) = 0 ; + croak("usage: use Subst qw(start stop from to)") + unless @_ == 5 ; + + filter_add( + sub + { + my ($status) ; + + if (($status = filter_read()) > 0) { + + $found = 1 + if $found == 0 and /$start/ ; + + if ($found) { + s/$from/$to/ ; + filter_del() if /$stop/ ; + } + + } + $status ; + } ) + + } + + 1 ; + +=head1 Filter::Simple + +If you intend using the Filter::Call functionality, I would strongly +recommend that you check out Damian Conway's excellent Filter::Simple +module. Damian's module provides a much cleaner interface than +Filter::Util::Call. Although it doesn't allow the fine control that +Filter::Util::Call does, it should be adequate for the majority of +applications. It's available at + + http://search.cpan.org/dist/Filter-Simple/ + +=head1 AUTHOR + +Paul Marquess + +=head1 DATE + +26th January 1996 + +=head1 LICENSE + +Copyright (c) 1995-2011 Paul Marquess. All rights reserved. +Copyright (c) 2011-2014 Reini Urban. All rights reserved. +Copyright (c) 2014-2017 cPanel Inc. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut + diff --git a/Call/Call.xs b/Call/Call.xs new file mode 100644 index 0000000..74c3676 --- /dev/null +++ b/Call/Call.xs @@ -0,0 +1,265 @@ +/* + * Filename : Call.xs + * + * Author : Paul Marquess + * Date : 2014-12-09 02:48:44 rurban + * Version : 1.58 + * + * Copyright (c) 1995-2011 Paul Marquess. All rights reserved. + * Copyright (c) 2011-2014 Reini Urban. All rights reserved. + * This program is free software; you can redistribute it and/or + * modify it under the same terms as Perl itself. + * + */ + +#define PERL_NO_GET_CONTEXT +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#ifdef _NOT_CORE +# include "ppport.h" +#endif + +/* Internal defines */ +#define PERL_MODULE(s) IoBOTTOM_NAME(s) +#define PERL_OBJECT(s) IoTOP_GV(s) +#define FILTER_ACTIVE(s) IoLINES(s) +#define BUF_OFFSET(sv) IoPAGE_LEN(sv) +#define CODE_REF(sv) IoPAGE(sv) +#ifndef PERL_FILTER_EXISTS +# define PERL_FILTER_EXISTS(i) (PL_rsfp_filters && (i) <= av_len(PL_rsfp_filters)) +#endif + +#define SET_LEN(sv,len) \ + do { SvPVX(sv)[len] = '\0'; SvCUR_set(sv, len); } while (0) + + +/* Global Data */ + +#define MY_CXT_KEY "Filter::Util::Call::_guts" XS_VERSION + +typedef struct { + int x_fdebug ; + int x_current_idx ; +} my_cxt_t; + +START_MY_CXT + +#define fdebug (MY_CXT.x_fdebug) +#define current_idx (MY_CXT.x_current_idx) + + +static I32 +filter_call(pTHX_ int idx, SV *buf_sv, int maxlen) +{ + dMY_CXT; + SV *my_sv = FILTER_DATA(idx); + const char *nl = "\n"; + char *p; + char *out_ptr; + int n; + + if (fdebug) + warn("**** In filter_call - maxlen = %d, out len buf = %" IVdf " idx = %d my_sv = %" IVdf " [%s]\n", + maxlen, (IV)SvCUR(buf_sv), idx, (IV)SvCUR(my_sv), SvPVX(my_sv) ) ; + + while (1) { + + /* anything left from last time */ + if ((n = SvCUR(my_sv))) { + + out_ptr = SvPVX(my_sv) + BUF_OFFSET(my_sv) ; + + if (maxlen) { + /* want a block */ + if (fdebug) + warn("BLOCK(%d): size = %d, maxlen = %d\n", + idx, n, maxlen) ; + + sv_catpvn(buf_sv, out_ptr, maxlen > n ? n : maxlen ); + if(n <= maxlen) { + BUF_OFFSET(my_sv) = 0 ; + SET_LEN(my_sv, 0) ; + } + else { + BUF_OFFSET(my_sv) += maxlen ; + SvCUR_set(my_sv, n - maxlen) ; + } + return SvCUR(buf_sv); + } + else { + /* want lines */ + if ((p = ninstr(out_ptr, out_ptr + n, nl, nl + 1))) { + + sv_catpvn(buf_sv, out_ptr, p - out_ptr + 1); + + n = n - (p - out_ptr + 1); + BUF_OFFSET(my_sv) += (p - out_ptr + 1); + SvCUR_set(my_sv, n) ; + if (fdebug) + warn("recycle %d - leaving %d, returning %" IVdf " [%s]", + idx, n, (IV)SvCUR(buf_sv), SvPVX(buf_sv)) ; + + return SvCUR(buf_sv); + } + else /* no EOL, so append the complete buffer */ + sv_catpvn(buf_sv, out_ptr, n) ; + } + + } + + + SET_LEN(my_sv, 0) ; + BUF_OFFSET(my_sv) = 0 ; + + if (FILTER_ACTIVE(my_sv)) + { + dSP ; + int count ; + + if (fdebug) + warn("gonna call %s::filter\n", PERL_MODULE(my_sv)) ; + + ENTER ; + SAVETMPS; + + SAVEINT(current_idx) ; /* save current idx */ + current_idx = idx ; + + SAVE_DEFSV ; /* save $_ */ + /* make $_ use our buffer */ + DEFSV_set(newSVpv("", 0)) ; + + PUSHMARK(sp) ; + if (CODE_REF(my_sv)) { + /* if (SvROK(PERL_OBJECT(my_sv)) && SvTYPE(SvRV(PERL_OBJECT(my_sv))) == SVt_PVCV) { */ + count = perl_call_sv((SV*)PERL_OBJECT(my_sv), G_SCALAR); + } + else { + XPUSHs((SV*)PERL_OBJECT(my_sv)) ; + PUTBACK ; + count = perl_call_method("filter", G_SCALAR); + } + SPAGAIN ; + + if (count != 1) + croak("Filter::Util::Call - %s::filter returned %d values, 1 was expected \n", + PERL_MODULE(my_sv), count ) ; + + n = POPi ; + + if (fdebug) + warn("status = %d, length op buf = %" IVdf " [%s]\n", + n, (IV)SvCUR(DEFSV), SvPVX(DEFSV) ) ; + if (SvCUR(DEFSV)) + sv_setpvn(my_sv, SvPVX(DEFSV), SvCUR(DEFSV)) ; + + sv_2mortal(DEFSV); + + PUTBACK ; + FREETMPS ; + LEAVE ; + } + else + n = FILTER_READ(idx + 1, my_sv, maxlen) ; + + if (n <= 0) + { + /* Either EOF or an error */ + + if (fdebug) + warn ("filter_read %d returned %d , returning %" IVdf "\n", idx, n, + (SvCUR(buf_sv)>0) ? (IV)SvCUR(buf_sv) : (IV)n); + + /* PERL_MODULE(my_sv) ; */ + /* PERL_OBJECT(my_sv) ; */ + filter_del(filter_call); + + /* If error, return the code */ + if (n < 0) + return n ; + + /* return what we have so far else signal eof */ + return (SvCUR(buf_sv)>0) ? (int)SvCUR(buf_sv) : n; + } + + } +} + + + +MODULE = Filter::Util::Call PACKAGE = Filter::Util::Call + +REQUIRE: 1.924 +PROTOTYPES: ENABLE + +#define IDX current_idx + +int +filter_read(size=0) + int size + CODE: + { + dMY_CXT; + SV * buffer = DEFSV ; + + RETVAL = FILTER_READ(IDX + 1, buffer, size) ; + } + OUTPUT: + RETVAL + + + + +void +real_import(object, perlmodule, coderef) + SV * object + char * perlmodule + int coderef + PPCODE: + { + SV * sv = newSV(1) ; + + (void)SvPOK_only(sv) ; + filter_add(filter_call, sv) ; + + PERL_MODULE(sv) = savepv(perlmodule) ; + PERL_OBJECT(sv) = (GV*) newSVsv(object) ; + FILTER_ACTIVE(sv) = TRUE ; + BUF_OFFSET(sv) = 0 ; + CODE_REF(sv) = coderef ; + + SvCUR_set(sv, 0) ; + + } + +void +filter_del() + CODE: + dMY_CXT; + if (PERL_FILTER_EXISTS(IDX) && FILTER_DATA(IDX) && FILTER_ACTIVE(FILTER_DATA(IDX))) + FILTER_ACTIVE(FILTER_DATA(IDX)) = FALSE ; + + + +void +unimport(package="$Package", ...) + const char *package + PPCODE: + PERL_UNUSED_VAR(package); + filter_del(filter_call); + + +BOOT: + { + MY_CXT_INIT; +#ifdef FDEBUG + fdebug = 1; +#else + fdebug = 0; +#endif + /* temporary hack to control debugging in toke.c */ + if (fdebug) + filter_add(NULL, (fdebug) ? (SV*)"1" : (SV*)"0"); + } + diff --git a/Call/Makefile.PL b/Call/Makefile.PL new file mode 100755 index 0000000..1ab017e --- /dev/null +++ b/Call/Makefile.PL @@ -0,0 +1,7 @@ +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'Filter::Util::Call', + DEFINE => '-D_NOT_CORE', + VERSION_FROM => 'Call.pm', +); diff --git a/Call/ppport.h b/Call/ppport.h new file mode 100644 index 0000000..03def99 --- /dev/null +++ b/Call/ppport.h @@ -0,0 +1,6960 @@ +#if 0 +<<'SKIP'; +#endif +/* +---------------------------------------------------------------------- + + ppport.h -- Perl/Pollution/Portability Version 3.16 + + Automatically created by Devel::PPPort running under perl 5.011000. + + 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.16 + +=head1 SYNOPSIS + + perl ppport.h [options] [source files] + + Searches current directory for files if no [source files] are given + + --help show short help + + --version show version + + --patch=file write one patch file with changes + --copy=suffix write changed copies with suffix + --diff=program use diff program and options + + --compat-version=version provide compatibility with Perl version + --cplusplus accept C++ comments + + --quiet don't output anything except fatal errors + --nodiag don't show diagnostics + --nohints don't show hints + --nochanges don't suggest changes + --nofilter don't filter input files + + --strip strip all script and doc functionality from + ppport.h + + --list-provided list provided API + --list-unsupported list unsupported API + --api-info=name show Perl API portability information + +=head1 COMPATIBILITY + +This version of F is designed to support operation with Perl +installations back to 5.003, and has been tested up to 5.10.0. + +=head1 OPTIONS + +=head2 --help + +Display a brief usage summary. + +=head2 --version + +Display the version of F. + +=head2 --patch=I + +If this option is given, a single patch file will be created if +any changes are suggested. This requires a working diff program +to be installed on your system. + +=head2 --copy=I + +If this option is given, a copy of each file will be saved with +the given suffix that contains the suggested changes. This does +not require any external programs. Note that this does not +automagially add a dot between the original filename and the +suffix. If you want the dot, you have to include it in the option +argument. + +If neither C<--patch> or C<--copy> are given, the default is to +simply print the diffs for each file. This requires either +C or a C program to be installed. + +=head2 --diff=I + +Manually set the diff program and options to use. The default +is to use C, when installed, and output unified +context diffs. + +=head2 --compat-version=I + +Tell F to check for compatibility with the given +Perl version. The default is to check for compatibility with Perl +version 5.003. You can use this option to reduce the output +of F if you intend to be backward compatible only +down to a certain Perl version. + +=head2 --cplusplus + +Usually, F will detect C++ style comments and +replace them with C style comments for portability reasons. +Using this option instructs F to leave C++ +comments untouched. + +=head2 --quiet + +Be quiet. Don't print anything except fatal errors. + +=head2 --nodiag + +Don't output any diagnostic messages. Only portability +alerts will be printed. + +=head2 --nohints + +Don't output any hints. Hints often contain useful portability +notes. Warnings will still be displayed. + +=head2 --nochanges + +Don't suggest any changes. Only give diagnostic output and hints +unless these are also deactivated. + +=head2 --nofilter + +Don't filter the list of input files. By default, files not looking +like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped. + +=head2 --strip + +Strip all script and documentation functionality from F. +This reduces the size of F dramatically and may be useful +if you want to include F in smaller modules without +increasing their distribution size too much. + +The stripped F will have a C<--unstrip> option that allows +you to undo the stripping, but only if an appropriate C +module is installed. + +=head2 --list-provided + +Lists the API elements for which compatibility is provided by +F. Also lists if it must be explicitly requested, +if it has dependencies, and if there are hints or warnings for it. + +=head2 --list-unsupported + +Lists the API elements that are known not to be supported by +F and below which version of Perl they probably +won't be available or work. + +=head2 --api-info=I + +Show portability information for API elements matching I. +If I is surrounded by slashes, it is interpreted as a regular +expression. + +=head1 DESCRIPTION + +In order for a Perl extension (XS) module to be as portable as possible +across differing versions of Perl itself, certain steps need to be taken. + +=over 4 + +=item * + +Including this header is the first major one. This alone will give you +access to a large part of the Perl API that hasn't been available in +earlier Perl releases. Use + + perl ppport.h --list-provided + +to see which API elements are provided by ppport.h. + +=item * + +You should avoid using deprecated parts of the API. For example, using +global Perl variables without the C prefix is deprecated. Also, +some API functions used to have a C prefix. Using this form is +also deprecated. You can safely use the supported API, as F +will provide wrappers for older Perl versions. + +=item * + +If you use one of a few functions or variables that were not present in +earlier versions of Perl, and that can't be provided using a macro, you +have to explicitly request support for these functions by adding one or +more C<#define>s in your source code before the inclusion of F. + +These functions or variables will be marked C in the list shown +by C<--list-provided>. + +Depending on whether you module has a single or multiple files that +use such functions or variables, you want either C or global +variants. + +For a C function or variable (used only in a single source +file), use: + + #define NEED_function + #define NEED_variable + +For a global function or variable (used in multiple source files), +use: + + #define NEED_function_GLOBAL + #define NEED_variable_GLOBAL + +Note that you mustn't have more than one global request for the +same function or variable in your project. + + Function / Variable Static Request Global Request + ----------------------------------------------------------------------------------------- + PL_parser NEED_PL_parser NEED_PL_parser_GLOBAL + PL_signals NEED_PL_signals NEED_PL_signals_GLOBAL + eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL + grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL + grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL + grok_number() NEED_grok_number NEED_grok_number_GLOBAL + grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL + grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL + load_module() NEED_load_module NEED_load_module_GLOBAL + my_snprintf() NEED_my_snprintf NEED_my_snprintf_GLOBAL + my_sprintf() NEED_my_sprintf NEED_my_sprintf_GLOBAL + my_strlcat() NEED_my_strlcat NEED_my_strlcat_GLOBAL + my_strlcpy() NEED_my_strlcpy NEED_my_strlcpy_GLOBAL + newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL + newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL + newSVpvn_flags() NEED_newSVpvn_flags NEED_newSVpvn_flags_GLOBAL + newSVpvn_share() NEED_newSVpvn_share NEED_newSVpvn_share_GLOBAL + pv_display() NEED_pv_display NEED_pv_display_GLOBAL + pv_escape() NEED_pv_escape NEED_pv_escape_GLOBAL + pv_pretty() NEED_pv_pretty NEED_pv_pretty_GLOBAL + sv_2pv_flags() NEED_sv_2pv_flags NEED_sv_2pv_flags_GLOBAL + sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL + sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL + sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL + sv_pvn_force_flags() NEED_sv_pvn_force_flags NEED_sv_pvn_force_flags_GLOBAL + sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL + sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL + vload_module() NEED_vload_module NEED_vload_module_GLOBAL + vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL + warner() NEED_warner NEED_warner_GLOBAL + +To avoid namespace conflicts, you can change the namespace of the +explicitly exported functions / variables using the C +macro. Just C<#define> the macro before including C: + + #define DPPP_NAMESPACE MyOwnNamespace_ + #include "ppport.h" + +The default namespace is C. + +=back + +The good thing is that most of the above can be checked by running +F on your source code. See the next section for +details. + +=head1 EXAMPLES + +To verify whether F is needed for your module, whether you +should make any changes to your code, and whether any special defines +should be used, F can be run as a Perl script to check your +source code. Simply say: + + perl ppport.h + +The result will usually be a list of patches suggesting changes +that should at least be acceptable, if not necessarily the most +efficient solution, or a fix for all possible problems. + +If you know that your XS module uses features only available in +newer Perl releases, if you're aware that it uses C++ comments, +and if you want all suggestions as a single patch file, you could +use something like this: + + perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff + +If you only want your code to be scanned without any suggestions +for changes, use: + + perl ppport.h --nochanges + +You can specify a different C program or options, using +the C<--diff> option: + + perl ppport.h --diff='diff -C 10' + +This would output context diffs with 10 lines of context. + +If you want to create patched copies of your files instead, use: + + perl ppport.h --copy=.new + +To display portability information for the C function, +use: + + perl ppport.h --api-info=newSVpvn + +Since the argument to C<--api-info> can be a regular expression, +you can use + + perl ppport.h --api-info=/_nomg$/ + +to display portability information for all C<_nomg> functions or + + perl ppport.h --api-info=/./ + +to display information for all known API elements. + +=head1 BUGS + +If this version of F is causing failure during +the compilation of this module, please check if newer versions +of either this module or C are available on CPAN +before sending a bug report. + +If F was generated using the latest version of +C and is causing failure of this module, please +file a bug report using the CPAN Request Tracker at L. + +Please include the following information: + +=over 4 + +=item 1. + +The complete output from running "perl -V" + +=item 2. + +This file. + +=item 3. + +The name and version of the module you were trying to build. + +=item 4. + +A full log of the build that failed. + +=item 5. + +Any other information that you think could be relevant. + +=back + +For the latest version of this code, please get the C +module from CPAN. + +=head1 COPYRIGHT + +Version 3.x, Copyright (c) 2004-2009, Marcus Holland-Moritz. + +Version 2.x, Copyright (C) 2001, Paul Marquess. + +Version 1.x, Copyright (C) 1999, Kenneth Albanowski. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L. + +=cut + +use strict; + +# Disable broken TRIE-optimization +BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 } + +my $VERSION = 3.16; + +my %opt = ( + quiet => 0, + diag => 1, + hints => 1, + changes => 1, + cplusplus => 0, + filter => 1, + strip => 0, + version => 0, +); + +my($ppport) = $0 =~ /([\w.]+)$/; +my $LF = '(?:\r\n|[\r\n])'; # line feed +my $HS = "[ \t]"; # horizontal whitespace + +# Never use C comments in this file! +my $ccs = '/'.'*'; +my $cce = '*'.'/'; +my $rccs = quotemeta $ccs; +my $rcce = quotemeta $cce; + +eval { + require Getopt::Long; + Getopt::Long::GetOptions(\%opt, qw( + help quiet diag! filter! hints! changes! cplusplus strip version + patch=s copy=s diff=s compat-version=s + list-provided list-unsupported api-info=s + )) or usage(); +}; + +if ($@ and grep /^-/, @ARGV) { + usage() if "@ARGV" =~ /^--?h(?:elp)?$/; + die "Getopt::Long not found. Please don't use any options.\n"; +} + +if ($opt{version}) { + print "This is $0 $VERSION.\n"; + exit 0; +} + +usage() if $opt{help}; +strip() if $opt{strip}; + +if (exists $opt{'compat-version'}) { + my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) }; + if ($@) { + die "Invalid version number format: '$opt{'compat-version'}'\n"; + } + die "Only Perl 5 is supported\n" if $r != 5; + die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000; + $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; +} +else { + $opt{'compat-version'} = 5; +} + +my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ + ? ( $1 => { + ($2 ? ( base => $2 ) : ()), + ($3 ? ( todo => $3 ) : ()), + (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), + (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), + (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()), + } ) + : die "invalid spec: $_" } qw( +AvFILLp|5.004050||p +AvFILL||| +CLASS|||n +CPERLscope|||p +CX_CURPAD_SAVE||| +CX_CURPAD_SV||| +CopFILEAV|5.006000||p +CopFILEGV_set|5.006000||p +CopFILEGV|5.006000||p +CopFILESV|5.006000||p +CopFILE_set|5.006000||p +CopFILE|5.006000||p +CopSTASHPV_set|5.006000||p +CopSTASHPV|5.006000||p +CopSTASH_eq|5.006000||p +CopSTASH_set|5.006000||p +CopSTASH|5.006000||p +CopyD|5.009002||p +Copy||| +CvPADLIST||| +CvSTASH||| +CvWEAKOUTSIDE||| +DEFSV_set|||p +DEFSV|5.004050||p +END_EXTERN_C|5.005000||p +ENTER||| +ERRSV|5.004050||p +EXTEND||| +EXTERN_C|5.005000||p +F0convert|||n +FREETMPS||| +GIMME_V||5.004000|n +GIMME|||n +GROK_NUMERIC_RADIX|5.007002||p +G_ARRAY||| +G_DISCARD||| +G_EVAL||| +G_METHOD|||p +G_NOARGS||| +G_SCALAR||| +G_VOID||5.004000| +GetVars||| +GvSV||| +Gv_AMupdate||| +HEf_SVKEY||5.004000| +HeHASH||5.004000| +HeKEY||5.004000| +HeKLEN||5.004000| +HePV||5.004000| +HeSVKEY_force||5.004000| +HeSVKEY_set||5.004000| +HeSVKEY||5.004000| +HeUTF8||5.011000| +HeVAL||5.004000| +HvNAME||| +INT2PTR|5.006000||p +IN_LOCALE_COMPILETIME|5.007002||p +IN_LOCALE_RUNTIME|5.007002||p +IN_LOCALE|5.007002||p +IN_PERL_COMPILETIME|5.008001||p +IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p +IS_NUMBER_INFINITY|5.007002||p +IS_NUMBER_IN_UV|5.007002||p +IS_NUMBER_NAN|5.007003||p +IS_NUMBER_NEG|5.007002||p +IS_NUMBER_NOT_INT|5.007002||p +IVSIZE|5.006000||p +IVTYPE|5.006000||p +IVdf|5.006000||p +LEAVE||| +LVRET||| +MARK||| +MULTICALL||5.011000| +MY_CXT_CLONE|5.009002||p +MY_CXT_INIT|5.007003||p +MY_CXT|5.007003||p +MoveD|5.009002||p +Move||| +NOOP|5.005000||p +NUM2PTR|5.006000||p +NVTYPE|5.006000||p +NVef|5.006001||p +NVff|5.006001||p +NVgf|5.006001||p +Newxc|5.009003||p +Newxz|5.009003||p +Newx|5.009003||p +Nullav||| +Nullch||| +Nullcv||| +Nullhv||| +Nullsv||| +ORIGMARK||| +PAD_BASE_SV||| +PAD_CLONE_VARS||| +PAD_COMPNAME_FLAGS||| +PAD_COMPNAME_GEN_set||| +PAD_COMPNAME_GEN||| +PAD_COMPNAME_OURSTASH||| +PAD_COMPNAME_PV||| +PAD_COMPNAME_TYPE||| +PAD_DUP||| +PAD_RESTORE_LOCAL||| +PAD_SAVE_LOCAL||| +PAD_SAVE_SETNULLPAD||| +PAD_SETSV||| +PAD_SET_CUR_NOSAVE||| +PAD_SET_CUR||| +PAD_SVl||| +PAD_SV||| +PERLIO_FUNCS_CAST|5.009003||p +PERLIO_FUNCS_DECL|5.009003||p +PERL_ABS|5.008001||p +PERL_BCDVERSION|5.011000||p +PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p +PERL_HASH|5.004000||p +PERL_INT_MAX|5.004000||p +PERL_INT_MIN|5.004000||p +PERL_LONG_MAX|5.004000||p +PERL_LONG_MIN|5.004000||p +PERL_MAGIC_arylen|5.007002||p +PERL_MAGIC_backref|5.007002||p +PERL_MAGIC_bm|5.007002||p +PERL_MAGIC_collxfrm|5.007002||p +PERL_MAGIC_dbfile|5.007002||p +PERL_MAGIC_dbline|5.007002||p +PERL_MAGIC_defelem|5.007002||p +PERL_MAGIC_envelem|5.007002||p +PERL_MAGIC_env|5.007002||p +PERL_MAGIC_ext|5.007002||p +PERL_MAGIC_fm|5.007002||p +PERL_MAGIC_glob|5.011000||p +PERL_MAGIC_isaelem|5.007002||p +PERL_MAGIC_isa|5.007002||p +PERL_MAGIC_mutex|5.011000||p +PERL_MAGIC_nkeys|5.007002||p +PERL_MAGIC_overload_elem|5.007002||p +PERL_MAGIC_overload_table|5.007002||p +PERL_MAGIC_overload|5.007002||p +PERL_MAGIC_pos|5.007002||p +PERL_MAGIC_qr|5.007002||p +PERL_MAGIC_regdata|5.007002||p +PERL_MAGIC_regdatum|5.007002||p +PERL_MAGIC_regex_global|5.007002||p +PERL_MAGIC_shared_scalar|5.007003||p +PERL_MAGIC_shared|5.007003||p +PERL_MAGIC_sigelem|5.007002||p +PERL_MAGIC_sig|5.007002||p +PERL_MAGIC_substr|5.007002||p +PERL_MAGIC_sv|5.007002||p +PERL_MAGIC_taint|5.007002||p +PERL_MAGIC_tiedelem|5.007002||p +PERL_MAGIC_tiedscalar|5.007002||p +PERL_MAGIC_tied|5.007002||p +PERL_MAGIC_utf8|5.008001||p +PERL_MAGIC_uvar_elem|5.007003||p +PERL_MAGIC_uvar|5.007002||p +PERL_MAGIC_vec|5.007002||p +PERL_MAGIC_vstring|5.008001||p +PERL_PV_ESCAPE_ALL|||p +PERL_PV_ESCAPE_FIRSTCHAR|||p +PERL_PV_ESCAPE_NOBACKSLASH|||p +PERL_PV_ESCAPE_NOCLEAR|||p +PERL_PV_ESCAPE_QUOTE|||p +PERL_PV_ESCAPE_RE|||p +PERL_PV_ESCAPE_UNI_DETECT|||p +PERL_PV_ESCAPE_UNI|||p +PERL_PV_PRETTY_DUMP|||p +PERL_PV_PRETTY_ELLIPSES|||p +PERL_PV_PRETTY_LTGT|||p +PERL_PV_PRETTY_NOCLEAR|||p +PERL_PV_PRETTY_QUOTE|||p +PERL_PV_PRETTY_REGPROP|||p +PERL_QUAD_MAX|5.004000||p +PERL_QUAD_MIN|5.004000||p +PERL_REVISION|5.006000||p +PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p +PERL_SCAN_DISALLOW_PREFIX|5.007003||p +PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p +PERL_SCAN_SILENT_ILLDIGIT|5.008001||p +PERL_SHORT_MAX|5.004000||p +PERL_SHORT_MIN|5.004000||p +PERL_SIGNALS_UNSAFE_FLAG|5.008001||p +PERL_SUBVERSION|5.006000||p +PERL_UCHAR_MAX|5.004000||p +PERL_UCHAR_MIN|5.004000||p +PERL_UINT_MAX|5.004000||p +PERL_UINT_MIN|5.004000||p +PERL_ULONG_MAX|5.004000||p +PERL_ULONG_MIN|5.004000||p +PERL_UNUSED_ARG|5.009003||p +PERL_UNUSED_CONTEXT|5.009004||p +PERL_UNUSED_DECL|5.007002||p +PERL_UNUSED_VAR|5.007002||p +PERL_UQUAD_MAX|5.004000||p +PERL_UQUAD_MIN|5.004000||p +PERL_USE_GCC_BRACE_GROUPS|5.009004||p +PERL_USHORT_MAX|5.004000||p +PERL_USHORT_MIN|5.004000||p +PERL_VERSION|5.006000||p +PL_DBsignal|5.005000||p +PL_DBsingle|||pn +PL_DBsub|||pn +PL_DBtrace|||pn +PL_Sv|5.005000||p +PL_bufend|||p +PL_bufptr|||p +PL_compiling|5.004050||p +PL_copline|5.011000||p +PL_curcop|5.004050||p +PL_curstash|5.004050||p +PL_debstash|5.004050||p +PL_defgv|5.004050||p +PL_diehook|5.004050||p +PL_dirty|5.004050||p +PL_dowarn|||pn +PL_errgv|5.004050||p +PL_expect|5.011000||p +PL_hexdigit|5.005000||p +PL_hints|5.005000||p +PL_last_in_gv|||n +PL_laststatval|5.005000||p +PL_lex_state|||p +PL_lex_stuff|||p +PL_linestr|||p +PL_modglobal||5.005000|n +PL_na|5.004050||pn +PL_no_modify|5.006000||p +PL_ofs_sv|||n +PL_parser|||p +PL_perl_destruct_level|5.004050||p +PL_perldb|5.004050||p +PL_ppaddr|5.006000||p +PL_rsfp_filters|5.004050||p +PL_rsfp|5.004050||p +PL_rs|||n +PL_signals|5.008001||p +PL_stack_base|5.004050||p +PL_stack_sp|5.004050||p +PL_statcache|5.005000||p +PL_stdingv|5.004050||p +PL_sv_arenaroot|5.004050||p +PL_sv_no|5.004050||pn +PL_sv_undef|5.004050||pn +PL_sv_yes|5.004050||pn +PL_tainted|5.004050||p +PL_tainting|5.004050||p +PL_tokenbuf|||p +POP_MULTICALL||5.011000| +POPi|||n +POPl|||n +POPn|||n +POPpbytex||5.007001|n +POPpx||5.005030|n +POPp|||n +POPs|||n +PTR2IV|5.006000||p +PTR2NV|5.006000||p +PTR2UV|5.006000||p +PTR2ul|5.007001||p +PTRV|5.006000||p +PUSHMARK||| +PUSH_MULTICALL||5.011000| +PUSHi||| +PUSHmortal|5.009002||p +PUSHn||| +PUSHp||| +PUSHs||| +PUSHu|5.004000||p +PUTBACK||| +PerlIO_clearerr||5.007003| +PerlIO_close||5.007003| +PerlIO_context_layers||5.009004| +PerlIO_eof||5.007003| +PerlIO_error||5.007003| +PerlIO_fileno||5.007003| +PerlIO_fill||5.007003| +PerlIO_flush||5.007003| +PerlIO_get_base||5.007003| +PerlIO_get_bufsiz||5.007003| +PerlIO_get_cnt||5.007003| +PerlIO_get_ptr||5.007003| +PerlIO_read||5.007003| +PerlIO_seek||5.007003| +PerlIO_set_cnt||5.007003| +PerlIO_set_ptrcnt||5.007003| +PerlIO_setlinebuf||5.007003| +PerlIO_stderr||5.007003| +PerlIO_stdin||5.007003| +PerlIO_stdout||5.007003| +PerlIO_tell||5.007003| +PerlIO_unread||5.007003| +PerlIO_write||5.007003| +Perl_signbit||5.009005|n +PoisonFree|5.009004||p +PoisonNew|5.009004||p +PoisonWith|5.009004||p +Poison|5.008000||p +RETVAL|||n +Renewc||| +Renew||| +SAVECLEARSV||| +SAVECOMPPAD||| +SAVEPADSV||| +SAVETMPS||| +SAVE_DEFSV|5.004050||p +SPAGAIN||| +SP||| +START_EXTERN_C|5.005000||p +START_MY_CXT|5.007003||p +STMT_END|||p +STMT_START|||p +STR_WITH_LEN|5.009003||p +ST||| +SV_CONST_RETURN|5.009003||p +SV_COW_DROP_PV|5.008001||p +SV_COW_SHARED_HASH_KEYS|5.009005||p +SV_GMAGIC|5.007002||p +SV_HAS_TRAILING_NUL|5.009004||p +SV_IMMEDIATE_UNREF|5.007001||p +SV_MUTABLE_RETURN|5.009003||p +SV_NOSTEAL|5.009002||p +SV_SMAGIC|5.009003||p +SV_UTF8_NO_ENCODING|5.008001||p +SVf_UTF8|5.006000||p +SVf|5.006000||p +SVt_IV||| +SVt_NV||| +SVt_PVAV||| +SVt_PVCV||| +SVt_PVHV||| +SVt_PVMG||| +SVt_PV||| +Safefree||| +Slab_Alloc||| +Slab_Free||| +Slab_to_rw||| +StructCopy||| +SvCUR_set||| +SvCUR||| +SvEND||| +SvGAMAGIC||5.006001| +SvGETMAGIC|5.004050||p +SvGROW||| +SvIOK_UV||5.006000| +SvIOK_notUV||5.006000| +SvIOK_off||| +SvIOK_only_UV||5.006000| +SvIOK_only||| +SvIOK_on||| +SvIOKp||| +SvIOK||| +SvIVX||| +SvIV_nomg|5.009001||p +SvIV_set||| +SvIVx||| +SvIV||| +SvIsCOW_shared_hash||5.008003| +SvIsCOW||5.008003| +SvLEN_set||| +SvLEN||| +SvLOCK||5.007003| +SvMAGIC_set|5.009003||p +SvNIOK_off||| +SvNIOKp||| +SvNIOK||| +SvNOK_off||| +SvNOK_only||| +SvNOK_on||| +SvNOKp||| +SvNOK||| +SvNVX||| +SvNV_set||| +SvNVx||| +SvNV||| +SvOK||| +SvOOK_offset||5.011000| +SvOOK||| +SvPOK_off||| +SvPOK_only_UTF8||5.006000| +SvPOK_only||| +SvPOK_on||| +SvPOKp||| +SvPOK||| +SvPVX_const|5.009003||p +SvPVX_mutable|5.009003||p +SvPVX||| +SvPV_const|5.009003||p +SvPV_flags_const_nolen|5.009003||p +SvPV_flags_const|5.009003||p +SvPV_flags_mutable|5.009003||p +SvPV_flags|5.007002||p +SvPV_force_flags_mutable|5.009003||p +SvPV_force_flags_nolen|5.009003||p +SvPV_force_flags|5.007002||p +SvPV_force_mutable|5.009003||p +SvPV_force_nolen|5.009003||p +SvPV_force_nomg_nolen|5.009003||p +SvPV_force_nomg|5.007002||p +SvPV_force|||p +SvPV_mutable|5.009003||p +SvPV_nolen_const|5.009003||p +SvPV_nolen|5.006000||p +SvPV_nomg_const_nolen|5.009003||p +SvPV_nomg_const|5.009003||p +SvPV_nomg|5.007002||p +SvPV_renew|||p +SvPV_set||| +SvPVbyte_force||5.009002| +SvPVbyte_nolen||5.006000| +SvPVbytex_force||5.006000| +SvPVbytex||5.006000| +SvPVbyte|5.006000||p +SvPVutf8_force||5.006000| +SvPVutf8_nolen||5.006000| +SvPVutf8x_force||5.006000| +SvPVutf8x||5.006000| +SvPVutf8||5.006000| +SvPVx||| +SvPV||| +SvREFCNT_dec||| +SvREFCNT_inc_NN|5.009004||p +SvREFCNT_inc_simple_NN|5.009004||p +SvREFCNT_inc_simple_void_NN|5.009004||p +SvREFCNT_inc_simple_void|5.009004||p +SvREFCNT_inc_simple|5.009004||p +SvREFCNT_inc_void_NN|5.009004||p +SvREFCNT_inc_void|5.009004||p +SvREFCNT_inc|||p +SvREFCNT||| +SvROK_off||| +SvROK_on||| +SvROK||| +SvRV_set|5.009003||p +SvRV||| +SvRXOK||5.009005| +SvRX||5.009005| +SvSETMAGIC||| +SvSHARED_HASH|5.009003||p +SvSHARE||5.007003| +SvSTASH_set|5.009003||p +SvSTASH||| +SvSetMagicSV_nosteal||5.004000| +SvSetMagicSV||5.004000| +SvSetSV_nosteal||5.004000| +SvSetSV||| +SvTAINTED_off||5.004000| +SvTAINTED_on||5.004000| +SvTAINTED||5.004000| +SvTAINT||| +SvTRUE||| +SvTYPE||| +SvUNLOCK||5.007003| +SvUOK|5.007001|5.006000|p +SvUPGRADE||| +SvUTF8_off||5.006000| +SvUTF8_on||5.006000| +SvUTF8||5.006000| +SvUVXx|5.004000||p +SvUVX|5.004000||p +SvUV_nomg|5.009001||p +SvUV_set|5.009003||p +SvUVx|5.004000||p +SvUV|5.004000||p +SvVOK||5.008001| +SvVSTRING_mg|5.009004||p +THIS|||n +UNDERBAR|5.009002||p +UTF8_MAXBYTES|5.009002||p +UVSIZE|5.006000||p +UVTYPE|5.006000||p +UVXf|5.007001||p +UVof|5.006000||p +UVuf|5.006000||p +UVxf|5.006000||p +WARN_ALL|5.006000||p +WARN_AMBIGUOUS|5.006000||p +WARN_ASSERTIONS|5.011000||p +WARN_BAREWORD|5.006000||p +WARN_CLOSED|5.006000||p +WARN_CLOSURE|5.006000||p +WARN_DEBUGGING|5.006000||p +WARN_DEPRECATED|5.006000||p +WARN_DIGIT|5.006000||p +WARN_EXEC|5.006000||p +WARN_EXITING|5.006000||p +WARN_GLOB|5.006000||p +WARN_INPLACE|5.006000||p +WARN_INTERNAL|5.006000||p +WARN_IO|5.006000||p +WARN_LAYER|5.008000||p +WARN_MALLOC|5.006000||p +WARN_MISC|5.006000||p +WARN_NEWLINE|5.006000||p +WARN_NUMERIC|5.006000||p +WARN_ONCE|5.006000||p +WARN_OVERFLOW|5.006000||p +WARN_PACK|5.006000||p +WARN_PARENTHESIS|5.006000||p +WARN_PIPE|5.006000||p +WARN_PORTABLE|5.006000||p +WARN_PRECEDENCE|5.006000||p +WARN_PRINTF|5.006000||p +WARN_PROTOTYPE|5.006000||p +WARN_QW|5.006000||p +WARN_RECURSION|5.006000||p +WARN_REDEFINE|5.006000||p +WARN_REGEXP|5.006000||p +WARN_RESERVED|5.006000||p +WARN_SEMICOLON|5.006000||p +WARN_SEVERE|5.006000||p +WARN_SIGNAL|5.006000||p +WARN_SUBSTR|5.006000||p +WARN_SYNTAX|5.006000||p +WARN_TAINT|5.006000||p +WARN_THREADS|5.008000||p +WARN_UNINITIALIZED|5.006000||p +WARN_UNOPENED|5.006000||p +WARN_UNPACK|5.006000||p +WARN_UNTIE|5.006000||p +WARN_UTF8|5.006000||p +WARN_VOID|5.006000||p +XCPT_CATCH|5.009002||p +XCPT_RETHROW|5.009002||p +XCPT_TRY_END|5.009002||p +XCPT_TRY_START|5.009002||p +XPUSHi||| +XPUSHmortal|5.009002||p +XPUSHn||| +XPUSHp||| +XPUSHs||| +XPUSHu|5.004000||p +XSRETURN_EMPTY||| +XSRETURN_IV||| +XSRETURN_NO||| +XSRETURN_NV||| +XSRETURN_PV||| +XSRETURN_UNDEF||| +XSRETURN_UV|5.008001||p +XSRETURN_YES||| +XSRETURN|||p +XST_mIV||| +XST_mNO||| +XST_mNV||| +XST_mPV||| +XST_mUNDEF||| +XST_mUV|5.008001||p +XST_mYES||| +XS_VERSION_BOOTCHECK||| +XS_VERSION||| +XSprePUSH|5.006000||p +XS||| +ZeroD|5.009002||p +Zero||| +_aMY_CXT|5.007003||p +_pMY_CXT|5.007003||p +aMY_CXT_|5.007003||p +aMY_CXT|5.007003||p +aTHXR_|5.011000||p +aTHXR|5.011000||p +aTHX_|5.006000||p +aTHX|5.006000||p +add_data|||n +addmad||| +allocmy||| +amagic_call||| +amagic_cmp_locale||| +amagic_cmp||| +amagic_i_ncmp||| +amagic_ncmp||| +any_dup||| +ao||| +append_elem||| +append_list||| +append_madprops||| +apply_attrs_my||| +apply_attrs_string||5.006001| +apply_attrs||| +apply||| +atfork_lock||5.007003|n +atfork_unlock||5.007003|n +av_arylen_p||5.009003| +av_clear||| +av_create_and_push||5.009005| +av_create_and_unshift_one||5.009005| +av_delete||5.006000| +av_exists||5.006000| +av_extend||| +av_fake||| +av_fetch||| +av_fill||| +av_iter_p||5.011000| +av_len||| +av_make||| +av_pop||| +av_push||| +av_reify||| +av_shift||| +av_store||| +av_undef||| +av_unshift||| +ax|||n +bad_type||| +bind_match||| +block_end||| +block_gimme||5.004000| +block_start||| +boolSV|5.004000||p +boot_core_PerlIO||| +boot_core_UNIVERSAL||| +boot_core_mro||| +boot_core_xsutils||| +bytes_from_utf8||5.007001| +bytes_to_uni|||n +bytes_to_utf8||5.006001| +call_argv|5.006000||p +call_atexit||5.006000| +call_list||5.004000| +call_method|5.006000||p +call_pv|5.006000||p +call_sv|5.006000||p +calloc||5.007002|n +cando||| +cast_i32||5.006000| +cast_iv||5.006000| +cast_ulong||5.006000| +cast_uv||5.006000| +check_type_and_open||| +check_uni||| +checkcomma||| +checkposixcc||| +ckWARN|5.006000||p +ck_anoncode||| +ck_bitop||| +ck_concat||| +ck_defined||| +ck_delete||| +ck_die||| +ck_each||| +ck_eof||| +ck_eval||| +ck_exec||| +ck_exists||| +ck_exit||| +ck_ftst||| +ck_fun||| +ck_glob||| +ck_grep||| +ck_index||| +ck_join||| +ck_lfun||| +ck_listiob||| +ck_match||| +ck_method||| +ck_null||| +ck_open||| +ck_readline||| +ck_repeat||| +ck_require||| +ck_return||| +ck_rfun||| +ck_rvconst||| +ck_sassign||| +ck_select||| +ck_shift||| +ck_sort||| +ck_spair||| +ck_split||| +ck_subr||| +ck_substr||| +ck_svconst||| +ck_trunc||| +ck_unpack||| +ckwarn_d||5.009003| +ckwarn||5.009003| +cl_and|||n +cl_anything|||n +cl_init_zero|||n +cl_init|||n +cl_is_anything|||n +cl_or|||n +clear_placeholders||| +closest_cop||| +convert||| +cop_free||| +cr_textfilter||| +create_eval_scope||| +croak_nocontext|||vn +croak_xs_usage||5.011000| +croak|||v +csighandler||5.009003|n +curmad||| +custom_op_desc||5.007003| +custom_op_name||5.007003| +cv_ckproto_len||| +cv_ckproto||| +cv_clone||| +cv_const_sv||5.004000| +cv_dump||| +cv_undef||| +cx_dump||5.005000| +cx_dup||| +cxinc||| +dAXMARK|5.009003||p +dAX|5.007002||p +dITEMS|5.007002||p +dMARK||| +dMULTICALL||5.009003| +dMY_CXT_SV|5.007003||p +dMY_CXT|5.007003||p +dNOOP|5.006000||p +dORIGMARK||| +dSP||| +dTHR|5.004050||p +dTHXR|5.011000||p +dTHXa|5.006000||p +dTHXoa|5.006000||p +dTHX|5.006000||p +dUNDERBAR|5.009002||p +dVAR|5.009003||p +dXCPT|5.009002||p +dXSARGS||| +dXSI32||| +dXSTARG|5.006000||p +deb_curcv||| +deb_nocontext|||vn +deb_stack_all||| +deb_stack_n||| +debop||5.005000| +debprofdump||5.005000| +debprof||| +debstackptrs||5.007003| +debstack||5.007003| +debug_start_match||| +deb||5.007003|v +del_sv||| +delete_eval_scope||| +delimcpy||5.004000| +deprecate_old||| +deprecate||| +despatch_signals||5.007001| +destroy_matcher||| +die_nocontext|||vn +die_where||| +die|||v +dirp_dup||| +div128||| +djSP||| +do_aexec5||| +do_aexec||| +do_aspawn||| +do_binmode||5.004050| +do_chomp||| +do_chop||| +do_close||| +do_dump_pad||| +do_eof||| +do_exec3||| +do_execfree||| +do_exec||| +do_gv_dump||5.006000| +do_gvgv_dump||5.006000| +do_hv_dump||5.006000| +do_ipcctl||| +do_ipcget||| +do_join||| +do_kv||| +do_magic_dump||5.006000| +do_msgrcv||| +do_msgsnd||| +do_oddball||| +do_op_dump||5.006000| +do_op_xmldump||| +do_open9||5.006000| +do_openn||5.007001| +do_open||5.004000| +do_pmop_dump||5.006000| +do_pmop_xmldump||| +do_print||| +do_readline||| +do_seek||| +do_semop||| +do_shmio||| +do_smartmatch||| +do_spawn_nowait||| +do_spawn||| +do_sprintf||| +do_sv_dump||5.006000| +do_sysseek||| +do_tell||| +do_trans_complex_utf8||| +do_trans_complex||| +do_trans_count_utf8||| +do_trans_count||| +do_trans_simple_utf8||| +do_trans_simple||| +do_trans||| +do_vecget||| +do_vecset||| +do_vop||| +docatch||| +doeval||| +dofile||| +dofindlabel||| +doform||| +doing_taint||5.008001|n +dooneliner||| +doopen_pm||| +doparseform||| +dopoptoeval||| +dopoptogiven||| +dopoptolabel||| +dopoptoloop||| +dopoptosub_at||| +dopoptowhen||| +doref||5.009003| +dounwind||| +dowantarray||| +dump_all||5.006000| +dump_eval||5.006000| +dump_exec_pos||| +dump_fds||| +dump_form||5.006000| +dump_indent||5.006000|v +dump_mstats||| +dump_packsubs||5.006000| +dump_sub||5.006000| +dump_sv_child||| +dump_trie_interim_list||| +dump_trie_interim_table||| +dump_trie||| +dump_vindent||5.006000| +dumpuntil||| +dup_attrlist||| +emulate_cop_io||| +eval_pv|5.006000||p +eval_sv|5.006000||p +exec_failed||| +expect_number||| +fbm_compile||5.005000| +fbm_instr||5.005000| +fd_on_nosuid_fs||| +feature_is_enabled||| +fetch_cop_label||5.011000| +filter_add||| +filter_del||| +filter_gets||| +filter_read||| +find_and_forget_pmops||| +find_array_subscript||| +find_beginning||| +find_byclass||| +find_hash_subscript||| +find_in_my_stash||| +find_runcv||5.008001| +find_rundefsvoffset||5.009002| +find_script||| +find_uninit_var||| +first_symbol|||n +fold_constants||| +forbid_setid||| +force_ident||| +force_list||| +force_next||| +force_version||| +force_word||| +forget_pmop||| +form_nocontext|||vn +form||5.004000|v +fp_dup||| +fprintf_nocontext|||vn +free_global_struct||| +free_tied_hv_pool||| +free_tmps||| +gen_constant_list||| +get_arena||| +get_aux_mg||| +get_av|5.006000||p +get_context||5.006000|n +get_cvn_flags||5.009005| +get_cv|5.006000||p +get_db_sub||| +get_debug_opts||| +get_hash_seed||| +get_hv|5.006000||p +get_mstats||| +get_no_modify||| +get_num||| +get_op_descs||5.005000| +get_op_names||5.005000| +get_opargs||| +get_ppaddr||5.006000| +get_re_arg||| +get_sv|5.006000||p +get_vtbl||5.005030| +getcwd_sv||5.007002| +getenv_len||| +glob_2number||| +glob_2pv||| +glob_assign_glob||| +glob_assign_ref||| +gp_dup||| +gp_free||| +gp_ref||| +grok_bin|5.007003||p +grok_hex|5.007003||p +grok_number|5.007002||p +grok_numeric_radix|5.007002||p +grok_oct|5.007003||p +group_end||| +gv_AVadd||| +gv_HVadd||| +gv_IOadd||| +gv_SVadd||| +gv_autoload4||5.004000| +gv_check||| +gv_const_sv||5.009003| +gv_dump||5.006000| +gv_efullname3||5.004000| +gv_efullname4||5.006001| +gv_efullname||| +gv_ename||| +gv_fetchfile_flags||5.009005| +gv_fetchfile||| +gv_fetchmeth_autoload||5.007003| +gv_fetchmethod_autoload||5.004000| +gv_fetchmethod_flags||5.011000| +gv_fetchmethod||| +gv_fetchmeth||| +gv_fetchpvn_flags||5.009002| +gv_fetchpv||| +gv_fetchsv||5.009002| +gv_fullname3||5.004000| +gv_fullname4||5.006001| +gv_fullname||| +gv_get_super_pkg||| +gv_handler||5.007001| +gv_init_sv||| +gv_init||| +gv_name_set||5.009004| +gv_stashpvn|5.004000||p +gv_stashpvs||5.009003| +gv_stashpv||| +gv_stashsv||| +he_dup||| +hek_dup||| +hfreeentries||| +hsplit||| +hv_assert||5.011000| +hv_auxinit|||n +hv_backreferences_p||| +hv_clear_placeholders||5.009001| +hv_clear||| +hv_common_key_len||5.010000| +hv_common||5.010000| +hv_copy_hints_hv||| +hv_delayfree_ent||5.004000| +hv_delete_common||| +hv_delete_ent||5.004000| +hv_delete||| +hv_eiter_p||5.009003| +hv_eiter_set||5.009003| +hv_exists_ent||5.004000| +hv_exists||| +hv_fetch_ent||5.004000| +hv_fetchs|5.009003||p +hv_fetch||| +hv_free_ent||5.004000| +hv_iterinit||| +hv_iterkeysv||5.004000| +hv_iterkey||| +hv_iternext_flags||5.008000| +hv_iternextsv||| +hv_iternext||| +hv_iterval||| +hv_kill_backrefs||| +hv_ksplit||5.004000| +hv_magic_check|||n +hv_magic||| +hv_name_set||5.009003| +hv_notallowed||| +hv_placeholders_get||5.009003| +hv_placeholders_p||5.009003| +hv_placeholders_set||5.009003| +hv_riter_p||5.009003| +hv_riter_set||5.009003| +hv_scalar||5.009001| +hv_store_ent||5.004000| +hv_store_flags||5.008000| +hv_stores|5.009004||p +hv_store||| +hv_undef||| +ibcmp_locale||5.004000| +ibcmp_utf8||5.007003| +ibcmp||| +incline||| +incpush_if_exists||| +incpush||| +ingroup||| +init_argv_symbols||| +init_debugger||| +init_global_struct||| +init_i18nl10n||5.006000| +init_i18nl14n||5.006000| +init_ids||| +init_interp||| +init_main_stash||| +init_perllib||| +init_postdump_symbols||| +init_predump_symbols||| +init_stacks||5.005000| +init_tm||5.007002| +instr||| +intro_my||| +intuit_method||| +intuit_more||| +invert||| +io_close||| +isALNUMC|||p +isALNUM||| +isALPHA||| +isASCII|||p +isBLANK|||p +isCNTRL|||p +isDIGIT||| +isGRAPH|||p +isLOWER||| +isPRINT|||p +isPSXSPC|||p +isPUNCT|||p +isSPACE||| +isUPPER||| +isXDIGIT|||p +is_an_int||| +is_gv_magical_sv||| +is_gv_magical||| +is_handle_constructor|||n +is_list_assignment||| +is_lvalue_sub||5.007001| +is_uni_alnum_lc||5.006000| +is_uni_alnumc_lc||5.006000| +is_uni_alnumc||5.006000| +is_uni_alnum||5.006000| +is_uni_alpha_lc||5.006000| +is_uni_alpha||5.006000| +is_uni_ascii_lc||5.006000| +is_uni_ascii||5.006000| +is_uni_cntrl_lc||5.006000| +is_uni_cntrl||5.006000| +is_uni_digit_lc||5.006000| +is_uni_digit||5.006000| +is_uni_graph_lc||5.006000| +is_uni_graph||5.006000| +is_uni_idfirst_lc||5.006000| +is_uni_idfirst||5.006000| +is_uni_lower_lc||5.006000| +is_uni_lower||5.006000| +is_uni_print_lc||5.006000| +is_uni_print||5.006000| +is_uni_punct_lc||5.006000| +is_uni_punct||5.006000| +is_uni_space_lc||5.006000| +is_uni_space||5.006000| +is_uni_upper_lc||5.006000| +is_uni_upper||5.006000| +is_uni_xdigit_lc||5.006000| +is_uni_xdigit||5.006000| +is_utf8_alnumc||5.006000| +is_utf8_alnum||5.006000| +is_utf8_alpha||5.006000| +is_utf8_ascii||5.006000| +is_utf8_char_slow|||n +is_utf8_char||5.006000| +is_utf8_cntrl||5.006000| +is_utf8_common||| +is_utf8_digit||5.006000| +is_utf8_graph||5.006000| +is_utf8_idcont||5.008000| +is_utf8_idfirst||5.006000| +is_utf8_lower||5.006000| +is_utf8_mark||5.006000| +is_utf8_print||5.006000| +is_utf8_punct||5.006000| +is_utf8_space||5.006000| +is_utf8_string_loclen||5.009003| +is_utf8_string_loc||5.008001| +is_utf8_string||5.006001| +is_utf8_upper||5.006000| +is_utf8_xdigit||5.006000| +isa_lookup||| +items|||n +ix|||n +jmaybe||| +join_exact||| +keyword||| +leave_scope||| +lex_end||| +lex_start||| +linklist||| +listkids||| +list||| +load_module_nocontext|||vn +load_module|5.006000||pv +localize||| +looks_like_bool||| +looks_like_number||| +lop||| +mPUSHi|5.009002||p +mPUSHn|5.009002||p +mPUSHp|5.009002||p +mPUSHs|5.011000||p +mPUSHu|5.009002||p +mXPUSHi|5.009002||p +mXPUSHn|5.009002||p +mXPUSHp|5.009002||p +mXPUSHs|5.011000||p +mXPUSHu|5.009002||p +mad_free||| +madlex||| +madparse||| +magic_clear_all_env||| +magic_clearenv||| +magic_clearhint||| +magic_clearisa||| +magic_clearpack||| +magic_clearsig||| +magic_dump||5.006000| +magic_existspack||| +magic_freearylen_p||| +magic_freeovrld||| +magic_getarylen||| +magic_getdefelem||| +magic_getnkeys||| +magic_getpack||| +magic_getpos||| +magic_getsig||| +magic_getsubstr||| +magic_gettaint||| +magic_getuvar||| +magic_getvec||| +magic_get||| +magic_killbackrefs||| +magic_len||| +magic_methcall||| +magic_methpack||| +magic_nextpack||| +magic_regdata_cnt||| +magic_regdatum_get||| +magic_regdatum_set||| +magic_scalarpack||| +magic_set_all_env||| +magic_setamagic||| +magic_setarylen||| +magic_setcollxfrm||| +magic_setdbline||| +magic_setdefelem||| +magic_setenv||| +magic_sethint||| +magic_setisa||| +magic_setmglob||| +magic_setnkeys||| +magic_setpack||| +magic_setpos||| +magic_setregexp||| +magic_setsig||| +magic_setsubstr||| +magic_settaint||| +magic_setutf8||| +magic_setuvar||| +magic_setvec||| +magic_set||| +magic_sizepack||| +magic_wipepack||| +magicname||| +make_matcher||| +make_trie_failtable||| +make_trie||| +malloc_good_size|||n +malloced_size|||n +malloc||5.007002|n +markstack_grow||| +matcher_matches_sv||| +measure_struct||| +memEQ|5.004000||p +memNE|5.004000||p +mem_collxfrm||| +mess_alloc||| +mess_nocontext|||vn +mess||5.006000|v +method_common||| +mfree||5.007002|n +mg_clear||| +mg_copy||| +mg_dup||| +mg_find||| +mg_free||| +mg_get||| +mg_length||5.005000| +mg_localize||| +mg_magical||| +mg_set||| +mg_size||5.005000| +mini_mktime||5.007002| +missingterm||| +mode_from_discipline||| +modkids||| +mod||| +more_bodies||| +more_sv||| +moreswitches||| +mro_get_linear_isa_c3||| +mro_get_linear_isa_dfs||| +mro_get_linear_isa||5.009005| +mro_isa_changed_in||| +mro_meta_dup||| +mro_meta_init||| +mro_method_changed_in||5.009005| +mul128||| +mulexp10|||n +my_atof2||5.007002| +my_atof||5.006000| +my_attrs||| +my_bcopy|||n +my_betoh16|||n +my_betoh32|||n +my_betoh64|||n +my_betohi|||n +my_betohl|||n +my_betohs|||n +my_bzero|||n +my_chsize||| +my_clearenv||| +my_cxt_index||| +my_cxt_init||| +my_dirfd||5.009005| +my_exit_jump||| +my_exit||| +my_failure_exit||5.004000| +my_fflush_all||5.006000| +my_fork||5.007003|n +my_htobe16|||n +my_htobe32|||n +my_htobe64|||n +my_htobei|||n +my_htobel|||n +my_htobes|||n +my_htole16|||n +my_htole32|||n +my_htole64|||n +my_htolei|||n +my_htolel|||n +my_htoles|||n +my_htonl||| +my_kid||| +my_letoh16|||n +my_letoh32|||n +my_letoh64|||n +my_letohi|||n +my_letohl|||n +my_letohs|||n +my_lstat||| +my_memcmp||5.004000|n +my_memset|||n +my_ntohl||| +my_pclose||5.004000| +my_popen_list||5.007001| +my_popen||5.004000| +my_setenv||| +my_snprintf|5.009004||pvn +my_socketpair||5.007003|n +my_sprintf|5.009003||pvn +my_stat||| +my_strftime||5.007002| +my_strlcat|5.009004||pn +my_strlcpy|5.009004||pn +my_swabn|||n +my_swap||| +my_unexec||| +my_vsnprintf||5.009004|n +my||| +need_utf8|||n +newANONATTRSUB||5.006000| +newANONHASH||| +newANONLIST||| +newANONSUB||| +newASSIGNOP||| +newATTRSUB||5.006000| +newAVREF||| +newAV||| +newBINOP||| +newCONDOP||| +newCONSTSUB|5.004050||p +newCVREF||| +newDEFSVOP||| +newFORM||| +newFOROP||| +newGIVENOP||5.009003| +newGIVWHENOP||| +newGP||| +newGVOP||| +newGVREF||| +newGVgen||| +newHVREF||| +newHVhv||5.005000| +newHV||| +newIO||| +newLISTOP||| +newLOGOP||| +newLOOPEX||| +newLOOPOP||| +newMADPROP||| +newMADsv||| +newMYSUB||| +newNULLLIST||| +newOP||| +newPADOP||| +newPMOP||| +newPROG||| +newPVOP||| +newRANGE||| +newRV_inc|5.004000||p +newRV_noinc|5.004000||p +newRV||| +newSLICEOP||| +newSTATEOP||| +newSUB||| +newSVOP||| +newSVREF||| +newSV_type||5.009005| +newSVhek||5.009003| +newSViv||| +newSVnv||| +newSVpvf_nocontext|||vn +newSVpvf||5.004000|v +newSVpvn_flags|5.011000||p +newSVpvn_share|5.007001||p +newSVpvn_utf8|5.011000||p +newSVpvn|5.004050||p +newSVpvs_flags|5.011000||p +newSVpvs_share||5.009003| +newSVpvs|5.009003||p +newSVpv||| +newSVrv||| +newSVsv||| +newSVuv|5.006000||p +newSV||| +newTOKEN||| +newUNOP||| +newWHENOP||5.009003| +newWHILEOP||5.009003| +newXS_flags||5.009004| +newXSproto||5.006000| +newXS||5.006000| +new_collate||5.006000| +new_constant||| +new_ctype||5.006000| +new_he||| +new_logop||| +new_numeric||5.006000| +new_stackinfo||5.005000| +new_version||5.009000| +new_warnings_bitfield||| +next_symbol||| +nextargv||| +nextchar||| +ninstr||| +no_bareword_allowed||| +no_fh_allowed||| +no_op||| +not_a_number||| +nothreadhook||5.008000| +nuke_stacks||| +num_overflow|||n +offer_nice_chunk||| +oopsAV||| +oopsCV||| +oopsHV||| +op_clear||| +op_const_sv||| +op_dump||5.006000| +op_free||| +op_getmad_weak||| +op_getmad||| +op_null||5.007002| +op_refcnt_dec||| +op_refcnt_inc||| +op_refcnt_lock||5.009002| +op_refcnt_unlock||5.009002| +op_xmldump||| +open_script||| +pMY_CXT_|5.007003||p +pMY_CXT|5.007003||p +pTHX_|5.006000||p +pTHX|5.006000||p +packWARN|5.007003||p +pack_cat||5.007003| +pack_rec||| +package||| +packlist||5.008001| +pad_add_anon||| +pad_add_name||| +pad_alloc||| +pad_block_start||| +pad_check_dup||| +pad_compname_type||| +pad_findlex||| +pad_findmy||| +pad_fixup_inner_anons||| +pad_free||| +pad_leavemy||| +pad_new||| +pad_peg|||n +pad_push||| +pad_reset||| +pad_setsv||| +pad_sv||5.011000| +pad_swipe||| +pad_tidy||| +pad_undef||| +parse_body||| +parse_unicode_opts||| +parser_dup||| +parser_free||| +path_is_absolute|||n +peep||| +pending_Slabs_to_ro||| +perl_alloc_using|||n +perl_alloc|||n +perl_clone_using|||n +perl_clone|||n +perl_construct|||n +perl_destruct||5.007003|n +perl_free|||n +perl_parse||5.006000|n +perl_run|||n +pidgone||| +pm_description||| +pmflag||| +pmop_dump||5.006000| +pmop_xmldump||| +pmruntime||| +pmtrans||| +pop_scope||| +pregcomp||5.009005| +pregexec||| +pregfree2||5.011000| +pregfree||| +prepend_elem||| +prepend_madprops||| +printbuf||| +printf_nocontext|||vn +process_special_blocks||| +ptr_table_clear||5.009005| +ptr_table_fetch||5.009005| +ptr_table_find|||n +ptr_table_free||5.009005| +ptr_table_new||5.009005| +ptr_table_split||5.009005| +ptr_table_store||5.009005| +push_scope||| +put_byte||| +pv_display|5.006000||p +pv_escape|5.009004||p +pv_pretty|5.009004||p +pv_uni_display||5.007003| +qerror||| +qsortsvu||| +re_compile||5.009005| +re_croak2||| +re_dup_guts||| +re_intuit_start||5.009005| +re_intuit_string||5.006000| +readpipe_override||| +realloc||5.007002|n +reentrant_free||| +reentrant_init||| +reentrant_retry|||vn +reentrant_size||| +ref_array_or_hash||| +refcounted_he_chain_2hv||| +refcounted_he_fetch||| +refcounted_he_free||| +refcounted_he_new_common||| +refcounted_he_new||| +refcounted_he_value||| +refkids||| +refto||| +ref||5.011000| +reg_check_named_buff_matched||| +reg_named_buff_all||5.009005| +reg_named_buff_exists||5.009005| +reg_named_buff_fetch||5.009005| +reg_named_buff_firstkey||5.009005| +reg_named_buff_iter||| +reg_named_buff_nextkey||5.009005| +reg_named_buff_scalar||5.009005| +reg_named_buff||| +reg_namedseq||| +reg_node||| +reg_numbered_buff_fetch||| +reg_numbered_buff_length||| +reg_numbered_buff_store||| +reg_qr_package||| +reg_recode||| +reg_scan_name||| +reg_skipcomment||| +reg_temp_copy||| +reganode||| +regatom||| +regbranch||| +regclass_swash||5.009004| +regclass||| +regcppop||| +regcppush||| +regcurly|||n +regdump_extflags||| +regdump||5.005000| +regdupe_internal||| +regexec_flags||5.005000| +regfree_internal||5.009005| +reghop3|||n +reghop4|||n +reghopmaybe3|||n +reginclass||| +reginitcolors||5.006000| +reginsert||| +regmatch||| +regnext||5.005000| +regpiece||| +regpposixcc||| +regprop||| +regrepeat||| +regtail_study||| +regtail||| +regtry||| +reguni||| +regwhite|||n +reg||| +repeatcpy||| +report_evil_fh||| +report_uninit||| +require_pv||5.006000| +require_tie_mod||| +restore_magic||| +rninstr||| +rsignal_restore||| +rsignal_save||| +rsignal_state||5.004000| +rsignal||5.004000| +run_body||| +run_user_filter||| +runops_debug||5.005000| +runops_standard||5.005000| +rvpv_dup||| +rxres_free||| +rxres_restore||| +rxres_save||| +safesyscalloc||5.006000|n +safesysfree||5.006000|n +safesysmalloc||5.006000|n +safesysrealloc||5.006000|n +same_dirent||| +save_I16||5.004000| +save_I32||| +save_I8||5.006000| +save_aelem||5.004050| +save_alloc||5.006000| +save_aptr||| +save_ary||| +save_bool||5.008001| +save_clearsv||| +save_delete||| +save_destructor_x||5.006000| +save_destructor||5.006000| +save_freeop||| +save_freepv||| +save_freesv||| +save_generic_pvref||5.006001| +save_generic_svref||5.005030| +save_gp||5.004000| +save_hash||| +save_hek_flags|||n +save_helem||5.004050| +save_hptr||| +save_int||| +save_item||| +save_iv||5.005000| +save_lines||| +save_list||| +save_long||| +save_magic||| +save_mortalizesv||5.007001| +save_nogv||| +save_op||| +save_padsv_and_mortalize||5.011000| +save_pptr||| +save_re_context||5.006000| +save_scalar_at||| +save_scalar||| +save_set_svflags||5.009000| +save_shared_pvref||5.007003| +save_sptr||| +save_svref||| +save_vptr||5.006000| +savepvn||| +savepvs||5.009003| +savepv||| +savesharedpvn||5.009005| +savesharedpv||5.007003| +savestack_grow_cnt||5.008001| +savestack_grow||| +savesvpv||5.009002| +sawparens||| +scalar_mod_type|||n +scalarboolean||| +scalarkids||| +scalarseq||| +scalarvoid||| +scalar||| +scan_bin||5.006000| +scan_commit||| +scan_const||| +scan_formline||| +scan_heredoc||| +scan_hex||| +scan_ident||| +scan_inputsymbol||| +scan_num||5.007001| +scan_oct||| +scan_pat||| +scan_str||| +scan_subst||| +scan_trans||| +scan_version||5.009001| +scan_vstring||5.009005| +scan_word||| +scope||| +screaminstr||5.005000| +seed||5.008001| +sequence_num||| +sequence_tail||| +sequence||| +set_context||5.006000|n +set_numeric_local||5.006000| +set_numeric_radix||5.006000| +set_numeric_standard||5.006000| +setdefout||| +setenv_getix||| +share_hek_flags||| +share_hek||5.004000| +si_dup||| +sighandler|||n +simplify_sort||| +skipspace0||| +skipspace1||| +skipspace2||| +skipspace||| +softref2xv||| +sortcv_stacked||| +sortcv_xsub||| +sortcv||| +sortsv_flags||5.009003| +sortsv||5.007003| +space_join_names_mortal||| +ss_dup||| +stack_grow||| +start_force||| +start_glob||| +start_subparse||5.004000| +stashpv_hvname_match||5.011000| +stdize_locale||| +store_cop_label||| +strEQ||| +strGE||| +strGT||| +strLE||| +strLT||| +strNE||| +str_to_version||5.006000| +strip_return||| +strnEQ||| +strnNE||| +study_chunk||| +sub_crush_depth||| +sublex_done||| +sublex_push||| +sublex_start||| +sv_2bool||| +sv_2cv||| +sv_2io||| +sv_2iuv_common||| +sv_2iuv_non_preserve||| +sv_2iv_flags||5.009001| +sv_2iv||| +sv_2mortal||| +sv_2num||| +sv_2nv||| +sv_2pv_flags|5.007002||p +sv_2pv_nolen|5.006000||p +sv_2pvbyte_nolen|5.006000||p +sv_2pvbyte|5.006000||p +sv_2pvutf8_nolen||5.006000| +sv_2pvutf8||5.006000| +sv_2pv||| +sv_2uv_flags||5.009001| +sv_2uv|5.004000||p +sv_add_arena||| +sv_add_backref||| +sv_backoff||| +sv_bless||| +sv_cat_decode||5.008001| +sv_catpv_mg|5.004050||p +sv_catpvf_mg_nocontext|||pvn +sv_catpvf_mg|5.006000|5.004000|pv +sv_catpvf_nocontext|||vn +sv_catpvf||5.004000|v +sv_catpvn_flags||5.007002| +sv_catpvn_mg|5.004050||p +sv_catpvn_nomg|5.007002||p +sv_catpvn||| +sv_catpvs|5.009003||p +sv_catpv||| +sv_catsv_flags||5.007002| +sv_catsv_mg|5.004050||p +sv_catsv_nomg|5.007002||p +sv_catsv||| +sv_catxmlpvn||| +sv_catxmlsv||| +sv_chop||| +sv_clean_all||| +sv_clean_objs||| +sv_clear||| +sv_cmp_locale||5.004000| +sv_cmp||| +sv_collxfrm||| +sv_compile_2op||5.008001| +sv_copypv||5.007003| +sv_dec||| +sv_del_backref||| +sv_derived_from||5.004000| +sv_destroyable||5.010000| +sv_does||5.009004| +sv_dump||| +sv_dup||| +sv_eq||| +sv_exp_grow||| +sv_force_normal_flags||5.007001| +sv_force_normal||5.006000| +sv_free2||| +sv_free_arenas||| +sv_free||| +sv_gets||5.004000| +sv_grow||| +sv_i_ncmp||| +sv_inc||| +sv_insert_flags||5.011000| +sv_insert||| +sv_isa||| +sv_isobject||| +sv_iv||5.005000| +sv_kill_backrefs||| +sv_len_utf8||5.006000| +sv_len||| +sv_magic_portable|5.011000|5.004000|p +sv_magicext||5.007003| +sv_magic||| +sv_mortalcopy||| +sv_ncmp||| +sv_newmortal||| +sv_newref||| +sv_nolocking||5.007003| +sv_nosharing||5.007003| +sv_nounlocking||| +sv_nv||5.005000| +sv_peek||5.005000| +sv_pos_b2u_midway||| +sv_pos_b2u||5.006000| +sv_pos_u2b_cached||| +sv_pos_u2b_forwards|||n +sv_pos_u2b_midway|||n +sv_pos_u2b||5.006000| +sv_pvbyten_force||5.006000| +sv_pvbyten||5.006000| +sv_pvbyte||5.006000| +sv_pvn_force_flags|5.007002||p +sv_pvn_force||| +sv_pvn_nomg|5.007003|5.005000|p +sv_pvn||5.005000| +sv_pvutf8n_force||5.006000| +sv_pvutf8n||5.006000| +sv_pvutf8||5.006000| +sv_pv||5.006000| +sv_recode_to_utf8||5.007003| +sv_reftype||| +sv_release_COW||| +sv_replace||| +sv_report_used||| +sv_reset||| +sv_rvweaken||5.006000| +sv_setiv_mg|5.004050||p +sv_setiv||| +sv_setnv_mg|5.006000||p +sv_setnv||| +sv_setpv_mg|5.004050||p +sv_setpvf_mg_nocontext|||pvn +sv_setpvf_mg|5.006000|5.004000|pv +sv_setpvf_nocontext|||vn +sv_setpvf||5.004000|v +sv_setpviv_mg||5.008001| +sv_setpviv||5.008001| +sv_setpvn_mg|5.004050||p +sv_setpvn||| +sv_setpvs|5.009004||p +sv_setpv||| +sv_setref_iv||| +sv_setref_nv||| +sv_setref_pvn||| +sv_setref_pv||| +sv_setref_uv||5.007001| +sv_setsv_cow||| +sv_setsv_flags||5.007002| +sv_setsv_mg|5.004050||p +sv_setsv_nomg|5.007002||p +sv_setsv||| +sv_setuv_mg|5.004050||p +sv_setuv|5.004000||p +sv_tainted||5.004000| +sv_taint||5.004000| +sv_true||5.005000| +sv_unglob||| +sv_uni_display||5.007003| +sv_unmagic||| +sv_unref_flags||5.007001| +sv_unref||| +sv_untaint||5.004000| +sv_upgrade||| +sv_usepvn_flags||5.009004| +sv_usepvn_mg|5.004050||p +sv_usepvn||| +sv_utf8_decode||5.006000| +sv_utf8_downgrade||5.006000| +sv_utf8_encode||5.006000| +sv_utf8_upgrade_flags||5.007002| +sv_utf8_upgrade||5.007001| +sv_uv|5.005000||p +sv_vcatpvf_mg|5.006000|5.004000|p +sv_vcatpvfn||5.004000| +sv_vcatpvf|5.006000|5.004000|p +sv_vsetpvf_mg|5.006000|5.004000|p +sv_vsetpvfn||5.004000| +sv_vsetpvf|5.006000|5.004000|p +sv_xmlpeek||| +svtype||| +swallow_bom||| +swap_match_buff||| +swash_fetch||5.007002| +swash_get||| +swash_init||5.006000| +sys_init3||5.010000|n +sys_init||5.010000|n +sys_intern_clear||| +sys_intern_dup||| +sys_intern_init||| +sys_term||5.010000|n +taint_env||| +taint_proper||| +tmps_grow||5.006000| +toLOWER||| +toUPPER||| +to_byte_substr||| +to_uni_fold||5.007003| +to_uni_lower_lc||5.006000| +to_uni_lower||5.007003| +to_uni_title_lc||5.006000| +to_uni_title||5.007003| +to_uni_upper_lc||5.006000| +to_uni_upper||5.007003| +to_utf8_case||5.007003| +to_utf8_fold||5.007003| +to_utf8_lower||5.007003| +to_utf8_substr||| +to_utf8_title||5.007003| +to_utf8_upper||5.007003| +token_free||| +token_getmad||| +tokenize_use||| +tokeq||| +tokereport||| +too_few_arguments||| +too_many_arguments||| +uiv_2buf|||n +unlnk||| +unpack_rec||| +unpack_str||5.007003| +unpackstring||5.008001| +unshare_hek_or_pvn||| +unshare_hek||| +unsharepvn||5.004000| +unwind_handler_stack||| +update_debugger_info||| +upg_version||5.009005| +usage||| +utf16_to_utf8_reversed||5.006001| +utf16_to_utf8||5.006001| +utf8_distance||5.006000| +utf8_hop||5.006000| +utf8_length||5.007001| +utf8_mg_pos_cache_update||| +utf8_to_bytes||5.006001| +utf8_to_uvchr||5.007001| +utf8_to_uvuni||5.007001| +utf8n_to_uvchr||| +utf8n_to_uvuni||5.007001| +utilize||| +uvchr_to_utf8_flags||5.007003| +uvchr_to_utf8||| +uvuni_to_utf8_flags||5.007003| +uvuni_to_utf8||5.007001| +validate_suid||| +varname||| +vcmp||5.009000| +vcroak||5.006000| +vdeb||5.007003| +vdie_common||| +vdie_croak_common||| +vdie||| +vform||5.006000| +visit||| +vivify_defelem||| +vivify_ref||| +vload_module|5.006000||p +vmess||5.006000| +vnewSVpvf|5.006000|5.004000|p +vnormal||5.009002| +vnumify||5.009000| +vstringify||5.009000| +vverify||5.009003| +vwarner||5.006000| +vwarn||5.006000| +wait4pid||| +warn_nocontext|||vn +warner_nocontext|||vn +warner|5.006000|5.004000|pv +warn|||v +watch||| +whichsig||| +write_no_mem||| +write_to_stderr||| +xmldump_all||| +xmldump_attr||| +xmldump_eval||| +xmldump_form||| +xmldump_indent|||v +xmldump_packsubs||| +xmldump_sub||| +xmldump_vindent||| +yyerror||| +yylex||| +yyparse||| +yywarn||| +); + +if (exists $opt{'list-unsupported'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{todo}; + print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; + } + exit 0; +} + +# Scan for possible replacement candidates + +my(%replace, %need, %hints, %warnings, %depends); +my $replace = 0; +my($hint, $define, $function); + +sub find_api +{ + my $code = shift; + $code =~ s{ + / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) + | "[^"\\]*(?:\\.[^"\\]*)*" + | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx; + grep { exists $API{$_} } $code =~ /(\w+)/mg; +} + +while () { + if ($hint) { + my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings; + if (m{^\s*\*\s(.*?)\s*$}) { + for (@{$hint->[1]}) { + $h->{$_} ||= ''; # suppress warning with older perls + $h->{$_} .= "$1\n"; + } + } + else { undef $hint } + } + + $hint = [$1, [split /,?\s+/, $2]] + if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$}; + + if ($define) { + if ($define->[1] =~ /\\$/) { + $define->[1] .= $_; + } + else { + if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) { + my @n = find_api($define->[1]); + push @{$depends{$define->[0]}}, @n if @n + } + undef $define; + } + } + + $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)}; + + if ($function) { + if (/^}/) { + if (exists $API{$function->[0]}) { + my @n = find_api($function->[1]); + push @{$depends{$function->[0]}}, @n if @n + } + undef $function; + } + else { + $function->[1] .= $_; + } + } + + $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)}; + + $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; + $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; + $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; + $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; + + if (m{^\s*$rccs\s+(\w+(\s*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { + my @deps = map { s/\s+//g; $_ } split /,/, $3; + my $d; + for $d (map { s/\s+//g; $_ } split /,/, $1) { + push @{$depends{$d}}, @deps; + } + } + + $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; +} + +for (values %depends) { + my %s; + $_ = [sort grep !$s{$_}++, @$_]; +} + +if (exists $opt{'api-info'}) { + my $f; + my $count = 0; + my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$"; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $f =~ /$match/; + print "\n=== $f ===\n\n"; + my $info = 0; + if ($API{$f}{base} || $API{$f}{todo}) { + my $base = format_version($API{$f}{base} || $API{$f}{todo}); + print "Supported at least starting from perl-$base.\n"; + $info++; + } + if ($API{$f}{provided}) { + my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003"; + print "Support by $ppport provided back to perl-$todo.\n"; + print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f}; + print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f}; + print "\n$hints{$f}" if exists $hints{$f}; + print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f}; + $info++; + } + print "No portability information available.\n" unless $info; + $count++; + } + $count or print "Found no API matching '$opt{'api-info'}'."; + print "\n"; + exit 0; +} + +if (exists $opt{'list-provided'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{provided}; + my @flags; + push @flags, 'explicit' if exists $need{$f}; + push @flags, 'depend' if exists $depends{$f}; + push @flags, 'hint' if exists $hints{$f}; + push @flags, 'warning' if exists $warnings{$f}; + my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; + print "$f$flags\n"; + } + exit 0; +} + +my @files; +my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc ); +my $srcext = join '|', map { quotemeta $_ } @srcext; + +if (@ARGV) { + my %seen; + for (@ARGV) { + if (-e) { + if (-f) { + push @files, $_ unless $seen{$_}++; + } + else { warn "'$_' is not a file.\n" } + } + else { + my @new = grep { -f } glob $_ + or warn "'$_' does not exist.\n"; + push @files, grep { !$seen{$_}++ } @new; + } + } +} +else { + eval { + require File::Find; + File::Find::find(sub { + $File::Find::name =~ /($srcext)$/i + and push @files, $File::Find::name; + }, '.'); + }; + if ($@) { + @files = map { glob "*$_" } @srcext; + } +} + +if (!@ARGV || $opt{filter}) { + my(@in, @out); + my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files; + for (@files) { + my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i; + push @{ $out ? \@out : \@in }, $_; + } + if (@ARGV && @out) { + warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out); + } + @files = @in; +} + +die "No input files given!\n" unless @files; + +my(%files, %global, %revreplace); +%revreplace = reverse %replace; +my $filename; +my $patch_opened = 0; + +for $filename (@files) { + unless (open IN, "<$filename") { + warn "Unable to read from $filename: $!\n"; + next; + } + + info("Scanning $filename ..."); + + my $c = do { local $/; }; + close IN; + + my %file = (orig => $c, changes => 0); + + # Temporarily remove C/XS comments and strings from the code + my @ccom; + + $c =~ s{ + ( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]* + | ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* ) + | ( ^$HS*\#[^\r\n]* + | "[^"\\]*(?:\\.[^"\\]*)*" + | '[^'\\]*(?:\\.[^'\\]*)*' + | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) ) + }{ defined $2 and push @ccom, $2; + defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex; + + $file{ccom} = \@ccom; + $file{code} = $c; + $file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m; + + my $func; + + for $func (keys %API) { + my $match = $func; + $match .= "|$revreplace{$func}" if exists $revreplace{$func}; + if ($c =~ /\b(?:Perl_)?($match)\b/) { + $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func}; + $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; + if (exists $API{$func}{provided}) { + $file{uses_provided}{$func}++; + if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { + $file{uses}{$func}++; + my @deps = rec_depend($func); + if (@deps) { + $file{uses_deps}{$func} = \@deps; + for (@deps) { + $file{uses}{$_} = 0 unless exists $file{uses}{$_}; + } + } + for ($func, @deps) { + $file{needs}{$_} = 'static' if exists $need{$_}; + } + } + } + if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { + if ($c =~ /\b$func\b/) { + $file{uses_todo}{$func}++; + } + } + } + } + + while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { + if (exists $need{$2}) { + $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; + } + else { warning("Possibly wrong #define $1 in $filename") } + } + + for (qw(uses needs uses_todo needed_global needed_static)) { + for $func (keys %{$file{$_}}) { + push @{$global{$_}{$func}}, $filename; + } + } + + $files{$filename} = \%file; +} + +# Globally resolve NEED_'s +my $need; +for $need (keys %{$global{needs}}) { + if (@{$global{needs}{$need}} > 1) { + my @targets = @{$global{needs}{$need}}; + my @t = grep $files{$_}{needed_global}{$need}, @targets; + @targets = @t if @t; + @t = grep /\.xs$/i, @targets; + @targets = @t if @t; + my $target = shift @targets; + $files{$target}{needs}{$need} = 'global'; + for (@{$global{needs}{$need}}) { + $files{$_}{needs}{$need} = 'extern' if $_ ne $target; + } + } +} + +for $filename (@files) { + exists $files{$filename} or next; + + info("=== Analyzing $filename ==="); + + my %file = %{$files{$filename}}; + my $func; + my $c = $file{code}; + my $warnings = 0; + + for $func (sort keys %{$file{uses_Perl}}) { + if ($API{$func}{varargs}) { + unless ($API{$func}{nothxarg}) { + my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} + { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); + if ($changes) { + warning("Doesn't pass interpreter argument aTHX to Perl_$func"); + $file{changes} += $changes; + } + } + } + else { + warning("Uses Perl_$func instead of $func"); + $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*} + {$func$1(}g); + } + } + + for $func (sort keys %{$file{uses_replace}}) { + warning("Uses $func instead of $replace{$func}"); + $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); + } + + for $func (sort keys %{$file{uses_provided}}) { + if ($file{uses}{$func}) { + if (exists $file{uses_deps}{$func}) { + diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); + } + else { + diag("Uses $func"); + } + } + $warnings += hint($func); + } + + unless ($opt{quiet}) { + for $func (sort keys %{$file{uses_todo}}) { + print "*** WARNING: Uses $func, which may not be portable below perl ", + format_version($API{$func}{todo}), ", even with '$ppport'\n"; + $warnings++; + } + } + + for $func (sort keys %{$file{needed_static}}) { + my $message = ''; + if (not exists $file{uses}{$func}) { + $message = "No need to define NEED_$func if $func is never used"; + } + elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') { + $message = "No need to define NEED_$func when already needed globally"; + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg); + } + } + + for $func (sort keys %{$file{needed_global}}) { + my $message = ''; + if (not exists $global{uses}{$func}) { + $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; + } + elsif (exists $file{needs}{$func}) { + if ($file{needs}{$func} eq 'extern') { + $message = "No need to define NEED_${func}_GLOBAL when already needed globally"; + } + elsif ($file{needs}{$func} eq 'static') { + $message = "No need to define NEED_${func}_GLOBAL when only used in this file"; + } + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg); + } + } + + $file{needs_inc_ppport} = keys %{$file{uses}}; + + if ($file{needs_inc_ppport}) { + my $pp = ''; + + for $func (sort keys %{$file{needs}}) { + my $type = $file{needs}{$func}; + next if $type eq 'extern'; + my $suffix = $type eq 'global' ? '_GLOBAL' : ''; + unless (exists $file{"needed_$type"}{$func}) { + if ($type eq 'global') { + diag("Files [@{$global{needs}{$func}}] need $func, adding global request"); + } + else { + diag("File needs $func, adding static request"); + } + $pp .= "#define NEED_$func$suffix\n"; + } + } + + if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) { + $pp = ''; + $file{changes}++; + } + + unless ($file{has_inc_ppport}) { + diag("Needs to include '$ppport'"); + $pp .= qq(#include "$ppport"\n) + } + + if ($pp) { + $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms) + || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m) + || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m) + || ($c =~ s/^/$pp/); + } + } + else { + if ($file{has_inc_ppport}) { + diag("No need to include '$ppport'"); + $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m); + } + } + + # put back in our C comments + my $ix; + my $cppc = 0; + my @ccom = @{$file{ccom}}; + for $ix (0 .. $#ccom) { + if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) { + $cppc++; + $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/; + } + else { + $c =~ s/$rccs$ix$rcce/$ccom[$ix]/; + } + } + + if ($cppc) { + my $s = $cppc != 1 ? 's' : ''; + warning("Uses $cppc C++ style comment$s, which is not portable"); + } + + my $s = $warnings != 1 ? 's' : ''; + my $warn = $warnings ? " ($warnings warning$s)" : ''; + info("Analysis completed$warn"); + + if ($file{changes}) { + if (exists $opt{copy}) { + my $newfile = "$filename$opt{copy}"; + if (-e $newfile) { + error("'$newfile' already exists, refusing to write copy of '$filename'"); + } + else { + local *F; + if (open F, ">$newfile") { + info("Writing copy of '$filename' with changes to '$newfile'"); + print F $c; + close F; + } + else { + error("Cannot open '$newfile' for writing: $!"); + } + } + } + elsif (exists $opt{patch} || $opt{changes}) { + if (exists $opt{patch}) { + unless ($patch_opened) { + if (open PATCH, ">$opt{patch}") { + $patch_opened = 1; + } + else { + error("Cannot open '$opt{patch}' for writing: $!"); + delete $opt{patch}; + $opt{changes} = 1; + goto fallback; + } + } + mydiff(\*PATCH, $filename, $c); + } + else { +fallback: + info("Suggested changes:"); + mydiff(\*STDOUT, $filename, $c); + } + } + else { + my $s = $file{changes} == 1 ? '' : 's'; + info("$file{changes} potentially required change$s detected"); + } + } + else { + info("Looks good"); + } +} + +close PATCH if $patch_opened; + +exit 0; + + +sub try_use { eval "use @_;"; return $@ eq '' } + +sub mydiff +{ + local *F = shift; + my($file, $str) = @_; + my $diff; + + if (exists $opt{diff}) { + $diff = run_diff($opt{diff}, $file, $str); + } + + if (!defined $diff and try_use('Text::Diff')) { + $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' }); + $diff = <
$tmp") { + print F $str; + close F; + + if (open F, "$prog $file $tmp |") { + while () { + s/\Q$tmp\E/$file.patched/; + $diff .= $_; + } + close F; + unlink $tmp; + return $diff; + } + + unlink $tmp; + } + else { + error("Cannot open '$tmp' for writing: $!"); + } + + return undef; +} + +sub rec_depend +{ + my($func, $seen) = @_; + return () unless exists $depends{$func}; + $seen = {%{$seen||{}}}; + return () if $seen->{$func}++; + my %s; + grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}}; +} + +sub parse_version +{ + my $ver = shift; + + if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { + return ($1, $2, $3); + } + elsif ($ver !~ /^\d+\.[\d_]+$/) { + die "cannot parse version '$ver'\n"; + } + + $ver =~ s/_//g; + $ver =~ s/$/000000/; + + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "cannot parse version '$ver'\n"; + } + } + + return ($r, $v, $s); +} + +sub format_version +{ + my $ver = shift; + + $ver =~ s/$/000000/; + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "invalid version '$ver'\n"; + } + $s /= 10; + + $ver = sprintf "%d.%03d", $r, $v; + $s > 0 and $ver .= sprintf "_%02d", $s; + + return $ver; + } + + return sprintf "%d.%d.%d", $r, $v, $s; +} + +sub info +{ + $opt{quiet} and return; + print @_, "\n"; +} + +sub diag +{ + $opt{quiet} and return; + $opt{diag} and print @_, "\n"; +} + +sub warning +{ + $opt{quiet} and return; + print "*** ", @_, "\n"; +} + +sub error +{ + print "*** ERROR: ", @_, "\n"; +} + +my %given_hints; +my %given_warnings; +sub hint +{ + $opt{quiet} and return; + my $func = shift; + my $rv = 0; + if (exists $warnings{$func} && !$given_warnings{$func}++) { + my $warn = $warnings{$func}; + $warn =~ s!^!*** !mg; + print "*** WARNING: $func\n", $warn; + $rv++; + } + if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) { + my $hint = $hints{$func}; + $hint =~ s/^/ /mg; + print " --- hint for $func ---\n", $hint; + } + $rv; +} + +sub usage +{ + my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; + my %M = ( 'I' => '*' ); + $usage =~ s/^\s*perl\s+\S+/$^X $0/; + $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; + + print < }; + my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms; + $copy =~ s/^(?=\S+)/ /gms; + $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms; + $self =~ s/^SKIP.*(?=^__DATA__)/SKIP +if (\@ARGV && \$ARGV[0] eq '--unstrip') { + eval { require Devel::PPPort }; + \$@ and die "Cannot require Devel::PPPort, please install.\\n"; + if (eval \$Devel::PPPort::VERSION < $VERSION) { + die "$0 was originally generated with Devel::PPPort $VERSION.\\n" + . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n" + . "Please install a newer version, or --unstrip will not work.\\n"; + } + Devel::PPPort::WriteFile(\$0); + exit 0; +} +print <$0" or die "cannot strip $0: $!\n"; + print OUT "$pl$c\n"; + + exit 0; +} + +__DATA__ +*/ + +#ifndef _P_P_PORTABILITY_H_ +#define _P_P_PORTABILITY_H_ + +#ifndef DPPP_NAMESPACE +# define DPPP_NAMESPACE DPPP_ +#endif + +#define DPPP_CAT2(x,y) CAT2(x,y) +#define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name) + +#ifndef PERL_REVISION +# if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION)) +# define PERL_PATCHLEVEL_H_IMPLICIT +# include +# endif +# if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) +# include +# endif +# ifndef PERL_REVISION +# define PERL_REVISION (5) + /* Replace: 1 */ +# define PERL_VERSION PATCHLEVEL +# define PERL_SUBVERSION SUBVERSION + /* Replace PERL_PATCHLEVEL with PERL_VERSION */ + /* Replace: 0 */ +# endif +#endif + +#define _dpppDEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10)) +#define PERL_BCDVERSION ((_dpppDEC2BCD(PERL_REVISION)<<24)|(_dpppDEC2BCD(PERL_VERSION)<<12)|_dpppDEC2BCD(PERL_SUBVERSION)) + +/* It is very unlikely that anyone will try to use this with Perl 6 + (or greater), but who knows. + */ +#if PERL_REVISION != 5 +# error ppport.h only works with Perl version 5 +#endif /* PERL_REVISION != 5 */ +#ifndef dTHR +# define dTHR dNOOP +#endif +#ifndef dTHX +# define dTHX dNOOP +#endif + +#ifndef dTHXa +# define dTHXa(x) dNOOP +#endif +#ifndef pTHX +# define pTHX void +#endif + +#ifndef pTHX_ +# define pTHX_ +#endif + +#ifndef aTHX +# define aTHX +#endif + +#ifndef aTHX_ +# define aTHX_ +#endif + +#if (PERL_BCDVERSION < 0x5006000) +# ifdef USE_THREADS +# define aTHXR thr +# define aTHXR_ thr, +# else +# define aTHXR +# define aTHXR_ +# endif +# define dTHXR dTHR +#else +# define aTHXR aTHX +# define aTHXR_ aTHX_ +# define dTHXR dTHX +#endif +#ifndef dTHXoa +# define dTHXoa(x) dTHXa(x) +#endif + +#ifdef I_LIMITS +# include +#endif + +#ifndef PERL_UCHAR_MIN +# define PERL_UCHAR_MIN ((unsigned char)0) +#endif + +#ifndef PERL_UCHAR_MAX +# ifdef UCHAR_MAX +# define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) +# else +# ifdef MAXUCHAR +# define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR) +# else +# define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) +# endif +# endif +#endif + +#ifndef PERL_USHORT_MIN +# define PERL_USHORT_MIN ((unsigned short)0) +#endif + +#ifndef PERL_USHORT_MAX +# ifdef USHORT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHORT_MAX) +# else +# ifdef MAXUSHORT +# define PERL_USHORT_MAX ((unsigned short)MAXUSHORT) +# else +# ifdef USHRT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) +# else +# define PERL_USHORT_MAX ((unsigned short)~(unsigned)0) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MAX +# ifdef SHORT_MAX +# define PERL_SHORT_MAX ((short)SHORT_MAX) +# else +# ifdef MAXSHORT /* Often used in */ +# define PERL_SHORT_MAX ((short)MAXSHORT) +# else +# ifdef SHRT_MAX +# define PERL_SHORT_MAX ((short)SHRT_MAX) +# else +# define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1)) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MIN +# ifdef SHORT_MIN +# define PERL_SHORT_MIN ((short)SHORT_MIN) +# else +# ifdef MINSHORT +# define PERL_SHORT_MIN ((short)MINSHORT) +# else +# ifdef SHRT_MIN +# define PERL_SHORT_MIN ((short)SHRT_MIN) +# else +# define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +#ifndef PERL_UINT_MAX +# ifdef UINT_MAX +# define PERL_UINT_MAX ((unsigned int)UINT_MAX) +# else +# ifdef MAXUINT +# define PERL_UINT_MAX ((unsigned int)MAXUINT) +# else +# define PERL_UINT_MAX (~(unsigned int)0) +# endif +# endif +#endif + +#ifndef PERL_UINT_MIN +# define PERL_UINT_MIN ((unsigned int)0) +#endif + +#ifndef PERL_INT_MAX +# ifdef INT_MAX +# define PERL_INT_MAX ((int)INT_MAX) +# else +# ifdef MAXINT /* Often used in */ +# define PERL_INT_MAX ((int)MAXINT) +# else +# define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_INT_MIN +# ifdef INT_MIN +# define PERL_INT_MIN ((int)INT_MIN) +# else +# ifdef MININT +# define PERL_INT_MIN ((int)MININT) +# else +# define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MAX +# ifdef ULONG_MAX +# define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) +# else +# ifdef MAXULONG +# define PERL_ULONG_MAX ((unsigned long)MAXULONG) +# else +# define PERL_ULONG_MAX (~(unsigned long)0) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MIN +# define PERL_ULONG_MIN ((unsigned long)0L) +#endif + +#ifndef PERL_LONG_MAX +# ifdef LONG_MAX +# define PERL_LONG_MAX ((long)LONG_MAX) +# else +# ifdef MAXLONG +# define PERL_LONG_MAX ((long)MAXLONG) +# else +# define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_LONG_MIN +# ifdef LONG_MIN +# define PERL_LONG_MIN ((long)LONG_MIN) +# else +# ifdef MINLONG +# define PERL_LONG_MIN ((long)MINLONG) +# else +# define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#if defined(HAS_QUAD) && (defined(convex) || defined(uts)) +# ifndef PERL_UQUAD_MAX +# ifdef ULONGLONG_MAX +# define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX) +# else +# ifdef MAXULONGLONG +# define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG) +# else +# define PERL_UQUAD_MAX (~(unsigned long long)0) +# endif +# endif +# endif + +# ifndef PERL_UQUAD_MIN +# define PERL_UQUAD_MIN ((unsigned long long)0L) +# endif + +# ifndef PERL_QUAD_MAX +# ifdef LONGLONG_MAX +# define PERL_QUAD_MAX ((long long)LONGLONG_MAX) +# else +# ifdef MAXLONGLONG +# define PERL_QUAD_MAX ((long long)MAXLONGLONG) +# else +# define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1)) +# endif +# endif +# endif + +# ifndef PERL_QUAD_MIN +# ifdef LONGLONG_MIN +# define PERL_QUAD_MIN ((long long)LONGLONG_MIN) +# else +# ifdef MINLONGLONG +# define PERL_QUAD_MIN ((long long)MINLONGLONG) +# else +# define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +/* This is based on code from 5.003 perl.h */ +#ifdef HAS_QUAD +# ifdef cray +#ifndef IVTYPE +# define IVTYPE int +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_INT_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_INT_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_UINT_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_UINT_MAX +#endif + +# ifdef INTSIZE +#ifndef IVSIZE +# define IVSIZE INTSIZE +#endif + +# endif +# else +# if defined(convex) || defined(uts) +#ifndef IVTYPE +# define IVTYPE long long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_QUAD_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_QUAD_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_UQUAD_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_UQUAD_MAX +#endif + +# ifdef LONGLONGSIZE +#ifndef IVSIZE +# define IVSIZE LONGLONGSIZE +#endif + +# endif +# else +#ifndef IVTYPE +# define IVTYPE long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_LONG_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_LONG_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_ULONG_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_ULONG_MAX +#endif + +# ifdef LONGSIZE +#ifndef IVSIZE +# define IVSIZE LONGSIZE +#endif + +# endif +# endif +# endif +#ifndef IVSIZE +# define IVSIZE 8 +#endif + +#ifndef PERL_QUAD_MIN +# define PERL_QUAD_MIN IV_MIN +#endif + +#ifndef PERL_QUAD_MAX +# define PERL_QUAD_MAX IV_MAX +#endif + +#ifndef PERL_UQUAD_MIN +# define PERL_UQUAD_MIN UV_MIN +#endif + +#ifndef PERL_UQUAD_MAX +# define PERL_UQUAD_MAX UV_MAX +#endif + +#else +#ifndef IVTYPE +# define IVTYPE long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_LONG_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_LONG_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_ULONG_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_ULONG_MAX +#endif + +#endif + +#ifndef IVSIZE +# ifdef LONGSIZE +# define IVSIZE LONGSIZE +# else +# define IVSIZE 4 /* A bold guess, but the best we can make. */ +# endif +#endif +#ifndef UVTYPE +# define UVTYPE unsigned IVTYPE +#endif + +#ifndef UVSIZE +# define UVSIZE IVSIZE +#endif +#ifndef sv_setuv +# define sv_setuv(sv, uv) \ + STMT_START { \ + UV TeMpUv = uv; \ + if (TeMpUv <= IV_MAX) \ + sv_setiv(sv, TeMpUv); \ + else \ + sv_setnv(sv, (double)TeMpUv); \ + } STMT_END +#endif +#ifndef newSVuv +# define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv)) +#endif +#ifndef sv_2uv +# define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) +#endif + +#ifndef SvUVX +# define SvUVX(sv) ((UV)SvIVX(sv)) +#endif + +#ifndef SvUVXx +# define SvUVXx(sv) SvUVX(sv) +#endif + +#ifndef SvUV +# define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) +#endif + +#ifndef SvUVx +# define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) +#endif + +/* Hint: sv_uv + * Always use the SvUVx() macro instead of sv_uv(). + */ +#ifndef sv_uv +# define sv_uv(sv) SvUVx(sv) +#endif + +#if !defined(SvUOK) && defined(SvIOK_UV) +# define SvUOK(sv) SvIOK_UV(sv) +#endif +#ifndef XST_mUV +# define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) +#endif + +#ifndef XSRETURN_UV +# define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END +#endif +#ifndef PUSHu +# define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END +#endif + +#ifndef XPUSHu +# define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END +#endif + +#ifdef HAS_MEMCMP +#ifndef memNE +# define memNE(s1,s2,l) (memcmp(s1,s2,l)) +#endif + +#ifndef memEQ +# define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) +#endif + +#else +#ifndef memNE +# define memNE(s1,s2,l) (bcmp(s1,s2,l)) +#endif + +#ifndef memEQ +# define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) +#endif + +#endif +#ifndef MoveD +# define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t)) +#endif + +#ifndef CopyD +# define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) +#endif + +#ifdef HAS_MEMSET +#ifndef ZeroD +# define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t)) +#endif + +#else +#ifndef ZeroD +# define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)), d) +#endif + +#endif +#ifndef PoisonWith +# define PoisonWith(d,n,t,b) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t)) +#endif + +#ifndef PoisonNew +# define PoisonNew(d,n,t) PoisonWith(d,n,t,0xAB) +#endif + +#ifndef PoisonFree +# define PoisonFree(d,n,t) PoisonWith(d,n,t,0xEF) +#endif + +#ifndef Poison +# define Poison(d,n,t) PoisonFree(d,n,t) +#endif +#ifndef Newx +# define Newx(v,n,t) New(0,v,n,t) +#endif + +#ifndef Newxc +# define Newxc(v,n,t,c) Newc(0,v,n,t,c) +#endif + +#ifndef Newxz +# define Newxz(v,n,t) Newz(0,v,n,t) +#endif + +#ifndef PERL_UNUSED_DECL +# ifdef HASATTRIBUTE +# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) +# define PERL_UNUSED_DECL +# else +# define PERL_UNUSED_DECL __attribute__((unused)) +# endif +# else +# define PERL_UNUSED_DECL +# endif +#endif + +#ifndef PERL_UNUSED_ARG +# if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ +# include +# define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) +# else +# define PERL_UNUSED_ARG(x) ((void)x) +# endif +#endif + +#ifndef PERL_UNUSED_VAR +# define PERL_UNUSED_VAR(x) ((void)x) +#endif + +#ifndef PERL_UNUSED_CONTEXT +# ifdef USE_ITHREADS +# define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) +# else +# define PERL_UNUSED_CONTEXT +# endif +#endif +#ifndef NOOP +# define NOOP /*EMPTY*/(void)0 +#endif + +#ifndef dNOOP +# define dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL +#endif + +#ifndef NVTYPE +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) +# define NVTYPE long double +# else +# define NVTYPE double +# endif +typedef NVTYPE NV; +#endif + +#ifndef INT2PTR + +# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) +# define PTRV UV +# define INT2PTR(any,d) (any)(d) +# else +# if PTRSIZE == LONGSIZE +# define PTRV unsigned long +# else +# define PTRV unsigned +# endif +# define INT2PTR(any,d) (any)(PTRV)(d) +# endif + +# define NUM2PTR(any,d) (any)(PTRV)(d) +# define PTR2IV(p) INT2PTR(IV,p) +# define PTR2UV(p) INT2PTR(UV,p) +# define PTR2NV(p) NUM2PTR(NV,p) + +# if PTRSIZE == LONGSIZE +# define PTR2ul(p) (unsigned long)(p) +# else +# define PTR2ul(p) INT2PTR(unsigned long,p) +# endif + +#endif /* !INT2PTR */ + +#undef START_EXTERN_C +#undef END_EXTERN_C +#undef EXTERN_C +#ifdef __cplusplus +# define START_EXTERN_C extern "C" { +# define END_EXTERN_C } +# define EXTERN_C extern "C" +#else +# define START_EXTERN_C +# define END_EXTERN_C +# define EXTERN_C extern +#endif + +#if defined(PERL_GCC_PEDANTIC) +# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN +# define PERL_GCC_BRACE_GROUPS_FORBIDDEN +# endif +#endif + +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) +# ifndef PERL_USE_GCC_BRACE_GROUPS +# define PERL_USE_GCC_BRACE_GROUPS +# endif +#endif + +#undef STMT_START +#undef STMT_END +#ifdef PERL_USE_GCC_BRACE_GROUPS +# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ +# define STMT_END ) +#else +# if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) +# define STMT_START if (1) +# define STMT_END else (void)0 +# else +# define STMT_START do +# define STMT_END while (0) +# endif +#endif +#ifndef boolSV +# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) +#endif + +/* DEFSV appears first in 5.004_56 */ +#ifndef DEFSV +# define DEFSV GvSV(PL_defgv) +#endif + +#ifndef SAVE_DEFSV +# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) +#endif + +#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 PERL_ABS +# define PERL_ABS(x) ((x) < 0 ? -(x) : (x)) +#endif +#ifndef dVAR +# define dVAR dNOOP +#endif +#ifndef SVf +# define SVf "_" +#endif +#ifndef UTF8_MAXBYTES +# define UTF8_MAXBYTES UTF8_MAXLEN +#endif +#ifndef CPERLscope +# define CPERLscope(x) x +#endif +#ifndef PERL_HASH +# define PERL_HASH(hash,str,len) \ + STMT_START { \ + const char *s_PeRlHaSh = str; \ + I32 i_PeRlHaSh = len; \ + U32 hash_PeRlHaSh = 0; \ + while (i_PeRlHaSh--) \ + hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \ + (hash) = hash_PeRlHaSh; \ + } STMT_END +#endif + +#ifndef PERLIO_FUNCS_DECL +# ifdef PERLIO_FUNCS_CONST +# define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs +# define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs) +# else +# define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs +# define PERLIO_FUNCS_CAST(funcs) (funcs) +# endif +#endif + +/* provide these typedefs for older perls */ +#if (PERL_BCDVERSION < 0x5009003) + +# ifdef ARGSproto +typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto); +# else +typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX); +# endif + +typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*); + +#endif +#ifndef isPSXSPC +# define isPSXSPC(c) (isSPACE(c) || (c) == '\v') +#endif + +#ifndef isBLANK +# define isBLANK(c) ((c) == ' ' || (c) == '\t') +#endif + +#ifdef EBCDIC +#ifndef isALNUMC +# define isALNUMC(c) isalnum(c) +#endif + +#ifndef isASCII +# define isASCII(c) isascii(c) +#endif + +#ifndef isCNTRL +# define isCNTRL(c) iscntrl(c) +#endif + +#ifndef isGRAPH +# define isGRAPH(c) isgraph(c) +#endif + +#ifndef isPRINT +# define isPRINT(c) isprint(c) +#endif + +#ifndef isPUNCT +# define isPUNCT(c) ispunct(c) +#endif + +#ifndef isXDIGIT +# define isXDIGIT(c) isxdigit(c) +#endif + +#else +# if (PERL_BCDVERSION < 0x5010000) +/* Hint: isPRINT + * The implementation in older perl versions includes all of the + * isSPACE() characters, which is wrong. The version provided by + * Devel::PPPort always overrides a present buggy version. + */ +# undef isPRINT +# endif +#ifndef isALNUMC +# define isALNUMC(c) (isALPHA(c) || isDIGIT(c)) +#endif + +#ifndef isASCII +# define isASCII(c) ((c) <= 127) +#endif + +#ifndef isCNTRL +# define isCNTRL(c) ((c) < ' ' || (c) == 127) +#endif + +#ifndef isGRAPH +# define isGRAPH(c) (isALNUM(c) || isPUNCT(c)) +#endif + +#ifndef isPRINT +# define isPRINT(c) (((c) >= 32 && (c) < 127)) +#endif + +#ifndef isPUNCT +# define isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126)) +#endif + +#ifndef isXDIGIT +# define isXDIGIT(c) (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F')) +#endif + +#endif + +#ifndef PERL_SIGNALS_UNSAFE_FLAG + +#define PERL_SIGNALS_UNSAFE_FLAG 0x0001 + +#if (PERL_BCDVERSION < 0x5008000) +# define D_PPP_PERL_SIGNALS_INIT PERL_SIGNALS_UNSAFE_FLAG +#else +# define D_PPP_PERL_SIGNALS_INIT 0 +#endif + +#if defined(NEED_PL_signals) +static U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; +#elif defined(NEED_PL_signals_GLOBAL) +U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; +#else +extern U32 DPPP_(my_PL_signals); +#endif +#define PL_signals DPPP_(my_PL_signals) + +#endif + +/* Hint: PL_ppaddr + * Calling an op via PL_ppaddr requires passing a context argument + * for threaded builds. Since the context argument is different for + * 5.005 perls, you can use aTHXR (supplied by ppport.h), which will + * automatically be defined as the correct argument. + */ + +#if (PERL_BCDVERSION <= 0x5005005) +/* Replace: 1 */ +# define PL_ppaddr ppaddr +# define PL_no_modify no_modify +/* Replace: 0 */ +#endif + +#if (PERL_BCDVERSION <= 0x5004005) +/* Replace: 1 */ +# define PL_DBsignal DBsignal +# define PL_DBsingle DBsingle +# define PL_DBsub DBsub +# define PL_DBtrace DBtrace +# define PL_Sv Sv +# define PL_bufend bufend +# define PL_bufptr bufptr +# define PL_compiling compiling +# define PL_copline copline +# define PL_curcop curcop +# define PL_curstash curstash +# define PL_debstash debstash +# define PL_defgv defgv +# define PL_diehook diehook +# define PL_dirty dirty +# define PL_dowarn dowarn +# define PL_errgv errgv +# define PL_expect expect +# define PL_hexdigit hexdigit +# define PL_hints hints +# define PL_laststatval laststatval +# define PL_lex_state lex_state +# define PL_lex_stuff lex_stuff +# define PL_linestr linestr +# define PL_na na +# define PL_perl_destruct_level perl_destruct_level +# define PL_perldb perldb +# define PL_rsfp_filters rsfp_filters +# define PL_rsfp rsfp +# define PL_stack_base stack_base +# define PL_stack_sp stack_sp +# define PL_statcache statcache +# define PL_stdingv stdingv +# define PL_sv_arenaroot sv_arenaroot +# define PL_sv_no sv_no +# define PL_sv_undef sv_undef +# define PL_sv_yes sv_yes +# define PL_tainted tainted +# define PL_tainting tainting +# define PL_tokenbuf tokenbuf +/* Replace: 0 */ +#endif + +/* Warning: PL_parser + * For perl versions earlier than 5.9.5, this is an always + * non-NULL dummy. Also, it cannot be dereferenced. Don't + * use it if you can avoid is and unless you absolutely know + * what you're doing. + * If you always check that PL_parser is non-NULL, you can + * define DPPP_PL_parser_NO_DUMMY to avoid the creation of + * a dummy parser structure. + */ + +#if (PERL_BCDVERSION >= 0x5009005) +# ifdef DPPP_PL_parser_NO_DUMMY +# define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ + (croak("panic: PL_parser == NULL in %s:%d", \ + __FILE__, __LINE__), (yy_parser *) NULL))->var) +# else +# ifdef DPPP_PL_parser_NO_DUMMY_WARNING +# define D_PPP_parser_dummy_warning(var) +# else +# define D_PPP_parser_dummy_warning(var) \ + warn("warning: dummy PL_" #var " used in %s:%d", __FILE__, __LINE__), +# endif +# define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ + (D_PPP_parser_dummy_warning(var) &DPPP_(dummy_PL_parser)))->var) +#if defined(NEED_PL_parser) +static yy_parser DPPP_(dummy_PL_parser); +#elif defined(NEED_PL_parser_GLOBAL) +yy_parser DPPP_(dummy_PL_parser); +#else +extern yy_parser DPPP_(dummy_PL_parser); +#endif + +# endif + +/* PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf depends on PL_parser */ +/* Warning: PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf + * Do not use this variable unless you know exactly what you're + * doint. It is internal to the perl parser and may change or even + * be removed in the future. As of perl 5.9.5, you have to check + * for (PL_parser != NULL) for this variable to have any effect. + * An always non-NULL PL_parser dummy is provided for earlier + * perl versions. + * If PL_parser is NULL when you try to access this variable, a + * dummy is being accessed instead and a warning is issued unless + * you define DPPP_PL_parser_NO_DUMMY_WARNING. + * If DPPP_PL_parser_NO_DUMMY is defined, the code trying to access + * this variable will croak with a panic message. + */ + +# define PL_expect D_PPP_my_PL_parser_var(expect) +# define PL_copline D_PPP_my_PL_parser_var(copline) +# define PL_rsfp D_PPP_my_PL_parser_var(rsfp) +# define PL_rsfp_filters D_PPP_my_PL_parser_var(rsfp_filters) +# define PL_linestr D_PPP_my_PL_parser_var(linestr) +# define PL_bufptr D_PPP_my_PL_parser_var(bufptr) +# define PL_bufend D_PPP_my_PL_parser_var(bufend) +# define PL_lex_state D_PPP_my_PL_parser_var(lex_state) +# define PL_lex_stuff D_PPP_my_PL_parser_var(lex_stuff) +# define PL_tokenbuf D_PPP_my_PL_parser_var(tokenbuf) + +#else + +/* ensure that PL_parser != NULL and cannot be dereferenced */ +# define PL_parser ((void *) 1) + +#endif +#ifndef mPUSHs +# define mPUSHs(s) PUSHs(sv_2mortal(s)) +#endif + +#ifndef PUSHmortal +# define PUSHmortal PUSHs(sv_newmortal()) +#endif + +#ifndef mPUSHp +# define mPUSHp(p,l) sv_setpvn(PUSHmortal, (p), (l)) +#endif + +#ifndef mPUSHn +# define mPUSHn(n) sv_setnv(PUSHmortal, (NV)(n)) +#endif + +#ifndef mPUSHi +# define mPUSHi(i) sv_setiv(PUSHmortal, (IV)(i)) +#endif + +#ifndef mPUSHu +# define mPUSHu(u) sv_setuv(PUSHmortal, (UV)(u)) +#endif +#ifndef mXPUSHs +# define mXPUSHs(s) XPUSHs(sv_2mortal(s)) +#endif + +#ifndef XPUSHmortal +# define XPUSHmortal XPUSHs(sv_newmortal()) +#endif + +#ifndef mXPUSHp +# define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn(PUSHmortal, (p), (l)); } STMT_END +#endif + +#ifndef mXPUSHn +# define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv(PUSHmortal, (NV)(n)); } STMT_END +#endif + +#ifndef mXPUSHi +# define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv(PUSHmortal, (IV)(i)); } STMT_END +#endif + +#ifndef mXPUSHu +# define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv(PUSHmortal, (UV)(u)); } STMT_END +#endif + +/* Replace: 1 */ +#ifndef call_sv +# define call_sv perl_call_sv +#endif + +#ifndef call_pv +# define call_pv perl_call_pv +#endif + +#ifndef call_argv +# define call_argv perl_call_argv +#endif + +#ifndef call_method +# define call_method perl_call_method +#endif +#ifndef eval_sv +# define eval_sv perl_eval_sv +#endif + +/* Replace: 0 */ +#ifndef PERL_LOADMOD_DENY +# define PERL_LOADMOD_DENY 0x1 +#endif + +#ifndef PERL_LOADMOD_NOIMPORT +# define PERL_LOADMOD_NOIMPORT 0x2 +#endif + +#ifndef PERL_LOADMOD_IMPORT_OPS +# define PERL_LOADMOD_IMPORT_OPS 0x4 +#endif + +#ifndef G_METHOD +# define G_METHOD 64 +# ifdef call_sv +# undef call_sv +# endif +# if (PERL_BCDVERSION < 0x5006000) +# define call_sv(sv, flags) ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \ + (flags) & ~G_METHOD) : perl_call_sv(sv, flags)) +# else +# define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \ + (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags)) +# endif +#endif + +/* Replace perl_eval_pv with eval_pv */ + +#ifndef eval_pv +#if defined(NEED_eval_pv) +static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); +static +#else +extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); +#endif + +#ifdef eval_pv +# undef eval_pv +#endif +#define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b) +#define Perl_eval_pv DPPP_(my_eval_pv) + +#if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) + +SV* +DPPP_(my_eval_pv)(char *p, I32 croak_on_error) +{ + dSP; + SV* sv = newSVpv(p, 0); + + PUSHMARK(sp); + eval_sv(sv, G_SCALAR); + SvREFCNT_dec(sv); + + SPAGAIN; + sv = POPs; + PUTBACK; + + if (croak_on_error && SvTRUE(GvSV(errgv))) + croak(SvPVx(GvSV(errgv), na)); + + return sv; +} + +#endif +#endif + +#ifndef vload_module +#if defined(NEED_vload_module) +static void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); +static +#else +extern void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); +#endif + +#ifdef vload_module +# undef vload_module +#endif +#define vload_module(a,b,c,d) DPPP_(my_vload_module)(aTHX_ a,b,c,d) +#define Perl_vload_module DPPP_(my_vload_module) + +#if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL) + +void +DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args) +{ + dTHR; + dVAR; + OP *veop, *imop; + + OP * const modname = newSVOP(OP_CONST, 0, name); + /* 5.005 has a somewhat hacky force_normal that doesn't croak on + SvREADONLY() if PL_compling is true. Current perls take care in + ck_require() to correctly turn off SvREADONLY before calling + force_normal_flags(). This seems a better fix than fudging PL_compling + */ + SvREADONLY_off(((SVOP*)modname)->op_sv); + modname->op_private |= OPpCONST_BARE; + if (ver) { + veop = newSVOP(OP_CONST, 0, ver); + } + else + veop = NULL; + if (flags & PERL_LOADMOD_NOIMPORT) { + imop = sawparens(newNULLLIST()); + } + else if (flags & PERL_LOADMOD_IMPORT_OPS) { + imop = va_arg(*args, OP*); + } + else { + SV *sv; + imop = NULL; + sv = va_arg(*args, SV*); + while (sv) { + imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); + sv = va_arg(*args, SV*); + } + } + { + const line_t ocopline = PL_copline; + COP * const ocurcop = PL_curcop; + const int oexpect = PL_expect; + +#if (PERL_BCDVERSION >= 0x5004000) + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), + veop, modname, imop); +#else + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), + modname, imop); +#endif + PL_expect = oexpect; + PL_copline = ocopline; + PL_curcop = ocurcop; + } +} + +#endif +#endif + +#ifndef load_module +#if defined(NEED_load_module) +static void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); +static +#else +extern void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); +#endif + +#ifdef load_module +# undef load_module +#endif +#define load_module DPPP_(my_load_module) +#define Perl_load_module DPPP_(my_load_module) + +#if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL) + +void +DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...) +{ + va_list args; + va_start(args, ver); + vload_module(flags, name, ver, &args); + va_end(args); +} + +#endif +#endif +#ifndef newRV_inc +# define newRV_inc(sv) newRV(sv) /* Replace */ +#endif + +#ifndef newRV_noinc +#if defined(NEED_newRV_noinc) +static SV * DPPP_(my_newRV_noinc)(SV *sv); +static +#else +extern SV * DPPP_(my_newRV_noinc)(SV *sv); +#endif + +#ifdef newRV_noinc +# undef newRV_noinc +#endif +#define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a) +#define Perl_newRV_noinc DPPP_(my_newRV_noinc) + +#if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) +SV * +DPPP_(my_newRV_noinc)(SV *sv) +{ + SV *rv = (SV *)newRV(sv); + SvREFCNT_dec(sv); + return rv; +} +#endif +#endif + +/* Hint: newCONSTSUB + * Returns a CV* as of perl-5.7.1. This return value is not supported + * by Devel::PPPort. + */ + +/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ +#if (PERL_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005) +#if defined(NEED_newCONSTSUB) +static void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); +static +#else +extern void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); +#endif + +#ifdef newCONSTSUB +# undef newCONSTSUB +#endif +#define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) +#define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) + +#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) + +/* This is just a trick to avoid a dependency of newCONSTSUB on PL_parser */ +/* (There's no PL_parser in perl < 5.005, so this is completely safe) */ +#define D_PPP_PL_copline PL_copline + +void +DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv) +{ + U32 oldhints = PL_hints; + HV *old_cop_stash = PL_curcop->cop_stash; + HV *old_curstash = PL_curstash; + line_t oldline = PL_curcop->cop_line; + PL_curcop->cop_line = D_PPP_PL_copline; + + PL_hints &= ~HINT_BLOCK_SCOPE; + if (stash) + PL_curstash = PL_curcop->cop_stash = stash; + + newSUB( + +#if (PERL_BCDVERSION < 0x5003022) + start_subparse(), +#elif (PERL_BCDVERSION == 0x5003022) + start_subparse(0), +#else /* 5.003_23 onwards */ + start_subparse(FALSE, 0), +#endif + + newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)), + newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ + newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) + ); + + PL_hints = oldhints; + PL_curcop->cop_stash = old_cop_stash; + PL_curstash = old_curstash; + PL_curcop->cop_line = oldline; +} +#endif +#endif + +/* + * Boilerplate macros for initializing and accessing interpreter-local + * data from C. All statics in extensions should be reworked to use + * this, if you want to make the extension thread-safe. See ext/re/re.xs + * for an example of the use of these macros. + * + * Code that uses these macros is responsible for the following: + * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" + * 2. Declare a typedef named my_cxt_t that is a structure that contains + * all the data that needs to be interpreter-local. + * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. + * 4. Use the MY_CXT_INIT macro such that it is called exactly once + * (typically put in the BOOT: section). + * 5. Use the members of the my_cxt_t structure everywhere as + * MY_CXT.member. + * 6. Use the dMY_CXT macro (a declaration) in all the functions that + * access MY_CXT. + */ + +#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ + defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) + +#ifndef START_MY_CXT + +/* This must appear in all extensions that define a my_cxt_t structure, + * right after the definition (i.e. at file scope). The non-threads + * case below uses it to declare the data as static. */ +#define START_MY_CXT + +#if (PERL_BCDVERSION < 0x5004068) +/* Fetches the SV that keeps the per-interpreter data. */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE) +#else /* >= perl5.004_68 */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ + sizeof(MY_CXT_KEY)-1, TRUE) +#endif /* < perl5.004_68 */ + +/* This declaration should be used within all functions that use the + * interpreter-local data. */ +#define dMY_CXT \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) + +/* Creates and zeroes the per-interpreter data. + * (We allocate my_cxtp in a Perl SV so that it will be released when + * the interpreter goes away.) */ +#define MY_CXT_INIT \ + dMY_CXT_SV; \ + /* newSV() allocates one more than needed */ \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Zero(my_cxtp, 1, my_cxt_t); \ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) + +/* This macro must be used to access members of the my_cxt_t structure. + * e.g. MYCXT.some_data */ +#define MY_CXT (*my_cxtp) + +/* Judicious use of these macros can reduce the number of times dMY_CXT + * is used. Use is similar to pTHX, aTHX etc. */ +#define pMY_CXT my_cxt_t *my_cxtp +#define pMY_CXT_ pMY_CXT, +#define _pMY_CXT ,pMY_CXT +#define aMY_CXT my_cxtp +#define aMY_CXT_ aMY_CXT, +#define _aMY_CXT ,aMY_CXT + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +/* Clones the per-interpreter data. */ +#define MY_CXT_CLONE \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) +#endif + +#else /* single interpreter */ + +#ifndef START_MY_CXT + +#define START_MY_CXT static my_cxt_t my_cxt; +#define dMY_CXT_SV dNOOP +#define dMY_CXT dNOOP +#define MY_CXT_INIT NOOP +#define MY_CXT my_cxt + +#define pMY_CXT void +#define pMY_CXT_ +#define _pMY_CXT +#define aMY_CXT +#define aMY_CXT_ +#define _aMY_CXT + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +#define MY_CXT_CLONE NOOP +#endif + +#endif + +#ifndef IVdf +# if IVSIZE == LONGSIZE +# define IVdf "ld" +# define UVuf "lu" +# define UVof "lo" +# define UVxf "lx" +# define UVXf "lX" +# else +# if IVSIZE == INTSIZE +# define IVdf "d" +# define UVuf "u" +# define UVof "o" +# define UVxf "x" +# define UVXf "X" +# endif +# endif +#endif + +#ifndef NVef +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ + defined(PERL_PRIfldbl) && (PERL_BCDVERSION != 0x5006000) + /* Not very likely, but let's try anyway. */ +# define NVef PERL_PRIeldbl +# define NVff PERL_PRIfldbl +# define NVgf PERL_PRIgldbl +# else +# define NVef "e" +# define NVff "f" +# define NVgf "g" +# endif +#endif + +#ifndef SvREFCNT_inc +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + if (_sv) \ + (SvREFCNT(_sv))++; \ + _sv; \ + }) +# else +# define SvREFCNT_inc(sv) \ + ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL) +# endif +#endif + +#ifndef SvREFCNT_inc_simple +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_simple(sv) \ + ({ \ + if (sv) \ + (SvREFCNT(sv))++; \ + (SV *)(sv); \ + }) +# else +# define SvREFCNT_inc_simple(sv) \ + ((sv) ? (SvREFCNT(sv)++,(SV*)(sv)) : NULL) +# endif +#endif + +#ifndef SvREFCNT_inc_NN +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_NN(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + SvREFCNT(_sv)++; \ + _sv; \ + }) +# else +# define SvREFCNT_inc_NN(sv) \ + (PL_Sv=(SV*)(sv),++(SvREFCNT(PL_Sv)),PL_Sv) +# endif +#endif + +#ifndef SvREFCNT_inc_void +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_void(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + if (_sv) \ + (void)(SvREFCNT(_sv)++); \ + }) +# else +# define SvREFCNT_inc_void(sv) \ + (void)((PL_Sv=(SV*)(sv)) ? ++(SvREFCNT(PL_Sv)) : 0) +# endif +#endif +#ifndef SvREFCNT_inc_simple_void +# define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END +#endif + +#ifndef SvREFCNT_inc_simple_NN +# define SvREFCNT_inc_simple_NN(sv) (++SvREFCNT(sv), (SV*)(sv)) +#endif + +#ifndef SvREFCNT_inc_void_NN +# define SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) +#endif + +#ifndef SvREFCNT_inc_simple_void_NN +# define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) +#endif + +#if (PERL_BCDVERSION < 0x5006000) +# define D_PPP_CONSTPV_ARG(x) ((char *) (x)) +#else +# define D_PPP_CONSTPV_ARG(x) (x) +#endif +#ifndef newSVpvn +# define newSVpvn(data,len) ((data) \ + ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ + : newSV(0)) +#endif +#ifndef newSVpvn_utf8 +# define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) +#endif +#ifndef SVf_UTF8 +# define SVf_UTF8 0 +#endif + +#ifndef newSVpvn_flags + +#if defined(NEED_newSVpvn_flags) +static SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); +static +#else +extern SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); +#endif + +#ifdef newSVpvn_flags +# undef newSVpvn_flags +#endif +#define newSVpvn_flags(a,b,c) DPPP_(my_newSVpvn_flags)(aTHX_ a,b,c) +#define Perl_newSVpvn_flags DPPP_(my_newSVpvn_flags) + +#if defined(NEED_newSVpvn_flags) || defined(NEED_newSVpvn_flags_GLOBAL) + +SV * +DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags) +{ + SV *sv = newSVpvn(D_PPP_CONSTPV_ARG(s), len); + SvFLAGS(sv) |= (flags & SVf_UTF8); + return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv; +} + +#endif + +#endif + +/* Backwards compatibility stuff... :-( */ +#if !defined(NEED_sv_2pv_flags) && defined(NEED_sv_2pv_nolen) +# define NEED_sv_2pv_flags +#endif +#if !defined(NEED_sv_2pv_flags_GLOBAL) && defined(NEED_sv_2pv_nolen_GLOBAL) +# define NEED_sv_2pv_flags_GLOBAL +#endif + +/* Hint: sv_2pv_nolen + * Use the SvPV_nolen() or SvPV_nolen_const() macros instead of sv_2pv_nolen(). + */ +#ifndef sv_2pv_nolen +# define sv_2pv_nolen(sv) SvPV_nolen(sv) +#endif + +#ifdef SvPVbyte + +/* Hint: SvPVbyte + * Does not work in perl-5.6.1, ppport.h implements a version + * borrowed from perl-5.7.3. + */ + +#if (PERL_BCDVERSION < 0x5007000) + +#if defined(NEED_sv_2pvbyte) +static char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); +static +#else +extern char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); +#endif + +#ifdef sv_2pvbyte +# undef sv_2pvbyte +#endif +#define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b) +#define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte) + +#if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) + +char * +DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp) +{ + sv_utf8_downgrade(sv,0); + return SvPV(sv,*lp); +} + +#endif + +/* Hint: sv_2pvbyte + * Use the SvPVbyte() macro instead of sv_2pvbyte(). + */ + +#undef SvPVbyte + +#define SvPVbyte(sv, lp) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) + +#endif + +#else + +# define SvPVbyte SvPV +# define sv_2pvbyte sv_2pv + +#endif +#ifndef sv_2pvbyte_nolen +# define sv_2pvbyte_nolen(sv) sv_2pv_nolen(sv) +#endif + +/* Hint: sv_pvn + * Always use the SvPV() macro instead of sv_pvn(). + */ + +/* Hint: sv_pvn_force + * Always use the SvPV_force() macro instead of sv_pvn_force(). + */ + +/* If these are undefined, they're not handled by the core anyway */ +#ifndef SV_IMMEDIATE_UNREF +# define SV_IMMEDIATE_UNREF 0 +#endif + +#ifndef SV_GMAGIC +# define SV_GMAGIC 0 +#endif + +#ifndef SV_COW_DROP_PV +# define SV_COW_DROP_PV 0 +#endif + +#ifndef SV_UTF8_NO_ENCODING +# define SV_UTF8_NO_ENCODING 0 +#endif + +#ifndef SV_NOSTEAL +# define SV_NOSTEAL 0 +#endif + +#ifndef SV_CONST_RETURN +# define SV_CONST_RETURN 0 +#endif + +#ifndef SV_MUTABLE_RETURN +# define SV_MUTABLE_RETURN 0 +#endif + +#ifndef SV_SMAGIC +# define SV_SMAGIC 0 +#endif + +#ifndef SV_HAS_TRAILING_NUL +# define SV_HAS_TRAILING_NUL 0 +#endif + +#ifndef SV_COW_SHARED_HASH_KEYS +# define SV_COW_SHARED_HASH_KEYS 0 +#endif + +#if (PERL_BCDVERSION < 0x5007002) + +#if defined(NEED_sv_2pv_flags) +static char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +static +#else +extern char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +#endif + +#ifdef sv_2pv_flags +# undef sv_2pv_flags +#endif +#define sv_2pv_flags(a,b,c) DPPP_(my_sv_2pv_flags)(aTHX_ a,b,c) +#define Perl_sv_2pv_flags DPPP_(my_sv_2pv_flags) + +#if defined(NEED_sv_2pv_flags) || defined(NEED_sv_2pv_flags_GLOBAL) + +char * +DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) +{ + STRLEN n_a = (STRLEN) flags; + return sv_2pv(sv, lp ? lp : &n_a); +} + +#endif + +#if defined(NEED_sv_pvn_force_flags) +static char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +static +#else +extern char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +#endif + +#ifdef sv_pvn_force_flags +# undef sv_pvn_force_flags +#endif +#define sv_pvn_force_flags(a,b,c) DPPP_(my_sv_pvn_force_flags)(aTHX_ a,b,c) +#define Perl_sv_pvn_force_flags DPPP_(my_sv_pvn_force_flags) + +#if defined(NEED_sv_pvn_force_flags) || defined(NEED_sv_pvn_force_flags_GLOBAL) + +char * +DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) +{ + STRLEN n_a = (STRLEN) flags; + return sv_pvn_force(sv, lp ? lp : &n_a); +} + +#endif + +#endif + +#if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) ) +# define DPPP_SVPV_NOLEN_LP_ARG &PL_na +#else +# define DPPP_SVPV_NOLEN_LP_ARG 0 +#endif +#ifndef SvPV_const +# define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC) +#endif + +#ifndef SvPV_mutable +# define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC) +#endif +#ifndef SvPV_flags +# define SvPV_flags(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags)) +#endif +#ifndef SvPV_flags_const +# define SvPV_flags_const(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \ + (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN)) +#endif +#ifndef SvPV_flags_const_nolen +# define SvPV_flags_const_nolen(sv, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX_const(sv) : \ + (const char*) sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags|SV_CONST_RETURN)) +#endif +#ifndef SvPV_flags_mutable +# define SvPV_flags_mutable(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \ + sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) +#endif +#ifndef SvPV_force +# define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC) +#endif + +#ifndef SvPV_force_nolen +# define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC) +#endif + +#ifndef SvPV_force_mutable +# define SvPV_force_mutable(sv, lp) SvPV_force_flags_mutable(sv, lp, SV_GMAGIC) +#endif + +#ifndef SvPV_force_nomg +# define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0) +#endif + +#ifndef SvPV_force_nomg_nolen +# define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0) +#endif +#ifndef SvPV_force_flags +# define SvPV_force_flags(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags)) +#endif +#ifndef SvPV_force_flags_nolen +# define SvPV_force_flags_nolen(sv, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? SvPVX(sv) : sv_pvn_force_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags)) +#endif +#ifndef SvPV_force_flags_mutable +# define SvPV_force_flags_mutable(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \ + : sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) +#endif +#ifndef SvPV_nolen +# define SvPV_nolen(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC)) +#endif +#ifndef SvPV_nolen_const +# define SvPV_nolen_const(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX_const(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC|SV_CONST_RETURN)) +#endif +#ifndef SvPV_nomg +# define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0) +#endif + +#ifndef SvPV_nomg_const +# define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0) +#endif + +#ifndef SvPV_nomg_const_nolen +# define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0) +#endif +#ifndef SvPV_renew +# define SvPV_renew(sv,n) STMT_START { SvLEN_set(sv, n); \ + SvPV_set((sv), (char *) saferealloc( \ + (Malloc_t)SvPVX(sv), (MEM_SIZE)((n)))); \ + } STMT_END +#endif +#ifndef SvMAGIC_set +# define SvMAGIC_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ + (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END +#endif + +#if (PERL_BCDVERSION < 0x5009003) +#ifndef SvPVX_const +# define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv))) +#endif + +#ifndef SvPVX_mutable +# define SvPVX_mutable(sv) (0 + SvPVX(sv)) +#endif +#ifndef SvRV_set +# define SvRV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ + (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END +#endif + +#else +#ifndef SvPVX_const +# define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv)) +#endif + +#ifndef SvPVX_mutable +# define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv) +#endif +#ifndef SvRV_set +# define SvRV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ + ((sv)->sv_u.svu_rv = (val)); } STMT_END +#endif + +#endif +#ifndef SvSTASH_set +# define SvSTASH_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ + (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END +#endif + +#if (PERL_BCDVERSION < 0x5004000) +#ifndef SvUV_set +# define SvUV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ + (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END +#endif + +#else +#ifndef SvUV_set +# define SvUV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ + (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END +#endif + +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(vnewSVpvf) +#if defined(NEED_vnewSVpvf) +static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); +static +#else +extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); +#endif + +#ifdef vnewSVpvf +# undef vnewSVpvf +#endif +#define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) +#define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) + +#if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) + +SV * +DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args) +{ + register SV *sv = newSV(0); + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + return sv; +} + +#endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf) +# define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf) +# define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg) +#if defined(NEED_sv_catpvf_mg) +static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +#endif + +#define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) + +#if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) + +void +DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +#ifdef PERL_IMPLICIT_CONTEXT +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg_nocontext) +#if defined(NEED_sv_catpvf_mg_nocontext) +static void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); +#endif + +#define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) +#define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) + +#if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) + +void +DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +/* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */ +#ifndef sv_catpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext +# else +# define sv_catpvf_mg Perl_sv_catpvf_mg +# endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf_mg) +# define sv_vcatpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg) +#if defined(NEED_sv_setpvf_mg) +static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +#endif + +#define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) + +#if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) + +void +DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +#ifdef PERL_IMPLICIT_CONTEXT +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg_nocontext) +#if defined(NEED_sv_setpvf_mg_nocontext) +static void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); +#endif + +#define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) +#define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) + +#if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) + +void +DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +/* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */ +#ifndef sv_setpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext +# else +# define sv_setpvf_mg Perl_sv_setpvf_mg +# endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf_mg) +# define sv_vsetpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif + +#ifndef newSVpvn_share + +#if defined(NEED_newSVpvn_share) +static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); +static +#else +extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); +#endif + +#ifdef newSVpvn_share +# undef newSVpvn_share +#endif +#define newSVpvn_share(a,b,c) DPPP_(my_newSVpvn_share)(aTHX_ a,b,c) +#define Perl_newSVpvn_share DPPP_(my_newSVpvn_share) + +#if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL) + +SV * +DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash) +{ + SV *sv; + if (len < 0) + len = -len; + if (!hash) + PERL_HASH(hash, (char*) src, len); + sv = newSVpvn((char *) src, len); + sv_upgrade(sv, SVt_PVIV); + SvIVX(sv) = hash; + SvREADONLY_on(sv); + SvPOK_on(sv); + return sv; +} + +#endif + +#endif +#ifndef SvSHARED_HASH +# define SvSHARED_HASH(sv) (0 + SvUVX(sv)) +#endif +#ifndef WARN_ALL +# define WARN_ALL 0 +#endif + +#ifndef WARN_CLOSURE +# define WARN_CLOSURE 1 +#endif + +#ifndef WARN_DEPRECATED +# define WARN_DEPRECATED 2 +#endif + +#ifndef WARN_EXITING +# define WARN_EXITING 3 +#endif + +#ifndef WARN_GLOB +# define WARN_GLOB 4 +#endif + +#ifndef WARN_IO +# define WARN_IO 5 +#endif + +#ifndef WARN_CLOSED +# define WARN_CLOSED 6 +#endif + +#ifndef WARN_EXEC +# define WARN_EXEC 7 +#endif + +#ifndef WARN_LAYER +# define WARN_LAYER 8 +#endif + +#ifndef WARN_NEWLINE +# define WARN_NEWLINE 9 +#endif + +#ifndef WARN_PIPE +# define WARN_PIPE 10 +#endif + +#ifndef WARN_UNOPENED +# define WARN_UNOPENED 11 +#endif + +#ifndef WARN_MISC +# define WARN_MISC 12 +#endif + +#ifndef WARN_NUMERIC +# define WARN_NUMERIC 13 +#endif + +#ifndef WARN_ONCE +# define WARN_ONCE 14 +#endif + +#ifndef WARN_OVERFLOW +# define WARN_OVERFLOW 15 +#endif + +#ifndef WARN_PACK +# define WARN_PACK 16 +#endif + +#ifndef WARN_PORTABLE +# define WARN_PORTABLE 17 +#endif + +#ifndef WARN_RECURSION +# define WARN_RECURSION 18 +#endif + +#ifndef WARN_REDEFINE +# define WARN_REDEFINE 19 +#endif + +#ifndef WARN_REGEXP +# define WARN_REGEXP 20 +#endif + +#ifndef WARN_SEVERE +# define WARN_SEVERE 21 +#endif + +#ifndef WARN_DEBUGGING +# define WARN_DEBUGGING 22 +#endif + +#ifndef WARN_INPLACE +# define WARN_INPLACE 23 +#endif + +#ifndef WARN_INTERNAL +# define WARN_INTERNAL 24 +#endif + +#ifndef WARN_MALLOC +# define WARN_MALLOC 25 +#endif + +#ifndef WARN_SIGNAL +# define WARN_SIGNAL 26 +#endif + +#ifndef WARN_SUBSTR +# define WARN_SUBSTR 27 +#endif + +#ifndef WARN_SYNTAX +# define WARN_SYNTAX 28 +#endif + +#ifndef WARN_AMBIGUOUS +# define WARN_AMBIGUOUS 29 +#endif + +#ifndef WARN_BAREWORD +# define WARN_BAREWORD 30 +#endif + +#ifndef WARN_DIGIT +# define WARN_DIGIT 31 +#endif + +#ifndef WARN_PARENTHESIS +# define WARN_PARENTHESIS 32 +#endif + +#ifndef WARN_PRECEDENCE +# define WARN_PRECEDENCE 33 +#endif + +#ifndef WARN_PRINTF +# define WARN_PRINTF 34 +#endif + +#ifndef WARN_PROTOTYPE +# define WARN_PROTOTYPE 35 +#endif + +#ifndef WARN_QW +# define WARN_QW 36 +#endif + +#ifndef WARN_RESERVED +# define WARN_RESERVED 37 +#endif + +#ifndef WARN_SEMICOLON +# define WARN_SEMICOLON 38 +#endif + +#ifndef WARN_TAINT +# define WARN_TAINT 39 +#endif + +#ifndef WARN_THREADS +# define WARN_THREADS 40 +#endif + +#ifndef WARN_UNINITIALIZED +# define WARN_UNINITIALIZED 41 +#endif + +#ifndef WARN_UNPACK +# define WARN_UNPACK 42 +#endif + +#ifndef WARN_UNTIE +# define WARN_UNTIE 43 +#endif + +#ifndef WARN_UTF8 +# define WARN_UTF8 44 +#endif + +#ifndef WARN_VOID +# define WARN_VOID 45 +#endif + +#ifndef WARN_ASSERTIONS +# define WARN_ASSERTIONS 46 +#endif +#ifndef packWARN +# define packWARN(a) (a) +#endif + +#ifndef ckWARN +# ifdef G_WARN_ON +# define ckWARN(a) (PL_dowarn & G_WARN_ON) +# else +# define ckWARN(a) PL_dowarn +# endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(warner) +#if defined(NEED_warner) +static void DPPP_(my_warner)(U32 err, const char *pat, ...); +static +#else +extern void DPPP_(my_warner)(U32 err, const char *pat, ...); +#endif + +#define Perl_warner DPPP_(my_warner) + +#if defined(NEED_warner) || defined(NEED_warner_GLOBAL) + +void +DPPP_(my_warner)(U32 err, const char *pat, ...) +{ + SV *sv; + va_list args; + + PERL_UNUSED_ARG(err); + + va_start(args, pat); + sv = vnewSVpvf(pat, &args); + va_end(args); + sv_2mortal(sv); + warn("%s", SvPV_nolen(sv)); +} + +#define warner Perl_warner + +#define Perl_warner_nocontext Perl_warner + +#endif +#endif + +/* concatenating with "" ensures that only literal strings are accepted as argument + * note that STR_WITH_LEN() can't be used as argument to macros or functions that + * under some configurations might be macros + */ +#ifndef STR_WITH_LEN +# define STR_WITH_LEN(s) (s ""), (sizeof(s)-1) +#endif +#ifndef newSVpvs +# define newSVpvs(str) newSVpvn(str "", sizeof(str) - 1) +#endif + +#ifndef newSVpvs_flags +# define newSVpvs_flags(str, flags) newSVpvn_flags(str "", sizeof(str) - 1, flags) +#endif + +#ifndef sv_catpvs +# define sv_catpvs(sv, str) sv_catpvn(sv, str "", sizeof(str) - 1) +#endif + +#ifndef sv_setpvs +# define sv_setpvs(sv, str) sv_setpvn(sv, str "", sizeof(str) - 1) +#endif + +#ifndef hv_fetchs +# define hv_fetchs(hv, key, lval) hv_fetch(hv, key "", sizeof(key) - 1, lval) +#endif + +#ifndef hv_stores +# define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0) +#endif +#ifndef SvGETMAGIC +# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END +#endif +#ifndef PERL_MAGIC_sv +# define PERL_MAGIC_sv '\0' +#endif + +#ifndef PERL_MAGIC_overload +# define PERL_MAGIC_overload 'A' +#endif + +#ifndef PERL_MAGIC_overload_elem +# define PERL_MAGIC_overload_elem 'a' +#endif + +#ifndef PERL_MAGIC_overload_table +# define PERL_MAGIC_overload_table 'c' +#endif + +#ifndef PERL_MAGIC_bm +# define PERL_MAGIC_bm 'B' +#endif + +#ifndef PERL_MAGIC_regdata +# define PERL_MAGIC_regdata 'D' +#endif + +#ifndef PERL_MAGIC_regdatum +# define PERL_MAGIC_regdatum 'd' +#endif + +#ifndef PERL_MAGIC_env +# define PERL_MAGIC_env 'E' +#endif + +#ifndef PERL_MAGIC_envelem +# define PERL_MAGIC_envelem 'e' +#endif + +#ifndef PERL_MAGIC_fm +# define PERL_MAGIC_fm 'f' +#endif + +#ifndef PERL_MAGIC_regex_global +# define PERL_MAGIC_regex_global 'g' +#endif + +#ifndef PERL_MAGIC_isa +# define PERL_MAGIC_isa 'I' +#endif + +#ifndef PERL_MAGIC_isaelem +# define PERL_MAGIC_isaelem 'i' +#endif + +#ifndef PERL_MAGIC_nkeys +# define PERL_MAGIC_nkeys 'k' +#endif + +#ifndef PERL_MAGIC_dbfile +# define PERL_MAGIC_dbfile 'L' +#endif + +#ifndef PERL_MAGIC_dbline +# define PERL_MAGIC_dbline 'l' +#endif + +#ifndef PERL_MAGIC_mutex +# define PERL_MAGIC_mutex 'm' +#endif + +#ifndef PERL_MAGIC_shared +# define PERL_MAGIC_shared 'N' +#endif + +#ifndef PERL_MAGIC_shared_scalar +# define PERL_MAGIC_shared_scalar 'n' +#endif + +#ifndef PERL_MAGIC_collxfrm +# define PERL_MAGIC_collxfrm 'o' +#endif + +#ifndef PERL_MAGIC_tied +# define PERL_MAGIC_tied 'P' +#endif + +#ifndef PERL_MAGIC_tiedelem +# define PERL_MAGIC_tiedelem 'p' +#endif + +#ifndef PERL_MAGIC_tiedscalar +# define PERL_MAGIC_tiedscalar 'q' +#endif + +#ifndef PERL_MAGIC_qr +# define PERL_MAGIC_qr 'r' +#endif + +#ifndef PERL_MAGIC_sig +# define PERL_MAGIC_sig 'S' +#endif + +#ifndef PERL_MAGIC_sigelem +# define PERL_MAGIC_sigelem 's' +#endif + +#ifndef PERL_MAGIC_taint +# define PERL_MAGIC_taint 't' +#endif + +#ifndef PERL_MAGIC_uvar +# define PERL_MAGIC_uvar 'U' +#endif + +#ifndef PERL_MAGIC_uvar_elem +# define PERL_MAGIC_uvar_elem 'u' +#endif + +#ifndef PERL_MAGIC_vstring +# define PERL_MAGIC_vstring 'V' +#endif + +#ifndef PERL_MAGIC_vec +# define PERL_MAGIC_vec 'v' +#endif + +#ifndef PERL_MAGIC_utf8 +# define PERL_MAGIC_utf8 'w' +#endif + +#ifndef PERL_MAGIC_substr +# define PERL_MAGIC_substr 'x' +#endif + +#ifndef PERL_MAGIC_defelem +# define PERL_MAGIC_defelem 'y' +#endif + +#ifndef PERL_MAGIC_glob +# define PERL_MAGIC_glob '*' +#endif + +#ifndef PERL_MAGIC_arylen +# define PERL_MAGIC_arylen '#' +#endif + +#ifndef PERL_MAGIC_pos +# define PERL_MAGIC_pos '.' +#endif + +#ifndef PERL_MAGIC_backref +# define PERL_MAGIC_backref '<' +#endif + +#ifndef PERL_MAGIC_ext +# define PERL_MAGIC_ext '~' +#endif + +/* That's the best we can do... */ +#ifndef sv_catpvn_nomg +# define sv_catpvn_nomg sv_catpvn +#endif + +#ifndef sv_catsv_nomg +# define sv_catsv_nomg sv_catsv +#endif + +#ifndef sv_setsv_nomg +# define sv_setsv_nomg sv_setsv +#endif + +#ifndef sv_pvn_nomg +# define sv_pvn_nomg sv_pvn +#endif + +#ifndef SvIV_nomg +# define SvIV_nomg SvIV +#endif + +#ifndef SvUV_nomg +# define SvUV_nomg SvUV +#endif + +#ifndef sv_catpv_mg +# define sv_catpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catpvn_mg +# define sv_catpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catsv_mg +# define sv_catsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_catsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setiv_mg +# define sv_setiv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setiv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setnv_mg +# define sv_setnv_mg(sv, num) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setnv(TeMpSv,num); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpv_mg +# define sv_setpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpvn_mg +# define sv_setpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setsv_mg +# define sv_setsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_setsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setuv_mg +# define sv_setuv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setuv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_usepvn_mg +# define sv_usepvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_usepvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif +#ifndef SvVSTRING_mg +# define SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL) +#endif + +/* Hint: sv_magic_portable + * This is a compatibility function that is only available with + * Devel::PPPort. It is NOT in the perl core. + * Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when + * it is being passed a name pointer with namlen == 0. In that + * case, perl 5.8.0 and later store the pointer, not a copy of it. + * The compatibility can be provided back to perl 5.004. With + * earlier versions, the code will not compile. + */ + +#if (PERL_BCDVERSION < 0x5004000) + + /* code that uses sv_magic_portable will not compile */ + +#elif (PERL_BCDVERSION < 0x5008000) + +# define sv_magic_portable(sv, obj, how, name, namlen) \ + STMT_START { \ + SV *SvMp_sv = (sv); \ + char *SvMp_name = (char *) (name); \ + I32 SvMp_namlen = (namlen); \ + if (SvMp_name && SvMp_namlen == 0) \ + { \ + MAGIC *mg; \ + sv_magic(SvMp_sv, obj, how, 0, 0); \ + mg = SvMAGIC(SvMp_sv); \ + mg->mg_len = -42; /* XXX: this is the tricky part */ \ + mg->mg_ptr = SvMp_name; \ + } \ + else \ + { \ + sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \ + } \ + } STMT_END + +#else + +# define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e) + +#endif + +#ifdef USE_ITHREADS +#ifndef CopFILE +# define CopFILE(c) ((c)->cop_file) +#endif + +#ifndef CopFILEGV +# define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv) +#endif + +#ifndef CopFILE_set +# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) +#endif + +#ifndef CopFILESV +# define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) +#endif + +#ifndef CopFILEAV +# define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) +#endif + +#ifndef CopSTASHPV +# define CopSTASHPV(c) ((c)->cop_stashpv) +#endif + +#ifndef CopSTASHPV_set +# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) +#endif + +#ifndef CopSTASH +# define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) +#endif + +#ifndef CopSTASH_set +# define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) +#endif + +#ifndef CopSTASH_eq +# define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \ + || (CopSTASHPV(c) && HvNAME(hv) \ + && strEQ(CopSTASHPV(c), HvNAME(hv))))) +#endif + +#else +#ifndef CopFILEGV +# define CopFILEGV(c) ((c)->cop_filegv) +#endif + +#ifndef CopFILEGV_set +# define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) +#endif + +#ifndef CopFILE_set +# define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) +#endif + +#ifndef CopFILESV +# define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) +#endif + +#ifndef CopFILEAV +# define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) +#endif + +#ifndef CopFILE +# define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) +#endif + +#ifndef CopSTASH +# define CopSTASH(c) ((c)->cop_stash) +#endif + +#ifndef CopSTASH_set +# define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) +#endif + +#ifndef CopSTASHPV +# define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) +#endif + +#ifndef CopSTASHPV_set +# define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) +#endif + +#ifndef CopSTASH_eq +# define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) +#endif + +#endif /* USE_ITHREADS */ +#ifndef IN_PERL_COMPILETIME +# define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) +#endif + +#ifndef IN_LOCALE_RUNTIME +# define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) +#endif + +#ifndef IN_LOCALE_COMPILETIME +# define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) +#endif + +#ifndef IN_LOCALE +# define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) +#endif +#ifndef IS_NUMBER_IN_UV +# define IS_NUMBER_IN_UV 0x01 +#endif + +#ifndef IS_NUMBER_GREATER_THAN_UV_MAX +# define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 +#endif + +#ifndef IS_NUMBER_NOT_INT +# define IS_NUMBER_NOT_INT 0x04 +#endif + +#ifndef IS_NUMBER_NEG +# define IS_NUMBER_NEG 0x08 +#endif + +#ifndef IS_NUMBER_INFINITY +# define IS_NUMBER_INFINITY 0x10 +#endif + +#ifndef IS_NUMBER_NAN +# define IS_NUMBER_NAN 0x20 +#endif +#ifndef GROK_NUMERIC_RADIX +# define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) +#endif +#ifndef PERL_SCAN_GREATER_THAN_UV_MAX +# define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 +#endif + +#ifndef PERL_SCAN_SILENT_ILLDIGIT +# define PERL_SCAN_SILENT_ILLDIGIT 0x04 +#endif + +#ifndef PERL_SCAN_ALLOW_UNDERSCORES +# define PERL_SCAN_ALLOW_UNDERSCORES 0x01 +#endif + +#ifndef PERL_SCAN_DISALLOW_PREFIX +# define PERL_SCAN_DISALLOW_PREFIX 0x02 +#endif + +#ifndef grok_numeric_radix +#if defined(NEED_grok_numeric_radix) +static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); +static +#else +extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); +#endif + +#ifdef grok_numeric_radix +# undef grok_numeric_radix +#endif +#define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b) +#define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix) + +#if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) +bool +DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send) +{ +#ifdef USE_LOCALE_NUMERIC +#ifdef PL_numeric_radix_sv + if (PL_numeric_radix_sv && IN_LOCALE) { + STRLEN len; + char* radix = SvPV(PL_numeric_radix_sv, len); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#else + /* older perls don't have PL_numeric_radix_sv so the radix + * must manually be requested from locale.h + */ +#include + dTHR; /* needed for older threaded perls */ + struct lconv *lc = localeconv(); + char *radix = lc->decimal_point; + if (radix && IN_LOCALE) { + STRLEN len = strlen(radix); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#endif +#endif /* USE_LOCALE_NUMERIC */ + /* always try "." if numeric radix didn't match because + * we may have data from different locales mixed */ + if (*sp < send && **sp == '.') { + ++*sp; + return TRUE; + } + return FALSE; +} +#endif +#endif + +#ifndef grok_number +#if defined(NEED_grok_number) +static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); +static +#else +extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); +#endif + +#ifdef grok_number +# undef grok_number +#endif +#define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c) +#define Perl_grok_number DPPP_(my_grok_number) + +#if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) +int +DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep) +{ + const char *s = pv; + const char *send = pv + len; + const UV max_div_10 = UV_MAX / 10; + const char max_mod_10 = UV_MAX % 10; + int numtype = 0; + int sawinf = 0; + int sawnan = 0; + + while (s < send && isSPACE(*s)) + s++; + if (s == send) { + return 0; + } else if (*s == '-') { + s++; + numtype = IS_NUMBER_NEG; + } + else if (*s == '+') + s++; + + if (s == send) + return 0; + + /* next must be digit or the radix separator or beginning of infinity */ + if (isDIGIT(*s)) { + /* UVs are at least 32 bits, so the first 9 decimal digits cannot + overflow. */ + UV value = *s - '0'; + /* This construction seems to be more optimiser friendly. + (without it gcc does the isDIGIT test and the *s - '0' separately) + With it gcc on arm is managing 6 instructions (6 cycles) per digit. + In theory the optimiser could deduce how far to unroll the loop + before checking for overflow. */ + if (++s < send) { + int digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + /* Now got 9 digits, so need to check + each time for overflow. */ + digit = *s - '0'; + while (digit >= 0 && digit <= 9 + && (value < max_div_10 + || (value == max_div_10 + && digit <= max_mod_10))) { + value = value * 10 + digit; + if (++s < send) + digit = *s - '0'; + else + break; + } + if (digit >= 0 && digit <= 9 + && (s < send)) { + /* value overflowed. + skip the remaining digits, don't + worry about setting *valuep. */ + do { + s++; + } while (s < send && isDIGIT(*s)); + numtype |= + IS_NUMBER_GREATER_THAN_UV_MAX; + goto skip_value; + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + numtype |= IS_NUMBER_IN_UV; + if (valuep) + *valuep = value; + + skip_value: + if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT; + while (s < send && isDIGIT(*s)) /* optional digits after the radix */ + s++; + } + } + else if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ + /* no digits before the radix means we need digits after it */ + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + if (valuep) { + /* integer approximation is valid - it's 0. */ + *valuep = 0; + } + } + else + return 0; + } else if (*s == 'I' || *s == 'i') { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; + s++; if (s < send && (*s == 'I' || *s == 'i')) { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; + s++; if (s == send || (*s != 'T' && *s != 't')) return 0; + s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; + s++; + } + sawinf = 1; + } else if (*s == 'N' || *s == 'n') { + /* XXX TODO: There are signaling NaNs and quiet NaNs. */ + s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; + sawnan = 1; + } else + return 0; + + if (sawinf) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; + } else if (sawnan) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; + } else if (s < send) { + /* we can have an optional exponent part */ + if (*s == 'e' || *s == 'E') { + /* The only flag we keep is sign. Blow away any "it's UV" */ + numtype &= IS_NUMBER_NEG; + numtype |= IS_NUMBER_NOT_INT; + s++; + if (s < send && (*s == '-' || *s == '+')) + s++; + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + } + else + return 0; + } + } + while (s < send && isSPACE(*s)) + s++; + if (s >= send) + return numtype; + if (len == 10 && memEQ(pv, "0 but true", 10)) { + if (valuep) + *valuep = 0; + return IS_NUMBER_IN_UV; + } + return 0; +} +#endif +#endif + +/* + * The grok_* routines have been modified to use warn() instead of + * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit, + * which is why the stack variable has been renamed to 'xdigit'. + */ + +#ifndef grok_bin +#if defined(NEED_grok_bin) +static UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +static +#else +extern UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +#endif + +#ifdef grok_bin +# undef grok_bin +#endif +#define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d) +#define Perl_grok_bin DPPP_(my_grok_bin) + +#if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) +UV +DPPP_(my_grok_bin)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_2 = UV_MAX / 2; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading b or 0b. + for compatibility silently suffer "b" and "0b" as valid binary + numbers. */ + if (len >= 1) { + if (s[0] == 'b') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'b') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + char bit = *s; + if (bit == '0' || bit == '1') { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_bin. */ + redo: + if (!overflowed) { + if (value <= max_div_2) { + value = (value << 1) | (bit - '0'); + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in binary number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 2.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount. */ + value_nv += (NV)(bit - '0'); + continue; + } + if (bit == '_' && len && allow_underscores && (bit = s[1]) + && (bit == '0' || bit == '1')) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal binary digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Binary number > 0b11111111111111111111111111111111 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_hex +#if defined(NEED_grok_hex) +static UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +static +#else +extern UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +#endif + +#ifdef grok_hex +# undef grok_hex +#endif +#define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d) +#define Perl_grok_hex DPPP_(my_grok_hex) + +#if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) +UV +DPPP_(my_grok_hex)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_16 = UV_MAX / 16; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + const char *xdigit; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading x or 0x. + for compatibility silently suffer "x" and "0x" as valid hex numbers. + */ + if (len >= 1) { + if (s[0] == 'x') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'x') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + xdigit = strchr((char *) PL_hexdigit, *s); + if (xdigit) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_hex. */ + redo: + if (!overflowed) { + if (value <= max_div_16) { + value = (value << 4) | ((xdigit - PL_hexdigit) & 15); + continue; + } + warn("Integer overflow in hexadecimal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 16.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 16-tuples. */ + value_nv += (NV)((xdigit - PL_hexdigit) & 15); + continue; + } + if (*s == '_' && len && allow_underscores && s[1] + && (xdigit = strchr((char *) PL_hexdigit, s[1]))) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal hexadecimal digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Hexadecimal number > 0xffffffff non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_oct +#if defined(NEED_grok_oct) +static UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +static +#else +extern UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +#endif + +#ifdef grok_oct +# undef grok_oct +#endif +#define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d) +#define Perl_grok_oct DPPP_(my_grok_oct) + +#if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) +UV +DPPP_(my_grok_oct)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_8 = UV_MAX / 8; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + for (; len-- && *s; s++) { + /* gcc 2.95 optimiser not smart enough to figure that this subtraction + out front allows slicker code. */ + int digit = *s - '0'; + if (digit >= 0 && digit <= 7) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + */ + redo: + if (!overflowed) { + if (value <= max_div_8) { + value = (value << 3) | digit; + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in octal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 8.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 8-tuples. */ + value_nv += (NV)digit; + continue; + } + if (digit == ('_' - '0') && len && allow_underscores + && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) + { + --len; + ++s; + goto redo; + } + /* Allow \octal to work the DWIM way (that is, stop scanning + * as soon as non-octal characters are seen, complain only iff + * someone seems to want to use the digits eight and nine). */ + if (digit == 8 || digit == 9) { + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal octal digit '%c' ignored", *s); + } + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Octal number > 037777777777 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#if !defined(my_snprintf) +#if defined(NEED_my_snprintf) +static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); +static +#else +extern int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); +#endif + +#define my_snprintf DPPP_(my_my_snprintf) +#define Perl_my_snprintf DPPP_(my_my_snprintf) + +#if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL) + +int +DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...) +{ + dTHX; + int retval; + va_list ap; + va_start(ap, format); +#ifdef HAS_VSNPRINTF + retval = vsnprintf(buffer, len, format, ap); +#else + retval = vsprintf(buffer, format, ap); +#endif + va_end(ap); + if (retval < 0 || (len > 0 && (Size_t)retval >= len)) + Perl_croak(aTHX_ "panic: my_snprintf buffer overflow"); + return retval; +} + +#endif +#endif + +#if !defined(my_sprintf) +#if defined(NEED_my_sprintf) +static int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); +static +#else +extern int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); +#endif + +#define my_sprintf DPPP_(my_my_sprintf) +#define Perl_my_sprintf DPPP_(my_my_sprintf) + +#if defined(NEED_my_sprintf) || defined(NEED_my_sprintf_GLOBAL) + +int +DPPP_(my_my_sprintf)(char *buffer, const char* pat, ...) +{ + va_list args; + va_start(args, pat); + vsprintf(buffer, pat, args); + va_end(args); + return strlen(buffer); +} + +#endif +#endif + +#ifdef NO_XSLOCKS +# ifdef dJMPENV +# define dXCPT dJMPENV; int rEtV = 0 +# define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0) +# define XCPT_TRY_END JMPENV_POP; +# define XCPT_CATCH if (rEtV != 0) +# define XCPT_RETHROW JMPENV_JUMP(rEtV) +# else +# define dXCPT Sigjmp_buf oldTOP; int rEtV = 0 +# define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0) +# define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf); +# define XCPT_CATCH if (rEtV != 0) +# define XCPT_RETHROW Siglongjmp(top_env, rEtV) +# endif +#endif + +#if !defined(my_strlcat) +#if defined(NEED_my_strlcat) +static Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); +static +#else +extern Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); +#endif + +#define my_strlcat DPPP_(my_my_strlcat) +#define Perl_my_strlcat DPPP_(my_my_strlcat) + +#if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL) + +Size_t +DPPP_(my_my_strlcat)(char *dst, const char *src, Size_t size) +{ + Size_t used, length, copy; + + used = strlen(dst); + length = strlen(src); + if (size > 0 && used < size - 1) { + copy = (length >= size - used) ? size - used - 1 : length; + memcpy(dst + used, src, copy); + dst[used + copy] = '\0'; + } + return used + length; +} +#endif +#endif + +#if !defined(my_strlcpy) +#if defined(NEED_my_strlcpy) +static Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); +static +#else +extern Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); +#endif + +#define my_strlcpy DPPP_(my_my_strlcpy) +#define Perl_my_strlcpy DPPP_(my_my_strlcpy) + +#if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL) + +Size_t +DPPP_(my_my_strlcpy)(char *dst, const char *src, Size_t size) +{ + Size_t length, copy; + + length = strlen(src); + if (size > 0) { + copy = (length >= size) ? size - 1 : length; + memcpy(dst, src, copy); + dst[copy] = '\0'; + } + return length; +} + +#endif +#endif +#ifndef PERL_PV_ESCAPE_QUOTE +# define PERL_PV_ESCAPE_QUOTE 0x0001 +#endif + +#ifndef PERL_PV_PRETTY_QUOTE +# define PERL_PV_PRETTY_QUOTE PERL_PV_ESCAPE_QUOTE +#endif + +#ifndef PERL_PV_PRETTY_ELLIPSES +# define PERL_PV_PRETTY_ELLIPSES 0x0002 +#endif + +#ifndef PERL_PV_PRETTY_LTGT +# define PERL_PV_PRETTY_LTGT 0x0004 +#endif + +#ifndef PERL_PV_ESCAPE_FIRSTCHAR +# define PERL_PV_ESCAPE_FIRSTCHAR 0x0008 +#endif + +#ifndef PERL_PV_ESCAPE_UNI +# define PERL_PV_ESCAPE_UNI 0x0100 +#endif + +#ifndef PERL_PV_ESCAPE_UNI_DETECT +# define PERL_PV_ESCAPE_UNI_DETECT 0x0200 +#endif + +#ifndef PERL_PV_ESCAPE_ALL +# define PERL_PV_ESCAPE_ALL 0x1000 +#endif + +#ifndef PERL_PV_ESCAPE_NOBACKSLASH +# define PERL_PV_ESCAPE_NOBACKSLASH 0x2000 +#endif + +#ifndef PERL_PV_ESCAPE_NOCLEAR +# define PERL_PV_ESCAPE_NOCLEAR 0x4000 +#endif + +#ifndef PERL_PV_ESCAPE_RE +# define PERL_PV_ESCAPE_RE 0x8000 +#endif + +#ifndef PERL_PV_PRETTY_NOCLEAR +# define PERL_PV_PRETTY_NOCLEAR PERL_PV_ESCAPE_NOCLEAR +#endif +#ifndef PERL_PV_PRETTY_DUMP +# define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE +#endif + +#ifndef PERL_PV_PRETTY_REGPROP +# define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE +#endif + +/* Hint: pv_escape + * Note that unicode functionality is only backported to + * those perl versions that support it. For older perl + * versions, the implementation will fall back to bytes. + */ + +#ifndef pv_escape +#if defined(NEED_pv_escape) +static char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); +static +#else +extern char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); +#endif + +#ifdef pv_escape +# undef pv_escape +#endif +#define pv_escape(a,b,c,d,e,f) DPPP_(my_pv_escape)(aTHX_ a,b,c,d,e,f) +#define Perl_pv_escape DPPP_(my_pv_escape) + +#if defined(NEED_pv_escape) || defined(NEED_pv_escape_GLOBAL) + +char * +DPPP_(my_pv_escape)(pTHX_ SV *dsv, char const * const str, + const STRLEN count, const STRLEN max, + STRLEN * const escaped, const U32 flags) +{ + const char esc = flags & PERL_PV_ESCAPE_RE ? '%' : '\\'; + const char dq = flags & PERL_PV_ESCAPE_QUOTE ? '"' : esc; + char octbuf[32] = "%123456789ABCDF"; + STRLEN wrote = 0; + STRLEN chsize = 0; + STRLEN readsize = 1; +#if defined(is_utf8_string) && defined(utf8_to_uvchr) + bool isuni = flags & PERL_PV_ESCAPE_UNI ? 1 : 0; +#endif + const char *pv = str; + const char * const end = pv + count; + octbuf[0] = esc; + + if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) + sv_setpvs(dsv, ""); + +#if defined(is_utf8_string) && defined(utf8_to_uvchr) + if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count)) + isuni = 1; +#endif + + for (; pv < end && (!max || wrote < max) ; pv += readsize) { + const UV u = +#if defined(is_utf8_string) && defined(utf8_to_uvchr) + isuni ? utf8_to_uvchr((U8*)pv, &readsize) : +#endif + (U8)*pv; + const U8 c = (U8)u & 0xFF; + + if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) { + if (flags & PERL_PV_ESCAPE_FIRSTCHAR) + chsize = my_snprintf(octbuf, sizeof octbuf, + "%"UVxf, u); + else + chsize = my_snprintf(octbuf, sizeof octbuf, + "%cx{%"UVxf"}", esc, u); + } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) { + chsize = 1; + } else { + if (c == dq || c == esc || !isPRINT(c)) { + chsize = 2; + switch (c) { + case '\\' : /* fallthrough */ + case '%' : if (c == esc) + octbuf[1] = esc; + else + chsize = 1; + break; + case '\v' : octbuf[1] = 'v'; break; + case '\t' : octbuf[1] = 't'; break; + case '\r' : octbuf[1] = 'r'; break; + case '\n' : octbuf[1] = 'n'; break; + case '\f' : octbuf[1] = 'f'; break; + case '"' : if (dq == '"') + octbuf[1] = '"'; + else + chsize = 1; + break; + default: chsize = my_snprintf(octbuf, sizeof octbuf, + pv < end && isDIGIT((U8)*(pv+readsize)) + ? "%c%03o" : "%c%o", esc, c); + } + } else { + chsize = 1; + } + } + if (max && wrote + chsize > max) { + break; + } else if (chsize > 1) { + sv_catpvn(dsv, octbuf, chsize); + wrote += chsize; + } else { + char tmp[2]; + my_snprintf(tmp, sizeof tmp, "%c", c); + sv_catpvn(dsv, tmp, 1); + wrote++; + } + if (flags & PERL_PV_ESCAPE_FIRSTCHAR) + break; + } + if (escaped != NULL) + *escaped= pv - str; + return SvPVX(dsv); +} + +#endif +#endif + +#ifndef pv_pretty +#if defined(NEED_pv_pretty) +static char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); +static +#else +extern char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); +#endif + +#ifdef pv_pretty +# undef pv_pretty +#endif +#define pv_pretty(a,b,c,d,e,f,g) DPPP_(my_pv_pretty)(aTHX_ a,b,c,d,e,f,g) +#define Perl_pv_pretty DPPP_(my_pv_pretty) + +#if defined(NEED_pv_pretty) || defined(NEED_pv_pretty_GLOBAL) + +char * +DPPP_(my_pv_pretty)(pTHX_ SV *dsv, char const * const str, const STRLEN count, + const STRLEN max, char const * const start_color, char const * const end_color, + const U32 flags) +{ + const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%'; + STRLEN escaped; + + if (!(flags & PERL_PV_PRETTY_NOCLEAR)) + sv_setpvs(dsv, ""); + + if (dq == '"') + sv_catpvs(dsv, "\""); + else if (flags & PERL_PV_PRETTY_LTGT) + sv_catpvs(dsv, "<"); + + if (start_color != NULL) + sv_catpv(dsv, D_PPP_CONSTPV_ARG(start_color)); + + pv_escape(dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR); + + if (end_color != NULL) + sv_catpv(dsv, D_PPP_CONSTPV_ARG(end_color)); + + if (dq == '"') + sv_catpvs(dsv, "\""); + else if (flags & PERL_PV_PRETTY_LTGT) + sv_catpvs(dsv, ">"); + + if ((flags & PERL_PV_PRETTY_ELLIPSES) && escaped < count) + sv_catpvs(dsv, "..."); + + return SvPVX(dsv); +} + +#endif +#endif + +#ifndef pv_display +#if defined(NEED_pv_display) +static char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); +static +#else +extern char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); +#endif + +#ifdef pv_display +# undef pv_display +#endif +#define pv_display(a,b,c,d,e) DPPP_(my_pv_display)(aTHX_ a,b,c,d,e) +#define Perl_pv_display DPPP_(my_pv_display) + +#if defined(NEED_pv_display) || defined(NEED_pv_display_GLOBAL) + +char * +DPPP_(my_pv_display)(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) +{ + pv_pretty(dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP); + if (len > cur && pv[cur] == '\0') + sv_catpvs(dsv, "\\0"); + return SvPVX(dsv); +} + +#endif +#endif + +#endif /* _P_P_PORTABILITY_H_ */ + +/* End of File ppport.h */ diff --git a/Call/typemap b/Call/typemap new file mode 100644 index 0000000..95784e6 --- /dev/null +++ b/Call/typemap @@ -0,0 +1,2 @@ +const char * T_PV + diff --git a/Changes b/Changes new file mode 100644 index 0000000..8fbe3a9 --- /dev/null +++ b/Changes @@ -0,0 +1,467 @@ +1.58 2017-11-15 rurban +---- + * Drop 5.005 support + * Switch from DynaLoader to XSLoader [atoomic #5] + * Replace use vars by our. [atoomic #5] + * Lazy load Carp only when required. [atoomic #5] + * Minor test improvements + * Fix v5.8 cast warnings + +1.57 2017-01-22 rurban +---- + * Todo the t/exec.t test 2 on cygwin. + * Fixed/Todo the t/decrypt.t test 7 utf8 failures. + Skip with non UTF-8 locale. + +1.56 2017-01-20 rurban +---- + + * add binmode to the decrypt/encr,decrypt sample scripts + * add utf8-encoded testcase to t/decrypt.t [cpan #110921]. use -C + * stabilized some tests, add diag to sometimes failing sh tests + * moved filter-util.pl to t/ + * fixed INSTALLDIRS back to site since 5.12 [gh #2] + * fixed exec/sh test races using the same temp. filenames + * reversed this Changes file to latest first + * added Travis CI + +1.55 2015-07-26 rurban +---- + + * Fix t/z_pod-coverage.t with old Test::More by Kent Frederik. RT #106090. + * Fix t/tee.t + t/order.t race under parallel testing. RT #105396. + Thanks to Kent Frederik + * Fix Filter exec refcount, breaking earlier parse exits with __DATA__ RT #101668 + Thanks to user42_kevin@yahoo.com.au + * Add missing filter_del in exec filter. + * Add pod for Filter::Util::Call::unimport to fix t/z_pod-coverage.t + +1.54 2015-01-17 rurban +---- + + * Fix some compiler warnings for -Wall. Some patches by Dave Mitchell. RT #101587 + Note that perl5 itself is not yet -pedantic safe, Filter is. + +1.53 2014-12-20 rurban +---- + + * Re-release caused by broken SIGNATURE, caused by broken ExtUtils::Makemaker distsignature rules. + See https://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker/issues/177 + +1.52 2014-12-19 rurban +---- + + * Fix Filter::Util::Call regression from 1.50, for filter_add({}) or filter_add([]). + This broke Switch, see RT #101004. + +1.51 2014-12-09 rurban +---- + + * Minor -Wall -Wextra cleanups by jhi and me. Fixes RT #100742 + * Updated Copyright years + * Document and warn about its limitations + +1.50 2014-06-04 rurban +---- + + * Do not re-bless already blessed filter_add arguments into the callers package. + Fixes RT #54452 + * t/z_pod-coverage.t: omit empty Filter::decrypt (also fixes RT #84405) + * Fix Perl Compiler detection in Filter::decrypt + +1.49 2013-04-02 rurban +---- + + * Better fix for RT #41285 test failures with non-english locale + (patched by srezic, pull #1) + + * Add t/z_*.t meta tests (now for real), move Try to t/FilterTry, + add POD to Filter::Util::Call, Filter::Util::Exec and generated + FilterTry. + +1.48 2013-04-01 rurban +---- + + * added META records, such as repository, recommends to Makefile.PL + + * added META and POD tests + +1.47 2013-03-31 rurban +---- + + * Reproduced and fixed RT #41285 test failures with non-english locale + (reported by srezic) + +1.46 2013-03-29 rurban +---- + + * Fix RT #84292 PIPE_PID/waitpid broken in Exec pipe_read since 5.17.6 (rurban) + + * Fix RT #84210 Bad NAME in Makefile.PL (miyagawa) + + * Fix RT #82687 cpansign MANIFEST failure (myra) + + * Work on RT #41285 test failures with non-english locale (reported by srezic) + + * Skip patching the src for newWarnings style, these are the default (rurban) + + * Fix RT #53132 examples/method/Decompress.pm syntax error (kevin ryde) + and add usage docs. + +1.45 2012-06-19 rurban +---- + + * Sync perlfilter.pod with core improvements + +1.44 2012-06-18 rurban +---- + + * Sync t/call.t with core fixes in 2adbc9b6 + + +1.43 21 Feb 2012 rurban +---- + + * Fix more windows tests: + http://www.cpantesters.org/cpan/report/9e790a72-6bf5-1014-9f3b-641f296be760 + +1.42 20 Feb 2012 rurban +---- + + * Improve t/tee.t test 5 on windows which allows all Administrator + members read-access [RT #75164] + +1.41 18 Feb 2012 rurban +---- + + * Hide example packages from the pause indexer + +1.40 9 Feb 2012 rurban +---- + + * Fix tee and all tests to work with Perl 5.14 and higher. + PVIO has no IV field anymore, so abuse the empty IoOFP, + which is only used for printing, not reading. + Fixes [RT #56875] and more. + Tested for 5.6.2, 5.8.4, 5.8.5, 5.8.8, 5.8.9, 5.10.1, 5.12.4, + 5.14.2, 5.15.7 + +1.39 30 April 2011 +---- + + * Fix decrypt to work with Perl 5.14 + [RT #67656] + +1.38 24 April 2011 +---- + + * Versions being seperate from Module versions results in dependency confusion + Bumped all versions to match the distribution version number. + [RT #67655] + + * Fix decrypt to work with Perl 5.14 + [RT #67656] + + * Update the Filter-Simple URL + [RT #49778] + +1.37 9 June 2009 +---- + + * No new feature or bug fixes - just sync with perl core. + +1.36 28 February 2009 +---- + + * Fixed install issue [RT #28232] + +1.35 25 February 2009 +---- + + * Included Core patches 32864, 33341 & 34776 + + * Side effect of above patches means that Filters needs at least Perl 5.005 + +1.34 7 July 2007 +---- + + * Included Core patch #31200 - change to support perl 5.10 for + Filter::Util::Call + + * Also included the equivalent changes for the other filters. Patch + kindly provided by Steve Hay. + +1.33 1 March 2007 +---- + + * fixed ninstr issue for 5.8.9 + + * added t/pod.t + +1.32 3 January 2006 +---- + + * Added core patch 26509 -- fix out by one bug in Call.xs + Problem reported & fixed by Gisle Aas. + +1.31 31 August 2005 +---- + + * added 'libscan' to Makefile.PL to stop .bak files being installed. + [rt.cpan.org: Ticket #14356 .bak files are being installed ] + +1.30 16 August 2003 +---- + + * rewording of reference to Filter::Simple + + * merged core patch 18269 + +1.29 29 June 2002 +---- + + * Fixed problem with sleep in Exec.xs. Patch provided by Charles Randall. + + * Exec.xs now used waitpid, when available, instead or wait. Patch provided + by Richard Clamp. + + * Also the place where the wait is called has been changed. + Deadlock condition spotted by Andrej Czapszys. + +1.28 +---- + + * Fixed bug in Filter::cpp where $Config{cppstdin} refered to an executable + with an absolute path. Bug spotted by P. Kent. + +1.27 +---- + + * Patch from Wim Verhaegen to allow cpp to be an absolute path + + * Patch from Gurusamy Sarathy to fix a Windods core dump in Exec.xs -- + dMY_CXT was being accessed before it was ititialised. + + * Merged core patch 13940 + +1.26 +---- + + * Call & Exec now use the CXT* macros + + * moved all backward compatability code into ppport.h + +1.25 +---- + + * Fixed minor typo in Makefile.PL + +1.24 +---- + + * Fixed sh.t, exec.t & cpp.t to work properly on NT + patch courtesy of Steve Hay. + + * The detection of cpp in cpp.pm is now more robust + patch courtesy of Michael Schwern + + * Changed na to PL_na in decrypt.xs + + * Merged Core patches 10752, 11434 + +1.23 Monday 23rd April 2001 +---- + + * Modified Makefile.PL to only enable the warnings pragma if using perl + 5.6.1 or better. + +1.22 Wednesday 21st February 20001 +---- + + * Added Michael G Schwern's example of a practical use of Filter::cpp + into the pod. + + * Filter::cpp assumed that cpp.exe is always available on MSWin32. Logic + has been added to check for the existence of cpp.exe. + + * Added a reference to Damian Conway's excellent Filter::Simple module. + + * Merged Core patch 9176 + +1.21 Monday 19th February 20001 +---- + + * Added logic in Makefile.PL to toggle between using $^W and + the warnings pragma in the module. + + * The module, the examples & the test harness are now all strict + & warnings clean. + +1.20 Sunday 7th January 2001 +---- + + * Added a SYNOPSIS to Call.pm & Exec.pm + + * Integrated perl core patches 7849, 7913 & 7931. + + * Modified decrypt.t to fix a case where HP-UX didn't pass test 4. + +1.19 Thursday 20th July 2000 +---- + + * Added a test in decrypt.xs to check if the Compiler backend is in use. + Thanks to Andrew Johnson for bringing this to my attention. + +1.18 Sunday 2nd April 2000 +---- + + * Test harnesses are more robust on Win32. + + * Fixed a problem where an __END__ or __DATA__ could crash Perl. + +1.17 Friday 10th December 1999 +---- + + * Addition of perlfilter.pod. This is the Source Filters article from + The Perl Journal, issue 11 and is identical to the file that is + distributed with Perl starting withversion 5.005_63. + +1.16 wednesday 17th March 1999 +---- + + * Upgraded to use the new PL_* symbols. Means the module can build with + Perl5.005_5*. + +1.15 Monday 26th October 1998 +---- + + * Fixed a bug in the tee filter. + + * Applied patch from Gurusamy Sarathy which prevents Exec from coredump + when perl |is run with PERL_DESTRUCT_LEVEL. + +1.14 Thursday 1st January 1998 +---- + + * patch from Gurusamy Sarathy to allow the filters to build when + threading is enabled. + +1.13 Monday 29th December 1997 +---- + + * added the order test harness. + + * patch from Gurusamy Sarathy to get the filters to build and pass + all tests on NT. + +1.12 Tuesday 25th March 1997 +---- + + * Patch from Andreas Koenig to make tee.xs compile when useperio is + enabled. + + * Fix Call interface to work with 5.003_94 + +1.11 Tuesday 29th October 1996 +---- + + * test harness for decrypt doesn't display the debugger banner + message any more. + + * casted uses of IoTOP_GV in Call.xs, decrypt.xs and Exec.xs to keep + the IRIX compiler happy. + +1.10 Thursday 20th June 1996 +---- + + * decrypt now calls filter_del. + +1.09 Wednesday 22nd April 1996 +---- + + * Fixed a warning in Exec.xs - added a cast to safefree + + * Makefile.PL now uses VERSION_FROM + + * Made all filter modules strict clean. + + * The simple encrypt script supplied with the decryption filter will + now preserve the original file permissions. In addition if the + first line of the script begins with "#!", the line will be + preserved in the encrypted version. + +1.08 Friday 15th December 1995 +---- + + * Fixed a bug in Exec.xs - wait was being called without a parameter. + + * Added a closure option to Call + +1.07 Wednesday 29th November 1995 +---- + + * exec now uses the non-blocking IO constants from Configure. Thanks + to Raphael for writing the dist module and to Andy for including it + in Configure. + + * The decrypt filter has been enhanced to detect when it is + executing as a dynamically linked module and if DEBUGGING is + enabled. Thanks to Tim for providing the dynamic module test. + + * Tim provided a pile of bug fixes for decrypt.xs + + * Filter::call has been renamed Filter::Util::Call and the logic for + installing it has been changed. + + * The workings of the filter method in Filter::Util::Call has been + changed. + +1.06 Sunday 2nd July 1995 +---- + + * Renamed decrypt.test to decrypt.tst. + + * Renamed mytest.pl to mytest - it was getting installed. + + * exec.xs had a bit of debugging code lurking around. This meant + that O_NONBLOCK was *always* being used to set non-blocking i/o. + This has been removed. + + * Changed the way O_NONBLOCK/O_NDELAY was being detected. The Tk + method is now used. + + * Addition of Filter::call - first go at implementation of perl filters. + +1.05 Monday 26th June 1995 +---- + + * updated MANIFEST + + * tee.t test 5 has been hard-wired to return true if run as root. + + * The test files don't use $^X to invoke perl any more. I've passed + the MakeMaker symbol FULLPERL via an environment variable. A bit + of a kludge, but it does work :-) + + * added a mytest target to allow users to play with the Filters + without having to install them. + + * The EWOULDBLOCK/EAGAIN stuff has been wrapped in preprocessor code. + + * The hints files don't seem to be needed anymore. + +1.04 Sunday 25th June 1995 +---- + + * The test harness now uses $^X to invoke Perl. + +1.03 Sunday 25th June 1995 +---- + + * Tidied up the build process so that it doesn't need an empty + Filter.xs file. + +1.02 Tuesday 20th June 1995 +---- + + * First release. diff --git a/Exec/Exec.pm b/Exec/Exec.pm new file mode 100644 index 0000000..fae4e7a --- /dev/null +++ b/Exec/Exec.pm @@ -0,0 +1,54 @@ +package Filter::Util::Exec ; + +require 5.006 ; +require XSLoader; +our $VERSION = "1.58" ; + +XSLoader::load('Filter::Util::Exec'); +1 ; +__END__ + +=head1 NAME + +Filter::Util::Exec - exec source filter + +=head1 SYNOPSIS + + use Filter::Util::Exec; + +=head1 DESCRIPTION + +This module is provides the interface to allow the creation of I which use a Unix coprocess. + +See L, L and L for examples of +the use of this module. + +Note that the size of the buffers is limited to 32-bit. + +=head2 B + +The function, C installs a filter. It takes one +parameter which should be a reference. The kind of reference used will +dictate which of the two filter types will be used. + +If a CODE reference is used then a I will be assumed. + +If a CODE reference is not used, a I will be assumed. +In a I, the reference can be used to store context +information. The reference will be I into the package by +C. + +See L for examples of using context information +using both I and I. + +=head1 AUTHOR + +Paul Marquess + +=head1 DATE + +11th December 1995. + +=cut + diff --git a/Exec/Exec.xs b/Exec/Exec.xs new file mode 100644 index 0000000..f03c1ca --- /dev/null +++ b/Exec/Exec.xs @@ -0,0 +1,630 @@ +/* + * Filename : exec.xs + * + * Author : Paul Marquess + * Date : 2014-12-09 02:50:27 rurban + * Version : 1.58 + * + */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include "../Call/ppport.h" + +#include + +/* Global Data */ + +#define MY_CXT_KEY "Filter::Util::Exec::_guts" XS_VERSION + +typedef struct { + int x_fdebug ; +#ifdef WIN32 + int x_write_started; + int x_pipe_pid; +#endif +} my_cxt_t; + +START_MY_CXT + +#define fdebug (MY_CXT.x_fdebug) +#ifdef WIN32 +#define write_started (MY_CXT.x_write_started) +#define pipe_pid (MY_CXT.x_pipe_pid) +#endif + +#ifdef PERL_FILTER_EXISTS +# define CORE_FILTER_SCRIPT PL_parser->rsfp +#else +# define CORE_FILTER_SCRIPT PL_rsfp +#endif + + +#define PIPE_IN(sv) IoLINES(sv) +#define PIPE_OUT(sv) IoPAGE(sv) +#define PIPE_PID(sv) IoLINES_LEFT(sv) + +#define BUF_SV(sv) IoTOP_GV(sv) +#define BUF_START(sv) SvPVX((SV*) BUF_SV(sv)) +#define BUF_SIZE(sv) SvCUR((SV*) BUF_SV(sv)) +#define BUF_NEXT(sv) IoFMT_NAME(sv) +#define BUF_END(sv) (BUF_START(sv) + BUF_SIZE(sv)) +#define BUF_OFFSET(sv) IoPAGE_LEN(sv) + +#define SET_LEN(sv,len) \ + do { SvPVX(sv)[len] = '\0'; SvCUR_set(sv, len); } while (0) + +#define BLOCKSIZE 100 + + +#ifdef WIN32 + +typedef struct { + SV * sv; + int idx; +#ifdef USE_THREADS + struct perl_thread * parent; +#endif +#ifdef USE_ITHREADS + PerlInterpreter * parent; +#endif +} thrarg; + +static void +pipe_write(void *args) +{ + thrarg *targ = (thrarg *)args; + SV *sv = targ->sv; + int idx = targ->idx; + int pipe_in = PIPE_IN(sv) ; + int pipe_out = PIPE_OUT(sv) ; + int rawread_eof = 0; + int r,w,len; +#ifdef USE_THREADS + /* use the parent's perl thread context */ + SET_THR(targ->parent); +#endif +#ifdef USE_ITHREADS + PERL_SET_THX(targ->parent); +#endif + { + dMY_CXT; + free(args); + for(;;) + { + + /* get some raw data to stuff down the pipe */ + /* But only when BUF_SV is empty */ + if (!rawread_eof && BUF_NEXT(sv) >= BUF_END(sv)) { + /* empty BUF_SV */ + SvCUR_set((SV*)BUF_SV(sv), 0) ; + if ((len = FILTER_READ(idx+1, (SV*) BUF_SV(sv), 0)) > 0) { + BUF_NEXT(sv) = BUF_START(sv); + if (fdebug) + warn ("*pipe_write(%d) Filt Rd returned %d %d [%*s]\n", + idx, len, BUF_SIZE(sv), BUF_SIZE(sv), BUF_START(sv)) ; + } + else { + /* eof, close write end of pipe after writing to it */ + rawread_eof = 1; + } + } + + /* write down the pipe */ + if ((w = BUF_END(sv) - BUF_NEXT(sv)) > 0) { + errno = 0; + if ((w = write(pipe_out, BUF_NEXT(sv), w)) > 0) { + BUF_NEXT(sv) += w; + if (fdebug) + warn ("*pipe_write(%d) wrote %d bytes to pipe\n", idx, w) ; + } + else { + if (fdebug) + warn ("*pipe_write(%d) closing pipe_out errno = %d %s\n", + idx, errno, Strerror(errno)) ; + close(pipe_out) ; + CloseHandle((HANDLE)pipe_pid); + write_started = 0; + return; + } + } + else if (rawread_eof) { + if (fdebug) + warn ("*pipe_write(%d) closing pipe_out errno = %d %s\n", + idx, errno, Strerror(errno)) ; + close(pipe_out); + CloseHandle((HANDLE)pipe_pid); + write_started = 0; + return; + } + } + } +} + +static int +pipe_read(SV *sv, int idx, int maxlen) +{ + dMY_CXT; + int pipe_in = PIPE_IN(sv) ; + int pipe_out = PIPE_OUT(sv) ; + + int r ; + int w ; + int len ; + + if (fdebug) + warn ("*pipe_read(sv=%d, SvCUR(sv)=%d, idx=%d, maxlen=%d\n", + sv, SvCUR(sv), idx, maxlen) ; + + if (!maxlen) + maxlen = 1024 ; + + /* just make sure the SV is big enough */ + SvGROW(sv, SvCUR(sv) + maxlen) ; + + if ( !BUF_NEXT(sv) ) + BUF_NEXT(sv) = BUF_START(sv); + + if (!write_started) { + thrarg *targ = (thrarg*)malloc(sizeof(thrarg)); + targ->sv = sv; targ->idx = idx; +#ifdef USE_THREADS + targ->parent = THR; +#endif +#ifdef USE_ITHREADS + targ->parent = aTHX; +#endif + /* thread handle is closed when pipe_write() returns */ + _beginthread(pipe_write,0,(void *)targ); + write_started = 1; + } + + /* try to get data from filter, if any */ + errno = 0; + len = SvCUR(sv) ; + if ((r = read(pipe_in, SvPVX(sv) + len, maxlen)) > 0) + { + if (fdebug) + warn ("*pipe_read(%d) from pipe returned %d [%*s]\n", + idx, r, r, SvPVX(sv) + len) ; + SvCUR_set(sv, r + len) ; + return SvCUR(sv); + } + + if (fdebug) + warn ("*pipe_read(%d) returned %d, errno = %d %s\n", + idx, r, errno, Strerror(errno)) ; + + /* close the read pipe on error/eof */ + if (fdebug) + warn("*pipe_read(%d) -- EOF <#########\n", idx) ; + close (pipe_in) ; + return 0; +} + +#else /* !WIN32 */ + + +static int +pipe_read(SV *sv, int idx, int maxlen) +{ + dMY_CXT; + int pipe_in = PIPE_IN(sv) ; + int pipe_out = PIPE_OUT(sv) ; +#if (PERL_VERSION < 17 || (PERL_VERSION == 17 && PERL_SUBVERSION < 6)) && defined(HAVE_WAITPID) + int pipe_pid = PIPE_PID(sv) ; +#endif + + int r ; + int w ; + int len ; + + if (fdebug) + warn ("*pipe_read(sv=%p, SvCUR(sv)=%" IVdf ", idx=%d, maxlen=%d)\n", + sv, SvCUR(sv), idx, maxlen) ; + + if (!maxlen) + maxlen = 1024 ; + + /* just make sure the SV is big enough */ + SvGROW(sv, SvCUR(sv) + maxlen) ; + + for(;;) + { + if ( !BUF_NEXT(sv) ) + BUF_NEXT(sv) = BUF_START(sv); + else + { + /* try to get data from filter, if any */ + errno = 0; + len = SvCUR(sv) ; + if ((r = read(pipe_in, SvPVX(sv) + len, maxlen)) > 0) + { + if (fdebug) + warn ("*pipe_read(%d) from pipe returned %d [%*s]\n", + idx, r, r, SvPVX(sv) + len) ; + SvCUR_set(sv, r + len) ; + return SvCUR(sv); + } + + if (fdebug) + warn ("*pipe_read(%d) returned %d, errno = %d %s\n", + idx, r, errno, Strerror(errno)) ; + + if (errno != VAL_EAGAIN) + { + /* close the read pipe on error/eof */ + if (fdebug) + warn("*pipe_read(%d) -- EOF <#########\n", idx) ; + close (pipe_in) ; +#if PERL_VERSION < 17 || (PERL_VERSION == 17 && PERL_SUBVERSION < 6) +#ifdef HAVE_WAITPID + waitpid(pipe_pid, NULL, 0) ; +#else + wait(NULL); +#endif +#else + sleep(0); +#endif + return 0; + } + } + + /* get some raw data to stuff down the pipe */ + /* But only when BUF_SV is empty */ + if (BUF_NEXT(sv) >= BUF_END(sv)) + { + /* empty BUF_SV */ + SvCUR_set((SV*)BUF_SV(sv), 0) ; + if ((len = FILTER_READ(idx+1, (SV*) BUF_SV(sv), 0)) > 0) { + BUF_NEXT(sv) = BUF_START(sv); + if (fdebug) + warn ("*pipe_write(%d) Filt Rd returned %d %" IVdf " [%*s]\n", + idx, len, BUF_SIZE(sv), (int)BUF_SIZE(sv), BUF_START(sv)) ; + } + else { + /* eof, close write end of pipe */ + close(pipe_out) ; + if (fdebug) + warn ("*pipe_read(%d) closing pipe_out errno = %d %s\n", + idx, errno, Strerror(errno)) ; + } + } + + /* write down the pipe */ + if ((w = BUF_END(sv) - BUF_NEXT(sv)) > 0) + { + errno = 0; + if ((w = write(pipe_out, BUF_NEXT(sv), w)) > 0) { + BUF_NEXT(sv) += w; + if (fdebug) + warn ("*pipe_read(%d) wrote %d bytes to pipe\n", idx, w) ; + } + else if (errno != VAL_EAGAIN) { + if (fdebug) + warn ("*pipe_read(%d) closing pipe_out errno = %d %s\n", + idx, errno, Strerror(errno)) ; + /* close(pipe_out) ; */ + return 0; + } + else { /* pipe is full, sleep for a while, then continue */ + if (fdebug) + warn ("*pipe_read(%d) - sleeping\n", idx ) ; + sleep(0); + } + } + } +} + + +static void +make_nonblock(int f) +{ + int RETVAL = 0; + int mode = fcntl(f, F_GETFL); + + if (mode < 0) + croak("fcntl(f, F_GETFL) failed, RETVAL = %d, errno = %d", + mode, errno) ; + + if (!(mode & VAL_O_NONBLOCK)) + RETVAL = fcntl(f, F_SETFL, mode | VAL_O_NONBLOCK); + + if (RETVAL < 0) + croak("cannot create a non-blocking pipe, RETVAL = %d, errno = %d", + RETVAL, errno) ; +} + +#endif + + +#define READER 0 +#define WRITER 1 + +static Pid_t +spawnCommand(PerlIO *fil, char *command, char *parameters[], int *p0, int *p1) +{ + dMY_CXT; +#ifdef WIN32 + +#if defined(PERL_OBJECT) +# define win32_pipe(p,n,f) _pipe(p,n,f) +#endif + + int p[2], c[2]; + SV * sv ; + int oldstdout, oldstdin; + + /* create the pipes */ + if (win32_pipe(p,512,O_TEXT|O_NOINHERIT) == -1 + || win32_pipe(c,512,O_BINARY|O_NOINHERIT) == -1) { + PerlIO_close( fil ); + croak("Can't get pipe for %s", command); + } + + /* duplicate stdout and stdin */ + oldstdout = dup(fileno(stdout)); + if (oldstdout == -1) { + PerlIO_close( fil ); + croak("Can't dup stdout for %s", command); + } + oldstdin = dup(fileno(stdin)); + if (oldstdin == -1) { + PerlIO_close( fil ); + croak("Can't dup stdin for %s", command); + } + + /* duplicate inheritable ends as std handles for the child */ + if (dup2(p[WRITER], fileno(stdout))) { + PerlIO_close( fil ); + croak("Can't attach pipe to stdout for %s", command); + } + if (dup2(c[READER], fileno(stdin))) { + PerlIO_close( fil ); + croak("Can't attach pipe to stdin for %s", command); + } + + /* close original inheritable ends in parent */ + close(p[WRITER]); + close(c[READER]); + + /* spawn child process (which inherits the redirected std handles) */ + pipe_pid = spawnvp(P_NOWAIT, command, parameters); + if (pipe_pid == -1) { + PerlIO_close( fil ); + croak("Can't spawn %s", command); + } + + /* restore std handles */ + if (dup2(oldstdout, fileno(stdout))) { + PerlIO_close( fil ); + croak("Can't restore stdout for %s", command); + } + if (dup2(oldstdin, fileno(stdin))) { + PerlIO_close( fil ); + croak("Can't restore stdin for %s", command); + } + + /* close saved handles */ + close(oldstdout); + close(oldstdin); + + *p0 = p[READER] ; + *p1 = c[WRITER] ; + +#else /* !WIN32 */ + + int p[2], c[2]; + int pipepid; + + /* Check that the file is seekable */ + /* if (lseek(fileno(fil), ftell(fil), 0) == -1) { */ + /* croak("lseek failed: %s", Strerror(errno)) ; */ + /* } */ + + if (pipe(p) < 0 || pipe(c)) { + PerlIO_close( fil ); + croak("Can't get pipe for %s", command); + } + + /* make sure that the child doesn't get anything extra */ + fflush(stdout); + fflush(stderr); + + while ((pipepid = fork()) < 0) { + if (errno != EAGAIN) { + close(p[0]); + close(p[1]); + close(c[0]) ; + close(c[1]) ; + PerlIO_close( fil ); + croak("Can't fork for %s", command); + } + sleep(1); + } + + if (pipepid == 0) { + /* The Child */ + + close(p[READER]) ; + close(c[WRITER]) ; + if (c[READER] != 0) { + dup2(c[READER], 0); + close(c[READER]); + } + if (p[WRITER] != 1) { + dup2(p[WRITER], 1); + close(p[WRITER]); + } + + /* Run command */ + execvp(command, parameters) ; + croak("execvp failed for command '%s': %s", command, Strerror(errno)) ; + fflush(stdout); + fflush(stderr); + _exit(0); + } + + /* The parent */ + + close(p[WRITER]) ; + close(c[READER]) ; + + /* make the pipe non-blocking */ + make_nonblock(p[READER]) ; + make_nonblock(c[WRITER]) ; + + *p0 = p[READER] ; + *p1 = c[WRITER] ; + + return pipepid; +#endif +} + + +static I32 +filter_exec(pTHX_ int idx, SV *buf_sv, int maxlen) +{ + dMY_CXT; + SV *buffer = FILTER_DATA(idx); + char * out_ptr = SvPVX(buffer) ; + int n ; + char * p ; + char * nl = "\n" ; + + if (fdebug) + warn ("filter_sh(idx=%d, SvCUR(buf_sv)=%" IVdf ", maxlen=%d\n", + idx, SvCUR(buf_sv), maxlen) ; + while (1) { + STRLEN n_a; + + /* If there was a partial line/block left from last time + copy it now + */ + if ((n = SvCUR(buffer))) { + out_ptr = SvPVX(buffer) + BUF_OFFSET(buffer) ; + if (maxlen) { + /* want a block */ + if (fdebug) + warn("filter_sh(%d) - wants a block\n", idx) ; + sv_catpvn(buf_sv, out_ptr, maxlen > n ? n : maxlen ); + if(n <= maxlen) { + BUF_OFFSET(buffer) = 0 ; + SET_LEN(buffer, 0) ; + } + else { + BUF_OFFSET(buffer) += maxlen ; + SvCUR_set(buffer, n - maxlen) ; + } + return SvCUR(buf_sv); + } + else { + /* want a line */ + if (fdebug) + warn("filter_sh(%d) - wants a line\n", idx) ; + if ((p = ninstr(out_ptr, out_ptr + n, nl, nl + 1))) { + sv_catpvn(buf_sv, out_ptr, p - out_ptr + 1); + n = n - (p - out_ptr + 1); + BUF_OFFSET(buffer) += (p - out_ptr + 1); + SvCUR_set(buffer, n) ; + if (fdebug) + warn("recycle(%d) - leaving %d [%s], returning %" IVdf " %" IVdf " [%s]", + idx, n, + SvPVX(buffer), p - out_ptr + 1, + SvCUR(buf_sv), SvPVX(buf_sv)) ; + + return SvCUR(buf_sv); + } + else /* partial buffer didn't have any newlines, so copy it all */ + sv_catpvn(buf_sv, out_ptr, n) ; + } + } + + /* the buffer has been consumed, so reset the length */ + SET_LEN(buffer, 0) ; + BUF_OFFSET(buffer) = 0 ; + + /* read from the sub-process */ + if ( (n=pipe_read(buffer, idx, maxlen)) <= 0) { + + if (fdebug) + warn ("filter_sh(%d) - pipe_read returned %d , returning %" IVdf "\n", + idx, n, (SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : (STRLEN)n); + + SvCUR_set(buffer, 0); + BUF_NEXT(buffer) = Nullch; /* or perl will try to free() it */ + filter_del(filter_exec); + + /* If error, return the code */ + if (n < 0) + return n ; + + /* return what we have so far else signal eof */ + return (SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : n; + } + + if (fdebug) + warn(" filter_sh(%d): pipe_read returned %d %" IVdf ": '%s'", + idx, n, SvCUR(buffer), SvPV(buffer,n_a)); + + } + +} + + +MODULE = Filter::Util::Exec PACKAGE = Filter::Util::Exec + +REQUIRE: 1.924 +PROTOTYPES: ENABLE + +BOOT: + { + MY_CXT_INIT; +#ifdef FDEBUG + fdebug = 1; +#else + fdebug = 0; +#endif + /* temporary hack to control debugging in toke.c */ + filter_add(NULL, (fdebug) ? (SV*)"1" : (SV*)"0"); + } + + +void +filter_add(module, command, ...) + SV * module = NO_INIT + char ** command = (char**) safemalloc(items * sizeof(char*)) ; + PROTOTYPE: $@ + CODE: + dMY_CXT; + int i ; + int pipe_in, pipe_out ; + STRLEN n_a ; + /* SV * sv = newSVpv("", 0) ; */ + SV * sv = SvREFCNT_inc(newSV(1)); + Pid_t pid; + + if (fdebug) + warn("Filter::exec::import\n") ; + for (i = 1 ; i < items ; ++i) + { + command[i-1] = SvPV(ST(i), n_a) ; + if (fdebug) + warn(" %s\n", command[i-1]) ; + } + command[i-1] = NULL ; + filter_add(filter_exec, sv); + pid = spawnCommand(CORE_FILTER_SCRIPT, command[0], command, &pipe_in, &pipe_out) ; + safefree((char*)command); + + PIPE_PID(sv) = pid ; + PIPE_IN(sv) = pipe_in ; + PIPE_OUT(sv) = pipe_out ; + /* BUF_SV(sv) = newSVpv("", 0) ; */ + BUF_SV(sv) = (GV*) newSV(1) ; + (void)SvPOK_only(BUF_SV(sv)) ; + BUF_NEXT(sv) = NULL ; + BUF_OFFSET(sv) = 0 ; + + diff --git a/Exec/Makefile.PL b/Exec/Makefile.PL new file mode 100755 index 0000000..5b8974a --- /dev/null +++ b/Exec/Makefile.PL @@ -0,0 +1,7 @@ +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'Filter::Util::Exec', + VERSION_FROM => 'Exec.pm', +); + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..1c56c7a --- /dev/null +++ b/MANIFEST @@ -0,0 +1,64 @@ +.appveyor.yml +.gitignore +.travis.yml +Call/Call.pm +Call/Call.xs +Call/Makefile.PL +Call/ppport.h +Call/typemap +Changes +Exec/Exec.pm +Exec/Exec.xs +Exec/Makefile.PL +MANIFEST +MANIFEST.SKIP +Makefile.PL +README +decrypt/Makefile.PL +decrypt/decr +decrypt/decrypt.pm +decrypt/decrypt.xs +decrypt/encrypt +examples/closure/Count.pm +examples/closure/Decompress.pm +examples/closure/Include.pm +examples/closure/Joe2Jim.pm +examples/closure/NewSubst.pm +examples/closure/Subst.pm +examples/closure/UUdecode.pm +examples/filtdef +examples/filtuu +examples/method/Count.pm +examples/method/Decompress.pm +examples/method/Joe2Jim.pm +examples/method/NewSubst.pm +examples/method/Subst.pm +examples/method/UUdecode.pm +lib/Filter/cpp.pm +lib/Filter/exec.pm +lib/Filter/sh.pm +mytest +perlfilter.pod +t/call.t +t/cpp.t +t/decrypt.t +t/exec.t +t/filter-util.pl +t/order.t +t/rt_101033.pm +t/rt_101033.t +t/rt_54452-rebless.t +t/sh.t +t/tee.t +t/z_kwalitee.t +t/z_manifest.t +t/z_meta.t +t/z_perl_minimum_version.t +t/z_pod-coverage.t +t/z_pod.t +tee/Makefile.PL +tee/tee.pm +tee/tee.xs +META.yml Module YAML meta-data (added by MakeMaker) +META.json Module JSON meta-data (added by MakeMaker) +SIGNATURE Public-key signature (added by MakeMaker) diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP new file mode 100644 index 0000000..6dee6c9 --- /dev/null +++ b/MANIFEST.SKIP @@ -0,0 +1 @@ +.gitgnore diff --git a/META.json b/META.json new file mode 100644 index 0000000..b5d2756 --- /dev/null +++ b/META.json @@ -0,0 +1,60 @@ +{ + "abstract" : "Source Filters", + "author" : [ + "Paul Marquess " + ], + "dynamic_config" : 1, + "generated_by" : "ExtUtils::MakeMaker version 7.3, CPAN::Meta::Converter version 2.150010", + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : "2" + }, + "name" : "Filter", + "no_index" : { + "directory" : [ + "t", + "inc" + ] + }, + "prereqs" : { + "build" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "configure" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "runtime" : { + "recommends" : { + "Class::XSAccessor" : "0", + "Filter::Simple" : "0.88", + "Filter::Simple::Compile" : "0.02", + "List::MoreUtils" : "0", + "Perl::MinimumVersion" : "0", + "Pod::Spell::CommonMistakes" : "0", + "Test::CPAN::Meta" : "0", + "Test::Kwalitee" : "0", + "Test::More" : "0.88", + "Test::Pod" : "1.00", + "Text::CSV_XS" : "0" + } + } + }, + "release_status" : "stable", + "resources" : { + "license" : [ + "http://dev.perl.org/licenses/" + ], + "repository" : { + "url" : "https://github.com/rurban/Filter" + } + }, + "version" : "1.58", + "x_serialization_backend" : "JSON::PP version 2.27400_02" +} diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..0e1ea61 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,171 @@ +use ExtUtils::MakeMaker; + +BEGIN +{ + die "Filters needs Perl version 5.005 or better, you have $]\n" + if $] < 5.005 ; + + warn "Perl 5.6.0 or better is strongly recommended for Win32\n" + if $^O eq 'MSWin32' && $] < 5.006 ; +} + +use strict; + +my @files = qw( t/filter-util.pl + Call/Call.pm + Exec/Exec.pm + decrypt/decrypt.pm decrypt/decr decrypt/encrypt + tee/tee.pm + lib/Filter/cpp.pm lib/Filter/exec.pm lib/Filter/sh.pm + examples/filtdef + examples/method/Count.pm + examples/method/NewSubst.pm + examples/method/UUdecode.pm + examples/method/Decompress.pm + examples/method/Joe2Jim.pm + examples/method/Subst.pm + examples/closure/Count.pm + examples/closure/NewSubst.pm + examples/closure/UUdecode.pm + examples/closure/Decompress.pm + examples/closure/Include.pm + examples/closure/Joe2Jim.pm + examples/closure/Subst.pm + examples/filtdef + examples/filtuu + t/call.t + t/cpp.t + t/decrypt.t + t/exec.t + t/order.t + t/sh.t + t/tee.t + ); + +if ($] < 5.006001) { oldWarnings(@files) } +# keep the src in the new-warnings style +#else { newWarnings(@files) } + +WriteMakefile + ( + DISTNAME => 'Filter', + NAME => 'Filter::Util::Call', + VERSION_FROM => 'Call/Call.pm', + 'linkext' => {LINKTYPE => ''}, + 'dist' => {COMPRESS=>'gzip', SUFFIX=>'gz', + DIST_DEFAULT => 'tardist'}, + 'SIGN' => 1, + ($] >= 5.005 + ? (ABSTRACT => 'Source Filters', + AUTHOR => 'Paul Marquess ') + : () + ), + + INSTALLDIRS => ($] >= 5.00703 && $] < 5.011 ? 'perl' : 'site'), + + ((ExtUtils::MakeMaker->VERSION() gt '6.30') ? + ('LICENSE' => 'perl', SIGN => 1) : ()), + ((ExtUtils::MakeMaker->VERSION() gt '6.46') ? + ('META_MERGE' => + {recommends => + { + 'Filter::Simple' => '0.88', + 'Filter::Simple::Compile' => '0.02', + 'Test::More' => '0.88', + 'Test::Kwalitee' => 0, + 'Class::XSAccessor' => 0, + 'Text::CSV_XS' => 0, + 'List::MoreUtils' => 0, + 'Pod::Spell::CommonMistakes' => 0, + 'Test::Pod' => '1.00', + 'Test::CPAN::Meta' => 0, + 'Perl::MinimumVersion' => 0, + }, + resources => + { + license => 'http://dev.perl.org/licenses/', + repository => 'https://github.com/rurban/Filter', + }}) : ()), + clean => { FILES => + "t/FilterTry.pm *~ " + ."META.yml MYMETA.yml MYMETA.json " + ."decrypt/MYMETA.yml decrypt/MYMETA.json decrypt/Makefile.old decrypt/pm_to_blib decrypt/*.c decrypt/*.o " + ."tee/MYMETA.yml tee/MYMETA.json tee/Makefile.old tee/pm_to_blib tee/*.c tee/*.o " + ."Exec/MYMETA.yml Exec/MYMETA.json Exec/Makefile.old Exec/pm_to_blib Exec/*.c Exec/*.o " + ."Call/MYMETA.yml Call/MYMETA.json Call/Makefile.old Call/pm_to_blib Call/*.c Call/*.o" + } + ); + +sub MY::libscan +{ + my $self = shift ; + my $path = shift ; + + return undef + if $path =~ /(~|\.bak)$/ || + $path =~ /^\..*\.swp$/ ; + + return $path; +} + +#sub MY::postamble +#{ +# ' +# +#MyDoubleCheck: +# @echo Checking for $$^W in files +# @perl -ne \' \ +# exit 1 if /^\s*local\s*\(\s*\$$\^W\s*\)/; \ +# \' ' . " @files || " . ' \ +# (echo found unexpected $$^W ; exit 1) +# @echo All is ok. +# +#' ; +#} + +sub oldWarnings +{ + local ($^I) = ".bak" ; + local (@ARGV) = @_ ; + + while (<>) + { + if (/^__END__/) + { + print ; + my $this = $ARGV ; + while (<>) + { + last if $ARGV ne $this ; + print ; + } + } + + s/^(\s*)(no\s+warnings)/${1}local (\$^W) = 0; #$2/ ; + s/^(\s*)(use\s+warnings)/${1}local (\$^W) = 1; #$2/ ; + print ; + } +} + +sub newWarnings +{ + local ($^I) = ".bak" ; + local (@ARGV) = @_ ; + + while (<>) + { + if (/^__END__/) + { + my $this = $ARGV ; + print ; + while (<>) + { + last if $ARGV ne $this ; + print ; + } + } + + s/^(\s*)local\s*\(\$\^W\)\s*=\s*\d+\s*;\s*#\s*((no|use)\s+warnings.*)/$1$2/ ; + print ; + } +} diff --git a/README b/README new file mode 100644 index 0000000..ea0d150 --- /dev/null +++ b/README @@ -0,0 +1,94 @@ + Source Filters + + Version 1.58 + + 2017-11-15 rurban + + Copyright (c) 1995-2011 Paul Marquess. All rights reserved. + Copyright (c) 2011-2014 Reini Urban. All rights reserved. + Copyright (c) 2014-2017 cPanel Inc. All rights reserved. + This program is free software; you can redistribute it and/or + modify it under the same terms as Perl itself. + + + +DESCRIPTION +----------- + +This distribution consists of a number of Source Filters. + +For more details see the pod documentation embedded in the .pm files. + +If you intend using the Filter::Util::Call functionality, I would strongly +recommend that you check out Damian Conway's excellent Filter::Simple +module. Damian's module provides a much cleaner interface than +Filter::Util::Call. Although it doesn't allow the fine control that +Filter::Util::Call does, it should be adequate for the majority of +applications. It's available at + + http://search.cpan.org/dist/Filter-Simple/ + +LIMITATIONS +----------- + +Source filters only work on the string level, thus are highly limited +in its ability to change source code on the fly. It cannot detect +comments, quoted strings, heredocs, it is no replacement for a real +parser. +The only stable usage for source filters are encryption, compression, +or the byteloader, to translate binary code back to source code. + +See for example the limitations in Switch, which uses source filters, +and thus is does not work inside a string eval, the presence of +regexes with embedded newlines that are specified with raw /.../ +delimiters and don't have a modifier //x are indistinguishable from +code chunks beginning with the division operator /. As a workaround +you must use m/.../ or m?...? for such patterns. Also, the presence of +regexes specified with raw ?...? delimiters may cause mysterious +errors. The workaround is to use m?...? instead. See +http://search.cpan.org/perldoc?Switch#LIMITATIONS + +Currently internal buffer lengths are limited to 32-bit only. + + +PREREQUISITES +------------- + +Before you can build the Source Filters you need to have the following +installed on your system: + + * Perl 5.6.0 or better + +For older Perls use older versions of Filter. + +BUILDING THE MODULES +-------------------- + +Assuming you have met all the prerequisites, building the modules +should be relatively straightforward. + +The modules can now be built using this sequence of commands: + + perl Makefile.PL + make + make test + +The filters have been successfully built and tested on the following +systems (at least): + + linux (gcc or clang) + cygwin 1.7 + mingw strawberry 5.14 + SunOS 4.1.3 (Sun C compiler & gcc 2.7.2.3) + Solaris 2.3 (Sun C Compiler) + irix 5.3 + irix 6.x + Windows XP (Visual C++ 6.0) + +On Windows tr.exe and cpp.exe should be really the gnu/mingw tools in the path +for the testsuite to pass successfully. + +INSTALLATION +------------ + + make install diff --git a/SIGNATURE b/SIGNATURE new file mode 100644 index 0000000..c2df864 --- /dev/null +++ b/SIGNATURE @@ -0,0 +1,85 @@ +This file contains message digests of all files listed in MANIFEST, +signed via the Module::Signature module, version 0.81. + +To verify the content in this distribution, first make sure you have +Module::Signature installed, then type: + + % cpansign -v + +It will check each file's integrity, as well as the signature's +validity. If "==> Signature verified OK! <==" is not displayed, +the distribution may already have been compromised, and you should +not run its Makefile.PL or Build.PL. + +-----BEGIN PGP SIGNED MESSAGE----- +Hash: SHA1 + +SHA1 bbd3a94f10284706b2d1330f9a47513e2592889b .appveyor.yml +SHA1 116cef9eb62a85d5af2d5295bb161446abc04ce7 .gitignore +SHA1 849dd33c8f8adcbd9570e542012e94aa680f70da .travis.yml +SHA1 886aef353596bd384e64a1ecda814e54f2ed1305 Call/Call.pm +SHA1 a49dd29acbba9235fa895c1084ca996343ecd282 Call/Call.xs +SHA1 3d1e6a5e07761b79dae2a67df5e7484ab8517e02 Call/Makefile.PL +SHA1 ab106878b5b6770b97a1a6bfc6ae327930aca030 Call/ppport.h +SHA1 bb5316cb0f0ae4449f3973242908bf656b446aea Call/typemap +SHA1 c4c5d289d220dcccc70d7297b78e09f28efe51ae Changes +SHA1 5c019e181a6040c1a0ae00e92ac5672af5437e41 Exec/Exec.pm +SHA1 08fe049a1ababb9d1de54f8c8f025396a31a58b6 Exec/Exec.xs +SHA1 f5c86e77cfcb10451775fc0d2c1448ba1b7ee7f7 Exec/Makefile.PL +SHA1 d3981723bf5d45c988bc956240e2720f48fe6737 MANIFEST +SHA1 1297205bc504429646d73644aefd1e8840800f17 MANIFEST.SKIP +SHA1 a6b01a1b1b14eea096437e972f77b58397cdf705 META.json +SHA1 71b24350042a83044a86bfc366ecc4a7f1e6dfce META.yml +SHA1 30a2cdeaa7df2e8560524a160f86734395679561 Makefile.PL +SHA1 92afc0b1d3220748835572980d4239f83cf8bd3a README +SHA1 d298989d6a6dde3eae4563d91c7c7cd3c511e050 decrypt/Makefile.PL +SHA1 066b3ec45fe0502d50e25094b05888297e161fa0 decrypt/decr +SHA1 577ae9ba66971dca6ad57f04469f26ae57463fc1 decrypt/decrypt.pm +SHA1 3c88373895b2c9f08dff6ce530d237b5a56bd77e decrypt/decrypt.xs +SHA1 6e5d44e0c42fbdc697b6d0b1dd187a128a56abb4 decrypt/encrypt +SHA1 0bf507061d318b097119837bbda8411f06c2bfb5 examples/closure/Count.pm +SHA1 b8965a11e0a20642dfe99421961a112edf2a8706 examples/closure/Decompress.pm +SHA1 b571192030a49517999c4d640c65c679ffabe987 examples/closure/Include.pm +SHA1 58648f39b04f74496015a680fd5d3d99b074a359 examples/closure/Joe2Jim.pm +SHA1 4fe4ce8beaf7f5849113ace1677870e07f877443 examples/closure/NewSubst.pm +SHA1 b4f98a32c6205675a7e041e0c837503b583e4c9d examples/closure/Subst.pm +SHA1 a6273396754c279634b5aac7ef1f604429d6e8d1 examples/closure/UUdecode.pm +SHA1 71b1257f8c9e64c891183e47ac57ad549138ed62 examples/filtdef +SHA1 429a322f7343d14d66d0bae4e489617a299433ce examples/filtuu +SHA1 f292b8b9cfb316ada1dce3d94f189c20710c9d11 examples/method/Count.pm +SHA1 6cf89f5cc21c4aa02a6ea905292f0d4fe82f28d6 examples/method/Decompress.pm +SHA1 fc6a95368aee62a2992521dd518087e6132c01cf examples/method/Joe2Jim.pm +SHA1 2d4b9dd848b9eeb0de0ee7667f8ba105f1545125 examples/method/NewSubst.pm +SHA1 a9cdfae6778ebaccf11e9e73cc9bd5d4db48df7d examples/method/Subst.pm +SHA1 4c1705bf10a64379adc1c07517f0da93b795c438 examples/method/UUdecode.pm +SHA1 b7fc1bd7c15f30454fed78e87ec1084817105dfa lib/Filter/cpp.pm +SHA1 5397ee1b5311b924cf397215070a90eed9722221 lib/Filter/exec.pm +SHA1 f64eaa2954d7100612d4e5e482cd457417ec43c5 lib/Filter/sh.pm +SHA1 cef9663cf8f6d83ee79b390d14d7a6e4683fb457 mytest +SHA1 29b4c5c112b01b5af68173200c65fc67c14e8803 perlfilter.pod +SHA1 ac7b3d91f2f7f370eb7523c5eba6953e4b217200 t/call.t +SHA1 39853585450ea13a129b907c9bcacd9f562f1267 t/cpp.t +SHA1 d1b368941603ca4f137deabb59c30a0d1c406916 t/decrypt.t +SHA1 8026e61c3b75f8e9779c4c3b99ef67967fdf5131 t/exec.t +SHA1 0b4a731a8bfc6f8b4167b748e5033dc5e2d054ac t/filter-util.pl +SHA1 6a33d90e08974740fcb1585c9a6d5782ec6a3850 t/order.t +SHA1 9b4350d540053c0570225de8bc439467c6e0064c t/rt_101033.pm +SHA1 d927984c7ed6466f9093715fde416fc8e592c850 t/rt_101033.t +SHA1 cb1d3b4c78b220b0c6649f84856e0038231f30b4 t/rt_54452-rebless.t +SHA1 802f7fd9b4f488753496c379818526bbd712e61e t/sh.t +SHA1 8633847bf4b739e5255c2bc9a33bef08f31760d3 t/tee.t +SHA1 42b4a5a2b5e9422d59c10189414af56b1ef0eaf1 t/z_kwalitee.t +SHA1 156c526df9fe3c9a6f5a23ad37107d565410e756 t/z_manifest.t +SHA1 8fd05d82c127d9217c58382f0efdc61a63dc386a t/z_meta.t +SHA1 ade48e2b6098a0a329312543e1451e7e7fb7bc5f t/z_perl_minimum_version.t +SHA1 c693266a614bee88f3c85c3b2ced1a82236b52fc t/z_pod-coverage.t +SHA1 c8aa3903d3aba84c19bbd94d677620c758fa07d5 t/z_pod.t +SHA1 8568bca5a96669cb8d8a37eec0453ead6f331b3e tee/Makefile.PL +SHA1 9cd096b16766cc962c1dd93c0c26c491856a33d1 tee/tee.pm +SHA1 635856a1d7f5b27085afeb2fdd3be65b633d1565 tee/tee.xs +-----BEGIN PGP SIGNATURE----- + +iF0EARECAB0WIQRZHhhUcL58V8z0UW2abZJij/3JQgUCWgwEEwAKCRCabZJij/3J +QmbLAJ4kWjZtI/qpGgi0AUh/TQ5XVs0TZgCeMS7H815Dx6IWKDREeR96lAJOEFo= +=aDMg +-----END PGP SIGNATURE----- diff --git a/decrypt/Makefile.PL b/decrypt/Makefile.PL new file mode 100755 index 0000000..49988e2 --- /dev/null +++ b/decrypt/Makefile.PL @@ -0,0 +1,12 @@ +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'Filter::decrypt', + VERSION_FROM => 'decrypt.pm', + + # The line below disables both the dynamic link test and the + # test for DEBUGGING. + # It is only enabled here to allow the decrypt test harness + # to run without having to build statically. + DEFINE => "-DBYPASS", +); diff --git a/decrypt/decr b/decrypt/decr new file mode 100644 index 0000000..357e27c --- /dev/null +++ b/decrypt/decr @@ -0,0 +1,72 @@ +#!/usr/local/bin/perl + +# This script will decrypt a Perl script that has been encrypted using the +# "encrypt" script. It cannot decrypt any other kind of encrypted Perl script. +# +# Usage is decr file... +# + +use strict; +use warnings; + +use vars qw($XOR $BLOCKSIZE $HEADERSIZE $CRYPT_MAGIC_1 $CRYPT_MAGIC_2 + $size $mode $line $Fingerprint $file $block $sharp_bang $f + ) ; +$XOR = 'Perl' ; +$BLOCKSIZE = length $XOR ; +$HEADERSIZE = 2 ; +$CRYPT_MAGIC_1 = 0xff ; +$CRYPT_MAGIC_2 = 0x00 ; +my $Version = 1 ; +my $module_name = 'Filter::decrypt' ; + +my $Fingerprint = pack ("C*", $CRYPT_MAGIC_1, $CRYPT_MAGIC_2) ; + +die "Usage: decrypt file...\n" + unless @ARGV ; + + +# Loop through each file in turn. +foreach $file (@ARGV) +{ + if (! -f $file) + { + print "Skipping directory $file\n" if -d $file ; + #print "Skipping strange file $file\n" if ! -d $file ; + next ; + } + + open (F, "<", $file) || die "Cannot open $file: $!\n" ; + binmode F; + + # skip the #! line + $a = ; + if ($a =~ /^#!/) + { + $sharp_bang = $a ; + $a = ; + } + + # skip "use decrypt;" line + die "No use $module_name in $file\n" + unless $a =~ /use\s+$module_name\s*;/ ; + + read(F, $f, length($Fingerprint)) || die "Cannot read from $file: $!\n" ; + (print "skipping file '$file': not encrypted\n"), next + unless $f eq $Fingerprint ; + + print "decrypting $file to $file.pd\n" ; + open (O, ">", ${file}.".pd") || die "Cannot open ${file}.pd: $!\n" ; + binmode O; + print O $sharp_bang if $sharp_bang ; + while ($size = read(F, $block, $BLOCKSIZE) ) + { + print O ($block ^ substr($XOR, 0, $size)) ; + } + + + close F ; + close O ; + +} + diff --git a/decrypt/decrypt.pm b/decrypt/decrypt.pm new file mode 100644 index 0000000..8137362 --- /dev/null +++ b/decrypt/decrypt.pm @@ -0,0 +1,111 @@ +package Filter::decrypt ; + +require 5.006 ; +require XSLoader; +our $VERSION = "1.58" ; + +XSLoader::load('Filter::decrypt'); +1; +__END__ + +=head1 NAME + +Filter::decrypt - template for a decrypt source filter + +=head1 SYNOPSIS + + use Filter::decrypt ; + +=head1 DESCRIPTION + +This is a sample decrypting source filter. + +Although this is a fully functional source filter and it does implement +a I simple decrypt algorithm, it is I intended to be used as +it is supplied. Consider it to be a template which you can combine with +a proper decryption algorithm to develop your own decryption filter. + +=head1 WARNING + +It is important to note that a decryption filter can I provide +complete security against attack. At some point the parser within Perl +needs to be able to scan the original decrypted source. That means that +at some stage fragments of the source will exist in a memory buffer. + +Also, with the introduction of the Perl Compiler backend modules, and +the B::Deparse module in particular, using a Source Filter to hide source +code is becoming an increasingly futile exercise. + +The best you can hope to achieve by decrypting your Perl source using a +source filter is to make it unavailable to the casual user. + +Given that proviso, there are a number of things you can do to make +life more difficult for the prospective cracker. + +=over 5 + +=item 1. + +Strip the Perl binary to remove all symbols. + +=item 2. + +Build the decrypt extension using static linking. If the extension is +provided as a dynamic module, there is nothing to stop someone from +linking it at run time with a modified Perl binary. + +=item 3. + +Do not build Perl with C<-DDEBUGGING>. If you do then your source can +be retrieved with the C<-DP> command line option. + +The sample filter contains logic to detect the C option. + +=item 4. + +Do not build Perl with C debugging support enabled. + +=item 5. + +Do not implement the decryption filter as a sub-process (like the cpp +source filter). It is possible to peek into the pipe that connects to +the sub-process. + +=item 6. + +Check that the Perl Compiler isn't being used. + +There is code in the BOOT: section of decrypt.xs that shows how to detect +the presence of the Compiler. Make sure you include it in your module. + +Assuming you haven't taken any steps to spot when the compiler is in +use and you have an encrypted Perl script called "myscript.pl", you can +get access the source code inside it using the perl Compiler backend, +like this + + perl -MO=Deparse myscript.pl + +Note that even if you have included the BOOT: test, it is still +possible to use the Deparse module to get the source code for individual +subroutines. + +=item 7. + +Do not use the decrypt filter as-is. The algorithm used in this filter +has been purposefully left simple. + +=back + +If you feel that the source filtering mechanism is not secure enough +you could try using the unexec/undump method. See the Perl FAQ for +further details. + +=head1 AUTHOR + +Paul Marquess + +=head1 DATE + +19th December 1995 + +=cut diff --git a/decrypt/decrypt.xs b/decrypt/decrypt.xs new file mode 100644 index 0000000..73f2659 --- /dev/null +++ b/decrypt/decrypt.xs @@ -0,0 +1,322 @@ +/* + * Filename : decrypt.xs + * + * Author : Paul Marquess + * Date : 2014-12-09 02:58:47 rurban + * Version : 1.58 + * + */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include "../Call/ppport.h" + +#ifdef FDEBUG +static int fdebug = 0; +#endif + +/* constants specific to the encryption format */ +#define CRYPT_MAGIC_1 0xff +#define CRYPT_MAGIC_2 0x00 + +#define HEADERSIZE 2 +#define BLOCKSIZE 4 + + +#define SET_LEN(sv,len) \ + do { SvPVX(sv)[len] = '\0'; SvCUR_set(sv, len); } while (0) + + +static unsigned XOR [BLOCKSIZE] = {'P', 'e', 'r', 'l' } ; + + +/* Internal defines */ +#ifdef PERL_FILTER_EXISTS +# define CORE_FILTER_COUNT \ + (PL_parser && PL_parser->rsfp_filters ? av_len(PL_parser->rsfp_filters) : 0) +#else +# define CORE_FILTER_COUNT \ + (PL_rsfp_filters ? av_len(PL_rsfp_filters) : 0) +#endif + +#define FILTER_COUNT(s) IoPAGE(s) +#define FILTER_LINE_NO(s) IoLINES(s) +#define FIRST_TIME(s) IoLINES_LEFT(s) + +#define ENCRYPT_GV(s) IoTOP_GV(s) +#define ENCRYPT_SV(s) ((SV*) ENCRYPT_GV(s)) +#define ENCRYPT_BUFFER(s) SvPVX(ENCRYPT_SV(s)) +#define CLEAR_ENCRYPT_SV(s) SvCUR_set(ENCRYPT_SV(s), 0) + +#define DECRYPT_SV(s) s +#define DECRYPT_BUFFER(s) SvPVX(DECRYPT_SV(s)) +#define CLEAR_DECRYPT_SV(s) SvCUR_set(DECRYPT_SV(s), 0) +#define DECRYPT_BUFFER_LEN(s) SvCUR(DECRYPT_SV(s)) +#define DECRYPT_OFFSET(s) IoPAGE_LEN(s) +#define SET_DECRYPT_BUFFER_LEN(s,n) SvCUR_set(DECRYPT_SV(s), n) + +static unsigned +Decrypt(SV *in_sv, SV *out_sv) +{ + /* Here is where the actual decryption takes place */ + + unsigned char * in_buffer = (unsigned char *) SvPVX(in_sv) ; + unsigned char * out_buffer ; + unsigned size = SvCUR(in_sv) ; + unsigned index = size ; + int i ; + + /* make certain that the output buffer is big enough */ + /* as the output from the decryption can never be larger than */ + /* the input buffer, make it that size */ + SvGROW(out_sv, size) ; + out_buffer = (unsigned char *) SvPVX(out_sv) ; + + /* XOR */ + for (i = 0 ; i < size ; ++i) + out_buffer[i] = (unsigned char)( XOR[i] ^ in_buffer[i] ) ; + + /* input has been consumed, so set length to 0 */ + SET_LEN(in_sv, 0) ; + + /* set decrypt buffer length */ + SET_LEN(out_sv, index) ; + + /* return the size of the decrypt buffer */ + return (index) ; +} + +static int +ReadBlock(int idx, SV *sv, unsigned size) +{ /* read *exactly* size bytes from the next filter */ + int i = size; + while (1) { + int n = FILTER_READ(idx, sv, i) ; + if (n <= 0 && i==size) /* eof/error when nothing read so far */ + return n ; + if (n <= 0) /* eof/error when something already read */ + return size - i; + if (n == i) + return size ; + i -= n ; + } +} + +static void +preDecrypt(int idx) +{ + /* If the encrypted data starts with a header or needs to do some + initialisation it can be done here + + In this case the encrypted data has to start with a fingerprint, + so that is checked. + */ + + SV * sv = FILTER_DATA(idx) ; + unsigned char * buffer ; + + + /* read the header */ + if (ReadBlock(idx+1, sv, HEADERSIZE) != HEADERSIZE) + croak("truncated file") ; + + buffer = (unsigned char *) SvPVX(sv) ; + + /* check for fingerprint of encrypted data */ + if (buffer[0] != CRYPT_MAGIC_1 || buffer[1] != CRYPT_MAGIC_2) + croak( "bad encryption format" ); +} + +static void +postDecrypt() +{ +} + +static I32 +filter_decrypt(pTHX_ int idx, SV *buf_sv, int maxlen) +{ + SV *my_sv = FILTER_DATA(idx); + char *nl = "\n"; + char *p; + char *out_ptr; + int n; + + /* check if this is the first time through */ + if (FIRST_TIME(my_sv)) { + + /* Mild paranoia mode - make sure that no extra filters have */ + /* been applied on the same line as the use Filter::decrypt */ + if (CORE_FILTER_COUNT > FILTER_COUNT(my_sv) ) + croak("too many filters") ; + + /* As this is the first time through, so deal with any */ + /* initialisation required */ + preDecrypt(idx) ; + + FIRST_TIME(my_sv) = FALSE ; + SET_LEN(DECRYPT_SV(my_sv), 0) ; + SET_LEN(ENCRYPT_SV(my_sv), 0) ; + DECRYPT_OFFSET(my_sv) = 0 ; + } + +#ifdef FDEBUG + if (fdebug) + warn("**** In filter_decrypt - maxlen = %d, len buf = %d idx = %d\n", + maxlen, SvCUR(buf_sv), idx ) ; +#endif + + while (1) { + + /* anything left from last time */ + if ((n = SvCUR(DECRYPT_SV(my_sv)))) { + + out_ptr = SvPVX(DECRYPT_SV(my_sv)) + DECRYPT_OFFSET(my_sv) ; + + if (maxlen) { + /* want a block */ +#ifdef FDEBUG + if (fdebug) + warn("BLOCK(%d): size = %d, maxlen = %d\n", + idx, n, maxlen) ; +#endif + + sv_catpvn(buf_sv, out_ptr, maxlen > n ? n : maxlen ); + if(n <= maxlen) { + DECRYPT_OFFSET(my_sv) = 0 ; + SET_LEN(DECRYPT_SV(my_sv), 0) ; + } + else { + DECRYPT_OFFSET(my_sv) += maxlen ; + SvCUR_set(DECRYPT_SV(my_sv), n - maxlen) ; + } + return SvCUR(buf_sv); + } + else { + /* want lines */ + if ((p = ninstr(out_ptr, out_ptr + n, nl, nl + 1))) { + + sv_catpvn(buf_sv, out_ptr, p - out_ptr + 1); + + n = n - (p - out_ptr + 1); + DECRYPT_OFFSET(my_sv) += (p - out_ptr + 1) ; + SvCUR_set(DECRYPT_SV(my_sv), n) ; +#ifdef FDEBUG + if (fdebug) + warn("recycle %d - leaving %d, returning %d [%.999s]", + idx, n, SvCUR(buf_sv), SvPVX(buf_sv)) ; +#endif + + return SvCUR(buf_sv); + } + else /* no EOL, so append the complete buffer */ + sv_catpvn(buf_sv, out_ptr, n) ; + } + + } + + + SET_LEN(DECRYPT_SV(my_sv), 0) ; + DECRYPT_OFFSET(my_sv) = 0 ; + + /* read from the file into the encrypt buffer */ + if ( (n = ReadBlock(idx+1, ENCRYPT_SV(my_sv), BLOCKSIZE)) <= 0) + { + /* Either EOF or an error */ + +#ifdef FDEBUG + if (fdebug) + warn ("filter_read %d returned %d , returning %d\n", idx, n, + (SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : n); +#endif + + /* If the decrypt code needs to tidy up on EOF/error, + now is the time - here is a hook */ + postDecrypt() ; + + filter_del(filter_decrypt); + + + /* If error, return the code */ + if (n < 0) + return n ; + + /* return what we have so far else signal eof */ + return (SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : n; + } + +#ifdef FDEBUG + if (fdebug) + warn(" filter_decrypt(%d): sub-filter returned %d: '%.999s'", + idx, n, SvPV(my_sv,PL_na)); +#endif + + /* Now decrypt a block */ + n = Decrypt(ENCRYPT_SV(my_sv), DECRYPT_SV(my_sv)) ; + +#ifdef FDEBUG + if (fdebug) + warn("Decrypt (%d) returned %d [%.999s]\n", idx, n, SvPVX(DECRYPT_SV(my_sv)) ) ; +#endif + + } +} + + +MODULE = Filter::decrypt PACKAGE = Filter::decrypt + +PROTOTYPES: DISABLE + +BOOT: + /* Check for the presence of the Perl Compiler. B::C[C], B::Deparse. Bytecode works fine */ + if (get_hv("B::C::",0) || get_av("B::NULL::ISA",0)) { + croak("Aborting, Compiler detected") ; + } +#ifndef BYPASS + /* Don't run if this module is dynamically linked */ + if (!isALPHA(SvPV(GvSV(CvFILEGV(cv)), PL_na)[0])) + croak("module is dynamically linked. Recompile as a static module") ; +#ifdef DEBUGGING + /* Don't run if compiled with DEBUGGING */ + croak("recompile without -DDEBUGGING") ; +#endif + + /* Double check that DEBUGGING hasn't been enabled */ + if (PL_debug) + croak("debugging flags detected") ; +#endif + + +void +import(module) + SV * module + PPCODE: + { + + SV * sv = newSV(BLOCKSIZE) ; + + /* make sure the Perl debugger isn't enabled */ + if( PL_perldb ) + croak("debugger disabled") ; + + filter_add(filter_decrypt, sv) ; + FIRST_TIME(sv) = TRUE ; + + ENCRYPT_GV(sv) = (GV*) newSV(BLOCKSIZE) ; + (void)SvPOK_only(DECRYPT_SV(sv)); + (void)SvPOK_only(ENCRYPT_SV(sv)); + SET_LEN(DECRYPT_SV(sv), 0) ; + SET_LEN(ENCRYPT_SV(sv), 0) ; + + + /* remember how many filters are enabled */ + FILTER_COUNT(sv) = CORE_FILTER_COUNT ; + /* and the line number */ + FILTER_LINE_NO(sv) = PL_curcop->cop_line ; + + } + +void +unimport(...) + PPCODE: + /* filter_del(filter_decrypt); */ diff --git a/decrypt/encrypt b/decrypt/encrypt new file mode 100755 index 0000000..6438a43 --- /dev/null +++ b/decrypt/encrypt @@ -0,0 +1,72 @@ +#!perl +require 5.002 ; + +use strict; +use warnings; + +use vars qw($XOR $BLOCKSIZE $HEADERSIZE $CRYPT_MAGIC_1 $CRYPT_MAGIC_2 + $size $mode $line $Fingerprint $file $block + ) ; + +$XOR = 'Perl' ; +$BLOCKSIZE = length $XOR ; +$HEADERSIZE = 2 ; +$CRYPT_MAGIC_1 = 0xff ; +$CRYPT_MAGIC_2 = 0x00 ; + +$Fingerprint = pack ("C*", $CRYPT_MAGIC_1, $CRYPT_MAGIC_2) ; + +die "Usage: encrypt file...\n" + unless @ARGV ; + +# Loop throught each file in turn. +foreach $file (@ARGV) +{ + + if (! -T $file) + { + print "Skipping directory $file\n" if -d $file ; + print "Skipping non-text $file\n" if ! -d $file ; + next ; + } + + open (F, "<", $file) or die "Cannot open $file: $!\n" ; + binmode F; + open (O, ">", ${file}.".pe") or die "Cannot open ${file}.pe: $!\n" ; + binmode O; + + # Get the mode + $mode = (stat F)[2] ; + + # Check for "#!perl" line + $line = ; + + if ( $line =~ /^#!/ ) + { print O $line } + else + { seek F, 0, 0 } + + print O "use Filter::decrypt ;\n" ; + print O $Fingerprint ; + + + $block = ''; + while ($size = read(F, $block, $BLOCKSIZE) ) + { + print O ($block ^ substr($XOR, 0, length $block)) ; + } + + close F ; + close O ; + + unlink ($file) + or die "Could not remove '$file': $!\n" ; + + rename ("${file}.pe", $file) + or die "Could not rename $file.pe to $file: $!\n" ; + + chmod $mode, $file unless $^O eq 'MSWin32' ; + + print "encrypted $file\n" ; +} + diff --git a/examples/closure/Count.pm b/examples/closure/Count.pm new file mode 100644 index 0000000..2d96055 --- /dev/null +++ b/examples/closure/Count.pm @@ -0,0 +1,33 @@ +package + Count ; + +use Filter::Util::Call ; + +use strict ; +use warnings ; + +sub import +{ + my ($self) = @_ ; + my ($count) = 0 ; + filter_add( + sub + { + my ($status) ; + + if (($status = filter_read()) > 0 ) { + s/Joe/Jim/g ; + ++ $count ; + } + elsif ($count >= 0) { # EOF + $_ = "print q[Made $count substitutions\n] ;" ; + $status = 1 ; + $count = -1 ; + } + + $status ; + }) +} + +1 ; + diff --git a/examples/closure/Decompress.pm b/examples/closure/Decompress.pm new file mode 100644 index 0000000..0be7b4d --- /dev/null +++ b/examples/closure/Decompress.pm @@ -0,0 +1,33 @@ +package Filter::Decompress ; +# For usage see examples/filtdef + +use Filter::Util::Call ; +use Compress::Zlib ; +use Carp ; + +use strict ; +use warnings ; + +our $VERSION = '1.02' ; + +sub import +{ + my ($self) = @_ ; + + # Initialise an inflation stream. + my $x = inflateInit() + or croak "Internal Error inflateInit" ; + filter_add( + sub + { + my ($status, $err) ; + if (($status = filter_read()) >0) { + ($_, $err) = $x->inflate($_) ; + return -1 unless $err == Z_OK or $err == Z_STREAM_END ; + } + $status ; + }) +} + +1 ; +__END__ diff --git a/examples/closure/Include.pm b/examples/closure/Include.pm new file mode 100644 index 0000000..351f65f --- /dev/null +++ b/examples/closure/Include.pm @@ -0,0 +1,39 @@ +package + Include ; + +use Filter::Util::Call ; +use IO::File ; +use Carp ; + +sub import +{ + my ($self) = shift ; + my ($filename) = shift ; + my $fh = new IO::File "<$filename" + or croak "Cannot open file '$filename': $!" ; + + my $first_time = 1 ; + my ($orig_filename, $orig_line) = (caller)[1,2] ; + ++ $orig_line ; + + filter_add( + sub + { + $_ = <$fh> ; + + if ($first_time) { + $_ = "#line 1 $filename\n$_" ; + $first_time = 0 ; + } + + if ($fh->eof) { + $fh->close ; + $_ .= "#line $orig_line $orig_filename\n" ; + filter_del() ; + } + 1 ; + }) +} + +1 ; + diff --git a/examples/closure/Joe2Jim.pm b/examples/closure/Joe2Jim.pm new file mode 100644 index 0000000..7520aa7 --- /dev/null +++ b/examples/closure/Joe2Jim.pm @@ -0,0 +1,24 @@ +package + Joe2Jim ; + +use Filter::Util::Call ; + +use strict ; +use warnings ; + +sub import +{ + my($type) = @_ ; + + filter_add( + sub + { + my($status) ; + s/Joe/Jim/g + if ($status = filter_read()) > 0 ; + $status ; + }) +} + +1 ; + diff --git a/examples/closure/NewSubst.pm b/examples/closure/NewSubst.pm new file mode 100644 index 0000000..8e2a185 --- /dev/null +++ b/examples/closure/NewSubst.pm @@ -0,0 +1,38 @@ +package + NewSubst ; + +use Filter::Util::Call ; +use Carp ; + +use strict ; +use warnings ; + +sub import +{ + my ($self, $start, $stop, $from, $to) = @_ ; + my ($found) = 0 ; + croak("usage: use Subst qw(start stop from to)") + unless @_ == 5 ; + + filter_add( + sub + { + my ($status) ; + + if (($status = filter_read()) > 0) { + + $found = 1 + if $found == 0 and /$start/ ; + + if ($found) { + s/$from/$to/ ; + filter_del() if /$stop/ ; + } + + } + $status ; + } ) + +} + +1 ; diff --git a/examples/closure/Subst.pm b/examples/closure/Subst.pm new file mode 100644 index 0000000..d7bc15d --- /dev/null +++ b/examples/closure/Subst.pm @@ -0,0 +1,25 @@ +package + Subst ; + +use Filter::Util::Call ; +use Carp ; + +use strict ; +use warnings ; + +sub import +{ + croak("usage: use Subst qw(from to)") + unless @_ == 3 ; + my ($self, $from, $to) = @_ ; + filter_add( + sub + { + my ($status) ; + s/$from/$to/ + if ($status = filter_read()) > 0 ; + $status ; + }) +} + +1 ; diff --git a/examples/closure/UUdecode.pm b/examples/closure/UUdecode.pm new file mode 100644 index 0000000..76cef8c --- /dev/null +++ b/examples/closure/UUdecode.pm @@ -0,0 +1,52 @@ + +package Filter::UUdecode ; + +use Filter::Util::Call ; + +use strict ; +use warnings ; + +our $VERSION = '1.00' ; + +sub import +{ + my($self) = @_ ; + my ($count) = 0 ; + + filter_add( + sub + { + my ($status) ; + + while (1) { + + return $status + if ($status = filter_read() ) <= 0; + + chomp ; + ++ $count ; + + # Skip the begin line (if it is there) + ($_ = ''), next if $count == 1 and /^begin/ ; + + # is this the last line? + if ($_ eq " " or length $_ <= 1) { + $_ = '' ; + # If there is an end line, skip it too + return $status + if ($status = filter_read() ) <= 0 ; + $_ = "\n" if /^end/ ; + filter_del() ; + return 1 ; + } + + # uudecode the line + $_ = unpack("u", $_) ; + + # return the uudecoded data + return $status ; + } + }) + +} +1 ; diff --git a/examples/filtdef b/examples/filtdef new file mode 100755 index 0000000..035bbf0 --- /dev/null +++ b/examples/filtdef @@ -0,0 +1,37 @@ +#!/usr/bin/perl + +use strict ; +use warnings ; + +my ($file, $output, $status) ; + +use Compress::Zlib ; + +die "Create a decompressor for a pl.gz\nUsage: filtdef file > filtfile\n" + unless @ARGV == 1; + +foreach $file (@ARGV) +{ + open (F, "<", $file) or die "Cannot open $file: $!\n" ; + my $x = deflateInit() + or die "Cannot create a deflation stream\n" ; + + print "use Filter::Decompress;\n" ; + while () + { + ($output, $status) = $x->deflate($_) ; + + $status == Z_OK + or die "deflation failed\n" ; + + print $output ; + } + + ($output, $status) = $x->flush() ; + + $status == Z_OK + or die "deflation failed\n" ; + + print $output ; + close F ; +} diff --git a/examples/filtuu b/examples/filtuu new file mode 100755 index 0000000..e16ab39 --- /dev/null +++ b/examples/filtuu @@ -0,0 +1,5 @@ + +print "use Filter::UUdecode ;\n" ; +while (<>) { + print pack("u", $_) ; +} diff --git a/examples/method/Count.pm b/examples/method/Count.pm new file mode 100644 index 0000000..c9dbd7e --- /dev/null +++ b/examples/method/Count.pm @@ -0,0 +1,35 @@ +package + Count; + +use Filter::Util::Call ; + +use strict ; +use warnings ; + +sub filter +{ + my ($self) = @_ ; + my ($status) ; + + if (($status = filter_read()) > 0 ) { + s/Joe/Jim/g ; + ++ $$self ; + } + elsif ($$self >= 0) { # EOF + $_ = "print q[Made ${$self} substitutions\n] ;" ; + $status = 1 ; + $$self = -1 ; + } + + $status ; +} + +sub import +{ + my ($self) = @_ ; + my ($count) = 0 ; + filter_add(\$count) ; +} + +1 ; + diff --git a/examples/method/Decompress.pm b/examples/method/Decompress.pm new file mode 100644 index 0000000..a8ae94d --- /dev/null +++ b/examples/method/Decompress.pm @@ -0,0 +1,37 @@ +package Filter::Decompress ; +# For usage see examples/filtdef + +use Filter::Util::Call ; +use Compress::Zlib ; +use Carp ; + +use strict ; +use warnings ; + +our $VERSION = '1.02' ; + +sub filter +{ + my ($self) = @_ ; + my ($status, $err) ; + my ($inf) = $$self ; + + if (($status = filter_read()) >0) { + ($_, $err) = $inf->inflate($_) ; + return -1 unless $err == Z_OK or $err == Z_STREAM_END ; + } + $status ; +} + +sub import +{ + my ($self) = @_ ; + + # Initialise an inflation stream. + my $x = inflateInit() + or croak "Internal Error inflateInit" ; + filter_add(\$x) ; +} + +1 ; +__END__ diff --git a/examples/method/Joe2Jim.pm b/examples/method/Joe2Jim.pm new file mode 100644 index 0000000..e73c7e6 --- /dev/null +++ b/examples/method/Joe2Jim.pm @@ -0,0 +1,27 @@ +package + Joe2Jim ; + +use Filter::Util::Call ; + +use strict ; +use warnings ; + +sub import +{ + my($type) = @_ ; + + filter_add(bless []) ; +} + +sub filter +{ + my($self) = @_ ; + my($status) ; + + s/Joe/Jim/g + if ($status = filter_read()) > 0 ; + $status ; +} + +1 ; + diff --git a/examples/method/NewSubst.pm b/examples/method/NewSubst.pm new file mode 100644 index 0000000..a9193e4 --- /dev/null +++ b/examples/method/NewSubst.pm @@ -0,0 +1,44 @@ +package + NewSubst ; + +use Filter::Util::Call ; +use Carp ; + +use strict ; +use warnings ; + +sub filter +{ + my ($self) = @_ ; + my ($status) ; + + if (($status = filter_read()) > 0) { + + $self->{Found} = 1 + if $self->{Found} == 0 and /$self->{Start}/ ; + + if ($self->{Found}) { + s/$self->{From}/$self->{To}/ ; + filter_del() if /$self->{Stop}/ ; + } + + } + $status ; +} + +sub import +{ + my ($self, @args) = @_ ; + croak("usage: use Subst qw(start stop from to)") + unless @args == 4 ; + + filter_add( { Start => $args[0], + Stop => $args[1], + From => $args[2], + To => $args[3], + Found => 0 } + ) ; +} + +1 ; + diff --git a/examples/method/Subst.pm b/examples/method/Subst.pm new file mode 100644 index 0000000..f3935bc --- /dev/null +++ b/examples/method/Subst.pm @@ -0,0 +1,31 @@ +package + Subst ; + +use Filter::Util::Call ; +use Carp ; + +use strict ; +use warnings ; + +sub filter +{ + my ($self) = @_ ; + my ($status) ; + my ($from) = $self->[0] ; + my ($to) = $self->[1] ; + + s/$from/$to/ + if ($status = filter_read()) > 0 ; + $status ; +} + +sub import +{ + my ($self, @args) = @_ ; + croak("usage: use Subst qw(from to)") + unless @args == 2 ; + filter_add([ @args ]) ; +} + +1 ; + diff --git a/examples/method/UUdecode.pm b/examples/method/UUdecode.pm new file mode 100644 index 0000000..0ebcaab --- /dev/null +++ b/examples/method/UUdecode.pm @@ -0,0 +1,54 @@ + +package Filter::UUdecode ; + +use Filter::Util::Call ; + +use strict ; +use warnings ; + +our $VERSION = '1.00' ; + +sub import +{ + my($self) = @_ ; + my ($count) = 0 ; + + filter_add( \$count ) ; +} + +sub filter +{ + my ($self) = @_ ; + my ($status) ; + + while (1) { + + return $status + if ($status = filter_read() ) <= 0; + + chomp ; + ++ $$self ; + + # Skip the begin line (if it is there) + ($_ = ''), next if $$self == 1 and /^begin/ ; + + # is this the last line? + if ($_ eq " " or length $_ <= 1) { + $_ = '' ; + # If there is an end line, skip it too + return $status + if ($status = filter_read() ) <= 0 ; + $_ = "\n" if /^end/ ; + filter_del() ; + return 1 ; + } + + # uudecode the line + $_ = unpack("u", $_) ; + + # return the uudecoded data + return $status ; + } +} + +1 ; diff --git a/lib/Filter/cpp.pm b/lib/Filter/cpp.pm new file mode 100644 index 0000000..18f5164 --- /dev/null +++ b/lib/Filter/cpp.pm @@ -0,0 +1,126 @@ +package Filter::cpp; + +use Filter::Util::Exec ; +use Config ; +use strict; +use warnings; + +our $VERSION = '1.58' ; + +my $cpp; +my $sep; +if ($^O eq 'MSWin32') { + $cpp = 'cpp.exe' ; + $sep = ';'; +} +else { + ($cpp) = $Config{cppstdin} =~ /^(\S+)/; + $sep = ':'; +} + +if (! $cpp) { + require Carp; + Carp::croak ("Cannot find cpp\n"); +} + +# Check if cpp is installed +if ( ! -x $cpp) { + my $foundCPP = 0 ; + foreach my $dir (split($sep, $ENV{PATH}), '') + { + if (-x "$dir/$cpp") + { + $foundCPP = 1; + last ; + } + } + + if (! $foundCPP) { + require Carp; + Carp::croak("Cannot find cpp\n"); + } +} + +sub import +{ + my($self, @args) = @_ ; + + if ($^O eq 'MSWin32') { + Filter::Util::Exec::filter_add ($self, 'cmd', '/c', + "cpp.exe 2>nul") ; + } + else { + Filter::Util::Exec::filter_add ($self, 'sh', '-c', + "$Config{'cppstdin'} $Config{'cppminus'} 2>/dev/null") ; + } +} + +1 ; +__END__ + +=head1 NAME + +Filter::cpp - cpp source filter + +=head1 SYNOPSIS + + use Filter::cpp ; + +=head1 DESCRIPTION + +This source filter pipes the current source file through the C +pre-processor (cpp) if it is available. + +As with all source filters its scope is limited to the current source +file only. Every file you want to be processed by the filter must have a + + use Filter::cpp ; + +near the top. + +Here is an example script which uses the filter: + + use Filter::cpp ; + + #define FRED 1 + $a = 2 + FRED ; + print "a = $a\n" ; + #ifdef FRED + print "Hello FRED\n" ; + #else + print "Where is FRED\n" ; + #endif + +And here is what it will output: + + a = 3 + Hello FRED + +This example below, provided by Michael G Schwern, shows a clever way +to get Perl to use a C pre-processor macro when the Filter::cpp module +is available, or to use a Perl sub when it is not. + + # use Filter::cpp if we can. + BEGIN { eval 'use Filter::cpp' } + + sub PRINT { + my($string) = shift; + + #define PRINT($string) \ + (print $string."\n") + } + + PRINT("Mu"); + +Look at Michael's Tie::VecArray module for a practical use. + +=head1 AUTHOR + +Paul Marquess + +=head1 DATE + +11th December 1995. + +=cut + diff --git a/lib/Filter/exec.pm b/lib/Filter/exec.pm new file mode 100644 index 0000000..fe379c9 --- /dev/null +++ b/lib/Filter/exec.pm @@ -0,0 +1,71 @@ +package Filter::exec ; + +use Filter::Util::Exec ; +use strict ; +use warnings ; + +our $VERSION = "1.58" ; + +sub import +{ + my($self, @args) = @_ ; + + unless (@args) { + require Carp; + Carp::croak("Usage: use Filter::exec 'command'"); + } + + Filter::Util::Exec::filter_add($self, @args) ; +} + +1 ; +__END__ + +=head1 NAME + +Filter::exec - exec source filter + +=head1 SYNOPSIS + + use Filter::exec qw(command parameters) ; + +=head1 DESCRIPTION + +This filter pipes the current source file through the program which +corresponds to the C parameter. + +As with all source filters its scope is limited to the current source +file only. Every file you want to be processed by the filter must have a + + use Filter::exec qw(command ) ; + +near the top. + +Here is an example script which uses the filter: + + use Filter::exec qw(tr XYZ PQR) ; + $a = 1 ; + print "XYZ a = $a\n" ; + +And here is what it will output: + + PQR = 1 + +=head1 WARNING + +You should be I careful when using this filter. Because of the +way the filter is implemented it is possible to end up with deadlock. + +Be especially careful when stacking multiple instances of the filter in +a single source file. + +=head1 AUTHOR + +Paul Marquess + +=head1 DATE + +11th December 1995. + +=cut + diff --git a/lib/Filter/sh.pm b/lib/Filter/sh.pm new file mode 100644 index 0000000..fc8a431 --- /dev/null +++ b/lib/Filter/sh.pm @@ -0,0 +1,76 @@ +package Filter::sh; + +use Filter::Util::Exec ; +use strict ; +use warnings ; + +our $VERSION = "1.58" ; + +sub import +{ + my($self, @args) = @_ ; + + unless (@args) { + require Carp; + Carp::croak("Usage: use Filter::sh 'command'"); + } + + if ($^O eq 'MSWin32') { + Filter::Util::Exec::filter_add ($self, 'cmd', '/c', "@args") ; + } + else { + Filter::Util::Exec::filter_add ($self, 'sh', '-c', "@args") ; + } +} + +1 ; +__END__ + +=head1 NAME + +Filter::sh - sh source filter + +=head1 SYNOPSIS + + use Filter::sh 'command' ; + +=head1 DESCRIPTION + +This filter pipes the current source file through the program which +corresponds to the C parameter using the Bourne shell. + +As with all source filters its scope is limited to the current source +file only. Every file you want to be processed by the filter must have a + + use Filter::sh 'command' ; + +near the top. + +Here is an example script which uses the filter: + + use Filter::sh 'tr XYZ PQR' ; + $a = 1 ; + print "XYZ a = $a\n" ; + +And here is what it will output: + + PQR = 1 + +=head1 WARNING + +You should be I careful when using this filter. Because of the +way the filter is implemented it is possible to end up with deadlock. + +Be especially careful when stacking multiple instances of the filter in +a single source file. + +=head1 AUTHOR + +Paul Marquess + +=head1 DATE + +11th December 1995. + +=cut + diff --git a/mytest b/mytest new file mode 100644 index 0000000..1d6e605 --- /dev/null +++ b/mytest @@ -0,0 +1,10 @@ +# You can use this file to play with the filters. +# +# If you type +# +# make mytest +# +# this file will get executed with the same 'environment' as the +# scripts in the t subdirectory. + +print "hello\n" ; diff --git a/perlfilter.pod b/perlfilter.pod new file mode 100644 index 0000000..60d0864 --- /dev/null +++ b/perlfilter.pod @@ -0,0 +1,613 @@ +=head1 NAME + +perlfilter - Source Filters + +=head1 DESCRIPTION + +This article is about a little-known feature of Perl called +I. Source filters alter the program text of a module +before Perl sees it, much as a C preprocessor alters the source text of +a C program before the compiler sees it. This article tells you more +about what source filters are, how they work, and how to write your +own. + +The original purpose of source filters was to let you encrypt your +program source to prevent casual piracy. This isn't all they can do, as +you'll soon learn. But first, the basics. + +=head1 CONCEPTS + +Before the Perl interpreter can execute a Perl script, it must first +read it from a file into memory for parsing and compilation. If that +script itself includes other scripts with a C or C +statement, then each of those scripts will have to be read from their +respective files as well. + +Now think of each logical connection between the Perl parser and an +individual file as a I. A source stream is created when +the Perl parser opens a file, it continues to exist as the source code +is read into memory, and it is destroyed when Perl is finished parsing +the file. If the parser encounters a C or C statement in +a source stream, a new and distinct stream is created just for that +file. + +The diagram below represents a single source stream, with the flow of +source from a Perl script file on the left into the Perl parser on the +right. This is how Perl normally operates. + + file -------> parser + +There are two important points to remember: + +=over 5 + +=item 1. + +Although there can be any number of source streams in existence at any +given time, only one will be active. + +=item 2. + +Every source stream is associated with only one file. + +=back + +A source filter is a special kind of Perl module that intercepts and +modifies a source stream before it reaches the parser. A source filter +changes our diagram like this: + + file ----> filter ----> parser + +If that doesn't make much sense, consider the analogy of a command +pipeline. Say you have a shell script stored in the compressed file +I. The simple pipeline command below runs the script without +needing to create a temporary file to hold the uncompressed file. + + gunzip -c trial.gz | sh + +In this case, the data flow from the pipeline can be represented as follows: + + trial.gz ----> gunzip ----> sh + +With source filters, you can store the text of your script compressed and use a source filter to uncompress it for Perl's parser: + + compressed gunzip + Perl program ---> source filter ---> parser + +=head1 USING FILTERS + +So how do you use a source filter in a Perl script? Above, I said that +a source filter is just a special kind of module. Like all Perl +modules, a source filter is invoked with a use statement. + +Say you want to pass your Perl source through the C preprocessor before +execution. As it happens, the source filters distribution comes with a C +preprocessor filter module called Filter::cpp. + +Below is an example program, C, which makes use of this filter. +Line numbers have been added to allow specific lines to be referenced +easily. + + 1: use Filter::cpp; + 2: #define TRUE 1 + 3: $a = TRUE; + 4: print "a = $a\n"; + +When you execute this script, Perl creates a source stream for the +file. Before the parser processes any of the lines from the file, the +source stream looks like this: + + cpp_test ---------> parser + +Line 1, C, includes and installs the C filter +module. All source filters work this way. The use statement is compiled +and executed at compile time, before any more of the file is read, and +it attaches the cpp filter to the source stream behind the scenes. Now +the data flow looks like this: + + cpp_test ----> cpp filter ----> parser + +As the parser reads the second and subsequent lines from the source +stream, it feeds those lines through the C source filter before +processing them. The C filter simply passes each line through the +real C preprocessor. The output from the C preprocessor is then +inserted back into the source stream by the filter. + + .-> cpp --. + | | + | | + | <-' + cpp_test ----> cpp filter ----> parser + +The parser then sees the following code: + + use Filter::cpp; + $a = 1; + print "a = $a\n"; + +Let's consider what happens when the filtered code includes another +module with use: + + 1: use Filter::cpp; + 2: #define TRUE 1 + 3: use Fred; + 4: $a = TRUE; + 5: print "a = $a\n"; + +The C filter does not apply to the text of the Fred module, only +to the text of the file that used it (C). Although the use +statement on line 3 will pass through the cpp filter, the module that +gets included (C) will not. The source streams look like this +after line 3 has been parsed and before line 4 is parsed: + + cpp_test ---> cpp filter ---> parser (INACTIVE) + + Fred.pm ----> parser + +As you can see, a new stream has been created for reading the source +from C. This stream will remain active until all of C +has been parsed. The source stream for C will still exist, +but is inactive. Once the parser has finished reading Fred.pm, the +source stream associated with it will be destroyed. The source stream +for C then becomes active again and the parser reads line 4 +and subsequent lines from C. + +You can use more than one source filter on a single file. Similarly, +you can reuse the same filter in as many files as you like. + +For example, if you have a uuencoded and compressed source file, it is +possible to stack a uudecode filter and an uncompression filter like +this: + + use Filter::uudecode; use Filter::uncompress; + M'XL(".H7/;1I;_>_I3=&E=%:F*I"T?22Q/ + M6]9* + ... + +Once the first line has been processed, the flow will look like this: + + file ---> uudecode ---> uncompress ---> parser + filter filter + +Data flows through filters in the same order they appear in the source +file. The uudecode filter appeared before the uncompress filter, so the +source file will be uudecoded before it's uncompressed. + +=head1 WRITING A SOURCE FILTER + +There are three ways to write your own source filter. You can write it +in C, use an external program as a filter, or write the filter in Perl. +I won't cover the first two in any great detail, so I'll get them out +of the way first. Writing the filter in Perl is most convenient, so +I'll devote the most space to it. + +=head1 WRITING A SOURCE FILTER IN C + +The first of the three available techniques is to write the filter +completely in C. The external module you create interfaces directly +with the source filter hooks provided by Perl. + +The advantage of this technique is that you have complete control over +the implementation of your filter. The big disadvantage is the +increased complexity required to write the filter - not only do you +need to understand the source filter hooks, but you also need a +reasonable knowledge of Perl guts. One of the few times it is worth +going to this trouble is when writing a source scrambler. The +C filter (which unscrambles the source before Perl parses it) +included with the source filter distribution is an example of a C +source filter (see Decryption Filters, below). + + +=over 5 + +=item B + +All decryption filters work on the principle of "security through +obscurity." Regardless of how well you write a decryption filter and +how strong your encryption algorithm is, anyone determined enough can +retrieve the original source code. The reason is quite simple - once +the decryption filter has decrypted the source back to its original +form, fragments of it will be stored in the computer's memory as Perl +parses it. The source might only be in memory for a short period of +time, but anyone possessing a debugger, skill, and lots of patience can +eventually reconstruct your program. + +That said, there are a number of steps that can be taken to make life +difficult for the potential cracker. The most important: Write your +decryption filter in C and statically link the decryption module into +the Perl binary. For further tips to make life difficult for the +potential cracker, see the file I in the source filters +distribution. + +=back + +=head1 CREATING A SOURCE FILTER AS A SEPARATE EXECUTABLE + +An alternative to writing the filter in C is to create a separate +executable in the language of your choice. The separate executable +reads from standard input, does whatever processing is necessary, and +writes the filtered data to standard output. C is an +example of a source filter implemented as a separate executable - the +executable is the C preprocessor bundled with your C compiler. + +The source filter distribution includes two modules that simplify this +task: C and C. Both allow you to run any +external executable. Both use a coprocess to control the flow of data +into and out of the external executable. (For details on coprocesses, +see Stephens, W.R., "Advanced Programming in the UNIX Environment." +Addison-Wesley, ISBN 0-210-56317-7, pages 441-445.) The difference +between them is that C spawns the external command +directly, while C spawns a shell to execute the external +command. (Unix uses the Bourne shell; NT uses the cmd shell.) Spawning +a shell allows you to make use of the shell metacharacters and +redirection facilities. + +Here is an example script that uses C: + + use Filter::sh 'tr XYZ PQR'; + $a = 1; + print "XYZ a = $a\n"; + +The output you'll get when the script is executed: + + PQR a = 1 + +Writing a source filter as a separate executable works fine, but a +small performance penalty is incurred. For example, if you execute the +small example above, a separate subprocess will be created to run the +Unix C command. Each use of the filter requires its own subprocess. +If creating subprocesses is expensive on your system, you might want to +consider one of the other options for creating source filters. + +=head1 WRITING A SOURCE FILTER IN PERL + +The easiest and most portable option available for creating your own +source filter is to write it completely in Perl. To distinguish this +from the previous two techniques, I'll call it a Perl source filter. + +To help understand how to write a Perl source filter we need an example +to study. Here is a complete source filter that performs rot13 +decoding. (Rot13 is a very simple encryption scheme used in Usenet +postings to hide the contents of offensive posts. It moves every letter +forward thirteen places, so that A becomes N, B becomes O, and Z +becomes M.) + + + package Rot13; + + use Filter::Util::Call; + + sub import { + my ($type) = @_; + my ($ref) = []; + filter_add(bless $ref); + } + + sub filter { + my ($self) = @_; + my ($status); + + tr/n-za-mN-ZA-M/a-zA-Z/ + if ($status = filter_read()) > 0; + $status; + } + + 1; + +All Perl source filters are implemented as Perl classes and have the +same basic structure as the example above. + +First, we include the C module, which exports a +number of functions into your filter's namespace. The filter shown +above uses two of these functions, C and +C. + +Next, we create the filter object and associate it with the source +stream by defining the C function. If you know Perl well +enough, you know that C is called automatically every time a +module is included with a use statement. This makes C the ideal +place to both create and install a filter object. + +In the example filter, the object (C<$ref>) is blessed just like any +other Perl object. Our example uses an anonymous array, but this isn't +a requirement. Because this example doesn't need to store any context +information, we could have used a scalar or hash reference just as +well. The next section demonstrates context data. + +The association between the filter object and the source stream is made +with the C function. This takes a filter object as a +parameter (C<$ref> in this case) and installs it in the source stream. + +Finally, there is the code that actually does the filtering. For this +type of Perl source filter, all the filtering is done in a method +called C. (It is also possible to write a Perl source filter +using a closure. See the C manual page for more +details.) It's called every time the Perl parser needs another line of +source to process. The C method, in turn, reads lines from +the source stream using the C function. + +If a line was available from the source stream, C +returns a status value greater than zero and appends the line to C<$_>. +A status value of zero indicates end-of-file, less than zero means an +error. The filter function itself is expected to return its status in +the same way, and put the filtered line it wants written to the source +stream in C<$_>. The use of C<$_> accounts for the brevity of most Perl +source filters. + +In order to make use of the rot13 filter we need some way of encoding +the source file in rot13 format. The script below, C, does +just that. + + die "usage mkrot13 filename\n" unless @ARGV; + my $in = $ARGV[0]; + my $out = "$in.tmp"; + open(IN, "<$in") or die "Cannot open file $in: $!\n"; + open(OUT, ">$out") or die "Cannot open file $out: $!\n"; + + print OUT "use Rot13;\n"; + while () { + tr/a-zA-Z/n-za-mN-ZA-M/; + print OUT; + } + + close IN; + close OUT; + unlink $in; + rename $out, $in; + +If we encrypt this with C: + + print " hello fred \n"; + +the result will be this: + + use Rot13; + cevag "uryyb serq\a"; + +Running it produces this output: + + hello fred + +=head1 USING CONTEXT: THE DEBUG FILTER + +The rot13 example was a trivial example. Here's another demonstration +that shows off a few more features. + +Say you wanted to include a lot of debugging code in your Perl script +during development, but you didn't want it available in the released +product. Source filters offer a solution. In order to keep the example +simple, let's say you wanted the debugging output to be controlled by +an environment variable, C. Debugging code is enabled if the +variable exists, otherwise it is disabled. + +Two special marker lines will bracket debugging code, like this: + + ## DEBUG_BEGIN + if ($year > 1999) { + warn "Debug: millennium bug in year $year\n"; + } + ## DEBUG_END + +The filter ensures that Perl parses the code between the +and C markers only when the C environment variable +exists. That means that when C does exist, the code above +should be passed through the filter unchanged. The marker lines can +also be passed through as-is, because the Perl parser will see them as +comment lines. When C isn't set, we need a way to disable the +debug code. A simple way to achieve that is to convert the lines +between the two markers into comments: + + ## DEBUG_BEGIN + #if ($year > 1999) { + # warn "Debug: millennium bug in year $year\n"; + #} + ## DEBUG_END + +Here is the complete Debug filter: + + package Debug; + + use strict; + use warnings; + use Filter::Util::Call; + + use constant TRUE => 1; + use constant FALSE => 0; + + sub import { + my ($type) = @_; + my (%context) = ( + Enabled => defined $ENV{DEBUG}, + InTraceBlock => FALSE, + Filename => (caller)[1], + LineNo => 0, + LastBegin => 0, + ); + filter_add(bless \%context); + } + + sub Die { + my ($self) = shift; + my ($message) = shift; + my ($line_no) = shift || $self->{LastBegin}; + die "$message at $self->{Filename} line $line_no.\n" + } + + sub filter { + my ($self) = @_; + my ($status); + $status = filter_read(); + ++ $self->{LineNo}; + + # deal with EOF/error first + if ($status <= 0) { + $self->Die("DEBUG_BEGIN has no DEBUG_END") + if $self->{InTraceBlock}; + return $status; + } + + if ($self->{InTraceBlock}) { + if (/^\s*##\s*DEBUG_BEGIN/ ) { + $self->Die("Nested DEBUG_BEGIN", $self->{LineNo}) + } elsif (/^\s*##\s*DEBUG_END/) { + $self->{InTraceBlock} = FALSE; + } + + # comment out the debug lines when the filter is disabled + s/^/#/ if ! $self->{Enabled}; + } elsif ( /^\s*##\s*DEBUG_BEGIN/ ) { + $self->{InTraceBlock} = TRUE; + $self->{LastBegin} = $self->{LineNo}; + } elsif ( /^\s*##\s*DEBUG_END/ ) { + $self->Die("DEBUG_END has no DEBUG_BEGIN", $self->{LineNo}); + } + return $status; + } + + 1; + +The big difference between this filter and the previous example is the +use of context data in the filter object. The filter object is based on +a hash reference, and is used to keep various pieces of context +information between calls to the filter function. All but two of the +hash fields are used for error reporting. The first of those two, +Enabled, is used by the filter to determine whether the debugging code +should be given to the Perl parser. The second, InTraceBlock, is true +when the filter has encountered a C line, but has not yet +encountered the following C line. + +If you ignore all the error checking that most of the code does, the +essence of the filter is as follows: + + sub filter { + my ($self) = @_; + my ($status); + $status = filter_read(); + + # deal with EOF/error first + return $status if $status <= 0; + if ($self->{InTraceBlock}) { + if (/^\s*##\s*DEBUG_END/) { + $self->{InTraceBlock} = FALSE + } + + # comment out debug lines when the filter is disabled + s/^/#/ if ! $self->{Enabled}; + } elsif ( /^\s*##\s*DEBUG_BEGIN/ ) { + $self->{InTraceBlock} = TRUE; + } + return $status; + } + +Be warned: just as the C-preprocessor doesn't know C, the Debug filter +doesn't know Perl. It can be fooled quite easily: + + print < environment variable can then be used to control which +blocks get included. + +Once you can identify individual blocks, try allowing them to be +nested. That isn't difficult either. + +Here is an interesting idea that doesn't involve the Debug filter. +Currently Perl subroutines have fairly limited support for formal +parameter lists. You can specify the number of parameters and their +type, but you still have to manually take them out of the C<@_> array +yourself. Write a source filter that allows you to have a named +parameter list. Such a filter would turn this: + + sub MySub ($first, $second, @rest) { ... } + +into this: + + sub MySub($$@) { + my ($first) = shift; + my ($second) = shift; + my (@rest) = @_; + ... + } + +Finally, if you feel like a real challenge, have a go at writing a +full-blown Perl macro preprocessor as a source filter. Borrow the +useful features from the C preprocessor and any other macro processors +you know. The tricky bit will be choosing how much knowledge of Perl's +syntax you want your filter to have. + +=head1 LIMITATIONS + +Source filters only work on the string level, thus are highly limited +in its ability to change source code on the fly. It cannot detect +comments, quoted strings, heredocs, it is no replacement for a real +parser. +The only stable usage for source filters are encryption, compression, +or the byteloader, to translate binary code back to source code. + +See for example the limitations in L, which uses source filters, +and thus is does not work inside a string eval, the presence of +regexes with embedded newlines that are specified with raw C +delimiters and don't have a modifier C are indistinguishable from +code chunks beginning with the division operator C. As a workaround +you must use C or C for such patterns. Also, the presence of +regexes specified with raw C delimiters may cause mysterious +errors. The workaround is to use C instead. See +L + +Currently the content of the C<__DATA__> block is not filtered. + +Currently internal buffer lengths are limited to 32-bit only. + + +=head1 THINGS TO LOOK OUT FOR + +=over 5 + +=item Some Filters Clobber the C Handle + +Some source filters use the C handle to read the calling program. +When using these source filters you cannot rely on this handle, nor expect +any particular kind of behavior when operating on it. Filters based on +Filter::Util::Call (and therefore Filter::Simple) do not alter the C +filehandle, but on the other hand totally ignore the text after C<__DATA__>. + +=back + +=head1 REQUIREMENTS + +The Source Filters distribution is available on CPAN, in + + CPAN/modules/by-module/Filter + +Starting from Perl 5.8 Filter::Util::Call (the core part of the +Source Filters distribution) is part of the standard Perl distribution. +Also included is a friendlier interface called Filter::Simple, by +Damian Conway. + +=head1 AUTHOR + +Paul Marquess EPaul.Marquess@btinternet.comE + +Reini Urban Erurban@cpan.orgE + +=head1 Copyrights + +The first version of this article originally appeared in The Perl +Journal #11, and is copyright 1998 The Perl Journal. It appears +courtesy of Jon Orwant and The Perl Journal. This document may be +distributed under the same terms as Perl itself. diff --git a/t/call.t b/t/call.t new file mode 100644 index 0000000..b2a0cad --- /dev/null +++ b/t/call.t @@ -0,0 +1,890 @@ +use Config; +BEGIN { + if ($ENV{PERL_CORE}) { + if ($Config{'extensions'} !~ m{\bFilter/Util/Call\b}) { + print "1..0 # Skip: Filter::Util::Call was not built\n"; + exit 0; + } + } + unshift @INC, 't'; + require 'filter-util.pl'; +} + +use strict; +use warnings; + +use vars qw($Inc $Perl); + +print "1..34\n"; + +$Perl = "$Perl -w"; + +use Cwd ; +my $here = getcwd ; + + +my $filename = "call$$.tst" ; +my $filename2 = "call2$$.tst" ; +my $filenamebin = "call$$.bin" ; +my $module = "MyTest" ; +my $module2 = "MyTest2" ; +my $module3 = "MyTest3" ; +my $module4 = "MyTest4" ; +my $module5 = "MyTest5" ; +my $module6 = "MyTest6" ; +my $nested = "nested" ; +my $block = "block" ; +my $redir = $^O eq 'MacOS' ? "" : "2>&1"; + +# Test error cases +################## + +# no filter function in module +############################### + +writeFile("${module}.pm", <>8) != 0 or (($^O eq 'MSWin32' || $^O eq 'MacOS' || $^O eq 'NetWare' || $^O eq 'mpeix') && $? != 0))) ; +ok(2, $a =~ /^Can't locate object method "filter" via package "MyTest"/m) ; + +# no reference parameter in filter_add +###################################### + +writeFile("${module}.pm", <>8) != 0 + or (($^O eq 'MSWin32' || $^O eq 'MacOS' || $^O eq 'NetWare' || $^O eq 'mpeix') + && $? != 0))) ; +#ok(4, $a =~ /^usage: filter_add\(ref\) at ${module}.pm/) ; +my $errmsg = $Config{usecperl} + ? qr/^Not enough arguments for subroutine entry Filter::Util::Call::filter_add at ${module}\.pm line/m + : qr/^Not enough arguments for Filter::Util::Call::filter_add at ${module}\.pm line/m; +$a =~ s/^(.*?\n).*$/$1/s; # only the first line +if ($] < 5.007) { + if ($a =~ $errmsg) { + ok(4, 1); + } else { + ok(4, 1, "TODO"); + } +} else { + ok(4, $a =~ $errmsg, 'usage error') + or diag("The error was: ", $a); +} + +# non-error cases +################# + + +# a simple filter, using a closure +################# + +writeFile("${module}.pm", < 0) { + s/ABC/DEF/g + } + $status ; + } ) ; +} + +1 ; +EOM + +writeFile($filename, <>8) == 0) ; +ok(6, $a eq < 0) { + s/ABC/DEF/g + } + $status ; +} + + +1 ; +EOM + +writeFile($filename, <>8) == 0) ; +ok(8, $a eq < 0) { + s/XYZ/PQR/g + } + $status ; +} + +1 ; +EOM + +writeFile("${module3}.pm", < 0) { + s/Fred/Joe/g + } + $status ; + } ) ; +} + +1 ; +EOM + +writeFile("${module4}.pm", < 0) { + s/Today/Tomorrow/g + } + $status ; +} + +1 ; +EOM + +writeFile($filename, <>8) == 0) ; +ok(10, $a eq < 0) { + foreach $pattern (@strings) + { s/$pattern/PQR/g } + } + + $status ; + } + ) + +} +1 ; +EOM + + +writeFile($filename, <>8) == 0) ; +ok(12, $a eq < 0) { + foreach $pattern (@$self) + { s/$pattern/PQR/g } + } + + $status ; +} + +1 ; +EOM + + +writeFile($filename, <>8) == 0) ; +ok(14, $a eq < 0) { + chop ; + s/\r$//; + # and now the second line (it will append) + $status = filter_read() ; + } + + $status ; +} + +1 ; +EOM + + +writeFile($filename, <>8) == 0) ; +ok(16, $a eq <>8) == 0) ; +ok(18, $a eq < 0) { + s/DIR/$here/g + } + $status ; +} + +1 ; +EOM + +writeFile($filename, <>8) == 0) ; +ok(20, $a eq < 0 ; + + -- $$self ; + filter_del() if $$self <= 0 ; + + $status ; +} + +1 ; +EOM + +writeFile($filename, <>8) == 0) ; +ok(22, $a eq < 0) { + s/HERE/THERE/g + } + + $status ; +} + +1 ; +EOM + +writeFile($filenamebin, <>8) == 0) ; +ok(24, $a eq < 0) { + s/HERE/THERE/g + } + + $status ; +} + +1 ; +EOM + +writeFile($filename, <; +print @a; +__DATA__ +HERE I am +I'm HERE +HERE today gone tomorrow +EOM + +$a = `$Perl "-I." $Inc $filename $redir` ; +ok(25, ($? >>8) == 0) ; +ok(26, $a eq < 0) { + s/HERE/THERE/g + } + + $status ; +} + +1 ; +EOM + +writeFile($filename, <; +print @a; +__END__ +HERE I am +I'm HERE +HERE today gone tomorrow +EOM + +$a = `$Perl "-I." $Inc $filename $redir` ; +ok(27, ($? >>8) == 0) ; +ok(28, $a eq < +#################### + +writeFile("${module6}.pm", <>8) == 0); +chomp( $a ) if $^O eq 'VMS'; +ok(30, $a eq 'ok'); + +$a = `$Perl "-I." $Inc $filename2`; +ok(31, ($? >>8) == 0); +chomp( $a ) if $^O eq 'VMS'; +ok(32, $a eq 'ok'); + +} + +# error: filter_read_exact: size parameter must be > 0 +###################################### + +writeFile("${block}.pm", < 0) { + s/HERE/THERE/g + } + $status ; +} + +1 ; +EOM + +writeFile($filenamebin, <>8) != 0) ; +ok(34, $a =~ /^filter_read_exact: size parameter must be > 0 at block.pm/) ; + + +END { + 1 while unlink $filename ; + 1 while unlink $filename2 ; + 1 while unlink $filenamebin ; + 1 while unlink "${module}.pm" ; + 1 while unlink "${module2}.pm" ; + 1 while unlink "${module3}.pm" ; + 1 while unlink "${module4}.pm" ; + 1 while unlink "${module5}.pm" ; + 1 while unlink "${module6}.pm" ; + 1 while unlink $nested ; + 1 while unlink "${block}.pm" ; +} + + diff --git a/t/cpp.t b/t/cpp.t new file mode 100644 index 0000000..5d39e0c --- /dev/null +++ b/t/cpp.t @@ -0,0 +1,80 @@ + +use strict; +use warnings; +use Config; + +BEGIN { + my $cpp; + my $sep; + unshift @INC, 't'; + if ($^O eq 'MSWin32') { + $cpp = 'cpp.exe' ; + $sep = ';'; + } + else { + ($cpp) = $Config{cppstdin} =~ /^(\S+)/; + $sep = ':'; + } + if (! $cpp) { + print "1..0 # Skipping cpp not found on this system.\n" ; + exit 0 ; + } + + # Check if cpp is installed + if ( ! -x $cpp) { + my $foundCPP = 0 ; + foreach my $dir (split($sep, $ENV{PATH}), '') { + if (-x "$dir/$cpp") { + $foundCPP = 1; + last ; + } + } + if (! $foundCPP) { + print "1..0 # Skipping cpp not found on this system.\n" ; + exit 0 ; + } + } +} + +use vars qw( $Inc $Perl ) ; + +require "filter-util.pl" ; + +my $script = <<'EOF' ; +use Filter::cpp ; +#define FRED 1 +#define JOE + +#a perl comment, not a cpp line + +$a = FRED + 2 ; +print "a = $a\n" ; + +require "./fred" ; + +#ifdef JOE + print "Hello Joe\n" ; +#else + print "Where is Joe?\n" ; +#endif +EOF + +my $cpp_script = 'cpp.script' ; +writeFile($cpp_script, $script) ; +writeFile('fred', 'print "This is FRED, not JOE\n" ; 1 ;') ; + +my $expected_output = <<'EOM' ; +a = 3 +This is FRED, not JOE +Hello Joe +EOM + +$a = `$Perl $Inc $cpp_script 2>&1` ; + +print "1..2\n" ; +ok(1, ($? >>8) == 0) ; +#print "|$a| vs |$expected_output|\n"; +ok(2, $a eq $expected_output) ; + +unlink $cpp_script ; +unlink 'fred' ; diff --git a/t/decrypt.t b/t/decrypt.t new file mode 100644 index 0000000..a548962 --- /dev/null +++ b/t/decrypt.t @@ -0,0 +1,138 @@ + +use strict; +use warnings; +BEGIN { unshift @INC, 't'; } +require "filter-util.pl" ; +use Config; +use Cwd ; +my $here = getcwd ; + +use vars qw( $Inc $Perl ) ; + +my $script = <<'EOM' ; + +print "testing, testing, 1, 2, 3\n" ; +require "./plain" ; +use Cwd ; +$cwd = getcwd ; +print <&1` ; + +print "1..7\n" ; + +print "# running perl with $Perl\n"; +print "# test 1: \$? $?\n" unless ($? >>8) == 0 ; + +ok(1, ($? >>8) == 0) ; +ok(2, $a eq $expected_output) or diag("Got '$a'"); + +# try to catch error cases + +# case 1 - Perl debugger +unless ($Config{usecperl}) { + $ENV{'PERLDB_OPTS'} = 'noTTY' ; + $a = `$Perl $Inc -d $filename 2>&1` ; + ok(3, $a =~ /debugger disabled/) or diag("Got '$a'");; +} else { + ok(3, 1, "SKIP cperl -d"); +} + +# case 2 - Perl Compiler in use +$a = `$Perl $Inc -MCarp -MO=Deparse $filename 2>&1` ; +#print "[[$a]]\n" ; +my $skip = "" ; +$skip = "# skipped -- compiler not available" + if $a =~ /^Can't locate O\.pm in/ || + $a =~ /^Can't load '/ || + $a =~ /^"my" variable \$len masks/ ; +print "# test 4: Got '$a'\n" unless $skip || $a =~ /Aborting, Compiler detected/; +ok(4, ($skip || $a =~ /Aborting, Compiler detected/), $skip) ; + +# case 3 - unknown encryption +writeFile($filename, <&1` ; +ok(5, $a =~ /bad encryption format/) or diag("Got '$a'"); + +# case 4 - extra source filter on the same line +writeFile($filename, <&1` ; +ok(6, $a =~ /too many filters/) or diag("Got '$a'"); + +# case 5 - ut8 encoding [cpan #110921] +writeFile($filename, <<'EOF') ; +use utf8; +my @hiragana = map {chr} ord("ぁ")..ord("ん"); +my $hiragana = join('' => @hiragana); +my $str = $hiragana; +$str =~ tr/ぁ-ん/ァ-ン/; +print $str; +EOF + +if ( $^O eq 'MSWin32' + or !($ENV{LC_ALL} or $ENV{LC_CTYPE}) + or ($ENV{LC_ALL} and $ENV{LC_ALL} !~ /UTF-8/) + or ($ENV{LC_CTYPE} and $ENV{LC_CTYPE} !~ /UTF-8/) ) +{ + print "ok 7 # skip no UTF8 locale\n"; +} else { + my $ori = `$Perl -C $Inc $filename` ; + `$Perl $Inc decrypt/encrypt $filename` ; + $a = `$Perl -C $Inc $filename 2>&1` ; + if ($a eq $ori) { + ok(7, $a eq $ori); + } else { + ok(7, 1, "TODO UTF-8 locale only. Got '$a'"); + } +} + +unlink $filename ; +unlink 'plain' ; diff --git a/t/exec.t b/t/exec.t new file mode 100644 index 0000000..1f5efa2 --- /dev/null +++ b/t/exec.t @@ -0,0 +1,99 @@ +#! perl +use strict; +use warnings; +use Config; + +BEGIN { + unshift @INC, 't'; + my $foundTR = 0 ; + if ($^O eq 'MSWin32') { + # Check if tr is installed + foreach (split ";", $ENV{PATH}) { + if (-e "$_/tr.exe") { + $foundTR = 1; + last ; + } + } + } + else { + $foundTR = 1 + if $Config{'tr'} ne '' ; + } + + if (! $foundTR) { + print "1..0 # Skipping tr not found on this system.\n" ; + exit 0 ; + } +} + +require "filter-util.pl" ; + +use vars qw( $Inc $Perl $script ) ; + +$script = ''; +if (eval { + require POSIX; + my $val = POSIX::setlocale(&POSIX::LC_CTYPE); + $val !~ m{^(C|en)} +}) { # CPAN #41285 + $script = q(BEGIN { $ENV{LANG}=$ENV{LC_ALL}=$ENV{LC_CTYPE}='C'; }); +} + +$script .= <<'EOF' ; + +use Filter::exec qw(tr '[A-E][I-M]' '[a-e][i-m]') ; +use Filter::exec qw(tr '[N-Z]' '[n-z]') ; + +EOF + +$script .= <<'EOF' ; + +$A = 2 ; +PRINT "A = $A\N" ; + +PRINT "HELLO JOE\N" ; +PRINT <&1` ; + +print "1..3\n"; +ok(1, ($? >> 8) == 0) or diag("$Perl $Inc $filename 2>&1", $?); +if ($^O eq 'cygwin' and $a ne $expected_output) { + ok(2, 1, "TODO $^O"); + diag($a); +} else { + ok(2, $a eq $expected_output) or diag($a); +} + +unlink $filename; + +# RT 101668 double free of BUF_NEXT in SvREFCNT_dec(parser->rsfp_filters) +# because we stole BUF_NEXT from IoFMT_NAME. +# +# echo is fairly common on all shells and archs I think. +$a = `echo __DATA__ | $Perl $Inc -MFilter::exec=cat - 2>&1`; +ok(3, ($? >> 8) == 0) or diag($?); + +# Note: To debug this case it is easier to put `echo __DATA__` into a data.sh +# `make MPOLLUTE=-DFDEBUG` +# and `gdb --args perl5.22.0d-nt -DP -Mblib -MFilter::exec=sh data.sh` diff --git a/t/filter-util.pl b/t/filter-util.pl new file mode 100644 index 0000000..a8755e4 --- /dev/null +++ b/t/filter-util.pl @@ -0,0 +1,62 @@ + +use strict ; +use warnings; + +use vars qw( $Perl $Inc); + +sub readFile +{ + my ($filename) = @_ ; + my ($string) = '' ; + + open (F, "<", $filename) + or die "Cannot read $filename: $!\n" ; + while () + { $string .= $_ } + close F ; + $string ; +} + +sub writeFile +{ + my($filename, @strings) = @_ ; + open (F, ">", $filename) + or die "Cannot write $filename: $!\n" ; + binmode(F) if $filename =~ /bin$/i; + foreach (@strings) + { print F } + close F or die "Could not close: $!" ; +} + +sub ok +{ + my ($number, $result, $note) = @_ ; + + $note = "" if ! defined $note ; + if ($note) { + $note = "# $note" if $note !~ /^\s*#/ ; + $note =~ s/^\s*/ / ; + } + + print "not " if !$result ; + print "ok ${number}${note}\n"; + return $result; +} + +sub diag { + print STDERR + (map { /^#/ ? "$_\n" : "# $_\n" } + map { split /\n/ } @_); +} + +$Inc = '' ; +foreach (@INC) { $Inc .= "\"-I$_\" " } +$Inc = "-I::lib" if $^O eq 'MacOS'; + +$Perl = '' ; +$Perl = ($ENV{'FULLPERL'} or $^X or 'perl') ; + +$Perl = "$Perl -MMac::err=unix" if $^O eq 'MacOS'; +$Perl = "$Perl -w" ; + +1; diff --git a/t/order.t b/t/order.t new file mode 100644 index 0000000..f34b13d --- /dev/null +++ b/t/order.t @@ -0,0 +1,85 @@ +#! perl +# check that the filters are destroyed in the correct order by +# installing two different types of filter. If they don't get destroyed +# in the correct order we should get a "filter_del can only delete in +# reverse order" error + +# skip this set of tests is running on anything less than 5.006 +if ($] < 5.006) { + print "1..0\n"; + exit 0; +} + +use strict; +use warnings; +BEGIN { unshift @INC, 't'; } +require "filter-util.pl" ; + +use vars qw( $Inc $Perl) ; + +my $file = "order.test" ; +my $module = "FilterTry"; +my $tee1 = "order1" ; +$Inc .= " -It"; + +writeFile("t/${module}.pm", < 0) { + s/ABC/DEF/g + } + $status ; + } ) ; +} + +1; +__END__ + +=head1 NAME + +FilterTry - Perl Source Filter Example Module created by t/order.t + +=head1 SYNOPSIS + + use FilterTry ; + sourcecode... + +=cut +EOM + +my $fil1 = <<"EOM"; +use $module ; + +print "ABC ABC\n" ; + +EOM + +writeFile($file, <<"EOM", $fil1) ; +use Filter::tee '>$tee1' ; +EOM + +my $a = `$Perl $Inc $file 2>&1` ; + +print "1..3\n" ; + +ok(1, ($? >> 8) == 0) ; +chomp $a; # strip crlf resp. lf +#print "|$a|\n"; +ok(2, $a eq "DEF DEF"); + +my $readtee1 = readFile($tee1); +if ($^O eq 'MSWin32') { + $readtee1 =~ s/\r//g; +} +ok(3, $fil1 eq $readtee1) ; + +unlink $file or die "Cannot remove $file: $!\n" ; +unlink $tee1 or die "Cannot remove $tee1: $!\n" ; diff --git a/t/rt_101033.pm b/t/rt_101033.pm new file mode 100644 index 0000000..526a97c --- /dev/null +++ b/t/rt_101033.pm @@ -0,0 +1,27 @@ +package rt_101033; + +use strict; +use Filter::Util::Call; + +sub import +{ + filter_add({}); + 1; +} + +sub unimport +{ + filter_del() +} + +sub filter +{ + my($self) = @_ ; + my $status = 1; + $status = filter_read(1_000_000); + #print "code: !$_!\n\n"; + return $status; +} + +1; + diff --git a/t/rt_101033.t b/t/rt_101033.t new file mode 100644 index 0000000..2c4a323 --- /dev/null +++ b/t/rt_101033.t @@ -0,0 +1,11 @@ +#! perl +use lib 't'; +use rt_101033; + +print "1..1\n"; +my $s = ; +print "not " if !$s or $s !~ /^test/; +print "ok 1 # TODO RT #101033 + Switch #97440 ignores __DATA__\n"; + +__DATA__ +test diff --git a/t/rt_54452-rebless.t b/t/rt_54452-rebless.t new file mode 100644 index 0000000..c212b2d --- /dev/null +++ b/t/rt_54452-rebless.t @@ -0,0 +1,63 @@ +# RT #54452 check that filter_add does not rebless an already blessed +# given object into the callers class. + +if ($] < 5.004_55) { + print "1..0\n"; + exit 0; +} + +use strict; +use warnings; +BEGIN { unshift @INC, 't'; } + +require "filter-util.pl" ; + +use vars qw( $Inc $Perl) ; + +my $file = "bless.test" ; +my $module = "Foo"; +my $bless1 = "bless1" ; + +writeFile("t/Foo.pm", <<'EOM') ; +package Foo; +use strict; +use warnings; +our @ISA = ('Foo::Base'); + +package Foo::Base; +use Filter::Util::Call; +sub import { + my ($class) = @_; + my $self = bless {}, $class; + print "before ", ref $self, "\n"; + filter_add ($self); + print "after ", ref $self, "\n"; +} +sub filter { + my ($self) = @_; + print "filter ", ref $self, "\n"; + return 0; +} + +1; +EOM + +my $fil1 = <&1` ; +print "1..2\n" ; + +ok(1, ($? >> 8) == 0) ; +chomp $a; +ok(2, $a eq "before Foo +after Foo +filter Foo", "RT \#54452 " . $a); + +unlink $file or die "Cannot remove $file: $!\n" ; +unlink "t/Foo.pm" or die "Cannot remove t/Foo.pm: $!\n" ; diff --git a/t/sh.t b/t/sh.t new file mode 100644 index 0000000..3605e8f --- /dev/null +++ b/t/sh.t @@ -0,0 +1,85 @@ +#! perl +use strict; +use warnings; +use Config; + +BEGIN +{ + unshift @INC, 't'; + my $foundTR = 0 ; + if ($^O eq 'MSWin32') { + # Check if tr is installed + foreach (split ";", $ENV{PATH}) { + if (-e "$_/tr.exe") { + $foundTR = 1; + last ; + } + } + } + else { + $foundTR = 1 + if $Config{'tr'} ne '' ; + } + + if (! $foundTR) { + print "1..0 # Skipping tr not found on this system.\n" ; + exit 0 ; + } +} + +require "filter-util.pl" ; + +use vars qw( $Inc $Perl $script ) ; + +$script = ''; +if (eval { + require POSIX; + my $val = POSIX::setlocale(&POSIX::LC_CTYPE); + $val !~ m{^(C|en)} +}) { # CPAN #41285 + $script = q(BEGIN { $ENV{LANG}=$ENV{LC_ALL}=$ENV{LC_CTYPE}='C'; }); +} + +$script .= <<"EOF" ; + +use Filter::sh q(tr '[A-E][I-M]' '[a-e][i-m]') ; +use Filter::sh q(tr '[N-Z]' '[n-z]') ; + +EOF + +$script .= <<'EOF' ; + +$A = 2 ; +PRINT "A = $A\N" ; + +PRINT "HELLO JOE\N" ; +PRINT <&1` ; + +print "1..2\n" ; +ok(1, ($? >> 8) == 0) or diag($?); +ok(2, $a eq $expected_output) or diag("$Perl $Inc $filename", $a); + +unlink $filename ; + diff --git a/t/tee.t b/t/tee.t new file mode 100644 index 0000000..13cd0d5 --- /dev/null +++ b/t/tee.t @@ -0,0 +1,76 @@ +#! perl +use strict; +use warnings; +BEGIN { unshift @INC, 't'; } +require "filter-util.pl" ; + +use vars qw( $Inc $Perl $tee1) ; + +my $file = "tee.test" ; +$tee1 = "tee1" ; +my $tee2 = "tee2" ; + + +my $out1 = <<"EOF" ; +use Filter::tee '>$tee1' ; +EOF + +my $out2 = <<"EOF" ; +use Filter::tee '>>$tee2' ; +EOF + +my $out3 = <<'EOF' ; + +$a = 1 ; +print "a = $a\n" ; + +use Carp ; +require "./joe" ; + +print <&1` ; + +print "1..5\n" ; + +ok(1, ($? >> 8) == 0) ; +ok(2, $a eq <&1` ; + + ok(5, $a =~ /cannot open file 'tee1':/) ; +} + +unlink $file or die "Cannot remove $file: $!\n" ; +unlink 'joe' or die "Cannot remove joe: $!\n" ; +unlink $tee1 or die "Cannot remove $tee1: $!\n" ; +unlink $tee2 or die "Cannot remove $tee2: $!\n" ; diff --git a/t/z_kwalitee.t b/t/z_kwalitee.t new file mode 100644 index 0000000..93132a7 --- /dev/null +++ b/t/z_kwalitee.t @@ -0,0 +1,29 @@ +# -*- perl -*- +use strict; +use warnings; +use Test::More; +use Config; + +plan skip_all => 'requires Test::More 0.88' if Test::More->VERSION < 0.88; + +plan skip_all => 'This test is only run for the module author' + unless -d '.git' || $ENV{AUTHOR_TESTING} || $ENV{RELEASE_TESTING}; + +# Missing XS dependencies are usually not caught by EUMM +# And they are usually only XS-loaded by the importer, not require. +for (qw( Class::XSAccessor Text::CSV_XS List::MoreUtils )) { + eval "use $_;"; + plan skip_all => "$_ required for Test::Kwalitee" + if $@; +} +eval "require Test::Kwalitee;"; +plan skip_all => "Test::Kwalitee required" + if $@; + +plan skip_all => 'Test::Kwalitee fails with clang -faddress-sanitizer' + if $Config{ccflags} =~ /-faddress-sanitizer/; + +use File::Copy 'cp'; +cp('MYMETA.yml','META.yml') if -e 'MYMETA.yml' and !-e 'META.yml'; + +Test::Kwalitee->import( tests => [ qw( -use_strict -proper_libs ) ] ); diff --git a/t/z_manifest.t b/t/z_manifest.t new file mode 100644 index 0000000..cf51810 --- /dev/null +++ b/t/z_manifest.t @@ -0,0 +1,16 @@ +# -*- perl -*- +use Test::More; +if (!-d ".git" or $^O !~ /^(linux|.*bsd|darwin|solaris|sunos)$/) { + plan skip_all => "requires a git checkout and a unix for git and diff"; +} +plan skip_all => "on travis" if $ENV{TRAVIS}; +plan tests => 1; + +system("git ls-tree -r --name-only HEAD >MANIFEST.git"); +if (-e "MANIFEST.git") { + diag "MANIFEST.git created with git ls-tree"; + is(`diff -bu MANIFEST.git MANIFEST`, "", "MANIFEST.git compared to MANIFEST"); + unlink "MANIFEST.git"; +} else { + ok(1, "skip no git"); +} diff --git a/t/z_meta.t b/t/z_meta.t new file mode 100644 index 0000000..8daf322 --- /dev/null +++ b/t/z_meta.t @@ -0,0 +1,33 @@ +# -*- perl -*- + +# Test that our META.yml file matches the current specification. + +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +my $MODULE = 'Test::CPAN::Meta 0.12'; + +# Don't run tests for installs +use Test::More; +use Config; +plan skip_all => 'This test is only run for the module author' + unless -d '.git' || $ENV{IS_MAINTAINER}; +plan skip_all => 'This test is unstable < 5.10' + if $] < 5.010; +plan skip_all => 'Test::CPAN::Meta fails with clang -faddress-sanitizer' + if $Config{ccflags} =~ /-faddress-sanitizer/; + +# Load the testing module +eval "use $MODULE;"; +if ( $@ ) { + plan( skip_all => "$MODULE not available for testing" ); + die "Failed to load required release-testing module $MODULE 0.12" + if -d '.git' || $ENV{IS_MAINTAINER}; +} +use File::Copy 'cp'; +cp('MYMETA.yml','META.yml') if -e 'MYMETA.yml' and !-e 'META.yml'; + +meta_yaml_ok(); diff --git a/t/z_perl_minimum_version.t b/t/z_perl_minimum_version.t new file mode 100644 index 0000000..2392cd5 --- /dev/null +++ b/t/z_perl_minimum_version.t @@ -0,0 +1,33 @@ +# -*- perl -*- + +# Test that our declared minimum Perl version matches our syntax +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +my @MODULES = ( + 'Perl::MinimumVersion 1.20', + 'Test::MinimumVersion 0.008', +); + +# Don't run tests during end-user installs +use Test::More; +unless (-d '.git' || $ENV{IS_MAINTAINER}) { + plan( skip_all => "Author tests not required for installation" ); +} + +# Load the testing modules +foreach my $MODULE ( @MODULES ) { + eval "use $MODULE"; + if ( $@ ) { + plan( skip_all => "$MODULE not available for testing" ); + die "Failed to load required release-testing module $MODULE" + if -d '.git' || $ENV{IS_MAINTAINER}; + } +} + +all_minimum_version_ok("5.006"); + +1; diff --git a/t/z_pod-coverage.t b/t/z_pod-coverage.t new file mode 100644 index 0000000..8a18851 --- /dev/null +++ b/t/z_pod-coverage.t @@ -0,0 +1,19 @@ +# -*- perl -*- +use strict; +use warnings; +use Test::More; + +BEGIN { + plan skip_all => 'done_testing requires Test::More 0.88' if Test::More->VERSION < 0.88; + plan skip_all => 'This test is only run for the module author' + unless -d '.git' || $ENV{IS_MAINTAINER}; +} +eval "use Test::Pod::Coverage 1.04"; +plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" + if $@; + +for (all_modules()) { + pod_coverage_ok($_) unless /Filter::decrypt/; +} + +done_testing; diff --git a/t/z_pod.t b/t/z_pod.t new file mode 100644 index 0000000..b2d4531 --- /dev/null +++ b/t/z_pod.t @@ -0,0 +1,5 @@ +# -*- perl -*- +use Test::More; +eval "use Test::Pod 1.00"; +plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; +all_pod_files_ok(); diff --git a/tee/Makefile.PL b/tee/Makefile.PL new file mode 100755 index 0000000..d6bc234 --- /dev/null +++ b/tee/Makefile.PL @@ -0,0 +1,7 @@ +use ExtUtils::MakeMaker; + + +WriteMakefile( + NAME => 'Filter::tee', + VERSION_FROM => 'tee.pm', +); diff --git a/tee/tee.pm b/tee/tee.pm new file mode 100644 index 0000000..559167f --- /dev/null +++ b/tee/tee.pm @@ -0,0 +1,45 @@ +package Filter::tee ; + +require 5.006 ; +require XSLoader; +our $VERSION = "1.58" ; + +XSLoader::load('Filter::tee'); +1; +__END__ + +=head1 NAME + +Filter::tee - tee source filter + +=head1 SYNOPSIS + + use Filter::tee 'filename' ; + use Filter::tee '>filename' ; + use Filter::tee '>>filename' ; + +=head1 DESCRIPTION + +This filter copies all text from the line after the C in the +current source file to the file specified by the parameter +C. + +By default and when the filename is prefixed with a '>' the output file +will be emptied first if it already exists. + +If the output filename is prefixed with '>>' it will be opened for +appending. + +This filter is useful as a debugging aid when developing other source +filters. + +=head1 AUTHOR + +Paul Marquess + +=head1 DATE + +20th June 1995. + +=cut + diff --git a/tee/tee.xs b/tee/tee.xs new file mode 100644 index 0000000..0d6572a --- /dev/null +++ b/tee/tee.xs @@ -0,0 +1,78 @@ +/* + * Filename : tee.xs + * + * Author : Paul Marquess + * Date : 2017-11-14 18:25:18 rurban + * Version : 1.02 + * + */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include "../Call/ppport.h" + +static I32 +filter_tee(pTHX_ int idx, SV *buf_sv, int maxlen) +{ + I32 len; +#if PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8) + PerlIO * fil = (PerlIO*) IoOFP(FILTER_DATA(idx)); +#else + PerlIO * fil = INT2PTR(PerlIO*, SvIV(FILTER_DATA(idx))); +#endif + int old_len = SvCUR(buf_sv) ; + + if ( (len = FILTER_READ(idx+1, buf_sv, maxlen)) <=0 ) { + /* error or eof */ + PerlIO_close(fil) ; + filter_del(filter_tee); /* remove me from filter stack */ + return len; + } + + /* write to the tee'd file */ + PerlIO_write(fil, SvPVX(buf_sv) + old_len, len - old_len) ; + + return SvCUR(buf_sv); +} + +MODULE = Filter::tee PACKAGE = Filter::tee + +PROTOTYPES: DISABLE + +void +import(module, filename) + SV * module = NO_INIT + char * filename + CODE: +#if PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8) + SV * stream = newSV_type(SVt_PVIO); +#else + SV * stream = newSViv(0); +#endif + PerlIO * fil ; + char * mode = "wb" ; + + filter_add(filter_tee, stream); + /* check for append */ + if (*filename == '>') { + ++ filename ; + if (*filename == '>') { + ++ filename ; + mode = "ab" ; + } + } + if ((fil = PerlIO_open(filename, mode)) == NULL) + croak("Filter::tee - cannot open file '%s': %s", + filename, Strerror(errno)) ; + + /* save the tee'd file handle. */ +#if PERL_VERSION > 8 || (PERL_VERSION == 8 && PERL_SUBVERSION > 8) + IoOFP(stream) = fil; +#else + { + IV iv = PTR2IV(fil); + SvIV_set(stream, iv); + } +#endif +