diff --git a/.editorconfig b/.editorconfig new file mode 100644 index 000000000000..a7417d0bbe24 --- /dev/null +++ b/.editorconfig @@ -0,0 +1,10 @@ +root = true + +[**/*.[ch]] +charset = utf-8 +indent_style = space +indent_size = 4 +tab_width = 8 +end_of_line = lf +trim_trailing_whitespace = true +insert_final_newline = true diff --git a/.github/workflows/irc-notifications.yaml b/.github/workflows/irc-notifications.yaml index 83e61c24f1d2..7cb111ee65e1 100644 --- a/.github/workflows/irc-notifications.yaml +++ b/.github/workflows/irc-notifications.yaml @@ -25,11 +25,61 @@ jobs: - name: setup branch env name run: | ref="${github_ref/refs\/heads\//}" - echo "setenv ref=$ref" - echo "::set-env name=ref::$ref" + echo "ref=$ref" >> $GITHUB_ENV env: github_ref: ${{ github.event.ref }} + - name: Setup commit message SUMUP env + env: + TXT: ${{ join(github.event.commits.*.message, '\n') }} + C1: ${{ github.event.commits[0].message }} + C2: ${{ github.event.commits[1].message }} + C3: ${{ github.event.commits[2].message }} + C4: ${{ github.event.commits[3].message }} + C5: ${{ github.event.commits[4].message }} + run: | + # ------------------------------------- + echo "# original commit message" + echo "TXT=$TXT" + + # ------------------------------------- + echo "# Last 5 commits message" + echo "C1=$C1" + echo "C2=$C2" + echo "C3=$C3" + echo "C4=$C4" + echo "C5=$C5" + + # ------------------------------------- + echo "# script parse.pl" + cat <<'EOS' > parse.pl + use v5.14; use strict; use warnings; + my $txt = join "\n", map { $ENV{"C$_"} // '' } 1..5; + $txt =~ s{\\n}{\n}g; $txt =~ s{\\t}{ }g; $txt =~ s{\t}{ }g; + my @l = split( "\n", $txt ); + my $max = 5; + @l = ( @l[0..$max], "..." ) if @l > $max; + @l = grep { $_ !~ m{^EOF} } @l; + say( join( "\n", @l ) ); + EOS + + # ------------------------------------- + echo "# testing script" + perl parse.pl + + # ------------------------------------- + echo "# setup SUMUP environment variable" + echo 'SUMUP<> $GITHUB_ENV + perl parse.pl >> $GITHUB_ENV + echo 'EOF' >> $GITHUB_ENV + + # ------------------------------------- + echo "# done" + + - name: checking SUMUP variable + run: | + echo "SUMUP: $SUMUP" + - name: irc push uses: rectalogic/notify-irc@v1 if: github.event_name == 'push' && github.ref != 'refs/heads/blead' @@ -40,7 +90,7 @@ jobs: nickname: Commit message: "\x037${{ github.actor }}\x0F pushed to branch \x033${{ env.ref }}\x0F\n\ - ${{ join(github.event.commits.*.message, '\n') }}\n\ + ${{ env.SUMUP }}\n\ ${{ github.event.compare }}" - name: irc push to blead @@ -53,7 +103,7 @@ jobs: nickname: inBlead message: "\x0313[blead]\x0F \x037${{ github.actor }}\x0F pushed to blead\n\ - ${{ join(github.event.commits.*.message, '\n') }}\n\ + ${{ env.SUMUP }}\n\ ${{ github.event.compare }}" - name: irc opened pull request @@ -82,18 +132,3 @@ jobs: "\x037${{ github.actor }}\x0F updated PR #${{ github.event.pull_request.number }}\n\ ${{ github.event.pull_request.title }}\n\ ${{ github.event.pull_request.html_url }}" - - # steps: - # - name: Pull request merged - # if: github.action == 'closed' && github.pull_request.merged == 'true' - # run: echo merged - # - name: irc tag created - # uses: rectalogic/notify-irc@v1 - # if: github.event_name == 'create' && github.event.ref_type == 'tag' - # with: - # server: ssl.irc.perl.org - # port: 7062 - # channel: "#p5p-commits" - # nickname: new-Tag - # message: | - # ${{ github.actor }} tagged ${{ github.repository }} ${{ github.event.ref }} diff --git a/.github/workflows/testsuite.yml b/.github/workflows/testsuite.yml index 6d422abc64ed..ad3b097a2606 100644 --- a/.github/workflows/testsuite.yml +++ b/.github/workflows/testsuite.yml @@ -200,9 +200,9 @@ jobs: # | ' \/ _` / _| (_) \__ \ # |_|_|_\__,_\__|\___/|___/ - smoke-macos-xcode11: - name: "macOS xcode 11" - runs-on: macos-latest + smoke-macos-catalina-xcode12: + name: "macOS (catalina) xcode 12" + runs-on: macos-10.15 timeout-minutes: 120 needs: sanity_check if: needs.sanity_check.outputs.run_all_jobs == 'true' diff --git a/.gitignore b/.gitignore index eab6ae957a0a..4fcfe623c7f9 100644 --- a/.gitignore +++ b/.gitignore @@ -83,8 +83,7 @@ perldtrace.h *.gcno dll.base -/ext/DynaLoader/dl_win32.xs -splittree.pl +/splittree.pl # generated by make on cygwin /cygwin.c @@ -134,8 +133,6 @@ lib/unicore/mktables.lst xlib/ # test byproducts -ext/Test-Harness/t/ext/ -ext/XS-APItest/APItest.bso t/rantests t/tmp* t/perl @@ -191,9 +188,6 @@ cscope.po.out # generated by the top level install.html target. XXX Why does it need this? /vms/README_vms.pod -# generated be ext/re/Makefile -ext/re/invlist_inline.h - # ctags tags TAGS diff --git a/AUTHORS b/AUTHORS index 6644eb825bb3..226b3eb1184e 100644 --- a/AUTHORS +++ b/AUTHORS @@ -175,6 +175,7 @@ Brad Lanam Bradley Dean Bram Brandon Black +Branislav Zahradník Brendan Byrd Brendan O'Dea Breno G. de Oliveira @@ -294,11 +295,13 @@ Dan Kogai Dan Schmidt Dan Sugalski Daniel Berger +Daniel Böhmer Daniel Chetlin Daniel Dragan Daniel Frederick Crisman Daniel Grisinger Daniel Kahn Gillmor +Daniel Laügt Daniel Lieberman Daniel Muiño Daniel P. Berrange @@ -460,6 +463,7 @@ Gerd Knops Gerrit P. Haase Gideon Israel Dsouza Giles Lean +Giovanni Tataranni Gisle Aas GitHub Glenn D. Golden @@ -554,6 +558,7 @@ Jacinta Richardson Jack Shirazi Jacques Germishuys Jacqui Caren +Jae Bradley Jake Hamby Jakub Wilk James @@ -621,6 +626,7 @@ Jim Miner Jim Richardson Jim Schneider Jirka Hruška +jkahrman Joachim Huober Joaquin Ferrero Jochen Wiedmann @@ -651,6 +657,7 @@ John Hawkinson John Heidemann John Holdsworth John Hughes +John Karr John Kristian John L. Allen John Lightsey @@ -1154,7 +1161,9 @@ Sebastian Wittmeier Sebastien Barre Sergey Alekseev Sergey Aleynikov +Sergey Poznyakoff Sergiy Borodych +Sevan Janiyan Shawn Shawn M Moore Sherm Pendley diff --git a/Configure b/Configure index 16d63709ee4a..2d2f22fc082a 100755 --- a/Configure +++ b/Configure @@ -514,6 +514,7 @@ d_gai_strerror='' d_Gconvert='' d_getaddrinfo='' d_getcwd='' +d_getenv_preserves_other_thread='' d_getespwnam='' d_getfsstat='' d_getgrent='' @@ -10373,6 +10374,15 @@ void checkit(const char *expect, char *got) } } +void lencheck(int expect, int got) +{ + if (expect != got) { + printf("%s length mismatch: Expected %d, got %d\n", + myname, expect, got); + exit(1); + } +} + int main() { char buf[64]; @@ -10445,6 +10455,12 @@ int main() else checkit("1e+34", buf); + /* Test for an Ubuntu/Debian bug in gcvt and qgcvt. See: * + * https://bugs.launchpad.net/ubuntu/+source/glibc/+bug/1899553 */ + + Gconvert((DOUBLETYPE)0.4, 53, 0, buf); + lencheck(55, (int)strlen(buf)); + /* For Perl, if you add additional tests here, also add them to * t/base/num.t for benefit of platforms not using Configure or * overriding d_Gconvert */ @@ -14206,6 +14222,86 @@ eval $inlibc set getcwd d_getcwd eval $inlibc +: check for getenv behavior +case "$d_getenv_preserves_other_thread" in +'') +$echo "Checking to see if getenv() preserves a different thread's results" >&4 +$cat >try.c < +#endif +#include +#include +#$i_pthread I_PTHREAD +#ifdef I_PTHREAD +# include +#endif + +void * +thread_start(void * arg) +{ + (void *) getenv("HOME"); +} + +int main() { + char * main_buffer; + char save_main_buffer[1000]; + pthread_t subthread; + pthread_attr_t attr; + + main_buffer = getenv("PATH"); + + /* If too large for our generous allowance, return we couldn't figure it + * out. */ + if (strlen(main_buffer) >= sizeof(save_main_buffer)) { + exit(2); + } + + strcpy(save_main_buffer, main_buffer); + + if (pthread_attr_init(&attr) != 0) { + exit(2); + } + + if (pthread_create(&subthread, &attr, thread_start, NULL) != 0) { + exit(2); + } + + if (pthread_join(subthread, NULL) != 0) { + exit(2); + } + + exit(! strcmp(main_buffer, save_main_buffer) == 0); +} +EOCP +val= +set try +if eval $compile_ok; then + $run ./try + rc=$? + case "$rc" in + 0) echo "getenv() didn't destroy another thread's buffer" >&4 + val=$define + ;; + 1) echo "getenv() does destroy another thread's buffer" >&4 + val=$undef + ;; + *) echo "Couldn't determine if getenv() destroys another thread's return value (code=$rc); assuming it does" >&4 + val=$undef + ;; + esac +else + echo "(I can't seem to compile the test program.)" >&4 + echo "Assuming that your C library's getenv destroys another thread's return value." >&4 + val=$undef +fi +set d_getenv_preserves_other_thread +eval $setvar +$rm_try +;; +esac + : see if getespwnam exists set getespwnam d_getespwnam eval $inlibc @@ -24251,6 +24347,7 @@ d_gdbm_ndbm_h_uses_prototypes='$d_gdbm_ndbm_h_uses_prototypes' d_gdbmndbm_h_uses_prototypes='$d_gdbmndbm_h_uses_prototypes' d_getaddrinfo='$d_getaddrinfo' d_getcwd='$d_getcwd' +d_getenv_preserves_other_thread='$d_getenv_preserves_other_thread' d_getespwnam='$d_getespwnam' d_getfsstat='$d_getfsstat' d_getgrent='$d_getgrent' diff --git a/Cross/config.sh-arm-linux b/Cross/config.sh-arm-linux index fc03860333db..8188147ae3ff 100644 --- a/Cross/config.sh-arm-linux +++ b/Cross/config.sh-arm-linux @@ -31,12 +31,12 @@ afsroot='/afs' alignbytes='4' aphostname='/bin/hostname' api_revision='5' -api_subversion='4' +api_subversion='7' api_version='33' -api_versionstring='5.33.4' +api_versionstring='5.33.7' ar='ar' -archlib='/usr/lib/perl5/5.33.4/armv4l-linux' -archlibexp='/usr/lib/perl5/5.33.4/armv4l-linux' +archlib='/usr/lib/perl5/5.33.7/armv4l-linux' +archlibexp='/usr/lib/perl5/5.33.7/armv4l-linux' archname64='' archname='armv4l-linux' archobjs='' @@ -55,7 +55,7 @@ castflags='0' cat='cat' cc='cc' cccdlflags='-fpic' -ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.33.4/armv4l-linux/CORE' +ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.33.7/armv4l-linux/CORE' ccflags='-fno-strict-aliasing -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64' ccflags_uselargefiles='-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64' ccname='arm-linux-gcc' @@ -248,6 +248,7 @@ d_gdbm_ndbm_h_uses_prototypes='undef' d_gdbmndbm_h_uses_prototypes='undef' d_getaddrinfo='undef' d_getcwd='define' +d_getenv_preserves_other_thread='define' d_getespwnam='undef' d_getfsstat='undef' d_getgrent='define' @@ -824,7 +825,7 @@ inc_version_list=' ' inc_version_list_init='0' incpath='' inews='' -installarchlib='./install_me_here/usr/lib/perl5/5.33.4/armv4l-linux' +installarchlib='./install_me_here/usr/lib/perl5/5.33.7/armv4l-linux' installbin='./install_me_here/usr/bin' installhtml1dir='' installhtml3dir='' @@ -832,13 +833,13 @@ installman1dir='./install_me_here/usr/share/man/man1' installman3dir='./install_me_here/usr/share/man/man3' installprefix='./install_me_here/usr' installprefixexp='./install_me_here/usr' -installprivlib='./install_me_here/usr/lib/perl5/5.33.4' +installprivlib='./install_me_here/usr/lib/perl5/5.33.7' installscript='./install_me_here/usr/bin' -installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.33.4/armv4l-linux' +installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.33.7/armv4l-linux' installsitebin='./install_me_here/usr/bin' installsitehtml1dir='' installsitehtml3dir='' -installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.33.4' +installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.33.7' installsiteman1dir='./install_me_here/usr/share/man/man1' installsiteman3dir='./install_me_here/usr/share/man/man3' installsitescript='./install_me_here/usr/bin' @@ -972,8 +973,8 @@ pmake='' pr='' prefix='/usr' prefixexp='/usr' -privlib='/usr/lib/perl5/5.33.4' -privlibexp='/usr/lib/perl5/5.33.4' +privlib='/usr/lib/perl5/5.33.7' +privlibexp='/usr/lib/perl5/5.33.7' procselfexe='"/proc/self/exe"' prototype='define' ptrsize='4' @@ -1038,17 +1039,17 @@ sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 6, 17, 29, 31, 0' sig_size='68' signal_t='void' -sitearch='/usr/lib/perl5/site_perl/5.33.4/armv4l-linux' -sitearchexp='/usr/lib/perl5/site_perl/5.33.4/armv4l-linux' +sitearch='/usr/lib/perl5/site_perl/5.33.7/armv4l-linux' +sitearchexp='/usr/lib/perl5/site_perl/5.33.7/armv4l-linux' sitebin='/usr/bin' sitebinexp='/usr/bin' sitehtml1dir='' sitehtml1direxp='' sitehtml3dir='' sitehtml3direxp='' -sitelib='/usr/lib/perl5/site_perl/5.33.4' +sitelib='/usr/lib/perl5/site_perl/5.33.7' sitelib_stem='/usr/lib/perl5/site_perl' -sitelibexp='/usr/lib/perl5/site_perl/5.33.4' +sitelibexp='/usr/lib/perl5/site_perl/5.33.7' siteman1dir='/usr/share/man/man1' siteman1direxp='/usr/share/man/man1' siteman3dir='/usr/share/man/man3' @@ -1087,7 +1088,7 @@ stdio_stream_array='' strerror_r_proto='0' strings='/usr/include/string.h' submit='' -subversion='4' +subversion='7' sysman='/usr/share/man/man1' tail='' tar='' @@ -1178,8 +1179,8 @@ vendorprefix='' vendorprefixexp='' vendorscript='' vendorscriptexp='' -version='5.33.4' -version_patchlevel_string='version 33 subversion 4' +version='5.33.7' +version_patchlevel_string='version 33 subversion 7' versiononly='undef' vi='' xlibpth='/usr/lib/386 /lib/386' @@ -1193,9 +1194,9 @@ config_args='' config_argc=0 PERL_REVISION=5 PERL_VERSION=33 -PERL_SUBVERSION=4 +PERL_SUBVERSION=7 PERL_API_REVISION=5 PERL_API_VERSION=33 -PERL_API_SUBVERSION=4 +PERL_API_SUBVERSION=7 PERL_PATCHLEVEL= PERL_CONFIG_SH=true diff --git a/Cross/config.sh-arm-linux-n770 b/Cross/config.sh-arm-linux-n770 index 5f18e7b4c84f..ec7832e47bf8 100644 --- a/Cross/config.sh-arm-linux-n770 +++ b/Cross/config.sh-arm-linux-n770 @@ -31,12 +31,12 @@ afsroot='/afs' alignbytes='4' aphostname='/bin/hostname' api_revision='5' -api_subversion='4' +api_subversion='7' api_version='33' -api_versionstring='5.33.4' +api_versionstring='5.33.7' ar='ar' -archlib='/usr/lib/perl5/5.33.4/armv4l-linux' -archlibexp='/usr/lib/perl5/5.33.4/armv4l-linux' +archlib='/usr/lib/perl5/5.33.7/armv4l-linux' +archlibexp='/usr/lib/perl5/5.33.7/armv4l-linux' archname64='' archname='armv4l-linux' archobjs='' @@ -54,7 +54,7 @@ castflags='0' cat='cat' cc='arm-none-linux-gnueabi-gcc' cccdlflags='-fpic' -ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.33.4/armv4l-linux/CORE' +ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.33.7/armv4l-linux/CORE' ccflags='-fno-strict-aliasing -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64' ccflags_uselargefiles='-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64' ccname='arm-linux-gcc' @@ -247,6 +247,7 @@ d_gdbm_ndbm_h_uses_prototypes='undef' d_gdbmndbm_h_uses_prototypes='undef' d_getaddrinfo='undef' d_getcwd='define' +d_getenv_preserves_other_thread='define' d_getespwnam='undef' d_getfsstat='undef' d_getgrent='define' @@ -822,7 +823,7 @@ inc_version_list=' ' inc_version_list_init='0' incpath='' inews='' -installarchlib='./install_me_here/usr/lib/perl5/5.33.4/armv4l-linux' +installarchlib='./install_me_here/usr/lib/perl5/5.33.7/armv4l-linux' installbin='./install_me_here/usr/bin' installhtml1dir='' installhtml3dir='' @@ -830,13 +831,13 @@ installman1dir='./install_me_here/usr/share/man/man1' installman3dir='./install_me_here/usr/share/man/man3' installprefix='./install_me_here/usr' installprefixexp='./install_me_here/usr' -installprivlib='./install_me_here/usr/lib/perl5/5.33.4' +installprivlib='./install_me_here/usr/lib/perl5/5.33.7' installscript='./install_me_here/usr/bin' -installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.33.4/armv4l-linux' +installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.33.7/armv4l-linux' installsitebin='./install_me_here/usr/bin' installsitehtml1dir='' installsitehtml3dir='' -installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.33.4' +installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.33.7' installsiteman1dir='./install_me_here/usr/share/man/man1' installsiteman3dir='./install_me_here/usr/share/man/man3' installsitescript='./install_me_here/usr/bin' @@ -970,8 +971,8 @@ pmake='' pr='' prefix='/usr' prefixexp='/usr' -privlib='/usr/lib/perl5/5.33.4' -privlibexp='/usr/lib/perl5/5.33.4' +privlib='/usr/lib/perl5/5.33.7' +privlibexp='/usr/lib/perl5/5.33.7' procselfexe='"/proc/self/exe"' prototype='define' ptrsize='4' @@ -1036,17 +1037,17 @@ sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 6, 17, 29, 31, 0' sig_size='68' signal_t='void' -sitearch='/usr/lib/perl5/site_perl/5.33.4/armv4l-linux' -sitearchexp='/usr/lib/perl5/site_perl/5.33.4/armv4l-linux' +sitearch='/usr/lib/perl5/site_perl/5.33.7/armv4l-linux' +sitearchexp='/usr/lib/perl5/site_perl/5.33.7/armv4l-linux' sitebin='/usr/bin' sitebinexp='/usr/bin' sitehtml1dir='' sitehtml1direxp='' sitehtml3dir='' sitehtml3direxp='' -sitelib='/usr/lib/perl5/site_perl/5.33.4' +sitelib='/usr/lib/perl5/site_perl/5.33.7' sitelib_stem='/usr/lib/perl5/site_perl' -sitelibexp='/usr/lib/perl5/site_perl/5.33.4' +sitelibexp='/usr/lib/perl5/site_perl/5.33.7' siteman1dir='/usr/share/man/man1' siteman1direxp='/usr/share/man/man1' siteman3dir='/usr/share/man/man3' @@ -1085,7 +1086,7 @@ stdio_stream_array='' strerror_r_proto='0' strings='/usr/include/string.h' submit='' -subversion='4' +subversion='7' sysman='/usr/share/man/man1' tail='' tar='' @@ -1176,8 +1177,8 @@ vendorprefix='' vendorprefixexp='' vendorscript='' vendorscriptexp='' -version='5.33.4' -version_patchlevel_string='version 33 subversion 4' +version='5.33.7' +version_patchlevel_string='version 33 subversion 7' versiononly='undef' vi='' xlibpth='/usr/lib/386 /lib/386' @@ -1191,9 +1192,9 @@ config_args='' config_argc=0 PERL_REVISION=5 PERL_VERSION=33 -PERL_SUBVERSION=4 +PERL_SUBVERSION=7 PERL_API_REVISION=5 PERL_API_VERSION=33 -PERL_API_SUBVERSION=4 +PERL_API_SUBVERSION=7 PERL_PATCHLEVEL= PERL_CONFIG_SH=true diff --git a/INSTALL b/INSTALL index c16117f12493..10467fc4c989 100644 --- a/INSTALL +++ b/INSTALL @@ -371,7 +371,7 @@ although from time to time we change which functions we support, and which function is default (currently SBOX+STADTX on 64 bit builds and SBOX+ZAPHOD32 for 32 bit builds). You can choose a different algorithm by defining one of the following symbols during configure. -Note that there security implications of which hash function you choose +Note that there are security implications regarding which hash function you choose to use. The functions are listed roughly by how secure they are believed to be, with the one believed to be most secure at release time being PERL_HASH_FUNC_SIPHASH. @@ -388,10 +388,10 @@ and which has rather expensive setup costs (relatively speaking), both in terms of performance and more importantly in terms of memory. SBOX32 requires 1k of storage per character it can hash, and it must populate that storage with 256 32-bit random values as well. In practice the RNG we use -for seeding the SBOX32 storage is very efficient and populating the table +for seeding the SBOX32 storage is very efficient, and populating the table required for hashing even fairly long keys is negligible as we only do it -during startup. By default we build with SBOX32 enabled, but you change that -by setting +during startup. By default we build with SBOX32 enabled, but you can change +that by setting PERL_HASH_USE_SBOX32_ALSO @@ -615,7 +615,7 @@ The directories set up by Configure fall into three broad categories. =item Directories for the perl distribution -By default, Configure will use the following directories for 5.33.4. +By default, Configure will use the following directories for 5.33.7. $version is the full perl version number, including subversion, e.g. 5.12.3, and $archname is a string like sun4-sunos, determined by Configure. The full definitions of all Configure @@ -2438,7 +2438,7 @@ L =head1 Coexistence with earlier versions of perl 5 -Perl 5.33.4 is not binary compatible with earlier versions of Perl. +Perl 5.33.7 is not binary compatible with earlier versions of Perl. In other words, you will have to recompile your XS modules. In general, you can usually safely upgrade from one stable version of Perl @@ -2513,9 +2513,9 @@ won't interfere with another version. (The defaults guarantee this for libraries after 5.6.0, but not for executables. TODO?) One convenient way to do this is by using a separate prefix for each version, such as - sh Configure -Dprefix=/opt/perl5.33.4 + sh Configure -Dprefix=/opt/perl5.33.7 -and adding /opt/perl5.33.4/bin to the shell PATH variable. Such users +and adding /opt/perl5.33.7/bin to the shell PATH variable. Such users may also wish to add a symbolic link /usr/local/bin/perl so that scripts can still start with #!/usr/local/bin/perl. @@ -2528,13 +2528,13 @@ seriously consider using a separate directory, since development subversions may not have all the compatibility wrinkles ironed out yet. -=head2 Upgrading from 5.33.3 or earlier +=head2 Upgrading from 5.33.6 or earlier -B Perl modules having binary parts (meaning that a C compiler is used) will have to be recompiled to be -used with 5.33.4. If you find you do need to rebuild an extension with -5.33.4, you may safely do so without disturbing the older +used with 5.33.7. If you find you do need to rebuild an extension with +5.33.7, you may safely do so without disturbing the older installations. (See L<"Coexistence with earlier versions of perl 5"> above.) @@ -2567,15 +2567,15 @@ Firstly, the bare minimum to run this script print("$f\n"); } -in Linux with perl-5.33.4 is as follows (under $Config{prefix}): +in Linux with perl-5.33.7 is as follows (under $Config{prefix}): ./bin/perl - ./lib/perl5/5.33.4/strict.pm - ./lib/perl5/5.33.4/warnings.pm - ./lib/perl5/5.33.4/i686-linux/File/Glob.pm - ./lib/perl5/5.33.4/feature.pm - ./lib/perl5/5.33.4/XSLoader.pm - ./lib/perl5/5.33.4/i686-linux/auto/File/Glob/Glob.so + ./lib/perl5/5.33.7/strict.pm + ./lib/perl5/5.33.7/warnings.pm + ./lib/perl5/5.33.7/i686-linux/File/Glob.pm + ./lib/perl5/5.33.7/feature.pm + ./lib/perl5/5.33.7/XSLoader.pm + ./lib/perl5/5.33.7/i686-linux/auto/File/Glob/Glob.so Secondly, for perl-5.10.1, the Debian perl-base package contains 591 files, (of which 510 are for lib/unicore) totaling about 3.5MB in its diff --git a/MANIFEST b/MANIFEST index 003b2203e48d..3ead9bd6c86a 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1,4 +1,5 @@ .dir-locals.el Emacs control file +.editorconfig EditorConfig style file .lgtm.yml LGTM.com configuration file .metaconf-exclusions.txt Symbols that should ignored when generating Configure .travis.yml continuous integration on github (where enabled) @@ -248,6 +249,10 @@ cpan/Config-Perl-V/t/31_plv52511.t Config::Perl::V cpan/Config-Perl-V/t/32_plv5261rc1.t Config::Perl::V cpan/Config-Perl-V/t/33_plv52711r.t Config::Perl::V cpan/Config-Perl-V/t/34_plv5280.t Config::Perl::V +cpan/Config-Perl-V/t/35_plv52910g.t Config::Perl::V +cpan/Config-Perl-V/t/36_plv5300.t Config::Perl::V +cpan/Config-Perl-V/t/37_plv53111qm.t Config::Perl::V +cpan/Config-Perl-V/t/38_plv5320tld.t Config::Perl::V cpan/Config-Perl-V/V.pm Config::Perl::V cpan/CPAN/lib/App/Cpan.pm helper package for CPAN.pm cpan/CPAN/lib/CPAN.pm Interface to Comprehensive Perl Archive Network @@ -1275,7 +1280,6 @@ cpan/libnet/t/config.t libnet cpan/libnet/t/datasend.t libnet cpan/libnet/t/ftp.t libnet cpan/libnet/t/hostname.t libnet -cpan/libnet/t/libnet_t.pl libnet cpan/libnet/t/netrc.t libnet cpan/libnet/t/nntp.t libnet cpan/libnet/t/nntp_ipv6.t @@ -1541,6 +1545,10 @@ cpan/perlfaq/lib/perlfaq8.pod System Interaction cpan/perlfaq/lib/perlfaq9.pod Networking cpan/perlfaq/lib/perlglossary.pod Perl Glossary cpan/PerlIO-via-QuotedPrint/lib/PerlIO/via/QuotedPrint.pm PerlIO::via::QuotedPrint +cpan/PerlIO-via-QuotedPrint/t/changes.t +cpan/PerlIO-via-QuotedPrint/t/critic.t +cpan/PerlIO-via-QuotedPrint/t/pod.t +cpan/PerlIO-via-QuotedPrint/t/pod_coverage.t cpan/PerlIO-via-QuotedPrint/t/QuotedPrint.t PerlIO::via::QuotedPrint cpan/Pod-Checker/lib/Pod/Checker.pm cpan/Pod-Checker/scripts/podchecker.PL @@ -2396,6 +2404,7 @@ cpan/Test-Simple/t/Legacy/Regression/6_cmp_ok.t cpan/Test-Simple/t/Legacy/Regression/736_use_ok.t cpan/Test-Simple/t/Legacy/Regression/789-read-only.t cpan/Test-Simple/t/Legacy/Regression/870-experimental-warnings.t +cpan/Test-Simple/t/Legacy/Regression/is_capture.t cpan/Test-Simple/t/Legacy/require_ok.t cpan/Test-Simple/t/Legacy/run_test.t cpan/Test-Simple/t/Legacy/simple.t @@ -2581,6 +2590,11 @@ cpan/Text-Balanced/t/06_extqlk.t See if Text::Balanced works cpan/Text-Balanced/t/07_exttag.t See if Text::Balanced works cpan/Text-Balanced/t/08_extvar.t See if Text::Balanced works cpan/Text-Balanced/t/09_gentag.t See if Text::Balanced works +cpan/Text-Balanced/t/94_changes.t +cpan/Text-Balanced/t/95_critic.t +cpan/Text-Balanced/t/96_pmv.t +cpan/Text-Balanced/t/97_pod.t +cpan/Text-Balanced/t/98_pod_coverage.t cpan/Text-ParseWords/lib/Text/ParseWords.pm Perl module to split words on arbitrary delimiter cpan/Text-ParseWords/t/ParseWords.t See if Text::ParseWords works cpan/Text-ParseWords/t/taint.t See if Text::ParseWords works with tainting @@ -3703,6 +3717,7 @@ dist/IO/t/io_pipe.t See if pipe()-related methods from IO work dist/IO/t/io_poll.t See if poll()-related methods from IO work dist/IO/t/io_sel.t See if select()-related methods from IO work dist/IO/t/io_sock.t See if INET socket-related methods from IO work +dist/IO/t/io_sock_errstr.t See if socket constructors put error string in the right place dist/IO/t/io_taint.t See if the untaint method from IO works dist/IO/t/io_tell.t See if seek()/tell()-related methods from IO work dist/IO/t/io_udp.t See if UDP socket-related methods from IO work @@ -4207,8 +4222,10 @@ ext/GDBM_File/GDBM_File.pm GDBM extension Perl module ext/GDBM_File/GDBM_File.xs GDBM extension external subroutines ext/GDBM_File/hints/sco.pl Hint for GDBM_File for named architecture ext/GDBM_File/Makefile.PL GDBM extension makefile writer +ext/GDBM_File/t/count.t Test if the count method works ext/GDBM_File/t/fatal.t Test the fatal_func argument to gdbm_open ext/GDBM_File/t/gdbm.t See if GDBM_File works +ext/GDBM_File/t/opt.t Test if gdbm_setopt and derived methods work ext/GDBM_File/typemap GDBM extension interface types ext/Hash-Util/Changes Change history of Hash::Util ext/Hash-Util/lib/Hash/Util.pm Hash::Util @@ -4350,6 +4367,7 @@ ext/POSIX/Makefile.PL POSIX extension makefile writer ext/POSIX/POSIX.xs POSIX extension external subroutines ext/POSIX/t/export.t Test @EXPORT and @EXPORT_OK ext/POSIX/t/iscrash See if POSIX isxxx() crashes with threads on Win32 +ext/POSIX/t/iv_const.t See if integer constants of POSIX are IV ext/POSIX/t/math.t Basic math tests for POSIX ext/POSIX/t/mb.t Multibyte function tests for POSIX ext/POSIX/t/posix.t See if POSIX works @@ -5209,10 +5227,14 @@ pod/perl5301delta.pod Perl changes in version 5.30.1 pod/perl5302delta.pod Perl changes in version 5.30.2 pod/perl5303delta.pod Perl changes in version 5.30.3 pod/perl5320delta.pod Perl changes in version 5.32.0 +pod/perl5321delta.pod Perl changes in version 5.32.1 pod/perl5330delta.pod Perl changes in version 5.33.0 pod/perl5331delta.pod Perl changes in version 5.33.1 pod/perl5332delta.pod Perl changes in version 5.33.2 pod/perl5333delta.pod Perl changes in version 5.33.3 +pod/perl5334delta.pod Perl changes in version 5.33.4 +pod/perl5335delta.pod Perl changes in version 5.33.5 +pod/perl5336delta.pod Perl changes in version 5.33.6 pod/perl561delta.pod Perl changes in version 5.6.1 pod/perl56delta.pod Perl changes in version 5.6 pod/perl581delta.pod Perl changes in version 5.8.1 @@ -5242,6 +5264,7 @@ pod/perldebug.pod Perl debugging pod/perldelta.pod Perl changes since previous version pod/perldeprecation.pod Perl deprecations pod/perldiag.pod Perl diagnostic messages +pod/perldocstyle.pod Perl style guide for core docs pod/perldsc.pod Perl data structures intro pod/perldtrace.pod Perl's support for DTrace pod/perlebcdic.pod Considerations for running Perl on EBCDIC platforms @@ -5252,6 +5275,7 @@ pod/perlfork.pod Perl fork() information pod/perlform.pod Perl formats pod/perlfunc.pod Perl built-in functions pod/perlgit.pod Using git with the Perl repository +pod/perlgov.pod Perl Rules of Governance pod/perlgpl.pod GNU General Public License pod/perlguts.pod Perl internal functions for those doing extensions pod/perlhack.pod Perl hackers guide @@ -5336,7 +5360,6 @@ Porting/checkcfgvar.pl Check that config scripts define all symbols Porting/checkpodencoding.pl Check POD encoding Porting/checkURL.pl Check whether we have working URLs Porting/checkVERSION.pl Check whether we have $VERSIONs -Porting/cherrymaint Command line tool for updating cherrymaint Porting/cmpVERSION.pl Compare whether two trees have changed modules Porting/config.sh Sample config.sh Porting/config_H Sample config.h @@ -5556,6 +5579,7 @@ t/io/inplace.t See if inplace editing works t/io/iofile.t See if we can load IO::File on demand t/io/iprefix.t See if inplace editing works with prefixes t/io/layers.t See if PerlIO layers work +t/io/msg.t See if SysV message queues work t/io/nargv.t See if nested ARGV stuff works t/io/open.t See if open works t/io/openpid.t See if open works for subprocesses @@ -5604,6 +5628,7 @@ t/lib/Devel/nodb.pm Module for t/run/switchd.t t/lib/Devel/switchd.pm Module for t/run/switchd.t t/lib/Devel/switchd_empty.pm Module for t/run/switchd.t t/lib/Devel/switchd_goto.pm Module for t/run/switchd.t +t/lib/feature/bareword_filehandles Tests for enabling/disabling bareword_filehandles feature t/lib/feature/bits Tests for feature bit handling t/lib/feature/bundle Tests for feature bundles t/lib/feature/implicit Tests for implicit loading of feature.pm @@ -5936,6 +5961,7 @@ t/op/time.t See if time functions work t/op/time_loop.t Test that very large values don't hang gmtime and localtime. t/op/tr.t See if tr works t/op/tr_latin1.t See if tr works, but file isn't encoded in UTF-8 +t/op/try.t See if try works t/op/undef.t See if undef works t/op/universal.t See if UNIVERSAL class works t/op/unlink.t See if unlink works @@ -6022,6 +6048,7 @@ t/re/fold_grind_T.t Wrapper for fold_grind.pl for /l testing with a Turkic loca t/re/fold_grind_u.t Wrapper for fold_grind.pl for /u testing t/re/keep_tabs.t Tests where \t can't be expanded. t/re/no_utf8_pm.t Verify utf8.pm doesn't get loaded unless required +t/re/opt.t Test regexp optimizations t/re/overload.t Test against string corruption in pattern matches on overloaded objects t/re/pat.t See if esoteric patterns work t/re/pat_advanced.t See if advanced esoteric patterns work @@ -6161,6 +6188,8 @@ t/win32/fs.t Test Win32 link for compatibility t/win32/popen.t Test for stdout races in backticks, etc t/win32/runenv.t Test if Win* perl honors its env variables t/win32/signal.t Test Win32 signal emulation +t/win32/stat.t Test Win32 stat emulation +t/win32/symlink.t Test Win32 symlink t/win32/system.t See if system works in Win* t/win32/system_tests Test runner for system.t taint.c Tainting code @@ -6252,7 +6281,6 @@ win32/include/sys/errno2.h Win32 port win32/include/sys/socket.h Win32 port win32/list_static_libs.pl prints libraries for static linking win32/Makefile Win32 makefile for NMAKE (Visual C++ build) -win32/makefile.mk Win32 makefile for DMAKE (BC++, VC++ builds) win32/perlexe.ico perlexe.ico image file win32/perlexe.manifest Assembly manifest file win32/perlexe.rc associated perl binary with icon diff --git a/META.json b/META.json index 96936940c538..38066d80acc5 100644 --- a/META.json +++ b/META.json @@ -96,6 +96,7 @@ "dist/IO/t/io_poll.t", "dist/IO/t/io_sel.t", "dist/IO/t/io_sock.t", + "dist/IO/t/io_sock_errstr.t", "dist/IO/t/io_taint.t", "dist/IO/t/io_tell.t", "dist/IO/t/io_udp.t", @@ -130,6 +131,6 @@ "url" : "https://github.com/Perl/perl5" } }, - "version" : "5.033004", + "version" : "5.033007", "x_serialization_backend" : "JSON::PP version 4.05" } diff --git a/META.yml b/META.yml index 0f588acf59b6..6d35ec7eb083 100644 --- a/META.yml +++ b/META.yml @@ -93,6 +93,7 @@ no_index: - dist/IO/t/io_poll.t - dist/IO/t/io_sel.t - dist/IO/t/io_sock.t + - dist/IO/t/io_sock_errstr.t - dist/IO/t/io_taint.t - dist/IO/t/io_tell.t - dist/IO/t/io_udp.t @@ -117,5 +118,5 @@ resources: homepage: https://www.perl.org/ license: https://dev.perl.org/licenses/ repository: https://github.com/Perl/perl5 -version: '5.033004' +version: '5.033007' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' diff --git a/Makefile.SH b/Makefile.SH index 1c40b75abad8..7ff2b144f670 100755 --- a/Makefile.SH +++ b/Makefile.SH @@ -589,7 +589,7 @@ esac $spitshell >>$Makefile <<'!NO!SUBS!' -perltoc_pod_prereqs = extra.pods pod/perl5334delta.pod pod/perlapi.pod pod/perlintern.pod pod/perlmodlib.pod pod/perluniprops.pod +perltoc_pod_prereqs = extra.pods pod/perl5337delta.pod pod/perlapi.pod pod/perlintern.pod pod/perlmodlib.pod pod/perluniprops.pod generated_pods = pod/perltoc.pod $(perltoc_pod_prereqs) generated_headers = uudmap.h bitcount.h mg_data.h @@ -1153,9 +1153,9 @@ pod/perlintern.pod: $(MINIPERL_EXE) autodoc.pl embed.fnc pod/perlmodlib.pod: $(MINIPERL_EXE) pod/perlmodlib.PL MANIFEST $(MINIPERL) pod/perlmodlib.PL -q -pod/perl5334delta.pod: pod/perldelta.pod - $(RMS) pod/perl5334delta.pod - $(LNS) perldelta.pod pod/perl5334delta.pod +pod/perl5337delta.pod: pod/perldelta.pod + $(RMS) pod/perl5337delta.pod + $(LNS) perldelta.pod pod/perl5337delta.pod extra.pods: $(MINIPERL_EXE) -@test ! -f extra.pods || rm -f `cat extra.pods` diff --git a/NetWare/CLIBstuf.c b/NetWare/CLIBstuf.c index 26a4a4b50228..f0e58b14b949 100644 --- a/NetWare/CLIBstuf.c +++ b/NetWare/CLIBstuf.c @@ -33,119 +33,119 @@ void ImportFromCLIB (unsigned int nlmHandle, void** psymbol, char* symbolName) { - *psymbol = ImportSymbol(nlmHandle, symbolName); - if (*psymbol == NULL) - { - ConsolePrintf("Symbol %s not found, unable to continue\n", symbolName); - exit(1); - } + *psymbol = ImportSymbol(nlmHandle, symbolName); + if (*psymbol == NULL) + { + ConsolePrintf("Symbol %s not found, unable to continue\n", symbolName); + exit(1); + } } void fnInitGpfGlobals(void) { - unsigned int nlmHandle = GetNLMHandle(); - - ImportFromCLIB(nlmHandle, &gpf___get_stdin, "__get_stdin"); - ImportFromCLIB(nlmHandle, &gpf___get_stdout, "__get_stdout"); - ImportFromCLIB(nlmHandle, &gpf___get_stderr, "__get_stderr"); - ImportFromCLIB(nlmHandle, &gpf_clearerr, "clearerr"); - ImportFromCLIB(nlmHandle, &gpf_fclose, "fclose"); - ImportFromCLIB(nlmHandle, &gpf_feof, "feof"); - ImportFromCLIB(nlmHandle, &gpf_ferror, "ferror"); - ImportFromCLIB(nlmHandle, &gpf_fflush, "fflush"); - ImportFromCLIB(nlmHandle, &gpf_fgetc, "fgetc"); - ImportFromCLIB(nlmHandle, &gpf_fgetpos, "fgetpos"); - ImportFromCLIB(nlmHandle, &gpf_fgets, "fgets"); - ImportFromCLIB(nlmHandle, &gpf_fopen, "fopen"); - ImportFromCLIB(nlmHandle, &gpf_fputc, "fputc"); - ImportFromCLIB(nlmHandle, &gpf_fputs, "fputs"); - ImportFromCLIB(nlmHandle, &gpf_fread, "fread"); - ImportFromCLIB(nlmHandle, &gpf_freopen, "freopen"); - ImportFromCLIB(nlmHandle, &gpf_fscanf, "fscanf"); - ImportFromCLIB(nlmHandle, &gpf_fseek, "fseek"); - ImportFromCLIB(nlmHandle, &gpf_fsetpos, "fsetpos"); - ImportFromCLIB(nlmHandle, &gpf_ftell, "ftell"); - ImportFromCLIB(nlmHandle, &gpf_fwrite, "fwrite"); - ImportFromCLIB(nlmHandle, &gpf_getc, "getc"); - ImportFromCLIB(nlmHandle, &gpf_getchar, "getchar"); - ImportFromCLIB(nlmHandle, &gpf_gets, "gets"); - ImportFromCLIB(nlmHandle, &gpf_perror, "perror"); - ImportFromCLIB(nlmHandle, &gpf_putc, "putc"); - ImportFromCLIB(nlmHandle, &gpf_putchar, "putchar"); - ImportFromCLIB(nlmHandle, &gpf_puts, "puts"); - ImportFromCLIB(nlmHandle, &gpf_rename, "rename"); - ImportFromCLIB(nlmHandle, &gpf_rewind, "rewind"); - ImportFromCLIB(nlmHandle, &gpf_scanf, "scanf"); - ImportFromCLIB(nlmHandle, &gpf_setbuf, "setbuf"); - ImportFromCLIB(nlmHandle, &gpf_setvbuf, "setvbuf"); - ImportFromCLIB(nlmHandle, &gpf_sscanf, "sscanf"); - ImportFromCLIB(nlmHandle, &gpf_tmpfile, "tmpfile"); - ImportFromCLIB(nlmHandle, &gpf_tmpnam, "tmpnam"); - ImportFromCLIB(nlmHandle, &gpf_ungetc, "ungetc"); - ImportFromCLIB(nlmHandle, &gpf_vfscanf, "vfscanf"); - ImportFromCLIB(nlmHandle, &gpf_vscanf, "vscanf"); - ImportFromCLIB(nlmHandle, &gpf_vsscanf, "vsscanf"); - ImportFromCLIB(nlmHandle, &gpf_fdopen, "fdopen"); - ImportFromCLIB(nlmHandle, &gpf_fileno, "fileno"); - ImportFromCLIB(nlmHandle, &gpf_cgets, "cgets"); - ImportFromCLIB(nlmHandle, &gpf_cprintf, "cprintf"); - ImportFromCLIB(nlmHandle, &gpf_cputs, "cputs"); - ImportFromCLIB(nlmHandle, &gpf_cscanf, "cscanf"); - ImportFromCLIB(nlmHandle, &gpf_fcloseall, "fcloseall"); - ImportFromCLIB(nlmHandle, &gpf_fgetchar, "fgetchar"); - ImportFromCLIB(nlmHandle, &gpf_flushall, "flushall"); - ImportFromCLIB(nlmHandle, &gpf_fputchar, "fputchar"); - ImportFromCLIB(nlmHandle, &gpf_getch, "getch"); - ImportFromCLIB(nlmHandle, &gpf_getche, "getche"); - ImportFromCLIB(nlmHandle, &gpf_putch, "putch"); - ImportFromCLIB(nlmHandle, &gpf_ungetch, "ungetch"); - ImportFromCLIB(nlmHandle, &gpf_vcprintf, "vcprintf"); - ImportFromCLIB(nlmHandle, &gpf_vcscanf, "vcscanf"); - - ImportFromCLIB(nlmHandle, &gpf_memchr, "memchr"); - ImportFromCLIB(nlmHandle, &gpf_memcmp, "memcmp"); - ImportFromCLIB(nlmHandle, &gpf_memcpy, "memcpy"); - ImportFromCLIB(nlmHandle, &gpf_memmove, "memmove"); - ImportFromCLIB(nlmHandle, &gpf_memset, "memset"); - ImportFromCLIB(nlmHandle, &gpf_memicmp, "memicmp"); - - ImportFromCLIB(nlmHandle, &gpf_strerror, "strerror"); - ImportFromCLIB(nlmHandle, &gpf_strtok_r, "strtok_r"); - - ImportFromCLIB(nlmHandle, &gpf_strcpy, "strcpy"); - ImportFromCLIB(nlmHandle, &gpf_strcat, "strcat"); - ImportFromCLIB(nlmHandle, &gpf_strchr, "strchr"); - ImportFromCLIB(nlmHandle, &gpf_strstr, "strstr"); - ImportFromCLIB(nlmHandle, &gpf_strcoll, "strcoll"); - ImportFromCLIB(nlmHandle, &gpf_strcspn, "strcspn"); - ImportFromCLIB(nlmHandle, &gpf_strpbrk, "strpbrk"); - ImportFromCLIB(nlmHandle, &gpf_strrchr, "strrchr"); - ImportFromCLIB(nlmHandle, &gpf_strrev, "strrev"); - ImportFromCLIB(nlmHandle, &gpf_strspn, "strspn"); - ImportFromCLIB(nlmHandle, &gpf_strupr, "strupr"); - ImportFromCLIB(nlmHandle, &gpf_strxfrm, "strxfrm"); - ImportFromCLIB(nlmHandle, &gpf_strcmp, "strcmp"); - ImportFromCLIB(nlmHandle, &gpf_stricmp, "stricmp"); - ImportFromCLIB(nlmHandle, &gpf_strtok, "strtok"); - ImportFromCLIB(nlmHandle, &gpf_strlen, "strlen"); - ImportFromCLIB(nlmHandle, &gpf_strncpy, "strncpy"); - ImportFromCLIB(nlmHandle, &gpf_strncat, "strncat"); - ImportFromCLIB(nlmHandle, &gpf_strncmp, "strncmp"); - ImportFromCLIB(nlmHandle, &gpf_strcmpi, "strcmpi"); - ImportFromCLIB(nlmHandle, &gpf_strnicmp, "strnicmp"); - ImportFromCLIB(nlmHandle, &gpf_strdup, "strdup"); - ImportFromCLIB(nlmHandle, &gpf_strlist, "strlist"); - ImportFromCLIB(nlmHandle, &gpf_strlwr, "strlwr"); - ImportFromCLIB(nlmHandle, &gpf_strnset, "strnset"); - ImportFromCLIB(nlmHandle, &gpf_strset, "strset"); - ImportFromCLIB(nlmHandle, &gpf_strtok_r, "strtok_r"); - ImportFromCLIB(nlmHandle, &gpf_printf, "printf"); - ImportFromCLIB(nlmHandle, &gpf_fprintf, "fprintf"); - ImportFromCLIB(nlmHandle, &gpf_sprintf, "sprintf"); - ImportFromCLIB(nlmHandle, &gpf_vprintf, "vprintf"); - ImportFromCLIB(nlmHandle, &gpf_vfprintf, "vfprintf"); - ImportFromCLIB(nlmHandle, &gpf_vsprintf, "vsprintf"); + unsigned int nlmHandle = GetNLMHandle(); + + ImportFromCLIB(nlmHandle, &gpf___get_stdin, "__get_stdin"); + ImportFromCLIB(nlmHandle, &gpf___get_stdout, "__get_stdout"); + ImportFromCLIB(nlmHandle, &gpf___get_stderr, "__get_stderr"); + ImportFromCLIB(nlmHandle, &gpf_clearerr, "clearerr"); + ImportFromCLIB(nlmHandle, &gpf_fclose, "fclose"); + ImportFromCLIB(nlmHandle, &gpf_feof, "feof"); + ImportFromCLIB(nlmHandle, &gpf_ferror, "ferror"); + ImportFromCLIB(nlmHandle, &gpf_fflush, "fflush"); + ImportFromCLIB(nlmHandle, &gpf_fgetc, "fgetc"); + ImportFromCLIB(nlmHandle, &gpf_fgetpos, "fgetpos"); + ImportFromCLIB(nlmHandle, &gpf_fgets, "fgets"); + ImportFromCLIB(nlmHandle, &gpf_fopen, "fopen"); + ImportFromCLIB(nlmHandle, &gpf_fputc, "fputc"); + ImportFromCLIB(nlmHandle, &gpf_fputs, "fputs"); + ImportFromCLIB(nlmHandle, &gpf_fread, "fread"); + ImportFromCLIB(nlmHandle, &gpf_freopen, "freopen"); + ImportFromCLIB(nlmHandle, &gpf_fscanf, "fscanf"); + ImportFromCLIB(nlmHandle, &gpf_fseek, "fseek"); + ImportFromCLIB(nlmHandle, &gpf_fsetpos, "fsetpos"); + ImportFromCLIB(nlmHandle, &gpf_ftell, "ftell"); + ImportFromCLIB(nlmHandle, &gpf_fwrite, "fwrite"); + ImportFromCLIB(nlmHandle, &gpf_getc, "getc"); + ImportFromCLIB(nlmHandle, &gpf_getchar, "getchar"); + ImportFromCLIB(nlmHandle, &gpf_gets, "gets"); + ImportFromCLIB(nlmHandle, &gpf_perror, "perror"); + ImportFromCLIB(nlmHandle, &gpf_putc, "putc"); + ImportFromCLIB(nlmHandle, &gpf_putchar, "putchar"); + ImportFromCLIB(nlmHandle, &gpf_puts, "puts"); + ImportFromCLIB(nlmHandle, &gpf_rename, "rename"); + ImportFromCLIB(nlmHandle, &gpf_rewind, "rewind"); + ImportFromCLIB(nlmHandle, &gpf_scanf, "scanf"); + ImportFromCLIB(nlmHandle, &gpf_setbuf, "setbuf"); + ImportFromCLIB(nlmHandle, &gpf_setvbuf, "setvbuf"); + ImportFromCLIB(nlmHandle, &gpf_sscanf, "sscanf"); + ImportFromCLIB(nlmHandle, &gpf_tmpfile, "tmpfile"); + ImportFromCLIB(nlmHandle, &gpf_tmpnam, "tmpnam"); + ImportFromCLIB(nlmHandle, &gpf_ungetc, "ungetc"); + ImportFromCLIB(nlmHandle, &gpf_vfscanf, "vfscanf"); + ImportFromCLIB(nlmHandle, &gpf_vscanf, "vscanf"); + ImportFromCLIB(nlmHandle, &gpf_vsscanf, "vsscanf"); + ImportFromCLIB(nlmHandle, &gpf_fdopen, "fdopen"); + ImportFromCLIB(nlmHandle, &gpf_fileno, "fileno"); + ImportFromCLIB(nlmHandle, &gpf_cgets, "cgets"); + ImportFromCLIB(nlmHandle, &gpf_cprintf, "cprintf"); + ImportFromCLIB(nlmHandle, &gpf_cputs, "cputs"); + ImportFromCLIB(nlmHandle, &gpf_cscanf, "cscanf"); + ImportFromCLIB(nlmHandle, &gpf_fcloseall, "fcloseall"); + ImportFromCLIB(nlmHandle, &gpf_fgetchar, "fgetchar"); + ImportFromCLIB(nlmHandle, &gpf_flushall, "flushall"); + ImportFromCLIB(nlmHandle, &gpf_fputchar, "fputchar"); + ImportFromCLIB(nlmHandle, &gpf_getch, "getch"); + ImportFromCLIB(nlmHandle, &gpf_getche, "getche"); + ImportFromCLIB(nlmHandle, &gpf_putch, "putch"); + ImportFromCLIB(nlmHandle, &gpf_ungetch, "ungetch"); + ImportFromCLIB(nlmHandle, &gpf_vcprintf, "vcprintf"); + ImportFromCLIB(nlmHandle, &gpf_vcscanf, "vcscanf"); + + ImportFromCLIB(nlmHandle, &gpf_memchr, "memchr"); + ImportFromCLIB(nlmHandle, &gpf_memcmp, "memcmp"); + ImportFromCLIB(nlmHandle, &gpf_memcpy, "memcpy"); + ImportFromCLIB(nlmHandle, &gpf_memmove, "memmove"); + ImportFromCLIB(nlmHandle, &gpf_memset, "memset"); + ImportFromCLIB(nlmHandle, &gpf_memicmp, "memicmp"); + + ImportFromCLIB(nlmHandle, &gpf_strerror, "strerror"); + ImportFromCLIB(nlmHandle, &gpf_strtok_r, "strtok_r"); + + ImportFromCLIB(nlmHandle, &gpf_strcpy, "strcpy"); + ImportFromCLIB(nlmHandle, &gpf_strcat, "strcat"); + ImportFromCLIB(nlmHandle, &gpf_strchr, "strchr"); + ImportFromCLIB(nlmHandle, &gpf_strstr, "strstr"); + ImportFromCLIB(nlmHandle, &gpf_strcoll, "strcoll"); + ImportFromCLIB(nlmHandle, &gpf_strcspn, "strcspn"); + ImportFromCLIB(nlmHandle, &gpf_strpbrk, "strpbrk"); + ImportFromCLIB(nlmHandle, &gpf_strrchr, "strrchr"); + ImportFromCLIB(nlmHandle, &gpf_strrev, "strrev"); + ImportFromCLIB(nlmHandle, &gpf_strspn, "strspn"); + ImportFromCLIB(nlmHandle, &gpf_strupr, "strupr"); + ImportFromCLIB(nlmHandle, &gpf_strxfrm, "strxfrm"); + ImportFromCLIB(nlmHandle, &gpf_strcmp, "strcmp"); + ImportFromCLIB(nlmHandle, &gpf_stricmp, "stricmp"); + ImportFromCLIB(nlmHandle, &gpf_strtok, "strtok"); + ImportFromCLIB(nlmHandle, &gpf_strlen, "strlen"); + ImportFromCLIB(nlmHandle, &gpf_strncpy, "strncpy"); + ImportFromCLIB(nlmHandle, &gpf_strncat, "strncat"); + ImportFromCLIB(nlmHandle, &gpf_strncmp, "strncmp"); + ImportFromCLIB(nlmHandle, &gpf_strcmpi, "strcmpi"); + ImportFromCLIB(nlmHandle, &gpf_strnicmp, "strnicmp"); + ImportFromCLIB(nlmHandle, &gpf_strdup, "strdup"); + ImportFromCLIB(nlmHandle, &gpf_strlist, "strlist"); + ImportFromCLIB(nlmHandle, &gpf_strlwr, "strlwr"); + ImportFromCLIB(nlmHandle, &gpf_strnset, "strnset"); + ImportFromCLIB(nlmHandle, &gpf_strset, "strset"); + ImportFromCLIB(nlmHandle, &gpf_strtok_r, "strtok_r"); + ImportFromCLIB(nlmHandle, &gpf_printf, "printf"); + ImportFromCLIB(nlmHandle, &gpf_fprintf, "fprintf"); + ImportFromCLIB(nlmHandle, &gpf_sprintf, "sprintf"); + ImportFromCLIB(nlmHandle, &gpf_vprintf, "vprintf"); + ImportFromCLIB(nlmHandle, &gpf_vfprintf, "vfprintf"); + ImportFromCLIB(nlmHandle, &gpf_vsprintf, "vsprintf"); } diff --git a/NetWare/Main.c b/NetWare/Main.c index 5116cbcfe1b9..4dea1dd2beb2 100644 --- a/NetWare/Main.c +++ b/NetWare/Main.c @@ -32,8 +32,8 @@ #include "clibstuf.h" #ifdef MPK_ON - #include - #include + #include + #include #endif //MPK_ON @@ -52,131 +52,131 @@ void main(void) { - fnInitGpfGlobals(); // For importing the CLIB calls in place of the Watcom calls - SynchronizeStart(); // Don't allow anything else to happen until all the symbols are imported - #ifdef MPK_ON - ExitThread(TSR_THREAD, 0); - #else - ExitThread(TSR_THREAD, 0); - #endif + fnInitGpfGlobals(); // For importing the CLIB calls in place of the Watcom calls + SynchronizeStart(); // Don't allow anything else to happen until all the symbols are imported + #ifdef MPK_ON + ExitThread(TSR_THREAD, 0); + #else + ExitThread(TSR_THREAD, 0); + #endif } void ImportFromCLIB (unsigned int nlmHandle, void** psymbol, char* symbolName) { - *psymbol = ImportSymbol(nlmHandle, symbolName); - if (*psymbol == NULL) - { - ConsolePrintf("Symbol %s not found, unable to continue\n", symbolName); - exit(1); - } + *psymbol = ImportSymbol(nlmHandle, symbolName); + if (*psymbol == NULL) + { + ConsolePrintf("Symbol %s not found, unable to continue\n", symbolName); + exit(1); + } } void fnInitGpfGlobals(void) { - unsigned int nlmHandle = GetNLMHandle(); - - ImportFromCLIB(nlmHandle, &gpf___get_stdin, "__get_stdin"); - ImportFromCLIB(nlmHandle, &gpf___get_stdout, "__get_stdout"); - ImportFromCLIB(nlmHandle, &gpf___get_stderr, "__get_stderr"); - ImportFromCLIB(nlmHandle, &gpf_clearerr, "clearerr"); - ImportFromCLIB(nlmHandle, &gpf_fclose, "fclose"); - ImportFromCLIB(nlmHandle, &gpf_feof, "feof"); - ImportFromCLIB(nlmHandle, &gpf_ferror, "ferror"); - ImportFromCLIB(nlmHandle, &gpf_fflush, "fflush"); - ImportFromCLIB(nlmHandle, &gpf_fgetc, "fgetc"); - ImportFromCLIB(nlmHandle, &gpf_fgetpos, "fgetpos"); - ImportFromCLIB(nlmHandle, &gpf_fgets, "fgets"); - ImportFromCLIB(nlmHandle, &gpf_fopen, "fopen"); - ImportFromCLIB(nlmHandle, &gpf_fputc, "fputc"); - ImportFromCLIB(nlmHandle, &gpf_fputs, "fputs"); - ImportFromCLIB(nlmHandle, &gpf_fread, "fread"); - ImportFromCLIB(nlmHandle, &gpf_freopen, "freopen"); - ImportFromCLIB(nlmHandle, &gpf_fscanf, "fscanf"); - ImportFromCLIB(nlmHandle, &gpf_fseek, "fseek"); - ImportFromCLIB(nlmHandle, &gpf_fsetpos, "fsetpos"); - ImportFromCLIB(nlmHandle, &gpf_ftell, "ftell"); - ImportFromCLIB(nlmHandle, &gpf_fwrite, "fwrite"); - ImportFromCLIB(nlmHandle, &gpf_getc, "getc"); - ImportFromCLIB(nlmHandle, &gpf_getchar, "getchar"); - ImportFromCLIB(nlmHandle, &gpf_gets, "gets"); - ImportFromCLIB(nlmHandle, &gpf_perror, "perror"); - ImportFromCLIB(nlmHandle, &gpf_putc, "putc"); - ImportFromCLIB(nlmHandle, &gpf_putchar, "putchar"); - ImportFromCLIB(nlmHandle, &gpf_puts, "puts"); - ImportFromCLIB(nlmHandle, &gpf_rename, "rename"); - ImportFromCLIB(nlmHandle, &gpf_rewind, "rewind"); - ImportFromCLIB(nlmHandle, &gpf_scanf, "scanf"); - ImportFromCLIB(nlmHandle, &gpf_setbuf, "setbuf"); - ImportFromCLIB(nlmHandle, &gpf_setvbuf, "setvbuf"); - ImportFromCLIB(nlmHandle, &gpf_sscanf, "sscanf"); - ImportFromCLIB(nlmHandle, &gpf_tmpfile, "tmpfile"); - ImportFromCLIB(nlmHandle, &gpf_tmpnam, "tmpnam"); - ImportFromCLIB(nlmHandle, &gpf_ungetc, "ungetc"); - ImportFromCLIB(nlmHandle, &gpf_vfscanf, "vfscanf"); - ImportFromCLIB(nlmHandle, &gpf_vscanf, "vscanf"); - ImportFromCLIB(nlmHandle, &gpf_vsscanf, "vsscanf"); - ImportFromCLIB(nlmHandle, &gpf_fdopen, "fdopen"); - ImportFromCLIB(nlmHandle, &gpf_fileno, "fileno"); - ImportFromCLIB(nlmHandle, &gpf_cgets, "cgets"); - ImportFromCLIB(nlmHandle, &gpf_cprintf, "cprintf"); - ImportFromCLIB(nlmHandle, &gpf_cputs, "cputs"); - ImportFromCLIB(nlmHandle, &gpf_cscanf, "cscanf"); - ImportFromCLIB(nlmHandle, &gpf_fcloseall, "fcloseall"); - ImportFromCLIB(nlmHandle, &gpf_fgetchar, "fgetchar"); - ImportFromCLIB(nlmHandle, &gpf_flushall, "flushall"); - ImportFromCLIB(nlmHandle, &gpf_fputchar, "fputchar"); - ImportFromCLIB(nlmHandle, &gpf_getch, "getch"); - ImportFromCLIB(nlmHandle, &gpf_getche, "getche"); - ImportFromCLIB(nlmHandle, &gpf_putch, "putch"); - ImportFromCLIB(nlmHandle, &gpf_ungetch, "ungetch"); - ImportFromCLIB(nlmHandle, &gpf_vcprintf, "vcprintf"); - ImportFromCLIB(nlmHandle, &gpf_vcscanf, "vcscanf"); - - ImportFromCLIB(nlmHandle, &gpf_memchr, "memchr"); - ImportFromCLIB(nlmHandle, &gpf_memcmp, "memcmp"); - ImportFromCLIB(nlmHandle, &gpf_memcpy, "memcpy"); - ImportFromCLIB(nlmHandle, &gpf_memmove, "memmove"); - ImportFromCLIB(nlmHandle, &gpf_memset, "memset"); - ImportFromCLIB(nlmHandle, &gpf_memicmp, "memicmp"); - - ImportFromCLIB(nlmHandle, &gpf_strerror, "strerror"); - ImportFromCLIB(nlmHandle, &gpf_strtok_r, "strtok_r"); - - ImportFromCLIB(nlmHandle, &gpf_strcpy, "strcpy"); - ImportFromCLIB(nlmHandle, &gpf_strcat, "strcat"); - ImportFromCLIB(nlmHandle, &gpf_strchr, "strchr"); - ImportFromCLIB(nlmHandle, &gpf_strstr, "strstr"); - ImportFromCLIB(nlmHandle, &gpf_strcoll, "strcoll"); - ImportFromCLIB(nlmHandle, &gpf_strcspn, "strcspn"); - ImportFromCLIB(nlmHandle, &gpf_strpbrk, "strpbrk"); - ImportFromCLIB(nlmHandle, &gpf_strrchr, "strrchr"); - ImportFromCLIB(nlmHandle, &gpf_strrev, "strrev"); - ImportFromCLIB(nlmHandle, &gpf_strspn, "strspn"); - ImportFromCLIB(nlmHandle, &gpf_strupr, "strupr"); - ImportFromCLIB(nlmHandle, &gpf_strxfrm, "strxfrm"); - ImportFromCLIB(nlmHandle, &gpf_strcmp, "strcmp"); - ImportFromCLIB(nlmHandle, &gpf_stricmp, "stricmp"); - ImportFromCLIB(nlmHandle, &gpf_strtok, "strtok"); - ImportFromCLIB(nlmHandle, &gpf_strlen, "strlen"); - ImportFromCLIB(nlmHandle, &gpf_strncpy, "strncpy"); - ImportFromCLIB(nlmHandle, &gpf_strncat, "strncat"); - ImportFromCLIB(nlmHandle, &gpf_strncmp, "strncmp"); - ImportFromCLIB(nlmHandle, &gpf_strcmpi, "strcmpi"); - ImportFromCLIB(nlmHandle, &gpf_strnicmp, "strnicmp"); - ImportFromCLIB(nlmHandle, &gpf_strdup, "strdup"); - ImportFromCLIB(nlmHandle, &gpf_strlist, "strlist"); - ImportFromCLIB(nlmHandle, &gpf_strlwr, "strlwr"); - ImportFromCLIB(nlmHandle, &gpf_strnset, "strnset"); - ImportFromCLIB(nlmHandle, &gpf_strset, "strset"); - ImportFromCLIB(nlmHandle, &gpf_strtok_r, "strtok_r"); - ImportFromCLIB(nlmHandle, &gpf_printf, "printf"); - ImportFromCLIB(nlmHandle, &gpf_fprintf, "fprintf"); - ImportFromCLIB(nlmHandle, &gpf_sprintf, "sprintf"); - ImportFromCLIB(nlmHandle, &gpf_vprintf, "vprintf"); - ImportFromCLIB(nlmHandle, &gpf_vfprintf, "vfprintf"); - ImportFromCLIB(nlmHandle, &gpf_vsprintf, "vsprintf"); + unsigned int nlmHandle = GetNLMHandle(); + + ImportFromCLIB(nlmHandle, &gpf___get_stdin, "__get_stdin"); + ImportFromCLIB(nlmHandle, &gpf___get_stdout, "__get_stdout"); + ImportFromCLIB(nlmHandle, &gpf___get_stderr, "__get_stderr"); + ImportFromCLIB(nlmHandle, &gpf_clearerr, "clearerr"); + ImportFromCLIB(nlmHandle, &gpf_fclose, "fclose"); + ImportFromCLIB(nlmHandle, &gpf_feof, "feof"); + ImportFromCLIB(nlmHandle, &gpf_ferror, "ferror"); + ImportFromCLIB(nlmHandle, &gpf_fflush, "fflush"); + ImportFromCLIB(nlmHandle, &gpf_fgetc, "fgetc"); + ImportFromCLIB(nlmHandle, &gpf_fgetpos, "fgetpos"); + ImportFromCLIB(nlmHandle, &gpf_fgets, "fgets"); + ImportFromCLIB(nlmHandle, &gpf_fopen, "fopen"); + ImportFromCLIB(nlmHandle, &gpf_fputc, "fputc"); + ImportFromCLIB(nlmHandle, &gpf_fputs, "fputs"); + ImportFromCLIB(nlmHandle, &gpf_fread, "fread"); + ImportFromCLIB(nlmHandle, &gpf_freopen, "freopen"); + ImportFromCLIB(nlmHandle, &gpf_fscanf, "fscanf"); + ImportFromCLIB(nlmHandle, &gpf_fseek, "fseek"); + ImportFromCLIB(nlmHandle, &gpf_fsetpos, "fsetpos"); + ImportFromCLIB(nlmHandle, &gpf_ftell, "ftell"); + ImportFromCLIB(nlmHandle, &gpf_fwrite, "fwrite"); + ImportFromCLIB(nlmHandle, &gpf_getc, "getc"); + ImportFromCLIB(nlmHandle, &gpf_getchar, "getchar"); + ImportFromCLIB(nlmHandle, &gpf_gets, "gets"); + ImportFromCLIB(nlmHandle, &gpf_perror, "perror"); + ImportFromCLIB(nlmHandle, &gpf_putc, "putc"); + ImportFromCLIB(nlmHandle, &gpf_putchar, "putchar"); + ImportFromCLIB(nlmHandle, &gpf_puts, "puts"); + ImportFromCLIB(nlmHandle, &gpf_rename, "rename"); + ImportFromCLIB(nlmHandle, &gpf_rewind, "rewind"); + ImportFromCLIB(nlmHandle, &gpf_scanf, "scanf"); + ImportFromCLIB(nlmHandle, &gpf_setbuf, "setbuf"); + ImportFromCLIB(nlmHandle, &gpf_setvbuf, "setvbuf"); + ImportFromCLIB(nlmHandle, &gpf_sscanf, "sscanf"); + ImportFromCLIB(nlmHandle, &gpf_tmpfile, "tmpfile"); + ImportFromCLIB(nlmHandle, &gpf_tmpnam, "tmpnam"); + ImportFromCLIB(nlmHandle, &gpf_ungetc, "ungetc"); + ImportFromCLIB(nlmHandle, &gpf_vfscanf, "vfscanf"); + ImportFromCLIB(nlmHandle, &gpf_vscanf, "vscanf"); + ImportFromCLIB(nlmHandle, &gpf_vsscanf, "vsscanf"); + ImportFromCLIB(nlmHandle, &gpf_fdopen, "fdopen"); + ImportFromCLIB(nlmHandle, &gpf_fileno, "fileno"); + ImportFromCLIB(nlmHandle, &gpf_cgets, "cgets"); + ImportFromCLIB(nlmHandle, &gpf_cprintf, "cprintf"); + ImportFromCLIB(nlmHandle, &gpf_cputs, "cputs"); + ImportFromCLIB(nlmHandle, &gpf_cscanf, "cscanf"); + ImportFromCLIB(nlmHandle, &gpf_fcloseall, "fcloseall"); + ImportFromCLIB(nlmHandle, &gpf_fgetchar, "fgetchar"); + ImportFromCLIB(nlmHandle, &gpf_flushall, "flushall"); + ImportFromCLIB(nlmHandle, &gpf_fputchar, "fputchar"); + ImportFromCLIB(nlmHandle, &gpf_getch, "getch"); + ImportFromCLIB(nlmHandle, &gpf_getche, "getche"); + ImportFromCLIB(nlmHandle, &gpf_putch, "putch"); + ImportFromCLIB(nlmHandle, &gpf_ungetch, "ungetch"); + ImportFromCLIB(nlmHandle, &gpf_vcprintf, "vcprintf"); + ImportFromCLIB(nlmHandle, &gpf_vcscanf, "vcscanf"); + + ImportFromCLIB(nlmHandle, &gpf_memchr, "memchr"); + ImportFromCLIB(nlmHandle, &gpf_memcmp, "memcmp"); + ImportFromCLIB(nlmHandle, &gpf_memcpy, "memcpy"); + ImportFromCLIB(nlmHandle, &gpf_memmove, "memmove"); + ImportFromCLIB(nlmHandle, &gpf_memset, "memset"); + ImportFromCLIB(nlmHandle, &gpf_memicmp, "memicmp"); + + ImportFromCLIB(nlmHandle, &gpf_strerror, "strerror"); + ImportFromCLIB(nlmHandle, &gpf_strtok_r, "strtok_r"); + + ImportFromCLIB(nlmHandle, &gpf_strcpy, "strcpy"); + ImportFromCLIB(nlmHandle, &gpf_strcat, "strcat"); + ImportFromCLIB(nlmHandle, &gpf_strchr, "strchr"); + ImportFromCLIB(nlmHandle, &gpf_strstr, "strstr"); + ImportFromCLIB(nlmHandle, &gpf_strcoll, "strcoll"); + ImportFromCLIB(nlmHandle, &gpf_strcspn, "strcspn"); + ImportFromCLIB(nlmHandle, &gpf_strpbrk, "strpbrk"); + ImportFromCLIB(nlmHandle, &gpf_strrchr, "strrchr"); + ImportFromCLIB(nlmHandle, &gpf_strrev, "strrev"); + ImportFromCLIB(nlmHandle, &gpf_strspn, "strspn"); + ImportFromCLIB(nlmHandle, &gpf_strupr, "strupr"); + ImportFromCLIB(nlmHandle, &gpf_strxfrm, "strxfrm"); + ImportFromCLIB(nlmHandle, &gpf_strcmp, "strcmp"); + ImportFromCLIB(nlmHandle, &gpf_stricmp, "stricmp"); + ImportFromCLIB(nlmHandle, &gpf_strtok, "strtok"); + ImportFromCLIB(nlmHandle, &gpf_strlen, "strlen"); + ImportFromCLIB(nlmHandle, &gpf_strncpy, "strncpy"); + ImportFromCLIB(nlmHandle, &gpf_strncat, "strncat"); + ImportFromCLIB(nlmHandle, &gpf_strncmp, "strncmp"); + ImportFromCLIB(nlmHandle, &gpf_strcmpi, "strcmpi"); + ImportFromCLIB(nlmHandle, &gpf_strnicmp, "strnicmp"); + ImportFromCLIB(nlmHandle, &gpf_strdup, "strdup"); + ImportFromCLIB(nlmHandle, &gpf_strlist, "strlist"); + ImportFromCLIB(nlmHandle, &gpf_strlwr, "strlwr"); + ImportFromCLIB(nlmHandle, &gpf_strnset, "strnset"); + ImportFromCLIB(nlmHandle, &gpf_strset, "strset"); + ImportFromCLIB(nlmHandle, &gpf_strtok_r, "strtok_r"); + ImportFromCLIB(nlmHandle, &gpf_printf, "printf"); + ImportFromCLIB(nlmHandle, &gpf_fprintf, "fprintf"); + ImportFromCLIB(nlmHandle, &gpf_sprintf, "sprintf"); + ImportFromCLIB(nlmHandle, &gpf_vprintf, "vprintf"); + ImportFromCLIB(nlmHandle, &gpf_vfprintf, "vfprintf"); + ImportFromCLIB(nlmHandle, &gpf_vsprintf, "vsprintf"); } diff --git a/NetWare/Makefile b/NetWare/Makefile index 9425c0ac7ae3..8544240e407e 100644 --- a/NetWare/Makefile +++ b/NetWare/Makefile @@ -86,7 +86,7 @@ NLM_VERSION = 3,20,0 # Here comes the CW tools - TO BE FILLED TO BUILD WITH CW - -MODULE_DESC = "Perl 5.33.4 for NetWare" +MODULE_DESC = "Perl 5.33.7 for NetWare" CCTYPE = CodeWarrior C_COMPILER = mwccnlm -c CPP_COMPILER = mwccnlm @@ -462,7 +462,7 @@ INST_NW_TOP2 = $(INST_NW_DRV)\perl # versioned installation can be obtained by setting INST_TOP above to a # path that includes an arbitrary version string. # -INST_VER = \5.33.4 +INST_VER = \5.33.7 # # Comment this out if you DON'T want your perl installation to have diff --git a/NetWare/NWTInfo.c b/NetWare/NWTInfo.c index b057d56b2ad8..a1221e703c56 100644 --- a/NetWare/NWTInfo.c +++ b/NetWare/NWTInfo.c @@ -23,10 +23,10 @@ #include "nwtinfo.h" #ifdef MPK_ON - #include - #include + #include + #include #else - #include + #include #endif //MPK_ON // Number of entries in the hashtable @@ -42,11 +42,11 @@ // Semaphore to control access to global linked list // #ifdef MPK_ON - static SEMAPHORE g_tinfoSem = NULL; - static SEMAPHORE g_tCtxSem = NULL; + static SEMAPHORE g_tinfoSem = NULL; + static SEMAPHORE g_tCtxSem = NULL; #else - static LONG g_tinfoSem = 0L; - static LONG g_tCtxSem = 0L; + static LONG g_tinfoSem = 0L; + static LONG g_tCtxSem = 0L; #endif //MPK_ON // Hash table of thread information structures @@ -70,37 +70,37 @@ ThreadContext* g_ThreadCtx; BOOL fnTerminateThreadInfo(void) { - int index = 0; - - if (g_tinfoSem) - { - #ifdef MPK_ON - kSemaphoreWait(g_tinfoSem); - #else - WaitOnLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - for (index = 0; index < NUM_ENTRIES; index++) - { - if (g_ThreadInfo[index] != NULL) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tinfoSem); - #else - SignalLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - return FALSE; - } - } - #ifdef MPK_ON - kSemaphoreFree(g_tinfoSem); - g_tinfoSem = NULL; - #else - CloseLocalSemaphore(g_tinfoSem); - g_tinfoSem = 0; - #endif //MPK_ON - } - - return TRUE; + int index = 0; + + if (g_tinfoSem) + { + #ifdef MPK_ON + kSemaphoreWait(g_tinfoSem); + #else + WaitOnLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + for (index = 0; index < NUM_ENTRIES; index++) + { + if (g_ThreadInfo[index] != NULL) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tinfoSem); + #else + SignalLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + return FALSE; + } + } + #ifdef MPK_ON + kSemaphoreFree(g_tinfoSem); + g_tinfoSem = NULL; + #else + CloseLocalSemaphore(g_tinfoSem); + g_tinfoSem = 0; + #endif //MPK_ON + } + + return TRUE; } @@ -109,7 +109,7 @@ BOOL fnTerminateThreadInfo(void) Function : fnInitializeThreadInfo Description : Initializes the global ThreadInfo hashtable and semaphore. - Call once per NLM instance + Call once per NLM instance Parameters : None. @@ -119,22 +119,22 @@ BOOL fnTerminateThreadInfo(void) void fnInitializeThreadInfo(void) { - int index = 0; + int index = 0; - if (g_tinfoSem) - return; + if (g_tinfoSem) + return; - #ifdef MPK_ON - g_tinfoSem = kSemaphoreAlloc((BYTE *)"threadInfo", 1); - #else - g_tinfoSem = OpenLocalSemaphore(1); - #endif //MPK_ON - + #ifdef MPK_ON + g_tinfoSem = kSemaphoreAlloc((BYTE *)"threadInfo", 1); + #else + g_tinfoSem = OpenLocalSemaphore(1); + #endif //MPK_ON + - for (index = 0; index < NUM_ENTRIES; index++) - g_ThreadInfo[index] = NULL; + for (index = 0; index < NUM_ENTRIES; index++) + g_ThreadInfo[index] = NULL; - return; + return; } @@ -152,18 +152,18 @@ void fnInitializeThreadInfo(void) BOOL fnRegisterWithThreadTable(void) { - ThreadInfo* tinfo = NULL; - - #ifdef MPK_ON - tinfo = fnAddThreadInfo(labs((int)kCurrentThread())); - #else - tinfo = fnAddThreadInfo(GetThreadID()); - #endif //MPK_ON - - if (!tinfo) - return FALSE; - else - return TRUE; + ThreadInfo* tinfo = NULL; + + #ifdef MPK_ON + tinfo = fnAddThreadInfo(labs((int)kCurrentThread())); + #else + tinfo = fnAddThreadInfo(GetThreadID()); + #endif //MPK_ON + + if (!tinfo) + return FALSE; + else + return TRUE; } @@ -181,11 +181,11 @@ BOOL fnRegisterWithThreadTable(void) BOOL fnUnregisterWithThreadTable(void) { - #ifdef MPK_ON - return fnRemoveThreadInfo(labs((int)kCurrentThread())); - #else - return fnRemoveThreadInfo(GetThreadID()); - #endif //MPK_ON + #ifdef MPK_ON + return fnRemoveThreadInfo(labs((int)kCurrentThread())); + #else + return fnRemoveThreadInfo(GetThreadID()); + #endif //MPK_ON } @@ -203,50 +203,50 @@ BOOL fnUnregisterWithThreadTable(void) ThreadInfo* fnAddThreadInfo(int tid) { - ThreadInfo* tip = NULL; - int index = 0; - - if (g_tinfoSem) - { - #ifdef MPK_ON - kSemaphoreWait(g_tinfoSem); - #else - WaitOnLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - } - - // Add a new one to the beginning of the hash entry - // - tip = (ThreadInfo *) malloc(sizeof(ThreadInfo)); - if (tip == NULL) - { - if (g_tinfoSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tinfoSem); - #else - SignalLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - } - return NULL; - } - index = INDEXOF(tid); // just take the bottom five bits - tip->next = g_ThreadInfo[index]; - tip->tid = tid; - tip->m_dontTouchHashLists = FALSE; - tip->m_allocList = NULL; - - g_ThreadInfo [index] = tip; - if (g_tinfoSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tinfoSem); - #else - SignalLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - } - - return tip; + ThreadInfo* tip = NULL; + int index = 0; + + if (g_tinfoSem) + { + #ifdef MPK_ON + kSemaphoreWait(g_tinfoSem); + #else + WaitOnLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + } + + // Add a new one to the beginning of the hash entry + // + tip = (ThreadInfo *) malloc(sizeof(ThreadInfo)); + if (tip == NULL) + { + if (g_tinfoSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tinfoSem); + #else + SignalLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + } + return NULL; + } + index = INDEXOF(tid); // just take the bottom five bits + tip->next = g_ThreadInfo[index]; + tip->tid = tid; + tip->m_dontTouchHashLists = FALSE; + tip->m_allocList = NULL; + + g_ThreadInfo [index] = tip; + if (g_tinfoSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tinfoSem); + #else + SignalLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + } + + return tip; } @@ -255,7 +255,7 @@ ThreadInfo* fnAddThreadInfo(int tid) Function : fnRemoveThreadInfo Description : Frees the specified thread info structure and removes it from the - global linked list. + global linked list. Parameters : tid (IN) - ID of the thread. @@ -265,54 +265,54 @@ ThreadInfo* fnAddThreadInfo(int tid) BOOL fnRemoveThreadInfo(int tid) { - ThreadInfo* tip = NULL; - ThreadInfo* prevt = NULL; - int index = INDEXOF(tid); // just take the bottom five bits - - if (g_tinfoSem) - { - #ifdef MPK_ON - kSemaphoreWait(g_tinfoSem); - #else - WaitOnLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - } - - for (tip = g_ThreadInfo[index]; tip != NULL; tip = tip->next) - { - if (tip->tid == tid) - { - if (prevt == NULL) - g_ThreadInfo[index] = tip->next; - else - prevt->next = tip->next; - - free(tip); - tip=NULL; - if (g_tinfoSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tinfoSem); - #else - SignalLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - } - - return TRUE; - } - prevt = tip; - } - - if (g_tinfoSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tinfoSem); - #else - SignalLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - } - - return FALSE; // entry not found + ThreadInfo* tip = NULL; + ThreadInfo* prevt = NULL; + int index = INDEXOF(tid); // just take the bottom five bits + + if (g_tinfoSem) + { + #ifdef MPK_ON + kSemaphoreWait(g_tinfoSem); + #else + WaitOnLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + } + + for (tip = g_ThreadInfo[index]; tip != NULL; tip = tip->next) + { + if (tip->tid == tid) + { + if (prevt == NULL) + g_ThreadInfo[index] = tip->next; + else + prevt->next = tip->next; + + free(tip); + tip=NULL; + if (g_tinfoSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tinfoSem); + #else + SignalLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + } + + return TRUE; + } + prevt = tip; + } + + if (g_tinfoSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tinfoSem); + #else + SignalLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + } + + return FALSE; // entry not found } @@ -330,153 +330,153 @@ BOOL fnRemoveThreadInfo(int tid) ThreadInfo* fnGetThreadInfo(int tid) { - ThreadInfo* tip; - int index = INDEXOF(tid); // just take the bottom five bits - - if (g_tinfoSem) { - #ifdef MPK_ON - kSemaphoreWait(g_tinfoSem); - #else - WaitOnLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - } - - // see if this is already in the table at the index'th offset - // - for (tip = g_ThreadInfo[index]; tip != NULL; tip = tip->next) - { - if (tip->tid == tid) - { - if (g_tinfoSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tinfoSem); - #else - SignalLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - } - return tip; - } - } - - if (g_tinfoSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tinfoSem); - #else - SignalLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - } - - return NULL; + ThreadInfo* tip; + int index = INDEXOF(tid); // just take the bottom five bits + + if (g_tinfoSem) { + #ifdef MPK_ON + kSemaphoreWait(g_tinfoSem); + #else + WaitOnLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + } + + // see if this is already in the table at the index'th offset + // + for (tip = g_ThreadInfo[index]; tip != NULL; tip = tip->next) + { + if (tip->tid == tid) + { + if (g_tinfoSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tinfoSem); + #else + SignalLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + } + return tip; + } + } + + if (g_tinfoSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tinfoSem); + #else + SignalLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + } + + return NULL; } BOOL fnInsertHashListAddrs(void *addrs, BOOL dontTouchHashList) { - ThreadInfo* tip; - int index,tid; - - if (g_tinfoSem) - { - #ifdef MPK_ON - kSemaphoreWait(g_tinfoSem); - #else - WaitOnLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - } - - #ifdef MPK_ON - tid=index = abs(kCurrentThread()); - #else - tid=index = GetThreadID(); - #endif //MPK_ON - - index = INDEXOF(index); // just take the bottom five bits - - // see if this is already in the table at the index'th offset - // - for (tip = g_ThreadInfo[index]; tip != NULL; tip = tip->next) - { - if (tip->tid == tid) - { - if (g_tinfoSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tinfoSem); - #else - SignalLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - } - tip->m_allocList = addrs; - tip->m_dontTouchHashLists = dontTouchHashList; - return TRUE; - } - } - - if (g_tinfoSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tinfoSem); - #else - SignalLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - } - - return FALSE; + ThreadInfo* tip; + int index,tid; + + if (g_tinfoSem) + { + #ifdef MPK_ON + kSemaphoreWait(g_tinfoSem); + #else + WaitOnLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + } + + #ifdef MPK_ON + tid=index = abs(kCurrentThread()); + #else + tid=index = GetThreadID(); + #endif //MPK_ON + + index = INDEXOF(index); // just take the bottom five bits + + // see if this is already in the table at the index'th offset + // + for (tip = g_ThreadInfo[index]; tip != NULL; tip = tip->next) + { + if (tip->tid == tid) + { + if (g_tinfoSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tinfoSem); + #else + SignalLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + } + tip->m_allocList = addrs; + tip->m_dontTouchHashLists = dontTouchHashList; + return TRUE; + } + } + + if (g_tinfoSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tinfoSem); + #else + SignalLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + } + + return FALSE; } BOOL fnGetHashListAddrs(void **addrs, BOOL *dontTouchHashList) { - ThreadInfo* tip; - int index,tid; - - if (g_tinfoSem) - { - #ifdef MPK_ON - kSemaphoreWait(g_tinfoSem); - #else - WaitOnLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - } - - #ifdef MPK_ON - tid=index = abs(kCurrentThread()); - #else - tid=index = GetThreadID(); - #endif //MPK_ON - - index = INDEXOF(index); // just take the bottom five bits - - // see if this is already in the table at the index'th offset - // - for (tip = g_ThreadInfo[index]; tip != NULL; tip = tip->next) - { - if (tip->tid == tid) - { - if (g_tinfoSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tinfoSem); - #else - SignalLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - } - *addrs = tip->m_allocList; - *dontTouchHashList = tip->m_dontTouchHashLists; - return TRUE; - } - } - - if (g_tinfoSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tinfoSem); - #else - SignalLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - } - - return FALSE; + ThreadInfo* tip; + int index,tid; + + if (g_tinfoSem) + { + #ifdef MPK_ON + kSemaphoreWait(g_tinfoSem); + #else + WaitOnLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + } + + #ifdef MPK_ON + tid=index = abs(kCurrentThread()); + #else + tid=index = GetThreadID(); + #endif //MPK_ON + + index = INDEXOF(index); // just take the bottom five bits + + // see if this is already in the table at the index'th offset + // + for (tip = g_ThreadInfo[index]; tip != NULL; tip = tip->next) + { + if (tip->tid == tid) + { + if (g_tinfoSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tinfoSem); + #else + SignalLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + } + *addrs = tip->m_allocList; + *dontTouchHashList = tip->m_dontTouchHashLists; + return TRUE; + } + } + + if (g_tinfoSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tinfoSem); + #else + SignalLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + } + + return FALSE; } @@ -494,20 +494,20 @@ BOOL fnGetHashListAddrs(void **addrs, BOOL *dontTouchHashList) long fnInitializeThreadCtx(void) { - int index = 0; - //long tid; + int index = 0; + //long tid; - if (!g_tCtxSem) { - #ifdef MPK_ON - g_tCtxSem = kSemaphoreAlloc((BYTE *)"threadCtx", 1); - #else - g_tCtxSem = OpenLocalSemaphore(1); - #endif //MPK_ON + if (!g_tCtxSem) { + #ifdef MPK_ON + g_tCtxSem = kSemaphoreAlloc((BYTE *)"threadCtx", 1); + #else + g_tCtxSem = OpenLocalSemaphore(1); + #endif //MPK_ON - g_ThreadCtx =NULL; - } + g_ThreadCtx =NULL; + } - return 0l; + return 0l; } @@ -518,7 +518,7 @@ long fnInitializeThreadCtx(void) Description : Add a new thread context. Parameters : lTLSIndex (IN) - Index - t (IN) - void pointer. + t (IN) - void pointer. Returns : Pointer to ThreadContext structure. @@ -526,67 +526,67 @@ long fnInitializeThreadCtx(void) ThreadContext* fnAddThreadCtx(long lTLSIndex, void *t) { - ThreadContext* tip = NULL; - ThreadContext* temp = NULL; - - if (g_tCtxSem) - { - #ifdef MPK_ON - kSemaphoreWait(g_tCtxSem); - #else - WaitOnLocalSemaphore(g_tCtxSem); - #endif //MPK_ON - } - - // add a new one to the beginning of the list - // - tip = (ThreadContext *) malloc(sizeof(ThreadContext)); - if (tip == NULL) - { - if (g_tCtxSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tCtxSem); - #else - SignalLocalSemaphore(g_tCtxSem); - #endif //MPK_ON - } - return NULL; - } - - #ifdef MPK_ON - lTLSIndex = labs(kCurrentThread()); - #else - lTLSIndex = GetThreadID(); - #endif //MPK_ON - - tip->next = NULL; - tip->tid = lTLSIndex; - tip->tInfo = t; - - if(g_ThreadCtx==NULL) { - g_ThreadCtx = tip; - } else { - int count=0; - //Traverse to the end - temp = g_ThreadCtx; - while(temp->next != NULL) - { - temp = temp->next; - count++; - } - temp->next = tip; - } - - if (g_tCtxSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tCtxSem); - #else - SignalLocalSemaphore(g_tCtxSem); - #endif //MPK_ON - } - return tip; + ThreadContext* tip = NULL; + ThreadContext* temp = NULL; + + if (g_tCtxSem) + { + #ifdef MPK_ON + kSemaphoreWait(g_tCtxSem); + #else + WaitOnLocalSemaphore(g_tCtxSem); + #endif //MPK_ON + } + + // add a new one to the beginning of the list + // + tip = (ThreadContext *) malloc(sizeof(ThreadContext)); + if (tip == NULL) + { + if (g_tCtxSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tCtxSem); + #else + SignalLocalSemaphore(g_tCtxSem); + #endif //MPK_ON + } + return NULL; + } + + #ifdef MPK_ON + lTLSIndex = labs(kCurrentThread()); + #else + lTLSIndex = GetThreadID(); + #endif //MPK_ON + + tip->next = NULL; + tip->tid = lTLSIndex; + tip->tInfo = t; + + if(g_ThreadCtx==NULL) { + g_ThreadCtx = tip; + } else { + int count=0; + //Traverse to the end + temp = g_ThreadCtx; + while(temp->next != NULL) + { + temp = temp->next; + count++; + } + temp->next = tip; + } + + if (g_tCtxSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tCtxSem); + #else + SignalLocalSemaphore(g_tCtxSem); + #endif //MPK_ON + } + return tip; } @@ -604,58 +604,58 @@ ThreadContext* fnAddThreadCtx(long lTLSIndex, void *t) BOOL fnRemoveThreadCtx(long lTLSIndex) { - ThreadContext* tip = NULL; - ThreadContext* prevt = NULL; - - if (g_tCtxSem) - { - #ifdef MPK_ON - kSemaphoreWait(g_tCtxSem); - #else - WaitOnLocalSemaphore(g_tCtxSem); - #endif //MPK_ON - } - - #ifdef MPK_ON - lTLSIndex = labs(kCurrentThread()); - #else - lTLSIndex = GetThreadID(); - #endif //MPK_ON - - tip = g_ThreadCtx; - while(tip) { - if (tip->tid == lTLSIndex) { - if (prevt == NULL) - g_ThreadCtx = tip->next; - else - prevt->next = tip->next; - - free(tip); - tip=NULL; - if (g_tCtxSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tCtxSem); - #else - SignalLocalSemaphore(g_tCtxSem); - #endif //MPK_ON - } - return TRUE; - } - prevt = tip; - tip = tip->next; - } - - if (g_tCtxSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tCtxSem); - #else - SignalLocalSemaphore(g_tCtxSem); - #endif //MPK_ON - } - - return FALSE; // entry not found + ThreadContext* tip = NULL; + ThreadContext* prevt = NULL; + + if (g_tCtxSem) + { + #ifdef MPK_ON + kSemaphoreWait(g_tCtxSem); + #else + WaitOnLocalSemaphore(g_tCtxSem); + #endif //MPK_ON + } + + #ifdef MPK_ON + lTLSIndex = labs(kCurrentThread()); + #else + lTLSIndex = GetThreadID(); + #endif //MPK_ON + + tip = g_ThreadCtx; + while(tip) { + if (tip->tid == lTLSIndex) { + if (prevt == NULL) + g_ThreadCtx = tip->next; + else + prevt->next = tip->next; + + free(tip); + tip=NULL; + if (g_tCtxSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tCtxSem); + #else + SignalLocalSemaphore(g_tCtxSem); + #endif //MPK_ON + } + return TRUE; + } + prevt = tip; + tip = tip->next; + } + + if (g_tCtxSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tCtxSem); + #else + SignalLocalSemaphore(g_tCtxSem); + #endif //MPK_ON + } + + return FALSE; // entry not found } @@ -673,48 +673,48 @@ BOOL fnRemoveThreadCtx(long lTLSIndex) void* fnGetThreadCtx(long lTLSIndex) { - ThreadContext* tip; - - if (g_tCtxSem) - { - #ifdef MPK_ON - kSemaphoreWait(g_tCtxSem); - #else - WaitOnLocalSemaphore(g_tCtxSem); - #endif //MPK_ON - } - - #ifdef MPK_ON - lTLSIndex = labs(kCurrentThread()); - #else - lTLSIndex = GetThreadID(); - #endif //MPK_ON - - tip = g_ThreadCtx; - while(tip) { - if (tip->tid == lTLSIndex) { - if (g_tCtxSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tCtxSem); - #else - SignalLocalSemaphore(g_tCtxSem); - #endif //MPK_ON - } - return (tip->tInfo); - } - tip=tip->next; - } - - if (g_tCtxSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tCtxSem); - #else - SignalLocalSemaphore(g_tCtxSem); - #endif //MPK_ON - } - - return NULL; + ThreadContext* tip; + + if (g_tCtxSem) + { + #ifdef MPK_ON + kSemaphoreWait(g_tCtxSem); + #else + WaitOnLocalSemaphore(g_tCtxSem); + #endif //MPK_ON + } + + #ifdef MPK_ON + lTLSIndex = labs(kCurrentThread()); + #else + lTLSIndex = GetThreadID(); + #endif //MPK_ON + + tip = g_ThreadCtx; + while(tip) { + if (tip->tid == lTLSIndex) { + if (g_tCtxSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tCtxSem); + #else + SignalLocalSemaphore(g_tCtxSem); + #endif //MPK_ON + } + return (tip->tInfo); + } + tip=tip->next; + } + + if (g_tCtxSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tCtxSem); + #else + SignalLocalSemaphore(g_tCtxSem); + #endif //MPK_ON + } + + return NULL; } diff --git a/NetWare/NWUtil.c b/NetWare/NWUtil.c index 6d60dfbabdb5..bb39971f5626 100644 --- a/NetWare/NWUtil.c +++ b/NetWare/NWUtil.c @@ -57,7 +57,7 @@ char *s2 = NULL; // Used in fnSkipToken. Function : fnSkipWhite Description : This function skips the white space characters in the given string and - returns the resultant value. + returns the resultant value. Parameters : s (IN) - Input string. @@ -67,9 +67,9 @@ char *s2 = NULL; // Used in fnSkipToken. char *fnSkipWhite(char *s) { - while (isspace(*s)) - s++; - return s; + while (isspace(*s)) + s++; + return s; } @@ -79,10 +79,10 @@ char *fnSkipWhite(char *s) Function : fnNwGetEnvironmentStr Description : This function returns the NetWare environment string if available, - otherwise returns the supplied default value + otherwise returns the supplied default value Parameters : name (IN) - To hold the NetWare environment value. - defaultvalue (IN) - Default value. + defaultvalue (IN) - Default value. Returns : String. @@ -91,10 +91,10 @@ char *fnSkipWhite(char *s) char *fnNwGetEnvironmentStr(char *name, char *defaultvalue) { - char* ret = getenv(name); - if (ret == NULL) - ret = defaultvalue; - return ret; + char* ret = getenv(name); + if (ret == NULL) + ret = defaultvalue; + return ret; } @@ -104,11 +104,11 @@ char *fnNwGetEnvironmentStr(char *name, char *defaultvalue) Function : fnCommandLineParser Description : This function parses the command line into argc/argv style of - Number of params and array of params. + Number of params and array of params. Parameters : pclp (IN) - CommandLine structure. - commandLine (IN) - CommandLine String. - preserverQuotes (IN) - Indicates whether to preserve/copy the quotes or not. + commandLine (IN) - CommandLine String. + preserverQuotes (IN) - Indicates whether to preserve/copy the quotes or not. Returns : Nothing. @@ -116,275 +116,275 @@ char *fnNwGetEnvironmentStr(char *name, char *defaultvalue) void fnCommandLineParser(PCOMMANDLINEPARSER pclp, char * commandLine, BOOL preserveQuotes) { - char *buffer = NULL; + char *buffer = NULL; - int index = 0; - int do_delete = 1; - int i=0, j=0, k=0; + int index = 0; + int do_delete = 1; + int i=0, j=0, k=0; - // +1 makes room for the terminating NULL - buffer = (char *) malloc((strlen(commandLine) + 1) * sizeof(char)); - if (buffer == NULL) - { - pclp->m_isValid = FALSE; - return; - } + // +1 makes room for the terminating NULL + buffer = (char *) malloc((strlen(commandLine) + 1) * sizeof(char)); + if (buffer == NULL) + { + pclp->m_isValid = FALSE; + return; + } - if (preserveQuotes) - { - // No I/O redirection nor quote processing if preserveQuotes + if (preserveQuotes) + { + // No I/O redirection nor quote processing if preserveQuotes - char *s = NULL; - char *sSkippedToken = NULL; + char *s = NULL; + char *sSkippedToken = NULL; - strcpy(buffer, commandLine); - s = buffer; - s = fnSkipWhite(s); // Skip white spaces. + strcpy(buffer, commandLine); + s = buffer; + s = fnSkipWhite(s); // Skip white spaces. - s2 = s; // Update the global pointer. + s2 = s; // Update the global pointer. - pclp->sSkippedToken = (char *) malloc(MAX_DN_BYTES * sizeof(char)); - if(pclp->sSkippedToken == NULL) - { - pclp->m_isValid = FALSE; - return; - } + pclp->sSkippedToken = (char *) malloc(MAX_DN_BYTES * sizeof(char)); + if(pclp->sSkippedToken == NULL) + { + pclp->m_isValid = FALSE; + return; + } - while (*s && pclp->m_isValid) - { + while (*s && pclp->m_isValid) + { /**** // Commented since only one time malloc and free is enough as is done outside this while loop. // It is not required to do them everytime the execution comes into this while loop. // Still retained here. Remove this once things are proved to be working fine to a good confident level, - if(pclp->sSkippedToken) - { - free(pclp->sSkippedToken); - pclp->sSkippedToken = NULL; - } - - if(pclp->sSkippedToken == NULL) - { - pclp->sSkippedToken = (char *) malloc(MAX_DN_BYTES * sizeof(char)); - if(pclp->sSkippedToken == NULL) - { - pclp->m_isValid = FALSE; - return; - } - } + if(pclp->sSkippedToken) + { + free(pclp->sSkippedToken); + pclp->sSkippedToken = NULL; + } + + if(pclp->sSkippedToken == NULL) + { + pclp->sSkippedToken = (char *) malloc(MAX_DN_BYTES * sizeof(char)); + if(pclp->sSkippedToken == NULL) + { + pclp->m_isValid = FALSE; + return; + } + } ****/ - // Empty the string. - strncpy(pclp->sSkippedToken, "", (MAX_DN_BYTES * sizeof(char))); - - // s is advanced by fnSkipToken - pclp->sSkippedToken = fnSkipToken(s, pclp->sSkippedToken); // Collect the next command-line argument. - - s2 = fnSkipWhite(s2); // s2 is already updated by fnSkipToken. - s = s2; // Update the local pointer too. - - fnAppendArgument(pclp, pclp->sSkippedToken); // Append the argument into an array. - } - - if(pclp->sSkippedToken) - { - free(pclp->sSkippedToken); - pclp->sSkippedToken = NULL; - } - } - else - { - char *s = NULL; - - strcpy(buffer, commandLine); - s = buffer; - s = fnSkipWhite(s); - - s1 = s; // Update the global pointer. - - while (*s && pclp->m_isValid) - { - // s is advanced by fnScanToken - // Check for I/O redirection here, *outside* of - // fnScanToken(), so that quote-protected angle - // brackets do NOT cause redirection. - if (*s == '<') - { - s = fnSkipWhite(s+1); // get stdin redirection - - if(pclp->m_redirInName) - { - free(pclp->m_redirInName); - pclp->m_redirInName = NULL; - } - - if(pclp->m_redirInName == NULL) - { - pclp->m_redirInName = (char *) malloc(MAX_DN_BYTES * sizeof(char)); - if(pclp->m_redirInName == NULL) - { - pclp->m_isValid = FALSE; - return; - } - } - - // Collect the next command-line argument. - pclp->m_redirInName = fnScanToken(s, pclp->m_redirInName); - - s1 = fnSkipWhite(s1); // s1 is already updated by fnScanToken. - s = s1; // Update the local pointer too. - } - else if (*s == '>') - { - s = fnSkipWhite(s+1); //get stdout redirection - - if(pclp->m_redirOutName) - { - free(pclp->m_redirOutName); - pclp->m_redirOutName = NULL; - } - - if(pclp->m_redirOutName == NULL) - { - pclp->m_redirOutName = (char *) malloc(MAX_DN_BYTES * sizeof(char)); - if(pclp->m_redirOutName == NULL) - { - pclp->m_isValid = FALSE; - return; - } - } - - // Collect the next command-line argument. - pclp->m_redirOutName = fnScanToken(s, pclp->m_redirOutName); - - s1 = fnSkipWhite(s1); // s1 is already updated by fnScanToken. - s = s1; // Update the local pointer too. - } - else if (*s == '2' && s[1] == '>') - { - s = fnSkipWhite(s+2); // get stderr redirection - - if(pclp->m_redirErrName) - { - free(pclp->m_redirErrName); - pclp->m_redirErrName = NULL; - } - - if(pclp->m_redirErrName == NULL) - { - pclp->m_redirErrName = (char *) malloc(MAX_DN_BYTES * sizeof(char)); - if(pclp->m_redirErrName == NULL) - { - pclp->m_isValid = FALSE; - return; - } - } - - // Collect the next command-line argument. - pclp->m_redirErrName = fnScanToken(s, pclp->m_redirErrName); - - s1 = fnSkipWhite(s1); // s1 is already updated by fnScanToken. - s = s1; // Update the local pointer too. - } - else if (*s == '&' && s[1] == '>') - { - s = fnSkipWhite(s+2); // get stdout+stderr redirection - - if(pclp->m_redirBothName) - { - free(pclp->m_redirBothName); - pclp->m_redirBothName = NULL; - } - - if(pclp->m_redirBothName == NULL) - { - pclp->m_redirBothName = (char *) malloc(MAX_DN_BYTES * sizeof(char)); - if(pclp->m_redirBothName == NULL) - { - pclp->m_isValid = FALSE; - return; - } - } - - // Collect the next command-line argument. - pclp->m_redirBothName = fnScanToken(s, pclp->m_redirBothName); - - s1 = fnSkipWhite(s1); // s1 is already updated by fnScanToken. - s = s1; // Update the local pointer too. - } - else - { - if(pclp->nextarg) - { - free(pclp->nextarg); - pclp->nextarg = NULL; - } - - if(pclp->nextarg == NULL) - { - pclp->nextarg = (char *) malloc(MAX_DN_BYTES * sizeof(char)); - if(pclp->nextarg == NULL) - { - pclp->m_isValid = FALSE; - return; - } - } - - // Collect the next command-line argument. - pclp->nextarg = fnScanToken(s, pclp->nextarg); - - s1 = fnSkipWhite(s1); // s1 is already updated by fnScanToken. - s = s1; // Update the local pointer too. - - // Append the next command-line argument into an array. - fnAppendArgument(pclp, pclp->nextarg); - } - } - } - - - // The -{ option, the --noscreen option, the --autodestroy option, if present, - // are processed now and removed from the argument vector. - for(index=0; index < pclp->m_argc; ) - { - // "-q" is replaced by "-{", because of clash with GetOpt - sgp - 7th Nov 2000 - // Copied from NDK build - Jan 5th 2001 - if (strncmp(pclp->m_argv[index], (char *)"-{", 2) == 0) - { - // found a -q option; grab the semaphore number - sscanf(pclp->m_argv[index], (char *)"-{%x", &pclp->m_qSemaphore); - fnDeleteArgument(pclp, index); // Delete the argument from the list. - } - else if (strcmp(pclp->m_argv[index], (char *)"--noscreen") == 0) - { - // found a --noscreen option - pclp->m_noScreen = 1; - fnDeleteArgument(pclp, index); - } - else if (strcmp(pclp->m_argv[index], (char *)"--autodestroy") == 0) - { - // found a --autodestroy option - create a screen but close automatically - pclp->m_AutoDestroy = 1; - fnDeleteArgument(pclp, index); - } - else - index++; - } - - // pclp->m_isValid is TRUE if there are more than 2 command line parameters OR - // if there is only one command and if it is the comman PERL. - pclp->m_isValid = ((pclp->m_argc >= 2) || ((pclp->m_argc > 0) && (stricmp(pclp->m_argv[0], LOAD_COMMAND) != 0))); - - if(buffer) - { - free(buffer); - buffer = NULL; - } - - return; + // Empty the string. + strncpy(pclp->sSkippedToken, "", (MAX_DN_BYTES * sizeof(char))); + + // s is advanced by fnSkipToken + pclp->sSkippedToken = fnSkipToken(s, pclp->sSkippedToken); // Collect the next command-line argument. + + s2 = fnSkipWhite(s2); // s2 is already updated by fnSkipToken. + s = s2; // Update the local pointer too. + + fnAppendArgument(pclp, pclp->sSkippedToken); // Append the argument into an array. + } + + if(pclp->sSkippedToken) + { + free(pclp->sSkippedToken); + pclp->sSkippedToken = NULL; + } + } + else + { + char *s = NULL; + + strcpy(buffer, commandLine); + s = buffer; + s = fnSkipWhite(s); + + s1 = s; // Update the global pointer. + + while (*s && pclp->m_isValid) + { + // s is advanced by fnScanToken + // Check for I/O redirection here, *outside* of + // fnScanToken(), so that quote-protected angle + // brackets do NOT cause redirection. + if (*s == '<') + { + s = fnSkipWhite(s+1); // get stdin redirection + + if(pclp->m_redirInName) + { + free(pclp->m_redirInName); + pclp->m_redirInName = NULL; + } + + if(pclp->m_redirInName == NULL) + { + pclp->m_redirInName = (char *) malloc(MAX_DN_BYTES * sizeof(char)); + if(pclp->m_redirInName == NULL) + { + pclp->m_isValid = FALSE; + return; + } + } + + // Collect the next command-line argument. + pclp->m_redirInName = fnScanToken(s, pclp->m_redirInName); + + s1 = fnSkipWhite(s1); // s1 is already updated by fnScanToken. + s = s1; // Update the local pointer too. + } + else if (*s == '>') + { + s = fnSkipWhite(s+1); //get stdout redirection + + if(pclp->m_redirOutName) + { + free(pclp->m_redirOutName); + pclp->m_redirOutName = NULL; + } + + if(pclp->m_redirOutName == NULL) + { + pclp->m_redirOutName = (char *) malloc(MAX_DN_BYTES * sizeof(char)); + if(pclp->m_redirOutName == NULL) + { + pclp->m_isValid = FALSE; + return; + } + } + + // Collect the next command-line argument. + pclp->m_redirOutName = fnScanToken(s, pclp->m_redirOutName); + + s1 = fnSkipWhite(s1); // s1 is already updated by fnScanToken. + s = s1; // Update the local pointer too. + } + else if (*s == '2' && s[1] == '>') + { + s = fnSkipWhite(s+2); // get stderr redirection + + if(pclp->m_redirErrName) + { + free(pclp->m_redirErrName); + pclp->m_redirErrName = NULL; + } + + if(pclp->m_redirErrName == NULL) + { + pclp->m_redirErrName = (char *) malloc(MAX_DN_BYTES * sizeof(char)); + if(pclp->m_redirErrName == NULL) + { + pclp->m_isValid = FALSE; + return; + } + } + + // Collect the next command-line argument. + pclp->m_redirErrName = fnScanToken(s, pclp->m_redirErrName); + + s1 = fnSkipWhite(s1); // s1 is already updated by fnScanToken. + s = s1; // Update the local pointer too. + } + else if (*s == '&' && s[1] == '>') + { + s = fnSkipWhite(s+2); // get stdout+stderr redirection + + if(pclp->m_redirBothName) + { + free(pclp->m_redirBothName); + pclp->m_redirBothName = NULL; + } + + if(pclp->m_redirBothName == NULL) + { + pclp->m_redirBothName = (char *) malloc(MAX_DN_BYTES * sizeof(char)); + if(pclp->m_redirBothName == NULL) + { + pclp->m_isValid = FALSE; + return; + } + } + + // Collect the next command-line argument. + pclp->m_redirBothName = fnScanToken(s, pclp->m_redirBothName); + + s1 = fnSkipWhite(s1); // s1 is already updated by fnScanToken. + s = s1; // Update the local pointer too. + } + else + { + if(pclp->nextarg) + { + free(pclp->nextarg); + pclp->nextarg = NULL; + } + + if(pclp->nextarg == NULL) + { + pclp->nextarg = (char *) malloc(MAX_DN_BYTES * sizeof(char)); + if(pclp->nextarg == NULL) + { + pclp->m_isValid = FALSE; + return; + } + } + + // Collect the next command-line argument. + pclp->nextarg = fnScanToken(s, pclp->nextarg); + + s1 = fnSkipWhite(s1); // s1 is already updated by fnScanToken. + s = s1; // Update the local pointer too. + + // Append the next command-line argument into an array. + fnAppendArgument(pclp, pclp->nextarg); + } + } + } + + + // The -{ option, the --noscreen option, the --autodestroy option, if present, + // are processed now and removed from the argument vector. + for(index=0; index < pclp->m_argc; ) + { + // "-q" is replaced by "-{", because of clash with GetOpt - sgp - 7th Nov 2000 + // Copied from NDK build - Jan 5th 2001 + if (strncmp(pclp->m_argv[index], (char *)"-{", 2) == 0) + { + // found a -q option; grab the semaphore number + sscanf(pclp->m_argv[index], (char *)"-{%x", &pclp->m_qSemaphore); + fnDeleteArgument(pclp, index); // Delete the argument from the list. + } + else if (strcmp(pclp->m_argv[index], (char *)"--noscreen") == 0) + { + // found a --noscreen option + pclp->m_noScreen = 1; + fnDeleteArgument(pclp, index); + } + else if (strcmp(pclp->m_argv[index], (char *)"--autodestroy") == 0) + { + // found a --autodestroy option - create a screen but close automatically + pclp->m_AutoDestroy = 1; + fnDeleteArgument(pclp, index); + } + else + index++; + } + + // pclp->m_isValid is TRUE if there are more than 2 command line parameters OR + // if there is only one command and if it is the comman PERL. + pclp->m_isValid = ((pclp->m_argc >= 2) || ((pclp->m_argc > 0) && (stricmp(pclp->m_argv[0], LOAD_COMMAND) != 0))); + + if(buffer) + { + free(buffer); + buffer = NULL; + } + + return; } @@ -396,7 +396,7 @@ void fnCommandLineParser(PCOMMANDLINEPARSER pclp, char * commandLine, BOOL prese Description : This function appends the arguments into a list. Parameters : pclp (IN) - CommandLine structure. - new_arg (IN) - The new argument to be appended. + new_arg (IN) - The new argument to be appended. Returns : Nothing. @@ -404,98 +404,98 @@ void fnCommandLineParser(PCOMMANDLINEPARSER pclp, char * commandLine, BOOL prese void fnAppendArgument(PCOMMANDLINEPARSER pclp, char *new_arg) { - char **new_argv = pclp->new_argv; - - int new_argv_len = pclp->m_argv_len*2; - int i = 0, j = 0; - - - // Lengthen the argument vector if there's not room for another. - // Testing for 'm_argc+2' rather than 'm_argc+1' in the test guarantees - // that there'll always be a NULL terminator at the end of argv. - if ((pclp->m_argc + 2) > pclp->m_argv_len) - { - new_argv = (char **) malloc(new_argv_len * sizeof(char*)); // get a longer arg-vector - if (new_argv == NULL) - { - pclp->m_isValid = FALSE; - return; - } - for(i=0; im_isValid = FALSE; - return; - } - } - - for (i=0; im_argc; i++) - strcpy(new_argv[i], pclp->m_argv[i]); // copy old arg strings - - for(i=0; i<(pclp->m_argv_len); i++) - { - if(pclp->m_argv[i]) - { - free(pclp->m_argv[i]); - pclp->m_argv[i] = NULL; - } - } - if (pclp->m_argv != NULL) - { - free(pclp->m_argv); - pclp->m_argv = NULL; - } - - - pclp->m_argv = new_argv; - pclp->m_argv_len = new_argv_len; - - } - - // Once m_argv is guaranteed long enough, appending the argument is a direct job. - strcpy(pclp->m_argv[pclp->m_argc], new_arg); // Appended the new argument. - pclp->m_argc++; // Increment the number of parameters appended. - - // The char array is emptied for all elements upto the end so that there are no - // junk characters. If this is not done, then the issue is like this: - // - Simple perl command like "perl" on the system console works fine for the first time. - // - When "perl" is executed the second time, a new blank screen should come up - // which allows for editing also. This was not consistently working well. - // More so when the command was like, "perl ", that is the name "perl" followed - // by a few blank spaces, it used to give error in opening file: - // "unable to open the file" since the filename would have some junk characters. - // - // These issues are fixed through the code below. - for(i=pclp->m_argc; im_argv_len; i++) - strncpy(pclp->m_argv[i], "", (MAX_DN_BYTES * sizeof(char))); // MAX_DN_BYTES is the size of pclp->m_argv[]. - - - // Fix for empty command line double quote abend - perl <.pl> "" - if ((new_arg==NULL) || ((strlen(new_arg))<=0)) - { - pclp->m_argc--; // Decrement the number of parameters appended. - pclp->m_isValid = FALSE; - return; - } - - - return; + char **new_argv = pclp->new_argv; + + int new_argv_len = pclp->m_argv_len*2; + int i = 0, j = 0; + + + // Lengthen the argument vector if there's not room for another. + // Testing for 'm_argc+2' rather than 'm_argc+1' in the test guarantees + // that there'll always be a NULL terminator at the end of argv. + if ((pclp->m_argc + 2) > pclp->m_argv_len) + { + new_argv = (char **) malloc(new_argv_len * sizeof(char*)); // get a longer arg-vector + if (new_argv == NULL) + { + pclp->m_isValid = FALSE; + return; + } + for(i=0; im_isValid = FALSE; + return; + } + } + + for (i=0; im_argc; i++) + strcpy(new_argv[i], pclp->m_argv[i]); // copy old arg strings + + for(i=0; i<(pclp->m_argv_len); i++) + { + if(pclp->m_argv[i]) + { + free(pclp->m_argv[i]); + pclp->m_argv[i] = NULL; + } + } + if (pclp->m_argv != NULL) + { + free(pclp->m_argv); + pclp->m_argv = NULL; + } + + + pclp->m_argv = new_argv; + pclp->m_argv_len = new_argv_len; + + } + + // Once m_argv is guaranteed long enough, appending the argument is a direct job. + strcpy(pclp->m_argv[pclp->m_argc], new_arg); // Appended the new argument. + pclp->m_argc++; // Increment the number of parameters appended. + + // The char array is emptied for all elements upto the end so that there are no + // junk characters. If this is not done, then the issue is like this: + // - Simple perl command like "perl" on the system console works fine for the first time. + // - When "perl" is executed the second time, a new blank screen should come up + // which allows for editing also. This was not consistently working well. + // More so when the command was like, "perl ", that is the name "perl" followed + // by a few blank spaces, it used to give error in opening file: + // "unable to open the file" since the filename would have some junk characters. + // + // These issues are fixed through the code below. + for(i=pclp->m_argc; im_argv_len; i++) + strncpy(pclp->m_argv[i], "", (MAX_DN_BYTES * sizeof(char))); // MAX_DN_BYTES is the size of pclp->m_argv[]. + + + // Fix for empty command line double quote abend - perl <.pl> "" + if ((new_arg==NULL) || ((strlen(new_arg))<=0)) + { + pclp->m_argc--; // Decrement the number of parameters appended. + pclp->m_isValid = FALSE; + return; + } + + + return; } @@ -505,11 +505,11 @@ void fnAppendArgument(PCOMMANDLINEPARSER pclp, char *new_arg) Function : fnSkipToken Description : This function collects the next command-line argument, breaking on - unquoted white space. The quote symbols are copied into the output. - White space has already been skipped. + unquoted white space. The quote symbols are copied into the output. + White space has already been skipped. Parameters : s (IN) - Input string in which the token is skipped. - r (IN) - The resultant return string. + r (IN) - The resultant return string. Returns : String. @@ -517,44 +517,44 @@ void fnAppendArgument(PCOMMANDLINEPARSER pclp, char *new_arg) char *fnSkipToken(char *s, char *r) { - char *t=NULL; - char quote = '\0'; // NULL, single quote, or double quote - char ch = '\0'; - - for (t=s; t[0]; t++) - { - ch = t[0]; - if (!quote) - { - if (isspace(ch)) // if unquoted whitespace... - { - break; // ...end of token found - } - else if (ch=='"' || ch=='\'') // if opening quote... - { - quote = ch; // ...enter quote mode - } - } - else - { - if (ch=='\\' && t[1]==quote) // if escaped quote... - { - t++; // ...skip backslash - } - else if (ch==quote) // if close quote... - { - quote = 0; // ...leave quote mode - } - } - } - - r = fnStashString(s, r, t-s); // get heap-allocated token string - t = fnSkipWhite(t); // skip any trailing white space - s = t; // return updated source pointer - - s2 = t; // return updated global source pointer - - return r; // return heap-allocated token string + char *t=NULL; + char quote = '\0'; // NULL, single quote, or double quote + char ch = '\0'; + + for (t=s; t[0]; t++) + { + ch = t[0]; + if (!quote) + { + if (isspace(ch)) // if unquoted whitespace... + { + break; // ...end of token found + } + else if (ch=='"' || ch=='\'') // if opening quote... + { + quote = ch; // ...enter quote mode + } + } + else + { + if (ch=='\\' && t[1]==quote) // if escaped quote... + { + t++; // ...skip backslash + } + else if (ch==quote) // if close quote... + { + quote = 0; // ...leave quote mode + } + } + } + + r = fnStashString(s, r, t-s); // get heap-allocated token string + t = fnSkipWhite(t); // skip any trailing white space + s = t; // return updated source pointer + + s2 = t; // return updated global source pointer + + return r; // return heap-allocated token string } @@ -564,12 +564,12 @@ char *fnSkipToken(char *s, char *r) Function : fnScanToken Description : This function collects the next command-line argument, breaking on - unquoted white space or I/O redirection symbols. Quote symbols are not - copied into the output. - When called, any leading white space has already been skipped. + unquoted white space or I/O redirection symbols. Quote symbols are not + copied into the output. + When called, any leading white space has already been skipped. Parameters : x (IN) - Input string in which the token is scanned. - r (IN) - The resultant return string. + r (IN) - The resultant return string. Returns : String. @@ -577,61 +577,61 @@ char *fnSkipToken(char *s, char *r) char *fnScanToken(char *x, char *r) { - char *s = x; // input string position - char *t = x; // output string position - char quote = '\0'; // either NULL, or single quote, or double quote - char ch = '\0'; - char c = '\0'; - - while (*s) - { - ch = *s; // invariant: ch != 0 - - // look to see if we've reached the end of the token - if (!quote) // but don't look for token break if we're inside quotes - { - if (isspace(ch)) - break; // break on whitespace - if (ch=='>') - break; // break on ">" (redirect stdout) - if (ch=='<') - break; // break on "<" (redirect stdin) - if (ch=='&' && x[1]=='>') - break; // break on "&>" (redirect both stdout & stderr) - } - - // process the next source character - if (ch=='\\' && (c=s[1]) && (c=='\\'||c=='>'||c=='<'||c==quote)) - { - //-----------------if an escaped '\\', '>', '<', or quote... - s++; // ...skip over the backslash... - *t++ = *s++; // ...and copy the escaped character - } - else if (ch==quote) // (won't match unless inside quotes because invariant ch!=0) - { - //-----------------if close quote... - s++; // ...skip over the quote... - quote=0; // ...and leave quote mode - } - else if (!quote && (ch=='"' || ch=='\'')) - { - //-----------------if opening quote... - quote = *s++; // ...enter quote mode (remembering quote char, and skipping the quote) - } - else - { //----------if normal character... - *t++ = *s++; // ...copy the character - } - } - - // clean up return values - r = fnStashString(x, r, t-x); // get heap-allocated token string - s = fnSkipWhite(s); // skip any trailing white space - x = s; // return updated source pointer - - s1 = s; // return updated global source pointer - - return r; + char *s = x; // input string position + char *t = x; // output string position + char quote = '\0'; // either NULL, or single quote, or double quote + char ch = '\0'; + char c = '\0'; + + while (*s) + { + ch = *s; // invariant: ch != 0 + + // look to see if we've reached the end of the token + if (!quote) // but don't look for token break if we're inside quotes + { + if (isspace(ch)) + break; // break on whitespace + if (ch=='>') + break; // break on ">" (redirect stdout) + if (ch=='<') + break; // break on "<" (redirect stdin) + if (ch=='&' && x[1]=='>') + break; // break on "&>" (redirect both stdout & stderr) + } + + // process the next source character + if (ch=='\\' && (c=s[1]) && (c=='\\'||c=='>'||c=='<'||c==quote)) + { + //-----------------if an escaped '\\', '>', '<', or quote... + s++; // ...skip over the backslash... + *t++ = *s++; // ...and copy the escaped character + } + else if (ch==quote) // (won't match unless inside quotes because invariant ch!=0) + { + //-----------------if close quote... + s++; // ...skip over the quote... + quote=0; // ...and leave quote mode + } + else if (!quote && (ch=='"' || ch=='\'')) + { + //-----------------if opening quote... + quote = *s++; // ...enter quote mode (remembering quote char, and skipping the quote) + } + else + { //----------if normal character... + *t++ = *s++; // ...copy the character + } + } + + // clean up return values + r = fnStashString(x, r, t-x); // get heap-allocated token string + s = fnSkipWhite(s); // skip any trailing white space + x = s; // return updated source pointer + + s1 = s; // return updated global source pointer + + return r; } @@ -643,8 +643,8 @@ char *fnScanToken(char *x, char *r) Description : This function return the heap-allocated token string. Parameters : s (IN) - Input string from which the token is extracted. - buffer (IN) - Return string. - length (IN) - Length of the token to be extracted. + buffer (IN) - Return string. + length (IN) - Length of the token to be extracted. Returns : String. @@ -652,19 +652,19 @@ char *fnScanToken(char *x, char *r) char *fnStashString(char *s, char *buffer, int length) { - if (length <= 0) - { - // Copy "" instead of NULL since "" indicates that there is memory allocated having no/null value. - // NULL indicates that there is no memory allocated to it! - strcpy(buffer, ""); - } - else - { - strncpy(buffer, s, length); - buffer[length] = '\0'; - } - - return buffer; + if (length <= 0) + { + // Copy "" instead of NULL since "" indicates that there is memory allocated having no/null value. + // NULL indicates that there is no memory allocated to it! + strcpy(buffer, ""); + } + else + { + strncpy(buffer, s, length); + buffer[length] = '\0'; + } + + return buffer; } @@ -676,7 +676,7 @@ char *fnStashString(char *s, char *buffer, int length) Description : This function deletes an argument (that was originally appended) from the list. Parameters : pclp (IN) - CommandLine structure. - index (IN) - Index of the argument to be deleted. + index (IN) - Index of the argument to be deleted. Returns : Nothing. @@ -684,33 +684,33 @@ char *fnStashString(char *s, char *buffer, int length) void fnDeleteArgument(PCOMMANDLINEPARSER pclp, int index) { - int i = index; + int i = index; - // If index is greater than the no. of arguments, just return. - if (index >= pclp->m_argc) - return; + // If index is greater than the no. of arguments, just return. + if (index >= pclp->m_argc) + return; - // Move all the arguments after the index one up. - while(i < (pclp->m_argv_len-1)) - { - strcpy(pclp->m_argv[i], pclp->m_argv[i+1]); - i++; - } + // Move all the arguments after the index one up. + while(i < (pclp->m_argv_len-1)) + { + strcpy(pclp->m_argv[i], pclp->m_argv[i+1]); + i++; + } - // Delete the last one and free memory. - if ( pclp->m_argv[i] ) - { - free(pclp->m_argv[i]); - pclp->m_argv[i] = NULL; - } + // Delete the last one and free memory. + if ( pclp->m_argv[i] ) + { + free(pclp->m_argv[i]); + pclp->m_argv[i] = NULL; + } - pclp->m_argc--; // Decrement the number of arguments. - pclp->m_argv_len--; + pclp->m_argc--; // Decrement the number of arguments. + pclp->m_argv_len--; - return; + return; } @@ -729,82 +729,82 @@ void fnDeleteArgument(PCOMMANDLINEPARSER pclp, int index) char* fnMy_MkTemp(char* templatestr) { - char* pXs=NULL; - char numbuf[50]={'\0'}; - int count=0; - char* pPid=NULL; + char* pXs=NULL; + char numbuf[50]={'\0'}; + int count=0; + char* pPid=NULL; - char termchar = '\0'; - char letter = 'a'; - char letter1 = 'a'; + char termchar = '\0'; + char letter = 'a'; + char letter1 = 'a'; - if (templatestr && (pXs = strstr(templatestr, (char *)"XXXXXX"))) - { - // generate temp name - termchar = pXs[6]; - ltoa(GetThreadID(), numbuf, 16); + if (templatestr && (pXs = strstr(templatestr, (char *)"XXXXXX"))) + { + // generate temp name + termchar = pXs[6]; + ltoa(GetThreadID(), numbuf, 16); // numbuf[sizeof(numbuf)-1] = '\0'; - numbuf[strlen(numbuf)-1] = '\0'; - // beware! thread IDs are 8 hex digits on NW 4.11 and only the - // lower digits seem to change, whereas on NW 5 they are in the - // range of < 1000 hex or 3 hex digits in length. So the following - // logic ensures we use the least significant portion of the number. - if (strlen(numbuf) > 5) - pPid = &numbuf[strlen(numbuf)-5]; - else - pPid = numbuf; + numbuf[strlen(numbuf)-1] = '\0'; + // beware! thread IDs are 8 hex digits on NW 4.11 and only the + // lower digits seem to change, whereas on NW 5 they are in the + // range of < 1000 hex or 3 hex digits in length. So the following + // logic ensures we use the least significant portion of the number. + if (strlen(numbuf) > 5) + pPid = &numbuf[strlen(numbuf)-5]; + else + pPid = numbuf; /** - Backtick operation uses temp files that are stored under NWDEFPERLTEMP - directory. They are temporarily used and then cleaned up after usage. - In cases where multiple backtick operations are used that call some - complex scripts, new temp files will be created before the old ones are - deleted. So, we need to have a provision to create many temp files. - Hence the below logic. It is found that provision for 26 files may - not be enough in some cases. - - This below logic allows 26 files (like, pla00015.tmp through plz00015.tmp) - plus 6x26=676 (like, plaa0015.tmp through plzz0015.tmp) + Backtick operation uses temp files that are stored under NWDEFPERLTEMP + directory. They are temporarily used and then cleaned up after usage. + In cases where multiple backtick operations are used that call some + complex scripts, new temp files will be created before the old ones are + deleted. So, we need to have a provision to create many temp files. + Hence the below logic. It is found that provision for 26 files may + not be enough in some cases. + + This below logic allows 26 files (like, pla00015.tmp through plz00015.tmp) + plus 6x26=676 (like, plaa0015.tmp through plzz0015.tmp) **/ - letter = 'a'; - do - { - sprintf(pXs, (char *)"%c%05.5s", letter, pPid); - pXs[6] = termchar; - if (access(templatestr, 0) != 0) // File does not exist - { - return templatestr; - } - letter++; - } while (letter <= 'z'); - - letter1 = 'a'; - do - { - letter = 'a'; - do - { - sprintf(pXs, (char *)"%c%c%04.5s", letter1, letter, pPid); - pXs[6] = termchar; - if (access(templatestr, 0) != 0) // File does not exist - { - return templatestr; - } - letter++; - } while (letter <= 'z'); - letter1++; - } while (letter1 <= 'z'); - - errno = ENOENT; - return NULL; - } - else - { - errno = EINVAL; - return NULL; - } + letter = 'a'; + do + { + sprintf(pXs, (char *)"%c%05.5s", letter, pPid); + pXs[6] = termchar; + if (access(templatestr, 0) != 0) // File does not exist + { + return templatestr; + } + letter++; + } while (letter <= 'z'); + + letter1 = 'a'; + do + { + letter = 'a'; + do + { + sprintf(pXs, (char *)"%c%c%04.5s", letter1, letter, pPid); + pXs[6] = termchar; + if (access(templatestr, 0) != 0) // File does not exist + { + return templatestr; + } + letter++; + } while (letter <= 'z'); + letter1++; + } while (letter1 <= 'z'); + + errno = ENOENT; + return NULL; + } + else + { + errno = EINVAL; + return NULL; + } } @@ -814,10 +814,10 @@ char* fnMy_MkTemp(char* templatestr) Function : fnSystemCommand Description : This function constructs a system command from the given - null-terminated argv array and runs the command on the system console. + null-terminated argv array and runs the command on the system console. Parameters : argv (IN) - Array of input commands. - argc (IN) - Number of input parameters. + argc (IN) - Number of input parameters. Returns : Nothing. @@ -825,34 +825,34 @@ char* fnMy_MkTemp(char* templatestr) void fnSystemCommand (char** argv, int argc) { - // calculate the size of a temp buffer needed - int k = 0; - int totalSize = 0; - int bytes = 0; - char* tempCmd = NULL; - char* tptr = NULL; + // calculate the size of a temp buffer needed + int k = 0; + int totalSize = 0; + int bytes = 0; + char* tempCmd = NULL; + char* tptr = NULL; - for(k=0; k - #include + #include + #include #endif //MPK_ON @@ -44,9 +44,9 @@ // so it should be okay for this to be global. // #ifdef MPK_ON - THREAD gThreadHandle; + THREAD gThreadHandle; #else - int gThreadGroupID = -1; + int gThreadGroupID = -1; #endif //MPK_ON @@ -77,8 +77,8 @@ char sPerlScreenName[MAX_DN_BYTES * sizeof(char)] = {'\0'}; // typedef struct tagScriptData { - char *m_commandLine; - BOOL m_fromConsole; + char *m_commandLine; + BOOL m_fromConsole; }ScriptData; @@ -131,10 +131,10 @@ void nw_freeenviron(); Function : main Description : Called when the NLM is first loaded. Registers the command-line handler - and then terminates-stay-resident. + and then terminates-stay-resident. Parameters : argc (IN) - No of Input strings. - argv (IN) - Array of Input strings. + argv (IN) - Array of Input strings. Returns : Nothing. @@ -142,117 +142,117 @@ void nw_freeenviron(); void main(int argc, char *argv[]) { - char sysCmdLine[MAX_COMMAND_SIZE] = {'\0'}; - char cmdLineCopy[sizeof(PERL_COMMAND_NAME)+sizeof(sysCmdLine)+2] = {'\0'}; + char sysCmdLine[MAX_COMMAND_SIZE] = {'\0'}; + char cmdLineCopy[sizeof(PERL_COMMAND_NAME)+sizeof(sysCmdLine)+2] = {'\0'}; - ScriptData* psdata = NULL; + ScriptData* psdata = NULL; - // Keep this thread alive, since we use the thread group id of this thread to allocate memory on. - // When we unload the NLM, clib will tear the thread down. - // - #ifdef MPK_ON - gThreadHandle = kCurrentThread(); - #else - gThreadGroupID = GetThreadGroupID (); - #endif //MPK_ON + // Keep this thread alive, since we use the thread group id of this thread to allocate memory on. + // When we unload the NLM, clib will tear the thread down. + // + #ifdef MPK_ON + gThreadHandle = kCurrentThread(); + #else + gThreadGroupID = GetThreadGroupID (); + #endif //MPK_ON - signal (SIGTERM, fnSigTermHandler); - fnInitGpfGlobals(); // For importing the CLIB calls in place of the Watcom calls - fnInitializeThreadInfo(); + signal (SIGTERM, fnSigTermHandler); + fnInitGpfGlobals(); // For importing the CLIB calls in place of the Watcom calls + fnInitializeThreadInfo(); // Ensure that we have a "temp" directory - fnSetupNamespace(); - if (access(NWDEFPERLTEMP, 0) != 0) - mkdir(NWDEFPERLTEMP); - - // Create the file NUL if not present. This is done only once per NLM load. - // This is required for -e. - // Earlier versions were creating temporary files (in perl.c file) for -e. - // Now, the technique of creating temporary files are removed since they were - // fragile or insecure or slow. It now uses the memory by setting - // the BIT_BUCKET to "nul" on Win32, which is equivalent to /dev/nul of Unix. - // Since there is no equivalent of /dev/nul on NetWare, the work-around is that - // we create a file called "nul" and the BIT_BUCKET is set to "nul". - // This makes sure that -e works on NetWare too without the creation of temporary files - // in -e code in perl.c - { - char sNUL[MAX_DN_BYTES] = {'\0'}; - - strcpy(sNUL, NWDEFPERLROOT); - strcat(sNUL, "\\nwnul"); - if (access((const char *)sNUL, 0) != 0) - { - // The file, "nul" is not found and so create the file. - FILE *fp = NULL; - - fp = fopen((const char *)sNUL, (const char *)"w"); - fclose(fp); - } - } - - fnRegisterCommandLineHandler(); // Register the command line handler - SynchronizeStart(); // Restart the NLM startup process when using synchronization mode. - - fnGetPerlScreenName(sPerlScreenName); // Get the screen name. Done only once per NLM load. - - - // If the command line has two strings, then the first has to be "Perl" and the second is assumed - // to be a script to be run. If only one string (i.e., Perl) is input, then there is nothing to do! - // - if ((argc > 1) && getcmd(sysCmdLine)) - { - strcpy(cmdLineCopy, PERL_COMMAND_NAME); - strcat(cmdLineCopy, (char *)" "); // Space between the Perl Command and the input script name. - strcat(cmdLineCopy, sysCmdLine); // The command line parameters built into - - // Create a safe copy of the command line and pass it to the - // new thread for parsing. The new thread will be responsible - // to delete it when it is finished with it. - // - psdata = (ScriptData *) malloc(sizeof(ScriptData)); - if (psdata) - { - psdata->m_commandLine = NULL; - psdata->m_commandLine = (char *) malloc(MAX_DN_BYTES * sizeof(char)); - if(psdata->m_commandLine) - { - strcpy(psdata->m_commandLine, cmdLineCopy); - psdata->m_fromConsole = TRUE; - - #ifdef MPK_ON + fnSetupNamespace(); + if (access(NWDEFPERLTEMP, 0) != 0) + mkdir(NWDEFPERLTEMP); + + // Create the file NUL if not present. This is done only once per NLM load. + // This is required for -e. + // Earlier versions were creating temporary files (in perl.c file) for -e. + // Now, the technique of creating temporary files are removed since they were + // fragile or insecure or slow. It now uses the memory by setting + // the BIT_BUCKET to "nul" on Win32, which is equivalent to /dev/nul of Unix. + // Since there is no equivalent of /dev/nul on NetWare, the work-around is that + // we create a file called "nul" and the BIT_BUCKET is set to "nul". + // This makes sure that -e works on NetWare too without the creation of temporary files + // in -e code in perl.c + { + char sNUL[MAX_DN_BYTES] = {'\0'}; + + strcpy(sNUL, NWDEFPERLROOT); + strcat(sNUL, "\\nwnul"); + if (access((const char *)sNUL, 0) != 0) + { + // The file, "nul" is not found and so create the file. + FILE *fp = NULL; + + fp = fopen((const char *)sNUL, (const char *)"w"); + fclose(fp); + } + } + + fnRegisterCommandLineHandler(); // Register the command line handler + SynchronizeStart(); // Restart the NLM startup process when using synchronization mode. + + fnGetPerlScreenName(sPerlScreenName); // Get the screen name. Done only once per NLM load. + + + // If the command line has two strings, then the first has to be "Perl" and the second is assumed + // to be a script to be run. If only one string (i.e., Perl) is input, then there is nothing to do! + // + if ((argc > 1) && getcmd(sysCmdLine)) + { + strcpy(cmdLineCopy, PERL_COMMAND_NAME); + strcat(cmdLineCopy, (char *)" "); // Space between the Perl Command and the input script name. + strcat(cmdLineCopy, sysCmdLine); // The command line parameters built into + + // Create a safe copy of the command line and pass it to the + // new thread for parsing. The new thread will be responsible + // to delete it when it is finished with it. + // + psdata = (ScriptData *) malloc(sizeof(ScriptData)); + if (psdata) + { + psdata->m_commandLine = NULL; + psdata->m_commandLine = (char *) malloc(MAX_DN_BYTES * sizeof(char)); + if(psdata->m_commandLine) + { + strcpy(psdata->m_commandLine, cmdLineCopy); + psdata->m_fromConsole = TRUE; + + #ifdef MPK_ON // kStartThread((char *)"ConsoleHandlerThread", fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void *)psdata); - // Establish a new thread within a new thread group. - BeginThreadGroup(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata); - #else - // Start a new thread in its own thread group - BeginThreadGroup(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata); - #endif //MPK_ON - } - else - { - free(psdata); - psdata = NULL; - return; - } - } - else - return; - } - - - // Keep this thread alive, since we use the thread group id of this thread to allocate memory on. - // When we unload the NLM, clib will tear the thread down. - // - #ifdef MPK_ON - kSuspendThread(gThreadHandle); - #else - SuspendThread(GetThreadID()); - #endif //MPK_ON - - - return; + // Establish a new thread within a new thread group. + BeginThreadGroup(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata); + #else + // Start a new thread in its own thread group + BeginThreadGroup(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata); + #endif //MPK_ON + } + else + { + free(psdata); + psdata = NULL; + return; + } + } + else + return; + } + + + // Keep this thread alive, since we use the thread group id of this thread to allocate memory on. + // When we unload the NLM, clib will tear the thread down. + // + #ifdef MPK_ON + kSuspendThread(gThreadHandle); + #else + SuspendThread(GetThreadID()); + #endif //MPK_ON + + + return; } @@ -271,55 +271,55 @@ void main(int argc, char *argv[]) void fnSigTermHandler(int sig) { - int k = 0; - - - #ifdef MPK_ON - kResumeThread(gThreadHandle); - #endif //MPK_ON - - // Unregister the command line handler. - // - if (gCmdProcInit) - { - UnRegisterConsoleCommand (&gCmdParser); - gCmdProcInit = FALSE; - } - - // Free the global environ buffer - nw_freeenviron(); - - // Kill running scripts. - // - if (!fnTerminateThreadInfo()) - { - ConsolePrintf("Terminating Perl scripts...\n"); - gKillAll = TRUE; - - // fnTerminateThreadInfo will be run for 5 threads. If more threads/scripts are run, - // then the NLM will unload without terminating the thread info and leaks more memory. - // If this number is increased to reduce memory leaks, then it will unnecessarily take more time - // to unload when there are a smaller no of threads. Since this is a rare case, the no is kept as 5. - // - while (!fnTerminateThreadInfo() && k < 5) - { - nw_sleep(1); - k++; - } - } - - // Delete the file, "nul" if present since the NLM is unloaded. - { - char sNUL[MAX_DN_BYTES] = {'\0'}; - - strcpy(sNUL, NWDEFPERLROOT); - strcat(sNUL, "\\nwnul"); - if (access((const char *)sNUL, 0) == 0) - { - // The file, "nul" is found and so delete it. - unlink((const char *)sNUL); - } - } + int k = 0; + + + #ifdef MPK_ON + kResumeThread(gThreadHandle); + #endif //MPK_ON + + // Unregister the command line handler. + // + if (gCmdProcInit) + { + UnRegisterConsoleCommand (&gCmdParser); + gCmdProcInit = FALSE; + } + + // Free the global environ buffer + nw_freeenviron(); + + // Kill running scripts. + // + if (!fnTerminateThreadInfo()) + { + ConsolePrintf("Terminating Perl scripts...\n"); + gKillAll = TRUE; + + // fnTerminateThreadInfo will be run for 5 threads. If more threads/scripts are run, + // then the NLM will unload without terminating the thread info and leaks more memory. + // If this number is increased to reduce memory leaks, then it will unnecessarily take more time + // to unload when there are a smaller no of threads. Since this is a rare case, the no is kept as 5. + // + while (!fnTerminateThreadInfo() && k < 5) + { + nw_sleep(1); + k++; + } + } + + // Delete the file, "nul" if present since the NLM is unloaded. + { + char sNUL[MAX_DN_BYTES] = {'\0'}; + + strcpy(sNUL, NWDEFPERLROOT); + strcat(sNUL, "\\nwnul"); + if (access((const char *)sNUL, 0) == 0) + { + // The file, "nul" is found and so delete it. + unlink((const char *)sNUL); + } + } } @@ -329,12 +329,12 @@ void fnSigTermHandler(int sig) Function : fnCommandLineHandler Description : Gets called by OS when someone enters an unknown command at the system console, - after this routine is registered by RegisterConsoleCommand. - For the valid command we just spawn a thread with enough stack space - to actually run the script. + after this routine is registered by RegisterConsoleCommand. + For the valid command we just spawn a thread with enough stack space + to actually run the script. Parameters : screenID (IN) - id for the screen. - cmdLine (IN) - Command line string. + cmdLine (IN) - Command line string. Returns : Long. @@ -342,78 +342,78 @@ void fnSigTermHandler(int sig) LONG fnCommandLineHandler (LONG screenID, BYTE * cmdLine) { - ScriptData* psdata=NULL; - int OsThrdGrpID = -1; - LONG retCode = CS_CMD_FOUND; - char* cptr = NULL; - - - #ifdef MPK_ON - // Initialisation for MPK_ON - #else - OsThrdGrpID = -1; - #endif //MPK_ON - - - #ifdef MPK_ON - // For MPK_ON - #else - if (gThreadGroupID != -1) - OsThrdGrpID = SetThreadGroupID (gThreadGroupID); - #endif //MPK_ON - - - cptr = fnSkipWhite(cmdLine); // Skip white spaces. - if ((strnicmp(cptr, PERL_COMMAND_NAME, strlen(PERL_COMMAND_NAME)) == 0) && - ((cptr[strlen(PERL_COMMAND_NAME)] == ' ') || - (cptr[strlen(PERL_COMMAND_NAME)] == '\t') || - (cptr[strlen(PERL_COMMAND_NAME)] == '\0'))) - { - // Create a safe copy of the command line and pass it to the new thread for parsing. - // The new thread will be responsible to delete it when it is finished with it. - // - psdata = (ScriptData *) malloc(sizeof(ScriptData)); - if (psdata) - { - psdata->m_commandLine = NULL; - psdata->m_commandLine = (char *) malloc(MAX_DN_BYTES * sizeof(char)); - if(psdata->m_commandLine) - { - strcpy(psdata->m_commandLine, (char *)cmdLine); - psdata->m_fromConsole = TRUE; - - #ifdef MPK_ON + ScriptData* psdata=NULL; + int OsThrdGrpID = -1; + LONG retCode = CS_CMD_FOUND; + char* cptr = NULL; + + + #ifdef MPK_ON + // Initialisation for MPK_ON + #else + OsThrdGrpID = -1; + #endif //MPK_ON + + + #ifdef MPK_ON + // For MPK_ON + #else + if (gThreadGroupID != -1) + OsThrdGrpID = SetThreadGroupID (gThreadGroupID); + #endif //MPK_ON + + + cptr = fnSkipWhite(cmdLine); // Skip white spaces. + if ((strnicmp(cptr, PERL_COMMAND_NAME, strlen(PERL_COMMAND_NAME)) == 0) && + ((cptr[strlen(PERL_COMMAND_NAME)] == ' ') || + (cptr[strlen(PERL_COMMAND_NAME)] == '\t') || + (cptr[strlen(PERL_COMMAND_NAME)] == '\0'))) + { + // Create a safe copy of the command line and pass it to the new thread for parsing. + // The new thread will be responsible to delete it when it is finished with it. + // + psdata = (ScriptData *) malloc(sizeof(ScriptData)); + if (psdata) + { + psdata->m_commandLine = NULL; + psdata->m_commandLine = (char *) malloc(MAX_DN_BYTES * sizeof(char)); + if(psdata->m_commandLine) + { + strcpy(psdata->m_commandLine, (char *)cmdLine); + psdata->m_fromConsole = TRUE; + + #ifdef MPK_ON // kStartThread((char *)"ConsoleHandlerThread", fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void *)psdata); - // Establish a new thread within a new thread group. - BeginThreadGroup(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata); - #else - // Start a new thread in its own thread group - BeginThreadGroup(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata); - #endif //MPK_ON - } - else - { - free(psdata); - psdata = NULL; - retCode = CS_CMD_NOT_FOUND; - } - } - else - retCode = CS_CMD_NOT_FOUND; - } - else - retCode = CS_CMD_NOT_FOUND; - - - #ifdef MPK_ON - // For MPK_ON - #else - if (OsThrdGrpID != -1) - SetThreadGroupID (OsThrdGrpID); - #endif //MPK_ON - - - return retCode; + // Establish a new thread within a new thread group. + BeginThreadGroup(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata); + #else + // Start a new thread in its own thread group + BeginThreadGroup(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata); + #endif //MPK_ON + } + else + { + free(psdata); + psdata = NULL; + retCode = CS_CMD_NOT_FOUND; + } + } + else + retCode = CS_CMD_NOT_FOUND; + } + else + retCode = CS_CMD_NOT_FOUND; + + + #ifdef MPK_ON + // For MPK_ON + #else + if (OsThrdGrpID != -1) + SetThreadGroupID (OsThrdGrpID); + #endif //MPK_ON + + + return retCode; } @@ -432,16 +432,16 @@ LONG fnCommandLineHandler (LONG screenID, BYTE * cmdLine) void fnRegisterCommandLineHandler(void) { - // Allocates resource tag for Console Command - if ((gCmdParser.RTag = - AllocateResourceTag (GetNLMHandle(), (char *)"Console Command", ConsoleCommandSignature)) != 0) - { - gCmdParser.parseRoutine = fnCommandLineHandler; // Set the Console Command parsing routine. - RegisterConsoleCommand (&gCmdParser); // Registers the Console Command parsing function - gCmdProcInit = TRUE; - } - - return; + // Allocates resource tag for Console Command + if ((gCmdParser.RTag = + AllocateResourceTag (GetNLMHandle(), (char *)"Console Command", ConsoleCommandSignature)) != 0) + { + gCmdParser.parseRoutine = fnCommandLineHandler; // Set the Console Command parsing routine. + RegisterConsoleCommand (&gCmdParser); // Registers the Console Command parsing function + gCmdProcInit = TRUE; + } + + return; } @@ -460,44 +460,44 @@ void fnRegisterCommandLineHandler(void) void fnSetupNamespace(void) { - SetCurrentNameSpace(NWOS2_NAME_SPACE); + SetCurrentNameSpace(NWOS2_NAME_SPACE); - //LATER: call SetTargetNameSpace(NWOS2_NAME_SPACE)? Currently, if - // I make this call, then CPerlExe::Rename fails in certain cases, - // and it isn't clear why. Looks like a CLIB bug... + //LATER: call SetTargetNameSpace(NWOS2_NAME_SPACE)? Currently, if + // I make this call, then CPerlExe::Rename fails in certain cases, + // and it isn't clear why. Looks like a CLIB bug... // SetTargetNameSpace(NWOS2_NAME_SPACE); - //Uncommented that above call, retaining the comment so that it will be easy - //to revert back if there is any problem - sgp - 10th May 2000 - - //Commented again, since Perl debugger had some problems because of - //the above call - sgp - 20th June 2000 - - { - // if running on Moab, call UseAccurateCaseForPaths. This API - // does bad things on 4.11 so we call only for Moab. - PFGETFILESERVERMAJORVERSIONNUMBER pf_getfileservermajorversionnumber = NULL; - pf_getfileservermajorversionnumber = (PFGETFILESERVERMAJORVERSIONNUMBER) - ImportSymbol(GetNLMHandle(), (char *)"GetFileServerMajorVersionNumber"); - if (pf_getfileservermajorversionnumber && ((*pf_getfileservermajorversionnumber)() > 4)) - { - PFUSEACCURATECASEFORPATHS pf_useaccuratecaseforpaths = NULL; - pf_useaccuratecaseforpaths = (PFUSEACCURATECASEFORPATHS) - ImportSymbol(GetNLMHandle(), (char *)"UseAccurateCaseForPaths"); - if (pf_useaccuratecaseforpaths) - (*pf_useaccuratecaseforpaths)(TRUE); - { - PFUNAUGMENTASTERISK pf_unaugmentasterisk = NULL; - pf_unaugmentasterisk = (PFUNAUGMENTASTERISK) - ImportSymbol(GetNLMHandle(), (char *)"UnAugmentAsterisk"); - if (pf_unaugmentasterisk) - (*pf_unaugmentasterisk)(TRUE); - } - } - } - - return; + //Uncommented that above call, retaining the comment so that it will be easy + //to revert back if there is any problem - sgp - 10th May 2000 + + //Commented again, since Perl debugger had some problems because of + //the above call - sgp - 20th June 2000 + + { + // if running on Moab, call UseAccurateCaseForPaths. This API + // does bad things on 4.11 so we call only for Moab. + PFGETFILESERVERMAJORVERSIONNUMBER pf_getfileservermajorversionnumber = NULL; + pf_getfileservermajorversionnumber = (PFGETFILESERVERMAJORVERSIONNUMBER) + ImportSymbol(GetNLMHandle(), (char *)"GetFileServerMajorVersionNumber"); + if (pf_getfileservermajorversionnumber && ((*pf_getfileservermajorversionnumber)() > 4)) + { + PFUSEACCURATECASEFORPATHS pf_useaccuratecaseforpaths = NULL; + pf_useaccuratecaseforpaths = (PFUSEACCURATECASEFORPATHS) + ImportSymbol(GetNLMHandle(), (char *)"UseAccurateCaseForPaths"); + if (pf_useaccuratecaseforpaths) + (*pf_useaccuratecaseforpaths)(TRUE); + { + PFUNAUGMENTASTERISK pf_unaugmentasterisk = NULL; + pf_unaugmentasterisk = (PFUNAUGMENTASTERISK) + ImportSymbol(GetNLMHandle(), (char *)"UnAugmentAsterisk"); + if (pf_unaugmentasterisk) + (*pf_unaugmentasterisk)(TRUE); + } + } + } + + return; } @@ -516,94 +516,94 @@ void fnSetupNamespace(void) void fnLaunchPerl(void* context) { - char* defaultDir = NULL; - char curdir[_MAX_PATH] = {'\0'}; - ScriptData* psdata = (ScriptData *) context; - - unsigned int moduleHandle = 0; - int currentThreadGroupID = -1; - - #ifdef MPK_ON - kExitNetWare(); - #endif //MPK_ON - - errno = 0; - - if (psdata->m_fromConsole) - { - // get the default working directory name - // - defaultDir = fnNwGetEnvironmentStr("PERL_ROOT", NWDEFPERLROOT); - } - else - defaultDir = getcwd(curdir, sizeof(curdir)-1); - - // set long name space - // - fnSetupNamespace(); - - // make the working directory the current directory if from console - // - if (psdata->m_fromConsole) - chdir(defaultDir); - - // run the script - // - fnRunScript(psdata); - - // May have to check this, I am blindly calling UCSTerminate, irrespective of - // whether it is initialized or not - // Copied from the previous Perl - sgp - 31st Oct 2000 - moduleHandle = FindNLMHandle("UCSCORE.NLM"); - if (moduleHandle) - { - PFUCSTERMINATE ucsterminate = (PFUCSTERMINATE)ImportSymbol(moduleHandle, "therealUCSTerminate"); - if (ucsterminate!=NULL) - (*ucsterminate)(); - } - - if (psdata->m_fromConsole) - { - // change thread groups for the call to free the memory - // allocated before the new thread group was started - #ifdef MPK_ON - // For MPK_ON - #else - if (gThreadGroupID != -1) - currentThreadGroupID = SetThreadGroupID (gThreadGroupID); - #endif //MPK_ON - } - - // Free memory - if (psdata) - { - if(psdata->m_commandLine) - { - free(psdata->m_commandLine); - psdata->m_commandLine = NULL; - } - - free(psdata); - psdata = NULL; - context = NULL; - } - - #ifdef MPK_ON - // For MPK_ON - #else - if (currentThreadGroupID != -1) - SetThreadGroupID (currentThreadGroupID); - #endif //MPK_ON - - #ifdef MPK_ON + char* defaultDir = NULL; + char curdir[_MAX_PATH] = {'\0'}; + ScriptData* psdata = (ScriptData *) context; + + unsigned int moduleHandle = 0; + int currentThreadGroupID = -1; + + #ifdef MPK_ON + kExitNetWare(); + #endif //MPK_ON + + errno = 0; + + if (psdata->m_fromConsole) + { + // get the default working directory name + // + defaultDir = fnNwGetEnvironmentStr("PERL_ROOT", NWDEFPERLROOT); + } + else + defaultDir = getcwd(curdir, sizeof(curdir)-1); + + // set long name space + // + fnSetupNamespace(); + + // make the working directory the current directory if from console + // + if (psdata->m_fromConsole) + chdir(defaultDir); + + // run the script + // + fnRunScript(psdata); + + // May have to check this, I am blindly calling UCSTerminate, irrespective of + // whether it is initialized or not + // Copied from the previous Perl - sgp - 31st Oct 2000 + moduleHandle = FindNLMHandle("UCSCORE.NLM"); + if (moduleHandle) + { + PFUCSTERMINATE ucsterminate = (PFUCSTERMINATE)ImportSymbol(moduleHandle, "therealUCSTerminate"); + if (ucsterminate!=NULL) + (*ucsterminate)(); + } + + if (psdata->m_fromConsole) + { + // change thread groups for the call to free the memory + // allocated before the new thread group was started + #ifdef MPK_ON + // For MPK_ON + #else + if (gThreadGroupID != -1) + currentThreadGroupID = SetThreadGroupID (gThreadGroupID); + #endif //MPK_ON + } + + // Free memory + if (psdata) + { + if(psdata->m_commandLine) + { + free(psdata->m_commandLine); + psdata->m_commandLine = NULL; + } + + free(psdata); + psdata = NULL; + context = NULL; + } + + #ifdef MPK_ON + // For MPK_ON + #else + if (currentThreadGroupID != -1) + SetThreadGroupID (currentThreadGroupID); + #endif //MPK_ON + + #ifdef MPK_ON // kExitThread(NULL); - #else - // just let the thread terminate by falling off the end of the - // function started by BeginThreadGroup + #else + // just let the thread terminate by falling off the end of the + // function started by BeginThreadGroup // ExitThread(EXIT_THREAD, 0); - #endif + #endif - return; + return; } @@ -622,459 +622,459 @@ void fnLaunchPerl(void* context) void fnRunScript(ScriptData* psdata) { - char **av=NULL; - char **en=NULL; - int exitstatus = 1; - int i=0, j=0; - int *dummy = 0; - - PCOMMANDLINEPARSER pclp = NULL; - - // Set up the environment block. This will only work on - // on Moab; on 4.11 the environment block will be empty. - char** env = NULL; - - BOOL use_system_console = TRUE; - BOOL newscreen = FALSE; - int newscreenhandle = 0; - - // redirect stdin or stdout and run the script - FILE* redirOut = NULL; - FILE* redirIn = NULL; - FILE* redirErr = NULL; - FILE* stderr_fp = NULL; - - int stdin_fd=-1, stdin_fd_dup=-1; - int stdout_fd=-1, stdout_fd_dup=-1; - int stderr_fd=-1, stderr_fd_dup=-1; - - - // Main callback instance - // - if (fnRegisterWithThreadTable() == FALSE) - return; - - // parse the command line into argc/argv style: - // number of params and char array of params - // - pclp = (PCOMMANDLINEPARSER) malloc(sizeof(COMMANDLINEPARSER)); - if (!pclp) - { - fnUnregisterWithThreadTable(); - return; - } - - // Initialise the variables - pclp->m_isValid = TRUE; - pclp->m_redirInName = NULL; - pclp->m_redirOutName = NULL; - pclp->m_redirErrName = NULL; - pclp->m_redirBothName = NULL; - pclp->nextarg = NULL; - pclp->sSkippedToken = NULL; - pclp->m_argv = NULL; - pclp->new_argv = NULL; - - #ifdef MPK_ON - pclp->m_qSemaphore = NULL; - #else - pclp->m_qSemaphore = 0L; - #endif //MPK_ON - - pclp->m_noScreen = 0; - pclp->m_AutoDestroy = 0; - pclp->m_argc = 0; - pclp->m_argv_len = 1; - - // Allocate memory - pclp->m_argv = (char **) malloc(pclp->m_argv_len * sizeof(char *)); - if (pclp->m_argv == NULL) - { - free(pclp); - pclp = NULL; - - fnUnregisterWithThreadTable(); - return; - } - - pclp->m_argv[0] = (char *) malloc(MAX_DN_BYTES * sizeof(char)); - if (pclp->m_argv[0] == NULL) - { - free(pclp->m_argv); - pclp->m_argv=NULL; - - free(pclp); - pclp = NULL; - - fnUnregisterWithThreadTable(); - return; - } - - // Parse the command line - fnCommandLineParser(pclp, (char *)psdata->m_commandLine, FALSE); - if (!pclp->m_isValid) - { - if(pclp->m_argv) - { - for(i=0; im_argv_len; i++) - { - if(pclp->m_argv[i] != NULL) - { - free(pclp->m_argv[i]); - pclp->m_argv[i] = NULL; - } - } - - free(pclp->m_argv); - pclp->m_argv = NULL; - } - - if(pclp->nextarg) - { - free(pclp->nextarg); - pclp->nextarg = NULL; - } - if(pclp->sSkippedToken != NULL) - { - free(pclp->sSkippedToken); - pclp->sSkippedToken = NULL; - } - - if(pclp->m_redirInName) - { - free(pclp->m_redirInName); - pclp->m_redirInName = NULL; - } - if(pclp->m_redirOutName) - { - free(pclp->m_redirOutName); - pclp->m_redirOutName = NULL; - } - if(pclp->m_redirErrName) - { - free(pclp->m_redirErrName); - pclp->m_redirErrName = NULL; - } - if(pclp->m_redirBothName) - { - free(pclp->m_redirBothName); - pclp->m_redirBothName = NULL; - } - - // Signal a semaphore, if indicated by "-{" option, to indicate that - // the script has terminated and files are closed - // - if (pclp->m_qSemaphore != 0) - { - #ifdef MPK_ON - kSemaphoreSignal(pclp->m_qSemaphore); - #else - SignalLocalSemaphore(pclp->m_qSemaphore); - #endif //MPK_ON - } - - free(pclp); - pclp = NULL; - - fnUnregisterWithThreadTable(); - return; - } - - // Simulating a shell on NetWare can be difficult. If you don't - // create a new screen for the script to run in, you can output to - // the console but you can't get any input from the console. Therefore, - // every invocation of perl potentially needs its own screen unless - // you are running either "perl -h" or "perl -v" or you are redirecting - // stdin from a file. - // - // So we need to create a new screen and set that screen as the current - // screen when running any script launched from the console that is not - // "perl -h" or "perl -v" and is not redirecting stdin from a file. - // - // But it would be a little weird if we didn't create a new screen only - // in the case when redirecting stdin from a file; in only that case, - // stdout would be the console instead of a new screen. - // - // There is also the issue of standard err. In short, we might as well - // create a new screen no matter what is going on with redirection, just - // for the sake of consistency. - // - // In summary, we should a create a new screen and make that screen the - // current screen unless one of the following is true: - // * The command is "perl -h" - // * The command is "perl -v" - // * The script was launched by another perl script. In this case, - // the screen belonging to the parent perl script should probably be - // the same screen for this process. And it will be if use BeginThread - // instead of BeginThreadGroup when launching Perl from within a Perl - // script. - // - // In those cases where we create a new screen we should probably also display - // that screen. - // - - use_system_console = pclp->m_noScreen || - ((pclp->m_argc == 2) && (strcmp(pclp->m_argv[1], (char *)"-h") == 0)) || - ((pclp->m_argc == 2) && (strcmp(pclp->m_argv[1], (char *)"-v") == 0)); - - newscreen = (!use_system_console) && psdata->m_fromConsole; - - if (newscreen) - { - newscreenhandle = CreateScreen(sPerlScreenName, 0); - if (newscreenhandle) - DisplayScreen(newscreenhandle); - } - else if (use_system_console) - CreateScreen((char *)"System Console", 0); - - if (pclp->m_redirInName) - { - if ((stdin_fd = fileno(stdin)) != -1) - { - stdin_fd_dup = dup(stdin_fd); - if (stdin_fd_dup != -1) - { - redirIn = fdopen (stdin_fd_dup, (char const *)"r"); - if (redirIn) - stdin = freopen (pclp->m_redirInName, (char const *)"r", redirIn); - if (!stdin) - { - redirIn = NULL; - // undo the redirect, if possible - stdin = fdopen(stdin_fd, (char const *)"r"); - } - } - } - } - - /** - The below code stores the handle for the existing stdout to be used later and the existing stdout is closed. - stdout is then initialised to the new File pointer where the operations are done onto that. - Later (look below for the code), the saved stdout is restored back. - **/ - if (pclp->m_redirOutName) - { - if ((stdout_fd = fileno(stdout)) != -1) // Handle of the existing stdout. - { - stdout_fd_dup = dup(stdout_fd); - if (stdout_fd_dup != -1) - { - // Close the existing stdout. - fflush(stdout); // Write any unwritten data to the file. - - // New stdout - redirOut = fdopen (stdout_fd_dup, (char const *)"w"); - if (redirOut) - stdout = freopen (pclp->m_redirOutName, (char const *)"w", redirOut); - if (!stdout) - { - redirOut = NULL; - // Undo the redirection. - stdout = fdopen(stdout_fd, (char const *)"w"); - } - setbuf(stdout, NULL); // Unbuffered file pointer. - } - } - } - - if (pclp->m_redirErrName) - { - if ((stderr_fd = fileno(stderr)) != -1) - { - stderr_fd_dup = dup(stderr_fd); - if (stderr_fd_dup != -1) - { - fflush(stderr); - - redirErr = fdopen (stderr_fd_dup, (char const *)"w"); - if (redirErr) - stderr = freopen (pclp->m_redirErrName, (char const *)"w", redirErr); - if (!stderr) - { - redirErr = NULL; - // undo the redirect, if possible - stderr = fdopen(stderr_fd, (char const *)"w"); - } - setbuf(stderr, NULL); // Unbuffered file pointer. - } - } - } - - if (pclp->m_redirBothName) - { - if ((stdout_fd = fileno(stdout)) != -1) - { - stdout_fd_dup = dup(stdout_fd); - if (stdout_fd_dup != -1) - { - fflush(stdout); - - redirOut = fdopen (stdout_fd_dup, (char const *)"w"); - if (redirOut) - stdout = freopen (pclp->m_redirBothName, (char const *)"w", redirOut); - if (!stdout) - { - redirOut = NULL; - // undo the redirect, if possible - stdout = fdopen(stdout_fd, (char const *)"w"); - } - setbuf(stdout, NULL); // Unbuffered file pointer. - } - } - if ((stderr_fd = fileno(stderr)) != -1) - { - stderr_fp = stderr; - stderr = stdout; - } - } - - env = NULL; - fnSetUpEnvBlock(&env); // Set up the ENV block - - // Run the Perl script - exitstatus = RunPerl(pclp->m_argc, pclp->m_argv, env); - - // clean up any redirection - // - if (pclp->m_redirInName && redirIn) - { - fclose(stdin); - stdin = fdopen(stdin_fd, (char const *)"r"); // Put back the old handle for stdin. - } - - if (pclp->m_redirOutName && redirOut) - { - // Close the new stdout. - fflush(stdout); - fclose(stdout); - - // Put back the old handle for stdout. - stdout = fdopen(stdout_fd, (char const *)"w"); - setbuf(stdout, NULL); // Unbuffered file pointer. - } - - if (pclp->m_redirErrName && redirErr) - { - fflush(stderr); - fclose(stderr); - - stderr = fdopen(stderr_fd, (char const *)"w"); // Put back the old handle for stderr. - setbuf(stderr, NULL); // Unbuffered file pointer. - } - - if (pclp->m_redirBothName && redirOut) - { - stderr = stderr_fp; - - fflush(stdout); - fclose(stdout); - - stdout = fdopen(stdout_fd, (char const *)"w"); // Put back the old handle for stdout. - setbuf(stdout, NULL); // Unbuffered file pointer. - } - - - if (newscreen && newscreenhandle) - { - //added for --autodestroy switch - if(!pclp->m_AutoDestroy) - { - if ((redirOut == NULL) && (redirIn == NULL) && (!gKillAll)) - { - printf((char *)"\n\nPress any key to exit\n"); - getch(); - } - } - DestroyScreen(newscreenhandle); - } + char **av=NULL; + char **en=NULL; + int exitstatus = 1; + int i=0, j=0; + int *dummy = 0; + + PCOMMANDLINEPARSER pclp = NULL; + + // Set up the environment block. This will only work on + // on Moab; on 4.11 the environment block will be empty. + char** env = NULL; + + BOOL use_system_console = TRUE; + BOOL newscreen = FALSE; + int newscreenhandle = 0; + + // redirect stdin or stdout and run the script + FILE* redirOut = NULL; + FILE* redirIn = NULL; + FILE* redirErr = NULL; + FILE* stderr_fp = NULL; + + int stdin_fd=-1, stdin_fd_dup=-1; + int stdout_fd=-1, stdout_fd_dup=-1; + int stderr_fd=-1, stderr_fd_dup=-1; + + + // Main callback instance + // + if (fnRegisterWithThreadTable() == FALSE) + return; + + // parse the command line into argc/argv style: + // number of params and char array of params + // + pclp = (PCOMMANDLINEPARSER) malloc(sizeof(COMMANDLINEPARSER)); + if (!pclp) + { + fnUnregisterWithThreadTable(); + return; + } + + // Initialise the variables + pclp->m_isValid = TRUE; + pclp->m_redirInName = NULL; + pclp->m_redirOutName = NULL; + pclp->m_redirErrName = NULL; + pclp->m_redirBothName = NULL; + pclp->nextarg = NULL; + pclp->sSkippedToken = NULL; + pclp->m_argv = NULL; + pclp->new_argv = NULL; + + #ifdef MPK_ON + pclp->m_qSemaphore = NULL; + #else + pclp->m_qSemaphore = 0L; + #endif //MPK_ON + + pclp->m_noScreen = 0; + pclp->m_AutoDestroy = 0; + pclp->m_argc = 0; + pclp->m_argv_len = 1; + + // Allocate memory + pclp->m_argv = (char **) malloc(pclp->m_argv_len * sizeof(char *)); + if (pclp->m_argv == NULL) + { + free(pclp); + pclp = NULL; + + fnUnregisterWithThreadTable(); + return; + } + + pclp->m_argv[0] = (char *) malloc(MAX_DN_BYTES * sizeof(char)); + if (pclp->m_argv[0] == NULL) + { + free(pclp->m_argv); + pclp->m_argv=NULL; + + free(pclp); + pclp = NULL; + + fnUnregisterWithThreadTable(); + return; + } + + // Parse the command line + fnCommandLineParser(pclp, (char *)psdata->m_commandLine, FALSE); + if (!pclp->m_isValid) + { + if(pclp->m_argv) + { + for(i=0; im_argv_len; i++) + { + if(pclp->m_argv[i] != NULL) + { + free(pclp->m_argv[i]); + pclp->m_argv[i] = NULL; + } + } + + free(pclp->m_argv); + pclp->m_argv = NULL; + } + + if(pclp->nextarg) + { + free(pclp->nextarg); + pclp->nextarg = NULL; + } + if(pclp->sSkippedToken != NULL) + { + free(pclp->sSkippedToken); + pclp->sSkippedToken = NULL; + } + + if(pclp->m_redirInName) + { + free(pclp->m_redirInName); + pclp->m_redirInName = NULL; + } + if(pclp->m_redirOutName) + { + free(pclp->m_redirOutName); + pclp->m_redirOutName = NULL; + } + if(pclp->m_redirErrName) + { + free(pclp->m_redirErrName); + pclp->m_redirErrName = NULL; + } + if(pclp->m_redirBothName) + { + free(pclp->m_redirBothName); + pclp->m_redirBothName = NULL; + } + + // Signal a semaphore, if indicated by "-{" option, to indicate that + // the script has terminated and files are closed + // + if (pclp->m_qSemaphore != 0) + { + #ifdef MPK_ON + kSemaphoreSignal(pclp->m_qSemaphore); + #else + SignalLocalSemaphore(pclp->m_qSemaphore); + #endif //MPK_ON + } + + free(pclp); + pclp = NULL; + + fnUnregisterWithThreadTable(); + return; + } + + // Simulating a shell on NetWare can be difficult. If you don't + // create a new screen for the script to run in, you can output to + // the console but you can't get any input from the console. Therefore, + // every invocation of perl potentially needs its own screen unless + // you are running either "perl -h" or "perl -v" or you are redirecting + // stdin from a file. + // + // So we need to create a new screen and set that screen as the current + // screen when running any script launched from the console that is not + // "perl -h" or "perl -v" and is not redirecting stdin from a file. + // + // But it would be a little weird if we didn't create a new screen only + // in the case when redirecting stdin from a file; in only that case, + // stdout would be the console instead of a new screen. + // + // There is also the issue of standard err. In short, we might as well + // create a new screen no matter what is going on with redirection, just + // for the sake of consistency. + // + // In summary, we should a create a new screen and make that screen the + // current screen unless one of the following is true: + // * The command is "perl -h" + // * The command is "perl -v" + // * The script was launched by another perl script. In this case, + // the screen belonging to the parent perl script should probably be + // the same screen for this process. And it will be if use BeginThread + // instead of BeginThreadGroup when launching Perl from within a Perl + // script. + // + // In those cases where we create a new screen we should probably also display + // that screen. + // + + use_system_console = pclp->m_noScreen || + ((pclp->m_argc == 2) && (strcmp(pclp->m_argv[1], (char *)"-h") == 0)) || + ((pclp->m_argc == 2) && (strcmp(pclp->m_argv[1], (char *)"-v") == 0)); + + newscreen = (!use_system_console) && psdata->m_fromConsole; + + if (newscreen) + { + newscreenhandle = CreateScreen(sPerlScreenName, 0); + if (newscreenhandle) + DisplayScreen(newscreenhandle); + } + else if (use_system_console) + CreateScreen((char *)"System Console", 0); + + if (pclp->m_redirInName) + { + if ((stdin_fd = fileno(stdin)) != -1) + { + stdin_fd_dup = dup(stdin_fd); + if (stdin_fd_dup != -1) + { + redirIn = fdopen (stdin_fd_dup, (char const *)"r"); + if (redirIn) + stdin = freopen (pclp->m_redirInName, (char const *)"r", redirIn); + if (!stdin) + { + redirIn = NULL; + // undo the redirect, if possible + stdin = fdopen(stdin_fd, (char const *)"r"); + } + } + } + } + + /** + The below code stores the handle for the existing stdout to be used later and the existing stdout is closed. + stdout is then initialised to the new File pointer where the operations are done onto that. + Later (look below for the code), the saved stdout is restored back. + **/ + if (pclp->m_redirOutName) + { + if ((stdout_fd = fileno(stdout)) != -1) // Handle of the existing stdout. + { + stdout_fd_dup = dup(stdout_fd); + if (stdout_fd_dup != -1) + { + // Close the existing stdout. + fflush(stdout); // Write any unwritten data to the file. + + // New stdout + redirOut = fdopen (stdout_fd_dup, (char const *)"w"); + if (redirOut) + stdout = freopen (pclp->m_redirOutName, (char const *)"w", redirOut); + if (!stdout) + { + redirOut = NULL; + // Undo the redirection. + stdout = fdopen(stdout_fd, (char const *)"w"); + } + setbuf(stdout, NULL); // Unbuffered file pointer. + } + } + } + + if (pclp->m_redirErrName) + { + if ((stderr_fd = fileno(stderr)) != -1) + { + stderr_fd_dup = dup(stderr_fd); + if (stderr_fd_dup != -1) + { + fflush(stderr); + + redirErr = fdopen (stderr_fd_dup, (char const *)"w"); + if (redirErr) + stderr = freopen (pclp->m_redirErrName, (char const *)"w", redirErr); + if (!stderr) + { + redirErr = NULL; + // undo the redirect, if possible + stderr = fdopen(stderr_fd, (char const *)"w"); + } + setbuf(stderr, NULL); // Unbuffered file pointer. + } + } + } + + if (pclp->m_redirBothName) + { + if ((stdout_fd = fileno(stdout)) != -1) + { + stdout_fd_dup = dup(stdout_fd); + if (stdout_fd_dup != -1) + { + fflush(stdout); + + redirOut = fdopen (stdout_fd_dup, (char const *)"w"); + if (redirOut) + stdout = freopen (pclp->m_redirBothName, (char const *)"w", redirOut); + if (!stdout) + { + redirOut = NULL; + // undo the redirect, if possible + stdout = fdopen(stdout_fd, (char const *)"w"); + } + setbuf(stdout, NULL); // Unbuffered file pointer. + } + } + if ((stderr_fd = fileno(stderr)) != -1) + { + stderr_fp = stderr; + stderr = stdout; + } + } + + env = NULL; + fnSetUpEnvBlock(&env); // Set up the ENV block + + // Run the Perl script + exitstatus = RunPerl(pclp->m_argc, pclp->m_argv, env); + + // clean up any redirection + // + if (pclp->m_redirInName && redirIn) + { + fclose(stdin); + stdin = fdopen(stdin_fd, (char const *)"r"); // Put back the old handle for stdin. + } + + if (pclp->m_redirOutName && redirOut) + { + // Close the new stdout. + fflush(stdout); + fclose(stdout); + + // Put back the old handle for stdout. + stdout = fdopen(stdout_fd, (char const *)"w"); + setbuf(stdout, NULL); // Unbuffered file pointer. + } + + if (pclp->m_redirErrName && redirErr) + { + fflush(stderr); + fclose(stderr); + + stderr = fdopen(stderr_fd, (char const *)"w"); // Put back the old handle for stderr. + setbuf(stderr, NULL); // Unbuffered file pointer. + } + + if (pclp->m_redirBothName && redirOut) + { + stderr = stderr_fp; + + fflush(stdout); + fclose(stdout); + + stdout = fdopen(stdout_fd, (char const *)"w"); // Put back the old handle for stdout. + setbuf(stdout, NULL); // Unbuffered file pointer. + } + + + if (newscreen && newscreenhandle) + { + //added for --autodestroy switch + if(!pclp->m_AutoDestroy) + { + if ((redirOut == NULL) && (redirIn == NULL) && (!gKillAll)) + { + printf((char *)"\n\nPress any key to exit\n"); + getch(); + } + } + DestroyScreen(newscreenhandle); + } /** - // Commented since a few abends were happening in fnFpSetMode - // Set the mode for stdin and stdout - fnFpSetMode(stdin, O_TEXT, dummy); - fnFpSetMode(stdout, O_TEXT, dummy); + // Commented since a few abends were happening in fnFpSetMode + // Set the mode for stdin and stdout + fnFpSetMode(stdin, O_TEXT, dummy); + fnFpSetMode(stdout, O_TEXT, dummy); **/ - setmode(stdin, O_TEXT); - setmode(stdout, O_TEXT); - - // Cleanup - if(pclp->m_argv) - { - for(i=0; im_argv_len; i++) - { - if(pclp->m_argv[i] != NULL) - { - free(pclp->m_argv[i]); - pclp->m_argv[i] = NULL; - } - } - - free(pclp->m_argv); - pclp->m_argv = NULL; - } - - if(pclp->nextarg) - { - free(pclp->nextarg); - pclp->nextarg = NULL; - } - if(pclp->sSkippedToken != NULL) - { - free(pclp->sSkippedToken); - pclp->sSkippedToken = NULL; - } - - if(pclp->m_redirInName) - { - free(pclp->m_redirInName); - pclp->m_redirInName = NULL; - } - if(pclp->m_redirOutName) - { - free(pclp->m_redirOutName); - pclp->m_redirOutName = NULL; - } - if(pclp->m_redirErrName) - { - free(pclp->m_redirErrName); - pclp->m_redirErrName = NULL; - } - if(pclp->m_redirBothName) - { - free(pclp->m_redirBothName); - pclp->m_redirBothName = NULL; - } - - // Signal a semaphore, if indicated by -{ option, to indicate that - // the script has terminated and files are closed - // - if (pclp->m_qSemaphore != 0) - { - #ifdef MPK_ON - kSemaphoreSignal(pclp->m_qSemaphore); - #else - SignalLocalSemaphore(pclp->m_qSemaphore); - #endif //MPK_ON - } - - if(pclp) - { - free(pclp); - pclp = NULL; - } - - if(env) - { - fnDestroyEnvBlock(env); - env = NULL; - } - - fnUnregisterWithThreadTable(); - // Remove the thread context set during Perl_set_context - Remove_Thread_Ctx(); - - return; + setmode(stdin, O_TEXT); + setmode(stdout, O_TEXT); + + // Cleanup + if(pclp->m_argv) + { + for(i=0; im_argv_len; i++) + { + if(pclp->m_argv[i] != NULL) + { + free(pclp->m_argv[i]); + pclp->m_argv[i] = NULL; + } + } + + free(pclp->m_argv); + pclp->m_argv = NULL; + } + + if(pclp->nextarg) + { + free(pclp->nextarg); + pclp->nextarg = NULL; + } + if(pclp->sSkippedToken != NULL) + { + free(pclp->sSkippedToken); + pclp->sSkippedToken = NULL; + } + + if(pclp->m_redirInName) + { + free(pclp->m_redirInName); + pclp->m_redirInName = NULL; + } + if(pclp->m_redirOutName) + { + free(pclp->m_redirOutName); + pclp->m_redirOutName = NULL; + } + if(pclp->m_redirErrName) + { + free(pclp->m_redirErrName); + pclp->m_redirErrName = NULL; + } + if(pclp->m_redirBothName) + { + free(pclp->m_redirBothName); + pclp->m_redirBothName = NULL; + } + + // Signal a semaphore, if indicated by -{ option, to indicate that + // the script has terminated and files are closed + // + if (pclp->m_qSemaphore != 0) + { + #ifdef MPK_ON + kSemaphoreSignal(pclp->m_qSemaphore); + #else + SignalLocalSemaphore(pclp->m_qSemaphore); + #endif //MPK_ON + } + + if(pclp) + { + free(pclp); + pclp = NULL; + } + + if(env) + { + fnDestroyEnvBlock(env); + env = NULL; + } + + fnUnregisterWithThreadTable(); + // Remove the thread context set during Perl_set_context + Remove_Thread_Ctx(); + + return; } @@ -1093,74 +1093,74 @@ void fnRunScript(ScriptData* psdata) void fnSetUpEnvBlock(char*** penv) { - char** env = NULL; - - int sequence = 0; - char var[kMaxVariableNameLen+1] = {'\0'}; - char val[kMaxValueLen+1] = {'\0'}; - char both[kMaxVariableNameLen + kMaxValueLen + 5] = {'\0'}; - size_t len = kMaxValueLen; - int totalcnt = 0; - - while(scanenv( &sequence, var, &len, val )) - { - totalcnt++; - len = kMaxValueLen; - } - // add one for null termination - totalcnt++; - - env = (char **) malloc (totalcnt * sizeof(char *)); - if (env) - { - int cnt = 0; - int i = 0; - - sequence = 0; - len = kMaxValueLen; - - while( (cnt < (totalcnt-1)) && scanenv( &sequence, var, &len, val ) ) - { - val[len] = '\0'; - strcpy( both, var ); - strcat( both, (char *)"=" ); - strcat( both, val ); - - env[cnt] = (char *) malloc((sizeof(both)+1) * sizeof(char)); - if (env[cnt]) - { - strcpy(env[cnt], both); - cnt++; - } - else - { - for(i=0; im_commandLine = NULL; - psdata->m_commandLine = (char *) malloc(MAX_DN_BYTES * sizeof(char)); - - if(psdata->m_commandLine) - { - strcpy(psdata->m_commandLine, cmdLine); - psdata->m_fromConsole = FALSE; - - #ifdef MPK_ON - BeginThread(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata); - #else - // Start a new thread in its own thread group - BeginThread(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata); - #endif //MPK_ON - } - else - { - free(psdata); - psdata = NULL; - return; - } - } - else - return; - - return; + int currentThreadGroup = -1; + + ScriptData* psdata=NULL; + + // Create a safe copy of the command line and pass it to the + // new thread for parsing. The new thread will be responsible + // to delete it when it is finished with it. + psdata = (ScriptData *) malloc(sizeof(ScriptData)); + if (psdata) + { + psdata->m_commandLine = NULL; + psdata->m_commandLine = (char *) malloc(MAX_DN_BYTES * sizeof(char)); + + if(psdata->m_commandLine) + { + strcpy(psdata->m_commandLine, cmdLine); + psdata->m_fromConsole = FALSE; + + #ifdef MPK_ON + BeginThread(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata); + #else + // Start a new thread in its own thread group + BeginThread(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata); + #endif //MPK_ON + } + else + { + free(psdata); + psdata = NULL; + return; + } + } + else + return; + + return; } @@ -1315,7 +1315,7 @@ void fnInternalPerlLaunchHandler(char* cmdLine) Function : fnGetPerlScreenName Description : This function creates the Perl screen name. - Gets called from main only once when the Perl NLM loads. + Gets called from main only once when the Perl NLM loads. Parameters : sPerlScreenName (OUT) - Resultant Perl screen name. @@ -1325,30 +1325,30 @@ void fnInternalPerlLaunchHandler(char* cmdLine) void fnGetPerlScreenName(char *sPerlScreenName) { - // HYAK: - // The logic for using 32 in the below array sizes is like this: - // The NetWare CLIB SDK documentation says that for base 2 conversion, - // this number must be minimum 8. Also, in the example of the documentation, - // 20 is used as the size and testing is done for bases from 2 upto 16. - // So, to simply chose a number above 20 and also keeping in mind not to reserve - // unnecessary big array sizes, I have chosen 32 ! - // Less than that may also suffice. - char sPerlRevision[32 * sizeof(char)] = {'\0'}; - char sPerlVersion[32 * sizeof(char)] = {'\0'}; - char sPerlSubVersion[32 * sizeof(char)] = {'\0'}; - - // The defines for PERL_REVISION, PERL_VERSION, PERL_SUBVERSION are available in - // patchlevel.h under root and gets included when perl.h is included. - // The number 10 below indicates base 10. - itoa(PERL_REVISION, sPerlRevision, 10); - itoa(PERL_VERSION, sPerlVersion, 10); - itoa(PERL_SUBVERSION, sPerlSubVersion, 10); - - // Concatenate substrings to get a string like Perl5.6.1 which is used as the screen name. - sprintf(sPerlScreenName, "%s%s.%s.%s", PERL_COMMAND_NAME, - sPerlRevision, sPerlVersion, sPerlSubVersion); - - return; + // HYAK: + // The logic for using 32 in the below array sizes is like this: + // The NetWare CLIB SDK documentation says that for base 2 conversion, + // this number must be minimum 8. Also, in the example of the documentation, + // 20 is used as the size and testing is done for bases from 2 upto 16. + // So, to simply chose a number above 20 and also keeping in mind not to reserve + // unnecessary big array sizes, I have chosen 32 ! + // Less than that may also suffice. + char sPerlRevision[32 * sizeof(char)] = {'\0'}; + char sPerlVersion[32 * sizeof(char)] = {'\0'}; + char sPerlSubVersion[32 * sizeof(char)] = {'\0'}; + + // The defines for PERL_REVISION, PERL_VERSION, PERL_SUBVERSION are available in + // patchlevel.h under root and gets included when perl.h is included. + // The number 10 below indicates base 10. + itoa(PERL_REVISION, sPerlRevision, 10); + itoa(PERL_VERSION, sPerlVersion, 10); + itoa(PERL_SUBVERSION, sPerlSubVersion, 10); + + // Concatenate substrings to get a string like Perl5.6.1 which is used as the screen name. + sprintf(sPerlScreenName, "%s%s.%s.%s", PERL_COMMAND_NAME, + sPerlRevision, sPerlVersion, sPerlSubVersion); + + return; } @@ -1376,13 +1376,13 @@ char** genviron = NULL; char *** nw_getenviron() { - if (genviron) - return (&genviron); // This might leak memory upto 11736 bytes on some versions of NetWare. + if (genviron) + return (&genviron); // This might leak memory upto 11736 bytes on some versions of NetWare. // return genviron; // Abending on some versions of NetWare. - else - fnSetUpEnvBlock(&genviron); + else + fnSetUpEnvBlock(&genviron); - return (&genviron); + return (&genviron); } @@ -1402,10 +1402,10 @@ nw_getenviron() void nw_freeenviron() { - if (genviron) - { - fnDestroyEnvBlock(genviron); - genviron=NULL; - } + if (genviron) + { + fnDestroyEnvBlock(genviron); + genviron=NULL; + } } diff --git a/NetWare/Nwpipe.c b/NetWare/Nwpipe.c index ce9c19800d63..154ee096968c 100644 --- a/NetWare/Nwpipe.c +++ b/NetWare/Nwpipe.c @@ -52,111 +52,111 @@ BOOL fnPipeFileMakeArgv(PTEMPPIPEFILE ptpf) { - int i=0, j=0; - int dindex = 0; - int sindex = 0; - - ptpf->m_argv_len = 0; - - - // Below 2 is added for the following reason: - // - The first one is for an additional value that will be added through ptpf->m_redirect. - // - The second one is for a NULL termination of the array. - // This is required for spawnvp API that takes a NULL-terminated array as its 3rd parameter. - // If the array is NOT NULL-terminated, then the server abends at the spawnvp call !! - ptpf->m_argv = (char **) malloc((ptpf->m_pipeCommand->m_argc + 2) * sizeof(char*)); - if (ptpf->m_argv == NULL) - return FALSE; - - // For memory allocation it is just +1 since the last one is only for NULL-termination - // and no memory is required to be allocated. - for(i=0; i<(ptpf->m_pipeCommand->m_argc + 1); i++) - { - ptpf->m_argv[i] = (char *) malloc(MAX_DN_BYTES * sizeof(char)); - if (ptpf->m_argv[i] == NULL) - { - for(j=0; jm_argv[j]) - { - free(ptpf->m_argv[j]); - ptpf->m_argv[j] = NULL; - } - } - free(ptpf->m_argv); - ptpf->m_argv = NULL; - - return FALSE; - } - } - - // Copy over parsed items, removing "load" keyword if necessary. - sindex = ((stricmp(ptpf->m_pipeCommand->m_argv[0], LOAD_COMMAND) == 0) ? 1 : 0); - while (sindex < ptpf->m_pipeCommand->m_argc) - { - strcpy(ptpf->m_argv[dindex], ptpf->m_pipeCommand->m_argv[sindex]); - dindex++; - sindex++; - } - - if (stricmp(ptpf->m_argv[0], PERL_COMMAND_NAME) == 0) // If Perl is the first command. - { - ptpf->m_launchPerl = TRUE; - - #ifdef MPK_ON - ptpf->m_perlSynchSemaphore = kSemaphoreAlloc((BYTE *)"pipeSemaphore", 0); - #else - ptpf->m_perlSynchSemaphore = OpenLocalSemaphore(0); - #endif //MPK_ON - } - else if (stricmp(ptpf->m_argv[0], (char *)"perlglob") == 0) - ptpf->m_doPerlGlob = TRUE; - - - // Create last argument, which will redirect to or from the temp file - if (!ptpf->m_doPerlGlob || ptpf->m_mode) - { - if (!ptpf->m_mode) // If read mode? - { - if (ptpf->m_launchPerl) - strcpy(ptpf->m_redirect, (char *)">"); - else - strcpy(ptpf->m_redirect, (char *)"(CLIB_OPT)/>"); - } - else - { - if (ptpf->m_launchPerl) - strcpy(ptpf->m_redirect, (char *)"<"); - else - strcpy(ptpf->m_redirect, (char *)"(CLIB_OPT)/<"); - } - strcat(ptpf->m_redirect, ptpf->m_fileName); - - if (ptpf->m_launchPerl) - { - char tbuf[15] = {'\0'}; - sprintf(tbuf, (char *)" -{%x", ptpf->m_perlSynchSemaphore); - strcat(ptpf->m_redirect, tbuf); - } - - strcpy(ptpf->m_argv[dindex], (char*) ptpf->m_redirect); - dindex++; - } - - if (dindex < (ptpf->m_pipeCommand->m_argc + 1)) - { - if(ptpf->m_argv[dindex]) - { - free(ptpf->m_argv[dindex]); - ptpf->m_argv[dindex] = NULL; // NULL termination - required for spawnvp call. - } - } - - ptpf->m_argv_len = dindex; // Length of the argv array OR number of argv string values. - ptpf->m_argv[ptpf->m_argv_len] = NULL; // NULL termination - required for spawnvp call. - - - return TRUE; + int i=0, j=0; + int dindex = 0; + int sindex = 0; + + ptpf->m_argv_len = 0; + + + // Below 2 is added for the following reason: + // - The first one is for an additional value that will be added through ptpf->m_redirect. + // - The second one is for a NULL termination of the array. + // This is required for spawnvp API that takes a NULL-terminated array as its 3rd parameter. + // If the array is NOT NULL-terminated, then the server abends at the spawnvp call !! + ptpf->m_argv = (char **) malloc((ptpf->m_pipeCommand->m_argc + 2) * sizeof(char*)); + if (ptpf->m_argv == NULL) + return FALSE; + + // For memory allocation it is just +1 since the last one is only for NULL-termination + // and no memory is required to be allocated. + for(i=0; i<(ptpf->m_pipeCommand->m_argc + 1); i++) + { + ptpf->m_argv[i] = (char *) malloc(MAX_DN_BYTES * sizeof(char)); + if (ptpf->m_argv[i] == NULL) + { + for(j=0; jm_argv[j]) + { + free(ptpf->m_argv[j]); + ptpf->m_argv[j] = NULL; + } + } + free(ptpf->m_argv); + ptpf->m_argv = NULL; + + return FALSE; + } + } + + // Copy over parsed items, removing "load" keyword if necessary. + sindex = ((stricmp(ptpf->m_pipeCommand->m_argv[0], LOAD_COMMAND) == 0) ? 1 : 0); + while (sindex < ptpf->m_pipeCommand->m_argc) + { + strcpy(ptpf->m_argv[dindex], ptpf->m_pipeCommand->m_argv[sindex]); + dindex++; + sindex++; + } + + if (stricmp(ptpf->m_argv[0], PERL_COMMAND_NAME) == 0) // If Perl is the first command. + { + ptpf->m_launchPerl = TRUE; + + #ifdef MPK_ON + ptpf->m_perlSynchSemaphore = kSemaphoreAlloc((BYTE *)"pipeSemaphore", 0); + #else + ptpf->m_perlSynchSemaphore = OpenLocalSemaphore(0); + #endif //MPK_ON + } + else if (stricmp(ptpf->m_argv[0], (char *)"perlglob") == 0) + ptpf->m_doPerlGlob = TRUE; + + + // Create last argument, which will redirect to or from the temp file + if (!ptpf->m_doPerlGlob || ptpf->m_mode) + { + if (!ptpf->m_mode) // If read mode? + { + if (ptpf->m_launchPerl) + strcpy(ptpf->m_redirect, (char *)">"); + else + strcpy(ptpf->m_redirect, (char *)"(CLIB_OPT)/>"); + } + else + { + if (ptpf->m_launchPerl) + strcpy(ptpf->m_redirect, (char *)"<"); + else + strcpy(ptpf->m_redirect, (char *)"(CLIB_OPT)/<"); + } + strcat(ptpf->m_redirect, ptpf->m_fileName); + + if (ptpf->m_launchPerl) + { + char tbuf[15] = {'\0'}; + sprintf(tbuf, (char *)" -{%x", ptpf->m_perlSynchSemaphore); + strcat(ptpf->m_redirect, tbuf); + } + + strcpy(ptpf->m_argv[dindex], (char*) ptpf->m_redirect); + dindex++; + } + + if (dindex < (ptpf->m_pipeCommand->m_argc + 1)) + { + if(ptpf->m_argv[dindex]) + { + free(ptpf->m_argv[dindex]); + ptpf->m_argv[dindex] = NULL; // NULL termination - required for spawnvp call. + } + } + + ptpf->m_argv_len = dindex; // Length of the argv array OR number of argv string values. + ptpf->m_argv[ptpf->m_argv_len] = NULL; // NULL termination - required for spawnvp call. + + + return TRUE; } @@ -167,8 +167,8 @@ BOOL fnPipeFileMakeArgv(PTEMPPIPEFILE ptpf) Description : This function opens the pipe file. Parameters : ptpf (IN) - Input structure. - command (IN) - Input command string. - mode (IN) - Mode of opening. + command (IN) - Input command string. + mode (IN) - Mode of opening. Returns : File pointer. @@ -176,281 +176,281 @@ BOOL fnPipeFileMakeArgv(PTEMPPIPEFILE ptpf) FILE* fnPipeFileOpen(PTEMPPIPEFILE ptpf, char* command, char* mode) { - int i=0, j=0; + int i=0, j=0; - char tempName[_MAX_PATH] = {'\0'}; + char tempName[_MAX_PATH] = {'\0'}; - ptpf->m_fileName = (char *) malloc(_MAX_PATH * sizeof(char)); - if(ptpf->m_fileName == NULL) - return NULL; + ptpf->m_fileName = (char *) malloc(_MAX_PATH * sizeof(char)); + if(ptpf->m_fileName == NULL) + return NULL; - // The char array is emptied so that there is no junk characters. - strncpy(ptpf->m_fileName, "", (_MAX_PATH * sizeof(char))); - + // The char array is emptied so that there is no junk characters. + strncpy(ptpf->m_fileName, "", (_MAX_PATH * sizeof(char))); + - // Save off stuff - // - if(strchr(mode,'r') != 0) - ptpf->m_mode = FALSE; // Read mode - else if(strchr(mode,'w') != 0) - ptpf->m_mode = TRUE; // Write mode - else - { - if(ptpf->m_fileName != NULL) - { + // Save off stuff + // + if(strchr(mode,'r') != 0) + ptpf->m_mode = FALSE; // Read mode + else if(strchr(mode,'w') != 0) + ptpf->m_mode = TRUE; // Write mode + else + { + if(ptpf->m_fileName != NULL) + { // if (strlen(ptpf->m_fileName)) - if (ptpf->m_fileName) - unlink(ptpf->m_fileName); + if (ptpf->m_fileName) + unlink(ptpf->m_fileName); - free(ptpf->m_fileName); - ptpf->m_fileName = NULL; - } + free(ptpf->m_fileName); + ptpf->m_fileName = NULL; + } - return NULL; - } + return NULL; + } - ptpf->m_pipeCommand = (PCOMMANDLINEPARSER) malloc(sizeof(COMMANDLINEPARSER)); - if (!ptpf->m_pipeCommand) - { + ptpf->m_pipeCommand = (PCOMMANDLINEPARSER) malloc(sizeof(COMMANDLINEPARSER)); + if (!ptpf->m_pipeCommand) + { // if (strlen(ptpf->m_fileName)) - if (ptpf->m_fileName) - unlink(ptpf->m_fileName); + if (ptpf->m_fileName) + unlink(ptpf->m_fileName); - free(ptpf->m_fileName); - ptpf->m_fileName = NULL; + free(ptpf->m_fileName); + ptpf->m_fileName = NULL; - return NULL; - } + return NULL; + } - // Initialise the variables - ptpf->m_pipeCommand->m_isValid = TRUE; + // Initialise the variables + ptpf->m_pipeCommand->m_isValid = TRUE; /**** // Commented since these are not being used. Still retained here. // To be removed once things are proved to be working fine to a good confident level, - ptpf->m_pipeCommand->m_redirInName = NULL; - ptpf->m_pipeCommand->m_redirOutName = NULL; - ptpf->m_pipeCommand->m_redirErrName = NULL; - ptpf->m_pipeCommand->m_redirBothName = NULL; - ptpf->m_pipeCommand->nextarg = NULL; + ptpf->m_pipeCommand->m_redirInName = NULL; + ptpf->m_pipeCommand->m_redirOutName = NULL; + ptpf->m_pipeCommand->m_redirErrName = NULL; + ptpf->m_pipeCommand->m_redirBothName = NULL; + ptpf->m_pipeCommand->nextarg = NULL; ****/ - ptpf->m_pipeCommand->sSkippedToken = NULL; - ptpf->m_pipeCommand->m_argv = NULL; - ptpf->m_pipeCommand->new_argv = NULL; + ptpf->m_pipeCommand->sSkippedToken = NULL; + ptpf->m_pipeCommand->m_argv = NULL; + ptpf->m_pipeCommand->new_argv = NULL; - #ifdef MPK_ON - ptpf->m_pipeCommand->m_qSemaphore = NULL; - #else - ptpf->m_pipeCommand->m_qSemaphore = 0L; - #endif //MPK_ON + #ifdef MPK_ON + ptpf->m_pipeCommand->m_qSemaphore = NULL; + #else + ptpf->m_pipeCommand->m_qSemaphore = 0L; + #endif //MPK_ON - ptpf->m_pipeCommand->m_noScreen = 0; - ptpf->m_pipeCommand->m_AutoDestroy = 0; - ptpf->m_pipeCommand->m_argc = 0; - ptpf->m_pipeCommand->m_argv_len = 1; + ptpf->m_pipeCommand->m_noScreen = 0; + ptpf->m_pipeCommand->m_AutoDestroy = 0; + ptpf->m_pipeCommand->m_argc = 0; + ptpf->m_pipeCommand->m_argv_len = 1; - ptpf->m_pipeCommand->m_argv = (char **) malloc(ptpf->m_pipeCommand->m_argv_len * sizeof(char *)); - if (ptpf->m_pipeCommand->m_argv == NULL) - { - free(ptpf->m_pipeCommand); - ptpf->m_pipeCommand = NULL; + ptpf->m_pipeCommand->m_argv = (char **) malloc(ptpf->m_pipeCommand->m_argv_len * sizeof(char *)); + if (ptpf->m_pipeCommand->m_argv == NULL) + { + free(ptpf->m_pipeCommand); + ptpf->m_pipeCommand = NULL; // if (strlen(ptpf->m_fileName)) - if (ptpf->m_fileName) - unlink(ptpf->m_fileName); - - free(ptpf->m_fileName); - ptpf->m_fileName = NULL; - - return NULL; - } - ptpf->m_pipeCommand->m_argv[0] = (char *) malloc(MAX_DN_BYTES * sizeof(char)); - if (ptpf->m_pipeCommand->m_argv[0] == NULL) - { - for(j=0; jm_pipeCommand->m_argv[j]) - { - free(ptpf->m_pipeCommand->m_argv[j]); - ptpf->m_pipeCommand->m_argv[j]=NULL; - } - } - free(ptpf->m_pipeCommand->m_argv); - ptpf->m_pipeCommand->m_argv=NULL; - - free(ptpf->m_pipeCommand); - ptpf->m_pipeCommand = NULL; + if (ptpf->m_fileName) + unlink(ptpf->m_fileName); + + free(ptpf->m_fileName); + ptpf->m_fileName = NULL; + + return NULL; + } + ptpf->m_pipeCommand->m_argv[0] = (char *) malloc(MAX_DN_BYTES * sizeof(char)); + if (ptpf->m_pipeCommand->m_argv[0] == NULL) + { + for(j=0; jm_pipeCommand->m_argv[j]) + { + free(ptpf->m_pipeCommand->m_argv[j]); + ptpf->m_pipeCommand->m_argv[j]=NULL; + } + } + free(ptpf->m_pipeCommand->m_argv); + ptpf->m_pipeCommand->m_argv=NULL; + + free(ptpf->m_pipeCommand); + ptpf->m_pipeCommand = NULL; // if (strlen(ptpf->m_fileName)) - if (ptpf->m_fileName) - unlink(ptpf->m_fileName); + if (ptpf->m_fileName) + unlink(ptpf->m_fileName); - free(ptpf->m_fileName); - ptpf->m_fileName = NULL; + free(ptpf->m_fileName); + ptpf->m_fileName = NULL; - return NULL; - } + return NULL; + } - ptpf->m_redirect = (char *) malloc(MAX_DN_BYTES * sizeof(char)); - if (ptpf->m_redirect == NULL) - { - for(i=0; im_pipeCommand->m_argv_len; i++) - { - if(ptpf->m_pipeCommand->m_argv[i] != NULL) - { - free(ptpf->m_pipeCommand->m_argv[i]); - ptpf->m_pipeCommand->m_argv[i] = NULL; - } - } + ptpf->m_redirect = (char *) malloc(MAX_DN_BYTES * sizeof(char)); + if (ptpf->m_redirect == NULL) + { + for(i=0; im_pipeCommand->m_argv_len; i++) + { + if(ptpf->m_pipeCommand->m_argv[i] != NULL) + { + free(ptpf->m_pipeCommand->m_argv[i]); + ptpf->m_pipeCommand->m_argv[i] = NULL; + } + } - free(ptpf->m_pipeCommand->m_argv); - ptpf->m_pipeCommand->m_argv = NULL; + free(ptpf->m_pipeCommand->m_argv); + ptpf->m_pipeCommand->m_argv = NULL; - free(ptpf->m_pipeCommand); - ptpf->m_pipeCommand = NULL; + free(ptpf->m_pipeCommand); + ptpf->m_pipeCommand = NULL; // if (strlen(ptpf->m_fileName)) - if (ptpf->m_fileName) - unlink(ptpf->m_fileName); - - free(ptpf->m_fileName); - ptpf->m_fileName = NULL; - - return NULL; - } - - // The char array is emptied. - // If it is not done so, then it could contain some junk values and the string length in that case - // will not be zero. This causes erroneous results in fnPipeFileMakeArgv() function - // where strlen(ptpf->m_redirect) is used as a check for incrementing the parameter count and - // it will wrongly get incremented in such cases. - strncpy(ptpf->m_redirect, "", (MAX_DN_BYTES * sizeof(char))); - - // Parse the parameters. - fnCommandLineParser(ptpf->m_pipeCommand, (char *)command, TRUE); - if (!ptpf->m_pipeCommand->m_isValid) - { - fnTempPipeFileReleaseMemory(ptpf); - return NULL; - } - - - // Create a temporary file name - // - strncpy ( tempName, fnNwGetEnvironmentStr((char *)"TEMP", NWDEFPERLTEMP), (_MAX_PATH - 20) ); - tempName[_MAX_PATH-20] = '\0'; - strcat(tempName, (char *)"\\plXXXXXX.tmp"); - if (!fnMy_MkTemp(tempName)) - { - fnTempPipeFileReleaseMemory(ptpf); - return NULL; - } - - // create a temporary place-holder file - fclose(fopen(tempName, (char *)"w")); - strcpy(ptpf->m_fileName, tempName); - - - // Make the argument array - if(!fnPipeFileMakeArgv(ptpf)) - { - fnTempPipeFileReleaseMemory(ptpf); - - // Release additional memory - if(ptpf->m_argv != NULL) - { - for(i=0; im_argv_len; i++) - { - if(ptpf->m_argv[i] != NULL) - { - free(ptpf->m_argv[i]); - ptpf->m_argv[i] = NULL; - } - } - - free(ptpf->m_argv); - ptpf->m_argv = NULL; - } - - return NULL; - } - - - // Open the temp file in the appropriate way... - // - if (!ptpf->m_mode) // If Read mode? - { - // we wish to spawn a command, intercept its output, - // and then get that output - // - if (!ptpf->m_argv[0]) - { - fnTempPipeFileReleaseMemory(ptpf); - - // Release additional memory - if(ptpf->m_argv != NULL) - { - for(i=0; im_argv_len; i++) - { - if(ptpf->m_argv[i] != NULL) - { - free(ptpf->m_argv[i]); - ptpf->m_argv[i] = NULL; - } - } - - free(ptpf->m_argv); - ptpf->m_argv = NULL; - } - - return NULL; - } - - if (ptpf->m_launchPerl) - fnPipeFileDoPerlLaunch(ptpf); - else - if (ptpf->m_doPerlGlob) - fnDoPerlGlob(ptpf->m_argv, ptpf->m_fileName); // hack to do perl globbing - else - spawnvp(P_WAIT, ptpf->m_argv[0], ptpf->m_argv); - - ptpf->m_file = fopen (ptpf->m_fileName, (char *)"r"); // Get the Pipe file handle - } - else if (ptpf->m_mode) // If Write mode? - { - // we wish to open the file for writing now and - // do the command later - // - ptpf->m_file = fopen(ptpf->m_fileName, (char *)"w"); - } - - fnTempPipeFileReleaseMemory(ptpf); - - // Release additional memory - if(ptpf->m_argv != NULL) - { - for(i=0; i<(ptpf->m_argv_len); i++) - { - if(ptpf->m_argv[i] != NULL) - { - free(ptpf->m_argv[i]); - ptpf->m_argv[i] = NULL; - } - } - - free(ptpf->m_argv); - ptpf->m_argv = NULL; - } - - - return ptpf->m_file; // Return the Pipe file handle. + if (ptpf->m_fileName) + unlink(ptpf->m_fileName); + + free(ptpf->m_fileName); + ptpf->m_fileName = NULL; + + return NULL; + } + + // The char array is emptied. + // If it is not done so, then it could contain some junk values and the string length in that case + // will not be zero. This causes erroneous results in fnPipeFileMakeArgv() function + // where strlen(ptpf->m_redirect) is used as a check for incrementing the parameter count and + // it will wrongly get incremented in such cases. + strncpy(ptpf->m_redirect, "", (MAX_DN_BYTES * sizeof(char))); + + // Parse the parameters. + fnCommandLineParser(ptpf->m_pipeCommand, (char *)command, TRUE); + if (!ptpf->m_pipeCommand->m_isValid) + { + fnTempPipeFileReleaseMemory(ptpf); + return NULL; + } + + + // Create a temporary file name + // + strncpy ( tempName, fnNwGetEnvironmentStr((char *)"TEMP", NWDEFPERLTEMP), (_MAX_PATH - 20) ); + tempName[_MAX_PATH-20] = '\0'; + strcat(tempName, (char *)"\\plXXXXXX.tmp"); + if (!fnMy_MkTemp(tempName)) + { + fnTempPipeFileReleaseMemory(ptpf); + return NULL; + } + + // create a temporary place-holder file + fclose(fopen(tempName, (char *)"w")); + strcpy(ptpf->m_fileName, tempName); + + + // Make the argument array + if(!fnPipeFileMakeArgv(ptpf)) + { + fnTempPipeFileReleaseMemory(ptpf); + + // Release additional memory + if(ptpf->m_argv != NULL) + { + for(i=0; im_argv_len; i++) + { + if(ptpf->m_argv[i] != NULL) + { + free(ptpf->m_argv[i]); + ptpf->m_argv[i] = NULL; + } + } + + free(ptpf->m_argv); + ptpf->m_argv = NULL; + } + + return NULL; + } + + + // Open the temp file in the appropriate way... + // + if (!ptpf->m_mode) // If Read mode? + { + // we wish to spawn a command, intercept its output, + // and then get that output + // + if (!ptpf->m_argv[0]) + { + fnTempPipeFileReleaseMemory(ptpf); + + // Release additional memory + if(ptpf->m_argv != NULL) + { + for(i=0; im_argv_len; i++) + { + if(ptpf->m_argv[i] != NULL) + { + free(ptpf->m_argv[i]); + ptpf->m_argv[i] = NULL; + } + } + + free(ptpf->m_argv); + ptpf->m_argv = NULL; + } + + return NULL; + } + + if (ptpf->m_launchPerl) + fnPipeFileDoPerlLaunch(ptpf); + else + if (ptpf->m_doPerlGlob) + fnDoPerlGlob(ptpf->m_argv, ptpf->m_fileName); // hack to do perl globbing + else + spawnvp(P_WAIT, ptpf->m_argv[0], ptpf->m_argv); + + ptpf->m_file = fopen (ptpf->m_fileName, (char *)"r"); // Get the Pipe file handle + } + else if (ptpf->m_mode) // If Write mode? + { + // we wish to open the file for writing now and + // do the command later + // + ptpf->m_file = fopen(ptpf->m_fileName, (char *)"w"); + } + + fnTempPipeFileReleaseMemory(ptpf); + + // Release additional memory + if(ptpf->m_argv != NULL) + { + for(i=0; i<(ptpf->m_argv_len); i++) + { + if(ptpf->m_argv[i] != NULL) + { + free(ptpf->m_argv[i]); + ptpf->m_argv[i] = NULL; + } + } + + free(ptpf->m_argv); + ptpf->m_argv = NULL; + } + + + return ptpf->m_file; // Return the Pipe file handle. } @@ -468,71 +468,71 @@ FILE* fnPipeFileOpen(PTEMPPIPEFILE ptpf, char* command, char* mode) void fnPipeFileClose(PTEMPPIPEFILE ptpf) { - int i = 0; - - if (ptpf->m_mode) // If Write mode? - { - // we wish to spawn a command using our temp file for - // its input - // - if(ptpf->m_file != NULL) - { - fclose (ptpf->m_file); - ptpf->m_file = NULL; - } - - if (ptpf->m_launchPerl) - fnPipeFileDoPerlLaunch(ptpf); - else if (ptpf->m_argv) - spawnvp(P_WAIT, ptpf->m_argv[0], ptpf->m_argv); - } - - - // Close the temporary Pipe File, if opened - if (ptpf->m_file) - { - fclose(ptpf->m_file); - ptpf->m_file = NULL; - } - // Delete the temporary Pipe Filename if still valid and free the memory associated with the file name. - if(ptpf->m_fileName != NULL) - { + int i = 0; + + if (ptpf->m_mode) // If Write mode? + { + // we wish to spawn a command using our temp file for + // its input + // + if(ptpf->m_file != NULL) + { + fclose (ptpf->m_file); + ptpf->m_file = NULL; + } + + if (ptpf->m_launchPerl) + fnPipeFileDoPerlLaunch(ptpf); + else if (ptpf->m_argv) + spawnvp(P_WAIT, ptpf->m_argv[0], ptpf->m_argv); + } + + + // Close the temporary Pipe File, if opened + if (ptpf->m_file) + { + fclose(ptpf->m_file); + ptpf->m_file = NULL; + } + // Delete the temporary Pipe Filename if still valid and free the memory associated with the file name. + if(ptpf->m_fileName != NULL) + { // if (strlen(ptpf->m_fileName)) - if (ptpf->m_fileName) - unlink(ptpf->m_fileName); + if (ptpf->m_fileName) + unlink(ptpf->m_fileName); - free(ptpf->m_fileName); - ptpf->m_fileName = NULL; - } + free(ptpf->m_fileName); + ptpf->m_fileName = NULL; + } /** - if(ptpf->m_argv != NULL) - { - for(i=0; i<(ptpf->m_argv_len); i++) - { - if(ptpf->m_argv[i] != NULL) - { - free(ptpf->m_argv[i]); - ptpf->m_argv[i] = NULL; - } - } - - free(ptpf->m_argv); - ptpf->m_argv = NULL; - } + if(ptpf->m_argv != NULL) + { + for(i=0; i<(ptpf->m_argv_len); i++) + { + if(ptpf->m_argv[i] != NULL) + { + free(ptpf->m_argv[i]); + ptpf->m_argv[i] = NULL; + } + } + + free(ptpf->m_argv); + ptpf->m_argv = NULL; + } **/ - if (ptpf->m_perlSynchSemaphore) - { - #ifdef MPK_ON - kSemaphoreFree(ptpf->m_perlSynchSemaphore); - #else - CloseLocalSemaphore(ptpf->m_perlSynchSemaphore); - #endif //MPK_ON - } + if (ptpf->m_perlSynchSemaphore) + { + #ifdef MPK_ON + kSemaphoreFree(ptpf->m_perlSynchSemaphore); + #else + CloseLocalSemaphore(ptpf->m_perlSynchSemaphore); + #endif //MPK_ON + } - return; + return; } @@ -550,30 +550,30 @@ void fnPipeFileClose(PTEMPPIPEFILE ptpf) void fnPipeFileDoPerlLaunch(PTEMPPIPEFILE ptpf) { - char curdir[_MAX_PATH] = {'\0'}; - char* pcwd = NULL; - - int i=0; - - - // save off the current working directory to restore later - // this is just a hack! these problems of synchronization and - // restoring calling context need a much better solution! - pcwd = (char *)getcwd(curdir, sizeof(curdir)-1); - fnSystemCommand(ptpf->m_argv, ptpf->m_argv_len); - if (ptpf->m_perlSynchSemaphore) - { - #ifdef MPK_ON - kSemaphoreWait(ptpf->m_perlSynchSemaphore); - #else - WaitOnLocalSemaphore(ptpf->m_perlSynchSemaphore); - #endif //MPK_ON - } - - if (pcwd) - chdir(pcwd); - - return; + char curdir[_MAX_PATH] = {'\0'}; + char* pcwd = NULL; + + int i=0; + + + // save off the current working directory to restore later + // this is just a hack! these problems of synchronization and + // restoring calling context need a much better solution! + pcwd = (char *)getcwd(curdir, sizeof(curdir)-1); + fnSystemCommand(ptpf->m_argv, ptpf->m_argv_len); + if (ptpf->m_perlSynchSemaphore) + { + #ifdef MPK_ON + kSemaphoreWait(ptpf->m_perlSynchSemaphore); + #else + WaitOnLocalSemaphore(ptpf->m_perlSynchSemaphore); + #endif //MPK_ON + } + + if (pcwd) + chdir(pcwd); + + return; } @@ -591,27 +591,27 @@ void fnPipeFileDoPerlLaunch(PTEMPPIPEFILE ptpf) void fnTempPipeFile(PTEMPPIPEFILE ptpf) { - ptpf->m_fileName = NULL; + ptpf->m_fileName = NULL; - ptpf->m_mode = FALSE; // Default mode = Read mode. - ptpf->m_file = NULL; - ptpf->m_pipeCommand = NULL; - ptpf->m_argv = NULL; + ptpf->m_mode = FALSE; // Default mode = Read mode. + ptpf->m_file = NULL; + ptpf->m_pipeCommand = NULL; + ptpf->m_argv = NULL; - ptpf->m_redirect = NULL; + ptpf->m_redirect = NULL; - ptpf->m_launchPerl = FALSE; - ptpf->m_doPerlGlob = FALSE; + ptpf->m_launchPerl = FALSE; + ptpf->m_doPerlGlob = FALSE; - #ifdef MPK_ON - ptpf->m_perlSynchSemaphore = NULL; - #else - ptpf->m_perlSynchSemaphore = 0L; - #endif + #ifdef MPK_ON + ptpf->m_perlSynchSemaphore = NULL; + #else + ptpf->m_perlSynchSemaphore = 0L; + #endif - ptpf->m_argv_len = 0; + ptpf->m_argv_len = 0; - return; + return; } @@ -629,76 +629,76 @@ void fnTempPipeFile(PTEMPPIPEFILE ptpf) void fnTempPipeFileReleaseMemory(PTEMPPIPEFILE ptpf) { - int i=0; - - - if (ptpf->m_pipeCommand) - { - if(ptpf->m_pipeCommand->m_argv != NULL) - { - for(i=0; im_pipeCommand->m_argv_len; i++) - { - if(ptpf->m_pipeCommand->m_argv[i] != NULL) - { - free(ptpf->m_pipeCommand->m_argv[i]); - ptpf->m_pipeCommand->m_argv[i] = NULL; - } - } - - free(ptpf->m_pipeCommand->m_argv); - ptpf->m_pipeCommand->m_argv = NULL; - } - - if(ptpf->m_pipeCommand->sSkippedToken != NULL) - { - free(ptpf->m_pipeCommand->sSkippedToken); - ptpf->m_pipeCommand->sSkippedToken = NULL; - } + int i=0; + + + if (ptpf->m_pipeCommand) + { + if(ptpf->m_pipeCommand->m_argv != NULL) + { + for(i=0; im_pipeCommand->m_argv_len; i++) + { + if(ptpf->m_pipeCommand->m_argv[i] != NULL) + { + free(ptpf->m_pipeCommand->m_argv[i]); + ptpf->m_pipeCommand->m_argv[i] = NULL; + } + } + + free(ptpf->m_pipeCommand->m_argv); + ptpf->m_pipeCommand->m_argv = NULL; + } + + if(ptpf->m_pipeCommand->sSkippedToken != NULL) + { + free(ptpf->m_pipeCommand->sSkippedToken); + ptpf->m_pipeCommand->sSkippedToken = NULL; + } /**** // Commented since these are not being used. Still retained here. // To be removed once things are proved to be working fine to a good confident level, - if(ptpf->m_pipeCommand->nextarg) - { - free(ptpf->m_pipeCommand->nextarg); - ptpf->m_pipeCommand->nextarg = NULL; - } - - if(ptpf->m_pipeCommand->m_redirInName) - { - free(ptpf->m_pipeCommand->m_redirInName); - ptpf->m_pipeCommand->m_redirInName = NULL; - } - if(ptpf->m_pipeCommand->m_redirOutName) - { - free(ptpf->m_pipeCommand->m_redirOutName); - ptpf->m_pipeCommand->m_redirOutName = NULL; - } - if(ptpf->m_pipeCommand->m_redirErrName) - { - free(ptpf->m_pipeCommand->m_redirErrName); - ptpf->m_pipeCommand->m_redirErrName = NULL; - } - if(ptpf->m_pipeCommand->m_redirBothName) - { - free(ptpf->m_pipeCommand->m_redirBothName); - ptpf->m_pipeCommand->m_redirBothName = NULL; - } + if(ptpf->m_pipeCommand->nextarg) + { + free(ptpf->m_pipeCommand->nextarg); + ptpf->m_pipeCommand->nextarg = NULL; + } + + if(ptpf->m_pipeCommand->m_redirInName) + { + free(ptpf->m_pipeCommand->m_redirInName); + ptpf->m_pipeCommand->m_redirInName = NULL; + } + if(ptpf->m_pipeCommand->m_redirOutName) + { + free(ptpf->m_pipeCommand->m_redirOutName); + ptpf->m_pipeCommand->m_redirOutName = NULL; + } + if(ptpf->m_pipeCommand->m_redirErrName) + { + free(ptpf->m_pipeCommand->m_redirErrName); + ptpf->m_pipeCommand->m_redirErrName = NULL; + } + if(ptpf->m_pipeCommand->m_redirBothName) + { + free(ptpf->m_pipeCommand->m_redirBothName); + ptpf->m_pipeCommand->m_redirBothName = NULL; + } ****/ - if(ptpf->m_pipeCommand != NULL) - { - free(ptpf->m_pipeCommand); - ptpf->m_pipeCommand = NULL; - } - } + if(ptpf->m_pipeCommand != NULL) + { + free(ptpf->m_pipeCommand); + ptpf->m_pipeCommand = NULL; + } + } - if(ptpf->m_redirect != NULL) - { - free(ptpf->m_redirect); - ptpf->m_redirect = NULL; - } + if(ptpf->m_redirect != NULL) + { + free(ptpf->m_redirect); + ptpf->m_redirect = NULL; + } - return; + return; } diff --git a/NetWare/config.wc b/NetWare/config.wc index 5f55e121c5fc..26c1755798ed 100644 --- a/NetWare/config.wc +++ b/NetWare/config.wc @@ -236,6 +236,7 @@ d_gdbm_ndbm_h_uses_prototypes='undef' d_gdbmndbm_h_uses_prototypes='undef' d_getaddrinfo='undef' d_getcwd='define' +d_getenv_preserves_other_thread='define' d_getespwnam='undef' d_getfsstat='undef' d_getgrent='undef' diff --git a/NetWare/config_H.wc b/NetWare/config_H.wc index 7d76806187df..b40e3262060b 100644 --- a/NetWare/config_H.wc +++ b/NetWare/config_H.wc @@ -887,7 +887,7 @@ * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define ARCHLIB "c:\\perl\\5.33.4\\lib\\NetWare-x86-multi-thread" /**/ +#define ARCHLIB "c:\\perl\\5.33.7\\lib\\NetWare-x86-multi-thread" /**/ /*#define ARCHLIB_EXP "" /**/ /* ARCHNAME: @@ -918,8 +918,8 @@ * This symbol is the filename expanded version of the BIN symbol, for * programs that do not want to deal with that at run-time. */ -#define BIN "c:\\perl\\5.33.4\\bin\\NetWare-x86-multi-thread" /**/ -#define BIN_EXP "c:\\perl\\5.33.4\\bin\\NetWare-x86-multi-thread" /**/ +#define BIN "c:\\perl\\5.33.7\\bin\\NetWare-x86-multi-thread" /**/ +#define BIN_EXP "c:\\perl\\5.33.7\\bin\\NetWare-x86-multi-thread" /**/ /* BYTEORDER: * This symbol holds the hexadecimal constant defined in byteorder, @@ -2878,7 +2878,7 @@ * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define SITEARCH "c:\\perl\\site\\5.33.4\\lib\\NetWare-x86-multi-thread" /**/ +#define SITEARCH "c:\\perl\\site\\5.33.7\\lib\\NetWare-x86-multi-thread" /**/ /*#define SITEARCH_EXP "" /**/ /* SITELIB: @@ -2901,7 +2901,7 @@ * removed. The elements in inc_version_list (inc_version_list.U) can * be tacked onto this variable to generate a list of directories to search. */ -#define SITELIB "c:\\perl\\site\\5.33.4\\lib" /**/ +#define SITELIB "c:\\perl\\site\\5.33.7\\lib" /**/ /*#define SITELIB_EXP "" /**/ #define SITELIB_STEM "" /**/ diff --git a/NetWare/deb.h b/NetWare/deb.h index e79a8f41a76d..a0000bc041da 100644 --- a/NetWare/deb.h +++ b/NetWare/deb.h @@ -25,21 +25,21 @@ #if defined(DEBUGON) && !defined(USE_D2) - //debug build and d1 flag is used, so enable IDB - #define DBGMESG ConsolePrintf - #define IDB(x) \ - ConsolePrintf(x); \ - _asm {int 3} + //debug build and d1 flag is used, so enable IDB + #define DBGMESG ConsolePrintf + #define IDB(x) \ + ConsolePrintf(x); \ + _asm {int 3} #else - #if defined(USE_D2) - //debug build and d2 flag is used, so disable IDB - #define DBGMESG ConsolePrintf - #define IDB ConsolePrintf - #else - //release build, so disable DBGMESG and IDB - #define DBGMESG - #define IDB - #endif //if defined(USE_D2) + #if defined(USE_D2) + //debug build and d2 flag is used, so disable IDB + #define DBGMESG ConsolePrintf + #define IDB ConsolePrintf + #else + //release build, so disable DBGMESG and IDB + #define DBGMESG + #define IDB + #endif //if defined(USE_D2) #endif //if defined(DEBUGON) && !defined(USE_D2) diff --git a/NetWare/intdef.h b/NetWare/intdef.h index 4c566c4e45bc..b0bcf010b555 100644 --- a/NetWare/intdef.h +++ b/NetWare/intdef.h @@ -47,8 +47,8 @@ //#define strcpy(x,y) NWLstrbcpy(x,y,NWstrlen(y)+1) #define strcpy(x,y) \ - NWstrncpy(x,y,NWstrlen(y)); \ - x[NWstrlen(y)] ='\0'; + NWstrncpy(x,y,NWstrlen(y)); \ + x[NWstrlen(y)] ='\0'; #define strncpy(x,y,z) NWLstrbcpy(x,y,(z + 1)) #define strcat(x,y) NWLstrbcpy((x + NWstrlen(x)), y, (NWstrlen(y) +1)) #define strncmp(s1,s2,l) NWgstrncmp(s1,s2,l) @@ -58,28 +58,28 @@ #define wsprintf NWsprintf #define strncat(x,y,l) \ - NWsprintf("oops!!! Not yet defined for NWI18N, define in intdef.h, still using strncat\n"); \ - strncat(x,y,l); + NWsprintf("oops!!! Not yet defined for NWI18N, define in intdef.h, still using strncat\n"); \ + strncat(x,y,l); #define strdup(s1) \ - NWsprintf("oops!!! Not yet defined for NWI18N, define in intdef.h, still using strdup\n"); \ - strdup(s1); + NWsprintf("oops!!! Not yet defined for NWI18N, define in intdef.h, still using strdup\n"); \ + strdup(s1); #define strlist \ - NWsprintf("oops!!! Not yet defined for NWI18N, define in intdef.h, still using strlist\n"); \ - strlist; + NWsprintf("oops!!! Not yet defined for NWI18N, define in intdef.h, still using strlist\n"); \ + strlist; #define strlwr(s1) \ - NWsprintf("oops!!! Not yet defined for NWI18N, define in intdef.h, still using strlwr\n"); \ - strlwr(s1); + NWsprintf("oops!!! Not yet defined for NWI18N, define in intdef.h, still using strlwr\n"); \ + strlwr(s1); #define strnset(s1,l1,l2) \ - NWsprintf("oops!!! Not yet defined for NWI18N, define in intdef.h, still using strnset\n"); \ - strnset(s1,l1,l2); + NWsprintf("oops!!! Not yet defined for NWI18N, define in intdef.h, still using strnset\n"); \ + strnset(s1,l1,l2); #define strset(s1,l1) \ - NWsprintf("oops!!! Not yet defined for NWI18N, define in intdef.h, still using strset\n"); \ - strset(s1,l1); + NWsprintf("oops!!! Not yet defined for NWI18N, define in intdef.h, still using strset\n"); \ + strset(s1,l1); #endif // __INTDEF__ diff --git a/NetWare/interface.c b/NetWare/interface.c index be3eddf149b2..cd2c6deb08c9 100644 --- a/NetWare/interface.c +++ b/NetWare/interface.c @@ -41,58 +41,58 @@ ClsPerlHost::~ClsPerlHost() ClsPerlHost::VersionNumber() { - return 0; + return 0; } bool ClsPerlHost::RegisterWithThreadTable() { - return(fnRegisterWithThreadTable()); + return(fnRegisterWithThreadTable()); } bool ClsPerlHost::UnregisterWithThreadTable() { - return(fnUnregisterWithThreadTable()); + return(fnUnregisterWithThreadTable()); } int ClsPerlHost::PerlCreate(PerlInterpreter *my_perl) { /* if (!(my_perl = perl_alloc())) // Allocate memory for Perl. - return (1);*/ + return (1);*/ perl_construct(my_perl); - return 1; + return 1; } int ClsPerlHost::PerlParse(PerlInterpreter *my_perl, int argc, char** argv, char** env) { - return(perl_parse(my_perl, xs_init, argc, argv, env)); // Parse the command line. + return(perl_parse(my_perl, xs_init, argc, argv, env)); // Parse the command line. } int ClsPerlHost::PerlRun(PerlInterpreter *my_perl) { - return(perl_run(my_perl)); // Run Perl. + return(perl_run(my_perl)); // Run Perl. } int ClsPerlHost::PerlDestroy(PerlInterpreter *my_perl) { - return(perl_destruct(my_perl)); // Destructor for Perl. + return(perl_destruct(my_perl)); // Destructor for Perl. } void ClsPerlHost::PerlFree(PerlInterpreter *my_perl) { - perl_free(my_perl); // Free the memory allocated for Perl. + perl_free(my_perl); // Free the memory allocated for Perl. - // Remove the thread context set during Perl_set_context - // This is added here since for web script there is no other place this gets executed - // and it cannot be included into cgi2perl.xs unless this symbol is exported. - Remove_Thread_Ctx(); + // Remove the thread context set during Perl_set_context + // This is added here since for web script there is no other place this gets executed + // and it cannot be included into cgi2perl.xs unless this symbol is exported. + Remove_Thread_Ctx(); } /*============================================================================================ @@ -109,58 +109,58 @@ ClsPerlHost::PerlFree(PerlInterpreter *my_perl) static void xs_init(pTHX) { - char *file = __FILE__; + char *file = __FILE__; - dXSUB_SYS; - newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); + dXSUB_SYS; + newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); } EXTERN_C int RunPerl(int argc, char **argv, char **env) { - int exitstatus = 0; - ClsPerlHost nlm; - - PerlInterpreter *my_perl = NULL; // defined in Perl.h - PerlInterpreter *new_perl = NULL; // defined in Perl.h - - PERL_SYS_INIT(&argc, &argv); - - if (!(my_perl = perl_alloc())) // Allocate memory for Perl. - return (1); - - if(nlm.PerlCreate(my_perl)) - { - PL_perl_destruct_level = 0; - - if(!nlm.PerlParse(my_perl, argc, argv, env)) - { - #if defined(TOP_CLONE) && defined(USE_ITHREADS) // XXXXXX testing - new_perl = perl_clone(my_perl, 1); - - (void) perl_run(new_perl); // Run Perl. - PERL_SET_THX(my_perl); - #else - (void) nlm.PerlRun(my_perl); - #endif - } - exitstatus = nlm.PerlDestroy(my_perl); - } - if(my_perl) - nlm.PerlFree(my_perl); - - #ifdef USE_ITHREADS - if (new_perl) - { - PERL_SET_THX(new_perl); - exitstatus = nlm.PerlDestroy(new_perl); - nlm.PerlFree(my_perl); - } - #endif - - PERL_SYS_TERM(); - return exitstatus; + int exitstatus = 0; + ClsPerlHost nlm; + + PerlInterpreter *my_perl = NULL; // defined in Perl.h + PerlInterpreter *new_perl = NULL; // defined in Perl.h + + PERL_SYS_INIT(&argc, &argv); + + if (!(my_perl = perl_alloc())) // Allocate memory for Perl. + return (1); + + if(nlm.PerlCreate(my_perl)) + { + PL_perl_destruct_level = 0; + + if(!nlm.PerlParse(my_perl, argc, argv, env)) + { + #if defined(TOP_CLONE) && defined(USE_ITHREADS) // XXXXXX testing + new_perl = perl_clone(my_perl, 1); + + (void) perl_run(new_perl); // Run Perl. + PERL_SET_THX(my_perl); + #else + (void) nlm.PerlRun(my_perl); + #endif + } + exitstatus = nlm.PerlDestroy(my_perl); + } + if(my_perl) + nlm.PerlFree(my_perl); + + #ifdef USE_ITHREADS + if (new_perl) + { + PERL_SET_THX(new_perl); + exitstatus = nlm.PerlDestroy(new_perl); + nlm.PerlFree(my_perl); + } + #endif + + PERL_SYS_TERM(); + return exitstatus; } @@ -173,7 +173,7 @@ int RunPerl(int argc, char **argv, char **env) // IPerlHost* AllocStdPerl() { - return (IPerlHost*) new ClsPerlHost(); + return (IPerlHost*) new ClsPerlHost(); } @@ -185,7 +185,7 @@ IPerlHost* AllocStdPerl() // void FreeStdPerl(IPerlHost* pPerlHost) { - if (pPerlHost) - delete (ClsPerlHost*) pPerlHost; + if (pPerlHost) + delete (ClsPerlHost*) pPerlHost; } diff --git a/NetWare/interface.h b/NetWare/interface.h index 2c9d46d75d53..3718cfea6210 100644 --- a/NetWare/interface.h +++ b/NetWare/interface.h @@ -27,19 +27,19 @@ class ClsPerlHost : public IPerlHost { public: - ClsPerlHost(void); - virtual ~ClsPerlHost(void); + ClsPerlHost(void); + virtual ~ClsPerlHost(void); - int VersionNumber(); + int VersionNumber(); - int PerlCreate(PerlInterpreter *my_perl); - int PerlParse(PerlInterpreter *my_perl, int argc, char** argv, char** env); - int PerlRun(PerlInterpreter *my_perl); - int PerlDestroy(PerlInterpreter *my_perl); - void PerlFree(PerlInterpreter *my_perl); + int PerlCreate(PerlInterpreter *my_perl); + int PerlParse(PerlInterpreter *my_perl, int argc, char** argv, char** env); + int PerlRun(PerlInterpreter *my_perl); + int PerlDestroy(PerlInterpreter *my_perl); + void PerlFree(PerlInterpreter *my_perl); - //bool RegisterWithThreadTable(void); - //bool UnregisterWithThreadTable(void); + //bool RegisterWithThreadTable(void); + //bool UnregisterWithThreadTable(void); }; diff --git a/NetWare/iperlhost.h b/NetWare/iperlhost.h index fe3dab7a34ae..946ee0a2c327 100644 --- a/NetWare/iperlhost.h +++ b/NetWare/iperlhost.h @@ -28,16 +28,16 @@ class IPerlHost { public: - virtual int VersionNumber() = 0; + virtual int VersionNumber() = 0; - virtual int PerlCreate(PerlInterpreter *my_perl) = 0; - virtual int PerlParse(PerlInterpreter *my_perl,int argc, char** argv, char** env) = 0; - virtual int PerlRun(PerlInterpreter *my_perl) = 0; - virtual int PerlDestroy(PerlInterpreter *my_perl) = 0; - virtual void PerlFree(PerlInterpreter *my_perl) = 0; + virtual int PerlCreate(PerlInterpreter *my_perl) = 0; + virtual int PerlParse(PerlInterpreter *my_perl,int argc, char** argv, char** env) = 0; + virtual int PerlRun(PerlInterpreter *my_perl) = 0; + virtual int PerlDestroy(PerlInterpreter *my_perl) = 0; + virtual void PerlFree(PerlInterpreter *my_perl) = 0; - //virtual bool RegisterWithThreadTable(void)=0; - //virtual bool UnregisterWithThreadTable(void)=0; + //virtual bool RegisterWithThreadTable(void)=0; + //virtual bool UnregisterWithThreadTable(void)=0; }; extern "C" IPerlHost* AllocStdPerl(); diff --git a/NetWare/netware.h b/NetWare/netware.h index c106476e28dd..af9e59936a13 100644 --- a/NetWare/netware.h +++ b/NetWare/netware.h @@ -33,10 +33,10 @@ //structure that will be used by times routine. struct tms { - long tms_utime; - long tms_stime; - long tms_cutime; - long tms_cstime; + long tms_utime; + long tms_stime; + long tms_cutime; + long tms_cstime; }; #define PERL_GET_CONTEXT_DEFINED @@ -87,9 +87,9 @@ EXTERN_C void Perl_nw5_init(int *argcp, char ***argvp); // Below is called in Run.c file when a perl script executes/runs. #ifdef MPK_ON - #define PERL_ASYNC_CHECK() kYieldThread(); + #define PERL_ASYNC_CHECK() kYieldThread(); #else - #define PERL_ASYNC_CHECK() ThreadSwitch(); + #define PERL_ASYNC_CHECK() ThreadSwitch(); #endif diff --git a/NetWare/nw5.c b/NetWare/nw5.c index 46642a4d5978..7db8ac090125 100644 --- a/NetWare/nw5.c +++ b/NetWare/nw5.c @@ -65,8 +65,8 @@ does not abend the server. void nw_abort(void) { - abort(); // Terminate the NLM application abnormally. - return; + abort(); // Terminate the NLM application abnormally. + return; } int @@ -84,8 +84,8 @@ nw_chmod(const char *path, int mode) void nw_clearerr(FILE *pf) { - if(pf) - clearerr(pf); + if(pf) + clearerr(pf); } int @@ -96,156 +96,156 @@ nw_close(int fd) nw_closedir(DIR *dirp) { - return (closedir(dirp)); + return (closedir(dirp)); } void nw_setbuf(FILE *pf, char *buf) { - if(pf) - setbuf(pf, buf); + if(pf) + setbuf(pf, buf); } int nw_setmode(FILE *fp, int mode) { /** - // Commented since a few abends were happening in fnFpSetMode - int *dummy = 0; - return(fnFpSetMode(fp, mode, dummy)); + // Commented since a few abends were happening in fnFpSetMode + int *dummy = 0; + return(fnFpSetMode(fp, mode, dummy)); **/ - int handle = -1; - errno = 0; + int handle = -1; + errno = 0; - handle = fileno(fp); - if (errno) - { - errno = 0; - return -1; - } - return setmode(handle, mode); + handle = fileno(fp); + if (errno) + { + errno = 0; + return -1; + } + return setmode(handle, mode); } int nw_setvbuf(FILE *pf, char *buf, int type, size_t size) { - if(pf) - return setvbuf(pf, buf, type, size); - else - return -1; + if(pf) + return setvbuf(pf, buf, type, size); + else + return -1; } unsigned int nw_sleep(unsigned int t) { - delay(t*1000); // Put the thread to sleep for 't' seconds. Initially 't' is passed in milliseconds. + delay(t*1000); // Put the thread to sleep for 't' seconds. Initially 't' is passed in milliseconds. return 0; } int nw_spawnvp(int mode, char *cmdname, char **argv) { - // There is no pass-around environment on NetWare so we throw that - // argument away for now. - - // The function "spawnvp" does not work in all situations. Loading - // edit.nlm seems to work, for example, but the name of the file - // to edit does not appear to get passed correctly. Another problem - // is that on Netware, P_WAIT does not really work reliably. It only - // works with NLMs built to use CLIB (according to Nile Thayne). - // NLMs such as EDIT that are written directly to the system have no - // way of running synchronously from another process. The whole - // architecture on NetWare seems pretty busted, so we just support it - // as best we can. - // - // The spawnvp function only launches NLMs, it will not execute a command; - // the NetWare "system" function is used for that purpose. Unfortunately, "system" - // always returns success whether the command is successful or not or even - // if the command was not found! To avoid ambiguity--you can have both an - // NLM named "perl" and a system command named "perl"--we need to - // force perl scripts to carry the word "load" when loading an NLM. This - // might be clearer anyway. - - int ret = 0; - int argc = 0; - - - if (stricmp(cmdname, LOAD_COMMAND) == 0) - { - if (argv[1] != NULL) - ret = spawnvp(mode, argv[1], &argv[1]); - } - else - { - int i=0; - while (argv[i] != '\0') - i++; - argc = i; - - fnSystemCommand(argv, argc); - } - - return ret; + // There is no pass-around environment on NetWare so we throw that + // argument away for now. + + // The function "spawnvp" does not work in all situations. Loading + // edit.nlm seems to work, for example, but the name of the file + // to edit does not appear to get passed correctly. Another problem + // is that on Netware, P_WAIT does not really work reliably. It only + // works with NLMs built to use CLIB (according to Nile Thayne). + // NLMs such as EDIT that are written directly to the system have no + // way of running synchronously from another process. The whole + // architecture on NetWare seems pretty busted, so we just support it + // as best we can. + // + // The spawnvp function only launches NLMs, it will not execute a command; + // the NetWare "system" function is used for that purpose. Unfortunately, "system" + // always returns success whether the command is successful or not or even + // if the command was not found! To avoid ambiguity--you can have both an + // NLM named "perl" and a system command named "perl"--we need to + // force perl scripts to carry the word "load" when loading an NLM. This + // might be clearer anyway. + + int ret = 0; + int argc = 0; + + + if (stricmp(cmdname, LOAD_COMMAND) == 0) + { + if (argv[1] != NULL) + ret = spawnvp(mode, argv[1], &argv[1]); + } + else + { + int i=0; + while (argv[i] != '\0') + i++; + argc = i; + + fnSystemCommand(argv, argc); + } + + return ret; } int nw_execv(char *cmdname, char **argv) { - return spawnvp(P_WAIT, cmdname, (char **)argv); + return spawnvp(P_WAIT, cmdname, (char **)argv); } int nw_execvp(char *cmdname, char **argv) { - return nw_spawnvp(P_WAIT, cmdname, (char **)argv); + return nw_spawnvp(P_WAIT, cmdname, (char **)argv); } int nw_stat(const char *path, struct stat *sbuf) { - return (stat(path, sbuf)); + return (stat(path, sbuf)); } FILE * nw_stderr(void) { - return (stderr); + return (stderr); } FILE * nw_stdin(void) { - return (stdin); + return (stdin); } FILE * nw_stdout() { - return (stdout); + return (stdout); } long nw_telldir(DIR *dirp) { - dTHX; - Perl_croak(aTHX_ "The telldir() function is not implemented on NetWare\n"); - return 0l; + dTHX; + Perl_croak(aTHX_ "The telldir() function is not implemented on NetWare\n"); + return 0l; } int nw_times(struct tms *timebuf) { - clock_t now = clock(); + clock_t now = clock(); - timebuf->tms_utime = now; - timebuf->tms_stime = 0; - timebuf->tms_cutime = 0; - timebuf->tms_cstime = 0; + timebuf->tms_utime = now; + timebuf->tms_stime = 0; + timebuf->tms_cutime = 0; + timebuf->tms_cstime = 0; - return 0; + return 0; } FILE* @@ -257,37 +257,37 @@ nw_tmpfile(void) int nw_uname(struct utsname *name) { - return(uname(name)); + return(uname(name)); } int nw_ungetc(int c, FILE *pf) { - if(pf) - return ungetc(c, pf); - else - return -1; + if(pf) + return ungetc(c, pf); + else + return -1; } int nw_unlink(const char *filename) { - return(unlink(filename)); + return(unlink(filename)); } int nw_utime(const char *filename, struct utimbuf *times) { - return(utime(filename, times)); + return(utime(filename, times)); } int nw_vfprintf(FILE *fp, const char *format, va_list args) { - if(fp) - return (vfprintf(fp, format, args)); - else - return -1; + if(fp) + return (vfprintf(fp, format, args)); + else + return -1; } int @@ -311,7 +311,7 @@ nw_write(int fd, const void *buf, unsigned int cnt) char * nw_crypt(const char *txt, const char *salt) { - dTHX; + dTHX; #ifdef HAVE_DES_FCRYPT dTHR; @@ -331,221 +331,221 @@ nw_dup(int fd) int nw_dup2(int fd1,int fd2) { - return dup2(fd1,fd2); + return dup2(fd1,fd2); } void* nw_dynaload(const char* filename) { - return NULL; + return NULL; } int nw_fclose(FILE *pf) { - if(pf) - return (fclose(pf)); - else - return -1; + if(pf) + return (fclose(pf)); + else + return -1; } FILE * nw_fdopen(int handle, const char *mode) { - return(fdopen(handle, mode)); + return(fdopen(handle, mode)); } int nw_feof(FILE *fp) { - if(fp) - return (feof(fp)); - else - return -1; + if(fp) + return (feof(fp)); + else + return -1; } int nw_ferror(FILE *fp) { - if(fp) - return (ferror(fp)); - else - return -1; + if(fp) + return (ferror(fp)); + else + return -1; } int nw_fflush(FILE *pf) { - if(pf) - return fflush(pf); - else - return -1; + if(pf) + return fflush(pf); + else + return -1; } int nw_fgetpos(FILE *pf, fpos_t *p) { - if(pf) - return fgetpos(pf, p); - else - return -1; + if(pf) + return fgetpos(pf, p); + else + return -1; } char* nw_fgets(char *s, int n, FILE *pf) { - if(pf) - return(fgets(s, n, pf)); - else - return NULL; + if(pf) + return(fgets(s, n, pf)); + else + return NULL; } int nw_fileno(FILE *pf) { - if(pf) - return fileno(pf); - else - return -1; + if(pf) + return fileno(pf); + else + return -1; } int nw_flock(int fd, int oper) { - dTHX; - Perl_croak(aTHX_ "The flock() function is not implemented on NetWare\n"); - return 0; + dTHX; + Perl_croak(aTHX_ "The flock() function is not implemented on NetWare\n"); + return 0; } FILE * nw_fopen(const char *filename, const char *mode) { - return (fopen(filename, mode)); + return (fopen(filename, mode)); } int nw_fputc(int c, FILE *pf) { - if(pf) - return fputc(c,pf); - else - return -1; + if(pf) + return fputc(c,pf); + else + return -1; } int nw_fputs(const char *s, FILE *pf) { - if(pf) - return fputs(s, pf); - else - return -1; + if(pf) + return fputs(s, pf); + else + return -1; } size_t nw_fread(void *buf, size_t size, size_t count, FILE *fp) { - if(fp) - return fread(buf, size, count, fp); - else - return -1; + if(fp) + return fread(buf, size, count, fp); + else + return -1; } FILE * nw_freopen(const char *path, const char *mode, FILE *stream) { - if(stream) - return freopen(path, mode, stream); - else - return NULL; + if(stream) + return freopen(path, mode, stream); + else + return NULL; } int nw_fseek(FILE *pf, long offset, int origin) { - if(pf) - return (fseek(pf, offset, origin)); - else - return -1; + if(pf) + return (fseek(pf, offset, origin)); + else + return -1; } int nw_fsetpos(FILE *pf, const fpos_t *p) { - if(pf) - return fsetpos(pf, p); - else - return -1; + if(pf) + return fsetpos(pf, p); + else + return -1; } long nw_ftell(FILE *pf) { - if(pf) - return ftell(pf); - else - return -1; + if(pf) + return ftell(pf); + else + return -1; } size_t nw_fwrite(const void *buf, size_t size, size_t count, FILE *fp) { - if(fp) - return fwrite(buf, size, count, fp); - else - return -1; + if(fp) + return fwrite(buf, size, count, fp); + else + return -1; } long nw_get_osfhandle(int fd) { - return 0l; + return 0l; } int nw_getc(FILE *pf) { - if(pf) - return getc(pf); - else - return -1; + if(pf) + return getc(pf); + else + return -1; } int nw_putc(int c, FILE *pf) { - if(pf) - return putc(c,pf); - else - return -1; + if(pf) + return putc(c,pf); + else + return -1; } int nw_fgetc(FILE *pf) { - if(pf) - return fgetc(pf); - else - return -1; + if(pf) + return fgetc(pf); + else + return -1; } int nw_getpid(void) { - return GetThreadGroupID(); + return GetThreadGroupID(); } int nw_kill(int pid, int sig) { - return 0; + return 0; } int nw_link(const char *oldname, const char *newname) { - return 0; + return 0; } long @@ -569,165 +569,165 @@ nw_rmdir(const char *dir) DIR * nw_opendir(const char *filename) { - char *buff = NULL; - int len = 0; - DIR *ret = NULL; - - len = strlen(filename); - buff = malloc(len + 5); - if (buff) { - strcpy(buff, filename); - if (buff[len-1]=='/' || buff[len-1]=='\\') { - buff[--len] = 0; - } - strcpy(buff+len, "/*.*"); - ret = opendir(buff); - free (buff); - buff = NULL; - return ret; - } else { - return NULL; - } + char *buff = NULL; + int len = 0; + DIR *ret = NULL; + + len = strlen(filename); + buff = malloc(len + 5); + if (buff) { + strcpy(buff, filename); + if (buff[len-1]=='/' || buff[len-1]=='\\') { + buff[--len] = 0; + } + strcpy(buff+len, "/*.*"); + ret = opendir(buff); + free (buff); + buff = NULL; + return ret; + } else { + return NULL; + } } int nw_open(const char *path, int flag, ...) { - va_list ap; - int pmode = -1; + va_list ap; + int pmode = -1; - va_start(ap, flag); + va_start(ap, flag); pmode = va_arg(ap, int); va_end(ap); - if (stricmp(path, "/dev/null")==0) - path = "NWNUL"; + if (stricmp(path, "/dev/null")==0) + path = "NWNUL"; - return open(path, flag, pmode); + return open(path, flag, pmode); } int nw_open_osfhandle(long handle, int flags) { - return 0; + return 0; } unsigned long nw_os_id(void) { - return 0l; + return 0l; } int nw_Pipe(int* a, int* e) { - int ret = 0; + int ret = 0; - errno = 0; - ret = pipe(a); - if(errno) - e = &errno; + errno = 0; + ret = pipe(a); + if(errno) + e = &errno; - return ret; + return ret; } FILE* nw_Popen(char* command, char* mode, int* e) { - int i = -1; - - FILE* ret = NULL; - PTEMPPIPEFILE ptpf = NULL; - - // this callback is supposed to call _popen, which spawns an - // asynchronous command and opens a pipe to it. The returned - // file handle can be read or written to; if read, it represents - // stdout of the called process and will return EOF when the - // called process finishes. If written to, it represents stdin - // of the called process. Naturally _popen is not available on - // NetWare so we must do some fancy stuff to simulate it. We will - // redirect to and from temp files; this has the side effect - // of having to run the process synchronously rather than - // asynchronously. This means that you will only be able to do - // this with CLIB NLMs built to run on the calling thread. - - errno = 0; - - ptpf1[iPopenCount] = (PTEMPPIPEFILE) malloc(sizeof(TEMPPIPEFILE)); - if (!ptpf1[iPopenCount]) - return NULL; - - ptpf = ptpf1[iPopenCount]; - iPopenCount ++; - if(iPopenCount > MAX_PIPE_RECURSION) - iPopenCount = MAX_PIPE_RECURSION; // Limit to the max no of pipes to be open recursively. - - fnTempPipeFile(ptpf); - ret = fnPipeFileOpen((PTEMPPIPEFILE) ptpf, (char *) command, (char *) mode); - if (ret) - File1[iPopenCount-1] = ret; // Store the obtained Pipe file handle. - else - { // Pipe file not obtained. So free the allocated memory. - if(ptpf1[iPopenCount-1]) - { - free(ptpf1[iPopenCount-1]); - ptpf1[iPopenCount-1] = NULL; - ptpf = NULL; - iPopenCount --; - } - } - - if (errno) - e = &errno; - - return ret; + int i = -1; + + FILE* ret = NULL; + PTEMPPIPEFILE ptpf = NULL; + + // this callback is supposed to call _popen, which spawns an + // asynchronous command and opens a pipe to it. The returned + // file handle can be read or written to; if read, it represents + // stdout of the called process and will return EOF when the + // called process finishes. If written to, it represents stdin + // of the called process. Naturally _popen is not available on + // NetWare so we must do some fancy stuff to simulate it. We will + // redirect to and from temp files; this has the side effect + // of having to run the process synchronously rather than + // asynchronously. This means that you will only be able to do + // this with CLIB NLMs built to run on the calling thread. + + errno = 0; + + ptpf1[iPopenCount] = (PTEMPPIPEFILE) malloc(sizeof(TEMPPIPEFILE)); + if (!ptpf1[iPopenCount]) + return NULL; + + ptpf = ptpf1[iPopenCount]; + iPopenCount ++; + if(iPopenCount > MAX_PIPE_RECURSION) + iPopenCount = MAX_PIPE_RECURSION; // Limit to the max no of pipes to be open recursively. + + fnTempPipeFile(ptpf); + ret = fnPipeFileOpen((PTEMPPIPEFILE) ptpf, (char *) command, (char *) mode); + if (ret) + File1[iPopenCount-1] = ret; // Store the obtained Pipe file handle. + else + { // Pipe file not obtained. So free the allocated memory. + if(ptpf1[iPopenCount-1]) + { + free(ptpf1[iPopenCount-1]); + ptpf1[iPopenCount-1] = NULL; + ptpf = NULL; + iPopenCount --; + } + } + + if (errno) + e = &errno; + + return ret; } int nw_Pclose(FILE* file, int* e) { - int i=0, j=0; + int i=0, j=0; - errno = 0; + errno = 0; - if(file) - { - if(iPopenCount > 0) - { - for (i=0; i 0) + { + for (i=0; i': - case '<': - case '|': - if (!inquote) - return TRUE; - default: - break; - } - ++ptr; + switch(*ptr) { + case '%': + return TRUE; + case '\'': + case '\"': + if (inquote) { + if (quote == *ptr) { + inquote = 0; + quote = '\0'; + } + } + else { + quote = *ptr; + inquote++; + } + break; + case '>': + case '<': + case '|': + if (!inquote) + return TRUE; + default: + break; + } + ++ptr; } return FALSE; } @@ -1110,7 +1110,7 @@ has_shell_metachars(char *ptr) int fork(void) { - return 0; + return 0; } @@ -1118,5 +1118,5 @@ fork(void) int Perl_Ireentrant_buffer_ptr(aTHX) { - return 0; + return 0; } diff --git a/NetWare/nw5sck.c b/NetWare/nw5sck.c index 35dee92bf123..217313e2238f 100644 --- a/NetWare/nw5sck.c +++ b/NetWare/nw5sck.c @@ -57,50 +57,50 @@ nw_ntohs(u_short netshort) SOCKET nw_accept(SOCKET s, struct sockaddr *addr, int *addrlen) { - return ((SOCKET)(accept(s, addr, addrlen))); + return ((SOCKET)(accept(s, addr, addrlen))); } int nw_bind(SOCKET s, const struct sockaddr *addr, int addrlen) { - return ((int)bind(s, (struct sockaddr *)addr, addrlen)); + return ((int)bind(s, (struct sockaddr *)addr, addrlen)); } int nw_connect(SOCKET s, const struct sockaddr *addr, int addrlen) { - return((int)connect(s, (struct sockaddr *)addr, addrlen)); + return((int)connect(s, (struct sockaddr *)addr, addrlen)); } void nw_endhostent() { - endhostent(); + endhostent(); } void nw_endnetent() { - endnetent(); + endnetent(); } void nw_endprotoent() { - endprotoent(); + endprotoent(); } void nw_endservent() { - endservent(); + endservent(); } struct hostent * nw_gethostent() { - return(gethostent()); + return(gethostent()); } struct netent * @@ -118,7 +118,7 @@ nw_getprotoent(void) struct hostent * nw_gethostbyname(const char *name) { - return(gethostbyname((char*)name)); + return(gethostbyname((char*)name)); } int @@ -130,13 +130,13 @@ nw_gethostname(char *name, int len) struct hostent * nw_gethostbyaddr(const char *addr, int len, int type) { - return(gethostbyaddr((char*)addr, len, type)); + return(gethostbyaddr((char*)addr, len, type)); } struct netent * nw_getnetbyaddr(long net, int type) { - return(getnetbyaddr(net,type)); + return(getnetbyaddr(net,type)); } struct netent * @@ -148,19 +148,19 @@ nw_getnetbyname(char *name) int nw_getpeername(SOCKET s, struct sockaddr *addr, int *addrlen) { - return((int)getpeername(s, addr, addrlen)); + return((int)getpeername(s, addr, addrlen)); } struct protoent * nw_getprotobyname(const char *name) { - return ((struct protoent *)getprotobyname((char*)name)); + return ((struct protoent *)getprotobyname((char*)name)); } struct protoent * nw_getprotobynumber(int num) { - return ((struct protoent *)getprotobynumber(num)); + return ((struct protoent *)getprotobynumber(num)); } struct servent * @@ -186,7 +186,7 @@ void nw_sethostent(int stayopen) { #ifdef HAS_SETHOSTENT - sethostent(stayopen); + sethostent(stayopen); #endif } @@ -194,7 +194,7 @@ void nw_setnetent(int stayopen) { #ifdef HAS_SETNETENT - setnetent(stayopen); + setnetent(stayopen); #endif } @@ -202,7 +202,7 @@ void nw_setprotoent(int stayopen) { #ifdef HAS_SETPROTENT - setprotoent(stayopen); + setprotoent(stayopen); #endif } @@ -210,26 +210,26 @@ void nw_setservent(int stayopen) { #ifdef HAS_SETSERVENT - setservent(stayopen); + setservent(stayopen); #endif } int nw_setsockopt(SOCKET s, int level, int optname, const char* optval, int optlen) { - return setsockopt(s, level, optname, (char*)optval, optlen); + return setsockopt(s, level, optname, (char*)optval, optlen); } int nw_getsockname(SOCKET s, struct sockaddr *addr, int *addrlen) { - return getsockname(s, addr, addrlen); + return getsockname(s, addr, addrlen); } int nw_getsockopt(SOCKET s, int level, int optname, char *optval, int *optlen) { - return ((int)getsockopt(s, level, optname, optval, optlen)); + return ((int)getsockopt(s, level, optname, optval, optlen)); } unsigned long @@ -253,9 +253,9 @@ nw_socket(int af, int type, int protocol) s = socket(af, type, protocol); #else if((s = socket(af, type, protocol)) == INVALID_SOCKET) - //errno = WSAGetLastError(); + //errno = WSAGetLastError(); else - s = s; + s = s; #endif /* USE_SOCKETS_AS_HANDLES */ return s; @@ -270,18 +270,18 @@ nw_listen(SOCKET s, int backlog) int nw_send(SOCKET s, const char *buf, int len, int flags) { - return(send(s,(char*)buf,len,flags)); + return(send(s,(char*)buf,len,flags)); } int nw_recv(SOCKET s, char *buf, int len, int flags) { - return (recv(s, buf, len, flags)); + return (recv(s, buf, len, flags)); } int nw_sendto(SOCKET s, const char *buf, int len, int flags, - const struct sockaddr *to, int tolen) + const struct sockaddr *to, int tolen) { return(sendto(s, (char*)buf, len, flags, (struct sockaddr *)to, tolen)); } @@ -293,16 +293,16 @@ nw_recvfrom(SOCKET s, char *buf, int len, int flags, struct sockaddr *from, int int frombufsize = *fromlen; r = recvfrom(s, buf, len, flags, from, fromlen); - //Not sure if the is required - chksgp + //Not sure if the is required - chksgp if (r && frombufsize == *fromlen) - (void)nw_getpeername(s, from, fromlen); + (void)nw_getpeername(s, from, fromlen); return r; } int nw_select(int nfds, fd_set* rd, fd_set* wr, fd_set* ex, const struct timeval* timeout) { - return(select(nfds, rd, wr, ex, (struct timeval*)timeout)); + return(select(nfds, rd, wr, ex, (struct timeval*)timeout)); } int diff --git a/NetWare/nw5thread.c b/NetWare/nw5thread.c index abedb5c2da1f..3b9d8304de4d 100644 --- a/NetWare/nw5thread.c +++ b/NetWare/nw5thread.c @@ -36,7 +36,7 @@ Perl_set_context(void *t) # ifdef USE_DECLSPEC_THREAD Perl_current_context = t; # else - fnAddThreadCtx(PL_thr_key, t); + fnAddThreadCtx(PL_thr_key, t); # endif #endif } @@ -49,7 +49,7 @@ Perl_get_context(void) # ifdef USE_DECLSPEC_THREAD return Perl_current_context; # else - return(fnGetThreadCtx(PL_thr_key)); + return(fnGetThreadCtx(PL_thr_key)); # endif #else return NULL; @@ -63,12 +63,12 @@ Remove_Thread_Ctx(void) { #if defined(USE_ITHREADS) # ifdef USE_DECLSPEC_THREAD - return TRUE; + return TRUE; # else - return(fnRemoveThreadCtx(PL_thr_key)); + return(fnRemoveThreadCtx(PL_thr_key)); # endif # else - return TRUE; + return TRUE; #endif } diff --git a/NetWare/nw5thread.h b/NetWare/nw5thread.h index e7d86757ee3a..40cbdc3aac70 100644 --- a/NetWare/nw5thread.h +++ b/NetWare/nw5thread.h @@ -37,10 +37,10 @@ typedef struct nw_cond { long waiters; unsigned int sem; } perl_cond; extern "C" { #endif - #include - #include - #define kSUCCESS (0) - #define ERROR_INVALID_MUTEX (0x1010) + #include + #include + #define kSUCCESS (0) + #define ERROR_INVALID_MUTEX (0x1010) #ifdef __cplusplus } @@ -55,34 +55,34 @@ extern "C" typedef MUTEX perl_mutex; # define MUTEX_INIT(m) \ STMT_START { \ - /*if ((*(m) = kMutexAlloc("NetWarePerlMutex")) == NULL) */\ - /*Perl_croak_nocontext("panic: MUTEX_ALLOC"); */\ - /*ConsolePrintf("Mutex Init %d\n",*(m)); */\ + /*if ((*(m) = kMutexAlloc("NetWarePerlMutex")) == NULL) */\ + /*Perl_croak_nocontext("panic: MUTEX_ALLOC"); */\ + /*ConsolePrintf("Mutex Init %d\n",*(m)); */\ } STMT_END # define MUTEX_LOCK(m) \ STMT_START { \ - /*ConsolePrintf("Mutex lock %d\n",*(m)); */\ - /*if (kMutexLock(*(m)) == ERROR_INVALID_MUTEX) */\ - /*Perl_croak_nocontext("panic: MUTEX_LOCK"); */\ + /*ConsolePrintf("Mutex lock %d\n",*(m)); */\ + /*if (kMutexLock(*(m)) == ERROR_INVALID_MUTEX) */\ + /*Perl_croak_nocontext("panic: MUTEX_LOCK"); */\ } STMT_END # define MUTEX_UNLOCK(m) \ STMT_START { \ - /*ConsolePrintf("Mutex unlock %d\n",*(m)); */\ - /*if (kMutexUnlock(*(m)) != kSUCCESS) \ - Perl_croak_nocontext("panic: MUTEX_UNLOCK"); */\ + /*ConsolePrintf("Mutex unlock %d\n",*(m)); */\ + /*if (kMutexUnlock(*(m)) != kSUCCESS) \ + Perl_croak_nocontext("panic: MUTEX_UNLOCK"); */\ } STMT_END # define MUTEX_DESTROY(m) \ STMT_START { \ - /*ConsolePrintf("Mutex Destroy %d\n",*(m)); */\ - /*if (kMutexWaitCount(*(m)) == 0 ) */\ - /*{ */\ - /*PERL_SET_INTERP(NULL); *//*newly added CHKSGP???*/ \ - /*if (kMutexFree(*(m)) != kSUCCESS) */ \ - /*Perl_croak_nocontext("panic: MUTEX_FREE"); */\ - /*} */\ + /*ConsolePrintf("Mutex Destroy %d\n",*(m)); */\ + /*if (kMutexWaitCount(*(m)) == 0 ) */\ + /*{ */\ + /*PERL_SET_INTERP(NULL); *//*newly added CHKSGP???*/ \ + /*if (kMutexFree(*(m)) != kSUCCESS) */ \ + /*Perl_croak_nocontext("panic: MUTEX_FREE"); */\ + /*} */\ } STMT_END #else @@ -100,56 +100,56 @@ typedef unsigned long perl_mutex; //For now let us just see when this happens -sgp. #define COND_INIT(c) \ STMT_START { \ - /*ConsolePrintf("In COND_INIT\n"); */\ + /*ConsolePrintf("In COND_INIT\n"); */\ } STMT_END /* (c)->waiters = 0; \ - (c)->sem = OpenLocalSemaphore (0); \ - if ((c)->sem == NULL) \ - Perl_croak_nocontext("panic: COND_INIT (%ld)",errno); \*/ + (c)->sem = OpenLocalSemaphore (0); \ + if ((c)->sem == NULL) \ + Perl_croak_nocontext("panic: COND_INIT (%ld)",errno); \*/ #define COND_SIGNAL(c) \ STMT_START { \ - /*ConsolePrintf("In COND_SIGNAL\n"); */\ + /*ConsolePrintf("In COND_SIGNAL\n"); */\ } STMT_END /*if ((c)->waiters > 0 && \ - SignalLocalSemaphore((c)->sem) != 0) \ - Perl_croak_nocontext("panic: COND_SIGNAL (%ld)",errno); \*/ + SignalLocalSemaphore((c)->sem) != 0) \ + Perl_croak_nocontext("panic: COND_SIGNAL (%ld)",errno); \*/ #define COND_BROADCAST(c) \ STMT_START { \ - /*ConsolePrintf("In COND_BROADCAST\n"); */\ + /*ConsolePrintf("In COND_BROADCAST\n"); */\ } STMT_END - /*if ((c)->waiters > 0 ) { \ - int count; \ - for(count=0; count<(c)->waiters; count++) { \ - if(SignalLocalSemaphore((c)->sem) != 0) \ - Perl_croak_nocontext("panic: COND_BROADCAST (%ld)",GetLastError());\ - } \ - } \*/ + /*if ((c)->waiters > 0 ) { \ + int count; \ + for(count=0; count<(c)->waiters; count++) { \ + if(SignalLocalSemaphore((c)->sem) != 0) \ + Perl_croak_nocontext("panic: COND_BROADCAST (%ld)",GetLastError());\ + } \ + } \*/ #define COND_WAIT(c, m) \ STMT_START { \ - /*ConsolePrintf("In COND_WAIT\n"); */\ + /*ConsolePrintf("In COND_WAIT\n"); */\ } STMT_END #define COND_DESTROY(c) \ STMT_START { \ - /*ConsolePrintf("In COND_DESTROY\n"); */\ + /*ConsolePrintf("In COND_DESTROY\n"); */\ } STMT_END /* (c)->waiters = 0; \ - if (CloseLocalSemaphore((c)->sem) != 0) \ - Perl_croak_nocontext("panic: COND_DESTROY (%ld)",errno); \*/ + if (CloseLocalSemaphore((c)->sem) != 0) \ + Perl_croak_nocontext("panic: COND_DESTROY (%ld)",errno); \*/ #if 0 #define DETACH(t) \ STMT_START { \ - if (CloseHandle((t)->self) == 0) { \ - MUTEX_UNLOCK(&(t)->mutex); \ - Perl_croak_nocontext("panic: DETACH"); \ - } \ + if (CloseHandle((t)->self) == 0) { \ + MUTEX_UNLOCK(&(t)->mutex); \ + Perl_croak_nocontext("panic: DETACH"); \ + } \ } STMT_END #endif //#if 0 @@ -172,7 +172,7 @@ extern __declspec(thread) void *PL_current_context; //See the comment at the end of file nw5thread.c as to why PL_thr_key is not assigned - sgp #define ALLOC_THREAD_KEY \ STMT_START { \ - fnInitializeThreadCtx(); \ + fnInitializeThreadCtx(); \ } STMT_END diff --git a/NetWare/nwhashcls.h b/NetWare/nwhashcls.h index 55ff20022036..ba18053ee2b1 100644 --- a/NetWare/nwhashcls.h +++ b/NetWare/nwhashcls.h @@ -22,8 +22,8 @@ struct HASHNODE { - void *data; - struct HASHNODE *next; + void *data; + struct HASHNODE *next; }; typedef void (*HASHFORALLFUN)(void *, void *); @@ -31,22 +31,22 @@ typedef void (*HASHFORALLFUN)(void *, void *); class NWPerlHashList { private: - HASHNODE* MemListHash[BUCKET_SIZE]; + HASHNODE* MemListHash[BUCKET_SIZE]; void removeAll() const; public: - ~NWPerlHashList(); - NWPerlHashList(); - int insert(void *lData); - int remove(void *lData); + ~NWPerlHashList(); + NWPerlHashList(); + int insert(void *lData); + int remove(void *lData); void forAll( void (*)(void *, void*), void * ) const; }; struct KEYHASHNODE { - void *key; - void *data; - KEYHASHNODE *next; + void *key; + void *data; + KEYHASHNODE *next; }; /** @@ -55,16 +55,16 @@ typedef void (*KEYHASHFORALLFUN)(void *, void *); class NWPerlKeyHashList { private: - KEYHASHNODE* MemListHash[BUCKET_SIZE]; + KEYHASHNODE* MemListHash[BUCKET_SIZE]; void removeAll() const; public: - ~NWPerlKeyHashList(); - NWPerlKeyHashList(); - int insert(void *key, void *lData); - int remove(void *key); + ~NWPerlKeyHashList(); + NWPerlKeyHashList(); + int insert(void *key, void *lData); + int remove(void *key); void forAll( void (*)(void *, void*), void * ) const; - int find(void *key, void **pData); + int find(void *key, void **pData); }; **/ diff --git a/NetWare/nwperlhost.h b/NetWare/nwperlhost.h index c69e554489b0..e011bd351ff5 100644 --- a/NetWare/nwperlhost.h +++ b/NetWare/nwperlhost.h @@ -52,10 +52,10 @@ class CPerlHost public: CPerlHost(void); CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, - struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv, - struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO, - struct IPerlDir** ppDir, struct IPerlSock** ppSock, - struct IPerlProc** ppProc); + struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv, + struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO, + struct IPerlDir** ppDir, struct IPerlSock** ppSock, + struct IPerlProc** ppProc); CPerlHost(const CPerlHost& host); virtual ~CPerlHost(void); @@ -73,21 +73,21 @@ class CPerlHost inline void* Malloc(size_t size) { return m_pVMem->Malloc(size); }; inline void* Realloc(void* ptr, size_t size) { return m_pVMem->Realloc(ptr, size); }; inline void Free(void* ptr) { m_pVMem->Free(ptr); }; - inline void* Calloc(size_t num, size_t size){ return m_pVMem->Calloc(num, size); }; + inline void* Calloc(size_t num, size_t size){ return m_pVMem->Calloc(num, size); }; /* IPerlMemShared */ inline void* MallocShared(size_t size) { - return m_pVMemShared->Malloc(size); + return m_pVMemShared->Malloc(size); }; inline void* ReallocShared(void* ptr, size_t size) { return m_pVMemShared->Realloc(ptr, size); }; inline void FreeShared(void* ptr) { m_pVMemShared->Free(ptr); }; inline void* CallocShared(size_t num, size_t size) { - size_t count = num*size; - void* lpVoid = MallocShared(count); + size_t count = num*size; + void* lpVoid = MallocShared(count); - return lpVoid; + return lpVoid; }; /* IPerlMemParse */ @@ -96,10 +96,10 @@ class CPerlHost inline void FreeParse(void* ptr) { m_pVMemParse->Free(ptr); }; inline void* CallocParse(size_t num, size_t size) { - size_t count = num*size; - void* lpVoid = MallocParse(count); + size_t count = num*size; + void* lpVoid = MallocParse(count); - return lpVoid; + return lpVoid; }; /* IPerlEnv */ @@ -107,11 +107,11 @@ class CPerlHost int Putenv(const char *envstring); inline char *Getenv(const char *varname, unsigned long *len) { - *len = 0; - char *e = Getenv(varname); - if (e) - *len = strlen(e); - return e; + *len = 0; + char *e = Getenv(varname); + if (e) + *len = strlen(e); + return e; } @@ -341,33 +341,33 @@ PerlEnvUname(struct IPerlEnv* piPerl, struct utsname *name) void PerlEnvClearenv(struct IPerlEnv* piPerl) { - // If removed, compilation fails while compiling CGI2Perl. + // If removed, compilation fails while compiling CGI2Perl. } void* PerlEnvGetChildenv(struct IPerlEnv* piPerl) { - // If removed, compilation fails while compiling CGI2Perl. - return NULL; + // If removed, compilation fails while compiling CGI2Perl. + return NULL; } void PerlEnvFreeChildenv(struct IPerlEnv* piPerl, void* childEnv) { - // If removed, compilation fails while compiling CGI2Perl. + // If removed, compilation fails while compiling CGI2Perl. } char* PerlEnvGetChilddir(struct IPerlEnv* piPerl) { - // If removed, compilation fails while compiling CGI2Perl. - return NULL; + // If removed, compilation fails while compiling CGI2Perl. + return NULL; } void PerlEnvFreeChilddir(struct IPerlEnv* piPerl, char* childDir) { - // If removed, compilation fails while compiling CGI2Perl. + // If removed, compilation fails while compiling CGI2Perl. } struct IPerlEnv perlEnv = @@ -636,7 +636,7 @@ PerlStdIOSetpos(struct IPerlStdIO* piPerl, PerlIO* pf, const Fpos_t *p) void PerlStdIOInit(struct IPerlStdIO* piPerl) { - // If removed, compilation error occurs. + // If removed, compilation error occurs. } void @@ -668,17 +668,17 @@ PerlStdIOFdupopen(struct IPerlStdIO* piPerl, PerlIO* pf) /* open the file in the same mode */ if(((FILE*)pf)->_flag & _IOREAD) { - mode[0] = 'r'; - mode[1] = 0; + mode[0] = 'r'; + mode[1] = 0; } else if(((FILE*)pf)->_flag & _IOWRT) { - mode[0] = 'a'; - mode[1] = 0; + mode[0] = 'a'; + mode[1] = 0; } else if(((FILE*)pf)->_flag & _IORW) { - mode[0] = 'r'; - mode[1] = '+'; - mode[2] = 0; + mode[0] = 'r'; + mode[1] = '+'; + mode[2] = 0; } /* it appears that the binmode is attached to the @@ -689,7 +689,7 @@ PerlStdIOFdupopen(struct IPerlStdIO* piPerl, PerlIO* pf) /* move the file pointer to the same position */ if (!fgetpos((FILE*)pf, &pos)) { - fsetpos((FILE*)pfdup, &pos); + fsetpos((FILE*)pfdup, &pos); } return pfdup; } @@ -757,14 +757,14 @@ PerlLIOChmod(struct IPerlLIO* piPerl, const char *filename, int pmode) int PerlLIOChown(struct IPerlLIO* piPerl, const char *filename, uid_t owner, gid_t group) { - // If removed, compilation error occurs. - return 0; + // If removed, compilation error occurs. + return 0; } int PerlLIOChsize(struct IPerlLIO* piPerl, int handle, long size) { - return (nw_chsize(handle,size)); + return (nw_chsize(handle,size)); } int @@ -788,7 +788,7 @@ PerlLIODup2(struct IPerlLIO* piPerl, int handle1, int handle2) int PerlLIOFlock(struct IPerlLIO* piPerl, int fd, int oper) { - //On NetWare simulate flock by locking a range on the file + //On NetWare simulate flock by locking a range on the file return nw_flock(fd, oper); } @@ -801,8 +801,8 @@ PerlLIOFileStat(struct IPerlLIO* piPerl, int handle, struct stat *buffer) int PerlLIOIOCtl(struct IPerlLIO* piPerl, int i, unsigned int u, char *data) { - // If removed, compilation error occurs. - return 0; + // If removed, compilation error occurs. + return 0; } int @@ -832,7 +832,7 @@ PerlLIOLstat(struct IPerlLIO* piPerl, const char *path, struct stat *buffer) char* PerlLIOMktemp(struct IPerlLIO* piPerl, char *Template) { - return(nw_mktemp(Template)); + return(nw_mktemp(Template)); } int @@ -939,37 +939,37 @@ struct IPerlLIO perlLIO = int PerlDirMakedir(struct IPerlDir* piPerl, const char *dirname, int mode) { - return mkdir(dirname); + return mkdir(dirname); } int PerlDirChdir(struct IPerlDir* piPerl, const char *dirname) { - return nw_chdir(dirname); + return nw_chdir(dirname); } int PerlDirRmdir(struct IPerlDir* piPerl, const char *dirname) { - return nw_rmdir(dirname); + return nw_rmdir(dirname); } int PerlDirClose(struct IPerlDir* piPerl, DIR *dirp) { - return nw_closedir(dirp); + return nw_closedir(dirp); } DIR* PerlDirOpen(struct IPerlDir* piPerl, const char *filename) { - return nw_opendir(filename); + return nw_opendir(filename); } struct direct * PerlDirRead(struct IPerlDir* piPerl, DIR *dirp) { - return nw_readdir(dirp); + return nw_readdir(dirp); } void @@ -1008,42 +1008,42 @@ struct IPerlDir perlDir = u_long PerlSockHtonl(struct IPerlSock* piPerl, u_long hostlong) { - return(nw_htonl(hostlong)); + return(nw_htonl(hostlong)); } u_short PerlSockHtons(struct IPerlSock* piPerl, u_short hostshort) { - return(nw_htons(hostshort)); + return(nw_htons(hostshort)); } u_long PerlSockNtohl(struct IPerlSock* piPerl, u_long netlong) { - return nw_ntohl(netlong); + return nw_ntohl(netlong); } u_short PerlSockNtohs(struct IPerlSock* piPerl, u_short netshort) { - return nw_ntohs(netshort); + return nw_ntohs(netshort); } SOCKET PerlSockAccept(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* addr, int* addrlen) { - return nw_accept(s, addr, addrlen); + return nw_accept(s, addr, addrlen); } int PerlSockBind(struct IPerlSock* piPerl, SOCKET s, const struct sockaddr* name, int namelen) { - return nw_bind(s, name, namelen); + return nw_bind(s, name, namelen); } int PerlSockConnect(struct IPerlSock* piPerl, SOCKET s, const struct sockaddr* name, int namelen) { - return nw_connect(s, name, namelen); + return nw_connect(s, name, namelen); } void @@ -1073,7 +1073,7 @@ PerlSockEndservent(struct IPerlSock* piPerl) struct hostent* PerlSockGethostbyaddr(struct IPerlSock* piPerl, const char* addr, int len, int type) { - return(nw_gethostbyaddr(addr,len,type)); + return(nw_gethostbyaddr(addr,len,type)); } struct hostent* @@ -1085,13 +1085,13 @@ PerlSockGethostbyname(struct IPerlSock* piPerl, const char* name) struct hostent* PerlSockGethostent(struct IPerlSock* piPerl) { - return(nw_gethostent()); + return(nw_gethostent()); } int PerlSockGethostname(struct IPerlSock* piPerl, char* name, int namelen) { - return nw_gethostname(name,namelen); + return nw_gethostname(name,namelen); } struct netent * @@ -1144,31 +1144,31 @@ PerlSockGetservbyname(struct IPerlSock* piPerl, const char* name, const char* pr struct servent* PerlSockGetservbyport(struct IPerlSock* piPerl, int port, const char* proto) { - return nw_getservbyport(port, proto); + return nw_getservbyport(port, proto); } struct servent* PerlSockGetservent(struct IPerlSock* piPerl) { - return nw_getservent(); + return nw_getservent(); } int PerlSockGetsockname(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* name, int* namelen) { - return nw_getsockname(s, name, namelen); + return nw_getsockname(s, name, namelen); } int PerlSockGetsockopt(struct IPerlSock* piPerl, SOCKET s, int level, int optname, char* optval, int* optlen) { - return nw_getsockopt(s, level, optname, optval, optlen); + return nw_getsockopt(s, level, optname, optval, optlen); } unsigned long PerlSockInetAddr(struct IPerlSock* piPerl, const char* cp) { - return(nw_inet_addr(cp)); + return(nw_inet_addr(cp)); } char* @@ -1180,79 +1180,79 @@ PerlSockInetNtoa(struct IPerlSock* piPerl, struct in_addr in) int PerlSockListen(struct IPerlSock* piPerl, SOCKET s, int backlog) { - return (nw_listen(s, backlog)); + return (nw_listen(s, backlog)); } int PerlSockRecv(struct IPerlSock* piPerl, SOCKET s, char* buffer, int len, int flags) { - return (nw_recv(s, buffer, len, flags)); + return (nw_recv(s, buffer, len, flags)); } int PerlSockRecvfrom(struct IPerlSock* piPerl, SOCKET s, char* buffer, int len, int flags, struct sockaddr* from, int* fromlen) { - return nw_recvfrom(s, buffer, len, flags, from, fromlen); + return nw_recvfrom(s, buffer, len, flags, from, fromlen); } int PerlSockSelect(struct IPerlSock* piPerl, int nfds, char* readfds, char* writefds, char* exceptfds, const struct timeval* timeout) { - return nw_select(nfds, (fd_set*) readfds, (fd_set*) writefds, (fd_set*) exceptfds, timeout); + return nw_select(nfds, (fd_set*) readfds, (fd_set*) writefds, (fd_set*) exceptfds, timeout); } int PerlSockSend(struct IPerlSock* piPerl, SOCKET s, const char* buffer, int len, int flags) { - return (nw_send(s, buffer, len, flags)); + return (nw_send(s, buffer, len, flags)); } int PerlSockSendto(struct IPerlSock* piPerl, SOCKET s, const char* buffer, int len, int flags, const struct sockaddr* to, int tolen) { - return(nw_sendto(s, buffer, len, flags, to, tolen)); + return(nw_sendto(s, buffer, len, flags, to, tolen)); } void PerlSockSethostent(struct IPerlSock* piPerl, int stayopen) { - nw_sethostent(stayopen); + nw_sethostent(stayopen); } void PerlSockSetnetent(struct IPerlSock* piPerl, int stayopen) { - nw_setnetent(stayopen); + nw_setnetent(stayopen); } void PerlSockSetprotoent(struct IPerlSock* piPerl, int stayopen) { - nw_setprotoent(stayopen); + nw_setprotoent(stayopen); } void PerlSockSetservent(struct IPerlSock* piPerl, int stayopen) { - nw_setservent(stayopen); + nw_setservent(stayopen); } int PerlSockSetsockopt(struct IPerlSock* piPerl, SOCKET s, int level, int optname, const char* optval, int optlen) { - return nw_setsockopt(s, level, optname, optval, optlen); + return nw_setsockopt(s, level, optname, optval, optlen); } int PerlSockShutdown(struct IPerlSock* piPerl, SOCKET s, int how) { - return nw_shutdown(s, how); + return nw_shutdown(s, how); } SOCKET PerlSockSocket(struct IPerlSock* piPerl, int af, int type, int protocol) { - return nw_socket(af, type, protocol); + return nw_socket(af, type, protocol); } int @@ -1266,9 +1266,9 @@ PerlSockSocketpair(struct IPerlSock* piPerl, int domain, int type, int protocol, int PerlSockIoctlsocket(struct IPerlSock* piPerl, SOCKET s, long cmd, u_long *argp) { - dTHX; // (J) dTHXo + dTHX; // (J) dTHXo Perl_croak(aTHX_ "ioctlsocket not implemented!\n"); - return 0; + return 0; } struct IPerlSock perlSock = @@ -1301,8 +1301,8 @@ struct IPerlSock perlSock = PerlSockGetsockname, PerlSockGetsockopt, PerlSockInetAddr, - PerlSockInetNtoa, - PerlSockListen, + PerlSockInetNtoa, + PerlSockListen, PerlSockRecv, PerlSockRecvfrom, PerlSockSelect, @@ -1314,9 +1314,9 @@ struct IPerlSock perlSock = PerlSockSetservent, PerlSockSetsockopt, PerlSockShutdown, - PerlSockSocket, + PerlSockSocket, PerlSockSocketpair, - //Following commented by sgp bcos of comiplation error too many initializers (E279) + //Following commented by sgp bcos of comiplation error too many initializers (E279) // PerlSockClosesocket, }; @@ -1342,25 +1342,25 @@ void PerlProcExit(struct IPerlProc* piPerl, int status) { // exit(status); - dTHX; - //dJMPENV; - JMPENV_JUMP(2); + dTHX; + //dJMPENV; + JMPENV_JUMP(2); } void PerlProc_Exit(struct IPerlProc* piPerl, int status) { // _exit(status); - dTHX; - //dJMPENV; - JMPENV_JUMP(2); + dTHX; + //dJMPENV; + JMPENV_JUMP(2); } int PerlProcExecl(struct IPerlProc* piPerl, const char *cmdname, const char *arg0, const char *arg1, const char *arg2, const char *arg3) { - // If removed, compilation error occurs. - return 0; + // If removed, compilation error occurs. + return 0; } int @@ -1378,36 +1378,36 @@ PerlProcExecvp(struct IPerlProc* piPerl, const char *cmdname, const char *const uid_t PerlProcGetuid(struct IPerlProc* piPerl) { - // If removed, compilation error occurs. - return 0; + // If removed, compilation error occurs. + return 0; } uid_t PerlProcGeteuid(struct IPerlProc* piPerl) { - // If removed, compilation error occurs. - return 0; + // If removed, compilation error occurs. + return 0; } gid_t PerlProcGetgid(struct IPerlProc* piPerl) { - // If removed, compilation error occurs. - return 0; + // If removed, compilation error occurs. + return 0; } gid_t PerlProcGetegid(struct IPerlProc* piPerl) { - // If removed, compilation error occurs. - return 0; + // If removed, compilation error occurs. + return 0; } char * PerlProcGetlogin(struct IPerlProc* piPerl) { - // If removed, compilation error occurs. - return NULL; + // If removed, compilation error occurs. + return NULL; } int @@ -1436,7 +1436,7 @@ PerlProcPopen(struct IPerlProc* piPerl, const char *command, const char *mode) dTHX; // (J) dTHXo PERL_FLUSHALL_FOR_CHILD; - return (PerlIO*)nw_Popen((char *)command, (char *)mode, (int *)errno); + return (PerlIO*)nw_Popen((char *)command, (char *)mode, (int *)errno); } int @@ -1454,15 +1454,15 @@ PerlProcPipe(struct IPerlProc* piPerl, int *phandles) int PerlProcSetuid(struct IPerlProc* piPerl, uid_t u) { - // If removed, compilation error occurs. - return 0; + // If removed, compilation error occurs. + return 0; } int PerlProcSetgid(struct IPerlProc* piPerl, gid_t g) { - // If removed, compilation error occurs. - return 0; + // If removed, compilation error occurs. + return 0; } int @@ -1492,15 +1492,15 @@ PerlProcWaitpid(struct IPerlProc* piPerl, int pid, int *status, int flags) Sighandler_t PerlProcSignal(struct IPerlProc* piPerl, int sig, Sighandler_t subcode) { - // If removed, compilation error occurs. + // If removed, compilation error occurs. return 0; } int PerlProcFork(struct IPerlProc* piPerl) { - // If removed, compilation error occurs. - return 0; + // If removed, compilation error occurs. + return 0; } int @@ -1582,8 +1582,8 @@ CPerlHost::CPerlHost(void) m_pVMemShared = new VMem(); m_pVMemParse = new VMem(); - memcpy(&m_hostperlMem, &perlMem, sizeof(perlMem)); - memcpy(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared)); + memcpy(&m_hostperlMem, &perlMem, sizeof(perlMem)); + memcpy(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared)); memcpy(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse)); memcpy(&m_hostperlEnv, &perlEnv, sizeof(perlEnv)); memcpy(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO)); @@ -1605,26 +1605,26 @@ CPerlHost::CPerlHost(void) #define SETUPEXCHANGE(xptr, iptr, table) \ STMT_START { \ - if (xptr) { \ - iptr = *xptr; \ - *xptr = &table; \ - } \ - else { \ - iptr = &table; \ - } \ + if (xptr) { \ + iptr = *xptr; \ + *xptr = &table; \ + } \ + else { \ + iptr = &table; \ + } \ } STMT_END CPerlHost::CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, - struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv, - struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO, - struct IPerlDir** ppDir, struct IPerlSock** ppSock, - struct IPerlProc** ppProc) + struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv, + struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO, + struct IPerlDir** ppDir, struct IPerlSock** ppSock, + struct IPerlProc** ppProc) { m_pVMem = new VMem(); m_pVMemShared = new VMem(); m_pVMemParse = new VMem(); - memcpy(&m_hostperlMem, &perlMem, sizeof(perlMem)); + memcpy(&m_hostperlMem, &perlMem, sizeof(perlMem)); memcpy(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared)); memcpy(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse)); memcpy(&m_hostperlEnv, &perlEnv, sizeof(perlEnv)); @@ -1648,7 +1648,7 @@ CPerlHost::CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, CPerlHost::CPerlHost(const CPerlHost& host) { - memcpy(&m_hostperlMem, &perlMem, sizeof(perlMem)); + memcpy(&m_hostperlMem, &perlMem, sizeof(perlMem)); memcpy(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared)); memcpy(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse)); memcpy(&m_hostperlEnv, &perlEnv, sizeof(perlEnv)); @@ -1672,26 +1672,26 @@ CPerlHost::CPerlHost(const CPerlHost& host) CPerlHost::~CPerlHost(void) { - if ( m_pVMemParse ) delete m_pVMemParse; - if ( m_pVMemShared ) delete m_pVMemShared; - if ( m_pVMem ) delete m_pVMem; + if ( m_pVMemParse ) delete m_pVMemParse; + if ( m_pVMemShared ) delete m_pVMemShared; + if ( m_pVMem ) delete m_pVMem; } char* CPerlHost::Getenv(const char *varname) { - // getenv is always present. In old CLIB, it is implemented - // to always return NULL. With java loaded on NW411, it will - // return values set by envset. Is correctly implemented by - // CLIB on MOAB. - // - return getenv(varname); + // getenv is always present. In old CLIB, it is implemented + // to always return NULL. With java loaded on NW411, it will + // return values set by envset. Is correctly implemented by + // CLIB on MOAB. + // + return getenv(varname); } int CPerlHost::Putenv(const char *envstring) { - return(putenv(envstring)); + return(putenv(envstring)); } diff --git a/NetWare/nwperlsys.c b/NetWare/nwperlsys.c index 32c15cb4380b..adc9abc75e92 100644 --- a/NetWare/nwperlsys.c +++ b/NetWare/nwperlsys.c @@ -34,10 +34,10 @@ Function : fnFreeMemEntry Description : Called for each outstanding memory allocation at the end of a script run. - Frees the outstanding allocations + Frees the outstanding allocations Parameters : ptr (IN). - context (IN) + context (IN) Returns : Nothing. @@ -45,10 +45,10 @@ void fnFreeMemEntry(void* ptr, void* context) { - if(ptr) - { - PerlMemFree(NULL, ptr); - } + if(ptr) + { + PerlMemFree(NULL, ptr); + } } /*============================================================================================ @@ -84,21 +84,21 @@ perl_alloc(void) { PerlInterpreter* my_perl = NULL; - WCValHashTable* m_allocList; - m_allocList = new WCValHashTable (fnAllocListHash, 256); - fnInsertHashListAddrs(m_allocList, FALSE); - my_perl = perl_alloc_using(&perlMem, - &perlMem, - NULL, - &perlEnv, - &perlStdIO, - &perlLIO, - &perlDir, - &perlSock, - &perlProc); - if (my_perl) { - //nw5_internal_host = m_allocList; - } + WCValHashTable* m_allocList; + m_allocList = new WCValHashTable (fnAllocListHash, 256); + fnInsertHashListAddrs(m_allocList, FALSE); + my_perl = perl_alloc_using(&perlMem, + &perlMem, + NULL, + &perlEnv, + &perlStdIO, + &perlLIO, + &perlDir, + &perlSock, + &perlProc); + if (my_perl) { + //nw5_internal_host = m_allocList; + } return my_perl; } @@ -115,72 +115,72 @@ perl_alloc(void) ==============================================================================================*/ EXTERN_C PerlInterpreter* perl_alloc_override(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, - struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv, - struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO, - struct IPerlDir** ppDir, struct IPerlSock** ppSock, - struct IPerlProc** ppProc) + struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv, + struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO, + struct IPerlDir** ppDir, struct IPerlSock** ppSock, + struct IPerlProc** ppProc) { PerlInterpreter *my_perl = NULL; - struct IPerlMem* lpMem; - struct IPerlEnv* lpEnv; - struct IPerlStdIO* lpStdio; - struct IPerlLIO* lpLIO; - struct IPerlDir* lpDir; - struct IPerlSock* lpSock; - struct IPerlProc* lpProc; - - WCValHashTable* m_allocList; - m_allocList = new WCValHashTable (fnAllocListHash, 256); - fnInsertHashListAddrs(m_allocList, FALSE); - - if (!ppMem) - lpMem=&perlMem; - else - lpMem=*ppMem; - - if (!ppEnv) - lpEnv=&perlEnv; - else - lpEnv=*ppEnv; - - if (!ppStdIO) - lpStdio=&perlStdIO; - else - lpStdio=*ppStdIO; - - if (!ppLIO) - lpLIO=&perlLIO; - else - lpLIO=*ppLIO; - - if (!ppDir) - lpDir=&perlDir; - else - lpDir=*ppDir; - - if (!ppSock) - lpSock=&perlSock; - else - lpSock=*ppSock; - - if (!ppProc) - lpProc=&perlProc; - else - lpProc=*ppProc; - my_perl = perl_alloc_using(lpMem, - lpMem, - NULL, - lpEnv, - lpStdio, - lpLIO, - lpDir, - lpSock, - lpProc); - - if (my_perl) { - //nw5_internal_host = pHost; - } + struct IPerlMem* lpMem; + struct IPerlEnv* lpEnv; + struct IPerlStdIO* lpStdio; + struct IPerlLIO* lpLIO; + struct IPerlDir* lpDir; + struct IPerlSock* lpSock; + struct IPerlProc* lpProc; + + WCValHashTable* m_allocList; + m_allocList = new WCValHashTable (fnAllocListHash, 256); + fnInsertHashListAddrs(m_allocList, FALSE); + + if (!ppMem) + lpMem=&perlMem; + else + lpMem=*ppMem; + + if (!ppEnv) + lpEnv=&perlEnv; + else + lpEnv=*ppEnv; + + if (!ppStdIO) + lpStdio=&perlStdIO; + else + lpStdio=*ppStdIO; + + if (!ppLIO) + lpLIO=&perlLIO; + else + lpLIO=*ppLIO; + + if (!ppDir) + lpDir=&perlDir; + else + lpDir=*ppDir; + + if (!ppSock) + lpSock=&perlSock; + else + lpSock=*ppSock; + + if (!ppProc) + lpProc=&perlProc; + else + lpProc=*ppProc; + my_perl = perl_alloc_using(lpMem, + lpMem, + NULL, + lpEnv, + lpStdio, + lpLIO, + lpDir, + lpSock, + lpProc); + + if (my_perl) { + //nw5_internal_host = pHost; + } return my_perl; } /*============================================================================================ @@ -198,19 +198,19 @@ perl_alloc_override(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, EXTERN_C void nw5_delete_internal_host(void *h) { - WCValHashTable* m_allocList; - void **listptr; - BOOL m_dontTouchHashLists; - if (fnGetHashListAddrs(&listptr,&m_dontTouchHashLists)) { - m_allocList = (WCValHashTable*)listptr; - fnInsertHashListAddrs(m_allocList, TRUE); - if (m_allocList) - { - m_allocList->forAll(fnFreeMemEntry, NULL); - fnInsertHashListAddrs(NULL, FALSE); - delete m_allocList; - } - } + WCValHashTable* m_allocList; + void **listptr; + BOOL m_dontTouchHashLists; + if (fnGetHashListAddrs(&listptr,&m_dontTouchHashLists)) { + m_allocList = (WCValHashTable*)listptr; + fnInsertHashListAddrs(m_allocList, TRUE); + if (m_allocList) + { + m_allocList->forAll(fnFreeMemEntry, NULL); + fnInsertHashListAddrs(NULL, FALSE); + delete m_allocList; + } + } } #endif /* PERL_IMPLICIT_SYS */ diff --git a/NetWare/nwperlsys.h b/NetWare/nwperlsys.h index 3d82dd1c8dd5..34f713d28752 100644 --- a/NetWare/nwperlsys.h +++ b/NetWare/nwperlsys.h @@ -48,103 +48,103 @@ END_EXTERN_C void* PerlMemMalloc(struct IPerlMem* piPerl, size_t size) { - void *ptr = NULL; - ptr = malloc(size); - if (ptr) { - void **listptr; - BOOL m_dontTouchHashLists; - if(fnGetHashListAddrs(&listptr,&m_dontTouchHashLists)) { - if (listptr) { - WCValHashTable* m_allocList= (WCValHashTable*)listptr; - (WCValHashTable*)m_allocList->insert(ptr); - } - } - } - return(ptr); + void *ptr = NULL; + ptr = malloc(size); + if (ptr) { + void **listptr; + BOOL m_dontTouchHashLists; + if(fnGetHashListAddrs(&listptr,&m_dontTouchHashLists)) { + if (listptr) { + WCValHashTable* m_allocList= (WCValHashTable*)listptr; + (WCValHashTable*)m_allocList->insert(ptr); + } + } + } + return(ptr); } void* PerlMemRealloc(struct IPerlMem* piPerl, void* ptr, size_t size) { - void *newptr = NULL; - WCValHashTable* m_allocList; + void *newptr = NULL; + WCValHashTable* m_allocList; - newptr = realloc(ptr, size); + newptr = realloc(ptr, size); - if (ptr) - { - void **listptr; - BOOL m_dontTouchHashLists; - if(fnGetHashListAddrs(&listptr,&m_dontTouchHashLists)) { - m_allocList= (WCValHashTable*)listptr; - (WCValHashTable*)m_allocList->remove(ptr); - } - } - if (newptr) - { - if (m_allocList) - (WCValHashTable*)m_allocList->insert(newptr); - } + if (ptr) + { + void **listptr; + BOOL m_dontTouchHashLists; + if(fnGetHashListAddrs(&listptr,&m_dontTouchHashLists)) { + m_allocList= (WCValHashTable*)listptr; + (WCValHashTable*)m_allocList->remove(ptr); + } + } + if (newptr) + { + if (m_allocList) + (WCValHashTable*)m_allocList->insert(newptr); + } - return(newptr); + return(newptr); } void PerlMemFree(struct IPerlMem* piPerl, void* ptr) { - BOOL m_dontTouchHashLists; - WCValHashTable* m_allocList; - - void **listptr; - if(fnGetHashListAddrs(&listptr,&m_dontTouchHashLists)) { - m_allocList= (WCValHashTable*)listptr; - // Final clean up, free all the nodes from the hash list - if (m_dontTouchHashLists) - { - if(ptr) - { - free(ptr); - ptr = NULL; - } - } - else - { - if(ptr && m_allocList) - { - if ((WCValHashTable*)m_allocList->remove(ptr)) - { - free(ptr); - ptr = NULL; - } - else - { - // If it comes here, that means that the memory pointer is not contained in the hash list. - // But no need to free now, since if is deleted here, it will result in an abend!! - // If the memory is still there, it will be cleaned during final cleanup anyway. - } - } - } - } - return; + BOOL m_dontTouchHashLists; + WCValHashTable* m_allocList; + + void **listptr; + if(fnGetHashListAddrs(&listptr,&m_dontTouchHashLists)) { + m_allocList= (WCValHashTable*)listptr; + // Final clean up, free all the nodes from the hash list + if (m_dontTouchHashLists) + { + if(ptr) + { + free(ptr); + ptr = NULL; + } + } + else + { + if(ptr && m_allocList) + { + if ((WCValHashTable*)m_allocList->remove(ptr)) + { + free(ptr); + ptr = NULL; + } + else + { + // If it comes here, that means that the memory pointer is not contained in the hash list. + // But no need to free now, since if is deleted here, it will result in an abend!! + // If the memory is still there, it will be cleaned during final cleanup anyway. + } + } + } + } + return; } void* PerlMemCalloc(struct IPerlMem* piPerl, size_t num, size_t size) { - void *ptr = NULL; + void *ptr = NULL; - ptr = calloc(num, size); - if (ptr) { - void **listptr; - BOOL m_dontTouchHashLists; - if(fnGetHashListAddrs(&listptr,&m_dontTouchHashLists)) { - if (listptr) { - WCValHashTable* m_allocList= (WCValHashTable*)listptr; - (WCValHashTable*)m_allocList->insert(ptr); - } - } - } - return(ptr); + ptr = calloc(num, size); + if (ptr) { + void **listptr; + BOOL m_dontTouchHashLists; + if(fnGetHashListAddrs(&listptr,&m_dontTouchHashLists)) { + if (listptr) { + WCValHashTable* m_allocList= (WCValHashTable*)listptr; + (WCValHashTable*)m_allocList->insert(ptr); + } + } + } + return(ptr); } struct IPerlMem perlMem = @@ -162,37 +162,37 @@ struct IPerlMem perlMem = int PerlDirMakedir(struct IPerlDir* piPerl, const char *dirname, int mode) { - return mkdir(dirname); + return mkdir(dirname); } int PerlDirChdir(struct IPerlDir* piPerl, const char *dirname) { - return nw_chdir(dirname); + return nw_chdir(dirname); } int PerlDirRmdir(struct IPerlDir* piPerl, const char *dirname) { - return nw_rmdir(dirname); + return nw_rmdir(dirname); } int PerlDirClose(struct IPerlDir* piPerl, DIR *dirp) { - return nw_closedir(dirp); + return nw_closedir(dirp); } DIR* PerlDirOpen(struct IPerlDir* piPerl, const char *filename) { - return nw_opendir(filename); + return nw_opendir(filename); } struct direct * PerlDirRead(struct IPerlDir* piPerl, DIR *dirp) { - return nw_readdir(dirp); + return nw_readdir(dirp); } void @@ -215,7 +215,7 @@ PerlDirTell(struct IPerlDir* piPerl, DIR *dirp) struct IPerlDir perlDir = { - PerlDirMakedir, + PerlDirMakedir, PerlDirChdir, PerlDirRmdir, PerlDirClose, @@ -233,23 +233,23 @@ struct IPerlDir perlDir = char* PerlEnvGetenv(struct IPerlEnv* piPerl, const char *varname) { - return(getenv(varname)); + return(getenv(varname)); }; int PerlEnvPutenv(struct IPerlEnv* piPerl, const char *envstring) { - return(putenv(envstring)); + return(putenv(envstring)); }; char* PerlEnvGetenv_len(struct IPerlEnv* piPerl, const char* varname, unsigned long* len) { - *len = 0; - char *e = getenv(varname); - if (e) - *len = strlen(e); - return e; + *len = 0; + char *e = getenv(varname); + if (e) + *len = strlen(e); + return e; } int @@ -261,13 +261,13 @@ PerlEnvUname(struct IPerlEnv* piPerl, struct utsname *name) void PerlEnvClearenv(struct IPerlEnv* piPerl) { - + } struct IPerlEnv perlEnv = { - PerlEnvGetenv, - PerlEnvPutenv, + PerlEnvGetenv, + PerlEnvPutenv, PerlEnvGetenv_len, PerlEnvUname, PerlEnvClearenv, @@ -559,17 +559,17 @@ PerlStdIOFdupopen(struct IPerlStdIO* piPerl, FILE* pf) /* open the file in the same mode */ if(((FILE*)pf)->_flag & _IOREAD) { - mode[0] = 'r'; - mode[1] = 0; + mode[0] = 'r'; + mode[1] = 0; } else if(((FILE*)pf)->_flag & _IOWRT) { - mode[0] = 'a'; - mode[1] = 0; + mode[0] = 'a'; + mode[1] = 0; } else if(((FILE*)pf)->_flag & _IORW) { - mode[0] = 'r'; - mode[1] = '+'; - mode[2] = 0; + mode[0] = 'r'; + mode[1] = '+'; + mode[2] = 0; } /* it appears that the binmode is attached to the @@ -580,14 +580,14 @@ PerlStdIOFdupopen(struct IPerlStdIO* piPerl, FILE* pf) /* move the file pointer to the same position */ if (!fgetpos(pf, &pos)) { - fsetpos(pfdup, &pos); + fsetpos(pfdup, &pos); } return pfdup; } struct IPerlStdIO perlStdIO = { - PerlStdIOStdin, + PerlStdIOStdin, PerlStdIOStdout, PerlStdIOStderr, PerlStdIOOpen, @@ -647,15 +647,15 @@ PerlLIOChmod(struct IPerlLIO* piPerl, const char *filename, int pmode) int PerlLIOChown(struct IPerlLIO* piPerl, const char *filename, uid_t owner, gid_t group) { - dTHX; + dTHX; Perl_croak(aTHX_ "chown not implemented!\n"); - return 0; + return 0; } int PerlLIOChsize(struct IPerlLIO* piPerl, int handle, long size) { - return (nw_chsize(handle,size)); + return (nw_chsize(handle,size)); } int @@ -679,7 +679,7 @@ PerlLIODup2(struct IPerlLIO* piPerl, int handle1, int handle2) int PerlLIOFlock(struct IPerlLIO* piPerl, int fd, int oper) { - //On NetWare simulate flock by locking a range on the file + //On NetWare simulate flock by locking a range on the file return nw_flock(fd, oper); } @@ -692,7 +692,7 @@ PerlLIOFileStat(struct IPerlLIO* piPerl, int handle, struct stat *buffer) int PerlLIOIOCtl(struct IPerlLIO* piPerl, int i, unsigned int u, char *data) { - return 0; + return 0; } int @@ -722,7 +722,7 @@ PerlLIOLstat(struct IPerlLIO* piPerl, const char *path, struct stat *buffer) char* PerlLIOMktemp(struct IPerlLIO* piPerl, char *Template) { - return(nw_mktemp(Template)); + return(nw_mktemp(Template)); } int @@ -793,7 +793,7 @@ PerlLIOWrite(struct IPerlLIO* piPerl, int handle, const void *buffer, unsigned i struct IPerlLIO perlLIO = { - PerlLIOAccess, + PerlLIOAccess, PerlLIOChmod, PerlLIOChown, PerlLIOChsize, @@ -844,26 +844,26 @@ void PerlProcExit(struct IPerlProc* piPerl, int status) { // exit(status); - dTHX; - dJMPENV; - JMPENV_JUMP(2); + dTHX; + dJMPENV; + JMPENV_JUMP(2); } void PerlProc_Exit(struct IPerlProc* piPerl, int status) { // _exit(status); - dTHX; - dJMPENV; - JMPENV_JUMP(2); + dTHX; + dJMPENV; + JMPENV_JUMP(2); } int PerlProcExecl(struct IPerlProc* piPerl, const char *cmdname, const char *arg0, const char *arg1, const char *arg2, const char *arg3) { - dTHX; + dTHX; Perl_croak(aTHX_ "execl not implemented!\n"); - return 0; + return 0; } int @@ -881,31 +881,31 @@ PerlProcExecvp(struct IPerlProc* piPerl, const char *cmdname, const char *const uid_t PerlProcGetuid(struct IPerlProc* piPerl) { - return 0; + return 0; } uid_t PerlProcGeteuid(struct IPerlProc* piPerl) { - return 0; + return 0; } gid_t PerlProcGetgid(struct IPerlProc* piPerl) { - return 0; + return 0; } gid_t PerlProcGetegid(struct IPerlProc* piPerl) { - return 0; + return 0; } char * PerlProcGetlogin(struct IPerlProc* piPerl) { - return NULL; + return NULL; } int @@ -934,7 +934,7 @@ PerlProcPopen(struct IPerlProc* piPerl, const char *command, const char *mode) dTHX; PERL_FLUSHALL_FOR_CHILD; - return (PerlIO*)nw_Popen((char *)command, (char *)mode, (int *)errno); + return (PerlIO*)nw_Popen((char *)command, (char *)mode, (int *)errno); } int @@ -952,13 +952,13 @@ PerlProcPipe(struct IPerlProc* piPerl, int *phandles) int PerlProcSetuid(struct IPerlProc* piPerl, uid_t u) { - return 0; + return 0; } int PerlProcSetgid(struct IPerlProc* piPerl, gid_t g) { - return 0; + return 0; } int @@ -994,7 +994,7 @@ PerlProcSignal(struct IPerlProc* piPerl, int sig, Sighandler_t subcode) int PerlProcFork(struct IPerlProc* piPerl) { - return 0; + return 0; } int @@ -1068,42 +1068,42 @@ struct IPerlProc perlProc = u_long PerlSockHtonl(struct IPerlSock* piPerl, u_long hostlong) { - return(nw_htonl(hostlong)); + return(nw_htonl(hostlong)); } u_short PerlSockHtons(struct IPerlSock* piPerl, u_short hostshort) { - return(nw_htons(hostshort)); + return(nw_htons(hostshort)); } u_long PerlSockNtohl(struct IPerlSock* piPerl, u_long netlong) { - return nw_ntohl(netlong); + return nw_ntohl(netlong); } u_short PerlSockNtohs(struct IPerlSock* piPerl, u_short netshort) { - return nw_ntohs(netshort); + return nw_ntohs(netshort); } SOCKET PerlSockAccept(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* addr, int* addrlen) { - return nw_accept(s, addr, addrlen); + return nw_accept(s, addr, addrlen); } int PerlSockBind(struct IPerlSock* piPerl, SOCKET s, const struct sockaddr* name, int namelen) { - return nw_bind(s, name, namelen); + return nw_bind(s, name, namelen); } int PerlSockConnect(struct IPerlSock* piPerl, SOCKET s, const struct sockaddr* name, int namelen) { - return nw_connect(s, name, namelen); + return nw_connect(s, name, namelen); } void @@ -1133,7 +1133,7 @@ PerlSockEndservent(struct IPerlSock* piPerl) struct hostent* PerlSockGethostbyaddr(struct IPerlSock* piPerl, const char* addr, int len, int type) { - return(nw_gethostbyaddr(addr,len,type)); + return(nw_gethostbyaddr(addr,len,type)); } struct hostent* @@ -1145,13 +1145,13 @@ PerlSockGethostbyname(struct IPerlSock* piPerl, const char* name) struct hostent* PerlSockGethostent(struct IPerlSock* piPerl) { - return(nw_gethostent()); + return(nw_gethostent()); } int PerlSockGethostname(struct IPerlSock* piPerl, char* name, int namelen) { - return nw_gethostname(name,namelen); + return nw_gethostname(name,namelen); } struct netent * @@ -1204,115 +1204,115 @@ PerlSockGetservbyname(struct IPerlSock* piPerl, const char* name, const char* pr struct servent* PerlSockGetservbyport(struct IPerlSock* piPerl, int port, const char* proto) { - return nw_getservbyport(port, proto); + return nw_getservbyport(port, proto); } struct servent* PerlSockGetservent(struct IPerlSock* piPerl) { - return nw_getservent(); + return nw_getservent(); } int PerlSockGetsockname(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* name, int* namelen) { - return nw_getsockname(s, name, namelen); + return nw_getsockname(s, name, namelen); } int PerlSockGetsockopt(struct IPerlSock* piPerl, SOCKET s, int level, int optname, char* optval, int* optlen) { - return nw_getsockopt(s, level, optname, optval, optlen); + return nw_getsockopt(s, level, optname, optval, optlen); } unsigned long PerlSockInetAddr(struct IPerlSock* piPerl, const char* cp) { - return(nw_inet_addr(cp)); + return(nw_inet_addr(cp)); } char* PerlSockInetNtoa(struct IPerlSock* piPerl, struct in_addr in) { - return NULL; + return NULL; } int PerlSockListen(struct IPerlSock* piPerl, SOCKET s, int backlog) { - return (nw_listen(s, backlog)); + return (nw_listen(s, backlog)); } int PerlSockRecv(struct IPerlSock* piPerl, SOCKET s, char* buffer, int len, int flags) { - return (nw_recv(s, buffer, len, flags)); + return (nw_recv(s, buffer, len, flags)); } int PerlSockRecvfrom(struct IPerlSock* piPerl, SOCKET s, char* buffer, int len, int flags, struct sockaddr* from, int* fromlen) { - return nw_recvfrom(s, buffer, len, flags, from, fromlen); + return nw_recvfrom(s, buffer, len, flags, from, fromlen); } int PerlSockSelect(struct IPerlSock* piPerl, int nfds, char* readfds, char* writefds, char* exceptfds, const struct timeval* timeout) { - return nw_select(nfds, (fd_set*) readfds, (fd_set*) writefds, (fd_set*) exceptfds, timeout); + return nw_select(nfds, (fd_set*) readfds, (fd_set*) writefds, (fd_set*) exceptfds, timeout); } int PerlSockSend(struct IPerlSock* piPerl, SOCKET s, const char* buffer, int len, int flags) { - return (nw_send(s, buffer, len, flags)); + return (nw_send(s, buffer, len, flags)); } int PerlSockSendto(struct IPerlSock* piPerl, SOCKET s, const char* buffer, int len, int flags, const struct sockaddr* to, int tolen) { - return(nw_sendto(s, buffer, len, flags, to, tolen)); + return(nw_sendto(s, buffer, len, flags, to, tolen)); } void PerlSockSethostent(struct IPerlSock* piPerl, int stayopen) { - nw_sethostent(stayopen); + nw_sethostent(stayopen); } void PerlSockSetnetent(struct IPerlSock* piPerl, int stayopen) { - nw_setnetent(stayopen); + nw_setnetent(stayopen); } void PerlSockSetprotoent(struct IPerlSock* piPerl, int stayopen) { - nw_setprotoent(stayopen); + nw_setprotoent(stayopen); } void PerlSockSetservent(struct IPerlSock* piPerl, int stayopen) { - nw_setservent(stayopen); + nw_setservent(stayopen); } int PerlSockSetsockopt(struct IPerlSock* piPerl, SOCKET s, int level, int optname, const char* optval, int optlen) { - return nw_setsockopt(s, level, optname, optval, optlen); + return nw_setsockopt(s, level, optname, optval, optlen); } int PerlSockShutdown(struct IPerlSock* piPerl, SOCKET s, int how) { - return nw_shutdown(s, how); + return nw_shutdown(s, how); } SOCKET PerlSockSocket(struct IPerlSock* piPerl, int af, int type, int protocol) { - return nw_socket(af, type, protocol); + return nw_socket(af, type, protocol); } int @@ -1326,14 +1326,14 @@ PerlSockSocketpair(struct IPerlSock* piPerl, int domain, int type, int protocol, int PerlSockIoctlsocket(struct IPerlSock* piPerl, SOCKET s, long cmd, u_long *argp) { - dTHX; + dTHX; Perl_croak(aTHX_ "ioctlsocket not implemented!\n"); - return 0; + return 0; } struct IPerlSock perlSock = { - PerlSockHtonl, + PerlSockHtonl, PerlSockHtons, PerlSockNtohl, PerlSockNtohs, @@ -1361,8 +1361,8 @@ struct IPerlSock perlSock = PerlSockGetsockname, PerlSockGetsockopt, PerlSockInetAddr, - PerlSockInetNtoa, - PerlSockListen, + PerlSockInetNtoa, + PerlSockListen, PerlSockRecv, PerlSockRecvfrom, PerlSockSelect, @@ -1374,7 +1374,7 @@ struct IPerlSock perlSock = PerlSockSetservent, PerlSockSetsockopt, PerlSockShutdown, - PerlSockSocket, + PerlSockSocket, PerlSockSocketpair, }; diff --git a/NetWare/nwpipe.h b/NetWare/nwpipe.h index 462a73dcf42c..1cf58706c13f 100644 --- a/NetWare/nwpipe.h +++ b/NetWare/nwpipe.h @@ -29,24 +29,24 @@ typedef struct tagTempPipeFile { - BOOL m_mode; // FALSE - Read mode ; TRUE - Write mode - BOOL m_launchPerl; - BOOL m_doPerlGlob; + BOOL m_mode; // FALSE - Read mode ; TRUE - Write mode + BOOL m_launchPerl; + BOOL m_doPerlGlob; - int m_argv_len; + int m_argv_len; - char * m_fileName; - char** m_argv; - char * m_redirect; + char * m_fileName; + char** m_argv; + char * m_redirect; - #ifdef MPK_ON - SEMAPHORE m_perlSynchSemaphore; - #else - long m_perlSynchSemaphore; - #endif + #ifdef MPK_ON + SEMAPHORE m_perlSynchSemaphore; + #else + long m_perlSynchSemaphore; + #endif - FILE* m_file; - PCOMMANDLINEPARSER m_pipeCommand; + FILE* m_file; + PCOMMANDLINEPARSER m_pipeCommand; } TEMPPIPEFILE, *PTEMPPIPEFILE; diff --git a/NetWare/nwplglob.c b/NetWare/nwplglob.c index 6810fd5e6973..fba55da7abce 100644 --- a/NetWare/nwplglob.c +++ b/NetWare/nwplglob.c @@ -36,7 +36,7 @@ Description : Perl globbing support: Takes an array of wildcard descriptors and produces from it a list of files that the wildcards expand into. - The list of files is written to the temporary file named by fileName. + The list of files is written to the temporary file named by fileName. Parameters : argv (IN) - Input argument vector. fileName (IN) - Input file name for storing globed file names. @@ -47,44 +47,44 @@ void fnDoPerlGlob(char** argv, char* fileName) { - FILE * redirOut = NULL; + FILE * redirOut = NULL; - if (*argv) - argv++; - if (*argv == NULL) - return; + if (*argv) + argv++; + if (*argv == NULL) + return; - redirOut = fopen((const char *)fileName, (const char *)"w"); - if (!redirOut) - return; + redirOut = fopen((const char *)fileName, (const char *)"w"); + if (!redirOut) + return; - do - { - DIR* dir = NULL; - DIR* fil = NULL; - char* pattern = NULL; + do + { + DIR* dir = NULL; + DIR* fil = NULL; + char* pattern = NULL; - pattern = *argv++; + pattern = *argv++; - dir = opendir((const char *)pattern); - if (!dir) - continue; + dir = opendir((const char *)pattern); + if (!dir) + continue; - /* find the last separator in pattern, NetWare has three: /\: */ - while (fil = readdir(dir)) - { - // The below displays the files separated by tab character. - // Also, it displays only the file names and not directories. - // If any other format is desired, it needs to be done here. - fprintf(redirOut, "%s\t", fil->d_name); - } + /* find the last separator in pattern, NetWare has three: /\: */ + while (fil = readdir(dir)) + { + // The below displays the files separated by tab character. + // Also, it displays only the file names and not directories. + // If any other format is desired, it needs to be done here. + fprintf(redirOut, "%s\t", fil->d_name); + } - closedir(dir); + closedir(dir); - } while (*argv); + } while (*argv); - fclose(redirOut); + fclose(redirOut); - return; + return; } diff --git a/NetWare/nwtinfo.h b/NetWare/nwtinfo.h index a08d060422c2..d8503d28112d 100644 --- a/NetWare/nwtinfo.h +++ b/NetWare/nwtinfo.h @@ -25,10 +25,10 @@ typedef struct tagThreadInfo { - int tid; - struct tagThreadInfo *next; - BOOL m_dontTouchHashLists; - void* m_allocList; + int tid; + struct tagThreadInfo *next; + BOOL m_dontTouchHashLists; + void* m_allocList; }ThreadInfo; void fnInitializeThreadInfo(void); @@ -39,17 +39,17 @@ BOOL fnRemoveThreadInfo(int tid); ThreadInfo* fnGetThreadInfo(int tid); #ifdef __cplusplus - //For storing and retrieving Watcom Hash list address - extern "C" BOOL fnInsertHashListAddrs(void *addrs, BOOL dontTouchHashList); - //Registering with the Thread table - extern "C" BOOL fnRegisterWithThreadTable(void); - extern "C" BOOL fnUnregisterWithThreadTable(void); + //For storing and retrieving Watcom Hash list address + extern "C" BOOL fnInsertHashListAddrs(void *addrs, BOOL dontTouchHashList); + //Registering with the Thread table + extern "C" BOOL fnRegisterWithThreadTable(void); + extern "C" BOOL fnUnregisterWithThreadTable(void); #else - //For storing and retrieving Watcom Hash list address - BOOL fnInsertHashListAddrs(void *addrs, BOOL dontTouchHashList); - //Registering with the Thread table - BOOL fnRegisterWithThreadTable(void); - BOOL fnUnregisterWithThreadTable(void); + //For storing and retrieving Watcom Hash list address + BOOL fnInsertHashListAddrs(void *addrs, BOOL dontTouchHashList); + //Registering with the Thread table + BOOL fnRegisterWithThreadTable(void); + BOOL fnUnregisterWithThreadTable(void); #endif BOOL fnGetHashListAddrs(void **addrs, BOOL *dontTouchHashList); @@ -58,9 +58,9 @@ BOOL fnGetHashListAddrs(void **addrs, BOOL *dontTouchHashList); //or see if the above portion can be removed once this works properly typedef struct tagThreadCtx { - long tid; - void *tInfo; - struct tagThreadCtx *next; + long tid; + void *tInfo; + struct tagThreadCtx *next; }ThreadContext; diff --git a/NetWare/nwutil.h b/NetWare/nwutil.h index ff05d1830f35..a27161147ddf 100644 --- a/NetWare/nwutil.h +++ b/NetWare/nwutil.h @@ -27,10 +27,10 @@ #ifdef MPK_ON - #include - #include + #include + #include #else - #include + #include #endif //MPK_ON @@ -43,28 +43,28 @@ typedef struct tagCommandLineParser { - BOOL m_noScreen; - BOOL m_AutoDestroy; - BOOL m_isValid; - - int m_argc; - int m_argv_len; - - #ifdef MPK_ON - SEMAPHORE m_qSemaphore; - #else - long m_qSemaphore; - #endif - - char* m_redirInName; - char* m_redirOutName; - char* m_redirErrName; - char* m_redirBothName; - char* nextarg; - char* sSkippedToken; - - char** m_argv; - char** new_argv; + BOOL m_noScreen; + BOOL m_AutoDestroy; + BOOL m_isValid; + + int m_argc; + int m_argv_len; + + #ifdef MPK_ON + SEMAPHORE m_qSemaphore; + #else + long m_qSemaphore; + #endif + + char* m_redirInName; + char* m_redirOutName; + char* m_redirErrName; + char* m_redirBothName; + char* nextarg; + char* sSkippedToken; + + char** m_argv; + char** new_argv; }COMMANDLINEPARSER, *PCOMMANDLINEPARSER; diff --git a/NetWare/nwvmem.h b/NetWare/nwvmem.h index e82eaeef8b50..98b287304419 100644 --- a/NetWare/nwvmem.h +++ b/NetWare/nwvmem.h @@ -38,12 +38,12 @@ class VMem virtual void* Malloc(size_t size); virtual void* Realloc(void* pMem, size_t size); virtual void Free(void* pMem); - virtual void* Calloc(size_t num, size_t size); + virtual void* Calloc(size_t num, size_t size); protected: - BOOL m_dontTouchHashLists; + BOOL m_dontTouchHashLists; // WCValHashTable* m_allocList; - NWPerlHashList *m_allocList; // CW changes + NWPerlHashList *m_allocList; // CW changes }; @@ -73,10 +73,10 @@ unsigned fnAllocListHash(void* const& invalue) Function : fnFreeMemEntry Description : Called for each outstanding memory allocation at the end of a script run. - Frees the outstanding allocations + Frees the outstanding allocations Parameters : ptr (IN). - context (IN) + context (IN) Returns : Nothing. @@ -84,15 +84,15 @@ unsigned fnAllocListHash(void* const& invalue) void fnFreeMemEntry(void* ptr, void* context) { - VMem* pVMem = (VMem*) context; - - if(ptr && pVMem) - { - pVMem->Free(ptr); - ptr=NULL; - pVMem = NULL; - context = NULL; - } + VMem* pVMem = (VMem*) context; + + if(ptr && pVMem) + { + pVMem->Free(ptr); + ptr=NULL; + pVMem = NULL; + context = NULL; + } } @@ -111,11 +111,11 @@ void fnFreeMemEntry(void* ptr, void* context) VMem::VMem() { - //Constructor - m_dontTouchHashLists = FALSE; - m_allocList = NULL; - // m_allocList = new WCValHashTable (fnAllocListHash, 256); - m_allocList = new NWPerlHashList(); // CW changes + //Constructor + m_dontTouchHashLists = FALSE; + m_allocList = NULL; + // m_allocList = new WCValHashTable (fnAllocListHash, 256); + m_allocList = new NWPerlHashList(); // CW changes } @@ -134,16 +134,16 @@ VMem::VMem() VMem::~VMem(void) { - //Destructor - m_dontTouchHashLists = TRUE; - if (m_allocList) - { - m_allocList->forAll(fnFreeMemEntry, (void*) this); - - delete m_allocList; - m_allocList = NULL; - } - m_dontTouchHashLists = FALSE; + //Destructor + m_dontTouchHashLists = TRUE; + if (m_allocList) + { + m_allocList->forAll(fnFreeMemEntry, (void*) this); + + delete m_allocList; + m_allocList = NULL; + } + m_dontTouchHashLists = FALSE; } @@ -162,33 +162,33 @@ VMem::~VMem(void) void* VMem::Malloc(size_t size) { - void *ptr = NULL; - - if (size <= 0) - return NULL; - - ptr = malloc(size); - if (ptr) - { - if(m_allocList) - m_allocList->insert(ptr); - } - else - { - m_dontTouchHashLists = TRUE; - if (m_allocList) - { - m_allocList->forAll(fnFreeMemEntry, (void*) this); - delete m_allocList; - m_allocList = NULL; - } - m_dontTouchHashLists = FALSE; - - // Serious error since memory allocation falied. So, exiting... - ExitThread(TSR_THREAD, 1); - } - - return(ptr); + void *ptr = NULL; + + if (size <= 0) + return NULL; + + ptr = malloc(size); + if (ptr) + { + if(m_allocList) + m_allocList->insert(ptr); + } + else + { + m_dontTouchHashLists = TRUE; + if (m_allocList) + { + m_allocList->forAll(fnFreeMemEntry, (void*) this); + delete m_allocList; + m_allocList = NULL; + } + m_dontTouchHashLists = FALSE; + + // Serious error since memory allocation falied. So, exiting... + ExitThread(TSR_THREAD, 1); + } + + return(ptr); } @@ -200,7 +200,7 @@ void* VMem::Malloc(size_t size) Description : Reallocates block of memory. Parameters : block (IN) - Points to a previously allocated memory block. - size (IN) - Size of memory to be allocated. + size (IN) - Size of memory to be allocated. Returns : Pointer to the allocated memory block. @@ -208,38 +208,38 @@ void* VMem::Malloc(size_t size) void* VMem::Realloc(void* block, size_t size) { - void *ptr = NULL; - - if (size <= 0) - return NULL; - - ptr = realloc(block, size); - if (ptr) - { - if (block) - { - if (m_allocList) - m_allocList->remove(block); - } - if (m_allocList) - m_allocList->insert(ptr); - } - else - { - m_dontTouchHashLists = TRUE; - if (m_allocList) - { - m_allocList->forAll(fnFreeMemEntry, (void*) this); - delete m_allocList; - m_allocList = NULL; - } - m_dontTouchHashLists = FALSE; - - // Serious error since memory allocation falied. So, exiting... - ExitThread(TSR_THREAD, 1); - } - - return(ptr); + void *ptr = NULL; + + if (size <= 0) + return NULL; + + ptr = realloc(block, size); + if (ptr) + { + if (block) + { + if (m_allocList) + m_allocList->remove(block); + } + if (m_allocList) + m_allocList->insert(ptr); + } + else + { + m_dontTouchHashLists = TRUE; + if (m_allocList) + { + m_allocList->forAll(fnFreeMemEntry, (void*) this); + delete m_allocList; + m_allocList = NULL; + } + m_dontTouchHashLists = FALSE; + + // Serious error since memory allocation falied. So, exiting... + ExitThread(TSR_THREAD, 1); + } + + return(ptr); } @@ -251,7 +251,7 @@ void* VMem::Realloc(void* block, size_t size) Description : Allocates and clears memory space for an array of objects. Parameters : num (IN) - Specifies the number of objects. - size (IN) - Size of each object. + size (IN) - Size of each object. Returns : Pointer to the allocated memory block. @@ -259,33 +259,33 @@ void* VMem::Realloc(void* block, size_t size) void* VMem::Calloc(size_t num, size_t size) { - void *ptr = NULL; - - if (size <= 0) - return NULL; - - ptr = calloc(num, size); - if (ptr) - { - if(m_allocList) - m_allocList->insert(ptr); - } - else - { - m_dontTouchHashLists = TRUE; - if (m_allocList) - { - m_allocList->forAll(fnFreeMemEntry, (void*) this); - delete m_allocList; - m_allocList = NULL; - } - m_dontTouchHashLists = FALSE; - - // Serious error since memory allocation falied. So, exiting... - ExitThread(TSR_THREAD, 1); - } - - return(ptr); + void *ptr = NULL; + + if (size <= 0) + return NULL; + + ptr = calloc(num, size); + if (ptr) + { + if(m_allocList) + m_allocList->insert(ptr); + } + else + { + m_dontTouchHashLists = TRUE; + if (m_allocList) + { + m_allocList->forAll(fnFreeMemEntry, (void*) this); + delete m_allocList; + m_allocList = NULL; + } + m_dontTouchHashLists = FALSE; + + // Serious error since memory allocation falied. So, exiting... + ExitThread(TSR_THREAD, 1); + } + + return(ptr); } @@ -304,35 +304,35 @@ void* VMem::Calloc(size_t num, size_t size) void VMem::Free(void* p) { - // Final clean up, free all the nodes from the hash list - if (m_dontTouchHashLists) - { - if(p) - { - free(p); - p = NULL; - } - } - else - { - if(p && m_allocList) - { - if (m_allocList->remove(p)) - { - free(p); - p = NULL; - } - else - { - // If it comes here, that means that the memory pointer is not contained in the hash list. - // But no need to free now, since if is deleted here, it will result in an abend!! - // If the memory is still there, it will be cleaned during final cleanup anyway. - } - } - } - - - return; + // Final clean up, free all the nodes from the hash list + if (m_dontTouchHashLists) + { + if(p) + { + free(p); + p = NULL; + } + } + else + { + if(p && m_allocList) + { + if (m_allocList->remove(p)) + { + free(p); + p = NULL; + } + else + { + // If it comes here, that means that the memory pointer is not contained in the hash list. + // But no need to free now, since if is deleted here, it will result in an abend!! + // If the memory is still there, it will be cleaned during final cleanup anyway. + } + } + } + + + return; } diff --git a/NetWare/win32ish.h b/NetWare/win32ish.h index f6603d50f447..7e94a1c0c2d1 100644 --- a/NetWare/win32ish.h +++ b/NetWare/win32ish.h @@ -22,11 +22,11 @@ #ifndef BOOL - typedef unsigned int BOOL; + typedef unsigned int BOOL; #endif #ifndef DWORD - typedef unsigned long DWORD; + typedef unsigned long DWORD; #endif typedef DWORD LCID; @@ -34,11 +34,11 @@ typedef long HRESULT; typedef void* LPVOID; #ifndef TRUE - #define TRUE 1 + #define TRUE 1 #endif #ifndef FALSE - #define FALSE 0 + #define FALSE 0 #endif diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 8d9f5c7b20ff..ebfbf28436e9 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -199,7 +199,7 @@ package Maintainers; }, 'Compress::Raw::Bzip2' => { - 'DISTRIBUTION' => 'PMQS/Compress-Raw-Bzip2-2.096.tar.gz', + 'DISTRIBUTION' => 'PMQS/Compress-Raw-Bzip2-2.100.tar.gz', 'FILES' => q[cpan/Compress-Raw-Bzip2], 'EXCLUDED' => [ qr{^t/Test/}, @@ -211,7 +211,7 @@ package Maintainers; }, 'Compress::Raw::Zlib' => { - 'DISTRIBUTION' => 'PMQS/Compress-Raw-Zlib-2.096.tar.gz', + 'DISTRIBUTION' => 'PMQS/Compress-Raw-Zlib-2.100.tar.gz', 'FILES' => q[cpan/Compress-Raw-Zlib], 'EXCLUDED' => [ qr{^examples/}, @@ -224,12 +224,11 @@ package Maintainers; }, 'Config::Perl::V' => { - 'DISTRIBUTION' => 'HMBRAND/Config-Perl-V-0.31.tgz', + 'DISTRIBUTION' => 'HMBRAND/Config-Perl-V-0.33.tgz', 'FILES' => q[cpan/Config-Perl-V], 'EXCLUDED' => [qw( examples/show-v.pl )], - 'CUSTOMIZED' => [ qw(V.pm) ], }, 'constant' => { @@ -340,7 +339,7 @@ package Maintainers; }, 'Devel::PPPort' => { - 'DISTRIBUTION' => 'ATOOMIC/Devel-PPPort-3.57.tar.gz', + 'DISTRIBUTION' => 'ATOOMIC/Devel-PPPort-3.62.tar.gz', 'FILES' => q[dist/Devel-PPPort], 'EXCLUDED' => [ 'PPPort.pm', # we use PPPort_pm.PL instead @@ -383,7 +382,7 @@ package Maintainers; }, 'Encode' => { - 'DISTRIBUTION' => 'DANKOGAI/Encode-3.07.tar.gz', + 'DISTRIBUTION' => 'DANKOGAI/Encode-3.08.tar.gz', 'FILES' => q[cpan/Encode], 'EXCLUDED' => [ qw( t/whatwg-aliases.json @@ -428,7 +427,7 @@ package Maintainers; }, 'ExtUtils::CBuilder' => { - 'DISTRIBUTION' => 'AMBS/ExtUtils-CBuilder-0.280234.tar.gz', + 'DISTRIBUTION' => 'AMBS/ExtUtils-CBuilder-0.280235.tar.gz', 'FILES' => q[dist/ExtUtils-CBuilder], 'EXCLUDED' => [ qw(README.mkdn), @@ -453,7 +452,7 @@ package Maintainers; }, 'ExtUtils::Install' => { - 'DISTRIBUTION' => 'BINGOS/ExtUtils-Install-2.18.tar.gz', + 'DISTRIBUTION' => 'BINGOS/ExtUtils-Install-2.20.tar.gz', 'FILES' => q[cpan/ExtUtils-Install], 'EXCLUDED' => [ qw( t/lib/Test/Builder.pm @@ -467,7 +466,7 @@ package Maintainers; }, 'ExtUtils::MakeMaker' => { - 'DISTRIBUTION' => 'BINGOS/ExtUtils-MakeMaker-7.52.tar.gz', + 'DISTRIBUTION' => 'BINGOS/ExtUtils-MakeMaker-7.58.tar.gz', 'FILES' => q[cpan/ExtUtils-MakeMaker], 'EXCLUDED' => [ qr{^t/lib/Test/}, @@ -494,7 +493,7 @@ package Maintainers; }, 'ExtUtils::Manifest' => { - 'DISTRIBUTION' => 'ETHER/ExtUtils-Manifest-1.72.tar.gz', + 'DISTRIBUTION' => 'ETHER/ExtUtils-Manifest-1.73.tar.gz', 'FILES' => q[cpan/ExtUtils-Manifest], 'EXCLUDED' => [ qr(^t/00-report-prereqs), @@ -508,7 +507,7 @@ package Maintainers; }, 'File::Fetch' => { - 'DISTRIBUTION' => 'BINGOS/File-Fetch-0.56.tar.gz', + 'DISTRIBUTION' => 'BINGOS/File-Fetch-1.00.tar.gz', 'FILES' => q[cpan/File-Fetch], }, @@ -637,7 +636,7 @@ package Maintainers; }, 'IO-Compress' => { - 'DISTRIBUTION' => 'PMQS/IO-Compress-2.096.tar.gz', + 'DISTRIBUTION' => 'PMQS/IO-Compress-2.100.tar.gz', 'FILES' => q[cpan/IO-Compress], 'EXCLUDED' => [ qr{^examples/}, @@ -668,7 +667,7 @@ package Maintainers; }, 'IPC::SysV' => { - 'DISTRIBUTION' => 'MHX/IPC-SysV-2.08.tar.gz', + 'DISTRIBUTION' => 'MHX/IPC-SysV-2.09.tar.gz', 'FILES' => q[cpan/IPC-SysV], 'EXCLUDED' => [ qw( const-c.inc @@ -693,7 +692,7 @@ package Maintainers; }, 'libnet' => { - 'DISTRIBUTION' => 'SHAY/libnet-3.11.tar.gz', + 'DISTRIBUTION' => 'SHAY/libnet-3.13.tar.gz', 'FILES' => q[cpan/libnet], 'EXCLUDED' => [ qw( Configure @@ -812,7 +811,7 @@ package Maintainers; }, 'Module::CoreList' => { - 'DISTRIBUTION' => 'BINGOS/Module-CoreList-5.20201020.tar.gz', + 'DISTRIBUTION' => 'BINGOS/Module-CoreList-5.20210120.tar.gz', 'FILES' => q[dist/Module-CoreList], }, @@ -843,13 +842,19 @@ package Maintainers; }, 'Net::Ping' => { - 'DISTRIBUTION' => 'RURBAN/Net-Ping-2.73.tar.gz', + 'DISTRIBUTION' => 'RURBAN/Net-Ping-2.74.tar.gz', 'FILES' => q[dist/Net-Ping], 'EXCLUDED' => [ + qr{^\.[awc]}, qw(README.md.PL), qw(t/020_external.t), qw(t/600_pod.t), qw(t/601_pod-coverage.t), + qw(t/602_kwalitee.t), + qw(t/603_meta.t), + qw(t/604_manifest.t), + qw(t/appveyor-test.bat), + ], 'CUSTOMIZED' => [ qw{ @@ -905,7 +910,7 @@ package Maintainers; }, 'PerlIO::via::QuotedPrint' => { - 'DISTRIBUTION' => 'SHAY/PerlIO-via-QuotedPrint-0.08.tar.gz', + 'DISTRIBUTION' => 'SHAY/PerlIO-via-QuotedPrint-0.09.tar.gz', 'FILES' => q[cpan/PerlIO-via-QuotedPrint], }, @@ -944,7 +949,7 @@ package Maintainers; }, 'Pod::Simple' => { - 'DISTRIBUTION' => 'KHW/Pod-Simple-3.41.tar.gz', + 'DISTRIBUTION' => 'KHW/Pod-Simple-3.42.tar.gz', 'FILES' => q[cpan/Pod-Simple], 'EXCLUDED' => [ qw{.ChangeLog.swp}, @@ -997,7 +1002,7 @@ package Maintainers; }, 'Socket' => { - 'DISTRIBUTION' => 'PEVANS/Socket-2.030.tar.gz', + 'DISTRIBUTION' => 'PEVANS/Socket-2.031.tar.gz', 'FILES' => q[cpan/Socket], }, @@ -1075,10 +1080,15 @@ package Maintainers; t/lib/if.pm ), ], + 'CUSTOMIZED' => [ + # https://github.com/Perl-Toolchain-Gang/Test-Harness/pull/103 + # applied but not released + 't/source.t' + ], }, 'Test::Simple' => { - 'DISTRIBUTION' => 'EXODIST/Test-Simple-1.302182.tar.gz', + 'DISTRIBUTION' => 'EXODIST/Test-Simple-1.302183.tar.gz', 'FILES' => q[cpan/Test-Simple], 'EXCLUDED' => [ qr{^examples/}, @@ -1098,7 +1108,7 @@ package Maintainers; }, 'Text::Balanced' => { - 'DISTRIBUTION' => 'SHAY/Text-Balanced-2.03.tar.gz', + 'DISTRIBUTION' => 'SHAY/Text-Balanced-2.04.tar.gz', 'FILES' => q[cpan/Text-Balanced], 'EXCLUDED' => [ qw( t/97_meta.t diff --git a/Porting/README.pod b/Porting/README.pod index b02a4da85e48..aa268215a0b8 100644 --- a/Porting/README.pod +++ b/Porting/README.pod @@ -78,11 +78,6 @@ Checks that all the URLs in the Perl source are valid. Used by F to ensure changed modules have had their versions updated. -=head2 F - -Command line tool to update cherrymaint; a tool for selecting commits from -blead to cherry-pick into stable perl versions. - =head2 F Compare the current Perl source tree and a given tag for modules that have diff --git a/Porting/add-package.pl b/Porting/add-package.pl index 012aa77894ca..af04c8f8bec8 100755 --- a/Porting/add-package.pl +++ b/Porting/add-package.pl @@ -319,11 +319,11 @@ } } - ### add entries to win32/Makefile and win32/makefile.mk + ### add entries to win32/Makefile ### they contain the following lines: # ./win32/makefile.mk: ..\utils\ptardiff \ # ./win32/makefile.mk: xsubpp instmodsh prove ptar ptardiff - for my $file ( qw[win32/Makefile win32/makefile.mk] ) { + for my $file ( qw[win32/Makefile] ) { unless ( `grep $bin $Repo/$file` ) { print " Adding $bin entries to $file..." if $Verbose; diff --git a/Porting/checkAUTHORS.pl b/Porting/checkAUTHORS.pl index b6a8fc57b253..3124fe057602 100755 --- a/Porting/checkAUTHORS.pl +++ b/Porting/checkAUTHORS.pl @@ -726,6 +726,7 @@ sub _raw_address { + perl5\100tux.freedom.nl mhx mhx-perl\100gmx.net + mhx\100r2d2.(none) ++ mhx\100cpan.org mst mst\100shadowcat.co.uk + matthewt\100hercule.scsys.co.uk nicholas nick\100ccl4.org diff --git a/Porting/cherrymaint b/Porting/cherrymaint deleted file mode 100644 index 08e8eb55a1b2..000000000000 --- a/Porting/cherrymaint +++ /dev/null @@ -1,103 +0,0 @@ -#!/usr/bin/env perl -use 5.010; -use strict; -use warnings; -use File::Basename; -use Getopt::Long; -require LWP::UserAgent; - -my %votemap = ( - 'unexamined' => 0, - 'rejected' => 1, - 'vote' => 4, - 'picked' => 5, -); - - -chomp(my $git_addr = `git config --get cherrymaint.address`); -my $addr = length $git_addr ? $git_addr : 'localhost:3000'; - -# Usage -my $program = basename $0; -my $usage = << "HERE"; -Usage: $program [--address address] [ACTION] [COMMIT] - - ACTIONS: (default is 'vote' if omitted) - -HERE -$usage .= join( "\n", map { " --$_" } (sort keys %votemap), 'help' ); -$usage .= "\n" . << "HERE"; - - COMMIT: a git revision ID (SHA1 or symbolic reference like HEAD) - - You must first tunnel $addr to perl5.git.perl.org:3000? E.g. - \$ ssh -C -L${\ join q{:} => reverse split /:/, $addr}:3000 perl5.git.perl.org - -HERE - -die $usage if grep { /^(--help|-h)$/ } @ARGV; - -# Determine action -my %opt = (address => \$addr); -GetOptions( \%opt, 'address=s', keys %votemap ) or die $usage; - -if ( keys(%opt) > 2 ) { - die "Error: cherrymaint takes only one action argument\n\n$usage" -} - -my ($action) = grep { exists $votemap{$_} } keys %opt; -$action ||= 'vote'; - -# Determine commit SHA1 -my $commit = shift @ARGV; - -unless ( defined $commit ) { - die "Error: cherrymaint requires an explicit commit ID\n\n$usage" -} - -my $short_id = qx/git rev-parse --short $commit/; -if ( $? ) { - die "Error: couldn't get git commit SHA1 from '$commit'\n"; -} -chomp $short_id; - -# Confirm actions -unless ( $action eq 'vote' ) { - say "Are you sure you want to mark $short_id as $action? (y/n)"; - my $ans = ; - exit 0 unless $ans =~ /^y/i; -} - -# Send the action to cherrymaint -my $n = $votemap{$action}; -my $url = "http://$addr/mark?commit=${short_id}&value=${n}"; - -my $ua = LWP::UserAgent->new( - agent => 'Porting/cherrymaint ', - timeout => 30, - env_proxy => 1, -); - -my $response = $ua->get($url); - -if ($response->is_success) { - say "Done."; -} -else { - die $response->status_line . << "HERE"; - -Have you remembered to tunnel $addr to perl5.git.perl.org:3000? E.g. - \$ ssh -C -L${\ join q{:} => reverse split /:/, $addr}:3000 perl5.git.perl.org - -Or maybe you created a different tunnel? You can specify the address to use -either on the command line with --address, or by doing - \$ git config cherrymaint.address host:port - -HERE - -# Note that you can vote through your browser by pointing it at the local -# end of the tunnel. For example, L if you went with -# the suggested default values -} - -exit 0; diff --git a/Porting/config.sh b/Porting/config.sh index a617f9192de7..88845e41a641 100644 --- a/Porting/config.sh +++ b/Porting/config.sh @@ -46,12 +46,12 @@ afsroot='/afs' alignbytes='16' aphostname='' api_revision='5' -api_subversion='4' +api_subversion='7' api_version='33' -api_versionstring='5.33.4' +api_versionstring='5.33.7' ar='ar' -archlib='/opt/perl/lib/5.33.4/x86_64-linux-thread-multi-ld' -archlibexp='/opt/perl/lib/5.33.4/x86_64-linux-thread-multi-ld' +archlib='/opt/perl/lib/5.33.7/x86_64-linux-thread-multi-ld' +archlibexp='/opt/perl/lib/5.33.7/x86_64-linux-thread-multi-ld' archname64='' archname='x86_64-linux-thread-multi-ld' archobjs='' @@ -264,6 +264,7 @@ d_gdbm_ndbm_h_uses_prototypes='undef' d_gdbmndbm_h_uses_prototypes='undef' d_getaddrinfo='define' d_getcwd='define' +d_getenv_preserves_other_thread='define' d_getespwnam='undef' d_getfsstat='undef' d_getgrent='define' @@ -853,7 +854,7 @@ incpath='' incpth='/usr/lib64/gcc/x86_64-suse-linux/10/include /usr/local/include /usr/lib64/gcc/x86_64-suse-linux/10/include-fixed /usr/lib64/gcc/x86_64-suse-linux/10/../../../../x86_64-suse-linux/include /usr/include' inews='' initialinstalllocation='/opt/perl/bin' -installarchlib='/opt/perl/lib/5.33.4/x86_64-linux-thread-multi-ld' +installarchlib='/opt/perl/lib/5.33.7/x86_64-linux-thread-multi-ld' installbin='/opt/perl/bin' installhtml1dir='' installhtml3dir='' @@ -861,13 +862,13 @@ installman1dir='/opt/perl/man/man1' installman3dir='/opt/perl/man/man3' installprefix='/opt/perl' installprefixexp='/opt/perl' -installprivlib='/opt/perl/lib/5.33.4' +installprivlib='/opt/perl/lib/5.33.7' installscript='/opt/perl/bin' -installsitearch='/opt/perl/lib/site_perl/5.33.4/x86_64-linux-thread-multi-ld' +installsitearch='/opt/perl/lib/site_perl/5.33.7/x86_64-linux-thread-multi-ld' installsitebin='/opt/perl/bin' installsitehtml1dir='' installsitehtml3dir='' -installsitelib='/opt/perl/lib/site_perl/5.33.4' +installsitelib='/opt/perl/lib/site_perl/5.33.7' installsiteman1dir='/opt/perl/man/man1' installsiteman3dir='/opt/perl/man/man3' installsitescript='/opt/perl/bin' @@ -992,7 +993,7 @@ perl_patchlevel='' perl_static_inline='static __inline__' perladmin='yourname@yourhost.yourplace.com' perllibs='-lpthread -lnsl -ldl -lm -lcrypt -lutil -lc' -perlpath='/opt/perl/bin/perl5.33.4' +perlpath='/opt/perl/bin/perl5.33.7' pg='pg' phostname='' pidtype='pid_t' @@ -1001,8 +1002,8 @@ pmake='' pr='' prefix='/opt/perl' prefixexp='/opt/perl' -privlib='/opt/perl/lib/5.33.4' -privlibexp='/opt/perl/lib/5.33.4' +privlib='/opt/perl/lib/5.33.7' +privlibexp='/opt/perl/lib/5.33.7' procselfexe='"/proc/self/exe"' ptrsize='8' quadkind='2' @@ -1067,17 +1068,17 @@ sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 6, 17, 29, 0' sig_size='68' signal_t='void' -sitearch='/opt/perl/lib/site_perl/5.33.4/x86_64-linux-thread-multi-ld' -sitearchexp='/opt/perl/lib/site_perl/5.33.4/x86_64-linux-thread-multi-ld' +sitearch='/opt/perl/lib/site_perl/5.33.7/x86_64-linux-thread-multi-ld' +sitearchexp='/opt/perl/lib/site_perl/5.33.7/x86_64-linux-thread-multi-ld' sitebin='/opt/perl/bin' sitebinexp='/opt/perl/bin' sitehtml1dir='' sitehtml1direxp='' sitehtml3dir='' sitehtml3direxp='' -sitelib='/opt/perl/lib/site_perl/5.33.4' +sitelib='/opt/perl/lib/site_perl/5.33.7' sitelib_stem='/opt/perl/lib/site_perl' -sitelibexp='/opt/perl/lib/site_perl/5.33.4' +sitelibexp='/opt/perl/lib/site_perl/5.33.7' siteman1dir='/opt/perl/man/man1' siteman1direxp='/opt/perl/man/man1' siteman3dir='/opt/perl/man/man3' @@ -1103,7 +1104,7 @@ src='.' ssizetype='ssize_t' st_ino_sign='1' st_ino_size='8' -startperl='#!/opt/perl/bin/perl5.33.4' +startperl='#!/opt/perl/bin/perl5.33.7' startsh='#!/bin/sh' static_ext=' ' stdchar='char' @@ -1115,7 +1116,7 @@ stdio_ptr='((fp)->_ptr)' stdio_stream_array='' strerror_r_proto='REENTRANT_PROTO_B_IBW' submit='' -subversion='4' +subversion='7' sysman='/usr/share/man/man1' sysroot='' tail='' @@ -1214,8 +1215,8 @@ vendorprefix='' vendorprefixexp='' vendorscript='' vendorscriptexp='' -version='5.33.4' -version_patchlevel_string='version 33 subversion 4' +version='5.33.7' +version_patchlevel_string='version 33 subversion 7' versiononly='define' vi='' xlibpth='/usr/lib/386 /lib/386' @@ -1225,10 +1226,10 @@ zcat='' zip='zip' PERL_REVISION=5 PERL_VERSION=33 -PERL_SUBVERSION=4 +PERL_SUBVERSION=7 PERL_API_REVISION=5 PERL_API_VERSION=33 -PERL_API_SUBVERSION=4 +PERL_API_SUBVERSION=7 PERL_PATCHLEVEL='' PERL_CONFIG_SH=true : Variables propagated from previous config.sh file. diff --git a/Porting/config_H b/Porting/config_H index f54e17376bc9..54c73d326fc5 100644 --- a/Porting/config_H +++ b/Porting/config_H @@ -1239,8 +1239,8 @@ * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define ARCHLIB "/opt/perl/lib/5.33.4/x86_64-linux" /**/ -#define ARCHLIB_EXP "/opt/perl/lib/5.33.4/x86_64-linux" /**/ +#define ARCHLIB "/opt/perl/lib/5.33.7/x86_64-linux" /**/ +#define ARCHLIB_EXP "/opt/perl/lib/5.33.7/x86_64-linux" /**/ /* BIN: * This symbol holds the path of the bin directory where the package will @@ -1293,8 +1293,8 @@ * This symbol contains the ~name expanded version of PRIVLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define PRIVLIB "/opt/perl/lib/5.33.4" /**/ -#define PRIVLIB_EXP "/opt/perl/lib/5.33.4" /**/ +#define PRIVLIB "/opt/perl/lib/5.33.7" /**/ +#define PRIVLIB_EXP "/opt/perl/lib/5.33.7" /**/ /* SITEARCH: * This symbol contains the name of the private library for this package. @@ -1311,8 +1311,8 @@ * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define SITEARCH "/opt/perl/lib/site_perl/5.33.4/x86_64-linux" /**/ -#define SITEARCH_EXP "/opt/perl/lib/site_perl/5.33.4/x86_64-linux" /**/ +#define SITEARCH "/opt/perl/lib/site_perl/5.33.7/x86_64-linux" /**/ +#define SITEARCH_EXP "/opt/perl/lib/site_perl/5.33.7/x86_64-linux" /**/ /* SITELIB: * This symbol contains the name of the private library for this package. @@ -1334,8 +1334,8 @@ * removed. The elements in inc_version_list (inc_version_list.U) can * be tacked onto this variable to generate a list of directories to search. */ -#define SITELIB "/opt/perl/lib/site_perl/5.33.4" /**/ -#define SITELIB_EXP "/opt/perl/lib/site_perl/5.33.4" /**/ +#define SITELIB "/opt/perl/lib/site_perl/5.33.7" /**/ +#define SITELIB_EXP "/opt/perl/lib/site_perl/5.33.7" /**/ #define SITELIB_STEM "/opt/perl/lib/site_perl" /**/ /* PERL_VENDORARCH: @@ -4109,7 +4109,7 @@ * script to make sure (one hopes) that it runs with perl and not * some shell. */ -#define STARTPERL "#!/opt/perl/bin/perl5.33.4" /**/ +#define STARTPERL "#!/opt/perl/bin/perl5.33.7" /**/ /* HAS_STDIO_STREAM_ARRAY: * This symbol, if defined, tells that there is an array diff --git a/Porting/corelist.pl b/Porting/corelist.pl index 05393c0ada6d..7c75f06d1600 100755 --- a/Porting/corelist.pl +++ b/Porting/corelist.pl @@ -96,6 +96,12 @@ find( sub { + if (-d) { + my @parts = File::Spec->splitdir($File::Find::name); + # be careful not to skip inc::latest + return $File::Find::prune = 1 if @parts == 3 and ($parts[-1] eq 'inc' or $parts[-1] eq 't'); + } + /(\.pm|_pm\.PL)$/ or return; /PPPort\.pm$/ and return; my $module = $File::Find::name; diff --git a/Porting/epigraphs.pod b/Porting/epigraphs.pod index ed53a8a354ba..2874b83075cd 100644 --- a/Porting/epigraphs.pod +++ b/Porting/epigraphs.pod @@ -17,6 +17,30 @@ Consult your favorite dictionary for details. =head1 EPIGRAPHS +=head2 v5.33.6 - Edward R. Murrow + +L + +This instrument can teach, it can illuminate; yes, and it can even +inspire. But it can do so only to the extent that humans are determined +to use it to those ends. Otherwise it is merely wires and lights in a box. + +=head2 v5.33.5 - Max Weber, (from "Understanding Administration", by Wolfgang Seibel) + +L + +Authority is primarily: Administration + -- Max Weber + +=head2 v5.33.4 - George Eliot, "Adam Bede" + +L + +It was more than two o'clock in the afternoon when Adam came in sight of +the grey town on the hill-side and looked searchingly towards the green +valley below, for the first glimpse of the old thatched roof near the +ugly red mill. + =head2 v5.33.3 - Ludwig van Beethoven, "Heiligenstadt Testament"; translated and quoted in: Maynard Solomon, "Beethoven" L @@ -65,6 +89,31 @@ L + +As the warning bells rang, inquisitive people were peeping into the star +dressing room. Among them were jugglers in bright robes and turbans, a +roller-skater in a knitted cardigan, a comedian with a powdered white +face and a make-up man. The celebrated guest artiste amazed everyone +with his unusually long, superbly cut tail coat and by wearing a black +domino. Even more astounding were the black magician's two companions: +a tall man in checks with an unsteady pince-nez and a fat black cat +which walked into the dressing room on its hind legs and casually sat +down on the divan, blinking in the light of the unshaded lamps round the +make-up mirror. + +=head2 v5.32.1-RC1 - Mikhail Bulgakov, trans. Michael Glenny, "The Heart of a Dog" + +L + +Why bother to learn to read when you can smell meat a mile away? If you +live in Moscow, though, and if you've got an ounce of brain in your head +you can't help learning to read - and without going to night-school +either. There are forty-thousand dogs in Moscow and I'll bet there's +not one of them so stupid he can't spell out the word 'sausage'. + =head2 v5.32.0 - Bob Dylan, "The Times They Are A Changing" L diff --git a/Porting/how_to_write_a_perldelta.pod b/Porting/how_to_write_a_perldelta.pod index 1934b7484f34..ec0385caabd1 100644 --- a/Porting/how_to_write_a_perldelta.pod +++ b/Porting/how_to_write_a_perldelta.pod @@ -39,11 +39,6 @@ Be consistent in how bugs are referenced. One style is =over 4 -=item rt.perl.org - -C inline, but enclose in square brackets after a sentence. -C<[perl #43010]>. This mirrors how rt.perl.org subject lines appear. - =item rt.cpan.org C inline, but enclose in square brackets after a sentence. diff --git a/Porting/makerel b/Porting/makerel index e9a7ea41adf0..79c17f484b18 100755 --- a/Porting/makerel +++ b/Porting/makerel @@ -303,7 +303,6 @@ my @writables = qw( lib/warnings.pm win32/GNUmakefile win32/Makefile - win32/makefile.mk win32/config_H.gc win32/config_H.vc uconfig.h diff --git a/Porting/manifest_lib.pl b/Porting/manifest_lib.pl index 0b63046056e6..95d49be9cd31 100644 --- a/Porting/manifest_lib.pl +++ b/Porting/manifest_lib.pl @@ -12,6 +12,8 @@ =head1 SYNOPSIS =head1 DESCRIPTION +This file makes available one function, C. + =head2 C Treats its arguments as (chomped) lines from a MANIFEST file, and returns that @@ -42,7 +44,8 @@ sub sort_manifest { $m =~ s!/!\0!g; # replace the extension (only one) by null null extension. # this puts any foo/blah.ext before any files in foo/blah/ - $m =~ s!(\.[^.]+\z)!\0\0$1!; + $m =~ s{(? =item * Purpose -Verify that a file contains exactly one contiguous run of lines which matches -the passed in pattern. Cs if the pattern is not found, or found in -more than one place. +Verify that a makefile or makefile constructor contains exactly one contiguous +run of lines which matches a given pattern. Cs if the pattern is not +found, or found in more than one place. + +By "makefile or makefile constructor" we mean a file which is one of the +right-hand values in this list of key-value pairs: + + manifest => 'MANIFEST', + vms => 'vms/descrip_mms.template', + nmake => 'win32/Makefile', + gmake => 'win32/GNUmakefile', + podmak => 'win32/pod.mak', + unix => 'Makefile.SH', + +(Currently found in C<%Targets> in F.) =item * Arguments =over 4 -=item * Name of file +=item * Name of target + +String holding the key of one element in C<%Targets> in F. =item * Contents of file +String holding slurped contents of the file named in the value of the element +in C<%Targets> in F named in the first argument. + =item * Pattern of interest +Compiled regular expression pertinent to a particular makefile constructor. + =item * Name to report on error +String holding description. + =back =item * Return Value The contents of the file, with C substituted for the pattern. +=item * Example (drawn from F C): + + my $makefile_SH = slurp_or_die('./Makefile.SH'); + my $re = qr/some\s+pattern/; + my $makefile_SH_out = + verify_contiguous('unix', $makefile_SH, $re, 'copy rules'); + =back =cut @@ -521,6 +549,8 @@ =head2 C =item * Purpose +Create a data structure holding information about files containing text in POD format. + =item * Arguments List of one or more arguments. @@ -565,6 +595,14 @@ =head2 C 'copies' => { # patch version perldelta => minor version perldelta } +=item * Comment + +Instances where this subroutine is used may be found in these files: + + pod/buildtoc + Porting/new-perldelta.pl + Porting/pod_rules.pl + =back =cut diff --git a/Porting/pod_rules.pl b/Porting/pod_rules.pl index 2ba023ba7c9d..d10c669c4aee 100644 --- a/Porting/pod_rules.pl +++ b/Porting/pod_rules.pl @@ -18,14 +18,12 @@ # --build-all tries to build everything # --build-foo updates foo as follows # --showfiles shows the files to be changed -# --test exit if perl.pod, MANIFEST are consistent, and regenerated -# files are up to date, die otherwise. +# --tap emit TAP (testing) output describing the state of the pod files %Targets = ( manifest => 'MANIFEST', vms => 'vms/descrip_mms.template', nmake => 'win32/Makefile', - dmake => 'win32/makefile.mk', gmake => 'win32/GNUmakefile', podmak => 'win32/pod.mak', unix => 'Makefile.SH', @@ -166,7 +164,6 @@ sub do_nmake { } # shut up used only once warning -*do_dmake = *do_dmake = \&do_nmake; *do_gmake = *do_gmake = \&do_nmake; sub do_podmak { diff --git a/Porting/release_managers_guide.pod b/Porting/release_managers_guide.pod index ecc6055a9931..c9f729f4eb76 100644 --- a/Porting/release_managers_guide.pod +++ b/Porting/release_managers_guide.pod @@ -141,23 +141,17 @@ Andreas' email address at: https://pause.perl.org/pause/query?ACTION=pause_04imprint -=head3 GitHub issue management access - -Make sure you have permission to close tickets on L -so you can respond to bug reports as necessary during your stint. If you -don't, make a GitHub account (if you don't have one) and contact the pumpking -with your username to get ticket-closing permission. - -=head3 git checkout and commit bit +=head3 GitHub access You will need a working C installation, checkout of the perl git repository and perl commit bit. For information about working with perl and git, see F. If you are not yet a perl committer, you won't be able to make a -release. Have a chat with whichever evil perl porter tried to talk -you into the idea in the first place to figure out the best way to -resolve the issue. +release. You will need to have a GitHub account (if you don't have one) +and contact the pumpking with your username to get membership of the L<< +Perl-Release-Managers|https://github.com/orgs/Perl/teams/perl-release-managers +>> team. =head3 web-based file share @@ -166,10 +160,6 @@ pre-release testing, and you may wish to upload to PAUSE via URL. Make sure you have a way of sharing files, such as a web server or file-sharing service. -Porters have access to the "dromedary" server (users.perl5.git.perl.org), -which has a F directory to share files with. -(L) - If you use Dropbox, you can append "raw=1" as a parameter to their usual sharing link to allow direct download (albeit with redirects). @@ -374,6 +364,10 @@ the raw reports. Similarly, monitor the smoking of perl for compiler warnings, and try to fix. +Additionally both L and +L smokers run +automatically. + =for checklist skip BLEAD-POINT =head3 monitor CPAN testers for failures @@ -388,14 +382,6 @@ colon-delimited versions to use for comparison. For example: L -=head3 Monitor Continuous Integration smokers - -Currently both "Travis CI" and "GitHub Actions" smokers are setup. -Their current status is available at: - -L -L - =head3 update perldelta Get perldelta in a mostly finished state. @@ -1176,11 +1162,6 @@ eliminate anxious gnashing of teeth while you wait to see if your 15 megabyte HTTP upload successfully completes across your slow, twitchy cable modem. -You can make use of your home directory on dromedary for -this purpose: F maps to -F, where F is your login account -on dromedary. - I: if your upload is partially successful, you may need to contact a PAUSE administrator or even bump the version of perl. diff --git a/Porting/release_schedule.pod b/Porting/release_schedule.pod index 0fcaa29e53ac..47ca623bad43 100644 --- a/Porting/release_schedule.pod +++ b/Porting/release_schedule.pod @@ -14,7 +14,7 @@ deemed necessary by the Pumpking. =head2 Perl 5.32 2020-06-20 5.32.0 ✓ Sawyer X - 2020-??-?? 5.32.1 + 2021-01-23 5.32.1 ✓ Steve Hay =head2 Perl 5.30 @@ -43,12 +43,15 @@ you should reset the version numbers to the next blead series. 2020-08-20 5.33.1 ✓ Karen Etheridge 2020-09-20 5.33.2 ✓ Sawyer X 2020-10-20 5.33.3 ✓ Steve Hay - 2020-11-20 5.33.4 - 2020-12-20 5.33.5 - 2021-01-20 5.33.6 - 2021-02-20 5.33.7 Renee Backer - 2021-03-20 5.33.8 - 2021-04-20 5.33.9 + 2020-11-20 5.33.4 ✓ Tom Hukins + 2020-12-20 5.33.5 ✓ Max Maischein + 2021-01-20 5.33.6 ✓ Richard Leach + 2021-02-20 5.33.7 Renee Backer Contentious changes freeze + 2021-03-20 5.33.8 Atoomic User-visible changes to + correctly functioning programs + freeze + 2021-04-20 5.33.9 Todd Rinaldo Full code freeze + 2021-05-20 5.34.0 Sawyer X Stable release! =head1 VICTIMS diff --git a/Porting/sync-with-cpan b/Porting/sync-with-cpan index b2cdd5ffeec2..660b3f3d43eb 100755 --- a/Porting/sync-with-cpan +++ b/Porting/sync-with-cpan @@ -9,7 +9,7 @@ Porting/sync-with-cpan - Synchronize with CPAN distributions sh ./Configure perl Porting/sync-with-cpan -where is the name it appears in the C<%Modules> hash +where C is the name it appears in the C<%Modules> hash of F =head1 DESCRIPTION diff --git a/Porting/timecheck.c b/Porting/timecheck.c index 87a252d631e5..9d977ca9f3f2 100644 --- a/Porting/timecheck.c +++ b/Porting/timecheck.c @@ -17,9 +17,9 @@ static char hexbuf[80]; char *hex (time_t t) { if ((long long)t < 0) - sprintf (hexbuf, " -0x%016lx", -t); + sprintf (hexbuf, " -0x%016lx", -t); else - sprintf (hexbuf, " 0x%016lx", t); + sprintf (hexbuf, " 0x%016lx", t); return (hexbuf); } /* hex */ @@ -27,19 +27,19 @@ void gm_check (time_t t, int min_year, int max_year) { tmp = gmtime (&t); if ( tmp == NULL || - /* Check tm_year overflow */ - tmp->tm_year < min_year || tmp->tm_year > max_year) { - if (opt_v) - fprintf (stderr, "gmtime (%ld) failed with errno %d\n", t, errno); - } + /* Check tm_year overflow */ + tmp->tm_year < min_year || tmp->tm_year > max_year) { + if (opt_v) + fprintf (stderr, "gmtime (%ld) failed with errno %d\n", t, errno); + } else { - if (opt_v) - fprintf (stderr, "%3d:%s: %12ld-%02d-%02d %02d:%02d:%02d\n", - i, hex (t), - (long)(tmp->tm_year) + 1900, tmp->tm_mon + 1, tmp->tm_mday, - tmp->tm_hour, tmp->tm_min, tmp->tm_sec); - pt = t; - } + if (opt_v) + fprintf (stderr, "%3d:%s: %12ld-%02d-%02d %02d:%02d:%02d\n", + i, hex (t), + (long)(tmp->tm_year) + 1900, tmp->tm_mon + 1, tmp->tm_mday, + tmp->tm_hour, tmp->tm_min, tmp->tm_sec); + pt = t; + } } /* gm_check */ int check_gm_max () @@ -47,12 +47,12 @@ int check_gm_max () tmp = NULL; pt = 0; if (tmp == NULL || tmp->tm_year < 0) { - for (i = 63; i >= 0; i--) { - time_t x = pt | ((time_t)1 << i); - if (x < 0 || x < pt) continue; - gm_check (x, 69, 0x7fffffff); - } - } + for (i = 63; i >= 0; i--) { + time_t x = pt | ((time_t)1 << i); + if (x < 0 || x < pt) continue; + gm_check (x, 69, 0x7fffffff); + } + } pt_max = pt; return (0); } /* check_gm_max */ @@ -62,12 +62,12 @@ int check_gm_min () tmp = NULL; pt = 0; if (tmp == NULL) { - for (i = 36; i >= 0; i--) { - time_t x = pt - ((time_t)1 << i); - if (x > 0) continue; - gm_check (x, -1900, 70); - } - } + for (i = 36; i >= 0; i--) { + time_t x = pt - ((time_t)1 << i); + if (x > 0) continue; + gm_check (x, -1900, 70); + } + } pt_min = pt; return (0); } /* check_gm_min */ @@ -75,23 +75,23 @@ int check_gm_min () void lt_check (time_t t, int min_year, int max_year) { if (sizeof (time_t) > 4 && t > 0x7ffffffffffff000LL) - tmp = NULL; + tmp = NULL; else - tmp = localtime (&t); + tmp = localtime (&t); if ( tmp == NULL || - /* Check tm_year overflow */ - tmp->tm_year < min_year || tmp->tm_year > max_year) { - if (opt_v) - fprintf (stderr, "localtime (%ld) failed with errno %d\n", t, errno); - } + /* Check tm_year overflow */ + tmp->tm_year < min_year || tmp->tm_year > max_year) { + if (opt_v) + fprintf (stderr, "localtime (%ld) failed with errno %d\n", t, errno); + } else { - if (opt_v) - fprintf (stderr, "%3d:%s: %12ld-%02d-%02d %02d:%02d:%02d\n", - i, hex (t), - (long)(tmp->tm_year) + 1900, tmp->tm_mon + 1, tmp->tm_mday, - tmp->tm_hour, tmp->tm_min, tmp->tm_sec); - pt = t; - } + if (opt_v) + fprintf (stderr, "%3d:%s: %12ld-%02d-%02d %02d:%02d:%02d\n", + i, hex (t), + (long)(tmp->tm_year) + 1900, tmp->tm_mon + 1, tmp->tm_mday, + tmp->tm_hour, tmp->tm_min, tmp->tm_sec); + pt = t; + } } /* lt_check */ int check_lt_max () @@ -99,12 +99,12 @@ int check_lt_max () tmp = NULL; pt = 0; if (tmp == NULL || tmp->tm_year < 0) { - for (i = 63; i >= 0; i--) { - time_t x = pt | ((time_t)1 << i); - if (x < 0 || x < pt) continue; - lt_check (x, 69, 0x7fffffff); - } - } + for (i = 63; i >= 0; i--) { + time_t x = pt | ((time_t)1 << i); + if (x < 0 || x < pt) continue; + lt_check (x, 69, 0x7fffffff); + } + } pt_max = pt; return (0); } /* check_lt_max */ @@ -114,12 +114,12 @@ int check_lt_min () tmp = NULL; pt = 0; if (tmp == NULL) { - for (i = 36; i >= 0; i--) { - time_t x = pt - ((time_t)1 << i); - if (x > 0) continue; - lt_check (x, -1900, 70); - } - } + for (i = 36; i >= 0; i--) { + time_t x = pt - ((time_t)1 << i); + if (x > 0) continue; + lt_check (x, -1900, 70); + } + } pt_min = pt; return (0); } /* check_lt_min */ diff --git a/Porting/timecheck2.c b/Porting/timecheck2.c index 06d4a66cff9d..483e152a23b9 100644 --- a/Porting/timecheck2.c +++ b/Porting/timecheck2.c @@ -10,8 +10,8 @@ time_t Time_Zero = 0; /* Visual C++ 2008's difftime() can't do negative times */ double my_difftime(time_t left, time_t right) { - double diff = (double)left - (double)right; - return diff; + double diff = (double)left - (double)right; + return diff; } void check_date_max( struct tm * (*date_func)(const time_t *), char *func_name ) { diff --git a/Porting/todo.pod b/Porting/todo.pod index b67e419addce..307058d31d6f 100644 --- a/Porting/todo.pod +++ b/Porting/todo.pod @@ -486,7 +486,7 @@ Natively 64-bit systems need neither -Duse64bitint nor -Duse64bitall. On these systems, it might be the default compilation mode, and there is currently no guarantee that passing no use64bitall option to the Configure process will build a 32bit perl. Implementing -Duse32bit* -options would be nice for perl 5.33.4. +options would be nice for perl 5.33.7. =head2 Profile Perl - am I hot or not? @@ -1189,7 +1189,7 @@ L =head1 Big projects Tasks that will get your name mentioned in the description of the "Highlights -of 5.33.4" +of 5.33.7" =head2 make ithreads more robust diff --git a/README b/README index c0e833d28e3c..859122434fa4 100644 --- a/README +++ b/README @@ -1,6 +1,6 @@ Perl is Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, -2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 by Larry Wall and others. +2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 by Larry Wall and others. All rights reserved. diff --git a/README.cygwin b/README.cygwin index 6ad9fb542c15..dec28527052c 100644 --- a/README.cygwin +++ b/README.cygwin @@ -598,7 +598,7 @@ be kept as clean as possible. plan9/mkfile hints/uwin.sh vms/descrip_mms.template - win32/Makefile win32/makefile.mk + win32/Makefile =item Tests diff --git a/README.haiku b/README.haiku index 241cba8d030c..a50a6d63b893 100644 --- a/README.haiku +++ b/README.haiku @@ -22,9 +22,9 @@ The build procedure is completely standard: Make perl executable and create a symlink for libperl: chmod a+x /boot/common/bin/perl - cd /boot/common/lib; ln -s perl5/5.33.4/BePC-haiku/CORE/libperl.so . + cd /boot/common/lib; ln -s perl5/5.33.7/BePC-haiku/CORE/libperl.so . -Replace C<5.33.4> with your respective version of Perl. +Replace C<5.33.7> with your respective version of Perl. =head1 KNOWN PROBLEMS diff --git a/README.macosx b/README.macosx index bb66fe71a88b..c3d2556d3124 100644 --- a/README.macosx +++ b/README.macosx @@ -10,9 +10,9 @@ perlmacosx - Perl under Mac OS X This document briefly describes Perl under Mac OS X. - curl -O https://www.cpan.org/src/perl-5.33.4.tar.gz - tar -xzf perl-5.33.4.tar.gz - cd perl-5.33.4 + curl -O https://www.cpan.org/src/perl-5.33.7.tar.gz + tar -xzf perl-5.33.7.tar.gz + cd perl-5.33.7 ./Configure -des -Dprefix=/usr/local/ make make test @@ -20,7 +20,7 @@ This document briefly describes Perl under Mac OS X. =head1 DESCRIPTION -The latest Perl release (5.33.4 as of this writing) builds without changes +The latest Perl release (5.33.7 as of this writing) builds without changes under all versions of Mac OS X from 10.3 "Panther" onwards. In order to build your own version of Perl you will need 'make', diff --git a/README.os2 b/README.os2 index edaf04962bdd..d12be9702d5c 100644 --- a/README.os2 +++ b/README.os2 @@ -619,7 +619,7 @@ C in F, see L">. =item Additional Perl modules - unzip perl_ste.zip -d f:/perllib/lib/site_perl/5.33.4/ + unzip perl_ste.zip -d f:/perllib/lib/site_perl/5.33.7/ Same remark as above applies. Additionally, if this directory is not one of directories on @INC (and @INC is influenced by C), you diff --git a/README.tw b/README.tw index 05220aa61525..9ec8af2ddd83 100644 --- a/README.tw +++ b/README.tw @@ -115,7 +115,7 @@ Perl 郵遞論壇一覽 臺灣 Perl 推廣組一覽 -=item L +=item L Perl.tw 線上聊天室 diff --git a/README.vms b/README.vms index 137e8eec1457..78944879e628 100644 --- a/README.vms +++ b/README.vms @@ -142,11 +142,11 @@ You may need to set up a foreign symbol for the unpacking utility of choice. Once you have done so, use a command like the following to unpack the archive: - vmstar -xvf perl-5^.33^.4.tar + vmstar -xvf perl-5^.33^.7.tar Then set default to the top-level source directory like so: - set default [.perl-5^.33^.4] + set default [.perl-5^.33^.7] and proceed with configuration as described in the next section. diff --git a/README.win32 b/README.win32 index 73d74bdee8ab..e0075d3f46cd 100644 --- a/README.win32 +++ b/README.win32 @@ -41,8 +41,7 @@ following compilers on the Intel x86 architecture: Microsoft Visual C++ version 6.0 or later Intel C++ Compiler (experimental) - Gcc by mingw.org gcc version 3.4.5 or later - with runtime < 3.21 + Gcc by mingw.org gcc version 3.4.5-5.3.0 Gcc by mingw-w64.org gcc version 4.4.3 or later Note that the last two of these are actually competing projects both @@ -98,20 +97,9 @@ See L below for general hints about this. You need a "make" program to build the sources. If you are using Visual C++ or the Windows SDK tools, you can use nmake supplied with Visual C++ -or Windows SDK. You may also use, for Visual C++ or Windows SDK, dmake or gmake -instead of nmake. dmake is open source software, but is not included with -Visual C++ or Windows SDK. Builds using gcc need dmake or gmake. nmake is not -supported for gcc builds. Parallel building is only supported with dmake and -gmake, not nmake. When using dmake it is recommended to use dmake 4.13 or newer -for parallel building. Older dmakes, in parallel mode, have very high CPU usage -and pound the disk/filing system with duplicate I/O calls in an aggressive -polling loop. - -A port of dmake for Windows is available from: - -L - -Fetch and install dmake somewhere on your path. +or Windows SDK. You may also use gmake instead of nmake. Builds using gcc need +gmake. nmake is not supported for gcc builds. Parallel building is only +supported with gmake, not nmake. =item Command Shell @@ -322,10 +310,10 @@ MinGW64 (version 4.4.3 or later). It can be downloaded here: L L -You also need dmake or gmake. See L above on how to get it. +You also need gmake. Usually it comes with MinGW but its executable may have +a different name, such as mingw32-make.exe. -Note that the MinGW build currently requires a MinGW runtime version earlier -than 3.21 (check __MINGW32_MAJOR_VERSION and __MINGW32_MINOR_VERSION). +Note that the MinGW build currently fails with version 6.3.0 or later. Note also that the C++ mode build currently fails with MinGW 3.4.5 and 4.7.2 or later, and with MinGW64 64-bit 6.3.0 or later. @@ -356,15 +344,14 @@ unlike GCC. Make sure you are in the "win32" subdirectory under the perl toplevel. This directory contains a "Makefile" that will work with versions of nmake that come with Visual C++ or the Windows SDK, and -a GNU make "GNUmakefile" or dmake "makefile.mk" that will work for all -supported compilers. The defaults in the gmake and dmake makefile are -setup to build using MinGW/gcc. +a GNU make "GNUmakefile" that will work for all supported compilers. +The defaults in the gmake makefile are setup to build using MinGW/gcc. =item * -Edit the GNUmakefile, makefile.mk (or Makefile, if you're using nmake) -and change the values of INST_DRV and INST_TOP. You can also enable -various build flags. These are explained in the makefiles. +Edit the GNUmakefile (or Makefile, if you're using nmake) and change the values +of INST_DRV and INST_TOP. You can also enable various build flags. These are +explained in the makefiles. Note that it is generally not a good idea to try to build a perl with INST_DRV and INST_TOP set to a path that already exists from a previous @@ -380,7 +367,7 @@ F directories. If building with the cross-compiler provided by mingw-w64.org you'll need to uncomment the line that sets -GCCCROSS in the makefile.mk. Do this only if it's the cross-compiler - ie +GCCCROSS in the GNUmakefile. Do this only if it's the cross-compiler - ie only if the bin folder doesn't contain a gcc.exe. (The cross-compiler does not provide a gcc.exe, g++.exe, ar.exe, etc. Instead, all of these executables are prefixed with 'x86_64-w64-mingw32-'.) @@ -396,21 +383,18 @@ Be sure to read the instructions near the top of the makefiles carefully. =item * -Type "dmake" ("gmake" for GNU make, or "nmake" if you are using that make). +Type "gmake" (or "nmake" if you are using that make). This should build everything. Specifically, it will create perl.exe, perl533.dll at the perl toplevel, and various other extension dll's under the lib\auto directory. If the build fails for any reason, make sure you have done the previous steps correctly. -To try dmake's parallel mode, type "dmake -P2", where 2, is the maximum number +To try gmake's parallel mode, type "gmake -j2", where 2, is the maximum number of parallel jobs you want to run. A number of things in the build process will run in parallel, but there are serialization points where you will see just 1 CPU maxed out. This is normal. -Similarly you can build in parallel with GNU make, type "gmake -j2" to -build with two parallel jobs, or higher for more. - If you are advanced enough with building C code, here is a suggestion to speed up building perl, and the later C. Try to keep your PATH environmental variable with the least number of folders possible (remember to keep your C @@ -422,7 +406,7 @@ is the most commonly launched program during the build and later testing. =head2 Testing Perl on Windows -Type "dmake test" (or "gmake test", "nmake test"). This will run most +Type "gmake test" (or "nmake test"). This will run most of the tests from the testsuite (many tests will be skipped). There should be no test failures. @@ -450,7 +434,7 @@ native "cmd.exe", or if you are building from a path that contains spaces. So don't do that. If you are running the tests from a emacs shell window, you may see -failures in op/stat.t. Run "dmake test-notty" in that case. +failures in op/stat.t. Run "gmake test-notty" in that case. Furthermore, you should make sure that during C you do not have any GNU tool packages in your path: some toolkits like Unixutils @@ -469,7 +453,7 @@ Please report any other failures as described under L. =head2 Installation of Perl on Windows -Type "dmake install" (or "gmake install", "nmake install"). This will +Type "gmake install" ("nmake install"). This will put the newly built perl and the libraries under whatever C points to in the Makefile. It will also install the pod documentation under C<$INST_TOP\$INST_VER\lib\pod> and HTML versions of the same @@ -652,25 +636,13 @@ may not provide a testsuite (so "$MAKE test" may not do anything or fail), but most serious ones do. It is important that you use a supported 'make' program, and -ensure Config.pm knows about it. If you don't have nmake, you can -either get dmake from the location mentioned earlier or get an -old version of nmake reportedly available from: - -L - -Another option is to use the make written in Perl, available from -CPAN. - -L - -You may also use dmake or gmake. See L above on how to get it. +ensure Config.pm knows about it. Note that MakeMaker actually emits makefiles with different syntax depending on what 'make' it thinks you are using. Therefore, it is important that one of the following values appears in Config.pm: make='nmake' # MakeMaker emits nmake syntax - make='dmake' # MakeMaker emits dmake syntax any other value # MakeMaker emits generic make syntax (e.g GNU make, or Perl make) @@ -970,6 +942,6 @@ Win9x support was added in 5.6 (Benjamin Stuhl). Support for 64-bit Windows added in 5.8 (ActiveState Corp). -Last updated: 30 April 2019 +Last updated: 26 January 2020 =cut diff --git a/XSUB.h b/XSUB.h index 616d8138401a..c1e395988542 100644 --- a/XSUB.h +++ b/XSUB.h @@ -108,10 +108,10 @@ is a lexical C<$_> in scope. */ #ifndef PERL_UNUSED_ARG -# define PERL_UNUSED_ARG(x) ((void)x) +# define PERL_UNUSED_ARG(x) ((void)sizeof(x)) #endif #ifndef PERL_UNUSED_VAR -# define PERL_UNUSED_VAR(x) ((void)x) +# define PERL_UNUSED_VAR(x) ((void)sizeof(x)) #endif #define ST(off) PL_stack_base[ax + (off)] diff --git a/amigaos4/amigaio.c b/amigaos4/amigaio.c index 3b5ce0e035a8..3b2cdcd5e024 100644 --- a/amigaos4/amigaio.c +++ b/amigaos4/amigaio.c @@ -28,244 +28,244 @@ extern int32 myruncommand(BPTR seglist, int stack, char *command, int length, ch void amigaos_stdio_get(pTHX_ StdioStore *store) { - store->astdin = - amigaos_get_file(PerlIO_fileno(IoIFP(GvIO(PL_stdingv)))); - store->astderr = - amigaos_get_file(PerlIO_fileno(IoIFP(GvIO(PL_stderrgv)))); - store->astdout = amigaos_get_file( - PerlIO_fileno(IoIFP(GvIO(gv_fetchpv("STDOUT", TRUE, SVt_PVIO))))); + store->astdin = + amigaos_get_file(PerlIO_fileno(IoIFP(GvIO(PL_stdingv)))); + store->astderr = + amigaos_get_file(PerlIO_fileno(IoIFP(GvIO(PL_stderrgv)))); + store->astdout = amigaos_get_file( + PerlIO_fileno(IoIFP(GvIO(gv_fetchpv("STDOUT", TRUE, SVt_PVIO))))); } void amigaos_stdio_save(pTHX_ StdioStore *store) { - amigaos_stdio_get(aTHX_ store); - store->oldstdin = IDOS->SelectInput(store->astdin); - store->oldstderr = IDOS->SelectErrorOutput(store->astderr); - store->oldstdout = IDOS->SelectOutput(store->astdout); + amigaos_stdio_get(aTHX_ store); + store->oldstdin = IDOS->SelectInput(store->astdin); + store->oldstderr = IDOS->SelectErrorOutput(store->astderr); + store->oldstdout = IDOS->SelectOutput(store->astdout); } void amigaos_stdio_restore(pTHX_ const StdioStore *store) { - IDOS->SelectInput(store->oldstdin); - IDOS->SelectErrorOutput(store->oldstderr); - IDOS->SelectOutput(store->oldstdout); + IDOS->SelectInput(store->oldstdin); + IDOS->SelectErrorOutput(store->oldstderr); + IDOS->SelectOutput(store->oldstdout); } void amigaos_post_exec(int fd, int do_report) { - /* We *must* write something to our pipe or else - * the other end hangs */ - if (do_report) - { - int e = errno; - PerlLIO_write(fd, (void *)&e, sizeof(e)); - PerlLIO_close(fd); - } + /* We *must* write something to our pipe or else + * the other end hangs */ + if (do_report) + { + int e = errno; + PerlLIO_write(fd, (void *)&e, sizeof(e)); + PerlLIO_close(fd); + } } struct popen_data { - struct Task *parent; - STRPTR command; + struct Task *parent; + STRPTR command; }; static int popen_result = 0; int popen_child() { - struct Task *thisTask = IExec->FindTask(0); - struct popen_data *pd = (struct popen_data *)thisTask->tc_UserData; - const char *argv[4]; + struct Task *thisTask = IExec->FindTask(0); + struct popen_data *pd = (struct popen_data *)thisTask->tc_UserData; + const char *argv[4]; - argv[0] = "sh"; - argv[1] = "-c"; - argv[2] = pd->command ? pd->command : NULL; - argv[3] = NULL; + argv[0] = "sh"; + argv[1] = "-c"; + argv[2] = pd->command ? pd->command : NULL; + argv[3] = NULL; - // adebug("%s %ld %s\n",__FUNCTION__,__LINE__,command?command:"NULL"); + // adebug("%s %ld %s\n",__FUNCTION__,__LINE__,command?command:"NULL"); - /* We need to give this to sh via execvp, execvp expects filename, - * argv[] - */ - IExec->ObtainSemaphore(&popen_sema); + /* We need to give this to sh via execvp, execvp expects filename, + * argv[] + */ + IExec->ObtainSemaphore(&popen_sema); - IExec->Signal(pd->parent,SIGBREAKF_CTRL_F); + IExec->Signal(pd->parent,SIGBREAKF_CTRL_F); - popen_result = myexecvp(FALSE, argv[0], (char **)argv); - if (pd->command) - IExec->FreeVec(pd->command); - IExec->FreeVec(pd); + popen_result = myexecvp(FALSE, argv[0], (char **)argv); + if (pd->command) + IExec->FreeVec(pd->command); + IExec->FreeVec(pd); - IExec->ReleaseSemaphore(&popen_sema); - IExec->Forbid(); - return 0; + IExec->ReleaseSemaphore(&popen_sema); + IExec->Forbid(); + return 0; } PerlIO *Perl_my_popen(pTHX_ const char *cmd, const char *mode) { - PERL_FLUSHALL_FOR_CHILD; - PerlIO *result = NULL; - char pipe_name[50]; - char unix_pipe[50]; - char ami_pipe[50]; - BPTR input = 0; - BPTR output = 0; - struct Process *proc = NULL; - struct Task *thisTask = IExec->FindTask(0); - struct popen_data * pd = NULL; - - /* First we need to check the mode - * We can only have unidirectional pipes - */ - // adebug("%s %ld cmd %s mode %s \n",__FUNCTION__,__LINE__,cmd, - // mode); - - switch (mode[0]) - { - case 'r': - case 'w': - break; - - default: - - errno = EINVAL; - return result; - } - - /* Make a unique pipe name - * we need a unix one and an amigaos version (of the same pipe!) - * as were linking with libunix. - */ - - sprintf(pipe_name, "%x%08lx/4096/0", pipenum++, - IUtility->GetUniqueID()); - sprintf(unix_pipe, "/PIPE/%s", pipe_name); - sprintf(ami_pipe, "PIPE:%s", pipe_name); - - /* Now we open the AmigaOs Filehandles That we wil pass to our - * Sub process - */ - - if (mode[0] == 'r') - { - /* A read mode pipe: Output from pipe input from Output() or NIL:*/ - /* First attempt to DUP Output() */ - input = IDOS->DupFileHandle(IDOS->Input()); - if(input == 0) - { - input = IDOS->Open("NIL:", MODE_READWRITE); - } - if (input != 0) - { - output = IDOS->Open(ami_pipe, MODE_NEWFILE); - } - result = PerlIO_open(unix_pipe, mode); - } - else - { - /* Open the write end first! */ - - result = PerlIO_open(unix_pipe, mode); - - input = IDOS->Open(ami_pipe, MODE_OLDFILE); - if (input != 0) - { - output = IDOS->DupFileHandle(IDOS->Output()); - if(output == 0) - { - output = IDOS->Open("NIL:", MODE_READWRITE); - } - } - } - if ((input == 0) || (output == 0) || (result == NULL)) - { - /* Ouch stream opening failed */ - /* Close and bail */ - if (input) - IDOS->Close(input); - if (output) - IDOS->Close(output); - if(result) - { - PerlIO_close(result); - result = NULL; - } - return result; - } - - /* We have our streams now start our new process - * We're using a new process so that execve can modify the environment - * with messing things up for the shell that launched perl - * Copy cmd before we launch the subprocess as perl seems to waste - * no time in overwriting it! The subprocess will free the copy. - */ - - if((pd = (struct popen_data*)IExec->AllocVecTags(sizeof(struct popen_data),AVT_Type,MEMF_SHARED,TAG_DONE))) - { - pd->parent = thisTask; - if ((pd->command = mystrdup(cmd))) - { - // adebug("%s %ld - // %s\n",__FUNCTION__,__LINE__,cmd_copy?cmd_copy:"NULL"); - proc = IDOS->CreateNewProcTags( - NP_Entry, popen_child, NP_Child, TRUE, NP_StackSize, - ((struct Process *)thisTask)->pr_StackSize, NP_Input, input, - NP_Output, output, NP_Error, IDOS->ErrorOutput(), - NP_CloseError, FALSE, NP_Cli, TRUE, NP_Name, - "Perl: popen process", NP_UserData, (int)pd, - TAG_DONE); - } - } - if(proc) - { - /* wait for the child be setup right */ - IExec->Wait(SIGBREAKF_CTRL_F); - } - if (!proc) - { - /* New Process Failed to start - * Close and bail out - */ - if(pd) - { - if(pd->command) - { - IExec->FreeVec(pd->command); - } - IExec->FreeVec(pd); - } - if (input) - IDOS->Close(input); - if (output) - IDOS->Close(output); - if(result) - { - PerlIO_close(result); - result = NULL; - } - } - - /* Our new process is running and will close it streams etc - * once its done. All we need to is open the pipe via stdio - */ - - return result; + PERL_FLUSHALL_FOR_CHILD; + PerlIO *result = NULL; + char pipe_name[50]; + char unix_pipe[50]; + char ami_pipe[50]; + BPTR input = 0; + BPTR output = 0; + struct Process *proc = NULL; + struct Task *thisTask = IExec->FindTask(0); + struct popen_data * pd = NULL; + + /* First we need to check the mode + * We can only have unidirectional pipes + */ + // adebug("%s %ld cmd %s mode %s \n",__FUNCTION__,__LINE__,cmd, + // mode); + + switch (mode[0]) + { + case 'r': + case 'w': + break; + + default: + + errno = EINVAL; + return result; + } + + /* Make a unique pipe name + * we need a unix one and an amigaos version (of the same pipe!) + * as were linking with libunix. + */ + + sprintf(pipe_name, "%x%08lx/4096/0", pipenum++, + IUtility->GetUniqueID()); + sprintf(unix_pipe, "/PIPE/%s", pipe_name); + sprintf(ami_pipe, "PIPE:%s", pipe_name); + + /* Now we open the AmigaOs Filehandles That we wil pass to our + * Sub process + */ + + if (mode[0] == 'r') + { + /* A read mode pipe: Output from pipe input from Output() or NIL:*/ + /* First attempt to DUP Output() */ + input = IDOS->DupFileHandle(IDOS->Input()); + if(input == 0) + { + input = IDOS->Open("NIL:", MODE_READWRITE); + } + if (input != 0) + { + output = IDOS->Open(ami_pipe, MODE_NEWFILE); + } + result = PerlIO_open(unix_pipe, mode); + } + else + { + /* Open the write end first! */ + + result = PerlIO_open(unix_pipe, mode); + + input = IDOS->Open(ami_pipe, MODE_OLDFILE); + if (input != 0) + { + output = IDOS->DupFileHandle(IDOS->Output()); + if(output == 0) + { + output = IDOS->Open("NIL:", MODE_READWRITE); + } + } + } + if ((input == 0) || (output == 0) || (result == NULL)) + { + /* Ouch stream opening failed */ + /* Close and bail */ + if (input) + IDOS->Close(input); + if (output) + IDOS->Close(output); + if(result) + { + PerlIO_close(result); + result = NULL; + } + return result; + } + + /* We have our streams now start our new process + * We're using a new process so that execve can modify the environment + * with messing things up for the shell that launched perl + * Copy cmd before we launch the subprocess as perl seems to waste + * no time in overwriting it! The subprocess will free the copy. + */ + + if((pd = (struct popen_data*)IExec->AllocVecTags(sizeof(struct popen_data),AVT_Type,MEMF_SHARED,TAG_DONE))) + { + pd->parent = thisTask; + if ((pd->command = mystrdup(cmd))) + { + // adebug("%s %ld + // %s\n",__FUNCTION__,__LINE__,cmd_copy?cmd_copy:"NULL"); + proc = IDOS->CreateNewProcTags( + NP_Entry, popen_child, NP_Child, TRUE, NP_StackSize, + ((struct Process *)thisTask)->pr_StackSize, NP_Input, input, + NP_Output, output, NP_Error, IDOS->ErrorOutput(), + NP_CloseError, FALSE, NP_Cli, TRUE, NP_Name, + "Perl: popen process", NP_UserData, (int)pd, + TAG_DONE); + } + } + if(proc) + { + /* wait for the child be setup right */ + IExec->Wait(SIGBREAKF_CTRL_F); + } + if (!proc) + { + /* New Process Failed to start + * Close and bail out + */ + if(pd) + { + if(pd->command) + { + IExec->FreeVec(pd->command); + } + IExec->FreeVec(pd); + } + if (input) + IDOS->Close(input); + if (output) + IDOS->Close(output); + if(result) + { + PerlIO_close(result); + result = NULL; + } + } + + /* Our new process is running and will close it streams etc + * once its done. All we need to is open the pipe via stdio + */ + + return result; } I32 Perl_my_pclose(pTHX_ PerlIO *ptr) { - int result = -1; - /* close the file before obtaining the semaphore else we might end up - hanging waiting for the child to read the last bit from the pipe */ - PerlIO_close(ptr); - IExec->ObtainSemaphore(&popen_sema); - result = popen_result; - IExec->ReleaseSemaphore(&popen_sema); - return result; + int result = -1; + /* close the file before obtaining the semaphore else we might end up + hanging waiting for the child to read the last bit from the pipe */ + PerlIO_close(ptr); + IExec->ObtainSemaphore(&popen_sema); + result = popen_result; + IExec->ReleaseSemaphore(&popen_sema); + return result; } @@ -284,11 +284,11 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) struct thread_info { - pthread_t ti_pid; - int ti_children; - pthread_t ti_parent; - struct MsgPort *ti_port; - struct Process *ti_Process; + pthread_t ti_pid; + int ti_children; + pthread_t ti_parent; + struct MsgPort *ti_port; + struct Process *ti_Process; }; static struct thread_info pseudo_children[MAX_THREADS]; @@ -297,61 +297,61 @@ static struct SignalSemaphore fork_array_sema; void amigaos4_init_fork_array() { - IExec->InitSemaphore(&fork_array_sema); - pseudo_children[0].ti_pid = (pthread_t)IExec->FindTask(0); - pseudo_children[0].ti_parent = -1; - pseudo_children[0].ti_port = - (struct MsgPort *)IExec->AllocSysObjectTags(ASOT_PORT, TAG_DONE); + IExec->InitSemaphore(&fork_array_sema); + pseudo_children[0].ti_pid = (pthread_t)IExec->FindTask(0); + pseudo_children[0].ti_parent = -1; + pseudo_children[0].ti_port = + (struct MsgPort *)IExec->AllocSysObjectTags(ASOT_PORT, TAG_DONE); } void amigaos4_dispose_fork_array() { - while (pseudo_children[0].ti_children > 0) - { - void *msg; - IExec->WaitPort(pseudo_children[0].ti_port); - msg = IExec->GetMsg(pseudo_children[0].ti_port); - if (msg) - IExec->FreeSysObject(ASOT_MESSAGE, msg); - pseudo_children[0].ti_children--; - } - IExec->FreeSysObject(ASOT_PORT, pseudo_children[0].ti_port); + while (pseudo_children[0].ti_children > 0) + { + void *msg; + IExec->WaitPort(pseudo_children[0].ti_port); + msg = IExec->GetMsg(pseudo_children[0].ti_port); + if (msg) + IExec->FreeSysObject(ASOT_MESSAGE, msg); + pseudo_children[0].ti_children--; + } + IExec->FreeSysObject(ASOT_PORT, pseudo_children[0].ti_port); } struct thread_exit_message { - struct Message tem_Message; - pthread_t tem_pid; - int tem_status; + struct Message tem_Message; + pthread_t tem_pid; + int tem_status; }; int getnextchild() { - int i; - for (i = 0; i < MAX_THREADS; i++) - { - if (pseudo_children[i].ti_pid == 0) - return i; - } - return -1; + int i; + for (i = 0; i < MAX_THREADS; i++) + { + if (pseudo_children[i].ti_pid == 0) + return i; + } + return -1; } int findparent(pthread_t pid) { - int i; - for (i = 0; i < MAX_THREADS; i++) - { - if (pseudo_children[i].ti_pid == pid) - return i; - } - return -1; + int i; + for (i = 0; i < MAX_THREADS; i++) + { + if (pseudo_children[i].ti_pid == pid) + return i; + } + return -1; } struct child_arg { - struct Task *ca_parent_task; - pthread_t ca_parent; - PerlInterpreter *ca_interp; + struct Task *ca_parent_task; + pthread_t ca_parent; + PerlInterpreter *ca_interp; }; #undef kill @@ -362,202 +362,202 @@ struct child_arg int amigaos_kill(Pid_t pid, int signal) { - int i; - BOOL thistask = FALSE; - Pid_t realpid = pid; // Perhaps we have a real pid from else where? - /* Look for our DOS pid */ - IExec->ObtainSemaphore(&fork_array_sema); - for (i = 0; i < MAX_THREADS; i++) - { - if (pseudo_children[i].ti_pid == pid) - { - realpid = (Pid_t)IDOS->GetPID(pseudo_children[i].ti_Process,GPID_PROCESS); - if(pseudo_children[i].ti_Process == (struct Process *)IExec->FindTask(NULL)) - { - thistask = TRUE; - } - break; - } - } - IExec->ReleaseSemaphore(&fork_array_sema); - /* Allow the C library to work out which signals are realy valid */ - if(thistask) - { - /* A quirk in newlib kill handling means it's better to call raise() rather than kill on out own task. */ - return raise(signal); - } - else - { - return kill(realpid,signal); - } + int i; + BOOL thistask = FALSE; + Pid_t realpid = pid; // Perhaps we have a real pid from else where? + /* Look for our DOS pid */ + IExec->ObtainSemaphore(&fork_array_sema); + for (i = 0; i < MAX_THREADS; i++) + { + if (pseudo_children[i].ti_pid == pid) + { + realpid = (Pid_t)IDOS->GetPID(pseudo_children[i].ti_Process,GPID_PROCESS); + if(pseudo_children[i].ti_Process == (struct Process *)IExec->FindTask(NULL)) + { + thistask = TRUE; + } + break; + } + } + IExec->ReleaseSemaphore(&fork_array_sema); + /* Allow the C library to work out which signals are realy valid */ + if(thistask) + { + /* A quirk in newlib kill handling means it's better to call raise() rather than kill on out own task. */ + return raise(signal); + } + else + { + return kill(realpid,signal); + } } static THREAD_RET_TYPE amigaos4_start_child(void *arg) { - PerlInterpreter *my_perl = - (PerlInterpreter *)((struct child_arg *)arg)->ca_interp; - ; + PerlInterpreter *my_perl = + (PerlInterpreter *)((struct child_arg *)arg)->ca_interp; + ; - GV *tmpgv; - int status; - int parent; - int nextchild; - pthread_t pseudo_id = pthread_self(); + GV *tmpgv; + int status; + int parent; + int nextchild; + pthread_t pseudo_id = pthread_self(); #ifdef PERL_SYNC_FORK - static long sync_fork_id = 0; - long id = ++sync_fork_id; + static long sync_fork_id = 0; + long id = ++sync_fork_id; #endif - /* before we do anything set up our process semaphore and add - a new entry to the pseudochildren */ + /* before we do anything set up our process semaphore and add + a new entry to the pseudochildren */ - /* get next available slot */ - /* should not fail here! */ + /* get next available slot */ + /* should not fail here! */ - IExec->ObtainSemaphore(&fork_array_sema); + IExec->ObtainSemaphore(&fork_array_sema); - nextchild = getnextchild(); + nextchild = getnextchild(); - pseudo_children[nextchild].ti_pid = pseudo_id; - pseudo_children[nextchild].ti_Process = (struct Process *)IExec->FindTask(NULL); - pseudo_children[nextchild].ti_parent = - ((struct child_arg *)arg)->ca_parent; - pseudo_children[nextchild].ti_port = - (struct MsgPort *)IExec->AllocSysObjectTags(ASOT_PORT, TAG_DONE); + pseudo_children[nextchild].ti_pid = pseudo_id; + pseudo_children[nextchild].ti_Process = (struct Process *)IExec->FindTask(NULL); + pseudo_children[nextchild].ti_parent = + ((struct child_arg *)arg)->ca_parent; + pseudo_children[nextchild].ti_port = + (struct MsgPort *)IExec->AllocSysObjectTags(ASOT_PORT, TAG_DONE); - num_pseudo_children++; - IExec->ReleaseSemaphore(&fork_array_sema); + num_pseudo_children++; + IExec->ReleaseSemaphore(&fork_array_sema); - /* We're set up let the parent continue */ + /* We're set up let the parent continue */ - IExec->Signal(((struct child_arg *)arg)->ca_parent_task, - SIGBREAKF_CTRL_F); + IExec->Signal(((struct child_arg *)arg)->ca_parent_task, + SIGBREAKF_CTRL_F); - PERL_SET_THX(my_perl); - if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV))) - { - SV *sv = GvSV(tmpgv); - SvREADONLY_off(sv); - sv_setiv(sv, (IV)pseudo_id); - SvREADONLY_on(sv); - } - hv_clear(PL_pidstatus); + PERL_SET_THX(my_perl); + if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV))) + { + SV *sv = GvSV(tmpgv); + SvREADONLY_off(sv); + sv_setiv(sv, (IV)pseudo_id); + SvREADONLY_on(sv); + } + hv_clear(PL_pidstatus); - /* push a zero on the stack (we are the child) */ - { - dSP; - dTARGET; - PUSHi(0); - PUTBACK; - } + /* push a zero on the stack (we are the child) */ + { + dSP; + dTARGET; + PUSHi(0); + PUTBACK; + } - /* continue from next op */ - PL_op = PL_op->op_next; + /* continue from next op */ + PL_op = PL_op->op_next; - { - dJMPENV; - volatile int oldscope = PL_scopestack_ix; + { + dJMPENV; + volatile int oldscope = PL_scopestack_ix; restart: - JMPENV_PUSH(status); - switch (status) - { - case 0: - CALLRUNOPS(aTHX); - status = 0; - break; - case 2: - while (PL_scopestack_ix > oldscope) - { - LEAVE; - } - FREETMPS; - PL_curstash = PL_defstash; - if (PL_endav && !PL_minus_c) - call_list(oldscope, PL_endav); - status = STATUS_EXIT; - break; - case 3: - if (PL_restartop) - { - POPSTACK_TO(PL_mainstack); - PL_op = PL_restartop; - PL_restartop = (OP *)NULL; - ; - goto restart; - } - PerlIO_printf(Perl_error_log, "panic: restartop\n"); - FREETMPS; - status = 1; - break; - } - JMPENV_POP; - - /* XXX hack to avoid perl_destruct() freeing optree */ - PL_main_root = (OP *)NULL; - } - - { - do_close(PL_stdingv, FALSE); - do_close(gv_fetchpv("STDOUT", TRUE, SVt_PVIO), - FALSE); /* PL_stdoutgv - ISAGN */ - do_close(PL_stderrgv, FALSE); - } - - /* destroy everything (waits for any pseudo-forked children) */ - - /* wait for any remaining children */ - - while (pseudo_children[nextchild].ti_children > 0) - { - if (IExec->WaitPort(pseudo_children[nextchild].ti_port)) - { - void *msg = - IExec->GetMsg(pseudo_children[nextchild].ti_port); - IExec->FreeSysObject(ASOT_MESSAGE, msg); - pseudo_children[nextchild].ti_children--; - } - } - if (PL_scopestack_ix <= 1) - { - perl_destruct(my_perl); - } - perl_free(my_perl); - - IExec->ObtainSemaphore(&fork_array_sema); - parent = findparent(pseudo_children[nextchild].ti_parent); - pseudo_children[nextchild].ti_pid = 0; - pseudo_children[nextchild].ti_parent = 0; - IExec->FreeSysObject(ASOT_PORT, pseudo_children[nextchild].ti_port); - pseudo_children[nextchild].ti_port = NULL; - - IExec->ReleaseSemaphore(&fork_array_sema); - - { - if (parent >= 0) - { - struct thread_exit_message *tem = - (struct thread_exit_message *) - IExec->AllocSysObjectTags( - ASOT_MESSAGE, ASOMSG_Size, - sizeof(struct thread_exit_message), - ASOMSG_Length, - sizeof(struct thread_exit_message)); - if (tem) - { - tem->tem_pid = pseudo_id; - tem->tem_status = status; - IExec->PutMsg(pseudo_children[parent].ti_port, - (struct Message *)tem); - } - } - } + JMPENV_PUSH(status); + switch (status) + { + case 0: + CALLRUNOPS(aTHX); + status = 0; + break; + case 2: + while (PL_scopestack_ix > oldscope) + { + LEAVE; + } + FREETMPS; + PL_curstash = PL_defstash; + if (PL_endav && !PL_minus_c) + call_list(oldscope, PL_endav); + status = STATUS_EXIT; + break; + case 3: + if (PL_restartop) + { + POPSTACK_TO(PL_mainstack); + PL_op = PL_restartop; + PL_restartop = (OP *)NULL; + ; + goto restart; + } + PerlIO_printf(Perl_error_log, "panic: restartop\n"); + FREETMPS; + status = 1; + break; + } + JMPENV_POP; + + /* XXX hack to avoid perl_destruct() freeing optree */ + PL_main_root = (OP *)NULL; + } + + { + do_close(PL_stdingv, FALSE); + do_close(gv_fetchpv("STDOUT", TRUE, SVt_PVIO), + FALSE); /* PL_stdoutgv - ISAGN */ + do_close(PL_stderrgv, FALSE); + } + + /* destroy everything (waits for any pseudo-forked children) */ + + /* wait for any remaining children */ + + while (pseudo_children[nextchild].ti_children > 0) + { + if (IExec->WaitPort(pseudo_children[nextchild].ti_port)) + { + void *msg = + IExec->GetMsg(pseudo_children[nextchild].ti_port); + IExec->FreeSysObject(ASOT_MESSAGE, msg); + pseudo_children[nextchild].ti_children--; + } + } + if (PL_scopestack_ix <= 1) + { + perl_destruct(my_perl); + } + perl_free(my_perl); + + IExec->ObtainSemaphore(&fork_array_sema); + parent = findparent(pseudo_children[nextchild].ti_parent); + pseudo_children[nextchild].ti_pid = 0; + pseudo_children[nextchild].ti_parent = 0; + IExec->FreeSysObject(ASOT_PORT, pseudo_children[nextchild].ti_port); + pseudo_children[nextchild].ti_port = NULL; + + IExec->ReleaseSemaphore(&fork_array_sema); + + { + if (parent >= 0) + { + struct thread_exit_message *tem = + (struct thread_exit_message *) + IExec->AllocSysObjectTags( + ASOT_MESSAGE, ASOMSG_Size, + sizeof(struct thread_exit_message), + ASOMSG_Length, + sizeof(struct thread_exit_message)); + if (tem) + { + tem->tem_pid = pseudo_id; + tem->tem_status = status; + IExec->PutMsg(pseudo_children[parent].ti_port, + (struct Message *)tem); + } + } + } #ifdef PERL_SYNC_FORK - return id; + return id; #else - return (void *)status; + return (void *)status; #endif } @@ -565,61 +565,61 @@ static THREAD_RET_TYPE amigaos4_start_child(void *arg) Pid_t amigaos_fork() { - dTHX; - pthread_t id; - int handle; - struct child_arg arg; - if (num_pseudo_children >= MAX_THREADS) - { - errno = EAGAIN; - return -1; - } - arg.ca_interp = perl_clone((PerlInterpreter *)aTHX, CLONEf_COPY_STACKS); - arg.ca_parent_task = IExec->FindTask(NULL); - arg.ca_parent = - pthread_self() ? pthread_self() : (pthread_t)IExec->FindTask(0); - - handle = pthread_create(&id, NULL, amigaos4_start_child, (void *)&arg); - pseudo_children[findparent(arg.ca_parent)].ti_children++; - - IExec->Wait(SIGBREAKF_CTRL_F); - - PERL_SET_THX(aTHX); /* XXX perl_clone*() set TLS */ - if (handle) - { - errno = EAGAIN; - return -1; - } - return id; + dTHX; + pthread_t id; + int handle; + struct child_arg arg; + if (num_pseudo_children >= MAX_THREADS) + { + errno = EAGAIN; + return -1; + } + arg.ca_interp = perl_clone((PerlInterpreter *)aTHX, CLONEf_COPY_STACKS); + arg.ca_parent_task = IExec->FindTask(NULL); + arg.ca_parent = + pthread_self() ? pthread_self() : (pthread_t)IExec->FindTask(0); + + handle = pthread_create(&id, NULL, amigaos4_start_child, (void *)&arg); + pseudo_children[findparent(arg.ca_parent)].ti_children++; + + IExec->Wait(SIGBREAKF_CTRL_F); + + PERL_SET_THX(aTHX); /* XXX perl_clone*() set TLS */ + if (handle) + { + errno = EAGAIN; + return -1; + } + return id; } Pid_t amigaos_waitpid(pTHX_ int optype, Pid_t pid, void *argflags) { - int result; - if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) - { - result = pthread_join(pid, (void **)argflags); - } - else - { - while ((result = pthread_join(pid, (void **)argflags)) == -1 && - errno == EINTR) - { - // PERL_ASYNC_CHECK(); - } - } - return result; + int result; + if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) + { + result = pthread_join(pid, (void **)argflags); + } + else + { + while ((result = pthread_join(pid, (void **)argflags)) == -1 && + errno == EINTR) + { + // PERL_ASYNC_CHECK(); + } + } + return result; } void amigaos_fork_set_userdata( pTHX_ struct UserData *userdata, I32 did_pipes, int pp, SV **sp, SV **mark) { - userdata->parent = IExec->FindTask(0); - userdata->did_pipes = did_pipes; - userdata->pp = pp; - userdata->sp = sp; - userdata->mark = mark; - userdata->my_perl = aTHX; + userdata->parent = IExec->FindTask(0); + userdata->did_pipes = did_pipes; + userdata->pp = pp; + userdata->sp = sp; + userdata->mark = mark; + userdata->my_perl = aTHX; } /* AmigaOS specific versions of #?exec#? solely for use in amigaos_system_child @@ -627,275 +627,275 @@ void amigaos_fork_set_userdata( static void S_exec_failed(pTHX_ const char *cmd, int fd, int do_report) { - const int e = errno; + const int e = errno; // PERL_ARGS_ASSERT_EXEC_FAILED; - if (e) - { - if (ckWARN(WARN_EXEC)) - Perl_warner(aTHX_ packWARN(WARN_EXEC), - "Can't exec \"%s\": %s", cmd, Strerror(e)); - } - if (do_report) - { - /* XXX silently ignore failures */ - PERL_UNUSED_RESULT(PerlLIO_write(fd, (void *)&e, sizeof(int))); - PerlLIO_close(fd); - } + if (e) + { + if (ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ packWARN(WARN_EXEC), + "Can't exec \"%s\": %s", cmd, Strerror(e)); + } + if (do_report) + { + /* XXX silently ignore failures */ + PERL_UNUSED_RESULT(PerlLIO_write(fd, (void *)&e, sizeof(int))); + PerlLIO_close(fd); + } } static I32 S_do_amigaos_exec3(pTHX_ const char *incmd, int fd, int do_report) { - const char **argv, **a; - char *s; - char *buf; - char *cmd; - /* Make a copy so we can change it */ - const Size_t cmdlen = strlen(incmd) + 1; - I32 result = -1; - - PERL_ARGS_ASSERT_DO_EXEC3; - - ENTER; - Newx(buf, cmdlen, char); - SAVEFREEPV(buf); - cmd = buf; - memcpy(cmd, incmd, cmdlen); - - while (*cmd && isSPACE(*cmd)) - cmd++; - - /* see if there are shell metacharacters in it */ - - if (*cmd == '.' && isSPACE(cmd[1])) - goto doshell; - - if (strBEGINs(cmd, "exec") && isSPACE(cmd[4])) - goto doshell; - - s = cmd; - while (isWORDCHAR(*s)) - s++; /* catch VAR=val gizmo */ - if (*s == '=') - goto doshell; - - for (s = cmd; *s; s++) - { - if (*s != ' ' && !isALPHA(*s) && - memCHRs("$&*(){}[]'\";\\|?<>~`\n", *s)) - { - if (*s == '\n' && !s[1]) - { - *s = '\0'; - break; - } - /* handle the 2>&1 construct at the end */ - if (*s == '>' && s[1] == '&' && s[2] == '1' && - s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2]) && - (!s[3] || isSPACE(s[3]))) - { - const char *t = s + 3; - - while (*t && isSPACE(*t)) - ++t; - if (!*t && (PerlLIO_dup2(1, 2) != -1)) - { - s[-2] = '\0'; - break; - } - } + const char **argv, **a; + char *s; + char *buf; + char *cmd; + /* Make a copy so we can change it */ + const Size_t cmdlen = strlen(incmd) + 1; + I32 result = -1; + + PERL_ARGS_ASSERT_DO_EXEC3; + + ENTER; + Newx(buf, cmdlen, char); + SAVEFREEPV(buf); + cmd = buf; + memcpy(cmd, incmd, cmdlen); + + while (*cmd && isSPACE(*cmd)) + cmd++; + + /* see if there are shell metacharacters in it */ + + if (*cmd == '.' && isSPACE(cmd[1])) + goto doshell; + + if (strBEGINs(cmd, "exec") && isSPACE(cmd[4])) + goto doshell; + + s = cmd; + while (isWORDCHAR(*s)) + s++; /* catch VAR=val gizmo */ + if (*s == '=') + goto doshell; + + for (s = cmd; *s; s++) + { + if (*s != ' ' && !isALPHA(*s) && + memCHRs("$&*(){}[]'\";\\|?<>~`\n", *s)) + { + if (*s == '\n' && !s[1]) + { + *s = '\0'; + break; + } + /* handle the 2>&1 construct at the end */ + if (*s == '>' && s[1] == '&' && s[2] == '1' && + s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2]) && + (!s[3] || isSPACE(s[3]))) + { + const char *t = s + 3; + + while (*t && isSPACE(*t)) + ++t; + if (!*t && (PerlLIO_dup2(1, 2) != -1)) + { + s[-2] = '\0'; + break; + } + } doshell: - PERL_FPU_PRE_EXEC - result = myexecl(FALSE, PL_sh_path, "sh", "-c", cmd, - (char *)NULL); - PERL_FPU_POST_EXEC - S_exec_failed(aTHX_ PL_sh_path, fd, do_report); - amigaos_post_exec(fd, do_report); - goto leave; - } - } - - Newx(argv, (s - cmd) / 2 + 2, const char *); - SAVEFREEPV(argv); - cmd = savepvn(cmd, s - cmd); - SAVEFREEPV(cmd); - a = argv; - for (s = cmd; *s;) - { - while (isSPACE(*s)) - s++; - if (*s) - *(a++) = s; - while (*s && !isSPACE(*s)) - s++; - if (*s) - *s++ = '\0'; - } - *a = NULL; - if (argv[0]) - { - PERL_FPU_PRE_EXEC - result = myexecvp(FALSE, argv[0], EXEC_ARGV_CAST(argv)); - PERL_FPU_POST_EXEC - if (errno == ENOEXEC) /* for system V NIH syndrome */ - goto doshell; - S_exec_failed(aTHX_ argv[0], fd, do_report); - amigaos_post_exec(fd, do_report); - } + PERL_FPU_PRE_EXEC + result = myexecl(FALSE, PL_sh_path, "sh", "-c", cmd, + (char *)NULL); + PERL_FPU_POST_EXEC + S_exec_failed(aTHX_ PL_sh_path, fd, do_report); + amigaos_post_exec(fd, do_report); + goto leave; + } + } + + Newx(argv, (s - cmd) / 2 + 2, const char *); + SAVEFREEPV(argv); + cmd = savepvn(cmd, s - cmd); + SAVEFREEPV(cmd); + a = argv; + for (s = cmd; *s;) + { + while (isSPACE(*s)) + s++; + if (*s) + *(a++) = s; + while (*s && !isSPACE(*s)) + s++; + if (*s) + *s++ = '\0'; + } + *a = NULL; + if (argv[0]) + { + PERL_FPU_PRE_EXEC + result = myexecvp(FALSE, argv[0], EXEC_ARGV_CAST(argv)); + PERL_FPU_POST_EXEC + if (errno == ENOEXEC) /* for system V NIH syndrome */ + goto doshell; + S_exec_failed(aTHX_ argv[0], fd, do_report); + amigaos_post_exec(fd, do_report); + } leave: - LEAVE; - return result; + LEAVE; + return result; } I32 S_do_amigaos_aexec5( pTHX_ SV *really, SV **mark, SV **sp, int fd, int do_report) { - I32 result = -1; - PERL_ARGS_ASSERT_DO_AEXEC5; - ENTER; - if (sp > mark) - { - const char **argv, **a; - const char *tmps = NULL; - Newx(argv, sp - mark + 1, const char *); - SAVEFREEPV(argv); - a = argv; - - while (++mark <= sp) - { - if (*mark) { - char *arg = savepv(SvPV_nolen_const(*mark)); - SAVEFREEPV(arg); - *a++ = arg; - } else - *a++ = ""; - } - *a = NULL; - if (really) { - tmps = savepv(SvPV_nolen_const(really)); - SAVEFREEPV(tmps); - } - if ((!really && *argv[0] != '/') || - (really && *tmps != '/')) /* will execvp use PATH? */ - TAINT_ENV(); /* testing IFS here is overkill, probably + I32 result = -1; + PERL_ARGS_ASSERT_DO_AEXEC5; + ENTER; + if (sp > mark) + { + const char **argv, **a; + const char *tmps = NULL; + Newx(argv, sp - mark + 1, const char *); + SAVEFREEPV(argv); + a = argv; + + while (++mark <= sp) + { + if (*mark) { + char *arg = savepv(SvPV_nolen_const(*mark)); + SAVEFREEPV(arg); + *a++ = arg; + } else + *a++ = ""; + } + *a = NULL; + if (really) { + tmps = savepv(SvPV_nolen_const(really)); + SAVEFREEPV(tmps); + } + if ((!really && *argv[0] != '/') || + (really && *tmps != '/')) /* will execvp use PATH? */ + TAINT_ENV(); /* testing IFS here is overkill, probably */ - PERL_FPU_PRE_EXEC - if (really && *tmps) - { - result = myexecvp(FALSE, tmps, EXEC_ARGV_CAST(argv)); - } - else - { - result = myexecvp(FALSE, argv[0], EXEC_ARGV_CAST(argv)); - } - PERL_FPU_POST_EXEC - S_exec_failed(aTHX_(really ? tmps : argv[0]), fd, do_report); - } - amigaos_post_exec(fd, do_report); - LEAVE; - return result; + PERL_FPU_PRE_EXEC + if (really && *tmps) + { + result = myexecvp(FALSE, tmps, EXEC_ARGV_CAST(argv)); + } + else + { + result = myexecvp(FALSE, argv[0], EXEC_ARGV_CAST(argv)); + } + PERL_FPU_POST_EXEC + S_exec_failed(aTHX_(really ? tmps : argv[0]), fd, do_report); + } + amigaos_post_exec(fd, do_report); + LEAVE; + return result; } void *amigaos_system_child(void *userdata) { - struct Task *parent; - I32 did_pipes; - int pp; - I32 value; - STRLEN n_a; - /* these next are declared by macros else where but I may be - * passing modified values here so declare them explictly but - * still referred to by macro below */ - - register SV **sp; - register SV **mark; - register PerlInterpreter *my_perl; - - StdioStore store; - - struct UserData *ud = (struct UserData *)userdata; - - did_pipes = ud->did_pipes; - parent = ud->parent; - pp = ud->pp; - SP = ud->sp; - MARK = ud->mark; - my_perl = ud->my_perl; - PERL_SET_THX(my_perl); - - amigaos_stdio_save(aTHX_ & store); - - if (did_pipes) - { - // PerlLIO_close(pp[0]); - } - if (PL_op->op_flags & OPf_STACKED) - { - SV *really = *++MARK; - value = (I32)S_do_amigaos_aexec5(aTHX_ really, MARK, SP, pp, - did_pipes); - } - else if (SP - MARK != 1) - { - value = (I32)S_do_amigaos_aexec5(aTHX_ NULL, MARK, SP, pp, - did_pipes); - } - else - { - value = (I32)S_do_amigaos_exec3( - aTHX_ SvPVx(sv_mortalcopy(*SP), n_a), pp, did_pipes); - } - - // Forbid(); - // Signal(parent, SIGBREAKF_CTRL_F); - - amigaos_stdio_restore(aTHX_ & store); - - return (void *)value; + struct Task *parent; + I32 did_pipes; + int pp; + I32 value; + STRLEN n_a; + /* these next are declared by macros else where but I may be + * passing modified values here so declare them explictly but + * still referred to by macro below */ + + register SV **sp; + register SV **mark; + register PerlInterpreter *my_perl; + + StdioStore store; + + struct UserData *ud = (struct UserData *)userdata; + + did_pipes = ud->did_pipes; + parent = ud->parent; + pp = ud->pp; + SP = ud->sp; + MARK = ud->mark; + my_perl = ud->my_perl; + PERL_SET_THX(my_perl); + + amigaos_stdio_save(aTHX_ & store); + + if (did_pipes) + { + // PerlLIO_close(pp[0]); + } + if (PL_op->op_flags & OPf_STACKED) + { + SV *really = *++MARK; + value = (I32)S_do_amigaos_aexec5(aTHX_ really, MARK, SP, pp, + did_pipes); + } + else if (SP - MARK != 1) + { + value = (I32)S_do_amigaos_aexec5(aTHX_ NULL, MARK, SP, pp, + did_pipes); + } + else + { + value = (I32)S_do_amigaos_exec3( + aTHX_ SvPVx(sv_mortalcopy(*SP), n_a), pp, did_pipes); + } + + // Forbid(); + // Signal(parent, SIGBREAKF_CTRL_F); + + amigaos_stdio_restore(aTHX_ & store); + + return (void *)value; } static BOOL contains_whitespace(char *string) { - if (string) - { - - if (strchr(string, ' ')) - return TRUE; - if (strchr(string, '\t')) - return TRUE; - if (strchr(string, '\n')) - return TRUE; - if (strchr(string, 0xA0)) - return TRUE; - if (strchr(string, '"')) - return TRUE; - } - return FALSE; + if (string) + { + + if (strchr(string, ' ')) + return TRUE; + if (strchr(string, '\t')) + return TRUE; + if (strchr(string, '\n')) + return TRUE; + if (strchr(string, 0xA0)) + return TRUE; + if (strchr(string, '"')) + return TRUE; + } + return FALSE; } static int no_of_escapes(char *string) { - int cnt = 0; - char *p; - for (p = string; p < string + strlen(string); p++) - { - if (*p == '"') - cnt++; - if (*p == '*') - cnt++; - if (*p == '\n') - cnt++; - if (*p == '\t') - cnt++; - } - return cnt; + int cnt = 0; + char *p; + for (p = string; p < string + strlen(string); p++) + { + if (*p == '"') + cnt++; + if (*p == '*') + cnt++; + if (*p == '\n') + cnt++; + if (*p == '\t') + cnt++; + } + return cnt; } struct command_data { - STRPTR args; - BPTR seglist; - struct Task *parent; + STRPTR args; + BPTR seglist; + struct Task *parent; }; #undef fopen @@ -910,262 +910,262 @@ int myexecve(bool isperlthread, char *argv[], char *envp[]) { - FILE *fh; - char buffer[1000]; - int size = 0; - char **cur; - char *interpreter = 0; - char *interpreter_args = 0; - char *full = 0; - char *filename_conv = 0; - char *interpreter_conv = 0; - // char *tmp = 0; - char *fname; - // int tmpint; - // struct Task *thisTask = IExec->FindTask(0); - int result = -1; - - StdioStore store; - - pTHX = NULL; - - if (isperlthread) - { - aTHX = PERL_GET_THX; - /* Save away our stdio */ - amigaos_stdio_save(aTHX_ & store); - } - - // adebug("%s %ld %s\n",__FUNCTION__,__LINE__,filename?filename:"NULL"); - - /* Calculate the size of filename and all args, including spaces and - * quotes */ - size = 0; // strlen(filename) + 1; - for (cur = (char **)argv /* +1 */; *cur; cur++) - { - size += - strlen(*cur) + 1 + - (contains_whitespace(*cur) ? (2 + no_of_escapes(*cur)) : 0); - } - /* Check if it's a script file */ - IExec->DebugPrintF("%s %ld %08lx %c %c\n",__FILE__,__LINE__,filename,filename[0],filename[1]); - fh = fopen(filename, "r"); - if (fh) - { - if (fgetc(fh) == '#' && fgetc(fh) == '!') - { - char *p; - char *q; - fgets(buffer, 999, fh); - p = buffer; - while (*p == ' ' || *p == '\t') - p++; - if (buffer[strlen(buffer) - 1] == '\n') - buffer[strlen(buffer) - 1] = '\0'; - if ((q = strchr(p, ' '))) - { - *q++ = '\0'; - if (*q != '\0') - { - interpreter_args = mystrdup(q); - } - } - else - interpreter_args = mystrdup(""); - - interpreter = mystrdup(p); - size += strlen(interpreter) + 1; - size += strlen(interpreter_args) + 1; - } - - fclose(fh); - } - else - { - /* We couldn't open this why not? */ - if (errno == ENOENT) - { - /* file didn't exist! */ - goto out; - } - } - - /* Allocate the command line */ - filename_conv = convert_path_u2a(filename); - - if (filename_conv) - size += strlen(filename_conv); - size += 1; - full = (char *)IExec->AllocVecTags(size + 10, AVT_ClearWithValue, 0 ,TAG_DONE); - if (full) - { - if (interpreter) - { - interpreter_conv = convert_path_u2a(interpreter); + FILE *fh; + char buffer[1000]; + int size = 0; + char **cur; + char *interpreter = 0; + char *interpreter_args = 0; + char *full = 0; + char *filename_conv = 0; + char *interpreter_conv = 0; + // char *tmp = 0; + char *fname; + // int tmpint; + // struct Task *thisTask = IExec->FindTask(0); + int result = -1; + + StdioStore store; + + pTHX = NULL; + + if (isperlthread) + { + aTHX = PERL_GET_THX; + /* Save away our stdio */ + amigaos_stdio_save(aTHX_ & store); + } + + // adebug("%s %ld %s\n",__FUNCTION__,__LINE__,filename?filename:"NULL"); + + /* Calculate the size of filename and all args, including spaces and + * quotes */ + size = 0; // strlen(filename) + 1; + for (cur = (char **)argv /* +1 */; *cur; cur++) + { + size += + strlen(*cur) + 1 + + (contains_whitespace(*cur) ? (2 + no_of_escapes(*cur)) : 0); + } + /* Check if it's a script file */ + IExec->DebugPrintF("%s %ld %08lx %c %c\n",__FILE__,__LINE__,filename,filename[0],filename[1]); + fh = fopen(filename, "r"); + if (fh) + { + if (fgetc(fh) == '#' && fgetc(fh) == '!') + { + char *p; + char *q; + fgets(buffer, 999, fh); + p = buffer; + while (*p == ' ' || *p == '\t') + p++; + if (buffer[strlen(buffer) - 1] == '\n') + buffer[strlen(buffer) - 1] = '\0'; + if ((q = strchr(p, ' '))) + { + *q++ = '\0'; + if (*q != '\0') + { + interpreter_args = mystrdup(q); + } + } + else + interpreter_args = mystrdup(""); + + interpreter = mystrdup(p); + size += strlen(interpreter) + 1; + size += strlen(interpreter_args) + 1; + } + + fclose(fh); + } + else + { + /* We couldn't open this why not? */ + if (errno == ENOENT) + { + /* file didn't exist! */ + goto out; + } + } + + /* Allocate the command line */ + filename_conv = convert_path_u2a(filename); + + if (filename_conv) + size += strlen(filename_conv); + size += 1; + full = (char *)IExec->AllocVecTags(size + 10, AVT_ClearWithValue, 0 ,TAG_DONE); + if (full) + { + if (interpreter) + { + interpreter_conv = convert_path_u2a(interpreter); #if !defined(__USE_RUNCOMMAND__) #warning(using system!) - sprintf(full, "%s %s %s ", interpreter_conv, - interpreter_args, filename_conv); + sprintf(full, "%s %s %s ", interpreter_conv, + interpreter_args, filename_conv); #else - sprintf(full, "%s %s ", interpreter_args, - filename_conv); + sprintf(full, "%s %s ", interpreter_args, + filename_conv); #endif - IExec->FreeVec(interpreter); - IExec->FreeVec(interpreter_args); - - if (filename_conv) - IExec->FreeVec(filename_conv); - fname = mystrdup(interpreter_conv); - - if (interpreter_conv) - IExec->FreeVec(interpreter_conv); - } - else - { + IExec->FreeVec(interpreter); + IExec->FreeVec(interpreter_args); + + if (filename_conv) + IExec->FreeVec(filename_conv); + fname = mystrdup(interpreter_conv); + + if (interpreter_conv) + IExec->FreeVec(interpreter_conv); + } + else + { #ifndef __USE_RUNCOMMAND__ - sprintf(full, "%s ", filename_conv); + sprintf(full, "%s ", filename_conv); #else - sprintf(full, ""); + sprintf(full, ""); #endif - fname = mystrdup(filename_conv); - if (filename_conv) - IExec->FreeVec(filename_conv); - } - - for (cur = (char **)(argv + 1); *cur != 0; cur++) - { - if (contains_whitespace(*cur)) - { - int esc = no_of_escapes(*cur); - - if (esc > 0) - { - char *buff = (char *)IExec->AllocVecTags( - strlen(*cur) + 4 + esc, - AVT_ClearWithValue,0, - TAG_DONE); - char *p = *cur; - char *q = buff; - - *q++ = '"'; - while (*p != '\0') - { - - if (*p == '\n') - { - *q++ = '*'; - *q++ = 'N'; - p++; - continue; - } - else if (*p == '"') - { - *q++ = '*'; - *q++ = '"'; - p++; - continue; - } - else if (*p == '*') - { - *q++ = '*'; - } - *q++ = *p++; - } - *q++ = '"'; - *q++ = ' '; - *q = '\0'; - strcat(full, buff); - IExec->FreeVec(buff); - } - else - { - strcat(full, "\""); - strcat(full, *cur); - strcat(full, "\" "); - } - } - else - { - strcat(full, *cur); - strcat(full, " "); - } - } - strcat(full, "\n"); + fname = mystrdup(filename_conv); + if (filename_conv) + IExec->FreeVec(filename_conv); + } + + for (cur = (char **)(argv + 1); *cur != 0; cur++) + { + if (contains_whitespace(*cur)) + { + int esc = no_of_escapes(*cur); + + if (esc > 0) + { + char *buff = (char *)IExec->AllocVecTags( + strlen(*cur) + 4 + esc, + AVT_ClearWithValue,0, + TAG_DONE); + char *p = *cur; + char *q = buff; + + *q++ = '"'; + while (*p != '\0') + { + + if (*p == '\n') + { + *q++ = '*'; + *q++ = 'N'; + p++; + continue; + } + else if (*p == '"') + { + *q++ = '*'; + *q++ = '"'; + p++; + continue; + } + else if (*p == '*') + { + *q++ = '*'; + } + *q++ = *p++; + } + *q++ = '"'; + *q++ = ' '; + *q = '\0'; + strcat(full, buff); + IExec->FreeVec(buff); + } + else + { + strcat(full, "\""); + strcat(full, *cur); + strcat(full, "\" "); + } + } + else + { + strcat(full, *cur); + strcat(full, " "); + } + } + strcat(full, "\n"); // if(envp) // createvars(envp); #ifndef __USE_RUNCOMMAND__ - result = IDOS->SystemTags( - full, SYS_UserShell, TRUE, NP_StackSize, - ((struct Process *)thisTask)->pr_StackSize, SYS_Input, - ((struct Process *)thisTask)->pr_CIS, SYS_Output, - ((struct Process *)thisTask)->pr_COS, SYS_Error, - ((struct Process *)thisTask)->pr_CES, TAG_DONE); + result = IDOS->SystemTags( + full, SYS_UserShell, TRUE, NP_StackSize, + ((struct Process *)thisTask)->pr_StackSize, SYS_Input, + ((struct Process *)thisTask)->pr_CIS, SYS_Output, + ((struct Process *)thisTask)->pr_COS, SYS_Error, + ((struct Process *)thisTask)->pr_CES, TAG_DONE); #else - if (fname) - { - BPTR seglist = IDOS->LoadSeg(fname); - if (seglist) - { - /* check if we have an executable! */ - struct PseudoSegList *ps = NULL; - if (!IDOS->GetSegListInfoTags( - seglist, GSLI_Native, &ps, TAG_DONE)) - { - IDOS->GetSegListInfoTags( - seglist, GSLI_68KPS, &ps, TAG_DONE); - } - if (ps != NULL) - { - // adebug("%s %ld %s - // %s\n",__FUNCTION__,__LINE__,fname,full); - IDOS->SetCliProgramName(fname); - // result=RunCommand(seglist,8*1024,full,strlen(full)); - // result=myruncommand(seglist,8*1024,full,strlen(full),envp); - result = myruncommand(seglist, 8 * 1024, - full, -1, envp); - errno = 0; - } - else - { - errno = ENOEXEC; - } - IDOS->UnLoadSeg(seglist); - } - else - { - errno = ENOEXEC; - } - IExec->FreeVec(fname); - } + if (fname) + { + BPTR seglist = IDOS->LoadSeg(fname); + if (seglist) + { + /* check if we have an executable! */ + struct PseudoSegList *ps = NULL; + if (!IDOS->GetSegListInfoTags( + seglist, GSLI_Native, &ps, TAG_DONE)) + { + IDOS->GetSegListInfoTags( + seglist, GSLI_68KPS, &ps, TAG_DONE); + } + if (ps != NULL) + { + // adebug("%s %ld %s + // %s\n",__FUNCTION__,__LINE__,fname,full); + IDOS->SetCliProgramName(fname); + // result=RunCommand(seglist,8*1024,full,strlen(full)); + // result=myruncommand(seglist,8*1024,full,strlen(full),envp); + result = myruncommand(seglist, 8 * 1024, + full, -1, envp); + errno = 0; + } + else + { + errno = ENOEXEC; + } + IDOS->UnLoadSeg(seglist); + } + else + { + errno = ENOEXEC; + } + IExec->FreeVec(fname); + } #endif /* USE_RUNCOMMAND */ - IExec->FreeVec(full); - if (errno == ENOEXEC) - { - result = -1; - } - goto out; - } + IExec->FreeVec(full); + if (errno == ENOEXEC) + { + result = -1; + } + goto out; + } - if (interpreter) - IExec->FreeVec(interpreter); - if (filename_conv) - IExec->FreeVec(filename_conv); + if (interpreter) + IExec->FreeVec(interpreter); + if (filename_conv) + IExec->FreeVec(filename_conv); - errno = ENOMEM; + errno = ENOMEM; out: - if (isperlthread) - { - amigaos_stdio_restore(aTHX_ & store); - STATUS_NATIVE_CHILD_SET(result); - PL_exit_flags |= PERL_EXIT_EXPECTED; - if (result != -1) - my_exit(result); - } - return (result); + if (isperlthread) + { + amigaos_stdio_restore(aTHX_ & store); + STATUS_NATIVE_CHILD_SET(result); + PL_exit_flags |= PERL_EXIT_EXPECTED; + if (result != -1) + my_exit(result); + } + return (result); } diff --git a/amigaos4/amigaio.h b/amigaos4/amigaio.h index 1f1a53a0dee0..0385ce14bd55 100644 --- a/amigaos4/amigaio.h +++ b/amigaos4/amigaio.h @@ -7,14 +7,14 @@ struct StdioStore { - /* astdin...astderr are the amigaos file descriptors */ - long astdin; - long astdout; - long astderr; - /* oldstdin...oldstderr are the amigados file handles */ - long oldstdin; - long oldstdout; - long oldstderr; + /* astdin...astderr are the amigaos file descriptors */ + long astdin; + long astdout; + long astderr; + /* oldstdin...oldstderr are the amigados file handles */ + long oldstdin; + long oldstdout; + long oldstderr; }; typedef struct StdioStore StdioStore; @@ -32,12 +32,12 @@ void amigaos_stdio_restore(pTHX_ const StdioStore *store); * then pass it through task->tc_UserData or as arg to new pthread */ struct UserData { - struct Task *parent; - I32 did_pipes; - int pp; - SV **sp; - SV **mark; - PerlInterpreter *my_perl; + struct Task *parent; + I32 did_pipes; + int pp; + SV **sp; + SV **mark; + PerlInterpreter *my_perl; }; void amigaos_fork_set_userdata( diff --git a/amigaos4/amigaos.c b/amigaos4/amigaos.c index 7d432d9dfc2f..cf5967315fe0 100644 --- a/amigaos4/amigaos.c +++ b/amigaos4/amigaos.c @@ -36,28 +36,28 @@ struct UtilityIFace *IUtility = NULL; struct Interface *OpenInterface(CONST_STRPTR libname, uint32 libver) { - struct Library *base = IExec->OpenLibrary(libname, libver); - struct Interface *iface = IExec->GetInterface(base, "main", 1, NULL); - if (iface == NULL) - { - // We should probably post some kind of error message here. + struct Library *base = IExec->OpenLibrary(libname, libver); + struct Interface *iface = IExec->GetInterface(base, "main", 1, NULL); + if (iface == NULL) + { + // We should probably post some kind of error message here. - IExec->CloseLibrary(base); - } + IExec->CloseLibrary(base); + } - return iface; + return iface; } /***************************************************************************/ void CloseInterface(struct Interface *iface) { - if (iface != NULL) - { - struct Library *base = iface->Data.LibBase; - IExec->DropInterface(iface); - IExec->CloseLibrary(base); - } + if (iface != NULL) + { + struct Library *base = iface->Data.LibBase; + IExec->DropInterface(iface); + IExec->CloseLibrary(base); + } } BOOL __unlink_retries = FALSE; @@ -70,17 +70,17 @@ void ___closeinterfaces() __attribute__((destructor)); void ___openinterfaces() { - if (!IDOS) - IDOS = (struct DOSIFace *)OpenInterface("dos.library", 53); - if (!IUtility) - IUtility = - (struct UtilityIFace *)OpenInterface("utility.library", 53); + if (!IDOS) + IDOS = (struct DOSIFace *)OpenInterface("dos.library", 53); + if (!IUtility) + IUtility = + (struct UtilityIFace *)OpenInterface("utility.library", 53); } void ___closeinterfaces() { - CloseInterface((struct Interface *)IDOS); - CloseInterface((struct Interface *)IUtility); + CloseInterface((struct Interface *)IDOS); + CloseInterface((struct Interface *)IUtility); } int VARARGS68K araddebug(UBYTE *fmt, ...); int VARARGS68K adebug(UBYTE *fmt, ...); @@ -94,150 +94,150 @@ static void createvars(char **envp); struct args { - BPTR seglist; - int stack; - char *command; - int length; - int result; - char **envp; + BPTR seglist; + int stack; + char *command; + int length; + int result; + char **envp; }; int __myrc(__attribute__((unused))char *arg) { - struct Task *thisTask = IExec->FindTask(0); - struct args *myargs = (struct args *)thisTask->tc_UserData; - if (myargs->envp) - createvars(myargs->envp); - // adebug("%s %ld %s \n",__FUNCTION__,__LINE__,myargs->command); - myargs->result = IDOS->RunCommand(myargs->seglist, myargs->stack, - myargs->command, myargs->length); - return 0; + struct Task *thisTask = IExec->FindTask(0); + struct args *myargs = (struct args *)thisTask->tc_UserData; + if (myargs->envp) + createvars(myargs->envp); + // adebug("%s %ld %s \n",__FUNCTION__,__LINE__,myargs->command); + myargs->result = IDOS->RunCommand(myargs->seglist, myargs->stack, + myargs->command, myargs->length); + return 0; } int32 myruncommand( BPTR seglist, int stack, char *command, int length, char **envp) { - struct args myargs; - struct Task *thisTask = IExec->FindTask(0); - struct Process *proc; - - // adebug("%s %ld %s\n",__FUNCTION__,__LINE__,command?command:"NULL"); - - myargs.seglist = seglist; - myargs.stack = stack; - myargs.command = command; - myargs.length = length; - myargs.result = -1; - myargs.envp = envp; - - if ((proc = IDOS->CreateNewProcTags( - NP_Entry, __myrc, NP_Child, TRUE, NP_Input, IDOS->Input(), - NP_Output, IDOS->Output(), NP_Error, IDOS->ErrorOutput(), - NP_CloseInput, FALSE, NP_CloseOutput, FALSE, NP_CloseError, - FALSE, NP_CopyVars, FALSE, - - // NP_StackSize, ((struct Process - // *)myargs.parent)->pr_StackSize, - NP_Cli, TRUE, NP_UserData, (int)&myargs, - NP_NotifyOnDeathSigTask, thisTask, TAG_DONE))) - - { - IExec->Wait(SIGF_CHILD); - } - return myargs.result; + struct args myargs; + struct Task *thisTask = IExec->FindTask(0); + struct Process *proc; + + // adebug("%s %ld %s\n",__FUNCTION__,__LINE__,command?command:"NULL"); + + myargs.seglist = seglist; + myargs.stack = stack; + myargs.command = command; + myargs.length = length; + myargs.result = -1; + myargs.envp = envp; + + if ((proc = IDOS->CreateNewProcTags( + NP_Entry, __myrc, NP_Child, TRUE, NP_Input, IDOS->Input(), + NP_Output, IDOS->Output(), NP_Error, IDOS->ErrorOutput(), + NP_CloseInput, FALSE, NP_CloseOutput, FALSE, NP_CloseError, + FALSE, NP_CopyVars, FALSE, + + // NP_StackSize, ((struct Process + // *)myargs.parent)->pr_StackSize, + NP_Cli, TRUE, NP_UserData, (int)&myargs, + NP_NotifyOnDeathSigTask, thisTask, TAG_DONE))) + + { + IExec->Wait(SIGF_CHILD); + } + return myargs.result; } char *mystrdup(const char *s) { - char *result = NULL; - size_t size; + char *result = NULL; + size_t size; - size = strlen(s) + 1; + size = strlen(s) + 1; - if ((result = (char *)IExec->AllocVecTags(size, TAG_DONE))) - { - memmove(result, s, size); - } - return result; + if ((result = (char *)IExec->AllocVecTags(size, TAG_DONE))) + { + memmove(result, s, size); + } + return result; } unsigned int pipenum = 0; int pipe(int filedes[2]) { - char pipe_name[1024]; + char pipe_name[1024]; // adebug("%s %ld \n",__FUNCTION__,__LINE__); #ifdef USE_TEMPFILES - sprintf(pipe_name, "/T/%x.%08lx", pipenum++, IUtility->GetUniqueID()); + sprintf(pipe_name, "/T/%x.%08lx", pipenum++, IUtility->GetUniqueID()); #else - sprintf(pipe_name, "/PIPE/%x%08lx/4096/0", pipenum++, - IUtility->GetUniqueID()); + sprintf(pipe_name, "/PIPE/%x%08lx/4096/0", pipenum++, + IUtility->GetUniqueID()); #endif - /* printf("pipe: %s \n", pipe_name);*/ - - filedes[1] = open(pipe_name, O_WRONLY | O_CREAT); - filedes[0] = open(pipe_name, O_RDONLY); - if (filedes[0] == -1 || filedes[1] == -1) - { - if (filedes[0] != -1) - close(filedes[0]); - if (filedes[1] != -1) - close(filedes[1]); - return -1; - } - /* printf("filedes %d %d\n", filedes[0], - * filedes[1]);fflush(stdout);*/ - - return 0; + /* printf("pipe: %s \n", pipe_name);*/ + + filedes[1] = open(pipe_name, O_WRONLY | O_CREAT); + filedes[0] = open(pipe_name, O_RDONLY); + if (filedes[0] == -1 || filedes[1] == -1) + { + if (filedes[0] != -1) + close(filedes[0]); + if (filedes[1] != -1) + close(filedes[1]); + return -1; + } + /* printf("filedes %d %d\n", filedes[0], + * filedes[1]);fflush(stdout);*/ + + return 0; } int fork(void) { - fprintf(stderr, "Can not bloody fork\n"); - errno = ENOMEM; - return -1; + fprintf(stderr, "Can not bloody fork\n"); + errno = ENOMEM; + return -1; } int wait(__attribute__((unused))int *status) { - fprintf(stderr, "No wait try waitpid instead\n"); - errno = ECHILD; - return -1; + fprintf(stderr, "No wait try waitpid instead\n"); + errno = ECHILD; + return -1; } char *convert_path_a2u(const char *filename) { - struct NameTranslationInfo nti; + struct NameTranslationInfo nti; - if (!filename) - { - return 0; - } + if (!filename) + { + return 0; + } - __translate_amiga_to_unix_path_name(&filename, &nti); + __translate_amiga_to_unix_path_name(&filename, &nti); - return mystrdup(filename); + return mystrdup(filename); } char *convert_path_u2a(const char *filename) { - struct NameTranslationInfo nti; + struct NameTranslationInfo nti; - if (!filename) - { - return 0; - } + if (!filename) + { + return 0; + } - if (strcmp(filename, "/dev/tty") == 0) - { - return mystrdup("CONSOLE:"); - ; - } + if (strcmp(filename, "/dev/tty") == 0) + { + return mystrdup("CONSOLE:"); + ; + } - __translate_unix_to_amiga_path_name(&filename, &nti); + __translate_unix_to_amiga_path_name(&filename, &nti); - return mystrdup(filename); + return mystrdup(filename); } struct SignalSemaphore environ_sema; @@ -246,278 +246,278 @@ struct SignalSemaphore popen_sema; void amigaos4_init_environ_sema() { - IExec->InitSemaphore(&environ_sema); - IExec->InitSemaphore(&popen_sema); + IExec->InitSemaphore(&environ_sema); + IExec->InitSemaphore(&popen_sema); } void amigaos4_obtain_environ() { - IExec->ObtainSemaphore(&environ_sema); + IExec->ObtainSemaphore(&environ_sema); } void amigaos4_release_environ() { - IExec->ReleaseSemaphore(&environ_sema); + IExec->ReleaseSemaphore(&environ_sema); } static void createvars(char **envp) { - if (envp) - { - /* Set a local var to indicate to any subsequent sh that it is - * not - * the top level shell and so should only inherit local amigaos - * vars */ - IDOS->SetVar("ABCSH_IMPORT_LOCAL", "TRUE", 5, GVF_LOCAL_ONLY); - - amigaos4_obtain_environ(); - - envp = myenviron; - - while ((envp != NULL) && (*envp != NULL)) - { - int len; - char *var; - char *val; - if ((len = strlen(*envp))) - { - if ((var = (char *)IExec->AllocVecTags(len + 1, AVT_ClearWithValue,0,TAG_DONE))) - { - strcpy(var, *envp); - - val = strchr(var, '='); - if (val) - { - *val++ = '\0'; - if (*val) - { - IDOS->SetVar( - var, val, - strlen(val) + 1, - GVF_LOCAL_ONLY); - } - } - IExec->FreeVec(var); - } - } - envp++; - } - amigaos4_release_environ(); - } + if (envp) + { + /* Set a local var to indicate to any subsequent sh that it is + * not + * the top level shell and so should only inherit local amigaos + * vars */ + IDOS->SetVar("ABCSH_IMPORT_LOCAL", "TRUE", 5, GVF_LOCAL_ONLY); + + amigaos4_obtain_environ(); + + envp = myenviron; + + while ((envp != NULL) && (*envp != NULL)) + { + int len; + char *var; + char *val; + if ((len = strlen(*envp))) + { + if ((var = (char *)IExec->AllocVecTags(len + 1, AVT_ClearWithValue,0,TAG_DONE))) + { + strcpy(var, *envp); + + val = strchr(var, '='); + if (val) + { + *val++ = '\0'; + if (*val) + { + IDOS->SetVar( + var, val, + strlen(val) + 1, + GVF_LOCAL_ONLY); + } + } + IExec->FreeVec(var); + } + } + envp++; + } + amigaos4_release_environ(); + } } struct command_data { - STRPTR args; - BPTR seglist; - struct Task *parent; + STRPTR args; + BPTR seglist; + struct Task *parent; }; int myexecvp(bool isperlthread, const char *filename, char *argv[]) { - // adebug("%s %ld - //%s\n",__FUNCTION__,__LINE__,filename?filename:"NULL"); - /* if there's a slash or a colon consider filename a path and skip - * search */ - int res; - char *name = NULL; - char *pathpart = NULL; - if ((strchr(filename, '/') == NULL) && (strchr(filename, ':') == NULL)) - { - const char *path; - const char *p; - size_t len; - struct stat st; - - if (!(path = getenv("PATH"))) - { - path = ".:/bin:/usr/bin:/c"; - } - - len = strlen(filename) + 1; - name = (char *)IExec->AllocVecTags(strlen(path) + len, AVT_ClearWithValue,0,AVT_Type,MEMF_SHARED,TAG_DONE); - pathpart = (char *)IExec->AllocVecTags(strlen(path) + 1, AVT_ClearWithValue,0,AVT_Type,MEMF_SHARED,TAG_DONE); - p = path; - do - { - path = p; - - if (!(p = strchr(path, ':'))) - { - p = strchr(path, '\0'); - } - - memcpy(pathpart, path, p - path); - pathpart[p - path] = '\0'; - if (!(strlen(pathpart) == 0)) - { - sprintf(name, "%s/%s", pathpart, filename); - } - else - sprintf(name, "%s", filename); - - if ((stat(name, &st) == 0) && (S_ISREG(st.st_mode))) - { - /* we stated it and it's a regular file */ - /* let's boogie! */ - filename = name; - break; - } - - } - while (*p++ != '\0'); - } - - res = myexecve(isperlthread, filename, argv, myenviron); - - if(name) - { - IExec->FreeVec((APTR)name); - name = NULL; - } - if(pathpart) - { - IExec->FreeVec((APTR)pathpart); - pathpart = NULL; - } - return res; + // adebug("%s %ld + //%s\n",__FUNCTION__,__LINE__,filename?filename:"NULL"); + /* if there's a slash or a colon consider filename a path and skip + * search */ + int res; + char *name = NULL; + char *pathpart = NULL; + if ((strchr(filename, '/') == NULL) && (strchr(filename, ':') == NULL)) + { + const char *path; + const char *p; + size_t len; + struct stat st; + + if (!(path = getenv("PATH"))) + { + path = ".:/bin:/usr/bin:/c"; + } + + len = strlen(filename) + 1; + name = (char *)IExec->AllocVecTags(strlen(path) + len, AVT_ClearWithValue,0,AVT_Type,MEMF_SHARED,TAG_DONE); + pathpart = (char *)IExec->AllocVecTags(strlen(path) + 1, AVT_ClearWithValue,0,AVT_Type,MEMF_SHARED,TAG_DONE); + p = path; + do + { + path = p; + + if (!(p = strchr(path, ':'))) + { + p = strchr(path, '\0'); + } + + memcpy(pathpart, path, p - path); + pathpart[p - path] = '\0'; + if (!(strlen(pathpart) == 0)) + { + sprintf(name, "%s/%s", pathpart, filename); + } + else + sprintf(name, "%s", filename); + + if ((stat(name, &st) == 0) && (S_ISREG(st.st_mode))) + { + /* we stated it and it's a regular file */ + /* let's boogie! */ + filename = name; + break; + } + + } + while (*p++ != '\0'); + } + + res = myexecve(isperlthread, filename, argv, myenviron); + + if(name) + { + IExec->FreeVec((APTR)name); + name = NULL; + } + if(pathpart) + { + IExec->FreeVec((APTR)pathpart); + pathpart = NULL; + } + return res; } int myexecv(bool isperlthread, const char *path, char *argv[]) { - return myexecve(isperlthread, path, argv, myenviron); + return myexecve(isperlthread, path, argv, myenviron); } int myexecl(bool isperlthread, const char *path, ...) { - va_list va; - char *argv[1024]; /* 1024 enough? let's hope so! */ - int i = 0; - // adebug("%s %ld\n",__FUNCTION__,__LINE__); - - va_start(va, path); - i = 0; - - do - { - argv[i] = va_arg(va, char *); - } - while (argv[i++] != NULL); - - va_end(va); - return myexecve(isperlthread, path, argv, myenviron); + va_list va; + char *argv[1024]; /* 1024 enough? let's hope so! */ + int i = 0; + // adebug("%s %ld\n",__FUNCTION__,__LINE__); + + va_start(va, path); + i = 0; + + do + { + argv[i] = va_arg(va, char *); + } + while (argv[i++] != NULL); + + va_end(va); + return myexecve(isperlthread, path, argv, myenviron); } int pause(void) { - fprintf(stderr, "Pause not implemented\n"); + fprintf(stderr, "Pause not implemented\n"); - errno = EINTR; - return -1; + errno = EINTR; + return -1; } uint32 size_env(struct Hook *hook, __attribute__((unused))APTR userdata, struct ScanVarsMsg *message) { - if (strlen(message->sv_GDir) <= 4) - { - hook->h_Data = (APTR)(((uint32)hook->h_Data) + 1); - } - return 0; + if (strlen(message->sv_GDir) <= 4) + { + hook->h_Data = (APTR)(((uint32)hook->h_Data) + 1); + } + return 0; } uint32 copy_env(struct Hook *hook, __attribute__((unused))APTR userdata, struct ScanVarsMsg *message) { - if (strlen(message->sv_GDir) <= 4) - { - char **env = (char **)hook->h_Data; - uint32 size = - strlen(message->sv_Name) + 1 + message->sv_VarLen + 1 + 1; - char *buffer = (char *)IExec->AllocVecTags((uint32)size,AVT_ClearWithValue,0,TAG_DONE); - - - snprintf(buffer, size - 1, "%s=%s", message->sv_Name, - message->sv_Var); - - *env = buffer; - env++; - hook->h_Data = env; - } - return 0; + if (strlen(message->sv_GDir) <= 4) + { + char **env = (char **)hook->h_Data; + uint32 size = + strlen(message->sv_Name) + 1 + message->sv_VarLen + 1 + 1; + char *buffer = (char *)IExec->AllocVecTags((uint32)size,AVT_ClearWithValue,0,TAG_DONE); + + + snprintf(buffer, size - 1, "%s=%s", message->sv_Name, + message->sv_Var); + + *env = buffer; + env++; + hook->h_Data = env; + } + return 0; } void ___makeenviron() { - struct Hook *hook = (struct Hook *)IExec->AllocSysObjectTags(ASOT_HOOK,TAG_DONE); - - if(hook) - { - char varbuf[8]; - uint32 flags = 0; - - struct DOSIFace *myIDOS = - (struct DOSIFace *)OpenInterface("dos.library", 53); - if (myIDOS) - { - uint32 size = 0; - if (myIDOS->GetVar("ABCSH_IMPORT_LOCAL", varbuf, 8, - GVF_LOCAL_ONLY) > 0) - { - flags = GVF_LOCAL_ONLY; - } - else - { - flags = GVF_GLOBAL_ONLY; - } - - hook->h_Entry = size_env; - hook->h_Data = 0; - - myIDOS->ScanVars(hook, flags, 0); - size = ((uint32)hook->h_Data) + 1; - - myenviron = (char **)IExec->AllocVecTags(size * - sizeof(char **), - AVT_ClearWithValue,0,TAG_DONE); - origenviron = myenviron; - if (!myenviron) - { - IExec->FreeSysObject(ASOT_HOOK,hook); - CloseInterface((struct Interface *)myIDOS); - return; - } - hook->h_Entry = copy_env; - hook->h_Data = myenviron; - - myIDOS->ScanVars(hook, flags, 0); - IExec->FreeSysObject(ASOT_HOOK,hook); - CloseInterface((struct Interface *)myIDOS); - } - } + struct Hook *hook = (struct Hook *)IExec->AllocSysObjectTags(ASOT_HOOK,TAG_DONE); + + if(hook) + { + char varbuf[8]; + uint32 flags = 0; + + struct DOSIFace *myIDOS = + (struct DOSIFace *)OpenInterface("dos.library", 53); + if (myIDOS) + { + uint32 size = 0; + if (myIDOS->GetVar("ABCSH_IMPORT_LOCAL", varbuf, 8, + GVF_LOCAL_ONLY) > 0) + { + flags = GVF_LOCAL_ONLY; + } + else + { + flags = GVF_GLOBAL_ONLY; + } + + hook->h_Entry = size_env; + hook->h_Data = 0; + + myIDOS->ScanVars(hook, flags, 0); + size = ((uint32)hook->h_Data) + 1; + + myenviron = (char **)IExec->AllocVecTags(size * + sizeof(char **), + AVT_ClearWithValue,0,TAG_DONE); + origenviron = myenviron; + if (!myenviron) + { + IExec->FreeSysObject(ASOT_HOOK,hook); + CloseInterface((struct Interface *)myIDOS); + return; + } + hook->h_Entry = copy_env; + hook->h_Data = myenviron; + + myIDOS->ScanVars(hook, flags, 0); + IExec->FreeSysObject(ASOT_HOOK,hook); + CloseInterface((struct Interface *)myIDOS); + } + } } void ___freeenviron() { - char **i; - /* perl might change environ, it puts it back except for ctrl-c */ - /* so restore our own copy here */ - struct DOSIFace *myIDOS = - (struct DOSIFace *)OpenInterface("dos.library", 53); - if (myIDOS) - { - myenviron = origenviron; - - if (myenviron) - { - for (i = myenviron; *i != NULL; i++) - { - IExec->FreeVec(*i); - } - IExec->FreeVec(myenviron); - myenviron = NULL; - } - CloseInterface((struct Interface *)myIDOS); - } + char **i; + /* perl might change environ, it puts it back except for ctrl-c */ + /* so restore our own copy here */ + struct DOSIFace *myIDOS = + (struct DOSIFace *)OpenInterface("dos.library", 53); + if (myIDOS) + { + myenviron = origenviron; + + if (myenviron) + { + for (i = myenviron; *i != NULL; i++) + { + IExec->FreeVec(*i); + } + IExec->FreeVec(myenviron); + myenviron = NULL; + } + CloseInterface((struct Interface *)myIDOS); + } } @@ -530,126 +530,126 @@ void ___freeenviron() int afstat(int fd, struct stat *statb) { - int result; - BPTR fh; - int mode; - BOOL input; - /* In the first instance pass it to fstat */ - // adebug("fd %ld ad %ld\n",fd,amigaos_get_file(fd)); + int result; + BPTR fh; + int mode; + BOOL input; + /* In the first instance pass it to fstat */ + // adebug("fd %ld ad %ld\n",fd,amigaos_get_file(fd)); - if ((result = fstat(fd, statb) >= 0)) - return result; + if ((result = fstat(fd, statb) >= 0)) + return result; - /* Now we've got a file descriptor but we failed to stat it */ - /* Could be a nil: or could be a std#? */ + /* Now we've got a file descriptor but we failed to stat it */ + /* Could be a nil: or could be a std#? */ - /* if get_default_file fails we had a dud fd so return failure */ + /* if get_default_file fails we had a dud fd so return failure */ #if !defined(__CLIB2__) - fh = amigaos_get_file(fd); - - /* if nil: return failure*/ - if (fh == 0) - return -1; - - /* Now compare with our process Input() Output() etc */ - /* if these were regular files sockets or pipes we had already - * succeeded */ - /* so we can guess they a character special console.... I hope */ - - struct ExamineData *data; - char name[120]; - name[0] = '\0'; - - data = IDOS->ExamineObjectTags(EX_FileHandleInput, fh, TAG_END); - if (data != NULL) - { - - IUtility->Strlcpy(name, data->Name, sizeof(name)); - - IDOS->FreeDosObject(DOS_EXAMINEDATA, data); - } - - // adebug("ad %ld '%s'\n",amigaos_get_file(fd),name); - mode = S_IFCHR; - - if (fh == IDOS->Input()) - { - input = TRUE; - SET_FLAG(mode, S_IRUSR); - SET_FLAG(mode, S_IRGRP); - SET_FLAG(mode, S_IROTH); - } - else if (fh == IDOS->Output() || fh == IDOS->ErrorOutput()) - { - input = FALSE; - SET_FLAG(mode, S_IWUSR); - SET_FLAG(mode, S_IWGRP); - SET_FLAG(mode, S_IWOTH); - } - else - { - /* we got a filehandle not handle by fstat or the above */ - /* most likely it's NIL: but lets check */ - struct ExamineData *exd = NULL; - if ((exd = IDOS->ExamineObjectTags(EX_FileHandleInput, fh, - TAG_DONE))) - { - BOOL isnil = FALSE; - if (exd->Type == - (20060920)) // Ugh yes I know nasty..... - { - isnil = TRUE; - } - IDOS->FreeDosObject(DOS_EXAMINEDATA, exd); - if (isnil) - { - /* yep we got NIL: */ - SET_FLAG(mode, S_IRUSR); - SET_FLAG(mode, S_IRGRP); - SET_FLAG(mode, S_IROTH); - SET_FLAG(mode, S_IWUSR); - SET_FLAG(mode, S_IWGRP); - SET_FLAG(mode, S_IWOTH); - } - else - { - IExec->DebugPrintF( - "unhandled filehandle in afstat()\n"); - return -1; - } - } - } - - memset(statb, 0, sizeof(statb)); - - statb->st_mode = mode; + fh = amigaos_get_file(fd); + + /* if nil: return failure*/ + if (fh == 0) + return -1; + + /* Now compare with our process Input() Output() etc */ + /* if these were regular files sockets or pipes we had already + * succeeded */ + /* so we can guess they a character special console.... I hope */ + + struct ExamineData *data; + char name[120]; + name[0] = '\0'; + + data = IDOS->ExamineObjectTags(EX_FileHandleInput, fh, TAG_END); + if (data != NULL) + { + + IUtility->Strlcpy(name, data->Name, sizeof(name)); + + IDOS->FreeDosObject(DOS_EXAMINEDATA, data); + } + + // adebug("ad %ld '%s'\n",amigaos_get_file(fd),name); + mode = S_IFCHR; + + if (fh == IDOS->Input()) + { + input = TRUE; + SET_FLAG(mode, S_IRUSR); + SET_FLAG(mode, S_IRGRP); + SET_FLAG(mode, S_IROTH); + } + else if (fh == IDOS->Output() || fh == IDOS->ErrorOutput()) + { + input = FALSE; + SET_FLAG(mode, S_IWUSR); + SET_FLAG(mode, S_IWGRP); + SET_FLAG(mode, S_IWOTH); + } + else + { + /* we got a filehandle not handle by fstat or the above */ + /* most likely it's NIL: but lets check */ + struct ExamineData *exd = NULL; + if ((exd = IDOS->ExamineObjectTags(EX_FileHandleInput, fh, + TAG_DONE))) + { + BOOL isnil = FALSE; + if (exd->Type == + (20060920)) // Ugh yes I know nasty..... + { + isnil = TRUE; + } + IDOS->FreeDosObject(DOS_EXAMINEDATA, exd); + if (isnil) + { + /* yep we got NIL: */ + SET_FLAG(mode, S_IRUSR); + SET_FLAG(mode, S_IRGRP); + SET_FLAG(mode, S_IROTH); + SET_FLAG(mode, S_IWUSR); + SET_FLAG(mode, S_IWGRP); + SET_FLAG(mode, S_IWOTH); + } + else + { + IExec->DebugPrintF( + "unhandled filehandle in afstat()\n"); + return -1; + } + } + } + + memset(statb, 0, sizeof(statb)); + + statb->st_mode = mode; #endif - return 0; + return 0; } BPTR amigaos_get_file(int fd) { - BPTR fh = (BPTR)NULL; - if (!(fh = _get_osfhandle(fd))) - { - switch (fd) - { - case 0: - fh = IDOS->Input(); - break; - case 1: - fh = IDOS->Output(); - break; - case 2: - fh = IDOS->ErrorOutput(); - break; - default: - break; - } - } - return fh; + BPTR fh = (BPTR)NULL; + if (!(fh = _get_osfhandle(fd))) + { + switch (fd) + { + case 0: + fh = IDOS->Input(); + break; + case 1: + fh = IDOS->Output(); + break; + case 2: + fh = IDOS->ErrorOutput(); + break; + default: + break; + } + } + return fh; } /*########################################################################*/ @@ -662,78 +662,78 @@ BPTR amigaos_get_file(int fd) int amigaos_flock(int fd, int oper) { - BPTR fh; - int32 success = -1; - - if (!(fh = amigaos_get_file(fd))) - { - errno = EBADF; - return -1; - } - - switch (oper) - { - case LOCK_SH: - { - if (IDOS->LockRecord(fh, LOCK_START, LOCK_LENGTH, - REC_SHARED | RECF_DOS_METHOD_ONLY, - TIMEOUT)) - { - success = 0; - } - break; - } - case LOCK_EX: - { - if (IDOS->LockRecord(fh, LOCK_START, LOCK_LENGTH, - REC_EXCLUSIVE | RECF_DOS_METHOD_ONLY, - TIMEOUT)) - { - success = 0; - } - break; - } - case LOCK_SH | LOCK_NB: - { - if (IDOS->LockRecord(fh, LOCK_START, LOCK_LENGTH, - REC_SHARED_IMMED | RECF_DOS_METHOD_ONLY, - TIMEOUT)) - { - success = 0; - } - else - { - errno = EWOULDBLOCK; - } - break; - } - case LOCK_EX | LOCK_NB: - { - if (IDOS->LockRecord(fh, LOCK_START, LOCK_LENGTH, - REC_EXCLUSIVE_IMMED | RECF_DOS_METHOD_ONLY, - TIMEOUT)) - { - success = 0; - } - else - { - errno = EWOULDBLOCK; - } - break; - } - case LOCK_UN: - { - if (IDOS->UnLockRecord(fh, LOCK_START, LOCK_LENGTH)) - { - success = 0; - } - break; - } - default: - { - errno = EINVAL; - return -1; - } - } - return success; + BPTR fh; + int32 success = -1; + + if (!(fh = amigaos_get_file(fd))) + { + errno = EBADF; + return -1; + } + + switch (oper) + { + case LOCK_SH: + { + if (IDOS->LockRecord(fh, LOCK_START, LOCK_LENGTH, + REC_SHARED | RECF_DOS_METHOD_ONLY, + TIMEOUT)) + { + success = 0; + } + break; + } + case LOCK_EX: + { + if (IDOS->LockRecord(fh, LOCK_START, LOCK_LENGTH, + REC_EXCLUSIVE | RECF_DOS_METHOD_ONLY, + TIMEOUT)) + { + success = 0; + } + break; + } + case LOCK_SH | LOCK_NB: + { + if (IDOS->LockRecord(fh, LOCK_START, LOCK_LENGTH, + REC_SHARED_IMMED | RECF_DOS_METHOD_ONLY, + TIMEOUT)) + { + success = 0; + } + else + { + errno = EWOULDBLOCK; + } + break; + } + case LOCK_EX | LOCK_NB: + { + if (IDOS->LockRecord(fh, LOCK_START, LOCK_LENGTH, + REC_EXCLUSIVE_IMMED | RECF_DOS_METHOD_ONLY, + TIMEOUT)) + { + success = 0; + } + else + { + errno = EWOULDBLOCK; + } + break; + } + case LOCK_UN: + { + if (IDOS->UnLockRecord(fh, LOCK_START, LOCK_LENGTH)) + { + success = 0; + } + break; + } + default: + { + errno = EINVAL; + return -1; + } + } + return success; } diff --git a/autodoc.pl b/autodoc.pl index 64491e751710..a9f6f6bf67d4 100644 --- a/autodoc.pl +++ b/autodoc.pl @@ -66,9 +66,9 @@ use strict; use warnings; -# 80 column terminal - 1 for pager adding a column; -7 for nroff -# indent; -my $max_width = 80 - 1 - 7; +# 80 column terminal - 2 for pager adding 2 columns; -4 for indent for +# non-heading lines; +my $max_width = 80 - 2 - 4; if (@ARGV) { my $workdir = shift; @@ -139,7 +139,6 @@ my $pad_scn = 'Pad Data Structures'; my $password_scn = 'Password and Group access'; my $paths_scn = 'Paths to system commands'; -my $intrpvar_scn = 'Per-Interpreter Variables'; my $prototypes_scn = 'Prototype information'; my $regexp_scn = 'REGEXP Functions'; my $signals_scn = 'Signals'; @@ -301,7 +300,6 @@ $pad_scn => {}, $password_scn => {}, $paths_scn => {}, - $intrpvar_scn => {}, $prototypes_scn => {}, $regexp_scn => {}, $signals_scn => {}, diff --git a/av.c b/av.c index ed67df19de99..ff0cb2340c4d 100644 --- a/av.c +++ b/av.c @@ -28,22 +28,22 @@ Perl_av_reify(pTHX_ AV *av) assert(SvTYPE(av) == SVt_PVAV); if (AvREAL(av)) - return; + return; #ifdef DEBUGGING if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied)) - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array"); + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array"); #endif key = AvMAX(av) + 1; while (key > AvFILLp(av) + 1) - AvARRAY(av)[--key] = NULL; + AvARRAY(av)[--key] = NULL; while (key) { - SV * const sv = AvARRAY(av)[--key]; - if (sv != &PL_sv_undef) - SvREFCNT_inc_simple_void(sv); + SV * const sv = AvARRAY(av)[--key]; + if (sv != &PL_sv_undef) + SvREFCNT_inc_simple_void(sv); } key = AvARRAY(av) - AvALLOC(av); while (key) - AvALLOC(av)[--key] = NULL; + AvALLOC(av)[--key] = NULL; AvREIFY_off(av); AvREAL_on(av); } @@ -72,7 +72,7 @@ Perl_av_extend(pTHX_ AV *av, SSize_t key) mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied); if (mg) { - SV *arg1 = sv_newmortal(); + SV *arg1 = sv_newmortal(); /* NOTE: the API for av_extend() is NOT the same as the tie method EXTEND. * * The C function takes an *index* (assumes 0 indexed arrays) and ensures @@ -82,10 +82,10 @@ Perl_av_extend(pTHX_ AV *av, SSize_t key) * is at least that many elements large. Thus we have to +1 the key when * we call the tied method. */ - sv_setiv(arg1, (IV)(key + 1)); - Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(EXTEND), G_DISCARD, 1, - arg1); - return; + sv_setiv(arg1, (IV)(key + 1)); + Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(EXTEND), G_DISCARD, 1, + arg1); + return; } av_extend_guts(av,key,&AvMAX(av),&AvALLOC(av),&AvARRAY(av)); } @@ -225,23 +225,23 @@ S_adjust_index(pTHX_ AV *av, const MAGIC *mg, SSize_t *keyp) { bool adjust_index = 1; if (mg) { - /* Handle negative array indices 20020222 MJD */ - SV * const ref = SvTIED_obj(MUTABLE_SV(av), mg); - SvGETMAGIC(ref); - if (SvROK(ref) && SvOBJECT(SvRV(ref))) { - SV * const * const negative_indices_glob = - hv_fetchs(SvSTASH(SvRV(ref)), NEGATIVE_INDICES_VAR, 0); - - if (negative_indices_glob && isGV(*negative_indices_glob) - && SvTRUE(GvSV(*negative_indices_glob))) - adjust_index = 0; - } + /* Handle negative array indices 20020222 MJD */ + SV * const ref = SvTIED_obj(MUTABLE_SV(av), mg); + SvGETMAGIC(ref); + if (SvROK(ref) && SvOBJECT(SvRV(ref))) { + SV * const * const negative_indices_glob = + hv_fetchs(SvSTASH(SvRV(ref)), NEGATIVE_INDICES_VAR, 0); + + if (negative_indices_glob && isGV(*negative_indices_glob) + && SvTRUE(GvSV(*negative_indices_glob))) + adjust_index = 0; + } } if (adjust_index) { - *keyp += AvFILL(av) + 1; - if (*keyp < 0) - return FALSE; + *keyp += AvFILL(av) + 1; + if (*keyp < 0) + return FALSE; } return TRUE; } @@ -257,22 +257,22 @@ Perl_av_fetch(pTHX_ AV *av, SSize_t key, I32 lval) if (UNLIKELY(SvRMAGICAL(av))) { const MAGIC * const tied_magic - = mg_find((const SV *)av, PERL_MAGIC_tied); + = mg_find((const SV *)av, PERL_MAGIC_tied); if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) { - SV *sv; - if (key < 0) { - if (!S_adjust_index(aTHX_ av, tied_magic, &key)) - return NULL; - } + SV *sv; + if (key < 0) { + if (!S_adjust_index(aTHX_ av, tied_magic, &key)) + return NULL; + } sv = sv_newmortal(); - sv_upgrade(sv, SVt_PVLV); - mg_copy(MUTABLE_SV(av), sv, 0, key); - if (!tied_magic) /* for regdata, force leavesub to make copies */ - SvTEMP_off(sv); - LvTYPE(sv) = 't'; - LvTARG(sv) = sv; /* fake (SV**) */ - return &(LvTARG(sv)); + sv_upgrade(sv, SVt_PVLV); + mg_copy(MUTABLE_SV(av), sv, 0, key); + if (!tied_magic) /* for regdata, force leavesub to make copies */ + SvTEMP_off(sv); + LvTYPE(sv) = 't'; + LvTARG(sv) = sv; /* fake (SV**) */ + return &(LvTARG(sv)); } } @@ -283,14 +283,14 @@ Perl_av_fetch(pTHX_ AV *av, SSize_t key, I32 lval) /* the cast from SSize_t to Size_t allows both (key < 0) and (key >= size) * to be tested as a single condition */ if ((Size_t)key >= (Size_t)size) { - if (UNLIKELY(neg)) - return NULL; + if (UNLIKELY(neg)) + return NULL; goto emptyness; } if (!AvARRAY(av)[key]) { emptyness: - return lval ? av_store(av,key,newSV(0)) : NULL; + return lval ? av_store(av,key,newSV(0)) : NULL; } return &AvARRAY(av)[key]; @@ -334,59 +334,59 @@ Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val) const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied); if (tied_magic) { if (key < 0) { - if (!S_adjust_index(aTHX_ av, tied_magic, &key)) + if (!S_adjust_index(aTHX_ av, tied_magic, &key)) return 0; } - if (val) { - mg_copy(MUTABLE_SV(av), val, 0, key); - } - return NULL; + if (val) { + mg_copy(MUTABLE_SV(av), val, 0, key); + } + return NULL; } } if (key < 0) { - key += AvFILL(av) + 1; - if (key < 0) - return NULL; + key += AvFILL(av) + 1; + if (key < 0) + return NULL; } if (SvREADONLY(av) && key >= AvFILL(av)) - Perl_croak_no_modify(); + Perl_croak_no_modify(); if (!AvREAL(av) && AvREIFY(av)) - av_reify(av); + av_reify(av); if (key > AvMAX(av)) - av_extend(av,key); + av_extend(av,key); ary = AvARRAY(av); if (AvFILLp(av) < key) { - if (!AvREAL(av)) { - if (av == PL_curstack && key > PL_stack_sp - PL_stack_base) - PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */ - do { - ary[++AvFILLp(av)] = NULL; - } while (AvFILLp(av) < key); - } - AvFILLp(av) = key; + if (!AvREAL(av)) { + if (av == PL_curstack && key > PL_stack_sp - PL_stack_base) + PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */ + do { + ary[++AvFILLp(av)] = NULL; + } while (AvFILLp(av) < key); + } + AvFILLp(av) = key; } else if (AvREAL(av)) - SvREFCNT_dec(ary[key]); + SvREFCNT_dec(ary[key]); ary[key] = val; if (SvSMAGICAL(av)) { - const MAGIC *mg = SvMAGIC(av); - bool set = TRUE; - for (; mg; mg = mg->mg_moremagic) { - if (!isUPPER(mg->mg_type)) continue; - if (val) { - sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key); - } - if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) { - PL_delaymagic |= DM_ARRAY_ISA; - set = FALSE; - } - } - if (set) - mg_set(MUTABLE_SV(av)); + const MAGIC *mg = SvMAGIC(av); + bool set = TRUE; + for (; mg; mg = mg->mg_moremagic) { + if (!isUPPER(mg->mg_type)) continue; + if (val) { + sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key); + } + if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) { + PL_delaymagic |= DM_ARRAY_ISA; + set = FALSE; + } + } + if (set) + mg_set(MUTABLE_SV(av)); } return &ary[key]; } @@ -416,29 +416,29 @@ Perl_av_make(pTHX_ SSize_t size, SV **strp) SSize_t i; SSize_t orig_ix; - Newx(ary,size,SV*); - AvALLOC(av) = ary; - AvARRAY(av) = ary; - AvMAX(av) = size - 1; + Newx(ary,size,SV*); + AvALLOC(av) = ary; + AvARRAY(av) = ary; + AvMAX(av) = size - 1; /* avoid av being leaked if croak when calling magic below */ EXTEND_MORTAL(1); PL_tmps_stack[++PL_tmps_ix] = (SV*)av; orig_ix = PL_tmps_ix; - for (i = 0; i < size; i++) { - assert (*strp); + for (i = 0; i < size; i++) { + assert (*strp); - /* Don't let sv_setsv swipe, since our source array might - have multiple references to the same temp scalar (e.g. - from a list slice) */ + /* Don't let sv_setsv swipe, since our source array might + have multiple references to the same temp scalar (e.g. + from a list slice) */ - SvGETMAGIC(*strp); /* before newSV, in case it dies */ - AvFILLp(av)++; - ary[i] = newSV(0); - sv_setsv_flags(ary[i], *strp, - SV_DO_COW_SVSETSV|SV_NOSTEAL); - strp++; - } + SvGETMAGIC(*strp); /* before newSV, in case it dies */ + AvFILLp(av)++; + ary[i] = newSV(0); + sv_setsv_flags(ary[i], *strp, + SV_DO_COW_SVSETSV|SV_NOSTEAL); + strp++; + } /* disarm av's leak guard */ if (LIKELY(PL_tmps_ix == orig_ix)) PL_tmps_ix--; @@ -451,7 +451,7 @@ Perl_av_make(pTHX_ SSize_t size, SV **strp) /* =for apidoc av_clear -Frees the all the elements of an array, leaving it empty. +Frees all the elements of an array, leaving it empty. The XS equivalent of C<@array = ()>. See also L. Note that it is possible that the actions of a destructor called directly @@ -476,46 +476,46 @@ Perl_av_clear(pTHX_ AV *av) #ifdef DEBUGGING if (SvREFCNT(av) == 0) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array"); + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array"); } #endif if (SvREADONLY(av)) - Perl_croak_no_modify(); + Perl_croak_no_modify(); /* Give any tie a chance to cleanup first */ if (SvRMAGICAL(av)) { - const MAGIC* const mg = SvMAGIC(av); - if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa) - PL_delaymagic |= DM_ARRAY_ISA; + const MAGIC* const mg = SvMAGIC(av); + if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa) + PL_delaymagic |= DM_ARRAY_ISA; else - mg_clear(MUTABLE_SV(av)); + mg_clear(MUTABLE_SV(av)); } if (AvMAX(av) < 0) - return; + return; if ((real = cBOOL(AvREAL(av)))) { - SV** const ary = AvARRAY(av); - SSize_t index = AvFILLp(av) + 1; + SV** const ary = AvARRAY(av); + SSize_t index = AvFILLp(av) + 1; /* avoid av being freed when calling destructors below */ EXTEND_MORTAL(1); PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av); orig_ix = PL_tmps_ix; - while (index) { - SV * const sv = ary[--index]; - /* undef the slot before freeing the value, because a - * destructor might try to modify this array */ - ary[index] = NULL; - SvREFCNT_dec(sv); - } + while (index) { + SV * const sv = ary[--index]; + /* undef the slot before freeing the value, because a + * destructor might try to modify this array */ + ary[index] = NULL; + SvREFCNT_dec(sv); + } } extra = AvARRAY(av) - AvALLOC(av); if (extra) { - AvMAX(av) += extra; - AvARRAY(av) = AvALLOC(av); + AvMAX(av) += extra; + AvARRAY(av) = AvALLOC(av); } AvFILLp(av) = -1; if (real) { @@ -553,19 +553,19 @@ Perl_av_undef(pTHX_ AV *av) /* Give any tie a chance to cleanup first */ if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied)) - av_fill(av, -1); + av_fill(av, -1); real = cBOOL(AvREAL(av)); if (real) { - SSize_t key = AvFILLp(av) + 1; + SSize_t key = AvFILLp(av) + 1; /* avoid av being freed when calling destructors below */ EXTEND_MORTAL(1); PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av); orig_ix = PL_tmps_ix; - while (key) - SvREFCNT_dec(AvARRAY(av)[--key]); + while (key) + SvREFCNT_dec(AvARRAY(av)[--key]); } Safefree(AvALLOC(av)); @@ -600,7 +600,7 @@ Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val) PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH; if (!*avp) - *avp = newAV(); + *avp = newAV(); av_push(*avp, val); } @@ -624,12 +624,12 @@ Perl_av_push(pTHX_ AV *av, SV *val) assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) - Perl_croak_no_modify(); + Perl_croak_no_modify(); if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { - Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(PUSH), G_DISCARD, 1, - val); - return; + Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(PUSH), G_DISCARD, 1, + val); + return; } av_store(av,AvFILLp(av)+1,val); } @@ -656,19 +656,19 @@ Perl_av_pop(pTHX_ AV *av) assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) - Perl_croak_no_modify(); + Perl_croak_no_modify(); if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { - retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(POP), 0, 0); - if (retval) - retval = newSVsv(retval); - return retval; + retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(POP), 0, 0); + if (retval) + retval = newSVsv(retval); + return retval; } if (AvFILL(av) < 0) - return &PL_sv_undef; + return &PL_sv_undef; retval = AvARRAY(av)[AvFILLp(av)]; AvARRAY(av)[AvFILLp(av)--] = NULL; if (SvSMAGICAL(av)) - mg_set(MUTABLE_SV(av)); + mg_set(MUTABLE_SV(av)); return retval ? retval : &PL_sv_undef; } @@ -689,7 +689,7 @@ Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val) PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE; if (!*avp) - *avp = newAV(); + *avp = newAV(); av_unshift(*avp, 1); return av_store(*avp, 0, val); } @@ -715,45 +715,45 @@ Perl_av_unshift(pTHX_ AV *av, SSize_t num) assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) - Perl_croak_no_modify(); + Perl_croak_no_modify(); if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { - Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT), - G_DISCARD | G_UNDEF_FILL, num); - return; + Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT), + G_DISCARD | G_UNDEF_FILL, num); + return; } if (num <= 0) return; if (!AvREAL(av) && AvREIFY(av)) - av_reify(av); + av_reify(av); i = AvARRAY(av) - AvALLOC(av); if (i) { - if (i > num) - i = num; - num -= i; + if (i > num) + i = num; + num -= i; - AvMAX(av) += i; - AvFILLp(av) += i; - AvARRAY(av) = AvARRAY(av) - i; + AvMAX(av) += i; + AvFILLp(av) += i; + AvARRAY(av) = AvARRAY(av) - i; } if (num) { - SV **ary; - const SSize_t i = AvFILLp(av); - /* Create extra elements */ - const SSize_t slide = i > 0 ? i : 0; - num += slide; - av_extend(av, i + num); - AvFILLp(av) += num; - ary = AvARRAY(av); - Move(ary, ary + num, i + 1, SV*); - do { - ary[--num] = NULL; - } while (num); - /* Make extra elements into a buffer */ - AvMAX(av) -= slide; - AvFILLp(av) -= slide; - AvARRAY(av) = AvARRAY(av) + slide; + SV **ary; + const SSize_t i = AvFILLp(av); + /* Create extra elements */ + const SSize_t slide = i > 0 ? i : 0; + num += slide; + av_extend(av, i + num); + AvFILLp(av) += num; + ary = AvARRAY(av); + Move(ary, ary + num, i + 1, SV*); + do { + ary[--num] = NULL; + } while (num); + /* Make extra elements into a buffer */ + AvMAX(av) -= slide; + AvFILLp(av) -= slide; + AvARRAY(av) = AvARRAY(av) + slide; } } @@ -779,23 +779,23 @@ Perl_av_shift(pTHX_ AV *av) assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) - Perl_croak_no_modify(); + Perl_croak_no_modify(); if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { - retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(SHIFT), 0, 0); - if (retval) - retval = newSVsv(retval); - return retval; + retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(SHIFT), 0, 0); + if (retval) + retval = newSVsv(retval); + return retval; } if (AvFILL(av) < 0) return &PL_sv_undef; retval = *AvARRAY(av); if (AvREAL(av)) - *AvARRAY(av) = NULL; + *AvARRAY(av) = NULL; AvARRAY(av) = AvARRAY(av) + 1; AvMAX(av)--; AvFILLp(av)--; if (SvSMAGICAL(av)) - mg_set(MUTABLE_SV(av)); + mg_set(MUTABLE_SV(av)); return retval ? retval : &PL_sv_undef; } @@ -856,35 +856,35 @@ Perl_av_fill(pTHX_ AV *av, SSize_t fill) assert(SvTYPE(av) == SVt_PVAV); if (fill < 0) - fill = -1; + fill = -1; if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { - SV *arg1 = sv_newmortal(); - sv_setiv(arg1, (IV)(fill + 1)); - Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD, - 1, arg1); - return; + SV *arg1 = sv_newmortal(); + sv_setiv(arg1, (IV)(fill + 1)); + Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD, + 1, arg1); + return; } if (fill <= AvMAX(av)) { - SSize_t key = AvFILLp(av); - SV** const ary = AvARRAY(av); - - if (AvREAL(av)) { - while (key > fill) { - SvREFCNT_dec(ary[key]); - ary[key--] = NULL; - } - } - else { - while (key < fill) - ary[++key] = NULL; - } - - AvFILLp(av) = fill; - if (SvSMAGICAL(av)) - mg_set(MUTABLE_SV(av)); + SSize_t key = AvFILLp(av); + SV** const ary = AvARRAY(av); + + if (AvREAL(av)) { + while (key > fill) { + SvREFCNT_dec(ary[key]); + ary[key--] = NULL; + } + } + else { + while (key < fill) + ary[++key] = NULL; + } + + AvFILLp(av) = fill; + if (SvSMAGICAL(av)) + mg_set(MUTABLE_SV(av)); } else - (void)av_store(av,fill,NULL); + (void)av_store(av,fill,NULL); } /* @@ -909,16 +909,16 @@ Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags) assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) - Perl_croak_no_modify(); + Perl_croak_no_modify(); if (SvRMAGICAL(av)) { const MAGIC * const tied_magic - = mg_find((const SV *)av, PERL_MAGIC_tied); + = mg_find((const SV *)av, PERL_MAGIC_tied); if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) { SV **svp; if (key < 0) { - if (!S_adjust_index(aTHX_ av, tied_magic, &key)) - return NULL; + if (!S_adjust_index(aTHX_ av, tied_magic, &key)) + return NULL; } svp = av_fetch(av, key, TRUE); if (svp) { @@ -928,39 +928,39 @@ Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags) sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */ return sv; } - return NULL; + return NULL; } } } if (key < 0) { - key += AvFILL(av) + 1; - if (key < 0) - return NULL; + key += AvFILL(av) + 1; + if (key < 0) + return NULL; } if (key > AvFILLp(av)) - return NULL; + return NULL; else { - if (!AvREAL(av) && AvREIFY(av)) - av_reify(av); - sv = AvARRAY(av)[key]; - AvARRAY(av)[key] = NULL; - if (key == AvFILLp(av)) { - do { - AvFILLp(av)--; - } while (--key >= 0 && !AvARRAY(av)[key]); - } - if (SvSMAGICAL(av)) - mg_set(MUTABLE_SV(av)); + if (!AvREAL(av) && AvREIFY(av)) + av_reify(av); + sv = AvARRAY(av)[key]; + AvARRAY(av)[key] = NULL; + if (key == AvFILLp(av)) { + do { + AvFILLp(av)--; + } while (--key >= 0 && !AvARRAY(av)[key]); + } + if (SvSMAGICAL(av)) + mg_set(MUTABLE_SV(av)); } if(sv != NULL) { - if (flags & G_DISCARD) { - SvREFCNT_dec_NN(sv); - return NULL; - } - else if (AvREAL(av)) - sv_2mortal(sv); + if (flags & G_DISCARD) { + SvREFCNT_dec_NN(sv); + return NULL; + } + else if (AvREAL(av)) + sv_2mortal(sv); } return sv; } @@ -985,14 +985,14 @@ Perl_av_exists(pTHX_ AV *av, SSize_t key) if (SvRMAGICAL(av)) { const MAGIC * const tied_magic - = mg_find((const SV *)av, PERL_MAGIC_tied); + = mg_find((const SV *)av, PERL_MAGIC_tied); const MAGIC * const regdata_magic = mg_find((const SV *)av, PERL_MAGIC_regdata); if (tied_magic || regdata_magic) { MAGIC *mg; /* Handle negative array indices 20020222 MJD */ if (key < 0) { - if (!S_adjust_index(aTHX_ av, tied_magic, &key)) + if (!S_adjust_index(aTHX_ av, tied_magic, &key)) return FALSE; } @@ -1002,36 +1002,36 @@ Perl_av_exists(pTHX_ AV *av, SSize_t key) else return FALSE; } - { - SV * const sv = sv_newmortal(); - mg_copy(MUTABLE_SV(av), sv, 0, key); - mg = mg_find(sv, PERL_MAGIC_tiedelem); - if (mg) { - magic_existspack(sv, mg); - { - I32 retbool = SvTRUE_nomg_NN(sv); - return cBOOL(retbool); - } - } - } + { + SV * const sv = sv_newmortal(); + mg_copy(MUTABLE_SV(av), sv, 0, key); + mg = mg_find(sv, PERL_MAGIC_tiedelem); + if (mg) { + magic_existspack(sv, mg); + { + I32 retbool = SvTRUE_nomg_NN(sv); + return cBOOL(retbool); + } + } + } } } if (key < 0) { - key += AvFILL(av) + 1; - if (key < 0) - return FALSE; + key += AvFILL(av) + 1; + if (key < 0) + return FALSE; } if (key <= AvFILLp(av) && AvARRAY(av)[key]) { - if (SvSMAGICAL(AvARRAY(av)[key]) - && mg_find(AvARRAY(av)[key], PERL_MAGIC_nonelem)) - return FALSE; - return TRUE; + if (SvSMAGICAL(AvARRAY(av)[key]) + && mg_find(AvARRAY(av)[key], PERL_MAGIC_nonelem)) + return FALSE; + return TRUE; } else - return FALSE; + return FALSE; } static MAGIC * @@ -1044,11 +1044,11 @@ S_get_aux_mg(pTHX_ AV *av) { mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p); if (!mg) { - mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p, - &PL_vtbl_arylen_p, 0, 0); - assert(mg); - /* sv_magicext won't set this for us because we pass in a NULL obj */ - mg->mg_flags |= MGf_REFCOUNTED; + mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p, + &PL_vtbl_arylen_p, 0, 0); + assert(mg); + /* sv_magicext won't set this for us because we pass in a NULL obj */ + mg->mg_flags |= MGf_REFCOUNTED; } return mg; } @@ -1071,15 +1071,15 @@ Perl_av_iter_p(pTHX_ AV *av) { assert(SvTYPE(av) == SVt_PVAV); if (sizeof(IV) == sizeof(SSize_t)) { - return (IV *)&(mg->mg_len); + return (IV *)&(mg->mg_len); } else { - if (!mg->mg_ptr) { - IV *temp; - mg->mg_len = IVSIZE; - Newxz(temp, 1, IV); - mg->mg_ptr = (char *) temp; - } - return (IV *)mg->mg_ptr; + if (!mg->mg_ptr) { + IV *temp; + mg->mg_len = IVSIZE; + Newxz(temp, 1, IV); + mg->mg_ptr = (char *) temp; + } + return (IV *)mg->mg_ptr; } } @@ -1088,7 +1088,7 @@ Perl_av_nonelem(pTHX_ AV *av, SSize_t ix) { SV * const sv = newSV(0); PERL_ARGS_ASSERT_AV_NONELEM; if (!av_store(av,ix,sv)) - return sv_2mortal(sv); /* has tie magic */ + return sv_2mortal(sv); /* has tie magic */ sv_magic(sv, NULL, PERL_MAGIC_nonelem, NULL, 0); return sv; } diff --git a/av.h b/av.h index 6903db6dbf45..41cb6fefd896 100644 --- a/av.h +++ b/av.h @@ -83,7 +83,7 @@ If all you need is to look up an array element, then prefer C. #define AvREALISH(av) (SvFLAGS(av) & (SVpav_REAL|SVpav_REIFY)) #define AvFILL(av) ((SvRMAGICAL((const SV *) (av))) \ - ? mg_size(MUTABLE_SV(av)) : AvFILLp(av)) + ? mg_size(MUTABLE_SV(av)) : AvFILLp(av)) #define av_top_index(av) AvFILL(av) #define av_tindex(av) av_top_index(av) diff --git a/charclass_invlists.h b/charclass_invlists.h index 42dd659a5a69..4493ae9f3953 100644 --- a/charclass_invlists.h +++ b/charclass_invlists.h @@ -419902,7 +419902,7 @@ static const U8 WB_table[23][23] = { * 5b7c14380d5cceeaffcfbc18db1ed936391d2af2d51f5a41f1a17b692c77e59b lib/unicore/extracted/DNumValues.txt * ee0dd174fd5b158d82dfea95d7d822ca0bfcd490182669353dca3ab39a8ee807 lib/unicore/mktables * 50b85a67451145545a65cea370dab8d3444fbfe07e9c34cef560c5b7da9d3eef lib/unicore/version - * 2680b9254eb236c5c090f11b149605043e8c8433661b96efc4a42fb4709342a5 regen/charset_translations.pl - * 6bbad21de0848e0236b02f34f5fa0edd3cdae9ba8173cc9469a5513936b9e728 regen/mk_PL_charclass.pl - * b1d799ef06236277bdbe06eea253a83a7d39f161ec51f4d4bf5e9b5b5a57f251 regen/mk_invlists.pl + * 24120d5e0c9685c442c93bc1dbea9b85ef973bf8e9474baf0e55b160c288226b regen/charset_translations.pl + * 9f74e34278592ddf58fef8c32236b294e94ea5e12627f911f4563e8040a07292 regen/mk_PL_charclass.pl + * 5eb9e6c825496cc9aa705e3cd33bc6d5a9657dcca16d4c4acc4824ff30b34a26 regen/mk_invlists.pl * ex: set ro: */ diff --git a/config_h.SH b/config_h.SH index fb3fba2cf5a3..dceb480e1fde 100755 --- a/config_h.SH +++ b/config_h.SH @@ -3603,7 +3603,7 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$default_inc_excludes_dot DEFAULT_INC_EXCLUDES_DOT /**/ -/* USE_STRICT_BY_DEFAULT +/* USE_STRICT_BY_DEFAULT: * This symbol, if defined, enables additional defaults. * At this time it only enables implicit strict by default. */ @@ -4575,6 +4575,19 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un #$d_endservent_r HAS_ENDSERVENT_R /**/ #define ENDSERVENT_R_PROTO $endservent_r_proto /**/ +/* GETENV_PRESERVES_OTHER_THREAD: + * This symbol, if defined, indicates that the getenv system call doesn't + * zap the static buffer of getenv() in a different thread. + * + * The typical getenv() implementation will return a pointer to the proper + * position in **environ. But some may instead copy them to a static + * buffer in getenv(). If there is a per-thread instance of that buffer, + * or the return points to **environ, then a many-reader/1-writer mutex + * will work; otherwise an exclusive locking mutex is required to prevent + * races. + */ +#$d_getenv_preserves_other_thread GETENV_PRESERVES_OTHER_THREAD /**/ + /* HAS_GETGRENT_R: * This symbol, if defined, indicates that the getgrent_r routine * is available to getgrent re-entrantly. diff --git a/configpm b/configpm index 0451f2de272c..94a477803733 100755 --- a/configpm +++ b/configpm @@ -856,7 +856,7 @@ tie %%Config, 'Config', { ENDOFTIE -open(CONFIG_POD, '>', $Config_POD) or die "Can't open $Config_POD: $!"; +open(CONFIG_POD, '>:raw', $Config_POD) or die "Can't open $Config_POD: $!"; print CONFIG_POD <<'ENDOFTAIL'; =head1 NAME diff --git a/configure.com b/configure.com index e7ea8b9fcb69..77ce7ae0866d 100644 --- a/configure.com +++ b/configure.com @@ -5603,6 +5603,7 @@ $ THEN $ vms_cc_type="decc" $ ENDIF $ d_faststdio="define" +$ d_getenv_preserves_other_thread="define" $ d_locconv="define" $ d_mblen="define" $ d_mbstowcs="define" @@ -6398,6 +6399,7 @@ $ WC "d_nextafter='" + d_nextafter + "'" $ WC "d_nexttoward='" + d_nexttoward + "'" $ WC "d_nice='define'" $ WC "d_nl_langinfo='" + d_nl_langinfo + "'" +$ WC "d_getenv_preserves_other_thread='" + d_getenv_preserves_other_thread + "'" $ WC "d_nv_preserves_uv='" + d_nv_preserves_uv + "'" $ WC "nv_overflows_integers_at='" + nv_overflows_integers_at + "'" $ WC "nv_preserves_uv_bits='" + nv_preserves_uv_bits + "'" diff --git a/cop.h b/cop.h index b61bb30174b4..7b8a14f0c83a 100644 --- a/cop.h +++ b/cop.h @@ -299,7 +299,7 @@ be stored with referential integrity, but will be coerced to strings. Perl_refcounted_he_new_pvn(aTHX_ cophh, keypv, keylen, hash, value, flags) /* -=for apidoc Amx|COPHH *|cophh_store_pvs|const COPHH *cophh|"key"|SV *value|U32 flags +=for apidoc Amx|COPHH *|cophh_store_pvs|COPHH *cophh|"key"|SV *value|U32 flags Like L, but takes a literal string instead of a string/length pair, and no precomputed hash. @@ -311,7 +311,7 @@ of a string/length pair, and no precomputed hash. Perl_refcounted_he_new_pvn(aTHX_ cophh, STR_WITH_LEN(key), 0, value, flags) /* -=for apidoc Amx|COPHH *|cophh_store_pv|const COPHH *cophh|const char *key|U32 hash|SV *value|U32 flags +=for apidoc Amx|COPHH *|cophh_store_pv|COPHH *cophh|const char *key|U32 hash|SV *value|U32 flags Like L, but takes a nul-terminated string instead of a string/length pair. @@ -323,7 +323,7 @@ a string/length pair. Perl_refcounted_he_new_pv(aTHX_ cophh, key, hash, value, flags) /* -=for apidoc Amx|COPHH *|cophh_store_sv|const COPHH *cophh|SV *key|U32 hash|SV *value|U32 flags +=for apidoc Amx|COPHH *|cophh_store_sv|COPHH *cophh|SV *key|U32 hash|SV *value|U32 flags Like L, but takes a Perl scalar instead of a string/length pair. @@ -356,7 +356,7 @@ hash of the key string, or zero if it has not been precomputed. (SV *)NULL, flags) /* -=for apidoc Amx|COPHH *|cophh_delete_pvs|const COPHH *cophh|"key"|U32 flags +=for apidoc Amx|COPHH *|cophh_delete_pvs|COPHH *cophh|"key"|U32 flags Like L, but takes a literal string instead of a string/length pair, and no precomputed hash. @@ -369,7 +369,7 @@ of a string/length pair, and no precomputed hash. (SV *)NULL, flags) /* -=for apidoc Amx|COPHH *|cophh_delete_pv|const COPHH *cophh|const char *key|U32 hash|U32 flags +=for apidoc Amx|COPHH *|cophh_delete_pv|COPHH *cophh|char *key|U32 hash|U32 flags Like L, but takes a nul-terminated string instead of a string/length pair. @@ -381,7 +381,7 @@ a string/length pair. Perl_refcounted_he_new_pv(aTHX_ cophh, key, hash, (SV *)NULL, flags) /* -=for apidoc Amx|COPHH *|cophh_delete_sv|const COPHH *cophh|SV *key|U32 hash|U32 flags +=for apidoc Amx|COPHH *|cophh_delete_sv|COPHH *cophh|SV *key|U32 hash|U32 flags Like L, but takes a Perl scalar instead of a string/length pair. @@ -423,6 +423,49 @@ struct cop { U32 cop_features; }; +/* +=for apidoc Am|const char *|CopFILE|const COP * c +Returns the name of the file associated with the C C + +=for apidoc Am|STRLEN|CopLINE|const COP * c +Returns the line number in the source code associated with the C C + +=for apidoc Am|AV *|CopFILEAV|const COP * c +Returns the AV associated with the C C + +=for apidoc Am|SV *|CopFILESV|const COP * c +Returns the SV associated with the C C + +=for apidoc Am|void|CopFILE_set|COP * c|const char * pv +Makes C the name of the file associated with the C C + +=for apidoc Am|GV *|CopFILEGV|const COP * c +Returns the GV associated with the C C + +=for apidoc CopFILEGV_set +Available only on unthreaded perls. Makes C the name of the file +associated with the C C + +=for apidoc Am|HV *|CopSTASH|const COP * c +Returns the stash associated with C. + +=for apidoc Am|bool|CopSTASH_eq|const COP * c|const HV * hv +Returns a boolean as to whether or not C is the stash associated with C. + +=for apidoc Am|bool|CopSTASH_set|COP * c|HV * hv +Set the stash associated with C to C. + +=for apidoc Am|char *|CopSTASHPV|const COP * c +Returns the package name of the stash associated with C, or C if no +associated stash + +=for apidoc Am|void|CopSTASHPV_set|COP * c|const char * pv +Set the package name of the stash associated with C, to the NUL-terminated C +string C

, creating the package if necessary. + +=cut +*/ + #ifdef USE_ITHREADS # define CopFILE(c) ((c)->cop_file) # define CopFILEGV(c) (CopFILE(c) \ @@ -818,6 +861,9 @@ struct subst { void * sbu_rxres; REGEXP * sbu_rx; }; + +#ifdef PERL_CORE + #define sb_iters cx_u.cx_subst.sbu_iters #define sb_maxiters cx_u.cx_subst.sbu_maxiters #define sb_rflags cx_u.cx_subst.sbu_rflags @@ -831,7 +877,6 @@ struct subst { #define sb_rxres cx_u.cx_subst.sbu_rxres #define sb_rx cx_u.cx_subst.sbu_rx -#ifdef PERL_CORE # define CX_PUSHSUBST(cx) CXINC, cx = CX_CUR(), \ cx->blk_oldsaveix = oldsave, \ cx->sb_iters = iters, \ @@ -895,7 +940,7 @@ struct context { or plain block { ...; } */ #define CXt_SUB 9 #define CXt_FORMAT 10 -#define CXt_EVAL 11 +#define CXt_EVAL 11 /* eval'', eval{}, try{} */ #define CXt_SUBST 12 /* SUBST doesn't feature in all switch statements. */ @@ -908,7 +953,8 @@ struct context { /* private flags for CXt_EVAL */ #define CXp_REAL 0x20 /* truly eval'', not a lookalike */ -#define CXp_TRYBLOCK 0x40 /* eval{}, not eval'' or similar */ +#define CXp_EVALBLOCK 0x40 /* eval{}, not eval'' or similar */ +#define CXp_TRY 0x80 /* try {} block */ /* private flags for CXt_LOOP */ @@ -930,11 +976,17 @@ struct context { #define CxMULTICALL(c) ((c)->cx_type & CXp_MULTICALL) #define CxREALEVAL(c) (((c)->cx_type & (CXTYPEMASK|CXp_REAL)) \ == (CXt_EVAL|CXp_REAL)) -#define CxTRYBLOCK(c) (((c)->cx_type & (CXTYPEMASK|CXp_TRYBLOCK)) \ - == (CXt_EVAL|CXp_TRYBLOCK)) +#define CxEVALBLOCK(c) (((c)->cx_type & (CXTYPEMASK|CXp_EVALBLOCK)) \ + == (CXt_EVAL|CXp_EVALBLOCK)) +#define CxTRY(c) (((c)->cx_type & (CXTYPEMASK|CXp_TRY)) \ + == (CXt_EVAL|CXp_TRY)) #define CxFOREACH(c) ( CxTYPE(cx) >= CXt_LOOP_ARY \ && CxTYPE(cx) <= CXt_LOOP_LIST) +/* deprecated old name before real try/catch was added */ +#define CXp_TRYBLOCK CXp_EVALBLOCK +#define CxTRYBLOCK(c) CxEVALBLOCK(c) + #define CXINC (cxstack_ix < cxstack_max ? ++cxstack_ix : (cxstack_ix = cxinc())) #define G_SCALAR 2 diff --git a/cpan/Compress-Raw-Bzip2/.gitignore b/cpan/Compress-Raw-Bzip2/.gitignore index 6f7f42a65e4a..5f4846c938c8 100644 --- a/cpan/Compress-Raw-Bzip2/.gitignore +++ b/cpan/Compress-Raw-Bzip2/.gitignore @@ -3,3 +3,4 @@ /constants.h /constants.xs !/bzip2-src/*.c +!/Makefile.PL diff --git a/cpan/Compress-Raw-Bzip2/Makefile.PL b/cpan/Compress-Raw-Bzip2/Makefile.PL index d60345410158..b4b95ec7ed41 100644 --- a/cpan/Compress-Raw-Bzip2/Makefile.PL +++ b/cpan/Compress-Raw-Bzip2/Makefile.PL @@ -18,10 +18,10 @@ my $BZIP2_INCLUDE = defined($ENV{BZIP2_INCLUDE}) ? $ENV{BZIP2_INCLUDE} : '.'; #ParseCONFIG() ; -UpDowngrade(getPerlFiles('MANIFEST')) +UpDowngrade(getPerlFiles('MANIFEST')) unless $ENV{PERL_CORE}; -WriteMakefile( +WriteMakefile( NAME => 'Compress::Raw::Bzip2', VERSION_FROM => 'lib/Compress/Raw/Bzip2.pm', INC => "-I$BZIP2_INCLUDE" , @@ -29,7 +29,7 @@ WriteMakefile( XS => { 'Bzip2.xs' => 'Bzip2.c'}, 'clean' => { FILES => '*.c bzip2.h bzlib.h bzlib_private.h constants.h constants.xs' }, #'depend' => { 'Makefile' => 'config.in' }, - 'dist' => { COMPRESS => 'gzip', + 'dist' => { COMPRESS => 'gzip', TARFLAGS => '-chvf', SUFFIX => 'gz', DIST_DEFAULT => 'MyTrebleCheck tardist', @@ -40,7 +40,7 @@ WriteMakefile( ? bzip2_files($BZIP2_LIB) : (LIBS => [ "-L$BZIP2_LIB -lbz2 " ]) ), - + ( $] >= 5.005 ? (ABSTRACT_FROM => 'lib/Compress/Raw/Bzip2.pm', @@ -50,9 +50,9 @@ WriteMakefile( INSTALLDIRS => ($] > 5.010 && $] < 5.011 ? 'perl' : 'site'), - ( eval { ExtUtils::MakeMaker->VERSION(6.46) } + ( eval { ExtUtils::MakeMaker->VERSION(6.46) } ? ( META_MERGE => { - + "meta-spec" => { version => 2 }, no_index => { @@ -60,7 +60,7 @@ WriteMakefile( }, resources => { - + bugtracker => { web => 'https://github.com/pmqs/Compress-Raw-Bzip2/issues' }, @@ -71,15 +71,15 @@ WriteMakefile( type => 'git', url => 'git://github.com/pmqs/Compress-Raw-Bzip2.git', web => 'https://github.com/pmqs/Compress-Raw-Bzip2', - }, + }, }, - } - ) + } + ) : () - ), + ), ((ExtUtils::MakeMaker->VERSION() gt '6.30') ? - ('LICENSE' => 'perl') : ()), + ('LICENSE' => 'perl') : ()), ) ; @@ -127,7 +127,7 @@ if (eval {require ExtUtils::Constant; 1}) { die "The following names are missing from \@EXPORT in Bzip2.pm\n" . "\t$missing\n" ; } - + #push @names, {name => 'BZ_VERSION', type => 'PV' }; ExtUtils::Constant::WriteConstants( @@ -135,9 +135,9 @@ if (eval {require ExtUtils::Constant; 1}) { NAMES => \@names, C_FILE => 'constants.h', XS_FILE => 'constants.xs', - + ); -} +} else { foreach my $name (qw( constants.h constants.xs )) { @@ -166,8 +166,8 @@ sub bzip2_files foreach my $file (@c_files, @h_files) { copy(catfile($dir, $file), '.') } - - + + @h_files = map { catfile($dir, $_) } @h_files ; my @o_files = map { "$_\$(OBJ_EXT)" } 'Bzip2', @c_files; push @c_files, 'Bzip2.c' ; @@ -177,10 +177,7 @@ sub bzip2_files 'C' => [ @c_files ] , #'OBJECT' => qq[ @o_files ], 'OBJECT' => q[ $(O_FILES) ], - + ) ; } - - - diff --git a/cpan/Compress-Raw-Bzip2/lib/Compress/Raw/Bzip2.pm b/cpan/Compress-Raw-Bzip2/lib/Compress/Raw/Bzip2.pm index 842aba3e8b39..695f108bb816 100644 --- a/cpan/Compress-Raw-Bzip2/lib/Compress/Raw/Bzip2.pm +++ b/cpan/Compress-Raw-Bzip2/lib/Compress/Raw/Bzip2.pm @@ -11,8 +11,8 @@ use Carp ; use bytes ; our ($VERSION, $XS_VERSION, @ISA, @EXPORT, $AUTOLOAD); -$VERSION = '2.096'; -$XS_VERSION = $VERSION; +$VERSION = '2.100'; +$XS_VERSION = $VERSION; $VERSION = eval $VERSION; @ISA = qw(Exporter); @@ -61,11 +61,11 @@ eval { require XSLoader; XSLoader::load('Compress::Raw::Bzip2', $XS_VERSION); 1; -} +} or do { require DynaLoader; local @ISA = qw(DynaLoader); - bootstrap Compress::Raw::Bzip2 $XS_VERSION ; + bootstrap Compress::Raw::Bzip2 $XS_VERSION ; }; #sub Compress::Raw::Bzip2::new @@ -132,14 +132,14 @@ Compress::Raw::Bzip2 - Low-Level Interface to bzip2 compression library my ($bz, $status) = new Compress::Raw::Bzip2 [OPTS] or die "Cannot create bzip2 object: $bzerno\n"; - + $status = $bz->bzdeflate($input, $output); $status = $bz->bzflush($output); $status = $bz->bzclose($output); my ($bz, $status) = new Compress::Raw::Bunzip2 [OPTS] or die "Cannot create bunzip2 object: $bzerno\n"; - + $status = $bz->bzinflate($input, $output); my $version = Compress::Raw::Bzip2::bzlibversion(); @@ -384,8 +384,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2020 Paul Marquess. All rights reserved. +Copyright (c) 2005-2021 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. - diff --git a/cpan/Compress-Raw-Bzip2/private/MakeUtil.pm b/cpan/Compress-Raw-Bzip2/private/MakeUtil.pm index 12fa26fd05f1..aa540c68fda3 100644 --- a/cpan/Compress-Raw-Bzip2/private/MakeUtil.pm +++ b/cpan/Compress-Raw-Bzip2/private/MakeUtil.pm @@ -42,14 +42,14 @@ sub MY::libscan return $path; } -sub MY::postamble +sub MY::postamble { return '' if $ENV{PERL_CORE} ; my @files = getPerlFiles('MANIFEST'); - # Note: Once you remove all the layers of shell/makefile escaping + # Note: Once you remove all the layers of shell/makefile escaping # the regular expression below reads # # /^\s*local\s*\(\s*\$^W\s*\)/ @@ -215,7 +215,7 @@ sub UpDowngrade foreach (@files) { #if (-l $_ ) { doUpDown($our_sub, $warn_sub, $_) } - #else + #else #{ doUpDownViaCopy($our_sub, $warn_sub, $_) } } @@ -234,7 +234,7 @@ sub doUpDown local ($^I) = ($^O eq 'VMS') ? "_bak" : ".bak"; local (@ARGV) = shift; - + while (<>) { print, last if /^__(END|DATA)__/ ; @@ -277,7 +277,7 @@ sub doUpDownViaCopy push @keep, $_; last ; } - + &{ $our_sub }() if $our_sub ; &{ $warn_sub }() if $warn_sub ; push @keep, $_; @@ -334,7 +334,7 @@ sub FindBrokenDependencies Compress::Zlib ); - + my @broken = (); foreach my $module ( grep { ! $thisModule{$_} } @modules) @@ -342,12 +342,12 @@ sub FindBrokenDependencies my $hasVersion = getInstalledVersion($module); # No need to upgrade if the module isn't installed at all - next + next if ! defined $hasVersion; # If already have C::Z version 1, then an upgrade to any of the # IO::Compress modules will not break it. - next + next if $module eq 'Compress::Zlib' && $hasVersion < 2; if ($hasVersion < $version) @@ -370,14 +370,12 @@ sub getInstalledVersion { no strict 'refs'; $version = ${ $module . "::VERSION" }; - $version = 0 + $version = 0 } - + return $version; } package MakeUtil ; 1; - - diff --git a/cpan/Compress-Raw-Bzip2/t/000prereq.t b/cpan/Compress-Raw-Bzip2/t/000prereq.t index 397366c00cd4..2eeff538456b 100644 --- a/cpan/Compress-Raw-Bzip2/t/000prereq.t +++ b/cpan/Compress-Raw-Bzip2/t/000prereq.t @@ -19,13 +19,13 @@ BEGIN if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - my $VERSION = '2.096'; + my $VERSION = '2.100'; my @NAMES = qw( - + ); my @OPT = qw( - + ); plan tests => 1 + @NAMES + @OPT + $extra ; @@ -43,15 +43,14 @@ BEGIN eval " require $name " ; if ($@) { - ok 1, "$name not available" + ok 1, "$name not available" } - else + else { my $ver = eval("\$${name}::VERSION"); - is $ver, $VERSION, "$name version should be $VERSION" + is $ver, $VERSION, "$name version should be $VERSION" or diag "$name version is $ver, need $VERSION" ; - } + } } - -} +} diff --git a/cpan/Compress-Raw-Bzip2/t/09limitoutput.t b/cpan/Compress-Raw-Bzip2/t/09limitoutput.t index 78e121aa902f..63138a0d0fe7 100644 --- a/cpan/Compress-Raw-Bzip2/t/09limitoutput.t +++ b/cpan/Compress-Raw-Bzip2/t/09limitoutput.t @@ -13,8 +13,8 @@ use bytes; use Test::More ; use CompTestUtils; -BEGIN -{ +BEGIN +{ # use Test::NoWarnings, if available my $extra = 0 ; $extra = 1 @@ -22,7 +22,7 @@ BEGIN plan tests => 88 + $extra ; - use_ok('Compress::Raw::Bzip2') ; + use_ok('Compress::Raw::Bzip2') ; } @@ -30,7 +30,7 @@ BEGIN my $hello = "I am a HAL 9000 computer" x 2001; my $tmp = $hello ; -my ($err, $x, $X, $status); +my ($err, $x, $X, $status); ok( ($x, $err) = new Compress::Raw::Bzip2 (1)); ok $x ; @@ -52,7 +52,7 @@ cmp_ok $x->bzclose($out), '==', BZ_STREAM_END, " bzflush returned BZ_STREAM_END ok $GOT eq $hello; } - + sub getOut { my $x = ''; return \$x } for my $bufsize (1, 2, 3, 13, 4096, 1024*10) @@ -68,7 +68,7 @@ for my $bufsize (1, 2, 3, 13, 4096, 1024*10) )); ok $k ; cmp_ok $err, '==', BZ_OK, " status is BZ_OK" ; - + is $k->total_in_lo32(), 0, " total_in_lo32 == 0" ; is $k->total_out_lo32(), 0, " total_out_lo32 == 0" ; my $GOT = getOut(); @@ -83,7 +83,7 @@ for my $bufsize (1, 2, 3, 13, 4096, 1024*10) last if $status != BZ_OK; $deltaOK = 0 if length($GOT) - $prev > $bufsize; } - + ok $deltaOK, " Output Delta never > $bufsize"; cmp_ok $looped, '>=', 1, " looped $looped"; is length($tmp), 0, " length of input buffer is zero"; @@ -98,7 +98,7 @@ sub getit { my $obj = shift ; my $input = shift; - + my $data ; 1 while $obj->bzinflate($input, $data) != BZ_STREAM_END ; return \$data ; @@ -106,9 +106,9 @@ sub getit { title "regression test"; - - my ($err, $x, $X, $status); - + + my ($err, $x, $X, $status); + ok( ($x, $err) = new Compress::Raw::Bzip2 (1)); ok $x ; cmp_ok $err, '==', BZ_OK, " status is BZ_OK" ; @@ -117,11 +117,11 @@ sub getit my $line2 = "second line\n" ; my $text = $line1 . $line2 ; my $tmp = $text; - + my $out ; $status = $x->bzdeflate($tmp, $out) ; cmp_ok $status, '==', BZ_RUN_OK, " status is BZ_RUN_OK" ; - + cmp_ok $x->bzclose($out), '==', BZ_STREAM_END, " bzclose returned BZ_STREAM_END" ; my $k; @@ -130,10 +130,9 @@ sub getit #LimitOutput => 1 )); - + my $c = getit($k, $out); is $$c, $text; - - -} + +} diff --git a/cpan/Compress-Raw-Bzip2/t/19nonpv.t b/cpan/Compress-Raw-Bzip2/t/19nonpv.t index 15d53b92cab7..d97de7e9406a 100644 --- a/cpan/Compress-Raw-Bzip2/t/19nonpv.t +++ b/cpan/Compress-Raw-Bzip2/t/19nonpv.t @@ -12,8 +12,8 @@ use warnings; use Test::More ; use CompTestUtils; -BEGIN -{ +BEGIN +{ # use Test::NoWarnings, if available my $extra = 0 ; $extra = 1 @@ -23,7 +23,7 @@ BEGIN use_ok('Compress::Raw::Bzip2', 2) ; } - + my $hello = <uncompressedBytes(), 0, "uncompressedBytes() == 0" ; is $x->compressedBytes(), 0, "compressedBytes() == 0" ; @@ -54,38 +54,36 @@ my $len = length $hello ; $Answer = *Answer; $status = $x->bzdeflate($hello, $Answer) ; cmp_ok $status, '==', BZ_RUN_OK, "bzdeflate returned BZ_RUN_OK" ; - + $X = *X; cmp_ok $x->bzflush($X), '==', BZ_RUN_OK, "bzflush returned BZ_RUN_OK" ; $Answer .= $X ; - + is $x->uncompressedBytes(), length $hello, "uncompressedBytes ok" ; is $x->compressedBytes(), length $Answer, "compressedBytes ok" ; - + $X = *X; cmp_ok $x->bzclose($X), '==', BZ_STREAM_END, "bzclose returned BZ_STREAM_END"; $Answer .= $X ; my @Answer = split('', $Answer) ; - + my $k; ok(($k, $err) = new Compress::Raw::Bunzip2(0, 0)); ok $k, "Compress::Raw::Bunzip2 ok" ; cmp_ok $err, '==', BZ_OK, "status is BZ_OK" ; - + is $k->compressedBytes(), 0, "compressedBytes() == 0" ; is $k->uncompressedBytes(), 0, "uncompressedBytes() == 0" ; my $GOT = *GOT; $GOT = *GOT; my $Z; $status = $k->bzinflate($Answer, $GOT) ; - - + + cmp_ok $status, '==', BZ_STREAM_END, "Got BZ_STREAM_END" ; is $GOT, $hello, "uncompressed data matches ok" ; is $k->compressedBytes(), length $Answer, "compressedBytes ok" ; is $k->uncompressedBytes(), length $hello , "uncompressedBytes ok"; } - - diff --git a/cpan/Compress-Raw-Bzip2/t/compress/CompTestUtils.pm b/cpan/Compress-Raw-Bzip2/t/compress/CompTestUtils.pm index c506632f90e3..fd9d963e0344 100644 --- a/cpan/Compress-Raw-Bzip2/t/compress/CompTestUtils.pm +++ b/cpan/Compress-Raw-Bzip2/t/compress/CompTestUtils.pm @@ -9,13 +9,13 @@ use bytes; #use lib qw(t t/compress); use Carp ; -#use Test::More ; +#use Test::More ; sub title { - #diag "" ; + #diag "" ; ok(1, $_[0]) ; #diag "" ; } @@ -26,7 +26,7 @@ sub like_eval } BEGIN { - eval { + eval { require File::Temp; } ; @@ -38,7 +38,7 @@ BEGIN { our ($index); $index = '00000'; - + sub new { my $self = shift ; @@ -72,7 +72,7 @@ BEGIN { $index = '00000'; our ($useTempFile); our ($useTempDir); - + sub new { my $self = shift ; @@ -115,11 +115,11 @@ BEGIN { # autogenerate the name if none supplied $_ = "tmpdir" . $$ . "X" . $index ++ . ".tmp" ; } - foreach (@_) - { + foreach (@_) + { rmtree $_, {verbose => 0, safe => 1} - if -d $_; - mkdir $_, 0777 + if -d $_; + mkdir $_, 0777 } bless [ @_ ], $self ; } @@ -131,10 +131,10 @@ BEGIN { if (! $useTempFile) { my $self = shift ; - foreach (@$self) - { + foreach (@$self) + { rmtree $_, {verbose => 0, safe => 1} - if -d $_ ; + if -d $_ ; } } } @@ -150,15 +150,15 @@ sub readFile { my $pos = tell($f); seek($f, 0,0); - @strings = <$f> ; + @strings = <$f> ; seek($f, 0, $pos); } else { - open (F, "<$f") + open (F, "<$f") or croak "Cannot open $f: $!\n" ; binmode F; - @strings = ; + @strings = ; close F ; } @@ -175,7 +175,7 @@ sub writeFile { my($filename, @strings) = @_ ; 1 while unlink $filename ; - open (F, ">$filename") + open (F, ">$filename") or croak "Cannot open $filename: $!\n" ; binmode F; foreach (@strings) { @@ -191,10 +191,10 @@ sub GZreadFile my ($uncomp) = "" ; my $line = "" ; - my $fil = gzopen($filename, "rb") + my $fil = gzopen($filename, "rb") or croak "Cannopt open '$filename': $Compress::Zlib::gzerrno" ; - $uncomp .= $line + $uncomp .= $line while $fil->gzread($line) > 0; $fil->gzclose ; @@ -248,7 +248,7 @@ sub readHeaderInfo some text EOM - ok my $x = new IO::Compress::Gzip $name, %opts + ok my $x = new IO::Compress::Gzip $name, %opts or diag "GzipError is $IO::Compress::Gzip::GzipError" ; ok $x->write($string) ; ok $x->close ; @@ -562,9 +562,9 @@ sub anyUncompress } my $out = ''; - my $o = new IO::Uncompress::AnyUncompress \$data, - Append => 1, - Transparent => 0, + my $o = new IO::Uncompress::AnyUncompress \$data, + Append => 1, + Transparent => 0, RawInflate => 1, UnLzma => 1, @opts @@ -622,10 +622,10 @@ sub getHeaders } my $out = ''; - my $o = new IO::Uncompress::AnyUncompress \$data, - MultiStream => 1, - Append => 1, - Transparent => 0, + my $o = new IO::Uncompress::AnyUncompress \$data, + MultiStream => 1, + Append => 1, + Transparent => 0, RawInflate => 1, UnLzma => 1, @opts diff --git a/cpan/Compress-Raw-Bzip2/typemap b/cpan/Compress-Raw-Bzip2/typemap index 873681619f36..c8a988929198 100644 --- a/cpan/Compress-Raw-Bzip2/typemap +++ b/cpan/Compress-Raw-Bzip2/typemap @@ -30,7 +30,6 @@ T_PTROBJ_AV else if (sv_derived_from($arg, \"${ntype}\")) { IV tmp = SvIV(getInnerObject($arg)) ; $var = INT2PTR($type, tmp); - } else croak(\"$var is not of type ${ntype}\") @@ -49,6 +48,3 @@ T_DUAL T_PV sv_setpv((SV*)$arg, $var); - - - diff --git a/cpan/Compress-Raw-Zlib/.gitignore b/cpan/Compress-Raw-Zlib/.gitignore index 091348d9ecb9..079481762a3f 100644 --- a/cpan/Compress-Raw-Zlib/.gitignore +++ b/cpan/Compress-Raw-Zlib/.gitignore @@ -1 +1,4 @@ -constants.* +!/zlib-src/*.c +!/Makefile.PL +/constants.h +/constants.xs diff --git a/cpan/Compress-Raw-Zlib/Makefile.PL b/cpan/Compress-Raw-Zlib/Makefile.PL index 67c28d606f72..60fc8742806a 100644 --- a/cpan/Compress-Raw-Zlib/Makefile.PL +++ b/cpan/Compress-Raw-Zlib/Makefile.PL @@ -32,7 +32,7 @@ my $ZLIB_LIBRARY_NAME = $^O eq 'MSWin32' ? 'zlib' : 'z' ; # ExtUtils::Install. # Don't ask if MM_USE_DEFAULT is set -- enables perl core building on cygwin -if ($^O =~ /cygwin/i and $ExtUtils::Install::VERSION < 1.39 +if ($^O =~ /cygwin/i and $ExtUtils::Install::VERSION < 1.39 and not ($ENV{PERL_MM_USE_DEFAULT} or $ENV{PERL_CORE})) { print < 'Compress::Raw::Zlib', VERSION_FROM => 'lib/Compress/Raw/Zlib.pm', INC => "-I$ZLIB_INCLUDE" , @@ -79,7 +79,7 @@ WriteMakefile( XS => { 'Zlib.xs' => 'Zlib.c'}, 'depend' => { 'Makefile' => 'config.in' }, 'clean' => { FILES => '*.c constants.h constants.xs' }, - 'dist' => { COMPRESS => 'gzip', + 'dist' => { COMPRESS => 'gzip', TARFLAGS => '-chvf', SUFFIX => 'gz', DIST_DEFAULT => 'MyTrebleCheck tardist', @@ -94,9 +94,9 @@ WriteMakefile( INSTALLDIRS => ($] >= 5.009 && $] < 5.011 ? 'perl' : 'site'), - ( eval { ExtUtils::MakeMaker->VERSION(6.46) } + ( eval { ExtUtils::MakeMaker->VERSION(6.46) } ? ( META_MERGE => { - + "meta-spec" => { version => 2 }, no_index => { @@ -104,7 +104,7 @@ WriteMakefile( }, resources => { - + bugtracker => { web => 'https://github.com/pmqs/Compress-Raw-Zlib/issues' }, @@ -115,15 +115,15 @@ WriteMakefile( type => 'git', url => 'git://github.com/pmqs/Compress-Raw-Zlib.git', web => 'https://github.com/pmqs/Compress-Raw-Zlib', - }, + }, }, - } - ) + } + ) : () ), ((ExtUtils::MakeMaker->VERSION() gt '6.30') ? - ('LICENSE' => 'perl') : ()), + ('LICENSE' => 'perl') : ()), ) ; @@ -201,13 +201,13 @@ if (eval {require ExtUtils::Constant; 1}) { die "The following names are missing from \@EXPORT in Zlib.pm\n" . "\t$missing\n" ; } - + push @names, { name => 'ZLIB_VERSION', type => 'PV' }; - - push @names, map { { name => $_, - macro => version_Macro $verSpecificNames{$_} - } - } + + push @names, map { { name => $_, + macro => version_Macro $verSpecificNames{$_} + } + } keys %verSpecificNames ; ExtUtils::Constant::WriteConstants( @@ -215,10 +215,10 @@ if (eval {require ExtUtils::Constant; 1}) { NAMES => \@names, C_FILE => 'constants.h', XS_FILE => 'constants.xs', - + ); -} +} else { foreach my $name (qw( constants.h constants.xs )) { @@ -263,14 +263,14 @@ sub ParseCONFIG # check parsed values my @missing = () ; - die "The following keys are missing from $CONFIG [@missing]\n" + die "The following keys are missing from $CONFIG [@missing]\n" if @missing = keys %Parsed ; $ZLIB_INCLUDE = defined $ENV{'ZLIB_INCLUDE'} - ? $ENV{'ZLIB_INCLUDE'} + ? $ENV{'ZLIB_INCLUDE'} : $Info{'INCLUDE'} ; - $ZLIB_LIB = defined $ENV{'ZLIB_LIB'} - ?$ENV{'ZLIB_LIB'} + $ZLIB_LIB = defined $ENV{'ZLIB_LIB'} + ?$ENV{'ZLIB_LIB'} : $Info{'LIB'} ; if ($^O eq 'VMS') { @@ -279,19 +279,19 @@ sub ParseCONFIG } my $y = defined $ENV{'OLD_ZLIB'} - ? $ENV{'OLD_ZLIB'} + ? $ENV{'OLD_ZLIB'} : $Info{'OLD_ZLIB'} ; $OLD_ZLIB = '-DOLD_ZLIB' if $y and $y =~ /^yes|on|true|1$/i; - my $x = defined $ENV{'BUILD_ZLIB'} - ? $ENV{'BUILD_ZLIB'} + my $x = defined $ENV{'BUILD_ZLIB'} + ? $ENV{'BUILD_ZLIB'} : $Info{'BUILD_ZLIB'} ; if ($x and $x =~ /^yes|on|true|1$/i ) { $BUILD_ZLIB = 1 ; - # ZLIB_LIB & ZLIB_INCLUDE must point to the same place when + # ZLIB_LIB & ZLIB_INCLUDE must point to the same place when # BUILD_ZLIB is specified. die "INCLUDE & LIB must be the same when BUILD_ZLIB is True\n" if $ZLIB_LIB ne $ZLIB_INCLUDE ; @@ -309,8 +309,8 @@ sub ParseCONFIG print "Building Zlib enabled\n" ; } - $GZIP_OS_CODE = defined $ENV{'GZIP_OS_CODE'} - ? $ENV{'GZIP_OS_CODE'} + $GZIP_OS_CODE = defined $ENV{'GZIP_OS_CODE'} + ? $ENV{'GZIP_OS_CODE'} : $Info{'GZIP_OS_CODE'} ; die "GZIP_OS_CODE not 'AUTO_DETECT' or a number between 0 and 255\n" @@ -322,7 +322,7 @@ sub ParseCONFIG print "Auto Detect Gzip OS Code..\n" ; $GZIP_OS_CODE = getOSCode() ; } - + my $name = getOSname($GZIP_OS_CODE); print "Setting Gzip OS Code to $GZIP_OS_CODE [$name]\n" ; @@ -347,22 +347,22 @@ sub zlib_files my @h_files = (); my @c_files = (); - + if (-f catfile($dir, "infback.c")) { # zlib 1.2.0 or greater # - @h_files = qw(crc32.h inffast.h inflate.h trees.h zconf.in.h - zutil.h deflate.h inffixed.h inftrees.h zconf.h - zlib.h + @h_files = qw(crc32.h inffast.h inflate.h trees.h zconf.in.h + zutil.h deflate.h inffixed.h inftrees.h zconf.h + zlib.h ); @c_files = qw(adler32 crc32 infback inflate uncompr - compress deflate inffast inftrees - trees zutil + compress deflate inffast inftrees + trees zutil ); } else { # zlib 1.1.x - + @h_files = qw(deflate.h infcodes.h inftrees.h zconf.h zutil.h infblock.h inffast.h infutil.h zlib.h ); @@ -371,20 +371,20 @@ sub zlib_files inftrees infcodes infutil inffast ); } - + @h_files = map { catfile($dir, $_) } @h_files ; my @o_files = map { "$_\$(OBJ_EXT)" } 'Zlib', @c_files; @c_files = map { "$_.c" } 'Zlib', @c_files ; foreach my $file (@c_files) { copy(catfile($dir, $file), '.') } - + return ( #'H' => [ @h_files ], 'C' => [ @c_files ] , #'OBJECT' => qq[ @o_files ], 'OBJECT' => q[ $(O_FILES) ], - + ) ; } @@ -418,7 +418,7 @@ BEGIN [ '' => 255, 'Unknown OS' ], ); - %OSnames = map { $$_[1] => $$_[2] } + %OSnames = map { $$_[1] => $$_[2] } @GZIP_OS_Names ; } @@ -447,4 +447,3 @@ sub getOSname } # end of file Makefile.PL - diff --git a/cpan/Compress-Raw-Zlib/config.in b/cpan/Compress-Raw-Zlib/config.in index d6701ffb0cf7..fa998b53dbb8 100644 --- a/cpan/Compress-Raw-Zlib/config.in +++ b/cpan/Compress-Raw-Zlib/config.in @@ -3,11 +3,11 @@ # written by Paul Marquess # last modified 28th October 2003 # version 2.000 -# -# +# +# # This file is used to control which zlib library will be used by # Compress::Zlib -# +# # See to the sections below in the README file for details of how to # use this file. # diff --git a/cpan/Compress-Raw-Zlib/lib/Compress/Raw/Zlib.pm b/cpan/Compress-Raw-Zlib/lib/Compress/Raw/Zlib.pm index 59cda238e2dc..df50ea314202 100644 --- a/cpan/Compress-Raw-Zlib/lib/Compress/Raw/Zlib.pm +++ b/cpan/Compress-Raw-Zlib/lib/Compress/Raw/Zlib.pm @@ -10,12 +10,12 @@ use warnings ; use bytes ; our ($VERSION, $XS_VERSION, @ISA, @EXPORT, %EXPORT_TAGS, @EXPORT_OK, $AUTOLOAD, %DEFLATE_CONSTANTS, @DEFLATE_CONSTANTS); -$VERSION = '2.096'; -$XS_VERSION = $VERSION; +$VERSION = '2.100'; +$XS_VERSION = $VERSION; $VERSION = eval $VERSION; @ISA = qw(Exporter); -%EXPORT_TAGS = ( flush => [qw{ +%EXPORT_TAGS = ( flush => [qw{ Z_NO_FLUSH Z_PARTIAL_FLUSH Z_SYNC_FLUSH @@ -23,30 +23,30 @@ $VERSION = eval $VERSION; Z_FINISH Z_BLOCK }], - level => [qw{ + level => [qw{ Z_NO_COMPRESSION Z_BEST_SPEED Z_BEST_COMPRESSION Z_DEFAULT_COMPRESSION }], - strategy => [qw{ + strategy => [qw{ Z_FILTERED Z_HUFFMAN_ONLY Z_RLE Z_FIXED Z_DEFAULT_STRATEGY }], - status => [qw{ + status => [qw{ Z_OK Z_STREAM_END Z_NEED_DICT Z_ERRNO Z_STREAM_ERROR - Z_DATA_ERROR - Z_MEM_ERROR - Z_BUF_ERROR - Z_VERSION_ERROR - }], + Z_DATA_ERROR + Z_MEM_ERROR + Z_BUF_ERROR + Z_VERSION_ERROR + }], ); %DEFLATE_CONSTANTS = %EXPORT_TAGS; @@ -54,12 +54,12 @@ $VERSION = eval $VERSION; # Items to export into callers namespace by default. Note: do not export # names by default without a very good reason. Use EXPORT_OK instead. # Do not simply export all your public functions/methods/constants. -@DEFLATE_CONSTANTS = +@DEFLATE_CONSTANTS = @EXPORT = qw( ZLIB_VERSION ZLIB_VERNUM - + OS_CODE MAX_MEM_LEVEL @@ -125,13 +125,13 @@ eval { require XSLoader; XSLoader::load('Compress::Raw::Zlib', $XS_VERSION); 1; -} +} or do { require DynaLoader; local @ISA = qw(DynaLoader); - bootstrap Compress::Raw::Zlib $XS_VERSION ; + bootstrap Compress::Raw::Zlib $XS_VERSION ; }; - + use constant Parse_any => 0x01; use constant Parse_unsigned => 0x02; @@ -153,7 +153,7 @@ use constant OFF_STICKY => 5 ; sub ParseParameters { - my $level = shift || 0 ; + my $level = shift || 0 ; my $sub = (caller($level + 1))[3] ; #local $Carp::CarpLevel = 1 ; @@ -186,13 +186,13 @@ sub Compress::Raw::Zlib::Parameters::setError $self->{Error} = $error ; return $retval; } - + #sub getError #{ # my $self = shift ; # return $self->{Error} ; #} - + sub Compress::Raw::Zlib::Parameters::parse { my $self = shift ; @@ -211,10 +211,10 @@ sub Compress::Raw::Zlib::Parameters::parse @entered = () ; } elsif (@_ == 1) { - my $href = $_[0] ; + my $href = $_[0] ; return $self->setError("Expected even number of parameters, got 1") if ! defined $href or ! ref $href or ref $href ne "HASH" ; - + foreach my $key (keys %$href) { push @entered, $key ; push @entered, \$href->{$key} ; @@ -224,7 +224,7 @@ sub Compress::Raw::Zlib::Parameters::parse my $count = @_; return $self->setError("Expected even number of parameters, got $count") if $count % 2 != 0 ; - + for my $i (0.. $count / 2 - 1) { push @entered, $_[2* $i] ; push @entered, \$_[2* $i+1] ; @@ -239,7 +239,7 @@ sub Compress::Raw::Zlib::Parameters::parse my ($first_only, $sticky, $type, $value) = @$v ; my $x ; - $self->_checkType($key, \$value, $type, 0, \$x) + $self->_checkType($key, \$value, $type, 0, \$x) or return undef ; $key = lc $key; @@ -260,7 +260,7 @@ sub Compress::Raw::Zlib::Parameters::parse $key =~ s/^-// ; my $canonkey = lc $key; - + if ($got->{$canonkey} && ($firstTime || ! $got->{$canonkey}[OFF_FIRST_ONLY] )) { @@ -275,7 +275,7 @@ sub Compress::Raw::Zlib::Parameters::parse else { push (@Bad, $key) } } - + if (@Bad) { my ($bad) = join(", ", @Bad) ; return $self->setError("unknown key value(s) @Bad") ; @@ -319,7 +319,7 @@ sub Compress::Raw::Zlib::Parameters::_checkType return $self->setError("Parameter '$key' must be an unsigned int, got '$value'") if $validate && $value !~ /^\d+$/; - $$output = defined $value ? $value : 0 ; + $$output = defined $value ? $value : 0 ; return 1; } elsif ($type & Parse_signed) @@ -329,19 +329,19 @@ sub Compress::Raw::Zlib::Parameters::_checkType return $self->setError("Parameter '$key' must be a signed int, got '$value'") if $validate && $value !~ /^-?\d+$/; - $$output = defined $value ? $value : 0 ; + $$output = defined $value ? $value : 0 ; return 1 ; } elsif ($type & Parse_boolean) { return $self->setError("Parameter '$key' must be an int, got '$value'") if $validate && defined $value && $value !~ /^\d*$/; - $$output = defined $value ? $value != 0 : 0 ; + $$output = defined $value ? $value != 0 : 0 ; return 1; } # elsif ($type & Parse_string) # { -# $$output = defined $value ? $value : "" ; +# $$output = defined $value ? $value : "" ; # return 1; # } @@ -374,7 +374,7 @@ sub Compress::Raw::Zlib::Parameters::value return $self->{Got}{lc $name}[OFF_FIXED] ; } -our $OPTIONS_deflate = +our $OPTIONS_deflate = { 'AppendOutput' => [1, 1, Parse_boolean, 0], 'CRC32' => [1, 1, Parse_boolean, 0], @@ -394,7 +394,7 @@ sub Compress::Raw::Zlib::Deflate::new my $pkg = shift ; my ($got) = ParseParameters(0, $OPTIONS_deflate, @_); - croak "Compress::Raw::Zlib::Deflate::new: Bufsize must be >= 1, you specified " . + croak "Compress::Raw::Zlib::Deflate::new: Bufsize must be >= 1, you specified " . $got->value('Bufsize') unless $got->value('Bufsize') >= 1; @@ -408,11 +408,11 @@ sub Compress::Raw::Zlib::Deflate::new if ($windowBits & MAX_WBITS()) == 0 ; _deflateInit($flags, - $got->value('Level'), - $got->value('Method'), - $windowBits, - $got->value('MemLevel'), - $got->value('Strategy'), + $got->value('Level'), + $got->value('Method'), + $windowBits, + $got->value('MemLevel'), + $got->value('Strategy'), $got->value('Bufsize'), $got->value('Dictionary')) ; @@ -431,7 +431,7 @@ sub Compress::Raw::Zlib::deflateStream::STORABLE_thaw } -our $OPTIONS_inflate = +our $OPTIONS_inflate = { 'AppendOutput' => [1, 1, Parse_boolean, 0], 'LimitOutput' => [1, 1, Parse_boolean, 0], @@ -439,7 +439,7 @@ our $OPTIONS_inflate = 'ADLER32' => [1, 1, Parse_boolean, 0], 'ConsumeInput' => [1, 1, Parse_boolean, 1], 'Bufsize' => [1, 1, Parse_unsigned, 4096], - + 'WindowBits' => [1, 1, Parse_signed, MAX_WBITS()], 'Dictionary' => [1, 1, Parse_any, ""], } ; @@ -449,7 +449,7 @@ sub Compress::Raw::Zlib::Inflate::new my $pkg = shift ; my ($got) = ParseParameters(0, $OPTIONS_inflate, @_); - croak "Compress::Raw::Zlib::Inflate::new: Bufsize must be >= 1, you specified " . + croak "Compress::Raw::Zlib::Inflate::new: Bufsize must be >= 1, you specified " . $got->value('Bufsize') unless $got->value('Bufsize') >= 1; @@ -465,7 +465,7 @@ sub Compress::Raw::Zlib::Inflate::new $windowBits += MAX_WBITS() if ($windowBits & MAX_WBITS()) == 0 ; - _inflateInit($flags, $windowBits, $got->value('Bufsize'), + _inflateInit($flags, $windowBits, $got->value('Bufsize'), $got->value('Dictionary')) ; } @@ -489,13 +489,13 @@ sub Compress::Raw::Zlib::InflateScan::new 'CRC32' => [1, 1, Parse_boolean, 0], 'ADLER32' => [1, 1, Parse_boolean, 0], 'Bufsize' => [1, 1, Parse_unsigned, 4096], - + 'WindowBits' => [1, 1, Parse_signed, -MAX_WBITS()], 'Dictionary' => [1, 1, Parse_any, ""], }, @_) ; - croak "Compress::Raw::Zlib::InflateScan::new: Bufsize must be >= 1, you specified " . + croak "Compress::Raw::Zlib::InflateScan::new: Bufsize must be >= 1, you specified " . $got->value('Bufsize') unless $got->value('Bufsize') >= 1; @@ -505,7 +505,7 @@ sub Compress::Raw::Zlib::InflateScan::new $flags |= FLAG_ADLER if $got->value('ADLER32') ; #$flags |= FLAG_CONSUME_INPUT if $got->value('ConsumeInput') ; - _inflateScanInit($flags, $got->value('WindowBits'), $got->value('Bufsize'), + _inflateScanInit($flags, $got->value('WindowBits'), $got->value('Bufsize'), '') ; } @@ -518,7 +518,7 @@ sub Compress::Raw::Zlib::inflateScanStream::createDeflateStream 'CRC32' => [1, 1, Parse_boolean, 0], 'ADLER32' => [1, 1, Parse_boolean, 0], 'Bufsize' => [1, 1, Parse_unsigned, 4096], - + 'Level' => [1, 1, Parse_signed, Z_DEFAULT_COMPRESSION()], 'Method' => [1, 1, Parse_unsigned, Z_DEFLATED()], 'WindowBits' => [1, 1, Parse_signed, - MAX_WBITS()], @@ -526,7 +526,7 @@ sub Compress::Raw::Zlib::inflateScanStream::createDeflateStream 'Strategy' => [1, 1, Parse_unsigned, Z_DEFAULT_STRATEGY()], }, @_) ; - croak "Compress::Raw::Zlib::InflateScan::createDeflateStream: Bufsize must be >= 1, you specified " . + croak "Compress::Raw::Zlib::InflateScan::createDeflateStream: Bufsize must be >= 1, you specified " . $got->value('Bufsize') unless $got->value('Bufsize') >= 1; @@ -536,11 +536,11 @@ sub Compress::Raw::Zlib::inflateScanStream::createDeflateStream $flags |= FLAG_ADLER if $got->value('ADLER32') ; $pkg->_createDeflateStream($flags, - $got->value('Level'), - $got->value('Method'), - $got->value('WindowBits'), - $got->value('MemLevel'), - $got->value('Strategy'), + $got->value('Level'), + $got->value('Method'), + $got->value('WindowBits'), + $got->value('MemLevel'), + $got->value('Strategy'), $got->value('Bufsize'), ) ; @@ -556,10 +556,10 @@ sub Compress::Raw::Zlib::inflateScanStream::inflate if ($status == Z_OK() && $_[2]) { my $byte = ' '; - + $status = $self->scan(\$byte, $_[1]) ; } - + return $status ; } @@ -570,14 +570,14 @@ sub Compress::Raw::Zlib::deflateStream::deflateParams 'Level' => [1, 1, Parse_signed, undef], 'Strategy' => [1, 1, Parse_unsigned, undef], 'Bufsize' => [1, 1, Parse_unsigned, undef], - }, + }, @_) ; croak "Compress::Raw::Zlib::deflateParams needs Level and/or Strategy" unless $got->parsed('Level') + $got->parsed('Strategy') + $got->parsed('Bufsize'); - croak "Compress::Raw::Zlib::Inflate::deflateParams: Bufsize must be >= 1, you specified " . + croak "Compress::Raw::Zlib::Inflate::deflateParams: Bufsize must be >= 1, you specified " . $got->value('Bufsize') if $got->parsed('Bufsize') && $got->value('Bufsize') <= 1; @@ -586,7 +586,7 @@ sub Compress::Raw::Zlib::deflateStream::deflateParams $flags |= 2 if $got->parsed('Strategy') ; $flags |= 4 if $got->parsed('Bufsize') ; - $self->_deflateParams($flags, $got->value('Level'), + $self->_deflateParams($flags, $got->value('Level'), $got->value('Strategy'), $got->value('Bufsize')); } @@ -931,18 +931,18 @@ input, deflates it and writes it to standard output. while (<>) { $status = $x->deflate($_, $output) ; - + $status == Z_OK or die "deflation failed\n" ; - + print $output ; } - + $status = $x->flush($output) ; - + $status == Z_OK or die "deflation failed\n" ; - + print $output ; =head1 Compress::Raw::Zlib::Inflate @@ -1210,26 +1210,26 @@ Here is an example of using C. use strict ; use warnings ; - + use Compress::Raw::Zlib; - + my $x = new Compress::Raw::Zlib::Inflate() or die "Cannot create a inflation stream\n" ; - + my $input = '' ; binmode STDIN; binmode STDOUT; - + my ($output, $status) ; while (read(STDIN, $input, 4096)) { $status = $x->inflate($input, $output) ; - + print $output ; - + last if $status != Z_OK ; } - + die "inflation failed\n" unless $status == Z_STREAM_END ; @@ -1243,16 +1243,16 @@ simpler. use strict ; use warnings ; - + use Compress::Raw::Zlib; - + my $x = new Compress::Raw::Zlib::Inflate(LimitOutput => 1) or die "Cannot create a inflation stream\n" ; - + my $input = '' ; binmode STDIN; binmode STDOUT; - + my ($output, $status) ; OUTER: @@ -1269,7 +1269,7 @@ simpler. } while ($status == Z_OK && length $input); } - + die "inflation failed\n" unless $status == Z_STREAM_END ; @@ -1324,24 +1324,24 @@ source and uncompressing as you go the code will look something like this use strict ; use warnings ; - + use Compress::Raw::Zlib; - + my $x = new Compress::Raw::Zlib::Inflate() or die "Cannot create a inflation stream\n" ; - + my $input = '' ; - + my ($output, $status) ; while (read(STDIN, $input, 4096)) { $status = $x->inflate($input, $output) ; - + print $output ; - + last if $status != Z_OK ; } - + die "inflation failed\n" unless $status == Z_STREAM_END ; @@ -1391,16 +1391,16 @@ Below is typical code that shows how to use C. use strict ; use warnings ; - + use Compress::Raw::Zlib; - + my $x = new Compress::Raw::Zlib::Inflate(LimitOutput => 1) or die "Cannot create a inflation stream\n" ; - + my $input = '' ; binmode STDIN; binmode STDOUT; - + my ($output, $status) ; OUTER: @@ -1417,7 +1417,7 @@ Below is typical code that shows how to use C. } while ($status == Z_OK && length $input); } - + die "inflation failed\n" unless $status == Z_STREAM_END ; @@ -1596,8 +1596,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2020 Paul Marquess. All rights reserved. +Copyright (c) 2005-2021 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. - diff --git a/cpan/Compress-Raw-Zlib/private/MakeUtil.pm b/cpan/Compress-Raw-Zlib/private/MakeUtil.pm index 12fa26fd05f1..aa540c68fda3 100644 --- a/cpan/Compress-Raw-Zlib/private/MakeUtil.pm +++ b/cpan/Compress-Raw-Zlib/private/MakeUtil.pm @@ -42,14 +42,14 @@ sub MY::libscan return $path; } -sub MY::postamble +sub MY::postamble { return '' if $ENV{PERL_CORE} ; my @files = getPerlFiles('MANIFEST'); - # Note: Once you remove all the layers of shell/makefile escaping + # Note: Once you remove all the layers of shell/makefile escaping # the regular expression below reads # # /^\s*local\s*\(\s*\$^W\s*\)/ @@ -215,7 +215,7 @@ sub UpDowngrade foreach (@files) { #if (-l $_ ) { doUpDown($our_sub, $warn_sub, $_) } - #else + #else #{ doUpDownViaCopy($our_sub, $warn_sub, $_) } } @@ -234,7 +234,7 @@ sub doUpDown local ($^I) = ($^O eq 'VMS') ? "_bak" : ".bak"; local (@ARGV) = shift; - + while (<>) { print, last if /^__(END|DATA)__/ ; @@ -277,7 +277,7 @@ sub doUpDownViaCopy push @keep, $_; last ; } - + &{ $our_sub }() if $our_sub ; &{ $warn_sub }() if $warn_sub ; push @keep, $_; @@ -334,7 +334,7 @@ sub FindBrokenDependencies Compress::Zlib ); - + my @broken = (); foreach my $module ( grep { ! $thisModule{$_} } @modules) @@ -342,12 +342,12 @@ sub FindBrokenDependencies my $hasVersion = getInstalledVersion($module); # No need to upgrade if the module isn't installed at all - next + next if ! defined $hasVersion; # If already have C::Z version 1, then an upgrade to any of the # IO::Compress modules will not break it. - next + next if $module eq 'Compress::Zlib' && $hasVersion < 2; if ($hasVersion < $version) @@ -370,14 +370,12 @@ sub getInstalledVersion { no strict 'refs'; $version = ${ $module . "::VERSION" }; - $version = 0 + $version = 0 } - + return $version; } package MakeUtil ; 1; - - diff --git a/cpan/Compress-Raw-Zlib/t/01version.t b/cpan/Compress-Raw-Zlib/t/01version.t index 46200bc9a974..a38a1e6b3b90 100644 --- a/cpan/Compress-Raw-Zlib/t/01version.t +++ b/cpan/Compress-Raw-Zlib/t/01version.t @@ -11,8 +11,8 @@ use warnings ; use Test::More ; -BEGIN -{ +BEGIN +{ # use Test::NoWarnings, if available my $extra = 0 ; $extra = 1 @@ -20,13 +20,13 @@ BEGIN plan tests => 2 + $extra ; - use_ok('Compress::Raw::Zlib', 2) ; + use_ok('Compress::Raw::Zlib', 2) ; } # Check zlib_version and ZLIB_VERSION are the same. SKIP: { - skip "TEST_SKIP_VERSION_CHECK is set", 1 + skip "TEST_SKIP_VERSION_CHECK is set", 1 if $ENV{TEST_SKIP_VERSION_CHECK}; my $zlib_h = ZLIB_VERSION ; my $libz = Compress::Raw::Zlib::zlib_version; @@ -35,12 +35,11 @@ SKIP: { or diag < "Lengthy Tests Disabled\n" . "set COMPRESS_ZLIB_RUN_ALL or COMPRESS_ZLIB_RUN_MOST to run this test suite" unless defined $ENV{COMPRESS_ZLIB_RUN_ALL} or defined $ENV{COMPRESS_ZLIB_RUN_MOST}; - + # use Test::NoWarnings, if available my $extra = 0 ; $extra = 1 @@ -27,7 +27,7 @@ BEGIN plan tests => 288 + $extra ; - use_ok('Compress::Raw::Zlib', 2) ; + use_ok('Compress::Raw::Zlib', 2) ; } @@ -40,7 +40,7 @@ my $len = length $hello ; # Check zlib_version and ZLIB_VERSION are the same. SKIP: { - skip "TEST_SKIP_VERSION_CHECK is set", 1 + skip "TEST_SKIP_VERSION_CHECK is set", 1 if $ENV{TEST_SKIP_VERSION_CHECK}; is Compress::Raw::Zlib::zlib_version, ZLIB_VERSION, "ZLIB_VERSION matches Compress::Raw::Zlib::zlib_version" ; @@ -54,18 +54,18 @@ for my $i (1 .. 13) my $hello = "I am a HAL 9000 computer" x 2001; my $tmp = $hello ; - + my @hello = (); - push @hello, $1 + push @hello, $1 while $tmp =~ s/^(.{$i})//; push @hello, $tmp if length $tmp ; - my ($err, $x, $X, $status); - + my ($err, $x, $X, $status); + ok( ($x, $err) = new Compress::Raw::Zlib::Deflate (-AppendOutput => 1)); ok $x ; cmp_ok $err, '==', Z_OK, " status is Z_OK" ; - + ok ! defined $x->msg(), " no msg" ; is $x->total_in(), 0, " total_in == 0" ; is $x->total_out(), 0, " total_out == 0" ; @@ -75,26 +75,26 @@ for my $i (1 .. 13) { $status = $x->deflate($_, $out) ; last unless $status == Z_OK ; - + } cmp_ok $status, '==', Z_OK, " status is Z_OK" ; - + cmp_ok $x->flush($out), '==', Z_OK, " flush returned Z_OK" ; - + ok ! defined $x->msg(), " no msg" ; is $x->total_in(), length $hello, " length total_in" ; is $x->total_out(), length $out, " length total_out" ; - + my @Answer = (); $tmp = $out; push @Answer, $1 while $tmp =~ s/^(.{$i})//; push @Answer, $tmp if length $tmp ; - + my $k; ok(($k, $err) = new Compress::Raw::Zlib::Inflate( -AppendOutput => 1)); ok $k ; cmp_ok $err, '==', Z_OK, " status is Z_OK" ; - + ok ! defined $k->msg(), " no msg" ; is $k->total_in(), 0, " total_in == 0" ; is $k->total_out(), 0, " total_out == 0" ; @@ -105,9 +105,9 @@ for my $i (1 .. 13) { $status = $k->inflate($_, $GOT) ; last if $status == Z_STREAM_END or $status != Z_OK ; - + } - + cmp_ok $status, '==', Z_STREAM_END, " status is Z_STREAM_END" ; is $GOT, $hello, " got expected output" ; ok ! defined $k->msg(), " no msg" ; diff --git a/cpan/Compress-Raw-Zlib/t/09limitoutput.t b/cpan/Compress-Raw-Zlib/t/09limitoutput.t index 2532f9c69266..b77a3b154e3a 100644 --- a/cpan/Compress-Raw-Zlib/t/09limitoutput.t +++ b/cpan/Compress-Raw-Zlib/t/09limitoutput.t @@ -13,8 +13,8 @@ use bytes; use Test::More ; use CompTestUtils; -BEGIN -{ +BEGIN +{ # use Test::NoWarnings, if available my $extra = 0 ; $extra = 1 @@ -22,7 +22,7 @@ BEGIN plan tests => 107 + $extra ; - use_ok('Compress::Raw::Zlib', 2) ; + use_ok('Compress::Raw::Zlib', 2) ; } @@ -30,7 +30,7 @@ BEGIN my $hello = "I am a HAL 9000 computer" x 2001; my $tmp = $hello ; -my ($err, $x, $X, $status); +my ($err, $x, $X, $status); ok( ($x, $err) = new Compress::Raw::Zlib::Deflate (-AppendOutput => 1)); ok $x ; @@ -41,8 +41,8 @@ $status = $x->deflate($tmp, $out) ; cmp_ok $status, '==', Z_OK, " status is Z_OK" ; cmp_ok $x->flush($out), '==', Z_OK, " flush returned Z_OK" ; - - + + sub getOut { my $x = ''; return \$x } for my $bufsize (1, 2, 3, 13, 4096, 1024*10) @@ -57,7 +57,7 @@ for my $bufsize (1, 2, 3, 13, 4096, 1024*10) )); ok $k ; cmp_ok $err, '==', Z_OK, " status is Z_OK" ; - + ok ! defined $k->msg(), " no msg" ; is $k->total_in(), 0, " total_in == 0" ; is $k->total_out(), 0, " total_out == 0" ; @@ -73,7 +73,7 @@ for my $bufsize (1, 2, 3, 13, 4096, 1024*10) last if $status == Z_STREAM_END || $status == Z_DATA_ERROR || $status == Z_STREAM_ERROR ; $deltaOK = 0 if length($GOT) - $prev > $bufsize; } - + ok $deltaOK, " Output Delta never > $bufsize"; cmp_ok $looped, '>=', 1, " looped $looped"; is length($tmp), 0, " length of input buffer is zero"; @@ -89,7 +89,7 @@ sub getit { my $obj = shift ; my $input = shift; - + my $data ; 1 while $obj->inflate($input, $data) != Z_STREAM_END ; return \$data ; @@ -97,9 +97,9 @@ sub getit { title "regression test"; - - my ($err, $x, $X, $status); - + + my ($err, $x, $X, $status); + ok( ($x, $err) = new Compress::Raw::Zlib::Deflate (-AppendOutput => 1)); ok $x ; cmp_ok $err, '==', Z_OK, " status is Z_OK" ; @@ -108,11 +108,11 @@ sub getit my $line2 = "second line\n" ; my $text = $line1 . $line2 ; my $tmp = $text; - + my $out ; $status = $x->deflate($tmp, $out) ; cmp_ok $status, '==', Z_OK, " status is Z_OK" ; - + cmp_ok $x->flush($out), '==', Z_OK, " flush returned Z_OK" ; my $k; @@ -120,40 +120,39 @@ sub getit LimitOutput => 1 )); - + my $c = getit($k, $out); is $$c, $text; - - + + } { title "regression test for #92521: Z_OK instead of Z_BUF_ERROR"; - - # 1M "aaa..." - my $in = 'a' x 100000; - my ($deflate, $err) = Compress::Raw::Zlib::Deflate->new(WindowBits => -15, - MemLevel => 8); + + # 1M "aaa..." + my $in = 'a' x 100000; + my ($deflate, $err) = Compress::Raw::Zlib::Deflate->new(WindowBits => -15, + MemLevel => 8); ok $deflate ; cmp_ok $err, '==', Z_OK, " status is Z_OK" ; - my $status = $deflate->deflate($in, my $zip); + my $status = $deflate->deflate($in, my $zip); cmp_ok $status, '==', Z_OK, " status is Z_OK" ; - cmp_ok $deflate->flush($zip, Z_SYNC_FLUSH), "==", Z_OK; + cmp_ok $deflate->flush($zip, Z_SYNC_FLUSH), "==", Z_OK; - # Compression should stop after 10K "aaa..." with Z_BUF_ERROR + # Compression should stop after 10K "aaa..." with Z_BUF_ERROR my $inflate; - ($inflate, $err) = Compress::Raw::Zlib::Inflate->new( Bufsize => 10000, - LimitOutput => 1, WindowBits => -15 ); + ($inflate, $err) = Compress::Raw::Zlib::Inflate->new( Bufsize => 10000, + LimitOutput => 1, WindowBits => -15 ); ok $inflate ; cmp_ok $err, '==', Z_OK, " status is Z_OK" ; - $status = $inflate->inflate($zip, my $out); + $status = $inflate->inflate($zip, my $out); cmp_ok length($out), ">=", 10000; - #warn 'RESULT: ', length($out), ' of ', length($in), "\n"; + #warn 'RESULT: ', length($out), ' of ', length($in), "\n"; cmp_ok $status, '==', Z_BUF_ERROR, " status is Z_BUF_ERROR" ; } - diff --git a/cpan/Compress-Raw-Zlib/t/18lvalue.t b/cpan/Compress-Raw-Zlib/t/18lvalue.t index 3b102c799e96..98d8423d10c1 100644 --- a/cpan/Compress-Raw-Zlib/t/18lvalue.t +++ b/cpan/Compress-Raw-Zlib/t/18lvalue.t @@ -13,10 +13,10 @@ use bytes; use Test::More ; use CompTestUtils; -BEGIN -{ +BEGIN +{ plan(skip_all => "lvalue sub tests need Perl ??") - if $] < 5.006 ; + if $] < 5.006 ; # use Test::NoWarnings, if available my $extra = 0 ; @@ -27,7 +27,7 @@ BEGIN use_ok('Compress::Raw::Zlib', 2) ; } - + my $hello = <deflate(getData, getX), '==', Z_OK ; cmp_ok $x->flush(getX), '==', Z_OK ; - + my $append = "Appended" ; $X .= $append ; - + ok my $k = new Compress::Raw::Zlib::Inflate ( -AppendOutput => 1 ) ; - + cmp_ok $k->inflate(getX, getZ), '==', Z_STREAM_END ; ; - + ok $hello eq $Z ; is $X, $append; - -} - +} diff --git a/cpan/Compress-Raw-Zlib/t/19nonpv.t b/cpan/Compress-Raw-Zlib/t/19nonpv.t index bbc20c764867..2567ec55b378 100644 --- a/cpan/Compress-Raw-Zlib/t/19nonpv.t +++ b/cpan/Compress-Raw-Zlib/t/19nonpv.t @@ -12,8 +12,8 @@ use warnings; use Test::More ; use CompTestUtils; -BEGIN -{ +BEGIN +{ # use Test::NoWarnings, if available my $extra = 0 ; $extra = 1 @@ -23,7 +23,7 @@ BEGIN use_ok('Compress::Raw::Zlib', 2) ; } - + my $hello = < Z_BEST_COMPRESSION, -Dictionary => $dictionary}) ; - + my $dictID = $x->dict_adler() ; my ($X, $Y, $Z); cmp_ok $x->deflate($hello, $X), '==', Z_OK; cmp_ok $x->flush($Y), '==', Z_OK; $X .= $Y ; - + ok my $k = new Compress::Raw::Zlib::Inflate(-Dictionary => $dictionary) ; - + cmp_ok $k->inflate($X, $Z), '==', Z_STREAM_END; is $k->dict_adler(), $dictID; is $hello, $Z ; @@ -72,12 +72,12 @@ SKIP: { # ============================== my $hello = *hello ; - my ($err, $x, $X, $status); - + my ($err, $x, $X, $status); + ok( ($x, $err) = new Compress::Raw::Zlib::Deflate, "Create deflate object" ); ok $x, "Compress::Raw::Zlib::Deflate ok" ; cmp_ok $err, '==', Z_OK, "status is Z_OK" ; - + ok ! defined $x->msg() ; is $x->total_in(), 0, "total_in() == 0" ; is $x->total_out(), 0, "total_out() == 0" ; @@ -86,22 +86,22 @@ SKIP: { my $Answer = ''; $status = $x->deflate($hello, $X) ; $Answer .= $X ; - + cmp_ok $status, '==', Z_OK, "deflate returned Z_OK" ; - + $X = *X; cmp_ok $x->flush($X), '==', Z_OK, "flush returned Z_OK" ; $Answer .= $X ; - + ok ! defined $x->msg() ; is $x->total_in(), length $hello, "total_in ok" ; is $x->total_out(), length $Answer, "total_out ok" ; - + my $k; ok(($k, $err) = new Compress::Raw::Zlib::Inflate); ok $k, "Compress::Raw::Zlib::Inflate ok" ; cmp_ok $err, '==', Z_OK, "status is Z_OK" ; - + ok ! defined $k->msg(), "No error messages" ; is $k->total_in(), 0, "total_in() == 0" ; is $k->total_out(), 0, "total_out() == 0" ; @@ -111,7 +111,7 @@ SKIP: { my $Alen = length $Answer; $status = $k->inflate($Answer, $Z) ; $GOT .= $Z ; - + cmp_ok $status, '==', Z_STREAM_END, "Got Z_STREAM_END" ; is $GOT, $hello, "uncompressed data matches ok" ; ok ! defined $k->msg(), "No error messages" ; @@ -132,4 +132,3 @@ SKIP: { cmp_ok $status, "!=", Z_OK, "inflateSync on *hello returns error (and does not crash)"; } - diff --git a/cpan/Compress-Raw-Zlib/t/compress/CompTestUtils.pm b/cpan/Compress-Raw-Zlib/t/compress/CompTestUtils.pm index c506632f90e3..fd9d963e0344 100644 --- a/cpan/Compress-Raw-Zlib/t/compress/CompTestUtils.pm +++ b/cpan/Compress-Raw-Zlib/t/compress/CompTestUtils.pm @@ -9,13 +9,13 @@ use bytes; #use lib qw(t t/compress); use Carp ; -#use Test::More ; +#use Test::More ; sub title { - #diag "" ; + #diag "" ; ok(1, $_[0]) ; #diag "" ; } @@ -26,7 +26,7 @@ sub like_eval } BEGIN { - eval { + eval { require File::Temp; } ; @@ -38,7 +38,7 @@ BEGIN { our ($index); $index = '00000'; - + sub new { my $self = shift ; @@ -72,7 +72,7 @@ BEGIN { $index = '00000'; our ($useTempFile); our ($useTempDir); - + sub new { my $self = shift ; @@ -115,11 +115,11 @@ BEGIN { # autogenerate the name if none supplied $_ = "tmpdir" . $$ . "X" . $index ++ . ".tmp" ; } - foreach (@_) - { + foreach (@_) + { rmtree $_, {verbose => 0, safe => 1} - if -d $_; - mkdir $_, 0777 + if -d $_; + mkdir $_, 0777 } bless [ @_ ], $self ; } @@ -131,10 +131,10 @@ BEGIN { if (! $useTempFile) { my $self = shift ; - foreach (@$self) - { + foreach (@$self) + { rmtree $_, {verbose => 0, safe => 1} - if -d $_ ; + if -d $_ ; } } } @@ -150,15 +150,15 @@ sub readFile { my $pos = tell($f); seek($f, 0,0); - @strings = <$f> ; + @strings = <$f> ; seek($f, 0, $pos); } else { - open (F, "<$f") + open (F, "<$f") or croak "Cannot open $f: $!\n" ; binmode F; - @strings = ; + @strings = ; close F ; } @@ -175,7 +175,7 @@ sub writeFile { my($filename, @strings) = @_ ; 1 while unlink $filename ; - open (F, ">$filename") + open (F, ">$filename") or croak "Cannot open $filename: $!\n" ; binmode F; foreach (@strings) { @@ -191,10 +191,10 @@ sub GZreadFile my ($uncomp) = "" ; my $line = "" ; - my $fil = gzopen($filename, "rb") + my $fil = gzopen($filename, "rb") or croak "Cannopt open '$filename': $Compress::Zlib::gzerrno" ; - $uncomp .= $line + $uncomp .= $line while $fil->gzread($line) > 0; $fil->gzclose ; @@ -248,7 +248,7 @@ sub readHeaderInfo some text EOM - ok my $x = new IO::Compress::Gzip $name, %opts + ok my $x = new IO::Compress::Gzip $name, %opts or diag "GzipError is $IO::Compress::Gzip::GzipError" ; ok $x->write($string) ; ok $x->close ; @@ -562,9 +562,9 @@ sub anyUncompress } my $out = ''; - my $o = new IO::Uncompress::AnyUncompress \$data, - Append => 1, - Transparent => 0, + my $o = new IO::Uncompress::AnyUncompress \$data, + Append => 1, + Transparent => 0, RawInflate => 1, UnLzma => 1, @opts @@ -622,10 +622,10 @@ sub getHeaders } my $out = ''; - my $o = new IO::Uncompress::AnyUncompress \$data, - MultiStream => 1, - Append => 1, - Transparent => 0, + my $o = new IO::Uncompress::AnyUncompress \$data, + MultiStream => 1, + Append => 1, + Transparent => 0, RawInflate => 1, UnLzma => 1, @opts diff --git a/cpan/Compress-Raw-Zlib/typemap b/cpan/Compress-Raw-Zlib/typemap index 36fce4aa94f0..cf73c737c15c 100644 --- a/cpan/Compress-Raw-Zlib/typemap +++ b/cpan/Compress-Raw-Zlib/typemap @@ -41,7 +41,6 @@ T_PTROBJ_AV else if (sv_derived_from($arg, \"${ntype}\")) { IV tmp = SvIV(getInnerObject($arg)) ; $var = INT2PTR($type, tmp); - } else croak(\"$var is not of type ${ntype}\") @@ -58,5 +57,3 @@ T_DUAL T_PV sv_setpv((SV*)$arg, $var); - - diff --git a/cpan/Config-Perl-V/V.pm b/cpan/Config-Perl-V/V.pm index dbb0f88ec157..774446a83f66 100644 --- a/cpan/Config-Perl-V/V.pm +++ b/cpan/Config-Perl-V/V.pm @@ -6,12 +6,12 @@ use warnings; use Config; use Exporter; use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS); -$VERSION = "0.32"; +$VERSION = "0.33"; @ISA = qw( Exporter ); @EXPORT_OK = qw( plv2hash summary myconfig signature ); %EXPORT_TAGS = ( - all => [ @EXPORT_OK ], - sig => [ "signature" ], + 'all' => [ @EXPORT_OK ], + 'sig' => [ "signature" ], ); # Characteristics of this binary (from libperl): @@ -24,7 +24,7 @@ $VERSION = "0.32"; # perl -ne'(/^S_Internals_V/../^}/)&&s/^\s+"( .*)"/$1/ and print' perl.c # perl.h line 4566 PL_bincompat_options # perl -ne'(/^\w.*PL_bincompat/../^\w}/)&&s/^\s+"( .*)"/$1/ and print' perl.h -my %BTD = map { $_ => 0 } qw( +my %BTD = map {( $_ => 0 )} qw( DEBUGGING NO_HASH_SEED @@ -183,52 +183,52 @@ my @config_vars = qw( ); my %empty_build = ( - osname => "", - stamp => 0, - options => { %BTD }, - patches => [], + 'osname' => "", + 'stamp' => 0, + 'options' => { %BTD }, + 'patches' => [], ); sub _make_derived { my $conf = shift; - for ( [ lseektype => "Off_t" ], - [ myuname => "uname" ], - [ perl_patchlevel => "patch" ], + for ( [ 'lseektype' => "Off_t" ], + [ 'myuname' => "uname" ], + [ 'perl_patchlevel' => "patch" ], ) { - my ($official, $derived) = @$_; - $conf->{config}{$derived} ||= $conf->{config}{$official}; - $conf->{config}{$official} ||= $conf->{config}{$derived}; - $conf->{derived}{$derived} = delete $conf->{config}{$derived}; + my ($official, $derived) = @{$_}; + $conf->{'config'}{$derived} ||= $conf->{'config'}{$official}; + $conf->{'config'}{$official} ||= $conf->{'config'}{$derived}; + $conf->{'derived'}{$derived} = delete $conf->{'config'}{$derived}; } - if (exists $conf->{config}{version_patchlevel_string} && - !exists $conf->{config}{api_version}) { - my $vps = $conf->{config}{version_patchlevel_string}; + if (exists $conf->{'config'}{'version_patchlevel_string'} && + !exists $conf->{'config'}{'api_version'}) { + my $vps = $conf->{'config'}{'version_patchlevel_string'}; $vps =~ s{\b revision \s+ (\S+) }{}x and - $conf->{config}{revision} ||= $1; + $conf->{'config'}{'revision'} ||= $1; $vps =~ s{\b version \s+ (\S+) }{}x and - $conf->{config}{api_version} ||= $1; + $conf->{'config'}{'api_version'} ||= $1; $vps =~ s{\b subversion \s+ (\S+) }{}x and - $conf->{config}{subversion} ||= $1; + $conf->{'config'}{'subversion'} ||= $1; $vps =~ s{\b patch \s+ (\S+) }{}x and - $conf->{config}{perl_patchlevel} ||= $1; + $conf->{'config'}{'perl_patchlevel'} ||= $1; } - ($conf->{config}{version_patchlevel_string} ||= join " ", - map { ($_, $conf->{config}{$_} ) } - grep { $conf->{config}{$_} } + ($conf->{'config'}{'version_patchlevel_string'} ||= join " ", + map { ($_, $conf->{'config'}{$_} ) } + grep { $conf->{'config'}{$_} } qw( api_version subversion perl_patchlevel )) =~ s/\bperl_//; - $conf->{config}{perl_patchlevel} ||= ""; # 0 is not a valid patchlevel + $conf->{'config'}{'perl_patchlevel'} ||= ""; # 0 is not a valid patchlevel - if ($conf->{config}{perl_patchlevel} =~ m{^git\w*-([^-]+)}i) { - $conf->{config}{git_branch} ||= $1; - $conf->{config}{git_describe} ||= $conf->{config}{perl_patchlevel}; + if ($conf->{'config'}{'perl_patchlevel'} =~ m{^git\w*-([^-]+)}i) { + $conf->{'config'}{'git_branch'} ||= $1; + $conf->{'config'}{'git_describe'} ||= $conf->{'config'}{'perl_patchlevel'}; } - $conf->{config}{$_} ||= "undef" for grep m/^(?:use|def)/ => @config_vars; + $conf->{'config'}{$_} ||= "undef" for grep m{^(?:use|def)} => @config_vars; $conf; } # _make_derived @@ -238,20 +238,20 @@ sub plv2hash { my $pv = join "\n" => @_; - if ($pv =~ m/^Summary of my\s+(\S+)\s+\(\s*(.*?)\s*\)/m) { - $config{"package"} = $1; + if ($pv =~ m{^Summary of my\s+(\S+)\s+\(\s*(.*?)\s*\)}m) { + $config{'package'} = $1; my $rev = $2; - $rev =~ s/^ revision \s+ (\S+) \s*//x and $config{revision} = $1; - $rev and $config{version_patchlevel_string} = $rev; - my ($rel) = $config{"package"} =~ m{perl(\d)}; + $rev =~ s/^ revision \s+ (\S+) \s*//x and $config{'revision'} = $1; + $rev and $config{'version_patchlevel_string'} = $rev; + my ($rel) = $config{'package'} =~ m{perl(\d)}; my ($vers, $subvers) = $rev =~ m{version\s+(\d+)\s+subversion\s+(\d+)}; defined $vers && defined $subvers && defined $rel and - $config{version} = "$rel.$vers.$subvers"; + $config{'version'} = "$rel.$vers.$subvers"; } - if ($pv =~ m/^\s+(Snapshot of:)\s+(\S+)/) { - $config{git_commit_id_title} = $1; - $config{git_commit_id} = $2; + if ($pv =~ m{^\s+(Snapshot of:)\s+(\S+)}) { + $config{'git_commit_id_title'} = $1; + $config{'git_commit_id'} = $2; } # these are always last on line and can have multiple quotation styles @@ -275,11 +275,11 @@ sub plv2hash { }gx)) { # between every kv pair while (my ($k, $v) = each %kv) { - $k =~ s/\s+$//; - $v =~ s/\s*\n\z//; - $v =~ s/,$//; - $v =~ m/^'(.*)'$/ and $v = $1; - $v =~ s/\s+$//; + $k =~ s{\s+$} {}; + $v =~ s{\s*\n\z} {}; + $v =~ s{,$} {}; + $v =~ m{^'(.*)'$} and $v = $1; + $v =~ s{\s+$} {}; $config{$k} = $v; } } @@ -287,36 +287,36 @@ sub plv2hash { my $build = { %empty_build }; $pv =~ m{^\s+Compiled at\s+(.*)}m - and $build->{stamp} = $1; + and $build->{'stamp'} = $1; $pv =~ m{^\s+Locally applied patches:(?:\s+|\n)(.*?)(?:[\s\n]+Buil[td] under)}ms - and $build->{patches} = [ split m/\n+\s*/, $1 ]; + and $build->{'patches'} = [ split m{\n+\s*}, $1 ]; $pv =~ m{^\s+Compile-time options:(?:\s+|\n)(.*?)(?:[\s\n]+(?:Locally applied|Buil[td] under))}ms - and map { $build->{options}{$_} = 1 } split m/\s+|\n/ => $1; + and map { $build->{'options'}{$_} = 1 } split m{\s+|\n} => $1; - $build->{osname} = $config{osname}; + $build->{'osname'} = $config{'osname'}; $pv =~ m{^\s+Built under\s+(.*)}m - and $build->{osname} = $1; - $config{osname} ||= $build->{osname}; + and $build->{'osname'} = $1; + $config{'osname'} ||= $build->{'osname'}; return _make_derived ({ - build => $build, - environment => {}, - config => \%config, - derived => {}, - inc => [], + 'build' => $build, + 'environment' => {}, + 'config' => \%config, + 'derived' => {}, + 'inc' => [], }); } # plv2hash sub summary { my $conf = shift || myconfig (); ref $conf eq "HASH" - && exists $conf->{config} - && exists $conf->{build} - && ref $conf->{config} eq "HASH" - && ref $conf->{build} eq "HASH" or return; + && exists $conf->{'config'} + && exists $conf->{'build'} + && ref $conf->{'config'} eq "HASH" + && ref $conf->{'build'} eq "HASH" or return; my %info = map { - exists $conf->{config}{$_} ? ( $_ => $conf->{config}{$_} ) : () } + exists $conf->{'config'}{$_} ? ( $_ => $conf->{'config'}{$_} ) : () } qw( archname osname osvers revision patchlevel subversion version cc ccversion gccversion config_args inc_version_list d_longdbl d_longlong use64bitall use64bitint useithreads @@ -324,7 +324,7 @@ sub summary { doublesize intsize ivsize nvsize longdblsize longlongsize lseeksize default_inc_excludes_dot ); - $info{$_}++ for grep { $conf->{build}{options}{$_} } keys %{$conf->{build}{options}}; + $info{$_}++ for grep { $conf->{'build'}{'options'}{$_} } keys %{$conf->{'build'}{'options'}}; return \%info; } # summary @@ -336,19 +336,19 @@ sub signature { eval { require Digest::MD5 }; $@ and return $no_md5; - $conf->{cc} =~ s{.*\bccache\s+}{}; - $conf->{cc} =~ s{.*[/\\]}{}; + $conf->{'cc'} =~ s{.*\bccache\s+}{}; + $conf->{'cc'} =~ s{.*[/\\]}{}; - delete $conf->{config_args}; + delete $conf->{'config_args'}; return Digest::MD5::md5_hex (join "\xFF" => map { "$_=".(defined $conf->{$_} ? $conf->{$_} : "\xFE"); - } sort keys %$conf); + } sort keys %{$conf}); } # signature sub myconfig { my $args = shift; - my %args = ref $args eq "HASH" ? %$args : - ref $args eq "ARRAY" ? @$args : (); + my %args = ref $args eq "HASH" ? %{$args} : + ref $args eq "ARRAY" ? @{$args} : (); my $build = { %empty_build }; @@ -356,33 +356,34 @@ sub myconfig { my $stamp = eval { Config::compile_date () }; if (defined $stamp) { $stamp =~ s/^Compiled at //; - $build->{osname} = $^O; - $build->{stamp} = $stamp; - $build->{patches} = [ Config::local_patches () ]; - $build->{options}{$_} = 1 for Config::bincompat_options (), - Config::non_bincompat_options (); + $build->{'osname'} = $^O; + $build->{'stamp'} = $stamp; + $build->{'patches'} = [ Config::local_patches () ]; + $build->{'options'}{$_} = 1 for Config::bincompat_options (), + Config::non_bincompat_options (); } else { #y $pv = qx[$^X -e"sub Config::myconfig{};" -V]; my $cnf = plv2hash (qx[$^X -V]); - $build->{$_} = $cnf->{build}{$_} for qw( osname stamp patches options ); + $build->{$_} = $cnf->{'build'}{$_} for qw( osname stamp patches options ); } my @KEYS = keys %ENV; my %env = - map { $_ => $ENV{$_} } grep m/^PERL/ => @KEYS; - $args{env} and - map { $env{$_} = $ENV{$_} } grep m{$args{env}} => @KEYS; + map {( $_ => $ENV{$_} )} grep m{^PERL} => @KEYS; + if ($args{'env'}) { + $env{$_} = $ENV{$_} for grep m{$args{'env'}} => @KEYS; + } my %config = map { $_ => $Config{$_} } @config_vars; return _make_derived ({ - build => $build, - environment => \%env, - config => \%config, - derived => {}, - inc => \@INC, + 'build' => $build, + 'environment' => \%env, + 'config' => \%config, + 'derived' => {}, + 'inc' => \@INC, }); } # myconfig @@ -553,7 +554,7 @@ H.Merijn Brand =head1 COPYRIGHT AND LICENSE -Copyright (C) 2009-2018 H.Merijn Brand +Copyright (C) 2009-2020 H.Merijn Brand This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Config-Perl-V/t/35_plv52910g.t b/cpan/Config-Perl-V/t/35_plv52910g.t new file mode 100644 index 000000000000..6d822d1cb280 --- /dev/null +++ b/cpan/Config-Perl-V/t/35_plv52910g.t @@ -0,0 +1,188 @@ +#!/pro/bin/perl + +use strict; +use warnings; + +BEGIN { + use Test::More; + my $tests = 128; + unless ($ENV{PERL_CORE}) { + require Test::NoWarnings; + Test::NoWarnings->import (); + $tests++; + } + + plan tests => $tests; + } + +use Config::Perl::V qw( summary ); + +ok (my $conf = Config::Perl::V::plv2hash (), "Read perl -v block"); +ok (exists $conf->{$_}, "Has $_ entry") for qw( build environment config inc ); + +is ($conf->{build}{osname}, $conf->{config}{osname}, "osname"); +is ($conf->{build}{stamp}, "Apr 13 2019 00:06:38", "Build time"); +is ($conf->{config}{version}, "5.29.10", "reconstructed \$Config{version}"); + +my $opt = Config::Perl::V::plv2hash ("")->{build}{options}; +foreach my $o (sort qw( + DEBUGGING HAS_TIMES MULTIPLICITY PERL_COPY_ON_WRITE PERL_DONT_CREATE_GVSV + PERL_IMPLICIT_CONTEXT PERLIO_LAYERS PERL_MALLOC_WRAP PERL_OP_PARENT + PERL_PRESERVE_IVUV PERL_TRACK_MEMPOOL PERL_USE_DEVEL USE_64_BIT_ALL + USE_64_BIT_INT USE_ITHREADS USE_LARGE_FILES USE_LOCALE USE_LOCALE_COLLATE + USE_LOCALE_CTYPE USE_LOCALE_NUMERIC USE_LOCALE_TIME USE_LONG_DOUBLE + USE_PERL_ATOF USE_PERLIO USE_REENTRANT_API USE_THREAD_SAFE_LOCALE + )) { + is ($conf->{build}{options}{$o}, 1, "Runtime option $o set"); + delete $opt->{$o}; + } +foreach my $o (sort keys %$opt) { + is ($conf->{build}{options}{$o}, 0, "Runtime option $o unset"); + } + +eval { require Digest::MD5; }; +my $md5 = $@ ? "0" x 32 : "8404b533829bd9752df7f662a710f993"; +ok (my $sig = Config::Perl::V::signature ($conf), "Get signature"); +is ($sig, $md5, "MD5"); + +is_deeply ($conf->{build}{patches}, [ + "SMOKEdfba4714a9dc4c35123b4df0a5e1721ccb081d97" ], "No local patches"); + +my %check = ( + alignbytes => 16, + api_version => 29, + bincompat5005 => "undef", + byteorder => 12345678, + cc => "g++", + cccdlflags => "-fPIC", + ccdlflags => "-Wl,-E", + config_args => "-des -Dcc=g++ -Dusedevel -Duseithreads -Duse64bitall -Duselongdouble -DDEBUGGING", + gccversion => "8.3.1 20190226 [gcc-8-branch revision 269204]", + gnulibc_version => "2.29", + ivsize => 8, + ivtype => "long", + ld => "g++", + lddlflags => "-shared -O2 -g -L/pro/local/lib -fstack-protector-strong", + ldflags => "-L/pro/local/lib -fstack-protector-strong", + libc => "libc-2.29.so", + lseektype => "off_t", + osvers => "5.0.7-1-default", + use64bitall => "define", + use64bitint => "define", + usemymalloc => "n", + default_inc_excludes_dot + => "define", + ); +is ($conf->{config}{$_}, $check{$_}, "reconstructed \$Config{$_}") for sort keys %check; + +ok (my $info = summary ($conf), "A summary"); +ok (exists $info->{$_}, "Summary has $_") for qw( cc config_args usemymalloc default_inc_excludes_dot ); +is ($info->{default_inc_excludes_dot}, "define", "This build has . NOT in INC"); + +__END__ +Summary of my perl5 (revision 5 version 29 subversion 10) configuration: + Snapshot of: dfba4714a9dc4c35123b4df0a5e1721ccb081d97 + Platform: + osname=linux + osvers=5.0.7-1-default + archname=x86_64-linux-thread-multi-ld + uname='linux lx09 5.0.7-1-default #1 smp sat apr 6 14:47:49 utc 2019 (8f18342) x86_64 x86_64 x86_64 gnulinux ' + config_args='-des -Dcc=g++ -Dusedevel -Duseithreads -Duse64bitall -Duselongdouble -DDEBUGGING' + hint=recommended + useposix=true + d_sigaction=define + useithreads=define + usemultiplicity=define + use64bitint=define + use64bitall=define + uselongdouble=define + usemymalloc=n + default_inc_excludes_dot=define + bincompat5005=undef + Compiler: + cc='g++' + ccflags ='-D_REENTRANT -D_GNU_SOURCE -fPIC -DDEBUGGING -fwrapv -DDEBUGGING -fno-strict-aliasing -pipe -fstack-protector-strong -I/pro/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -D_FORTIFY_SOURCE=2' + optimize='-O2 -g' + cppflags='-D_REENTRANT -D_GNU_SOURCE -fPIC -DDEBUGGING -fwrapv -DDEBUGGING -fno-strict-aliasing -pipe -fstack-protector-strong -I/pro/local/include' + ccversion='' + gccversion='8.3.1 20190226 [gcc-8-branch revision 269204]' + gccosandvers='' + intsize=4 + longsize=8 + ptrsize=8 + doublesize=8 + byteorder=12345678 + doublekind=3 + d_longlong=define + longlongsize=8 + d_longdbl=define + longdblsize=16 + longdblkind=3 + ivtype='long' + ivsize=8 + nvtype='long double' + nvsize=16 + Off_t='off_t' + lseeksize=8 + alignbytes=16 + prototype=define + Linker and Libraries: + ld='g++' + ldflags ='-L/pro/local/lib -fstack-protector-strong' + libpth=/usr/include/c++/8 /usr/include/c++/8/x86_64-suse-linux /usr/include/c++/8/backward /usr/local/lib /usr/lib64/gcc/x86_64-suse-linux/8/include-fixed /usr/lib64/gcc/x86_64-suse-linux/8/../../../../x86_64-suse-linux/lib /usr/lib /pro/local/lib /lib/../lib64 /usr/lib/../lib64 /lib /lib64 /usr/lib64 /usr/local/lib64 + libs=-lpthread -lnsl -lgdbm -ldb -ldl -lm -lcrypt -lutil -lc -lgdbm_compat + perllibs=-lpthread -lnsl -ldl -lm -lcrypt -lutil -lc + libc=libc-2.29.so + so=so + useshrplib=false + libperl=libperl.a + gnulibc_version='2.29' + Dynamic Linking: + dlsrc=dl_dlopen.xs + dlext=so + d_dlsymun=undef + ccdlflags='-Wl,-E' + cccdlflags='-fPIC' + lddlflags='-shared -O2 -g -L/pro/local/lib -fstack-protector-strong' + + +Characteristics of this binary (from libperl): + Compile-time options: + DEBUGGING + HAS_TIMES + MULTIPLICITY + PERLIO_LAYERS + PERL_COPY_ON_WRITE + PERL_DONT_CREATE_GVSV + PERL_IMPLICIT_CONTEXT + PERL_MALLOC_WRAP + PERL_OP_PARENT + PERL_PRESERVE_IVUV + PERL_TRACK_MEMPOOL + PERL_USE_DEVEL + USE_64_BIT_ALL + USE_64_BIT_INT + USE_ITHREADS + USE_LARGE_FILES + USE_LOCALE + USE_LOCALE_COLLATE + USE_LOCALE_CTYPE + USE_LOCALE_NUMERIC + USE_LOCALE_TIME + USE_LONG_DOUBLE + USE_PERLIO + USE_PERL_ATOF + USE_REENTRANT_API + USE_THREAD_SAFE_LOCALE + Locally applied patches: + SMOKEdfba4714a9dc4c35123b4df0a5e1721ccb081d97 + Built under linux + Compiled at Apr 13 2019 00:06:38 + %ENV: + PERL6LIB="inst#/pro/3gl/CPAN/rakudo/install" + @INC: + lib + /opt/perl/lib/site_perl/5.29.10/x86_64-linux-thread-multi-ld + /opt/perl/lib/site_perl/5.29.10 + /opt/perl/lib/5.29.10/x86_64-linux-thread-multi-ld + /opt/perl/lib/5.29.10 diff --git a/cpan/Config-Perl-V/t/36_plv5300.t b/cpan/Config-Perl-V/t/36_plv5300.t new file mode 100644 index 000000000000..6db751245f3c --- /dev/null +++ b/cpan/Config-Perl-V/t/36_plv5300.t @@ -0,0 +1,182 @@ +#!/pro/bin/perl + +use strict; +use warnings; + +BEGIN { + use Test::More; + my $tests = 128; + unless ($ENV{PERL_CORE}) { + require Test::NoWarnings; + Test::NoWarnings->import (); + $tests++; + } + + plan tests => $tests; + } + +use Config::Perl::V qw( summary ); + +ok (my $conf = Config::Perl::V::plv2hash (), "Read perl -v block"); +ok (exists $conf->{$_}, "Has $_ entry") for qw( build environment config inc ); + +is ($conf->{build}{osname}, $conf->{config}{osname}, "osname"); +is ($conf->{build}{stamp}, "May 23 2019 14:05:36", "Build time"); +is ($conf->{config}{version}, "5.30.0", "reconstructed \$Config{version}"); + +my $opt = Config::Perl::V::plv2hash ("")->{build}{options}; +foreach my $o (sort qw( + HAS_TIMES MULTIPLICITY PERLIO_LAYERS PERL_COPY_ON_WRITE + PERL_DONT_CREATE_GVSV PERL_IMPLICIT_CONTEXT PERL_MALLOC_WRAP + PERL_OP_PARENT PERL_PRESERVE_IVUV USE_THREAD_SAFE_LOCALE + USE_64_BIT_ALL USE_64_BIT_INT USE_ITHREADS USE_LARGE_FILES + USE_LOCALE USE_LOCALE_COLLATE USE_LOCALE_CTYPE USE_LOCALE_NUMERIC + USE_LOCALE_TIME USE_LONG_DOUBLE USE_PERLIO USE_PERL_ATOF + USE_REENTRANT_API + )) { + is ($conf->{build}{options}{$o}, 1, "Runtime option $o set"); + delete $opt->{$o}; + } +foreach my $o (sort keys %$opt) { + is ($conf->{build}{options}{$o}, 0, "Runtime option $o unset"); + } + +eval { require Digest::MD5; }; +my $md5 = $@ ? "0" x 32 : "b1138522685da4fff74f7b1118128d02"; +ok (my $sig = Config::Perl::V::signature ($conf), "Get signature"); +is ($sig, $md5, "MD5"); + +is_deeply ($conf->{build}{patches}, [ ], "No patches"); + +my %check = ( + alignbytes => 16, + api_version => 30, + bincompat5005 => "undef", + byteorder => 12345678, + cc => "cc", + cccdlflags => "-fPIC", + ccdlflags => "-Wl,-E -Wl,-rpath,/pro/lib/perl5/5.30.0/x86_64-linux-thread-multi-ld/CORE", + config_args => "-Dusethreads -Duseithreads -Duse64bitall -Duselongdouble -Duseshrplib -des", + gccversion => "8.3.1 20190226 [gcc-8-branch revision 269204]", + gnulibc_version => "2.29", + ivsize => 8, + ivtype => "long", + ld => "cc", + lddlflags => "-shared -O2 -L/pro/local/lib -fstack-protector-strong", + ldflags => "-L/pro/local/lib -fstack-protector-strong", + libc => "libc-2.29.so", + lseektype => "off_t", + osvers => "5.1.3-1-default", + use64bitall => "define", + use64bitint => "define", + usemymalloc => "n", + default_inc_excludes_dot + => "define", + ); +is ($conf->{config}{$_}, $check{$_}, "reconstructed \$Config{$_}") for sort keys %check; + +ok (my $info = summary ($conf), "A summary"); +ok (exists $info->{$_}, "Summary has $_") for qw( cc config_args usemymalloc default_inc_excludes_dot ); +is ($info->{default_inc_excludes_dot}, "define", "This build has . NOT in INC"); + +__END__ +Summary of my perl5 (revision 5 version 30 subversion 0) configuration: + + Platform: + osname=linux + osvers=5.1.3-1-default + archname=x86_64-linux-thread-multi-ld + uname='linux lx09 5.1.3-1-default #1 smp fri may 17 04:54:29 utc 2019 (07d2e25) x86_64 x86_64 x86_64 gnulinux ' + config_args='-Dusethreads -Duseithreads -Duse64bitall -Duselongdouble -Duseshrplib -des' + hint=recommended + useposix=true + d_sigaction=define + useithreads=define + usemultiplicity=define + use64bitint=define + use64bitall=define + uselongdouble=define + usemymalloc=n + default_inc_excludes_dot=define + bincompat5005=undef + Compiler: + cc='cc' + ccflags ='-D_REENTRANT -D_GNU_SOURCE -fPIC -fwrapv -fno-strict-aliasing -pipe -fstack-protector-strong -I/pro/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -D_FORTIFY_SOURCE=2' + optimize='-O2' + cppflags='-D_REENTRANT -D_GNU_SOURCE -fPIC -fwrapv -fno-strict-aliasing -pipe -fstack-protector-strong -I/pro/local/include' + ccversion='' + gccversion='8.3.1 20190226 [gcc-8-branch revision 269204]' + gccosandvers='' + intsize=4 + longsize=8 + ptrsize=8 + doublesize=8 + byteorder=12345678 + doublekind=3 + d_longlong=define + longlongsize=8 + d_longdbl=define + longdblsize=16 + longdblkind=3 + ivtype='long' + ivsize=8 + nvtype='long double' + nvsize=16 + Off_t='off_t' + lseeksize=8 + alignbytes=16 + prototype=define + Linker and Libraries: + ld='cc' + ldflags ='-L/pro/local/lib -fstack-protector-strong' + libpth=/usr/local/lib /usr/lib64/gcc/x86_64-suse-linux/8/include-fixed /usr/lib64/gcc/x86_64-suse-linux/8/../../../../x86_64-suse-linux/lib /usr/lib /pro/local/lib /lib/../lib64 /usr/lib/../lib64 /lib /lib64 /usr/lib64 /usr/local/lib64 + libs=-lpthread -lnsl -lgdbm -ldb -ldl -lm -lcrypt -lutil -lc -lgdbm_compat + perllibs=-lpthread -lnsl -ldl -lm -lcrypt -lutil -lc + libc=libc-2.29.so + so=so + useshrplib=true + libperl=libperl.so + gnulibc_version='2.29' + Dynamic Linking: + dlsrc=dl_dlopen.xs + dlext=so + d_dlsymun=undef + ccdlflags='-Wl,-E -Wl,-rpath,/pro/lib/perl5/5.30.0/x86_64-linux-thread-multi-ld/CORE' + cccdlflags='-fPIC' + lddlflags='-shared -O2 -L/pro/local/lib -fstack-protector-strong' + + +Characteristics of this binary (from libperl): + Compile-time options: + HAS_TIMES + MULTIPLICITY + PERLIO_LAYERS + PERL_COPY_ON_WRITE + PERL_DONT_CREATE_GVSV + PERL_IMPLICIT_CONTEXT + PERL_MALLOC_WRAP + PERL_OP_PARENT + PERL_PRESERVE_IVUV + USE_64_BIT_ALL + USE_64_BIT_INT + USE_ITHREADS + USE_LARGE_FILES + USE_LOCALE + USE_LOCALE_COLLATE + USE_LOCALE_CTYPE + USE_LOCALE_NUMERIC + USE_LOCALE_TIME + USE_LONG_DOUBLE + USE_PERLIO + USE_PERL_ATOF + USE_REENTRANT_API + USE_THREAD_SAFE_LOCALE + Built under linux + Compiled at May 23 2019 14:05:36 + %ENV: + PERL6LIB="inst#/pro/3gl/CPAN/rakudo/install" + @INC: + /pro/lib/perl5/site_perl/5.30.0/x86_64-linux-thread-multi-ld + /pro/lib/perl5/site_perl/5.30.0 + /pro/lib/perl5/5.30.0/x86_64-linux-thread-multi-ld + /pro/lib/perl5/5.30.0 diff --git a/cpan/Config-Perl-V/t/37_plv53111qm.t b/cpan/Config-Perl-V/t/37_plv53111qm.t new file mode 100644 index 000000000000..f566f7607b27 --- /dev/null +++ b/cpan/Config-Perl-V/t/37_plv53111qm.t @@ -0,0 +1,186 @@ +#!/pro/bin/perl + +use strict; +use warnings; + +BEGIN { + use Test::More; + my $tests = 128; + unless ($ENV{PERL_CORE}) { + require Test::NoWarnings; + Test::NoWarnings->import (); + $tests++; + } + + plan tests => $tests; + } + +use Config::Perl::V qw( summary ); + +ok (my $conf = Config::Perl::V::plv2hash (), "Read perl -v block"); +ok (exists $conf->{$_}, "Has $_ entry") for qw( build environment config inc ); + +is ($conf->{build}{osname}, $conf->{config}{osname}, "osname"); +is ($conf->{build}{stamp}, "Apr 9 2020 17:12:07", "Build time"); +is ($conf->{config}{version}, "5.31.11", "reconstructed \$Config{version}"); + +my $opt = Config::Perl::V::plv2hash ("")->{build}{options}; +foreach my $o (sort qw( + DEBUGGING HAS_TIMES MULTIPLICITY PERL_COPY_ON_WRITE + PERL_DONT_CREATE_GVSV PERL_IMPLICIT_CONTEXT PERLIO_LAYERS + PERL_MALLOC_WRAP PERL_OP_PARENT PERL_PRESERVE_IVUV PERL_TRACK_MEMPOOL + PERL_USE_DEVEL USE_64_BIT_ALL USE_64_BIT_INT USE_ITHREADS + USE_LARGE_FILES USE_LOCALE USE_LOCALE_COLLATE USE_LOCALE_CTYPE + USE_LOCALE_NUMERIC USE_LOCALE_TIME USE_PERL_ATOF USE_PERLIO + USE_QUADMATH USE_REENTRANT_API USE_THREAD_SAFE_LOCALE + )) { + is ($conf->{build}{options}{$o}, 1, "Runtime option $o set"); + delete $opt->{$o}; + } +foreach my $o (sort keys %$opt) { + is ($conf->{build}{options}{$o}, 0, "Runtime option $o unset"); + } + +eval { require Digest::MD5; }; +my $md5 = $@ ? "0" x 32 : "146e648c6239f623b8a8242fc8b5759f"; +ok (my $sig = Config::Perl::V::signature ($conf), "Get signature"); +is ($sig, $md5, "MD5"); + +is_deeply ($conf->{build}{patches}, [ ], "No patches"); + +my %check = ( + alignbytes => 16, + api_version => 31, + bincompat5005 => "undef", + byteorder => 12345678, + cc => "cc", + cccdlflags => "-fPIC", + ccdlflags => "-Wl,-E", + config_args => "-Dusedevel -Duse64bitall -Dusethreads -Duseithreads -Dusequadmath -des", + gccversion => "10.0.1 20200302 (experimental) [revision 778a77357cad11e8dd4c810544330af0fbe843b1]", + gnulibc_version => "2.31", + ivsize => 8, + ivtype => "long", + ld => "cc", + lddlflags => "-shared -O2 -L/pro/local/lib -fstack-protector-strong", + ldflags => "-L/pro/local/lib -fstack-protector-strong", + libc => "libc-2.31.so", + lseektype => "off_t", + osvers => "5.6.2-1-default", + use64bitall => "define", + use64bitint => "define", + usemymalloc => "n", + default_inc_excludes_dot + => "define", + ); +is ($conf->{config}{$_}, $check{$_}, "reconstructed \$Config{$_}") for sort keys %check; + +ok (my $info = summary ($conf), "A summary"); +ok (exists $info->{$_}, "Summary has $_") for qw( cc config_args usemymalloc default_inc_excludes_dot ); +is ($info->{default_inc_excludes_dot}, "define", "This build has . NOT in INC"); + +__END__ +Summary of my perl5 (revision 5 version 31 subversion 11) configuration: + Snapshot of: +0300 + Platform: + osname=linux + osvers=5.6.2-1-default + archname=x86_64-linux-thread-multi-quadmath + uname='linux lx09 5.6.2-1-default #1 smp thu apr 2 06:31:32 utc 2020 (c8170d6) x86_64 x86_64 x86_64 gnulinux ' + config_args='-Dusedevel -Duse64bitall -Dusethreads -Duseithreads -Dusequadmath -des' + hint=recommended + useposix=true + d_sigaction=define + useithreads=define + usemultiplicity=define + use64bitint=define + use64bitall=define + uselongdouble=undef + usemymalloc=n + default_inc_excludes_dot=define + bincompat5005=undef + Compiler: + cc='cc' + ccflags ='-D_REENTRANT -D_GNU_SOURCE -fPIC -DDEBUGGING -fwrapv -fno-strict-aliasing -pipe -fstack-protector-strong -I/pro/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -D_FORTIFY_SOURCE=2' + optimize='-O2' + cppflags='-D_REENTRANT -D_GNU_SOURCE -fPIC -DDEBUGGING -fwrapv -fno-strict-aliasing -pipe -fstack-protector-strong -I/pro/local/include' + ccversion='' + gccversion='10.0.1 20200302 (experimental) [revision 778a77357cad11e8dd4c810544330af0fbe843b1]' + gccosandvers='' + intsize=4 + longsize=8 + ptrsize=8 + doublesize=8 + byteorder=12345678 + doublekind=3 + d_longlong=define + longlongsize=8 + d_longdbl=define + longdblsize=16 + longdblkind=3 + ivtype='long' + ivsize=8 + nvtype='__float128' + nvsize=16 + Off_t='off_t' + lseeksize=8 + alignbytes=16 + prototype=define + Linker and Libraries: + ld='cc' + ldflags ='-L/pro/local/lib -fstack-protector-strong' + libpth=/usr/local/lib /usr/lib64/gcc/x86_64-suse-linux/10/include-fixed /usr/lib64/gcc/x86_64-suse-linux/10/../../../../x86_64-suse-linux/lib /usr/lib /pro/local/lib /lib/../lib64 /usr/lib/../lib64 /lib /lib64 /usr/lib64 /usr/local/lib64 + libs=-lpthread -lnsl -lgdbm -ldb -ldl -lm -lcrypt -lutil -lc -lgdbm_compat -lquadmath + perllibs=-lpthread -lnsl -ldl -lm -lcrypt -lutil -lc -lquadmath + libc=libc-2.31.so + so=so + useshrplib=false + libperl=libperl.a + gnulibc_version='2.31' + Dynamic Linking: + dlsrc=dl_dlopen.xs + dlext=so + d_dlsymun=undef + ccdlflags='-Wl,-E' + cccdlflags='-fPIC' + lddlflags='-shared -O2 -L/pro/local/lib -fstack-protector-strong' + + +Characteristics of this binary (from libperl): + Compile-time options: + DEBUGGING + HAS_TIMES + MULTIPLICITY + PERLIO_LAYERS + PERL_COPY_ON_WRITE + PERL_DONT_CREATE_GVSV + PERL_IMPLICIT_CONTEXT + PERL_MALLOC_WRAP + PERL_OP_PARENT + PERL_PRESERVE_IVUV + PERL_TRACK_MEMPOOL + PERL_USE_DEVEL + USE_64_BIT_ALL + USE_64_BIT_INT + USE_ITHREADS + USE_LARGE_FILES + USE_LOCALE + USE_LOCALE_COLLATE + USE_LOCALE_CTYPE + USE_LOCALE_NUMERIC + USE_LOCALE_TIME + USE_PERLIO + USE_PERL_ATOF + USE_QUADMATH + USE_REENTRANT_API + USE_THREAD_SAFE_LOCALE + Built under linux + Compiled at Apr 9 2020 17:12:07 + %ENV: + PERL6LIB="inst#/pro/3gl/CPAN/rakudo/install" + @INC: + lib + /pro/lib/perl5/site_perl/5.31.11/x86_64-linux-thread-multi-quadmath + /pro/lib/perl5/site_perl/5.31.11 + /pro/lib/perl5/5.31.11/x86_64-linux-thread-multi-quadmath + /pro/lib/perl5/5.31.11 diff --git a/cpan/Config-Perl-V/t/38_plv5320tld.t b/cpan/Config-Perl-V/t/38_plv5320tld.t new file mode 100644 index 000000000000..a8f0d736dc43 --- /dev/null +++ b/cpan/Config-Perl-V/t/38_plv5320tld.t @@ -0,0 +1,182 @@ +#!/pro/bin/perl + +use strict; +use warnings; + +BEGIN { + use Test::More; + my $tests = 128; + unless ($ENV{PERL_CORE}) { + require Test::NoWarnings; + Test::NoWarnings->import (); + $tests++; + } + + plan tests => $tests; + } + +use Config::Perl::V qw( summary ); + +ok (my $conf = Config::Perl::V::plv2hash (), "Read perl -v block"); +ok (exists $conf->{$_}, "Has $_ entry") for qw( build environment config inc ); + +is ($conf->{build}{osname}, $conf->{config}{osname}, "osname"); +is ($conf->{build}{stamp}, "Jun 21 2020 10:17:00", "Build time"); +is ($conf->{config}{version}, "5.32.0", "reconstructed \$Config{version}"); + +my $opt = Config::Perl::V::plv2hash ("")->{build}{options}; +foreach my $o (sort qw( + HAS_TIMES MULTIPLICITY PERLIO_LAYERS PERL_COPY_ON_WRITE + PERL_DONT_CREATE_GVSV PERL_IMPLICIT_CONTEXT PERL_MALLOC_WRAP + PERL_OP_PARENT PERL_PRESERVE_IVUV USE_THREAD_SAFE_LOCALE + USE_64_BIT_ALL USE_64_BIT_INT USE_ITHREADS USE_LARGE_FILES + USE_LOCALE USE_LOCALE_COLLATE USE_LOCALE_CTYPE USE_LOCALE_NUMERIC + USE_LOCALE_TIME USE_LONG_DOUBLE USE_PERLIO USE_PERL_ATOF + USE_REENTRANT_API + )) { + is ($conf->{build}{options}{$o}, 1, "Runtime option $o set"); + delete $opt->{$o}; + } +foreach my $o (sort keys %$opt) { + is ($conf->{build}{options}{$o}, 0, "Runtime option $o unset"); + } + +eval { require Digest::MD5; }; +my $md5 = $@ ? "0" x 32 : "901df8463a7bda6075bd75539214e75e"; +ok (my $sig = Config::Perl::V::signature ($conf), "Get signature"); +is ($sig, $md5, "MD5"); + +is_deeply ($conf->{build}{patches}, [ ], "No patches"); + +my %check = ( + alignbytes => 16, + api_version => 32, + bincompat5005 => "undef", + byteorder => 12345678, + cc => "cc", + cccdlflags => "-fPIC", + ccdlflags => "-Wl,-E -Wl,-rpath,/pro/lib/perl5/5.32.0/x86_64-linux-thread-multi-ld/CORE", + config_args => "-Dusethreads -Duseithreads -Duse64bitall -Duselongdouble -Duseshrplib -des", + gccversion => "10.1.1 20200507 [revision dd38686d9c810cecbaa80bb82ed91caaa58ad635]", + gnulibc_version => "2.31", + ivsize => 8, + ivtype => "long", + ld => "cc", + lddlflags => "-shared -O2 -L/pro/local/lib -fstack-protector-strong", + ldflags => "-L/pro/local/lib -fstack-protector-strong", + libc => "libc-2.31.so", + lseektype => "off_t", + osvers => "5.7.1-1-default", + use64bitall => "define", + use64bitint => "define", + usemymalloc => "n", + default_inc_excludes_dot + => "define", + ); +is ($conf->{config}{$_}, $check{$_}, "reconstructed \$Config{$_}") for sort keys %check; + +ok (my $info = summary ($conf), "A summary"); +ok (exists $info->{$_}, "Summary has $_") for qw( cc config_args usemymalloc default_inc_excludes_dot ); +is ($info->{default_inc_excludes_dot}, "define", "This build has . NOT in INC"); + +__END__ +Summary of my perl5 (revision 5 version 32 subversion 0) configuration: + + Platform: + osname=linux + osvers=5.7.1-1-default + archname=x86_64-linux-thread-multi-ld + uname='linux lx09 5.7.1-1-default #1 smp wed jun 10 11:53:46 utc 2020 (6a549f6) x86_64 x86_64 x86_64 gnulinux ' + config_args='-Dusethreads -Duseithreads -Duse64bitall -Duselongdouble -Duseshrplib -des' + hint=recommended + useposix=true + d_sigaction=define + useithreads=define + usemultiplicity=define + use64bitint=define + use64bitall=define + uselongdouble=define + usemymalloc=n + default_inc_excludes_dot=define + bincompat5005=undef + Compiler: + cc='cc' + ccflags ='-D_REENTRANT -D_GNU_SOURCE -fPIC -fwrapv -fno-strict-aliasing -pipe -fstack-protector-strong -I/pro/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -D_FORTIFY_SOURCE=2' + optimize='-O2' + cppflags='-D_REENTRANT -D_GNU_SOURCE -fPIC -fwrapv -fno-strict-aliasing -pipe -fstack-protector-strong -I/pro/local/include' + ccversion='' + gccversion='10.1.1 20200507 [revision dd38686d9c810cecbaa80bb82ed91caaa58ad635]' + gccosandvers='' + intsize=4 + longsize=8 + ptrsize=8 + doublesize=8 + byteorder=12345678 + doublekind=3 + d_longlong=define + longlongsize=8 + d_longdbl=define + longdblsize=16 + longdblkind=3 + ivtype='long' + ivsize=8 + nvtype='long double' + nvsize=16 + Off_t='off_t' + lseeksize=8 + alignbytes=16 + prototype=define + Linker and Libraries: + ld='cc' + ldflags ='-L/pro/local/lib -fstack-protector-strong' + libpth=/usr/local/lib /usr/lib64/gcc/x86_64-suse-linux/10/include-fixed /usr/lib64/gcc/x86_64-suse-linux/10/../../../../x86_64-suse-linux/lib /usr/lib /pro/local/lib /lib/../lib64 /usr/lib/../lib64 /lib /lib64 /usr/lib64 /usr/local/lib64 + libs=-lpthread -lnsl -lgdbm -ldb -ldl -lm -lcrypt -lutil -lc -lgdbm_compat + perllibs=-lpthread -lnsl -ldl -lm -lcrypt -lutil -lc + libc=libc-2.31.so + so=so + useshrplib=true + libperl=libperl.so + gnulibc_version='2.31' + Dynamic Linking: + dlsrc=dl_dlopen.xs + dlext=so + d_dlsymun=undef + ccdlflags='-Wl,-E -Wl,-rpath,/pro/lib/perl5/5.32.0/x86_64-linux-thread-multi-ld/CORE' + cccdlflags='-fPIC' + lddlflags='-shared -O2 -L/pro/local/lib -fstack-protector-strong' + + +Characteristics of this binary (from libperl): + Compile-time options: + HAS_TIMES + MULTIPLICITY + PERLIO_LAYERS + PERL_COPY_ON_WRITE + PERL_DONT_CREATE_GVSV + PERL_IMPLICIT_CONTEXT + PERL_MALLOC_WRAP + PERL_OP_PARENT + PERL_PRESERVE_IVUV + USE_64_BIT_ALL + USE_64_BIT_INT + USE_ITHREADS + USE_LARGE_FILES + USE_LOCALE + USE_LOCALE_COLLATE + USE_LOCALE_CTYPE + USE_LOCALE_NUMERIC + USE_LOCALE_TIME + USE_LONG_DOUBLE + USE_PERLIO + USE_PERL_ATOF + USE_REENTRANT_API + USE_THREAD_SAFE_LOCALE + Built under linux + Compiled at Jun 21 2020 10:17:00 + %ENV: + PERL6LIB="inst#/pro/3gl/CPAN/rakudo/install" + @INC: + /pro/lib/perl5/site_perl/5.32.0/x86_64-linux-thread-multi-ld + /pro/lib/perl5/site_perl/5.32.0 + /pro/lib/perl5/5.32.0/x86_64-linux-thread-multi-ld + /pro/lib/perl5/5.32.0 diff --git a/cpan/DB_File/.gitignore b/cpan/DB_File/.gitignore index f1c4edfa6e1e..ef1c21950b3f 100644 --- a/cpan/DB_File/.gitignore +++ b/cpan/DB_File/.gitignore @@ -1,3 +1,5 @@ !/version.c /constants.* *.bak +!/Makefile.PL +!/src/*.c diff --git a/cpan/Digest-MD5/.gitignore b/cpan/Digest-MD5/.gitignore new file mode 100644 index 000000000000..e54624d60d99 --- /dev/null +++ b/cpan/Digest-MD5/.gitignore @@ -0,0 +1 @@ +!/Makefile.PL diff --git a/cpan/Digest-SHA/.gitignore b/cpan/Digest-SHA/.gitignore new file mode 100644 index 000000000000..335fafbdca68 --- /dev/null +++ b/cpan/Digest-SHA/.gitignore @@ -0,0 +1,2 @@ +!/Makefile.PL +!/src/*.c diff --git a/cpan/Encode/.gitignore b/cpan/Encode/.gitignore index 3ac370bd5641..2e7d1d67af45 100644 --- a/cpan/Encode/.gitignore +++ b/cpan/Encode/.gitignore @@ -1,4 +1,5 @@ !/encengine.c +!Makefile.PL /Byte/Byte.xs /CN/CN.xs /EBCDIC/EBCDIC.xs diff --git a/cpan/Encode/Encode.pm b/cpan/Encode/Encode.pm index 77ca93e87bb6..d3eb3c1b1131 100644 --- a/cpan/Encode/Encode.pm +++ b/cpan/Encode/Encode.pm @@ -1,5 +1,5 @@ # -# $Id: Encode.pm,v 3.07 2020/07/25 12:59:10 dankogai Exp $ +# $Id: Encode.pm,v 3.08 2020/12/02 01:27:44 dankogai Exp $ # package Encode; use strict; @@ -7,7 +7,7 @@ use warnings; use constant DEBUG => !!$ENV{PERL_ENCODE_DEBUG}; our $VERSION; BEGIN { - $VERSION = sprintf "%d.%02d", q$Revision: 3.07 $ =~ /(\d+)/g; + $VERSION = sprintf "%d.%02d", q$Revision: 3.08 $ =~ /(\d+)/g; require XSLoader; XSLoader::load( __PACKAGE__, $VERSION ); } diff --git a/cpan/Encode/Makefile.PL b/cpan/Encode/Makefile.PL index 8c20d20226f0..f9c774845f4b 100644 --- a/cpan/Encode/Makefile.PL +++ b/cpan/Encode/Makefile.PL @@ -1,5 +1,5 @@ # -# $Id: Makefile.PL,v 2.22 2017/10/06 22:21:53 dankogai Exp $ +# $Id: Makefile.PL,v 2.23 2020/12/02 01:28:17 dankogai Exp dankogai $ # use 5.007003; use strict; @@ -70,7 +70,7 @@ WriteMakefile( Storable => '0', # bundled with Perl 5.7.3 }, TEST_REQUIRES => { - 'Test::More' => '0.81_01', + 'Test::More' => '0.92', }, PMLIBDIRS => \@pmlibdirs, INSTALLDIRS => ($] < 5.011 ? 'perl' : 'site'), diff --git a/cpan/Encode/bin/encguess b/cpan/Encode/bin/encguess index 0f344ea3fc03..19a0673e7607 100644 --- a/cpan/Encode/bin/encguess +++ b/cpan/Encode/bin/encguess @@ -61,7 +61,7 @@ encguess - guess character encodings of files =head1 VERSION -$Id: encguess,v 0.2 2016/08/04 03:15:58 dankogai Exp $ +$Id: encguess,v 0.3 2020/12/02 01:28:17 dankogai Exp dankogai $ =head1 SYNOPSIS @@ -78,7 +78,7 @@ show this message and exit. =item -s specify a list of "suspect encoding types" to test, -seperated by either C<:> or C<,> +separated by either C<:> or C<,> =item -S diff --git a/cpan/Encode/lib/Encode/GSM0338.pm b/cpan/Encode/lib/Encode/GSM0338.pm index 8b23a7bb6a90..644d4452851c 100644 --- a/cpan/Encode/lib/Encode/GSM0338.pm +++ b/cpan/Encode/lib/Encode/GSM0338.pm @@ -1,5 +1,5 @@ # -# $Id: GSM0338.pm,v 2.8 2020/07/25 12:59:29 dankogai Exp dankogai $ +# $Id: GSM0338.pm,v 2.9 2020/12/02 01:28:17 dankogai Exp dankogai $ # package Encode::GSM0338; @@ -8,16 +8,13 @@ use warnings; use Carp; use vars qw($VERSION); -$VERSION = do { my @r = ( q$Revision: 2.8 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r }; +$VERSION = do { my @r = ( q$Revision: 2.9 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r }; use Encode qw(:fallbacks); use parent qw(Encode::Encoding); __PACKAGE__->Define('gsm0338'); -sub needs_lines { 1 } -sub perlio_ok { 0 } - use utf8; # Mapping table according to 3GPP TS 23.038 version 16.0.0 Release 16 and ETSI TS 123 038 V16.0.0 (2020-07) @@ -182,6 +179,10 @@ sub decode ($$;$) { ? $chk->( unpack 'C*', $seq ) : "\x{FFFD}"; if ( not exists $GSM2UNI{$seq} and $chk and not ref $chk ) { + if ( substr($seq, 0, 1) eq $ESC and ($chk & Encode::STOP_AT_PARTIAL) ) { + $bytes .= $seq; + last; + } croak join( '', map { sprintf "\\x%02X", $_ } unpack 'C*', $seq ) . ' does not map to Unicode' if $chk & Encode::DIE_ON_ERR; carp join( '', map { sprintf "\\x%02X", $_ } unpack 'C*', $seq ) . ' does not map to Unicode' if $chk & Encode::WARN_ON_ERR; if ($chk & Encode::RETURN_ON_ERR) { diff --git a/cpan/Encode/t/gsm0338.t b/cpan/Encode/t/gsm0338.t index 21a82fad5e24..ab985838f3d0 100644 --- a/cpan/Encode/t/gsm0338.t +++ b/cpan/Encode/t/gsm0338.t @@ -13,7 +13,7 @@ BEGIN { use strict; use utf8; -use Test::More tests => 776; +use Test::More tests => 777; use Encode; use Encode::GSM0338; @@ -83,49 +83,9 @@ is encode("gsm0338", chr(0xC7)) => "\x09", 'RT75670: encode'; is decode("gsm0338", encode('gsm0338', '..@@..')), '..@@..'; is decode("gsm0338", encode('gsm0338', '..@€..')), '..@€..'; -__END__ -for my $c (map { chr } 0..127){ - my $b = "\x1b$c"; - my $u = $Encode::GSM0338::GSM2UNI{$b}; - next unless $u; - $u ||= "\xA0" . $Encode::GSM0338::GSM2UNI{$c}; - is decode("gsm0338", $b), $u, sprintf("decode ESC+\\x%02X", ord($c) ); -} - -__END__ -# old test follows -ub t { is(decode("gsm0338", my $t = $_[0]), $_[1]) } - -# t("\x00", "\x00"); # ??? - -# "Round-trip". -t("\x41", "\x41"); - -t("\x01", "\xA3"); -t("\x02", "\x24"); -t("\x03", "\xA5"); -t("\x09", "\xE7"); - -t("\x00\x00", "\x00\x00"); # Maybe? -t("\x00\x1B", "\x40\xA0"); # Maybe? -t("\x00\x41", "\x40\x41"); - -# t("\x1B", "\x1B"); # ??? - -# Escape with no special second byte is just a NBSP. -t("\x1B\x41", "\xA0\x41"); - -t("\x1B\x00", "\xA0\x40"); # Maybe? - -# Special escape characters. -t("\x1B\x0A", "\x0C"); -t("\x1B\x14", "\x5E"); -t("\x1B\x28", "\x7B"); -t("\x1B\x29", "\x7D"); -t("\x1B\x2F", "\x5C"); -t("\x1B\x3C", "\x5B"); -t("\x1B\x3D", "\x7E"); -t("\x1B\x3E", "\x5D"); -t("\x1B\x40", "\x7C"); -t("\x1B\x40", "\x7C"); -t("\x1B\x65", "\x{20AC}"); +# special GSM sequence, € is at 1024 byte buffer boundary +my $gsm = "\x41" . "\x1B\x65" x 1024; +open my $fh, '<:encoding(gsm0338)', \$gsm or die; +my $uni = <$fh>; +close $fh; +is $uni, "A" . "€" x 1024, 'PerlIO encoding(gsm0338) read works'; diff --git a/cpan/ExtUtils-Install/lib/ExtUtils/Install.pm b/cpan/ExtUtils-Install/lib/ExtUtils/Install.pm index 2fb43bc8d4f6..96081806f78f 100644 --- a/cpan/ExtUtils-Install/lib/ExtUtils/Install.pm +++ b/cpan/ExtUtils-Install/lib/ExtUtils/Install.pm @@ -32,11 +32,11 @@ ExtUtils::Install - install files from here to there =head1 VERSION -2.18 +2.20 =cut -our $VERSION = '2.18'; # <-- do not forget to update the POD section just above this line! +our $VERSION = '2.20'; # <-- do not forget to update the POD section just above this line! $VERSION = eval $VERSION; =pod @@ -65,26 +65,22 @@ anything depending on this module cannot proceed until a reboot has occurred. If this value is defined but false then such an operation has -ocurred, but should not impact later operations. - -=over +occurred, but should not impact later operations. =begin _private -=item _chmod($$;$) +=head2 _chmod($$;$) Wrapper to chmod() for debugging and error trapping. -=item _warnonce(@) +=head2 _warnonce(@) Warns about something only once. -=item _choke(@) +=head2 _choke(@) Dies with a special message. -=back - =end _private =cut @@ -137,8 +133,12 @@ sub _confess { } sub _compare { - require File::Compare; - File::Compare::compare(@_); + # avoid loading File::Compare in the common case + if (-f $_[1] && -s _ == -s $_[0]) { + require File::Compare; + return File::Compare::compare(@_); + } + return 1; } @@ -157,9 +157,7 @@ sub _chmod($$;$) { =begin _private -=over - -=item _move_file_at_boot( $file, $target, $moan ) +=head2 _move_file_at_boot( $file, $target, $moan ) OS-Specific, Win32/Cygwin @@ -231,8 +229,7 @@ If $moan is true then returns 0 on error and warns instead of dies. =begin _private - -=item _unlink_or_rename( $file, $tryhard, $installing ) +=head2 _unlink_or_rename( $file, $tryhard, $installing ) OS-Specific, Win32/Cygwin @@ -263,8 +260,6 @@ On failure throws a fatal error. =cut - - sub _unlink_or_rename { #XXX OS-SPECIFIC my ( $file, $tryhard, $installing )= @_; @@ -310,25 +305,16 @@ sub _unlink_or_rename { #XXX OS-SPECIFIC } - -=pod - -=back - -=head2 Functions +=head1 Functions =begin _private -=over - -=item _get_install_skip +=head2 _get_install_skip Handles loading the INSTALL.SKIP file. Returns an array of patterns to use. =cut - - sub _get_install_skip { my ( $skip, $verbose )= @_; if ($ENV{EU_INSTALL_IGNORE_SKIP}) { @@ -378,9 +364,7 @@ sub _get_install_skip { return $skip } -=pod - -=item _have_write_access +=head2 _have_write_access Abstract a -w check that tries to use POSIX::access() if possible. @@ -402,9 +386,7 @@ Abstract a -w check that tries to use POSIX::access() if possible. } } -=pod - -=item _can_write_dir(C<$dir>) +=head2 _can_write_dir(C<$dir>) Checks whether a given directory is writable, taking account the possibility that the directory might not exist and would have to @@ -423,7 +405,6 @@ relative paths with C<..> in them. But for our purposes it should work ok =cut - sub _can_write_dir { my $dir=shift; return @@ -461,9 +442,7 @@ sub _can_write_dir { return 0; } -=pod - -=item _mkpath($dir,$show,$mode,$verbose,$dry_run) +=head2 _mkpath($dir,$show,$mode,$verbose,$dry_run) Wrapper around File::Path::mkpath() to handle errors. @@ -486,10 +465,16 @@ sub _mkpath { printf "mkpath(%s,%d,%#o)\n", $dir, $show, $mode; } if (!$dry_run) { - if ( ! eval { File::Path::mkpath($dir,$show,$mode); 1 } ) { - _choke("Can't create '$dir'","$@"); + my @created; + eval { + @created = File::Path::mkpath($dir,$show,$mode); + 1; + } or _choke("Can't create '$dir'","$@"); + # if we created any directories, we were able to write and don't need + # extra checks + if (@created) { + return; } - } my ($can,$root,@make)=_can_write_dir($dir); if (!$can) { @@ -509,9 +494,7 @@ sub _mkpath { } -=pod - -=item _copy($from,$to,$verbose,$dry_run) +=head2 _copy($from,$to,$verbose,$dry_run) Wrapper around File::Copy::copy to handle errors. @@ -523,7 +506,6 @@ Dies if the copy fails. =cut - sub _copy { my ( $from, $to, $verbose, $dry_run)=@_; if ($verbose && $verbose>1) { @@ -537,7 +519,7 @@ sub _copy { =pod -=item _chdir($from) +=head2 _chdir($from) Wrapper around chdir to catch errors. @@ -558,15 +540,9 @@ sub _chdir { return $ret; } -=pod - -=back - =end _private -=over - -=item B +=head2 install # deprecated forms install(\%from_to); @@ -774,15 +750,9 @@ sub install { #XXX OS-SPECIFIC } # we have to do this for back compat with old File::Finds # and because the target is relative - my $save_cwd = _chdir($cwd); - my $diff = 0; - # XXX: I wonder how useful this logic is actually -- demerphq - if ( $always_copy or !-f $targetfile or -s $targetfile != $size) { - $diff++; - } else { - # we might not need to copy this file - $diff = _compare($sourcefile, $targetfile); - } + my $save_cwd = File::Spec->catfile($cwd, $sourcedir); + _chdir($cwd); + my $diff = $always_copy || _compare($sourcefile, $targetfile); $check_dirs{$targetdir}++ unless -w $targetfile; @@ -864,7 +834,7 @@ sub install { #XXX OS-SPECIFIC =begin _private -=item _do_cleanup +=head2 _do_cleanup Standardize finish event for after another instruction has occurred. Handles converting $MUST_REBOOT to a die for instance. @@ -887,12 +857,12 @@ sub _do_cleanup { =begin _undocumented -=item install_rooted_file( $file ) +=head2 install_rooted_file( $file ) Returns $file, or catfile($INSTALL_ROOT,$file) if $INSTALL_ROOT is defined. -=item install_rooted_dir( $dir ) +=head2 install_rooted_dir( $dir ) Returns $dir, or catdir($INSTALL_ROOT,$dir) if $INSTALL_ROOT is defined. @@ -901,7 +871,6 @@ is defined. =cut - sub install_rooted_file { if (defined $INSTALL_ROOT) { File::Spec->catfile($INSTALL_ROOT, $_[0]); @@ -921,7 +890,7 @@ sub install_rooted_dir { =begin _undocumented -=item forceunlink( $file, $tryhard ) +=head2 forceunlink( $file, $tryhard ) Tries to delete a file. If $tryhard is true then we will use whatever devious tricks we can to delete the file. Currently this only applies to @@ -932,7 +901,6 @@ reboot. A wrapper for _unlink_or_rename(). =cut - sub forceunlink { my ( $file, $tryhard )= @_; #XXX OS-SPECIFIC _unlink_or_rename( $file, $tryhard, not("installing") ); @@ -940,7 +908,7 @@ sub forceunlink { =begin _undocumented -=item directory_not_empty( $dir ) +=head2 directory_not_empty( $dir ) Returns 1 if there is an .exists file somewhere in a directory tree. Returns 0 if there is not. @@ -963,9 +931,9 @@ sub directory_not_empty ($) { return $files; } -=pod +=head2 install_default -=item B I +I install_default(); install_default($fullext); @@ -1019,7 +987,7 @@ sub install_default { } -=item B +=head2 uninstall uninstall($packlist_file); uninstall($packlist_file, $verbose, $dont_execute); @@ -1057,7 +1025,7 @@ sub uninstall { =begin _undocumented -=item inc_uninstall($filepath,$libdir,$verbose,$dry_run,$ignore,$results) +=head2 inc_uninstall($filepath,$libdir,$verbose,$dry_run,$ignore,$results) Remove shadowed files. If $ignore is true then it is assumed to hold a filename to ignore. This is used to prevent spurious warnings from @@ -1103,13 +1071,8 @@ sub inc_uninstall { # The reason why we compare file's contents is, that we cannot # know, which is the file we just installed (AFS). So we leave # an identical file in place - my $diff = 0; - if ( -f $targetfile && -s _ == -s $filepath) { - # We have a good chance, we can skip this one - $diff = _compare($filepath,$targetfile); - } else { - $diff++; - } + my $diff = _compare($filepath,$targetfile); + print "#$file and $targetfile differ\n" if $diff && $verbose > 1; if (!$diff or $targetfile eq $ignore) { @@ -1150,7 +1113,7 @@ sub inc_uninstall { =begin _undocumented -=item run_filter($cmd,$src,$dest) +=head2 run_filter($cmd,$src,$dest) Filter $src using $cmd into $dest. @@ -1172,9 +1135,7 @@ sub run_filter { close CMD or die "Filter command '$cmd' failed for $src"; } -=pod - -=item B +=head2 pm_to_blib pm_to_blib(\%from_to); pm_to_blib(\%from_to, $autosplit_dir); @@ -1199,6 +1160,7 @@ environment variable will silence this output. sub pm_to_blib { my($fromto,$autodir,$pm_filter) = @_; + my %dirs; _mkpath($autodir,0,0755) if defined $autodir; while(my($from, $to) = each %$fromto) { if( -f $to && -s $from == -s $to && -M $to < -M $from ) { @@ -1214,7 +1176,7 @@ sub pm_to_blib { my $need_filtering = defined $pm_filter && length $pm_filter && $from =~ /\.pm$/; - if (!$need_filtering && 0 == _compare($from,$to)) { + if (!$need_filtering && !_compare($from,$to)) { print "Skip $to (unchanged)\n" unless $INSTALL_QUIET; next; } @@ -1222,7 +1184,10 @@ sub pm_to_blib { # we wont try hard here. its too likely to mess things up. forceunlink($to); } else { - _mkpath(dirname($to),0,0755); + my $dirname = dirname($to); + if (!$dirs{$dirname}++) { + _mkpath($dirname,0,0755); + } } if ($need_filtering) { run_filter($pm_filter, $from, $to); @@ -1239,10 +1204,9 @@ sub pm_to_blib { } } - =begin _private -=item _autosplit +=head2 _autosplit From 1.0307 back, AutoSplit will sometimes leave an open filehandle to the file being split. This causes problems on systems with mandatory @@ -1293,7 +1257,7 @@ sub DESTROY { =begin _private -=item _invokant +=head2 _invokant Does a heuristic on the stack to see who called us for more intelligent error messages. Currently assumes we will be called only by Module::Build @@ -1320,10 +1284,6 @@ sub _invokant { return $builder; } -=pod - -=back - =head1 ENVIRONMENT =over 4 diff --git a/cpan/ExtUtils-Install/lib/ExtUtils/Installed.pm b/cpan/ExtUtils-Install/lib/ExtUtils/Installed.pm index f12ea23f19bf..0cfd96b507d4 100644 --- a/cpan/ExtUtils-Install/lib/ExtUtils/Installed.pm +++ b/cpan/ExtUtils-Install/lib/ExtUtils/Installed.pm @@ -15,7 +15,7 @@ my $DOSISH = ($^O =~ /^(MSWin\d\d|os2|dos|mint)$/); require VMS::Filespec if $Is_VMS; -our $VERSION = '2.18'; +our $VERSION = '2.20'; $VERSION = eval $VERSION; sub _is_prefix { diff --git a/cpan/ExtUtils-Install/lib/ExtUtils/Packlist.pm b/cpan/ExtUtils-Install/lib/ExtUtils/Packlist.pm index f975b41b042a..98d09e3d8208 100644 --- a/cpan/ExtUtils-Install/lib/ExtUtils/Packlist.pm +++ b/cpan/ExtUtils-Install/lib/ExtUtils/Packlist.pm @@ -4,7 +4,7 @@ use strict; use Carp qw(); use Config; our $Relocations; -our $VERSION = '2.18'; +our $VERSION = '2.20'; $VERSION = eval $VERSION; # Used for generating filehandle globs. IO::File might not be available! diff --git a/cpan/ExtUtils-Install/t/Installed.t b/cpan/ExtUtils-Install/t/Installed.t index 5cf7b80cafdd..7d7bf243d366 100644 --- a/cpan/ExtUtils-Install/t/Installed.t +++ b/cpan/ExtUtils-Install/t/Installed.t @@ -18,7 +18,7 @@ use File::Basename; use File::Spec; use File::Temp qw[tempdir]; -use Test::More tests => 74; +use Test::More tests => 76; BEGIN { use_ok( 'ExtUtils::Installed' ) } @@ -36,6 +36,10 @@ ok( $ei->_is_prefix('foo/bar', 'foo'), '_is_prefix() should match valid path prefix' ); ok( !$ei->_is_prefix('\foo\bar', '\bar'), '... should not match wrong prefix' ); +ok( ! defined $ei->_is_prefix( undef, 'foo' ), + '_is_prefix() needs two defined arguments' ); +ok( ! defined $ei->_is_prefix( 'foo/bar', undef ), + '_is_prefix() needs two defined arguments' ); # _is_type ok( $ei->_is_type(0, 'all'), '_is_type() should be true for type of "all"' ); diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Command.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Command.pm index 6bbe48fcc418..bce04cccb078 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Command.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Command.pm @@ -8,7 +8,7 @@ use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); @ISA = qw(Exporter); @EXPORT = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f test_d chmod dos2unix); -$VERSION = '7.52'; +$VERSION = '7.58'; $VERSION =~ tr/_//d; my $Is_VMS = $^O eq 'VMS'; diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Command/MM.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Command/MM.pm index 9aa734f2ad24..93bddbfd5b98 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Command/MM.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Command/MM.pm @@ -10,7 +10,7 @@ our @ISA = qw(Exporter); our @EXPORT = qw(test_harness pod2man perllocal_install uninstall warn_if_old_packlist test_s cp_nonempty); -our $VERSION = '7.52'; +our $VERSION = '7.58'; $VERSION =~ tr/_//d; my $Is_VMS = $^O eq 'VMS'; diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist.pm index 4e7435fdfc65..877bffaf3d7d 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist.pm @@ -3,7 +3,7 @@ package ExtUtils::Liblist; use strict; use warnings; -our $VERSION = '7.52'; +our $VERSION = '7.58'; $VERSION =~ tr/_//d; use File::Spec; diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist/Kid.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist/Kid.pm index 196abfcbc6ab..ef53dbc43be0 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist/Kid.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist/Kid.pm @@ -11,7 +11,7 @@ use 5.006; use strict; use warnings; -our $VERSION = '7.52'; +our $VERSION = '7.58'; $VERSION =~ tr/_//d; use ExtUtils::MakeMaker::Config; @@ -174,6 +174,10 @@ sub _unix_os2_ext { && -f ( $fullname = "$thispth/lib$thislib.$Config_dlext" ) ) { } + elsif ( $^O eq 'darwin' && require DynaLoader && defined &DynaLoader::dl_load_file + && DynaLoader::dl_load_file( $fullname = "$thispth/lib$thislib.$so", 0 ) ) + { + } elsif ( -f ( $fullname = "$thispth/$thislib$Config_libext" ) ) { } elsif ( -f ( $fullname = "$thispth/lib$thislib.dll$Config_libext" ) ) { diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM.pm index 37952fc8091c..fc8d1c8a5f82 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM.pm @@ -4,7 +4,7 @@ use strict; use warnings; use ExtUtils::MakeMaker::Config; -our $VERSION = '7.52'; +our $VERSION = '7.58'; $VERSION =~ tr/_//d; require ExtUtils::Liblist; diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_AIX.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_AIX.pm index b469bb20811e..b2864e75749c 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_AIX.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_AIX.pm @@ -2,7 +2,7 @@ package ExtUtils::MM_AIX; use strict; use warnings; -our $VERSION = '7.52'; +our $VERSION = '7.58'; $VERSION =~ tr/_//d; use ExtUtils::MakeMaker::Config; diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Any.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Any.pm index 9fbdc793cd23..2f86884ef5b7 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Any.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Any.pm @@ -2,7 +2,7 @@ package ExtUtils::MM_Any; use strict; use warnings; -our $VERSION = '7.52'; +our $VERSION = '7.58'; $VERSION =~ tr/_//d; use Carp; diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_BeOS.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_BeOS.pm index 09b11630be2e..9e054f56c0c3 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_BeOS.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_BeOS.pm @@ -27,7 +27,7 @@ require ExtUtils::MM_Any; require ExtUtils::MM_Unix; our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix ); -our $VERSION = '7.52'; +our $VERSION = '7.58'; $VERSION =~ tr/_//d; diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Cygwin.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Cygwin.pm index 42790061bc6d..403f052be953 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Cygwin.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Cygwin.pm @@ -10,7 +10,7 @@ require ExtUtils::MM_Unix; require ExtUtils::MM_Win32; our @ISA = qw( ExtUtils::MM_Unix ); -our $VERSION = '7.52'; +our $VERSION = '7.58'; $VERSION =~ tr/_//d; diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_DOS.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_DOS.pm index 9b078b5c5ad6..cb6cb650e9e0 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_DOS.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_DOS.pm @@ -3,7 +3,7 @@ package ExtUtils::MM_DOS; use strict; use warnings; -our $VERSION = '7.52'; +our $VERSION = '7.58'; $VERSION =~ tr/_//d; require ExtUtils::MM_Any; diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Darwin.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Darwin.pm index e906c2440435..2fed5634c006 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Darwin.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Darwin.pm @@ -8,7 +8,7 @@ BEGIN { our @ISA = qw( ExtUtils::MM_Unix ); } -our $VERSION = '7.52'; +our $VERSION = '7.58'; $VERSION =~ tr/_//d; @@ -53,11 +53,22 @@ Over-ride Apple's automatic setting of -Werror =cut sub cflags { - my $self = shift; - - $self->{CCFLAGS} .= ($self->{CCFLAGS} ? ' ' : '').'-Wno-error=implicit-function-declaration'; - - $self->SUPER::cflags(@_); + my($self,$libperl)=@_; + return $self->{CFLAGS} if $self->{CFLAGS}; + return '' unless $self->needs_linking(); + + my $base = $self->SUPER::cflags($libperl); + + foreach (split /\n/, $base) { + /^(\S*)\s*=\s*(\S*)$/ and $self->{$1} = $2; + }; + $self->{CCFLAGS} .= " -Wno-error=implicit-function-declaration"; + + return $self->{CFLAGS} = qq{ +CCFLAGS = $self->{CCFLAGS} +OPTIMIZE = $self->{OPTIMIZE} +PERLTYPE = $self->{PERLTYPE} +}; } 1; diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_MacOS.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_MacOS.pm index c224cd963eba..8a0bba474433 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_MacOS.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_MacOS.pm @@ -3,7 +3,7 @@ package ExtUtils::MM_MacOS; use strict; use warnings; -our $VERSION = '7.52'; +our $VERSION = '7.58'; $VERSION =~ tr/_//d; sub new { diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_NW5.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_NW5.pm index f352ed43bb6d..fc35d28a41f6 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_NW5.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_NW5.pm @@ -23,7 +23,7 @@ use warnings; use ExtUtils::MakeMaker::Config; use File::Basename; -our $VERSION = '7.52'; +our $VERSION = '7.58'; $VERSION =~ tr/_//d; require ExtUtils::MM_Win32; diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS2.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS2.pm index f16d4bfd6915..da43f6b9a5ed 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS2.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS2.pm @@ -6,7 +6,7 @@ use warnings; use ExtUtils::MakeMaker qw(neatvalue); use File::Spec; -our $VERSION = '7.52'; +our $VERSION = '7.58'; $VERSION =~ tr/_//d; require ExtUtils::MM_Any; diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS390.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS390.pm index d80cd8a3958c..f3e687988651 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS390.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS390.pm @@ -2,7 +2,7 @@ package ExtUtils::MM_OS390; use strict; use warnings; -our $VERSION = '7.52'; +our $VERSION = '7.58'; $VERSION =~ tr/_//d; use ExtUtils::MakeMaker::Config; diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_QNX.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_QNX.pm index 70f0197e698d..145a826c38c0 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_QNX.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_QNX.pm @@ -2,7 +2,7 @@ package ExtUtils::MM_QNX; use strict; use warnings; -our $VERSION = '7.52'; +our $VERSION = '7.58'; $VERSION =~ tr/_//d; require ExtUtils::MM_Unix; diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_UWIN.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_UWIN.pm index ca0b482a6eda..80074c7402ff 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_UWIN.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_UWIN.pm @@ -2,7 +2,7 @@ package ExtUtils::MM_UWIN; use strict; use warnings; -our $VERSION = '7.52'; +our $VERSION = '7.58'; $VERSION =~ tr/_//d; require ExtUtils::MM_Unix; diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm index c24fb3edb031..46d457cc2a3b 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm @@ -15,7 +15,7 @@ use ExtUtils::MakeMaker qw($Verbose neatvalue _sprintf562); # If we make $VERSION an our variable parse_version() breaks use vars qw($VERSION); -$VERSION = '7.52'; +$VERSION = '7.58'; $VERSION =~ tr/_//d; require ExtUtils::MM_Any; diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VMS.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VMS.pm index b4d612800d78..c0039c8f3bc2 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VMS.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VMS.pm @@ -16,7 +16,7 @@ BEGIN { use File::Basename; -our $VERSION = '7.52'; +our $VERSION = '7.58'; $VERSION =~ tr/_//d; require ExtUtils::MM_Any; diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VOS.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VOS.pm index 277850a58f7d..08c3a80f5c1f 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VOS.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VOS.pm @@ -2,7 +2,7 @@ package ExtUtils::MM_VOS; use strict; use warnings; -our $VERSION = '7.52'; +our $VERSION = '7.58'; $VERSION =~ tr/_//d; require ExtUtils::MM_Unix; diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win32.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win32.pm index 7597f22981e1..1fa000bf7dd7 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win32.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win32.pm @@ -27,7 +27,7 @@ use ExtUtils::MakeMaker qw(neatvalue _sprintf562); require ExtUtils::MM_Any; require ExtUtils::MM_Unix; our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix ); -our $VERSION = '7.52'; +our $VERSION = '7.58'; $VERSION =~ tr/_//d; $ENV{EMXSHELL} = 'sh'; # to run `commands` diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win95.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win95.pm index d43eb51dc5e4..f17d536958d7 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win95.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win95.pm @@ -3,7 +3,7 @@ package ExtUtils::MM_Win95; use strict; use warnings; -our $VERSION = '7.52'; +our $VERSION = '7.58'; $VERSION =~ tr/_//d; require ExtUtils::MM_Win32; diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MY.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MY.pm index 5aec641304a3..a179de921610 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MY.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MY.pm @@ -3,7 +3,7 @@ package ExtUtils::MY; use strict; require ExtUtils::MM; -our $VERSION = '7.52'; +our $VERSION = '7.58'; $VERSION =~ tr/_//d; our @ISA = qw(ExtUtils::MM); diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker.pm index 4309b84cf0ae..aed2a7487685 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker.pm @@ -25,7 +25,7 @@ my %Recognized_Att_Keys; our %macro_fsentity; # whether a macro is a filesystem name our %macro_dep; # whether a macro is a dependency -our $VERSION = '7.52'; +our $VERSION = '7.58'; $VERSION =~ tr/_//d; # Emulate something resembling CVS $Revision$ @@ -426,7 +426,10 @@ sub _has_cpan_meta_requirements { return eval { require CPAN::Meta::Requirements; CPAN::Meta::Requirements->VERSION(2.130); - require B; # CMR requires this, for core we have to too. + # Make sure vstrings can be handled. Some versions of CMR require B to + # do this, which won't be available in miniperl. + CPAN::Meta::Requirements->new->add_string_requirement('Module' => v1.2); + 1; }; } @@ -1032,7 +1035,7 @@ sub _parse_line { } sub check_manifest { - print "Checking if your kit is complete...\n"; + print STDOUT "Checking if your kit is complete...\n"; require ExtUtils::Manifest; # avoid warning $ExtUtils::Manifest::Quiet = $ExtUtils::Manifest::Quiet = 1; @@ -1230,15 +1233,15 @@ sub flush { my $self = shift; my $finalname = $self->{MAKEFILE}; - printf "Generating a %s %s\n", $self->make_type, $finalname if $Verbose || !$self->{PARENT}; - print "Writing $finalname for $self->{NAME}\n" if $Verbose || !$self->{PARENT}; + printf STDOUT "Generating a %s %s\n", $self->make_type, $finalname if $Verbose || !$self->{PARENT}; + print STDOUT "Writing $finalname for $self->{NAME}\n" if $Verbose || !$self->{PARENT}; unlink($finalname, "MakeMaker.tmp", $Is_VMS ? 'Descrip.MMS' : ()); write_file_via_tmp($finalname, $self->{RESULT}); # Write MYMETA.yml to communicate metadata up to the CPAN clients - print "Writing MYMETA.yml and MYMETA.json\n" + print STDOUT "Writing MYMETA.yml and MYMETA.json\n" if !$self->{NO_MYMETA} and $self->write_mymeta( $self->mymeta ); # save memory diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Config.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Config.pm index f1aca0f2ddc4..1140a61293ec 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Config.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Config.pm @@ -3,7 +3,7 @@ package ExtUtils::MakeMaker::Config; use strict; use warnings; -our $VERSION = '7.52'; +our $VERSION = '7.58'; $VERSION =~ tr/_//d; use Config (); diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/FAQ.pod b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/FAQ.pod index c2769364f231..0dccca320b8e 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/FAQ.pod +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/FAQ.pod @@ -1,6 +1,6 @@ package ExtUtils::MakeMaker::FAQ; -our $VERSION = '7.52'; +our $VERSION = '7.58'; $VERSION =~ tr/_//d; 1; diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Locale.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Locale.pm index 000e75df7513..d2ca5c695f0d 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Locale.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Locale.pm @@ -2,7 +2,7 @@ package ExtUtils::MakeMaker::Locale; use strict; use warnings; -our $VERSION = "7.52"; +our $VERSION = "7.58"; $VERSION =~ tr/_//d; use base 'Exporter'; diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Tutorial.pod b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Tutorial.pod index 5023b933114c..54bf7cb4306f 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Tutorial.pod +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Tutorial.pod @@ -1,6 +1,6 @@ package ExtUtils::MakeMaker::Tutorial; -our $VERSION = '7.52'; +our $VERSION = '7.58'; $VERSION =~ tr/_//d; diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/version.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/version.pm index 174058efd709..72a4ef713828 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/version.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/version.pm @@ -16,7 +16,7 @@ use warnings; use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv); -$VERSION = '7.52'; +$VERSION = '7.58'; $VERSION =~ tr/_//d; $CLASS = 'version'; diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/version/regex.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/version/regex.pm index 8445bd160be1..6742d98028bc 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/version/regex.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/version/regex.pm @@ -11,7 +11,7 @@ use warnings; use vars qw($VERSION $CLASS $STRICT $LAX); -$VERSION = '7.52'; +$VERSION = '7.58'; $VERSION =~ tr/_//d; #--------------------------------------------------------------------------# diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Mkbootstrap.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Mkbootstrap.pm index 8af07f8c1c97..7e7a545e02db 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Mkbootstrap.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Mkbootstrap.pm @@ -3,7 +3,7 @@ package ExtUtils::Mkbootstrap; use strict; use warnings; -our $VERSION = '7.52'; +our $VERSION = '7.58'; $VERSION =~ tr/_//d; require Exporter; diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Mksymlists.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Mksymlists.pm index 6ff186a0d69f..562c9c38e4a1 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Mksymlists.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Mksymlists.pm @@ -11,7 +11,7 @@ use Config; our @ISA = qw(Exporter); our @EXPORT = qw(&Mksymlists); -our $VERSION = '7.52'; +our $VERSION = '7.58'; $VERSION =~ tr/_//d; sub Mksymlists { diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/testlib.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/testlib.pm index 72ae8d73dcf3..c4006c29f58e 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/testlib.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/testlib.pm @@ -3,7 +3,7 @@ package ExtUtils::testlib; use strict; use warnings; -our $VERSION = '7.52'; +our $VERSION = '7.58'; $VERSION =~ tr/_//d; use Cwd; diff --git a/cpan/ExtUtils-Manifest/lib/ExtUtils/MANIFEST.SKIP b/cpan/ExtUtils-Manifest/lib/ExtUtils/MANIFEST.SKIP index 72286fdf199b..9d1430745a67 100644 --- a/cpan/ExtUtils-Manifest/lib/ExtUtils/MANIFEST.SKIP +++ b/cpan/ExtUtils-Manifest/lib/ExtUtils/MANIFEST.SKIP @@ -5,6 +5,7 @@ ,v$ \B\.svn\b \B\.git\b +^\.github\b \B\.gitignore\b \b_darcs\b \B\.cvsignore$ @@ -51,6 +52,8 @@ \B\.DS_Store # Mac OSX SMB mount metadata files \B\._ +# Placeholder files created when iCloud will "optimize Mac storage" +\.i[cC]loud$ # Avoid Devel::Cover and Devel::CoverX::Covered files. \bcover_db\b diff --git a/cpan/ExtUtils-Manifest/lib/ExtUtils/Manifest.pm b/cpan/ExtUtils-Manifest/lib/ExtUtils/Manifest.pm index 201fd36cb9eb..c0a7b06764a6 100644 --- a/cpan/ExtUtils-Manifest/lib/ExtUtils/Manifest.pm +++ b/cpan/ExtUtils-Manifest/lib/ExtUtils/Manifest.pm @@ -1,4 +1,4 @@ -package ExtUtils::Manifest; # git description: 1.71-18-g17b7919 +package ExtUtils::Manifest; # git description: 1.72-7-g54209ce require Exporter; use Config; @@ -10,7 +10,7 @@ use Carp; use strict; use warnings; -our $VERSION = '1.72'; +our $VERSION = '1.73'; our @ISA = ('Exporter'); our @EXPORT_OK = qw(mkmanifest manicheck filecheck fullcheck skipcheck @@ -56,7 +56,7 @@ our $Verbose = defined $ENV{PERL_MM_MANIFEST_VERBOSE} ? our $Quiet = 0; our $MANIFEST = 'MANIFEST'; -our $DEFAULT_MSKIP = File::Spec->catfile( dirname(__FILE__), "$MANIFEST.SKIP" ); +our $DEFAULT_MSKIP = File::Spec->rel2abs(File::Spec->catfile( dirname(__FILE__), "$MANIFEST.SKIP" )); =head1 NAME @@ -65,7 +65,7 @@ ExtUtils::Manifest - Utilities to write and check a MANIFEST file =head1 VERSION -version 1.72 +version 1.73 =head1 SYNOPSIS diff --git a/cpan/File-Fetch/lib/File/Fetch.pm b/cpan/File-Fetch/lib/File/Fetch.pm index 90c62e96bee4..76c641d2e7b6 100644 --- a/cpan/File-Fetch/lib/File/Fetch.pm +++ b/cpan/File-Fetch/lib/File/Fetch.pm @@ -22,7 +22,7 @@ use vars qw[ $VERBOSE $PREFER_BIN $FROM_EMAIL $USER_AGENT $FTP_PASSIVE $TIMEOUT $DEBUG $WARN $FORCEIPV4 ]; -$VERSION = '0.56'; +$VERSION = '1.00'; $VERSION = eval $VERSION; # avoid warnings with development releases $PREFER_BIN = 0; # XXX TODO implement $FROM_EMAIL = 'File-Fetch@example.com'; @@ -52,9 +52,6 @@ local $Params::Check::VERBOSE = 1; local $Module::Load::Conditional::VERBOSE = 0; local $Module::Load::Conditional::VERBOSE = 0; -### Fix CVE-2016-1238 ### -local $Module::Load::Conditional::FORCE_SAFE_INC = 1; - ### see what OS we are on, important for file:// uris ### use constant ON_WIN => ($^O eq 'MSWin32'); use constant ON_VMS => ($^O eq 'VMS'); @@ -576,6 +573,8 @@ sub _lwp_fetch { $use_list->{'LWP::Protocol::https'} = '0'; } + ### Fix CVE-2016-1238 ### + local $Module::Load::Conditional::FORCE_SAFE_INC = 1; unless( can_load( modules => $use_list ) ) { $METHOD_FAIL->{'lwp'} = 1; return; @@ -633,6 +632,8 @@ sub _httptiny_fetch { }; + ### Fix CVE-2016-1238 ### + local $Module::Load::Conditional::FORCE_SAFE_INC = 1; unless( can_load(modules => $use_list) ) { $METHOD_FAIL->{'httptiny'} = 1; return; @@ -672,6 +673,8 @@ sub _httplite_fetch { 'MIME::Base64' => '0', }; + ### Fix CVE-2016-1238 ### + local $Module::Load::Conditional::FORCE_SAFE_INC = 1; unless( can_load(modules => $use_list) ) { $METHOD_FAIL->{'httplite'} = 1; return; @@ -752,6 +755,8 @@ sub _iosock_fetch { 'IO::Select' => '0.0', }; + ### Fix CVE-2016-1238 ### + local $Module::Load::Conditional::FORCE_SAFE_INC = 1; unless( can_load(modules => $use_list) ) { $METHOD_FAIL->{'iosock'} = 1; return; @@ -835,6 +840,8 @@ sub _netftp_fetch { ### required modules ### my $use_list = { 'Net::FTP' => 0 }; + ### Fix CVE-2016-1238 ### + local $Module::Load::Conditional::FORCE_SAFE_INC = 1; unless( can_load( modules => $use_list ) ) { $METHOD_FAIL->{'netftp'} = 1; return; diff --git a/cpan/IO-Compress/.gitignore b/cpan/IO-Compress/.gitignore new file mode 100644 index 000000000000..e54624d60d99 --- /dev/null +++ b/cpan/IO-Compress/.gitignore @@ -0,0 +1 @@ +!/Makefile.PL diff --git a/cpan/IO-Compress/Makefile.PL b/cpan/IO-Compress/Makefile.PL index 1249a3c7a035..d55f014296f0 100644 --- a/cpan/IO-Compress/Makefile.PL +++ b/cpan/IO-Compress/Makefile.PL @@ -3,7 +3,7 @@ use strict ; require 5.006 ; -$::VERSION = '2.096' ; +$::VERSION = '2.100' ; use lib '.'; use private::MakeUtil; diff --git a/cpan/IO-Compress/bin/zipdetails b/cpan/IO-Compress/bin/zipdetails index 6a054cd4cd91..55276af67bb7 100644 --- a/cpan/IO-Compress/bin/zipdetails +++ b/cpan/IO-Compress/bin/zipdetails @@ -188,7 +188,7 @@ my %Extras = ( ); -my $VERSION = "2.01" ; +my $VERSION = "2.02" ; my $FH; @@ -198,10 +198,10 @@ my $LocalHeaderCount = 0; my $CentralHeaderCount = 0; my $START; -my $OFFSET = new U64 0; +my $OFFSET = U64->new( 0 ); my $TRAILING = 0 ; -my $PAYLOADLIMIT = 256; #new U64 256; -my $ZERO = new U64 0 ; +my $PAYLOADLIMIT = 256; # U64->new( 256 ); +my $ZERO = U64->new( 0 ); sub prOff { @@ -595,7 +595,7 @@ sub read_U64 myRead($b, 8); my ($lo, $hi) = unpack ("V V" , $b); no warnings 'uninitialized'; - return ($b, new U64 $hi, $lo); + return ($b, U64->new( $hi, $lo) ); } sub read_VV @@ -714,7 +714,7 @@ die "$filename does not exist\n" die "$filename not a standard file\n" unless -f $filename ; -$FH = new IO::File "<$filename" +$FH = IO::File->new( "<$filename" ) or die "Cannot open $filename: $!\n"; @@ -901,7 +901,7 @@ sub LocalHeader myRead($filename, $filenameLength); outputFilename($filename); - my $cl64 = new U64 $compressedLength ; + my $cl64 = U64->new( $compressedLength ); my %ExtraContext = (); if ($extraLength) { @@ -1154,7 +1154,7 @@ sub GeneralPurposeBits if ($method == ZIP_CM_DEFLATE) { - my $mid = $gp & 0x03; + my $mid = ($gp >> 1) & 0x03 ; out1 "[Bits 1-2]", "$mid '$lookup{$mid}'"; } @@ -1171,8 +1171,8 @@ sub GeneralPurposeBits if ($method == ZIP_CM_IMPLODE) # Imploding { - out1 "[Bit 1]", ($gp & 1 ? "1 '8k" : "0 '4k") . " Sliding Dictionary'" ; - out1 "[Bit 2]", ($gp & 2 ? "1 '3" : "0 '2" ) . " Shannon-Fano Trees'" ; + out1 "[Bit 1]", ($gp & (1 << 1) ? "1 '8k" : "0 '4k") . " Sliding Dictionary'" ; + out1 "[Bit 2]", ($gp & (2 << 1) ? "1 '3" : "0 '2" ) . " Shannon-Fano Trees'" ; } out1 "[Bit 3]", "1 'Streamed'" if $gp & ZIP_GP_FLAG_STREAMING_MASK; @@ -1363,7 +1363,7 @@ sub Ntfs2Unix # NTFS offset is 19DB1DED53E8000 my $hex = Value_U64($u64) ; - my $NTFS_OFFSET = new U64 0x19DB1DE, 0xD53E8000 ; + my $NTFS_OFFSET = U64->new( 0x19DB1DE, 0xD53E8000 ); $u64->subtract($NTFS_OFFSET); my $elapse = $u64->get64bit(); my $ns = ($elapse % 10000000) * 100; @@ -1766,8 +1766,8 @@ sub scanCentralDirectory my $got = [$locHeaderOffset, $compressedLength] ; - # my $v64 = new U64 $compressedLength ; - # my $loc64 = new U64 $locHeaderOffset ; + # my $v64 = U64->new( $compressedLength ); + # my $loc64 = U64->new( $locHeaderOffset ); # my $got = [$loc64, $v64] ; # if (full32 $compressedLength || full32 $locHeaderOffset) { @@ -2285,7 +2285,7 @@ OPTIONS -v Verbose - output more stuff --version Print version number -Copyright (c) 2011-2020 Paul Marquess. All rights reserved. +Copyright (c) 2011-2021 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/IO-Compress/lib/Compress/Zlib.pm b/cpan/IO-Compress/lib/Compress/Zlib.pm index 1290b1d63356..238027128955 100644 --- a/cpan/IO-Compress/lib/Compress/Zlib.pm +++ b/cpan/IO-Compress/lib/Compress/Zlib.pm @@ -7,18 +7,18 @@ use Carp ; use IO::Handle ; use Scalar::Util qw(dualvar); -use IO::Compress::Base::Common 2.096 ; -use Compress::Raw::Zlib 2.096 ; -use IO::Compress::Gzip 2.096 ; -use IO::Uncompress::Gunzip 2.096 ; +use IO::Compress::Base::Common 2.100 ; +use Compress::Raw::Zlib 2.100 ; +use IO::Compress::Gzip 2.100 ; +use IO::Uncompress::Gunzip 2.100 ; use strict ; use warnings ; use bytes ; our ($VERSION, $XS_VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); -$VERSION = '2.096'; -$XS_VERSION = $VERSION; +$VERSION = '2.100'; +$XS_VERSION = $VERSION; $VERSION = eval $VERSION; @ISA = qw(Exporter); @@ -126,7 +126,7 @@ sub gzopen($$) my @params = () ; croak "gzopen: file parameter is not a filehandle or filename" - unless isaFilehandle $file || isaFilename $file || + unless isaFilehandle $file || isaFilename $file || (ref $file && ref $file eq 'SCALAR'); return undef unless $mode =~ /[rwa]/i ; @@ -134,17 +134,17 @@ sub gzopen($$) _set_gzerr(0) ; if ($writing) { - $gz = new IO::Compress::Gzip($file, Minimal => 1, AutoClose => 1, - %defOpts) + $gz = IO::Compress::Gzip->new($file, Minimal => 1, AutoClose => 1, + %defOpts) or $Compress::Zlib::gzerrno = $IO::Compress::Gzip::GzipError; } else { - $gz = new IO::Uncompress::Gunzip($file, + $gz = IO::Uncompress::Gunzip->new($file, Transparent => 1, - Append => 0, - AutoClose => 1, + Append => 0, + AutoClose => 1, MultiStream => 1, - Strict => 0) + Strict => 0) or $Compress::Zlib::gzerrno = $IO::Uncompress::Gunzip::GunzipError; } @@ -161,7 +161,7 @@ sub Compress::Zlib::gzFile::gzread return _set_gzerr(Z_STREAM_ERROR()) if $self->[1] ne 'inflate'; - my $len = defined $_[1] ? $_[1] : 4096 ; + my $len = defined $_[1] ? $_[1] : 4096 ; my $gz = $self->[0] ; if ($self->gzeof() || $len == 0) { @@ -171,7 +171,7 @@ sub Compress::Zlib::gzFile::gzread return 0 ; } - my $status = $gz->read($_[0], $len) ; + my $status = $gz->read($_[0], $len) ; _save_gzerr($gz, 1); return $status ; } @@ -185,7 +185,7 @@ sub Compress::Zlib::gzFile::gzreadline # Maintain backward compatibility with 1.x behaviour # It didn't support $/, so this can't either. local $/ = "\n" ; - $_[0] = $gz->getline() ; + $_[0] = $gz->getline() ; } _save_gzerr($gz, 1); return defined $_[0] ? length $_[0] : 0 ; @@ -199,7 +199,7 @@ sub Compress::Zlib::gzFile::gzwrite return _set_gzerr(Z_STREAM_ERROR()) if $self->[1] ne 'deflate'; - $] >= 5.008 and (utf8::downgrade($_[0], 1) + $] >= 5.008 and (utf8::downgrade($_[0], 1) or croak "Wide character in gzwrite"); my $status = $gz->write($_[0]) ; @@ -282,8 +282,8 @@ sub Compress::Zlib::gzFile::gzsetparams return _set_gzerr(Z_STREAM_ERROR()) if $self->[1] ne 'deflate'; - - my $status = *$gz->{Compress}->deflateParams(-Level => $level, + + my $status = *$gz->{Compress}->deflateParams(-Level => $level, -Strategy => $strategy); _save_gzerr($gz); return $status ; @@ -293,7 +293,7 @@ sub Compress::Zlib::gzFile::gzerror { my $self = shift ; my $gz = $self->[0] ; - + return $Compress::Zlib::gzerrno ; } @@ -310,7 +310,7 @@ sub compress($;$) $in = \$_[0] ; } - $] >= 5.008 and (utf8::downgrade($$in, 1) + $] >= 5.008 and (utf8::downgrade($$in, 1) or croak "Wide character in compress"); my $level = (@_ == 2 ? $_[1] : Z_DEFAULT_COMPRESSION() ); @@ -322,7 +322,7 @@ sub compress($;$) MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY, 4096, - '') + '') or return undef ; $err = $x->deflate($in, $output) ; @@ -330,7 +330,7 @@ sub compress($;$) $err = $x->flush($output) ; return undef unless $err == Z_OK() ; - + return $output ; } @@ -346,21 +346,21 @@ sub uncompress($) $in = \$_[0] ; } - $] >= 5.008 and (utf8::downgrade($$in, 1) - or croak "Wide character in uncompress"); - + $] >= 5.008 and (utf8::downgrade($$in, 1) + or croak "Wide character in uncompress"); + my ($obj, $status) = Compress::Raw::Zlib::_inflateInit(0, - MAX_WBITS, 4096, "") ; - - $status == Z_OK + MAX_WBITS, 4096, "") ; + + $status == Z_OK or return undef; - - $obj->inflate($in, $output) == Z_STREAM_END + + $obj->inflate($in, $output) == Z_STREAM_END or return undef; - + return $output; } - + sub deflateInit(@) { my ($got) = ParseParameters(0, @@ -374,27 +374,27 @@ sub deflateInit(@) 'dictionary' => [IO::Compress::Base::Common::Parse_any, ""], }, @_ ) ; - croak "Compress::Zlib::deflateInit: Bufsize must be >= 1, you specified " . + croak "Compress::Zlib::deflateInit: Bufsize must be >= 1, you specified " . $got->getValue('bufsize') unless $got->getValue('bufsize') >= 1; my $obj ; - + my $status = 0 ; - ($obj, $status) = + ($obj, $status) = Compress::Raw::Zlib::_deflateInit(0, - $got->getValue('level'), - $got->getValue('method'), - $got->getValue('windowbits'), - $got->getValue('memlevel'), - $got->getValue('strategy'), + $got->getValue('level'), + $got->getValue('method'), + $got->getValue('windowbits'), + $got->getValue('memlevel'), + $got->getValue('strategy'), $got->getValue('bufsize'), $got->getValue('dictionary')) ; my $x = ($status == Z_OK() ? bless $obj, "Zlib::OldDeflate" : undef) ; return wantarray ? ($x, $status) : $x ; } - + sub inflateInit(@) { my ($got) = ParseParameters(0, @@ -405,15 +405,15 @@ sub inflateInit(@) }, @_) ; - croak "Compress::Zlib::inflateInit: Bufsize must be >= 1, you specified " . + croak "Compress::Zlib::inflateInit: Bufsize must be >= 1, you specified " . $got->getValue('bufsize') unless $got->getValue('bufsize') >= 1; my $status = 0 ; my $obj ; ($obj, $status) = Compress::Raw::Zlib::_inflateInit(FLAG_CONSUME_INPUT, - $got->getValue('windowbits'), - $got->getValue('bufsize'), + $got->getValue('windowbits'), + $got->getValue('bufsize'), $got->getValue('dictionary')) ; my $x = ($status == Z_OK() ? bless $obj, "Zlib::OldInflate" : undef) ; @@ -442,7 +442,7 @@ sub flush my $output ; my $flag = shift || Compress::Zlib::Z_FINISH(); my $status = $self->SUPER::flush($output, $flag) ; - + wantarray ? ($output, $status) : $output ; } @@ -461,7 +461,7 @@ sub inflate package Compress::Zlib ; -use IO::Compress::Gzip::Constants 2.096 ; +use IO::Compress::Gzip::Constants 2.100 ; sub memGzip($) { @@ -473,13 +473,13 @@ sub memGzip($) MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY, 4096, - '') + '') or return undef ; - + # if the deflation buffer isn't a reference, make it one my $string = (ref $_[0] ? $_[0] : \$_[0]) ; - $] >= 5.008 and (utf8::downgrade($$string, 1) + $] >= 5.008 and (utf8::downgrade($$string, 1) or croak "Wide character in memGzip"); my $out; @@ -487,12 +487,12 @@ sub memGzip($) $x->deflate($string, $out) == Z_OK or return undef ; - + $x->flush($out) == Z_OK or return undef ; - - return IO::Compress::Gzip::Constants::GZIP_MINIMUM_HEADER . - $out . + + return IO::Compress::Gzip::Constants::GZIP_MINIMUM_HEADER . + $out . pack("V V", $x->crc32(), $x->total_in()); } @@ -501,10 +501,10 @@ sub _removeGzipHeader($) { my $string = shift ; - return Z_DATA_ERROR() + return Z_DATA_ERROR() if length($$string) < GZIP_MIN_HEADER_SIZE ; - my ($magic1, $magic2, $method, $flags, $time, $xflags, $oscode) = + my ($magic1, $magic2, $method, $flags, $time, $xflags, $oscode) = unpack ('CCCCVCC', $$string); return Z_DATA_ERROR() @@ -551,7 +551,7 @@ sub _removeGzipHeader($) if length ($$string) < GZIP_FHCRC_SIZE ; substr($$string, 0, GZIP_FHCRC_SIZE) = ''; } - + return Z_OK(); } @@ -566,24 +566,24 @@ sub memGunzip($) { # if the buffer isn't a reference, make it one my $string = (ref $_[0] ? $_[0] : \$_[0]); - - $] >= 5.008 and (utf8::downgrade($$string, 1) + + $] >= 5.008 and (utf8::downgrade($$string, 1) or croak "Wide character in memGunzip"); _set_gzerr(0); my $status = _removeGzipHeader($string) ; - $status == Z_OK() + $status == Z_OK() or return _set_gzerr_undef($status); - + my $bufsize = length $$string > 4096 ? length $$string : 4096 ; my $x = Compress::Raw::Zlib::_inflateInit(FLAG_CRC | FLAG_CONSUME_INPUT, - -MAX_WBITS(), $bufsize, '') + -MAX_WBITS(), $bufsize, '') or return _ret_gun_error(); my $output = '' ; $status = $x->inflate($string, $output); - + if ( $status == Z_OK() ) { _set_gzerr(Z_DATA_ERROR()); @@ -606,7 +606,7 @@ sub memGunzip($) $$string = ''; } - return $output; + return $output; } # Autoload methods go after __END__, and are processed by the autosplit program. @@ -938,23 +938,23 @@ I function. use strict ; use warnings ; - + use Compress::Zlib ; - + # use stdin if no files supplied @ARGV = '-' unless @ARGV ; - + foreach my $file (@ARGV) { my $buffer ; - + my $gz = gzopen($file, "rb") or die "Cannot open $file: $gzerrno\n" ; - + print $buffer while $gz->gzread($buffer) > 0 ; - + die "Error reading from $file: $gzerrno" . ($gzerrno+0) . "\n" if $gzerrno != Z_STREAM_END ; - + $gz->gzclose() ; } @@ -963,28 +963,28 @@ very simple I like script. use strict ; use warnings ; - + use Compress::Zlib ; - + die "Usage: gzgrep pattern [file...]\n" unless @ARGV >= 1; - + my $pattern = shift ; - + # use stdin if no files supplied @ARGV = '-' unless @ARGV ; - + foreach my $file (@ARGV) { my $gz = gzopen($file, "rb") or die "Cannot open $file: $gzerrno\n" ; - + while ($gz->gzreadline($_) > 0) { print if /$pattern/ ; } - + die "Error reading from $file: $gzerrno\n" if $gzerrno != Z_STREAM_END ; - + $gz->gzclose() ; } @@ -994,14 +994,14 @@ standard output. use strict ; use warnings ; - + use Compress::Zlib ; - + binmode STDOUT; # gzopen only sets it on the fd - + my $gz = gzopen(\*STDOUT, "wb") or die "Cannot open stdout: $gzerrno\n" ; - + while (<>) { $gz->gzwrite($_) or die "error writing: $gzerrno\n" ; @@ -1275,18 +1275,18 @@ input, deflates it and writes it to standard output. 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 ; =head1 Inflate Interface @@ -1313,13 +1313,13 @@ I error code. The function optionally takes a number of named options specified as C<< -Name=>value >> pairs. This allows individual options to be tailored without having to specify them all in the parameter list. - + For backward compatibility, it is also possible to pass the parameters as a reference to a hash containing the name=>value pairs. - + The function takes one optional parameter, a reference to a hash. The contents of the hash allow the deflation interface to be tailored. - + Here is a list of the valid options: =over 5 @@ -1409,27 +1409,27 @@ Here is an example of using C. use strict ; use warnings ; - + use Compress::Zlib ; - + my $x = inflateInit() or die "Cannot create a inflation stream\n" ; - + my $input = '' ; binmode STDIN; binmode STDOUT; - + my ($output, $status) ; while (read(STDIN, $input, 4096)) { ($output, $status) = $x->inflate(\$input) ; - + print $output if $status == Z_OK or $status == Z_STREAM_END ; - + last if $status != Z_OK ; } - + die "inflation failed\n" unless $status == Z_STREAM_END ; @@ -1506,8 +1506,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 1995-2020 Paul Marquess. All rights reserved. +Copyright (c) 1995-2021 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. - diff --git a/cpan/IO-Compress/lib/File/GlobMapper.pm b/cpan/IO-Compress/lib/File/GlobMapper.pm index a4e5385565e7..f015b1656745 100644 --- a/cpan/IO-Compress/lib/File/GlobMapper.pm +++ b/cpan/IO-Compress/lib/File/GlobMapper.pm @@ -51,7 +51,7 @@ sub globmap ($$;) my $inputGlob = shift ; my $outputGlob = shift ; - my $obj = new File::GlobMapper($inputGlob, $outputGlob, @_) + my $obj = File::GlobMapper->new($inputGlob, $outputGlob, @_) or croak "globmap: $Error" ; return $obj->getFileMap(); } @@ -383,7 +383,7 @@ File::GlobMapper - Extend File Glob to Allow Input and Output Files my $aref = globmap $input => $output or die $File::GlobMapper::Error ; - my $gm = new File::GlobMapper $input => $output + my $gm = File::GlobMapper->new( $input => $output ) or die $File::GlobMapper::Error ; diff --git a/cpan/IO-Compress/lib/IO/Compress/Adapter/Bzip2.pm b/cpan/IO-Compress/lib/IO/Compress/Adapter/Bzip2.pm index 635091e802a4..d20b62b9b349 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Adapter/Bzip2.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Adapter/Bzip2.pm @@ -4,12 +4,12 @@ use strict; use warnings; use bytes; -use IO::Compress::Base::Common 2.096 qw(:Status); +use IO::Compress::Base::Common 2.100 qw(:Status); -use Compress::Raw::Bzip2 2.096 ; +use Compress::Raw::Bzip2 2.100 ; our ($VERSION); -$VERSION = '2.096'; +$VERSION = '2.100'; sub mkCompObject { @@ -21,7 +21,7 @@ sub mkCompObject $WorkFactor = 0 if ! defined $WorkFactor ; $Verbosity = 0 if ! defined $Verbosity ; - my ($def, $status) = new Compress::Raw::Bzip2(1, $BlockSize100K, + my ($def, $status) = Compress::Raw::Bzip2->new(1, $BlockSize100K, $WorkFactor, $Verbosity); return (undef, "Could not create Deflate object: $status", $status) @@ -30,7 +30,7 @@ sub mkCompObject return bless {'Def' => $def, 'Error' => '', 'ErrorNo' => 0, - } ; + } ; } sub compr @@ -44,11 +44,11 @@ sub compr if ($status != BZ_RUN_OK) { - $self->{Error} = "Deflate Error: $status"; + $self->{Error} = "Deflate Error: $status"; return STATUS_ERROR; } - return STATUS_OK; + return STATUS_OK; } sub flush @@ -62,12 +62,12 @@ sub flush if ($status != BZ_RUN_OK) { - $self->{Error} = "Deflate Error: $status"; + $self->{Error} = "Deflate Error: $status"; return STATUS_ERROR; } - return STATUS_OK; - + return STATUS_OK; + } sub close @@ -81,12 +81,12 @@ sub close if ($status != BZ_STREAM_END) { - $self->{Error} = "Deflate Error: $status"; + $self->{Error} = "Deflate Error: $status"; return STATUS_ERROR; } - return STATUS_OK; - + return STATUS_OK; + } @@ -96,18 +96,18 @@ sub reset my $outer = $self->{Outer}; - my ($def, $status) = new Compress::Raw::Bzip2(); + my ($def, $status) = Compress::Raw::Bzip2->new(); $self->{ErrorNo} = ($status == BZ_OK) ? 0 : $status ; if ($status != BZ_OK) { - $self->{Error} = "Cannot create Deflate object: $status"; + $self->{Error} = "Cannot create Deflate object: $status"; return STATUS_ERROR; } $self->{Def} = $def; - return STATUS_OK; + return STATUS_OK; } sub compressedBytes @@ -151,4 +151,3 @@ sub uncompressedBytes 1; __END__ - diff --git a/cpan/IO-Compress/lib/IO/Compress/Adapter/Deflate.pm b/cpan/IO-Compress/lib/IO/Compress/Adapter/Deflate.pm index 4f6f1d617508..fc8332ce2010 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Adapter/Deflate.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Adapter/Deflate.pm @@ -4,13 +4,13 @@ use strict; use warnings; use bytes; -use IO::Compress::Base::Common 2.096 qw(:Status); -use Compress::Raw::Zlib 2.096 qw( !crc32 !adler32 ) ; - -require Exporter; +use IO::Compress::Base::Common 2.100 qw(:Status); +use Compress::Raw::Zlib 2.100 qw( !crc32 !adler32 ) ; + +require Exporter; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, @EXPORT, %DEFLATE_CONSTANTS); -$VERSION = '2.096'; +$VERSION = '2.100'; @ISA = qw(Exporter); @EXPORT_OK = @Compress::Raw::Zlib::DEFLATE_CONSTANTS; %EXPORT_TAGS = %Compress::Raw::Zlib::DEFLATE_CONSTANTS; @@ -24,20 +24,20 @@ sub mkCompObject my $level = shift ; my $strategy = shift ; - my ($def, $status) = new Compress::Raw::Zlib::Deflate + my ($def, $status) = Compress::Raw::Zlib::Deflate->new( -AppendOutput => 1, -CRC32 => $crc32, -ADLER32 => $adler32, -Level => $level, -Strategy => $strategy, - -WindowBits => - MAX_WBITS; + -WindowBits => - MAX_WBITS); - return (undef, "Cannot create Deflate object: $status", $status) - if $status != Z_OK; + return (undef, "Cannot create Deflate object: $status", $status) + if $status != Z_OK; return bless {'Def' => $def, 'Error' => '', - } ; + } ; } sub compr @@ -51,11 +51,11 @@ sub compr if ($status != Z_OK) { - $self->{Error} = "Deflate Error: $status"; + $self->{Error} = "Deflate Error: $status"; return STATUS_ERROR; } - return STATUS_OK; + return STATUS_OK; } sub flush @@ -70,11 +70,11 @@ sub flush if ($status != Z_OK) { - $self->{Error} = "Deflate Error: $status"; + $self->{Error} = "Deflate Error: $status"; return STATUS_ERROR; } - return STATUS_OK; + return STATUS_OK; } sub close @@ -97,14 +97,14 @@ sub reset $self->{ErrorNo} = $status; if ($status != Z_OK) { - $self->{Error} = "Deflate Error: $status"; + $self->{Error} = "Deflate Error: $status"; return STATUS_ERROR; } - return STATUS_OK; + return STATUS_OK; } -sub deflateParams +sub deflateParams { my $self = shift ; @@ -114,11 +114,11 @@ sub deflateParams $self->{ErrorNo} = $status; if ($status != Z_OK) { - $self->{Error} = "deflateParams Error: $status"; + $self->{Error} = "deflateParams Error: $status"; return STATUS_ERROR; } - return STATUS_OK; + return STATUS_OK; } @@ -167,4 +167,3 @@ sub adler32 1; __END__ - diff --git a/cpan/IO-Compress/lib/IO/Compress/Adapter/Identity.pm b/cpan/IO-Compress/lib/IO/Compress/Adapter/Identity.pm index 00b529b01999..091e655bd4a1 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Adapter/Identity.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Adapter/Identity.pm @@ -4,10 +4,10 @@ use strict; use warnings; use bytes; -use IO::Compress::Base::Common 2.096 qw(:Status); +use IO::Compress::Base::Common 2.100 qw(:Status); our ($VERSION); -$VERSION = '2.096'; +$VERSION = '2.100'; sub mkCompObject { @@ -19,7 +19,7 @@ sub mkCompObject 'UnCompSize' => 0, 'Error' => '', 'ErrorNo' => 0, - } ; + } ; } sub compr @@ -30,7 +30,7 @@ sub compr $self->{CompSize} += length ${ $_[0] } ; $self->{UnCompSize} = $self->{CompSize} ; - if ( ref $_[1] ) + if ( ref $_[1] ) { ${ $_[1] } .= ${ $_[0] } } else { $_[1] .= ${ $_[0] } } @@ -43,14 +43,14 @@ sub flush { my $self = shift ; - return STATUS_OK; + return STATUS_OK; } sub close { my $self = shift ; - return STATUS_OK; + return STATUS_OK; } sub reset @@ -60,14 +60,14 @@ sub reset $self->{CompSize} = 0; $self->{UnCompSize} = 0; - return STATUS_OK; + return STATUS_OK; } -sub deflateParams +sub deflateParams { my $self = shift ; - return STATUS_OK; + return STATUS_OK; } #sub total_out @@ -98,4 +98,3 @@ sub uncompressedBytes __END__ - diff --git a/cpan/IO-Compress/lib/IO/Compress/Base.pm b/cpan/IO-Compress/lib/IO/Compress/Base.pm index 1f1942965b75..bc49e0184158 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Base.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Base.pm @@ -6,7 +6,7 @@ require 5.006 ; use strict ; use warnings; -use IO::Compress::Base::Common 2.096 ; +use IO::Compress::Base::Common 2.100 ; use IO::File (); ; use Scalar::Util (); @@ -20,7 +20,7 @@ use Symbol(); our (@ISA, $VERSION); @ISA = qw(IO::File Exporter); -$VERSION = '2.096'; +$VERSION = '2.100'; #Can't locate object method "SWASHNEW" via package "utf8" (perhaps you forgot to load "utf8"?) at .../ext/Compress-Zlib/Gzip/blib/lib/Compress/Zlib/Common.pm line 16. @@ -254,8 +254,8 @@ sub _create *$obj->{Compress} = $obj->mkComp($got) or return undef; - *$obj->{UnCompSize} = new U64 ; - *$obj->{CompSize} = new U64 ; + *$obj->{UnCompSize} = U64->new; + *$obj->{CompSize} = U64->new; if ( $outType eq 'buffer') { ${ *$obj->{Buffer} } = '' @@ -279,7 +279,7 @@ sub _create my $mode = '>' ; $mode = '>>' if $appendOutput; - *$obj->{FH} = new IO::File "$mode $outValue" + *$obj->{FH} = IO::File->new( "$mode $outValue" ) or return $obj->saveErrorString(undef, "cannot open file '$outValue': $!", $!) ; *$obj->{StdIO} = ($outValue eq '-'); setBinModeOutput(*$obj->{FH}) ; @@ -340,7 +340,7 @@ sub _def my $haveOut = @_ ; my $output = shift ; - my $x = new IO::Compress::Base::Validator($class, *$obj->{Error}, $name, $input, $output) + my $x = IO::Compress::Base::Validator->new($class, *$obj->{Error}, $name, $input, $output) or return undef ; push @_, $output if $haveOut && $x->{Hash}; @@ -493,7 +493,7 @@ sub _wr2 if ( ! $isFilehandle ) { - $fh = new IO::File "<$input" + $fh = IO::File->new( "<$input" ) or return $self->saveErrorString(undef, "cannot open file '$input': $!", $!) ; } binmode $fh ; @@ -983,23 +983,27 @@ sub _notAvailable return sub { Carp::croak "$name Not Available: File opened only for output" ; } ; } -*read = _notAvailable('read'); -*READ = _notAvailable('read'); -*readline = _notAvailable('readline'); -*READLINE = _notAvailable('readline'); -*getc = _notAvailable('getc'); -*GETC = _notAvailable('getc'); - -*FILENO = \&fileno; -*PRINT = \&print; -*PRINTF = \&printf; -*WRITE = \&syswrite; -*write = \&syswrite; -*SEEK = \&seek; -*TELL = \&tell; -*EOF = \&eof; -*CLOSE = \&close; -*BINMODE = \&binmode; +{ + no warnings 'once'; + + *read = _notAvailable('read'); + *READ = _notAvailable('read'); + *readline = _notAvailable('readline'); + *READLINE = _notAvailable('readline'); + *getc = _notAvailable('getc'); + *GETC = _notAvailable('getc'); + + *FILENO = \&fileno; + *PRINT = \&print; + *PRINTF = \&printf; + *WRITE = \&syswrite; + *write = \&syswrite; + *SEEK = \&seek; + *TELL = \&tell; + *EOF = \&eof; + *CLOSE = \&close; + *BINMODE = \&binmode; +} #*sysread = \&_notAvailable; #*syswrite = \&_write; @@ -1047,8 +1051,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2020 Paul Marquess. All rights reserved. +Copyright (c) 2005-2021 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. - diff --git a/cpan/IO-Compress/lib/IO/Compress/Base/Common.pm b/cpan/IO-Compress/lib/IO/Compress/Base/Common.pm index 37501a63e5f2..8f0530cdddc0 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Base/Common.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Base/Common.pm @@ -11,7 +11,7 @@ use File::GlobMapper; require Exporter; our ($VERSION, @ISA, @EXPORT, %EXPORT_TAGS, $HAS_ENCODE); @ISA = qw(Exporter); -$VERSION = '2.096'; +$VERSION = '2.100'; @EXPORT = qw( isaFilehandle isaFilename isaScalar whatIsInput whatIsOutput @@ -160,7 +160,7 @@ sub whatIsInput($;$) #use IO::File; $got = 'handle'; $_[0] = *STDIN; - #$_[0] = new IO::File("<-"); + #$_[0] = IO::File->new("<-"); } return $got; @@ -174,7 +174,7 @@ sub whatIsOutput($;$) { $got = 'handle'; $_[0] = *STDOUT; - #$_[0] = new IO::File(">-"); + #$_[0] = IO::File->new(">-"); } return $got; @@ -267,7 +267,7 @@ sub IO::Compress::Base::Validator::new { $data{GlobMap} = 1 ; $data{inType} = $data{outType} = 'filename'; - my $mapper = new File::GlobMapper($_[0], $_[1]); + my $mapper = File::GlobMapper->new($_[0], $_[1]); if ( ! $mapper ) { return $obj->saveErrorString($File::GlobMapper::Error) ; @@ -509,7 +509,7 @@ sub ParseParameters return $_[1] if @_ == 2 && defined $_[1] && UNIVERSAL::isa($_[1], "IO::Compress::Base::Parameters"); - my $p = new IO::Compress::Base::Parameters() ; + my $p = IO::Compress::Base::Parameters->new(); $p->parse(@_) or croak "$sub: $p->[IxError]" ; diff --git a/cpan/IO-Compress/lib/IO/Compress/Bzip2.pm b/cpan/IO-Compress/lib/IO/Compress/Bzip2.pm index 950366c378cd..88dd7f9bfe98 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Bzip2.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Bzip2.pm @@ -5,16 +5,16 @@ use warnings; use bytes; require Exporter ; -use IO::Compress::Base 2.096 ; +use IO::Compress::Base 2.100 ; -use IO::Compress::Base::Common 2.096 qw(); -use IO::Compress::Adapter::Bzip2 2.096 ; +use IO::Compress::Base::Common 2.100 qw(); +use IO::Compress::Adapter::Bzip2 2.100 ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $Bzip2Error); -$VERSION = '2.096'; +$VERSION = '2.100'; $Bzip2Error = ''; @ISA = qw(IO::Compress::Base Exporter); @@ -40,7 +40,7 @@ sub bzip2 } -sub mkHeader +sub mkHeader { my $self = shift ; return ''; @@ -51,9 +51,9 @@ sub getExtraParams { my $self = shift ; - use IO::Compress::Base::Common 2.096 qw(:Parse); - - return ( + use IO::Compress::Base::Common 2.100 qw(:Parse); + + return ( 'blocksize100k' => [IO::Compress::Base::Common::Parse_unsigned, 1], 'workfactor' => [IO::Compress::Base::Common::Parse_unsigned, 0], 'verbosity' => [IO::Compress::Base::Common::Parse_boolean, 0], @@ -66,7 +66,7 @@ sub ckParams { my $self = shift ; my $got = shift; - + # check that BlockSize100K is a number between 1 & 9 if ($got->parsed('blocksize100k')) { my $value = $got->getValue('blocksize100k'); @@ -101,7 +101,7 @@ sub mkComp return $self->saveErrorString(undef, $errstr, $errno) if ! defined $obj; - + return $obj; } @@ -133,7 +133,7 @@ sub getFileInfo my $self = shift ; my $params = shift; my $file = shift ; - + } 1; @@ -151,7 +151,7 @@ IO::Compress::Bzip2 - Write bzip2 files/buffers my $status = bzip2 $input => $output [,OPTS] or die "bzip2 failed: $Bzip2Error\n"; - my $z = new IO::Compress::Bzip2 $output [,OPTS] + my $z = IO::Compress::Bzip2->new( $output [,OPTS] ) or die "bzip2 failed: $Bzip2Error\n"; $z->print($string); @@ -426,7 +426,7 @@ compressed data to a buffer, C<$buffer>. use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ; use IO::File ; - my $input = new IO::File "new( " \$buffer @@ -463,7 +463,7 @@ and if you want to compress each file one at a time, this will do the trick The format of the constructor for C is shown below - my $z = new IO::Compress::Bzip2 $output [,OPTS] + my $z = IO::Compress::Bzip2->new( $output [,OPTS] ) or die "IO::Compress::Bzip2 failed: $Bzip2Error\n"; It returns an C object on success and undef on failure. @@ -818,8 +818,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2020 Paul Marquess. All rights reserved. +Copyright (c) 2005-2021 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. - diff --git a/cpan/IO-Compress/lib/IO/Compress/Deflate.pm b/cpan/IO-Compress/lib/IO/Compress/Deflate.pm index 358e01989ef0..c3aa1eab78ce 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Deflate.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Deflate.pm @@ -8,16 +8,16 @@ use bytes; require Exporter ; -use IO::Compress::RawDeflate 2.096 (); -use IO::Compress::Adapter::Deflate 2.096 ; +use IO::Compress::RawDeflate 2.100 (); +use IO::Compress::Adapter::Deflate 2.100 ; -use IO::Compress::Zlib::Constants 2.096 ; -use IO::Compress::Base::Common 2.096 qw(); +use IO::Compress::Zlib::Constants 2.100 ; +use IO::Compress::Base::Common 2.100 qw(); our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $DeflateError); -$VERSION = '2.096'; +$VERSION = '2.100'; $DeflateError = ''; @ISA = qw(IO::Compress::RawDeflate Exporter); @@ -80,7 +80,7 @@ sub mkDeflateHdr($$$;$) return $hdr; } -sub mkHeader +sub mkHeader { my $self = shift ; my $param = shift ; @@ -89,7 +89,7 @@ sub mkHeader my $strategy = $param->getValue('strategy'); my $lflag ; - $level = 6 + $level = 6 if $level == Z_DEFAULT_COMPRESSION ; if (ZLIB_VERNUM >= 0x1210) @@ -118,7 +118,7 @@ sub ckParams { my $self = shift ; my $got = shift; - + $got->setValue('adler32' => 1); return 1 ; } @@ -149,6 +149,7 @@ sub getExtraParams sub getInverseClass { + no warnings 'once'; return ('IO::Uncompress::Inflate', \$IO::Uncompress::Inflate::InflateError); } @@ -158,7 +159,7 @@ sub getFileInfo my $self = shift ; my $params = shift; my $file = shift ; - + } @@ -178,7 +179,7 @@ IO::Compress::Deflate - Write RFC 1950 files/buffers my $status = deflate $input => $output [,OPTS] or die "deflate failed: $DeflateError\n"; - my $z = new IO::Compress::Deflate $output [,OPTS] + my $z = IO::Compress::Deflate->new( $output [,OPTS] ) or die "deflate failed: $DeflateError\n"; $z->print($string); @@ -455,7 +456,7 @@ compressed data to a buffer, C<$buffer>. use IO::Compress::Deflate qw(deflate $DeflateError) ; use IO::File ; - my $input = new IO::File "new( " \$buffer @@ -492,7 +493,7 @@ and if you want to compress each file one at a time, this will do the trick The format of the constructor for C is shown below - my $z = new IO::Compress::Deflate $output [,OPTS] + my $z = IO::Compress::Deflate->new( $output [,OPTS] ) or die "IO::Compress::Deflate failed: $DeflateError\n"; It returns an C object on success and undef on failure. @@ -951,8 +952,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2020 Paul Marquess. All rights reserved. +Copyright (c) 2005-2021 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. - diff --git a/cpan/IO-Compress/lib/IO/Compress/FAQ.pod b/cpan/IO-Compress/lib/IO/Compress/FAQ.pod index d6d11c764679..367468ec0782 100644 --- a/cpan/IO-Compress/lib/IO/Compress/FAQ.pod +++ b/cpan/IO-Compress/lib/IO/Compress/FAQ.pod @@ -79,7 +79,7 @@ write a C<.tar.Z> file use Archive::Tar; use IO::File; - my $fh = new IO::File "| compress -c >$filename"; + my $fh = IO::File->new( "| compress -c >$filename" ); my $tar = Archive::Tar->new(); ... $tar->write($fh); @@ -101,7 +101,7 @@ recompression. my $gzipFile = "somefile.gz"; my $bzipFile = "somefile.bz2"; - my $gunzip = new IO::Uncompress::Gunzip $gzipFile + my $gunzip = IO::Uncompress::Gunzip->new( $gzipFile ) or die "Cannot gunzip $gzipFile: $GunzipError\n" ; bzip2 $gunzip => $bzipFile @@ -167,8 +167,8 @@ by including the C option. If you want to create a zip64 zip file with the OO interface you must specify the C option. - my $zip = new IO::Compress::Zip "whatever", Zip64 => 1; - + my $zip = IO::Compress::Zip->new( "whatever", Zip64 => 1 ); + When uncompressing with C, it will automatically detect if the zip file is zip64. @@ -300,14 +300,14 @@ L 0x1f8b; use constant OS_MAGIC => 0x03; - + sub handler { my $r = shift; my ($fh,$gz); @@ -316,28 +316,28 @@ Lheader_out('Content-Encoding'=>'gzip'); $r->send_http_header; return OK if $r->header_only; - + tie *STDOUT,'Apache::GZip',$r; print($_) while <$fh>; untie *STDOUT; return OK; } - + sub TIEHANDLE { my($class,$r) = @_; # initialize a deflation stream my $d = deflateInit(-WindowBits=>-MAX_WBITS()) || return undef; - + # gzip header -- don't ask how I found out $r->print(pack("nccVcc",GZIP_MAGIC,Z_DEFLATED,0,time(),0,OS_MAGIC)); - + return bless { r => $r, crc => crc32(undef), d => $d, l => 0 },$class; } - + sub PRINT { my $self = shift; foreach (@_) { @@ -349,18 +349,18 @@ L{crc} = crc32($_,$self->{crc}); } } - + sub DESTROY { my $self = shift; - + # flush the output buffers my $data = $self->{d}->flush; $self->{r}->print($data); - + # print the CRC and the total length (uncompressed) $self->{r}->print(pack("LL",@{$self}{qw/crc l/})); } - + 1; Here's the Apache configuration entry you'll need to make use of it. Once @@ -401,12 +401,12 @@ C is used instead of C the whole tied filehandle code can be removed. Here is the rewritten code. package Apache::GZip; - + use strict vars; use Apache::Constants ':common'; use IO::Compress::Gzip; use IO::File; - + sub handler { my $r = shift; my ($fh,$gz); @@ -416,22 +416,22 @@ filehandle code can be removed. Here is the rewritten code. $r->send_http_header; return OK if $r->header_only; - my $gz = new IO::Compress::Gzip '-', Minimal => 1 + my $gz = IO::Compress::Gzip->new( '-', Minimal => 1 ) or return DECLINED ; print $gz $_ while <$fh>; - + return OK; } - + or even more succinctly, like this, using a one-shot gzip package Apache::GZip; - + use strict vars; use Apache::Constants ':common'; use IO::Compress::Gzip qw(gzip); - + sub handler { my $r = shift; $r->header_out('Content-Encoding'=>'gzip'); @@ -443,7 +443,7 @@ or even more succinctly, like this, using a one-shot gzip return OK; } - + 1; The use of one-shot C above just reads from C<< $r->filename >> and @@ -468,7 +468,7 @@ read from the FTP Server. use Net::FTP; use IO::Uncompress::Gunzip qw(:all); - my $ftp = new Net::FTP ... + my $ftp = Net::FTP->new( ... ) my $retr_fh = $ftp->retr($compressed_filename); gunzip $retr_fh => $outFilename, AutoClose => 1 @@ -518,7 +518,7 @@ the other C modules. my $file = $ARGV[0] ; - my $fh = new IO::File "<$file" + my $fh = IO::File->new( "<$file" ) or die "Cannot open '$file': $!\n"; while (1) @@ -566,9 +566,9 @@ the other C modules. # Done reading the Local Header - my $inf = new IO::Uncompress::RawInflate $fh, + my $inf = IO::Uncompress::RawInflate->new( $fh, Transparent => 1, - InputLength => $compressedLength + InputLength => $compressedLength ) or die "Cannot uncompress $file [$filename]: $RawInflateError\n" ; my $line_count = 0; @@ -585,14 +585,14 @@ The majority of the code above is concerned with reading the zip local header data. The code that I want to focus on is at the bottom. while (1) { - + # read local zip header data # get $filename # get $compressedLength - my $inf = new IO::Uncompress::RawInflate $fh, + my $inf = IO::Uncompress::RawInflate->new( $fh, Transparent => 1, - InputLength => $compressedLength + InputLength => $compressedLength ) or die "Cannot uncompress $file [$filename]: $RawInflateError\n" ; my $line_count = 0; @@ -618,7 +618,7 @@ byte directly after the compressed data stream. Now consider what the code looks like without C while (1) { - + # read local zip header data # get $filename # get $compressedLength @@ -626,8 +626,8 @@ Now consider what the code looks like without C # read all the compressed data into $data read($fh, $data, $compressedLength); - my $inf = new IO::Uncompress::RawInflate \$data, - Transparent => 1, + my $inf = IO::Uncompress::RawInflate->new( \$data, + Transparent => 1 ) or die "Cannot uncompress $file [$filename]: $RawInflateError\n" ; my $line_count = 0; @@ -682,7 +682,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2020 Paul Marquess. All rights reserved. +Copyright (c) 2005-2021 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/IO-Compress/lib/IO/Compress/Gzip.pm b/cpan/IO-Compress/lib/IO/Compress/Gzip.pm index 68f6008ef102..cf9d8e263aad 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Gzip.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Gzip.pm @@ -8,24 +8,24 @@ use bytes; require Exporter ; -use IO::Compress::RawDeflate 2.096 () ; -use IO::Compress::Adapter::Deflate 2.096 ; +use IO::Compress::RawDeflate 2.100 () ; +use IO::Compress::Adapter::Deflate 2.100 ; -use IO::Compress::Base::Common 2.096 qw(:Status ); -use IO::Compress::Gzip::Constants 2.096 ; -use IO::Compress::Zlib::Extra 2.096 ; +use IO::Compress::Base::Common 2.100 qw(:Status ); +use IO::Compress::Gzip::Constants 2.100 ; +use IO::Compress::Zlib::Extra 2.100 ; BEGIN { - if (defined &utf8::downgrade ) + if (defined &utf8::downgrade ) { *noUTF8 = \&utf8::downgrade } else - { *noUTF8 = sub {} } + { *noUTF8 = sub {} } } our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $GzipError); -$VERSION = '2.096'; +$VERSION = '2.100'; $GzipError = '' ; @ISA = qw(IO::Compress::RawDeflate Exporter); @@ -65,7 +65,7 @@ sub getExtraParams return ( # zlib behaviour $self->getZlibParams(), - + # Gzip header fields 'minimal' => [IO::Compress::Base::Common::Parse_boolean, 0], 'comment' => [IO::Compress::Base::Common::Parse_any, undef], @@ -105,7 +105,7 @@ sub ckParams # Also check that they only contain ISO 8859-1 chars. if ($got->parsed('name') && defined $got->getValue('name')) { my $name = $got->getValue('name'); - + return $self->saveErrorString(undef, "Null Character found in Name", Z_DATA_ERROR) if $strict && $name =~ /\x00/ ; @@ -132,16 +132,16 @@ sub ckParams return $self->saveErrorString(undef, "OS_Code must be between 0 and 255, got '$value'") if $value < 0 || $value > 255 ; - + } # gzip only supports Deflate at present $got->setValue('method' => Z_DEFLATED) ; if ( ! $got->parsed('extraflags')) { - $got->setValue('extraflags' => 2) + $got->setValue('extraflags' => 2) if $got->getValue('level') == Z_BEST_COMPRESSION ; - $got->setValue('extraflags' => 4) + $got->setValue('extraflags' => 4) if $got->getValue('level') == Z_BEST_SPEED ; } @@ -161,12 +161,13 @@ sub ckParams sub mkTrailer { my $self = shift ; - return pack("V V", *$self->{Compress}->crc32(), + return pack("V V", *$self->{Compress}->crc32(), *$self->{UnCompSize}->get32bit()); } sub getInverseClass { + no warnings 'once'; return ('IO::Uncompress::Gunzip', \$IO::Uncompress::Gunzip::GunzipError); } @@ -184,7 +185,7 @@ sub getFileInfo $params->setValue('name' => $filename) if ! $params->parsed('name') ; - $params->setValue('time' => $defaultTime) + $params->setValue('time' => $defaultTime) if ! $params->parsed('time') ; } @@ -207,7 +208,7 @@ sub mkHeader $flags |= GZIP_FLG_FEXTRA if $param->wantValue('extrafield') ; $flags |= GZIP_FLG_FNAME if $param->wantValue('name') ; $flags |= GZIP_FLG_FCOMMENT if $param->wantValue('comment') ; - + # MTIME my $time = $param->valueOrDefault('time', GZIP_MTIME_DEFAULT) ; @@ -218,7 +219,7 @@ sub mkHeader my $os_code = $param->valueOrDefault('os_code', GZIP_OS_DEFAULT) ; - my $out = pack("C4 V C C", + my $out = pack("C4 V C C", GZIP_ID1, # ID1 GZIP_ID2, # ID2 $method, # Compression Method @@ -240,7 +241,7 @@ sub mkHeader $name =~ s/\x00.*$//; $out .= $name ; # Terminate the filename with NULL unless it already is - $out .= GZIP_NULL_BYTE + $out .= GZIP_NULL_BYTE if !length $name or substr($name, 1, -1) ne GZIP_NULL_BYTE ; } @@ -257,7 +258,7 @@ sub mkHeader } # HEADER CRC - $out .= pack("v", Compress::Raw::Zlib::crc32($out) & 0x00FF ) + $out .= pack("v", Compress::Raw::Zlib::crc32($out) & 0x00FF ) if $param->getValue('headercrc') ; noUTF8($out); @@ -270,7 +271,7 @@ sub mkFinalTrailer return ''; } -1; +1; __END__ @@ -285,7 +286,7 @@ IO::Compress::Gzip - Write RFC 1952 files/buffers my $status = gzip $input => $output [,OPTS] or die "gzip failed: $GzipError\n"; - my $z = new IO::Compress::Gzip $output [,OPTS] + my $z = IO::Compress::Gzip->new( $output [,OPTS] ) or die "gzip failed: $GzipError\n"; $z->print($string); @@ -573,7 +574,7 @@ compressed data to a buffer, C<$buffer>. use IO::Compress::Gzip qw(gzip $GzipError) ; use IO::File ; - my $input = new IO::File "new( " \$buffer @@ -610,7 +611,7 @@ and if you want to compress each file one at a time, this will do the trick The format of the constructor for C is shown below - my $z = new IO::Compress::Gzip $output [,OPTS] + my $z = IO::Compress::Gzip->new( $output [,OPTS] ) or die "IO::Compress::Gzip failed: $GzipError\n"; It returns an C object on success and undef on failure. @@ -1263,8 +1264,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2020 Paul Marquess. All rights reserved. +Copyright (c) 2005-2021 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. - diff --git a/cpan/IO-Compress/lib/IO/Compress/Gzip/Constants.pm b/cpan/IO-Compress/lib/IO/Compress/Gzip/Constants.pm index c41fa18fe5c9..ef67f7e66a5a 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Gzip/Constants.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Gzip/Constants.pm @@ -9,7 +9,7 @@ require Exporter; our ($VERSION, @ISA, @EXPORT, %GZIP_OS_Names); our ($GZIP_FNAME_INVALID_CHAR_RE, $GZIP_FCOMMENT_INVALID_CHAR_RE); -$VERSION = '2.096'; +$VERSION = '2.100'; @ISA = qw(Exporter); @@ -89,22 +89,22 @@ use constant GZIP_FEXTRA_SUBFIELD_ID_SIZE => 2 ; use constant GZIP_FEXTRA_SUBFIELD_LEN_SIZE => 2 ; use constant GZIP_FEXTRA_SUBFIELD_HEADER_SIZE => GZIP_FEXTRA_SUBFIELD_ID_SIZE + GZIP_FEXTRA_SUBFIELD_LEN_SIZE; -use constant GZIP_FEXTRA_SUBFIELD_MAX_SIZE => GZIP_FEXTRA_MAX_SIZE - +use constant GZIP_FEXTRA_SUBFIELD_MAX_SIZE => GZIP_FEXTRA_MAX_SIZE - GZIP_FEXTRA_SUBFIELD_HEADER_SIZE ; if (ord('A') == 193) { - # EBCDIC + # EBCDIC $GZIP_FNAME_INVALID_CHAR_RE = '[\x00-\x3f\xff]'; $GZIP_FCOMMENT_INVALID_CHAR_RE = '[\x00-\x0a\x11-\x14\x16-\x3f\xff]'; - + } else { $GZIP_FNAME_INVALID_CHAR_RE = '[\x00-\x1F\x7F-\x9F]'; $GZIP_FCOMMENT_INVALID_CHAR_RE = '[\x00-\x09\x11-\x1F\x7F-\x9F]'; -} +} use constant GZIP_FHCRC_SIZE => 2 ; # aka CONTINUATION in gzip @@ -140,7 +140,7 @@ use constant GZIP_OS_DEFAULT=> 0xFF ; GZIP_OS_DEFAULT() => 'Unknown', ) ; -use constant GZIP_MINIMUM_HEADER => pack("C4 V C C", +use constant GZIP_MINIMUM_HEADER => pack("C4 V C C", GZIP_ID1, GZIP_ID2, GZIP_CM_DEFLATED, GZIP_FLG_DEFAULT, GZIP_MTIME_DEFAULT, GZIP_XFL_DEFAULT, GZIP_OS_DEFAULT) ; diff --git a/cpan/IO-Compress/lib/IO/Compress/RawDeflate.pm b/cpan/IO-Compress/lib/IO/Compress/RawDeflate.pm index 603c9e02312b..a0005dd6cdb6 100644 --- a/cpan/IO-Compress/lib/IO/Compress/RawDeflate.pm +++ b/cpan/IO-Compress/lib/IO/Compress/RawDeflate.pm @@ -6,15 +6,16 @@ use strict ; use warnings; use bytes; -use IO::Compress::Base 2.096 ; -use IO::Compress::Base::Common 2.096 qw(:Status ); -use IO::Compress::Adapter::Deflate 2.096 ; +use IO::Compress::Base 2.100 ; +use IO::Compress::Base::Common 2.100 qw(:Status :Parse); +use IO::Compress::Adapter::Deflate 2.100 ; +use Compress::Raw::Zlib 2.100 qw(Z_DEFLATED Z_DEFAULT_COMPRESSION Z_DEFAULT_STRATEGY); require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %DEFLATE_CONSTANTS, %EXPORT_TAGS, $RawDeflateError); -$VERSION = '2.096'; +$VERSION = '2.100'; $RawDeflateError = ''; @ISA = qw(IO::Compress::Base Exporter); @@ -28,8 +29,8 @@ push @EXPORT_OK, @IO::Compress::Adapter::Deflate::EXPORT_OK ; my %seen; foreach (keys %EXPORT_TAGS ) { - push @{$EXPORT_TAGS{constants}}, - grep { !$seen{$_}++ } + push @{$EXPORT_TAGS{constants}}, + grep { !$seen{$_}++ } @{ $EXPORT_TAGS{$_} } } $EXPORT_TAGS{all} = $EXPORT_TAGS{constants} ; @@ -41,7 +42,7 @@ push @EXPORT_OK, @IO::Compress::Adapter::Deflate::EXPORT_OK ; #push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; Exporter::export_ok_tags('all'); - + sub new @@ -82,7 +83,7 @@ sub mkComp return $self->saveErrorString(undef, $errstr, $errno) if ! defined $obj; - return $obj; + return $obj; } @@ -116,8 +117,6 @@ sub getExtraParams return getZlibParams(); } -use IO::Compress::Base::Common 2.096 qw(:Parse); -use Compress::Raw::Zlib 2.096 qw(Z_DEFLATED Z_DEFAULT_COMPRESSION Z_DEFAULT_STRATEGY); our %PARAMS = ( #'method' => [IO::Compress::Base::Common::Parse_unsigned, Z_DEFLATED], 'level' => [IO::Compress::Base::Common::Parse_signed, Z_DEFAULT_COMPRESSION], @@ -125,17 +124,18 @@ our %PARAMS = ( 'crc32' => [IO::Compress::Base::Common::Parse_boolean, 0], 'adler32' => [IO::Compress::Base::Common::Parse_boolean, 0], - 'merge' => [IO::Compress::Base::Common::Parse_boolean, 0], + 'merge' => [IO::Compress::Base::Common::Parse_boolean, 0], ); - + sub getZlibParams { - return %PARAMS; + return %PARAMS; } sub getInverseClass { - return ('IO::Uncompress::RawInflate', + no warnings 'once'; + return ('IO::Uncompress::RawInflate', \$IO::Uncompress::RawInflate::RawInflateError); } @@ -144,7 +144,7 @@ sub getFileInfo my $self = shift ; my $params = shift; my $file = shift ; - + } use Fcntl qw(SEEK_SET); @@ -156,20 +156,20 @@ sub createMerge my $outType = shift ; my ($invClass, $error_ref) = $self->getInverseClass(); - eval "require $invClass" + eval "require $invClass" or die "aaaahhhh" ; - my $inf = $invClass->new( $outValue, - Transparent => 0, + my $inf = $invClass->new( $outValue, + Transparent => 0, #Strict => 1, AutoClose => 0, Scan => 1) or return $self->saveErrorString(undef, "Cannot create InflateScan object: $$error_ref" ) ; my $end_offset = 0; - $inf->scan() + $inf->scan() or return $self->saveErrorString(undef, "Error Scanning: $$error_ref", $inf->errorNo) ; - $inf->zap($end_offset) + $inf->zap($end_offset) or return $self->saveErrorString(undef, "Error Zapping: $$error_ref", $inf->errorNo) ; my $def = *$self->{Compress} = $inf->createDeflate(); @@ -178,10 +178,10 @@ sub createMerge *$self->{UnCompSize} = *$inf->{UnCompSize}->clone(); *$self->{CompSize} = *$inf->{CompSize}->clone(); # TODO -- fix this - #*$self->{CompSize} = new U64(0, *$self->{UnCompSize_32bit}); + #*$self->{CompSize} = U64->new(0, *$self->{UnCompSize_32bit}); - if ( $outType eq 'buffer') + if ( $outType eq 'buffer') { substr( ${ *$self->{Buffer} }, $end_offset) = '' } elsif ($outType eq 'handle' || $outType eq 'filename') { *$self->{FH} = *$inf->{FH} ; @@ -189,8 +189,8 @@ sub createMerge *$self->{FH}->flush() ; *$self->{Handle} = 1 if $outType eq 'handle'; - #seek(*$self->{FH}, $end_offset, SEEK_SET) - *$self->{FH}->seek($end_offset, SEEK_SET) + #seek(*$self->{FH}, $end_offset, SEEK_SET) + *$self->{FH}->seek($end_offset, SEEK_SET) or return $self->saveErrorString(undef, $!, $!) ; } @@ -199,7 +199,7 @@ sub createMerge #### zlib specific methods -sub deflateParams +sub deflateParams { my $self = shift ; @@ -210,7 +210,7 @@ sub deflateParams return $self->saveErrorString(0, *$self->{Compress}{Error}, *$self->{Compress}{ErrorNo}) if $status == STATUS_ERROR; - return 1; + return 1; } @@ -231,7 +231,7 @@ IO::Compress::RawDeflate - Write RFC 1951 files/buffers my $status = rawdeflate $input => $output [,OPTS] or die "rawdeflate failed: $RawDeflateError\n"; - my $z = new IO::Compress::RawDeflate $output [,OPTS] + my $z = IO::Compress::RawDeflate->new( $output [,OPTS] ) or die "rawdeflate failed: $RawDeflateError\n"; $z->print($string); @@ -511,7 +511,7 @@ compressed data to a buffer, C<$buffer>. use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ; use IO::File ; - my $input = new IO::File "new( " \$buffer @@ -548,7 +548,7 @@ and if you want to compress each file one at a time, this will do the trick The format of the constructor for C is shown below - my $z = new IO::Compress::RawDeflate $output [,OPTS] + my $z = IO::Compress::RawDeflate->new( $output [,OPTS] ) or die "IO::Compress::RawDeflate failed: $RawDeflateError\n"; It returns an C object on success and undef on failure. @@ -1007,8 +1007,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2020 Paul Marquess. All rights reserved. +Copyright (c) 2005-2021 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. - diff --git a/cpan/IO-Compress/lib/IO/Compress/Zip.pm b/cpan/IO-Compress/lib/IO/Compress/Zip.pm index 63bd9981ab71..16d956129e23 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Zip.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Zip.pm @@ -4,40 +4,41 @@ use strict ; use warnings; use bytes; -use IO::Compress::Base::Common 2.096 qw(:Status ); -use IO::Compress::RawDeflate 2.096 (); -use IO::Compress::Adapter::Deflate 2.096 ; -use IO::Compress::Adapter::Identity 2.096 ; -use IO::Compress::Zlib::Extra 2.096 ; -use IO::Compress::Zip::Constants 2.096 ; +use IO::Compress::Base::Common 2.100 qw(:Status ); +use IO::Compress::RawDeflate 2.100 (); +use IO::Compress::Adapter::Deflate 2.100 ; +use IO::Compress::Adapter::Identity 2.100 ; +use IO::Compress::Zlib::Extra 2.100 ; +use IO::Compress::Zip::Constants 2.100 ; use File::Spec(); use Config; -use Compress::Raw::Zlib 2.096 (); +use Compress::Raw::Zlib 2.100 (); BEGIN { eval { require IO::Compress::Adapter::Bzip2 ; - import IO::Compress::Adapter::Bzip2 2.096 ; + IO::Compress::Adapter::Bzip2->import( 2.096 ); require IO::Compress::Bzip2 ; - import IO::Compress::Bzip2 2.096 ; + IO::Compress::Bzip2->import( 2.096 ); } ; eval { require IO::Compress::Adapter::Lzma ; - import IO::Compress::Adapter::Lzma 2.096 ; + IO::Compress::Adapter::Lzma->import( 2.096 ); require IO::Compress::Lzma ; - import IO::Compress::Lzma 2.096 ; + IO::Compress::Lzma->import( 2.096 ); } ; + eval { require IO::Compress::Adapter::Xz ; - import IO::Compress::Adapter::Xz 2.096 ; + IO::Compress::Adapter::Xz->import( 2.096 ); require IO::Compress::Xz ; - import IO::Compress::Xz 2.096 ; + IO::Compress::Xz->import( 2.096 ); } ; eval { require IO::Compress::Adapter::Zstd ; - import IO::Compress::Adapter::Zstd 2.096 ; + IO::Compress::Adapter::Zstd->import( 2.096 ); require IO::Compress::Zstd ; - import IO::Compress::Zstd 2.096 ; + IO::Compress::Zstd->import( 2.096 ); } ; } @@ -46,7 +47,7 @@ require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $ZipError); -$VERSION = '2.096'; +$VERSION = '2.100'; $ZipError = ''; @ISA = qw(IO::Compress::RawDeflate Exporter); @@ -177,7 +178,7 @@ sub mkComp if (! defined *$self->{ZipData}{SizesOffset}) { *$self->{ZipData}{SizesOffset} = 0; - *$self->{ZipData}{Offset} = new U64 ; + *$self->{ZipData}{Offset} = U64->new(); } *$self->{ZipData}{AnyZip64} = 0 @@ -753,6 +754,7 @@ sub getExtraParams sub getInverseClass { + no warnings 'once'; return ('IO::Uncompress::Unzip', \$IO::Uncompress::Unzip::UnzipError); } @@ -905,7 +907,7 @@ IO::Compress::Zip - Write zip files/buffers my $status = zip $input => $output [,OPTS] or die "zip failed: $ZipError\n"; - my $z = new IO::Compress::Zip $output [,OPTS] + my $z = IO::Compress::Zip->new( $output [,OPTS] ) or die "zip failed: $ZipError\n"; $z->print($string); @@ -1251,7 +1253,7 @@ compressed data to a buffer, C<$buffer>. use IO::Compress::Zip qw(zip $ZipError) ; use IO::File ; - my $input = new IO::File "new( " \$buffer @@ -1292,7 +1294,7 @@ or more succinctly The format of the constructor for C is shown below - my $z = new IO::Compress::Zip $output [,OPTS] + my $z = IO::Compress::Zip->new( $output [,OPTS] ) or die "IO::Compress::Zip failed: $ZipError\n"; It returns an C object on success and undef on failure. @@ -1730,10 +1732,10 @@ By default, no comment field is written to the zip file. =item C<< Method => $method >> Controls which compression method is used. At present the compression -methods are supported are: Store (no compression at all), Deflate, -Bzip2, Xz and Lzma. +methods supported are: Store (no compression at all), Deflate, +Bzip2, Zstd, Xz and Lzma. -The symbols, ZIP_CM_STORE, ZIP_CM_DEFLATE, ZIP_CM_BZIP2, ZIP_CM_XZ and ZIP_CM_LZMA +The symbols ZIP_CM_STORE, ZIP_CM_DEFLATE, ZIP_CM_BZIP2, ZIP_CM_ZSTD, ZIP_CM_XZ and ZIP_CM_LZMA are used to select the compression method. These constants are not imported by C by default. @@ -1754,6 +1756,10 @@ Note that to create Xz content, the module C must be installed. A fatal error will be thrown if you attempt to create Xz content when C is not available. +Note that to create Zstd content, the module C must +be installed. A fatal error will be thrown if you attempt to create Zstd +content when C is not available. + The default method is ZIP_CM_DEFLATE. =item C<< TextFlag => 0|1 >> @@ -2137,8 +2143,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2020 Paul Marquess. All rights reserved. +Copyright (c) 2005-2021 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. - diff --git a/cpan/IO-Compress/lib/IO/Compress/Zip/Constants.pm b/cpan/IO-Compress/lib/IO/Compress/Zip/Constants.pm index 526e0ba994d9..c81a4ad56c4a 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Zip/Constants.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Zip/Constants.pm @@ -7,7 +7,7 @@ require Exporter; our ($VERSION, @ISA, @EXPORT, %ZIP_CM_MIN_VERSIONS); -$VERSION = '2.096'; +$VERSION = '2.100'; @ISA = qw(Exporter); diff --git a/cpan/IO-Compress/lib/IO/Compress/Zlib/Constants.pm b/cpan/IO-Compress/lib/IO/Compress/Zlib/Constants.pm index a6903a76621e..1b953510b318 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Zlib/Constants.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Zlib/Constants.pm @@ -9,7 +9,7 @@ require Exporter; our ($VERSION, @ISA, @EXPORT); -$VERSION = '2.096'; +$VERSION = '2.100'; @ISA = qw(Exporter); @@ -23,7 +23,7 @@ $VERSION = '2.096'; ZLIB_CMF_CM_DEFLATED ZLIB_CMF_CINFO_OFFSET - ZLIB_CMF_CINFO_BITS + ZLIB_CMF_CINFO_BITS ZLIB_CMF_CINFO_MAX ZLIB_FLG_FCHECK_OFFSET diff --git a/cpan/IO-Compress/lib/IO/Compress/Zlib/Extra.pm b/cpan/IO-Compress/lib/IO/Compress/Zlib/Extra.pm index b5c49b7cde46..0bbef359f2d4 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Zlib/Extra.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Zlib/Extra.pm @@ -8,9 +8,9 @@ use bytes; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS); -$VERSION = '2.096'; +$VERSION = '2.100'; -use IO::Compress::Gzip::Constants 2.096 ; +use IO::Compress::Gzip::Constants 2.100 ; sub ExtraFieldError { @@ -36,11 +36,11 @@ sub validateExtraFieldPair return ExtraFieldError("SubField Data is a reference") if ref $pair->[1] ; - # ID is exactly two chars + # ID is exactly two chars return ExtraFieldError("SubField ID not two chars long") unless length $pair->[0] == GZIP_FEXTRA_SUBFIELD_ID_SIZE ; - # Check that the 2nd byte of the ID isn't 0 + # Check that the 2nd byte of the ID isn't 0 return ExtraFieldError("SubField ID 2nd byte is 0x00") if $strict && $gzipMode && substr($pair->[0], 1, 1) eq "\x00" ; @@ -74,7 +74,7 @@ sub parseRawExtra return ExtraFieldError("Truncated in FEXTRA Body Section") if $offset + GZIP_FEXTRA_SUBFIELD_HEADER_SIZE > $XLEN ; - my $id = substr($data, $offset, GZIP_FEXTRA_SUBFIELD_ID_SIZE); + my $id = substr($data, $offset, GZIP_FEXTRA_SUBFIELD_ID_SIZE); $offset += GZIP_FEXTRA_SUBFIELD_ID_SIZE; my $subLen = unpack("v", substr($data, $offset, @@ -84,8 +84,8 @@ sub parseRawExtra return ExtraFieldError("Truncated in FEXTRA Body Section") if $offset + $subLen > $XLEN ; - my $bad = validateExtraFieldPair( [$id, - substr($data, $offset, $subLen)], + my $bad = validateExtraFieldPair( [$id, + substr($data, $offset, $subLen)], $strict, $gzipMode ); return $bad if $bad ; push @$extraRef, [$id => substr($data, $offset, $subLen)] @@ -94,7 +94,7 @@ sub parseRawExtra $offset += $subLen ; } - + return undef ; } @@ -111,7 +111,7 @@ sub findID return undef if $offset + GZIP_FEXTRA_SUBFIELD_HEADER_SIZE > $XLEN ; - my $id = substr($data, $offset, GZIP_FEXTRA_SUBFIELD_ID_SIZE); + my $id = substr($data, $offset, GZIP_FEXTRA_SUBFIELD_ID_SIZE); $offset += GZIP_FEXTRA_SUBFIELD_ID_SIZE; my $subLen = unpack("v", substr($data, $offset, @@ -126,7 +126,7 @@ sub findID $offset += $subLen ; } - + return undef ; } @@ -165,7 +165,7 @@ sub parseExtraField # $id2 => $data2, # ... # } - + if ( ! ref $dataRef ) { return undef @@ -177,7 +177,7 @@ sub parseExtraField my $data = $dataRef; my $out = '' ; - if (ref $data eq 'ARRAY') { + if (ref $data eq 'ARRAY') { if (ref $data->[0]) { foreach my $pair (@$data) { @@ -188,30 +188,30 @@ sub parseExtraField return $bad if $bad ; $out .= mkSubField(@$pair); - } - } + } + } else { return ExtraFieldError("Not even number of elements") unless @$data % 2 == 0; for (my $ix = 0; $ix <= @$data -1 ; $ix += 2) { my $bad = validateExtraFieldPair([$data->[$ix], - $data->[$ix+1]], + $data->[$ix+1]], $strict, $gzipMode) ; return $bad if $bad ; $out .= mkSubField($data->[$ix], $data->[$ix+1]); - } + } } - } - elsif (ref $data eq 'HASH') { + } + elsif (ref $data eq 'HASH') { while (my ($id, $info) = each %$data) { my $bad = validateExtraFieldPair([$id, $info], $strict, $gzipMode); return $bad if $bad ; $out .= mkSubField($id, $info); - } - } + } + } else { return ExtraFieldError("Not a scalar, array ref or hash ref") ; } diff --git a/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Bunzip2.pm b/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Bunzip2.pm index 60b34bab8249..92f3945c4d72 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Bunzip2.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Bunzip2.pm @@ -4,19 +4,19 @@ use strict; use warnings; use bytes; -use IO::Compress::Base::Common 2.096 qw(:Status); +use IO::Compress::Base::Common 2.100 qw(:Status); -use Compress::Raw::Bzip2 2.096 ; +use Compress::Raw::Bzip2 2.100 ; our ($VERSION, @ISA); -$VERSION = '2.096'; +$VERSION = '2.100'; sub mkUncompObject { my $small = shift || 0; my $verbosity = shift || 0; - my ($inflate, $status) = new Compress::Raw::Bunzip2(1, 1, $small, $verbosity, 1); + my ($inflate, $status) = Compress::Raw::Bunzip2->new(1, 1, $small, $verbosity, 1); return (undef, "Could not create Inflation object: $status", $status) if $status != BZ_OK ; @@ -26,8 +26,8 @@ sub mkUncompObject 'UnCompSize' => 0, 'Error' => '', 'ConsumesInput' => 1, - } ; - + } ; + } sub uncompr @@ -48,7 +48,7 @@ sub uncompr return STATUS_ERROR; } - + return STATUS_OK if $status == BZ_OK ; return STATUS_ENDSTREAM if $status == BZ_STREAM_END ; return STATUS_ERROR ; @@ -59,12 +59,12 @@ sub reset { my $self = shift ; - my ($inf, $status) = new Compress::Raw::Bunzip2(); + my ($inf, $status) = Compress::Raw::Bunzip2->new(); $self->{ErrorNo} = ($status == BZ_OK) ? 0 : $status ; if ($status != BZ_OK) { - $self->{Error} = "Cannot create Inflate object: $status"; + $self->{Error} = "Cannot create Inflate object: $status"; return STATUS_ERROR; } @@ -100,8 +100,8 @@ sub adler32 sub sync { my $self = shift ; - #( $self->{Inf}->inflateSync(@_) == BZ_OK) - # ? STATUS_OK + #( $self->{Inf}->inflateSync(@_) == BZ_OK) + # ? STATUS_OK # : STATUS_ERROR ; } @@ -109,4 +109,3 @@ sub sync 1; __END__ - diff --git a/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Identity.pm b/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Identity.pm index 84d74c9cabe2..07621b4f694e 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Identity.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Identity.pm @@ -4,14 +4,14 @@ use warnings; use strict; use bytes; -use IO::Compress::Base::Common 2.096 qw(:Status); +use IO::Compress::Base::Common 2.100 qw(:Status); use IO::Compress::Zip::Constants ; our ($VERSION); -$VERSION = '2.096'; +$VERSION = '2.100'; -use Compress::Raw::Zlib 2.096 (); +use Compress::Raw::Zlib 2.100 (); sub mkUncompObject { @@ -21,7 +21,7 @@ sub mkUncompObject my $crc32 = 1; #shift ; my $adler32 = shift; - bless { 'CompSize' => new U64 , # 0, + bless { 'CompSize' => U64->new(), # 0, 'UnCompSize' => 0, 'wantCRC32' => $crc32, 'CRC32' => Compress::Raw::Zlib::crc32(''), @@ -70,7 +70,7 @@ sub uncompr $ind = $len - 1 ; } } - + if ($ind >= 0) { $remainder = substr($$in, $ind) ; substr($$in, $ind) = '' ; @@ -94,7 +94,7 @@ sub uncompr $l1 = U64::newUnpack_V32(substr($remainder, 8)); $l2 = U64::newUnpack_V32(substr($remainder, 12)); } - + my $newLen = $self->{CompSize}->clone(); $newLen->add(length $$in); if ($l1->equal($l2) && $l1->equal($newLen) ) { @@ -142,7 +142,7 @@ sub reset $self->{CompSize}->reset(); $self->{UnCompSize} = 0; $self->{CRC32} = Compress::Raw::Zlib::crc32(''); - $self->{ADLER32} = Compress::Raw::Zlib::adler32(''); + $self->{ADLER32} = Compress::Raw::Zlib::adler32(''); return STATUS_OK ; } diff --git a/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Inflate.pm b/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Inflate.pm index 63e87077379e..9d5dba948107 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Inflate.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Inflate.pm @@ -4,11 +4,11 @@ use strict; use warnings; use bytes; -use IO::Compress::Base::Common 2.096 qw(:Status); -use Compress::Raw::Zlib 2.096 qw(Z_OK Z_BUF_ERROR Z_STREAM_END Z_FINISH MAX_WBITS); +use IO::Compress::Base::Common 2.100 qw(:Status); +use Compress::Raw::Zlib 2.100 qw(Z_OK Z_BUF_ERROR Z_STREAM_END Z_FINISH MAX_WBITS); our ($VERSION); -$VERSION = '2.096'; +$VERSION = '2.100'; @@ -23,23 +23,23 @@ sub mkUncompObject if ($scan) { - ($inflate, $status) = new Compress::Raw::Zlib::InflateScan + ($inflate, $status) = Compress::Raw::Zlib::InflateScan->new( #LimitOutput => 1, CRC32 => $crc32, ADLER32 => $adler32, - WindowBits => - MAX_WBITS ; + WindowBits => - MAX_WBITS ); } else { - ($inflate, $status) = new Compress::Raw::Zlib::Inflate + ($inflate, $status) = Compress::Raw::Zlib::Inflate->new( AppendOutput => 1, LimitOutput => 1, CRC32 => $crc32, ADLER32 => $adler32, - WindowBits => - MAX_WBITS ; + WindowBits => - MAX_WBITS ); } - return (undef, "Could not create Inflation object: $status", $status) + return (undef, "Could not create Inflation object: $status", $status) if $status != Z_OK ; return bless {'Inf' => $inflate, @@ -47,8 +47,8 @@ sub mkUncompObject 'UnCompSize' => 0, 'Error' => '', 'ConsumesInput' => 1, - } ; - + } ; + } sub uncompr @@ -67,7 +67,7 @@ sub uncompr $self->{Error} = "Inflation Error: $status"; return STATUS_ERROR; } - + return STATUS_OK if $status == Z_BUF_ERROR ; # ??? return STATUS_OK if $status == Z_OK ; return STATUS_ENDSTREAM if $status == Z_STREAM_END ; @@ -115,8 +115,8 @@ sub adler32 sub sync { my $self = shift ; - ( $self->{Inf}->inflateSync(@_) == Z_OK) - ? STATUS_OK + ( $self->{Inf}->inflateSync(@_) == Z_OK) + ? STATUS_OK : STATUS_ERROR ; } @@ -154,4 +154,3 @@ sub createDeflateStream __END__ - diff --git a/cpan/IO-Compress/lib/IO/Uncompress/AnyInflate.pm b/cpan/IO-Compress/lib/IO/Uncompress/AnyInflate.pm index 63ada56ee1dd..7e2066d4e82a 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/AnyInflate.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/AnyInflate.pm @@ -6,27 +6,27 @@ use strict; use warnings; use bytes; -use IO::Compress::Base::Common 2.096 (); +use IO::Compress::Base::Common 2.100 qw(:Parse); -use IO::Uncompress::Adapter::Inflate 2.096 (); +use IO::Uncompress::Adapter::Inflate 2.100 (); -use IO::Uncompress::Base 2.096 ; -use IO::Uncompress::Gunzip 2.096 ; -use IO::Uncompress::Inflate 2.096 ; -use IO::Uncompress::RawInflate 2.096 ; -use IO::Uncompress::Unzip 2.096 ; +use IO::Uncompress::Base 2.100 ; +use IO::Uncompress::Gunzip 2.100 ; +use IO::Uncompress::Inflate 2.100 ; +use IO::Uncompress::RawInflate 2.100 ; +use IO::Uncompress::Unzip 2.100 ; require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $AnyInflateError); -$VERSION = '2.096'; +$VERSION = '2.100'; $AnyInflateError = ''; @ISA = qw(IO::Uncompress::Base Exporter); @EXPORT_OK = qw( $AnyInflateError anyinflate ) ; -%EXPORT_TAGS = %IO::Uncompress::Base::DEFLATE_CONSTANTS ; +%EXPORT_TAGS = %IO::Uncompress::Base::DEFLATE_CONSTANTS if keys %IO::Uncompress::Base::DEFLATE_CONSTANTS; push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; Exporter::export_ok_tags('all'); @@ -48,7 +48,6 @@ sub anyinflate sub getExtraParams { - use IO::Compress::Base::Common 2.096 qw(:Parse); return ( 'rawinflate' => [Parse_boolean, 0] ) ; } @@ -75,9 +74,9 @@ sub mkUncomp if ! defined $obj; *$self->{Uncomp} = $obj; - + my @possible = qw( Inflate Gunzip Unzip ); - unshift @possible, 'RawInflate' + unshift @possible, 'RawInflate' if 1 || $got->getValue('rawinflate'); my $magic = $self->ckMagic( @possible ); @@ -113,7 +112,7 @@ sub ckMagic $self->pushBack(*$self->{HeaderPending}) ; *$self->{HeaderPending} = '' ; - } + } bless $self => $keep; return undef; @@ -135,7 +134,7 @@ IO::Uncompress::AnyInflate - Uncompress zlib-based (zip, gzip) file/buffer my $status = anyinflate $input => $output [,OPTS] or die "anyinflate failed: $AnyInflateError\n"; - my $z = new IO::Uncompress::AnyInflate $input [OPTS] + my $z = IO::Uncompress::AnyInflate->new( $input [OPTS] ) or die "anyinflate failed: $AnyInflateError\n"; $status = $z->read($buffer) @@ -444,7 +443,7 @@ uncompressed data to a buffer, C<$buffer>. use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ; use IO::File ; - my $input = new IO::File "new( " \$buffer @@ -479,7 +478,7 @@ and if you want to compress each file one at a time, this will do the trick The format of the constructor for IO::Uncompress::AnyInflate is shown below - my $z = new IO::Uncompress::AnyInflate $input [OPTS] + my $z = IO::Uncompress::AnyInflate->new( $input [OPTS] ) or die "IO::Uncompress::AnyInflate failed: $AnyInflateError\n"; Returns an C object on success and undef on failure. @@ -999,8 +998,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2020 Paul Marquess. All rights reserved. +Copyright (c) 2005-2021 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. - diff --git a/cpan/IO-Compress/lib/IO/Uncompress/AnyUncompress.pm b/cpan/IO-Compress/lib/IO/Uncompress/AnyUncompress.pm index ae8acdf2d836..b17a3edbdad8 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/AnyUncompress.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/AnyUncompress.pm @@ -4,21 +4,21 @@ use strict; use warnings; use bytes; -use IO::Compress::Base::Common 2.096 (); +use IO::Compress::Base::Common 2.100 (); -use IO::Uncompress::Base 2.096 ; +use IO::Uncompress::Base 2.100 ; require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $AnyUncompressError); -$VERSION = '2.096'; +$VERSION = '2.100'; $AnyUncompressError = ''; @ISA = qw(IO::Uncompress::Base Exporter); @EXPORT_OK = qw( $AnyUncompressError anyuncompress ) ; -%EXPORT_TAGS = %IO::Uncompress::Base::DEFLATE_CONSTANTS ; +%EXPORT_TAGS = %IO::Uncompress::Base::DEFLATE_CONSTANTS if keys %IO::Uncompress::Base::DEFLATE_CONSTANTS; push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; Exporter::export_ok_tags('all'); @@ -33,26 +33,26 @@ BEGIN # Don't trigger any __DIE__ Hooks. local $SIG{__DIE__}; - eval ' use IO::Uncompress::Adapter::Inflate 2.096 ;'; - eval ' use IO::Uncompress::Adapter::Bunzip2 2.096 ;'; - eval ' use IO::Uncompress::Adapter::LZO 2.096 ;'; - eval ' use IO::Uncompress::Adapter::Lzf 2.096 ;'; - eval ' use IO::Uncompress::Adapter::UnLzma 2.096 ;'; - eval ' use IO::Uncompress::Adapter::UnXz 2.096 ;'; - eval ' use IO::Uncompress::Adapter::UnZstd 2.096 ;'; - eval ' use IO::Uncompress::Adapter::UnLzip 2.096 ;'; - - eval ' use IO::Uncompress::Bunzip2 2.096 ;'; - eval ' use IO::Uncompress::UnLzop 2.096 ;'; - eval ' use IO::Uncompress::Gunzip 2.096 ;'; - eval ' use IO::Uncompress::Inflate 2.096 ;'; - eval ' use IO::Uncompress::RawInflate 2.096 ;'; - eval ' use IO::Uncompress::Unzip 2.096 ;'; - eval ' use IO::Uncompress::UnLzf 2.096 ;'; - eval ' use IO::Uncompress::UnLzma 2.096 ;'; - eval ' use IO::Uncompress::UnXz 2.096 ;'; - eval ' use IO::Uncompress::UnZstd 2.096 ;'; - eval ' use IO::Uncompress::UnLzip 2.096 ;'; + eval ' use IO::Uncompress::Adapter::Inflate 2.100 ;'; + eval ' use IO::Uncompress::Adapter::Bunzip2 2.100 ;'; + eval ' use IO::Uncompress::Adapter::LZO 2.100 ;'; + eval ' use IO::Uncompress::Adapter::Lzf 2.100 ;'; + eval ' use IO::Uncompress::Adapter::UnLzma 2.100 ;'; + eval ' use IO::Uncompress::Adapter::UnXz 2.100 ;'; + eval ' use IO::Uncompress::Adapter::UnZstd 2.100 ;'; + eval ' use IO::Uncompress::Adapter::UnLzip 2.100 ;'; + + eval ' use IO::Uncompress::Bunzip2 2.100 ;'; + eval ' use IO::Uncompress::UnLzop 2.100 ;'; + eval ' use IO::Uncompress::Gunzip 2.100 ;'; + eval ' use IO::Uncompress::Inflate 2.100 ;'; + eval ' use IO::Uncompress::RawInflate 2.100 ;'; + eval ' use IO::Uncompress::Unzip 2.100 ;'; + eval ' use IO::Uncompress::UnLzf 2.100 ;'; + eval ' use IO::Uncompress::UnLzma 2.100 ;'; + eval ' use IO::Uncompress::UnXz 2.100 ;'; + eval ' use IO::Uncompress::UnZstd 2.100 ;'; + eval ' use IO::Uncompress::UnLzip 2.100 ;'; } @@ -279,7 +279,7 @@ IO::Uncompress::AnyUncompress - Uncompress gzip, zip, bzip2, zstd, xz, lzma, lzi my $status = anyuncompress $input => $output [,OPTS] or die "anyuncompress failed: $AnyUncompressError\n"; - my $z = new IO::Uncompress::AnyUncompress $input [OPTS] + my $z = IO::Uncompress::AnyUncompress->new( $input [OPTS] ) or die "anyuncompress failed: $AnyUncompressError\n"; $status = $z->read($buffer) @@ -600,7 +600,7 @@ uncompressed data to a buffer, C<$buffer>. use IO::Uncompress::AnyUncompress qw(anyuncompress $AnyUncompressError) ; use IO::File ; - my $input = new IO::File "new( " \$buffer @@ -635,7 +635,7 @@ and if you want to compress each file one at a time, this will do the trick The format of the constructor for IO::Uncompress::AnyUncompress is shown below - my $z = new IO::Uncompress::AnyUncompress $input [OPTS] + my $z = IO::Uncompress::AnyUncompress->new( $input [OPTS] ) or die "IO::Uncompress::AnyUncompress failed: $AnyUncompressError\n"; Returns an C object on success and undef on failure. @@ -1077,8 +1077,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2020 Paul Marquess. All rights reserved. +Copyright (c) 2005-2021 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. - diff --git a/cpan/IO-Compress/lib/IO/Uncompress/Base.pm b/cpan/IO-Compress/lib/IO/Uncompress/Base.pm index 91a50e726328..5627bc6a44f7 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/Base.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/Base.pm @@ -9,12 +9,12 @@ our (@ISA, $VERSION, @EXPORT_OK, %EXPORT_TAGS); @ISA = qw(IO::File Exporter); -$VERSION = '2.096'; +$VERSION = '2.100'; use constant G_EOF => 0 ; use constant G_ERR => -1 ; -use IO::Compress::Base::Common 2.096 ; +use IO::Compress::Base::Common 2.100 ; use IO::File ; use Symbol; @@ -58,7 +58,7 @@ sub smartRead if (defined *$self->{FH}) { if ($offset) { - # Not using this + # Not using this # # *$self->{FH}->read($$out, $get_size, $offset); # @@ -75,7 +75,7 @@ sub smartRead elsif (defined *$self->{InputEvent}) { my $got = 1 ; while (length $$out < $size) { - last + last if ($got = *$self->{InputEvent}->($$out, $get_size)) <= 0; } @@ -93,13 +93,13 @@ sub smartRead substr($$out, $offset) = substr($$buf, *$self->{BufferOffset}, $get_size); if (*$self->{ConsumeInput}) { substr($$buf, 0, $get_size) = '' } - else + else { *$self->{BufferOffset} += length($$out) - $offset } } - *$self->{InputLengthRemaining} -= length($$out) #- $offset + *$self->{InputLengthRemaining} -= length($$out) #- $offset if defined *$self->{InputLength}; - + if (! defined $status) { $self->saveStatus($!) ; return STATUS_ERROR; @@ -169,7 +169,7 @@ sub smartTell if (defined *$self->{FH}) { return *$self->{FH}->tell() } - else + else { return *$self->{BufferOffset} } } @@ -179,7 +179,7 @@ sub smartWrite my $out_data = shift ; if (defined *$self->{FH}) { - # flush needed for 5.8.0 + # flush needed for 5.8.0 defined *$self->{FH}->write($out_data, length $out_data) && defined *$self->{FH}->flush() ; } @@ -199,7 +199,7 @@ sub smartReadExact sub smartEof { my ($self) = $_[0]; - local $.; + local $.; return 0 if length *$self->{Prime} || *$self->{PushMode}; @@ -207,15 +207,15 @@ sub smartEof { # Could use # - # *$self->{FH}->eof() + # *$self->{FH}->eof() # # here, but this can cause trouble if # the filehandle is itself a tied handle, but it uses sysread. - # Then we get into mixing buffered & non-buffered IO, + # Then we get into mixing buffered & non-buffered IO, # which will cause trouble my $info = $self->getErrInfo(); - + my $buffer = ''; my $status = $self->smartRead(\$buffer, 1); $self->pushBack($buffer) if length $buffer; @@ -225,7 +225,7 @@ sub smartEof } elsif (defined *$self->{InputEvent}) { *$self->{EventEof} } - else + else { *$self->{BufferOffset} >= length(${ *$self->{Buffer} }) } } @@ -347,7 +347,7 @@ sub checkParams my $class = shift ; my $got = shift || IO::Compress::Base::Parameters::new(); - + my $Valid = { 'blocksize' => [IO::Compress::Base::Common::Parse_unsigned, 16 * 1024], 'autoclose' => [IO::Compress::Base::Common::Parse_boolean, 0], @@ -362,7 +362,7 @@ sub checkParams #'decode' => [IO::Compress::Base::Common::Parse_any, undef], #'consumeinput' => [IO::Compress::Base::Common::Parse_boolean, 0], - + $self->getExtraParams(), #'Todo - Revert to ordinary file on end Z_STREAM_END'=> 0, @@ -371,11 +371,11 @@ sub checkParams $Valid->{trailingdata} = [IO::Compress::Base::Common::Parse_writable_scalar, undef] if *$self->{OneShot} ; - - $got->parse($Valid, @_ ) + + $got->parse($Valid, @_ ) or $self->croakError("${class}: " . $got->getError()) ; - $self->postCheckParams($got) + $self->postCheckParams($got) or $self->croakError("${class}: " . $self->error()) ; return $got; @@ -403,7 +403,7 @@ sub _create my $inType = whatIsInput($inValue, 1); - $obj->ckInputParam($class, $inValue, 1) + $obj->ckInputParam($class, $inValue, 1) or return undef ; *$obj->{InNew} = 1; @@ -412,8 +412,8 @@ sub _create or $obj->croakError("${class}: " . *$obj->{Error}); if ($inType eq 'buffer' || $inType eq 'code') { - *$obj->{Buffer} = $inValue ; - *$obj->{InputEvent} = $inValue + *$obj->{Buffer} = $inValue ; + *$obj->{InputEvent} = $inValue if $inType eq 'code' ; } else { @@ -422,18 +422,18 @@ sub _create *$obj->{Handle} = 1 ; # Need to rewind for Scan - *$obj->{FH}->seek(0, SEEK_SET) + *$obj->{FH}->seek(0, SEEK_SET) if $got->getValue('scan'); - } - else { + } + else { no warnings ; my $mode = '<'; $mode = '+<' if $got->getValue('scan'); *$obj->{StdIO} = ($inValue eq '-'); - *$obj->{FH} = new IO::File "$mode $inValue" + *$obj->{FH} = IO::File->new( "$mode $inValue" ) or return $obj->saveErrorString(undef, "cannot open file '$inValue': $!", $!) ; } - + *$obj->{LineNo} = $. = 0; setBinModeInput(*$obj->{FH}) ; @@ -441,7 +441,7 @@ sub _create *$obj->{Buffer} = \$buff ; } -# if ($got->getValue('decode')) { +# if ($got->getValue('decode')) { # my $want_encoding = $got->getValue('decode'); # *$obj->{Encoding} = IO::Compress::Base::Common::getEncoding($obj, $class, $want_encoding); # } @@ -449,7 +449,7 @@ sub _create # *$obj->{Encoding} = undef; # } - *$obj->{InputLength} = $got->parsed('inputlength') + *$obj->{InputLength} = $got->parsed('inputlength') ? $got->getValue('inputlength') : undef ; *$obj->{InputLengthRemaining} = $got->getValue('inputlength'); @@ -465,7 +465,7 @@ sub _create # TODO - move these two into RawDeflate *$obj->{Scan} = $got->getValue('scan'); - *$obj->{ParseExtra} = $got->getValue('parseextra') + *$obj->{ParseExtra} = $got->getValue('parseextra') || $got->getValue('strict') ; *$obj->{Type} = ''; *$obj->{Prime} = $got->getValue('prime') || '' ; @@ -473,8 +473,8 @@ sub _create *$obj->{Plain} = 0; *$obj->{PlainBytesRead} = 0; *$obj->{InflatedBytesRead} = 0; - *$obj->{UnCompSize} = new U64; - *$obj->{CompSize} = new U64; + *$obj->{UnCompSize} = U64->new; + *$obj->{CompSize} = U64->new; *$obj->{TotalInflatedBytesRead} = 0; *$obj->{NewStream} = 0 ; *$obj->{EventEof} = 0 ; @@ -494,19 +494,19 @@ sub _create *$obj->{InNew} = 0; *$obj->{Closed} = 0; - - return $obj + + return $obj if *$obj->{Pause} ; if ($status) { # Need to try uncompressing to catch the case # where the compressed file uncompresses to an # empty string - so eof is set immediately. - + my $out_buffer = ''; $status = $obj->read(\$out_buffer); - + if ($status < 0) { *$obj->{ReadStatus} = [ $status, $obj->error(), $obj->errorNo() ]; } @@ -515,7 +515,7 @@ sub _create if length $out_buffer; } else { - return undef + return undef unless *$obj->{Transparent}; $obj->clearError(); @@ -549,7 +549,7 @@ sub ckInputParam # # if ($_[0] ne '-' && ! -e $_[0] ) # { -# return $self->saveErrorString(1, +# return $self->saveErrorString(1, # "input file '$_[0]' does not exist", STATUS_ERROR); # } # } @@ -573,13 +573,13 @@ sub _inf my $output = shift ; - my $x = new IO::Compress::Base::Validator($class, *$obj->{Error}, $name, $input, $output) + my $x = IO::Compress::Base::Validator->new($class, *$obj->{Error}, $name, $input, $output) or return undef ; - + push @_, $output if $haveOut && $x->{Hash}; *$obj->{OneShot} = 1 ; - + my $got = $obj->checkParams($name, undef, @_) or return undef ; @@ -589,25 +589,25 @@ sub _inf # warn "TD $value "; # #$value = $$value; ## warn "TD $value $$value "; -# +# # return retErr($obj, "Parameter 'TrailingData' not writable") -# if readonly $$value ; +# if readonly $$value ; # -# if (ref $$value) +# if (ref $$value) # { # return retErr($obj,"Parameter 'TrailingData' not a scalar reference") # if ref $$value ne 'SCALAR' ; -# +# # *$obj->{TrailingData} = $$value ; # } -# else +# else # { # return retErr($obj,"Parameter 'TrailingData' not a scalar") -# if ref $value ne 'SCALAR' ; +# if ref $value ne 'SCALAR' ; # # *$obj->{TrailingData} = $value ; # } - + *$obj->{TrailingData} = $got->getValue('trailingdata'); } @@ -620,7 +620,7 @@ sub _inf # { # while (my($k, $v) = each %$input) # { -# $v = \$input->{$k} +# $v = \$input->{$k} # unless defined $v ; # # $obj->_singleTarget($x, $k, $v, @_) @@ -629,7 +629,7 @@ sub _inf # # return keys %$input ; # } - + if ($x->{GlobMap}) { $x->{oneInput} = 1 ; @@ -645,11 +645,11 @@ sub _inf if (! $x->{oneOutput} ) { - my $inFile = ($x->{inType} eq 'filenames' + my $inFile = ($x->{inType} eq 'filenames' || $x->{inType} eq 'filename'); $x->{inType} = $inFile ? 'filename' : 'buffer'; - + foreach my $in ($x->{oneInput} ? $input : @$input) { my $out ; @@ -684,7 +684,7 @@ sub _singleTarget my $x = shift ; my $input = shift; my $output = shift; - + my $buff = ''; $x->{buff} = \$buff ; @@ -693,7 +693,7 @@ sub _singleTarget my $mode = '>' ; $mode = '>>' if $x->{Got}->getValue('append') ; - $x->{fh} = new IO::File "$mode $output" + $x->{fh} = IO::File->new( "$mode $output" ) or return retErr($x, "cannot open file '$output': $!") ; binmode $x->{fh} ; @@ -708,10 +708,10 @@ sub _singleTarget } } - + elsif ($x->{outType} eq 'buffer' ) { - $$output = '' + $$output = '' unless $x->{Got}->getValue('append'); $x->{buff} = $output ; } @@ -719,22 +719,22 @@ sub _singleTarget if ($x->{oneInput}) { defined $self->_rd2($x, $input, $output) - or return undef; + or return undef; } else { for my $element ( ($x->{inType} eq 'hash') ? keys %$input : @$input) { - defined $self->_rd2($x, $element, $output) + defined $self->_rd2($x, $element, $output) or return undef ; } } - if ( ($x->{outType} eq 'filename' && $output ne '-') || + if ( ($x->{outType} eq 'filename' && $output ne '-') || ($x->{outType} eq 'handle' && $x->{Got}->getValue('autoclose'))) { - $x->{fh}->close() - or return retErr($x, $!); + $x->{fh}->close() + or return retErr($x, $!); delete $x->{fh}; } @@ -747,15 +747,15 @@ sub _rd2 my $x = shift ; my $input = shift; my $output = shift; - + my $z = IO::Compress::Base::Common::createSelfTiedObject($x->{Class}, *$self->{Error}); - + $z->_create($x->{Got}, 1, $input, @_) or return undef ; my $status ; my $fh = $x->{fh}; - + while (1) { while (($status = $z->read($x->{buff})) > 0) { @@ -770,9 +770,9 @@ sub _rd2 if (! $x->{oneOutput} ) { my $ot = $x->{outType} ; - if ($ot eq 'array') + if ($ot eq 'array') { push @$output, $x->{buff} } - elsif ($ot eq 'hash') + elsif ($ot eq 'hash') { $output->{$input} = $x->{buff} } my $buff = ''; @@ -781,12 +781,12 @@ sub _rd2 last if $status < 0 || $z->smartEof(); - last + last unless *$self->{MultiStream}; $status = $z->nextStream(); - last + last unless $status == 1 ; } @@ -796,7 +796,7 @@ sub _rd2 ${ *$self->{TrailingData} } = $z->trailingData() if defined *$self->{TrailingData} ; - $z->close() + $z->close() or return undef ; return 1 ; @@ -808,7 +808,7 @@ sub TIEHANDLE die "OOPS\n" ; } - + sub UNTIE { my $self = shift ; @@ -836,7 +836,7 @@ sub readBlock $size = List::Util::min($size, *$self->{CompressedInputLengthRemaining} ); *$self->{CompressedInputLengthRemaining} -= $size ; } - + my $status = $self->smartRead($buff, $size) ; return $self->saveErrorString(STATUS_ERROR, "Error Reading Data: $!", $!) if $status == STATUS_ERROR ; @@ -861,7 +861,7 @@ sub _raw_read # >0 - ok, number of bytes read # =0 - ok, eof # <0 - not ok - + my $self = shift ; return G_EOF if *$self->{Closed} ; @@ -873,8 +873,8 @@ sub _raw_read if (*$self->{Plain}) { my $tmp_buff ; my $len = $self->smartRead(\$tmp_buff, *$self->{BlockSize}) ; - - return $self->saveErrorString(G_ERR, "Error reading data: $!", $!) + + return $self->saveErrorString(G_ERR, "Error reading data: $!", $!) if $len == STATUS_ERROR ; if ($len == 0 ) { @@ -898,13 +898,13 @@ sub _raw_read $$buffer .= *$self->{Pending} ; my $len = length *$self->{Pending} ; *$self->{Pending} = ''; - return $len; + return $len; } my $temp_buf = ''; my $outSize = 0; my $status = $self->readBlock(\$temp_buf, *$self->{BlockSize}, $outSize) ; - + return G_ERR if $status == STATUS_ERROR ; @@ -915,18 +915,18 @@ sub _raw_read $status = *$self->{Uncomp}->uncompr(\$temp_buf, $buffer, defined *$self->{CompressedInputLengthDone} || $self->smartEof(), $outSize); - + # Remember the input buffer if it wasn't consumed completely $self->pushBack($temp_buf) if *$self->{Uncomp}{ConsumesInput}; return $self->saveErrorString(G_ERR, *$self->{Uncomp}{Error}, *$self->{Uncomp}{ErrorNo}) - if $self->saveStatus($status) == STATUS_ERROR; + if $self->saveStatus($status) == STATUS_ERROR; $self->postBlockChk($buffer, $before_len) == STATUS_OK or return G_ERR; $buf_len = defined $$buffer ? length($$buffer) - $before_len : 0; - + *$self->{CompSize}->add($beforeC_len - length $temp_buf) ; *$self->{InflatedBytesRead} += $buf_len ; @@ -960,7 +960,7 @@ sub _raw_read or return G_ERR; } else { - return $self->TrailerError("trailer truncated. Expected " . + return $self->TrailerError("trailer truncated. Expected " . "$trailer_size bytes, got $got") if *$self->{Strict}; $self->pushBack($trailer) ; @@ -978,7 +978,7 @@ sub _raw_read } } - + # return the number of uncompressed bytes read return $buf_len ; @@ -1029,7 +1029,7 @@ sub gotoNextStream # TODO - make this more efficient if know the offset for the end of # the stream and seekable - $status = $self->read($buffer) + $status = $self->read($buffer) while $status > 0 ; return $status @@ -1074,7 +1074,7 @@ sub gotoNextStream push @{ *$self->{InfoList} }, *$self->{Info} ; - return 1; + return 1; } sub streamCount @@ -1090,7 +1090,7 @@ sub read # >0 - ok, number of bytes read # =0 - ok, eof # <0 - not ok - + my $self = shift ; if (defined *$self->{ReadStatus} ) { @@ -1123,7 +1123,7 @@ sub read my $offset = $_[2] || 0; if (! *$self->{AppendOutput}) { - if (! $offset) { + if (! $offset) { $$buffer = '' ; } @@ -1161,13 +1161,13 @@ sub read } else { my $len = 0; - $len = $self->_raw_read($buffer) + $len = $self->_raw_read($buffer) while ! *$self->{EndStream} && $len == 0 ; return $len ; } } - # Need to jump through more hoops - either length or offset + # Need to jump through more hoops - either length or offset # or both are specified. my $out_buffer = *$self->{Pending} ; *$self->{Pending} = ''; @@ -1176,17 +1176,17 @@ sub read while (! *$self->{EndStream} && length($out_buffer) < $length) { my $buf_len = $self->_raw_read(\$out_buffer); - return $buf_len + return $buf_len if $buf_len < 0 ; } - $length = length $out_buffer + $length = length $out_buffer if length($out_buffer) < $length ; - return 0 + return 0 if $length == 0 ; - $$buffer = '' + $$buffer = '' if ! defined $$buffer; $offset = length $$buffer @@ -1223,7 +1223,7 @@ sub _getline # Paragraph Mode if ( ! length $/ ) { - my $paragraph ; + my $paragraph ; while (($status = $self->read($paragraph)) > 0 ) { if ($paragraph =~ s/^(.*?\n\n+)//s) { *$self->{Pending} = $paragraph ; @@ -1236,13 +1236,13 @@ sub _getline # $/ isn't empty, or a reference, so it's Line Mode. { - my $line ; + my $line ; my $p = \*$self->{Pending} ; while (($status = $self->read($line)) > 0 ) { my $offset = index($line, $/); if ($offset >= 0) { my $l = substr($line, 0, $offset + length $/ ); - substr($line, 0, $offset + length $/) = ''; + substr($line, 0, $offset + length $/) = ''; $$p = $line; return (1, \$l); } @@ -1262,7 +1262,7 @@ sub getline return undef; } - return undef + return undef if *$self->{Closed} || (!length *$self->{Pending} && *$self->{EndStream}) ; my $current_append = *$self->{AppendOutput} ; @@ -1271,7 +1271,7 @@ sub getline my ($status, $lineref) = $self->_getline(); *$self->{AppendOutput} = $current_append; - return undef + return undef if $status < 0 || length $$lineref == 0 ; $. = ++ *$self->{LineNo} ; @@ -1282,10 +1282,10 @@ sub getline sub getlines { my $self = shift; - $self->croakError(*$self->{ClassName} . + $self->croakError(*$self->{ClassName} . "::getlines: called in scalar context\n") unless wantarray; my($line, @lines); - push(@lines, $line) + push(@lines, $line) while defined($line = $self->getline); return @lines; } @@ -1307,8 +1307,8 @@ sub getc sub ungetc { my $self = shift; - *$self->{Pending} = "" unless defined *$self->{Pending} ; - *$self->{Pending} = $_[0] . *$self->{Pending} ; + *$self->{Pending} = "" unless defined *$self->{Pending} ; + *$self->{Pending} = $_[0] . *$self->{Pending} ; } @@ -1332,7 +1332,7 @@ sub eof my $self = shift ; return (*$self->{Closed} || - (!length *$self->{Pending} + (!length *$self->{Pending} && ( $self->smartEof() || *$self->{EndStream}))) ; } @@ -1362,14 +1362,14 @@ sub close return 1 if *$self->{Closed} ; - untie *$self + untie *$self if $] >= 5.008 ; my $status = 1 ; if (defined *$self->{FH}) { if ((! *$self->{Handle} || *$self->{AutoClose}) && ! *$self->{StdIO}) { - local $.; + local $.; $! = 0 ; $status = *$self->{FH}->close(); return $self->saveErrorString(0, $!, $!) @@ -1449,8 +1449,8 @@ sub seek sub fileno { my $self = shift ; - return defined *$self->{FH} - ? fileno *$self->{FH} + return defined *$self->{FH} + ? fileno *$self->{FH} : undef ; } @@ -1458,8 +1458,8 @@ sub binmode { 1; # my $self = shift ; -# return defined *$self->{FH} -# ? binmode *$self->{FH} +# return defined *$self->{FH} +# ? binmode *$self->{FH} # : 1 ; } @@ -1472,8 +1472,8 @@ sub opened sub autoflush { my $self = shift ; - return defined *$self->{FH} - ? *$self->{FH}->autoflush(@_) + return defined *$self->{FH} + ? *$self->{FH}->autoflush(@_) : undef ; } @@ -1485,33 +1485,35 @@ sub input_line_number return $last; } - -*BINMODE = \&binmode; -*SEEK = \&seek; -*READ = \&read; -*sysread = \&read; -*TELL = \&tell; -*EOF = \&eof; - -*FILENO = \&fileno; -*CLOSE = \&close; - sub _notAvailable { my $name = shift ; return sub { croak "$name Not Available: File opened only for intput" ; } ; } - -*print = _notAvailable('print'); -*PRINT = _notAvailable('print'); -*printf = _notAvailable('printf'); -*PRINTF = _notAvailable('printf'); -*write = _notAvailable('write'); -*WRITE = _notAvailable('write'); - -#*sysread = \&read; -#*syswrite = \&_notAvailable; +{ + no warnings 'once'; + + *BINMODE = \&binmode; + *SEEK = \&seek; + *READ = \&read; + *sysread = \&read; + *TELL = \&tell; + *EOF = \&eof; + + *FILENO = \&fileno; + *CLOSE = \&close; + + *print = _notAvailable('print'); + *PRINT = _notAvailable('print'); + *printf = _notAvailable('printf'); + *PRINTF = _notAvailable('printf'); + *write = _notAvailable('write'); + *WRITE = _notAvailable('write'); + + #*sysread = \&read; + #*syswrite = \&_notAvailable; +} @@ -1560,8 +1562,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2020 Paul Marquess. All rights reserved. +Copyright (c) 2005-2021 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. - diff --git a/cpan/IO-Compress/lib/IO/Uncompress/Bunzip2.pm b/cpan/IO-Compress/lib/IO/Uncompress/Bunzip2.pm index 65932c19c445..1bc8ac2b0eba 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/Bunzip2.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/Bunzip2.pm @@ -4,15 +4,15 @@ use strict ; use warnings; use bytes; -use IO::Compress::Base::Common 2.096 qw(:Status ); +use IO::Compress::Base::Common 2.100 qw(:Status ); -use IO::Uncompress::Base 2.096 ; -use IO::Uncompress::Adapter::Bunzip2 2.096 ; +use IO::Uncompress::Base 2.100 ; +use IO::Uncompress::Adapter::Bunzip2 2.100 ; require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $Bunzip2Error); -$VERSION = '2.096'; +$VERSION = '2.100'; $Bunzip2Error = ''; @ISA = qw(IO::Uncompress::Base Exporter); @@ -72,7 +72,7 @@ sub mkUncomp return $self->saveErrorString(undef, $errstr, $errno) if ! defined $obj; - + *$self->{Uncomp} = $obj; return 1; @@ -88,15 +88,15 @@ sub ckMagic $self->smartReadExact(\$magic, 4); *$self->{HeaderPending} = $magic ; - - return $self->HeaderError("Header size is " . - 4 . " bytes") + + return $self->HeaderError("Header size is " . + 4 . " bytes") if length $magic != 4; return $self->HeaderError("Bad Magic.") if ! isBzip2Magic($magic) ; - - + + *$self->{Type} = 'bzip2'; return $magic; } @@ -117,7 +117,7 @@ sub readHeader 'TrailerLength' => 0, 'Header' => '$magic' }; - + } sub chkTrailer @@ -149,7 +149,7 @@ IO::Uncompress::Bunzip2 - Read bzip2 files/buffers my $status = bunzip2 $input => $output [,OPTS] or die "bunzip2 failed: $Bunzip2Error\n"; - my $z = new IO::Uncompress::Bunzip2 $input [OPTS] + my $z = IO::Uncompress::Bunzip2->new( $input [OPTS] ) or die "bunzip2 failed: $Bunzip2Error\n"; $status = $z->read($buffer) @@ -440,7 +440,7 @@ uncompressed data to a buffer, C<$buffer>. use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ; use IO::File ; - my $input = new IO::File "new( " \$buffer @@ -475,7 +475,7 @@ and if you want to compress each file one at a time, this will do the trick The format of the constructor for IO::Uncompress::Bunzip2 is shown below - my $z = new IO::Uncompress::Bunzip2 $input [OPTS] + my $z = IO::Uncompress::Bunzip2->new( $input [OPTS] ) or die "IO::Uncompress::Bunzip2 failed: $Bunzip2Error\n"; Returns an C object on success and undef on failure. @@ -907,8 +907,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2020 Paul Marquess. All rights reserved. +Copyright (c) 2005-2021 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. - diff --git a/cpan/IO-Compress/lib/IO/Uncompress/Gunzip.pm b/cpan/IO-Compress/lib/IO/Uncompress/Gunzip.pm index 2bb383c2b886..2c2529d53b1b 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/Gunzip.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/Gunzip.pm @@ -9,12 +9,12 @@ use strict ; use warnings; use bytes; -use IO::Uncompress::RawInflate 2.096 ; +use IO::Uncompress::RawInflate 2.100 ; -use Compress::Raw::Zlib 2.096 () ; -use IO::Compress::Base::Common 2.096 qw(:Status ); -use IO::Compress::Gzip::Constants 2.096 ; -use IO::Compress::Zlib::Extra 2.096 ; +use Compress::Raw::Zlib 2.100 () ; +use IO::Compress::Base::Common 2.100 qw(:Status ); +use IO::Compress::Gzip::Constants 2.100 ; +use IO::Compress::Zlib::Extra 2.100 ; require Exporter ; @@ -28,7 +28,7 @@ Exporter::export_ok_tags('all'); $GunzipError = ''; -$VERSION = '2.096'; +$VERSION = '2.100'; sub new { @@ -70,9 +70,9 @@ sub ckMagic *$self->{HeaderPending} = $magic ; - return $self->HeaderError("Minimum header size is " . - GZIP_MIN_HEADER_SIZE . " bytes") - if length $magic != GZIP_ID_SIZE ; + return $self->HeaderError("Minimum header size is " . + GZIP_MIN_HEADER_SIZE . " bytes") + if length $magic != GZIP_ID_SIZE ; return $self->HeaderError("Bad Magic") if ! isGzipMagic($magic) ; @@ -95,10 +95,10 @@ sub chkTrailer my $self = shift; my $trailer = shift; - # Check CRC & ISIZE + # Check CRC & ISIZE my ($CRC32, $ISIZE) = unpack("V V", $trailer) ; - *$self->{Info}{CRC32} = $CRC32; - *$self->{Info}{ISIZE} = $ISIZE; + *$self->{Info}{CRC32} = $CRC32; + *$self->{Info}{ISIZE} = $ISIZE; if (*$self->{Strict}) { return $self->TrailerError("CRC mismatch") @@ -130,9 +130,9 @@ sub _readFullGzipHeader($) *$self->{HeaderPending} = $magic ; - return $self->HeaderError("Minimum header size is " . - GZIP_MIN_HEADER_SIZE . " bytes") - if length $magic != GZIP_ID_SIZE ; + return $self->HeaderError("Minimum header size is " . + GZIP_MIN_HEADER_SIZE . " bytes") + if length $magic != GZIP_ID_SIZE ; return $self->HeaderError("Bad Magic") @@ -150,7 +150,7 @@ sub _readGzipHeader($) my ($buffer) = '' ; $self->smartReadExact(\$buffer, GZIP_MIN_HEADER_SIZE - GZIP_ID_SIZE) - or return $self->HeaderError("Minimum header size is " . + or return $self->HeaderError("Minimum header size is " . GZIP_MIN_HEADER_SIZE . " bytes") ; my $keep = $magic . $buffer ; @@ -159,22 +159,22 @@ sub _readGzipHeader($) # now split out the various parts my ($cm, $flag, $mtime, $xfl, $os) = unpack("C C V C C", $buffer) ; - $cm == GZIP_CM_DEFLATED + $cm == GZIP_CM_DEFLATED or return $self->HeaderError("Not Deflate (CM is $cm)") ; # check for use of reserved bits return $self->HeaderError("Use of Reserved Bits in FLG field.") - if $flag & GZIP_FLG_RESERVED ; + if $flag & GZIP_FLG_RESERVED ; my $EXTRA ; my @EXTRA = () ; if ($flag & GZIP_FLG_FEXTRA) { $EXTRA = "" ; - $self->smartReadExact(\$buffer, GZIP_FEXTRA_HEADER_SIZE) + $self->smartReadExact(\$buffer, GZIP_FEXTRA_HEADER_SIZE) or return $self->TruncatedHeader("FEXTRA Length") ; my ($XLEN) = unpack("v", $buffer) ; - $self->smartReadExact(\$EXTRA, $XLEN) + $self->smartReadExact(\$EXTRA, $XLEN) or return $self->TruncatedHeader("FEXTRA Body"); $keep .= $buffer . $EXTRA ; @@ -190,10 +190,10 @@ sub _readGzipHeader($) if ($flag & GZIP_FLG_FNAME) { $origname = "" ; while (1) { - $self->smartReadExact(\$buffer, 1) + $self->smartReadExact(\$buffer, 1) or return $self->TruncatedHeader("FNAME"); last if $buffer eq GZIP_NULL_BYTE ; - $origname .= $buffer + $origname .= $buffer } $keep .= $origname . GZIP_NULL_BYTE ; @@ -205,10 +205,10 @@ sub _readGzipHeader($) if ($flag & GZIP_FLG_FCOMMENT) { $comment = ""; while (1) { - $self->smartReadExact(\$buffer, 1) + $self->smartReadExact(\$buffer, 1) or return $self->TruncatedHeader("FCOMMENT"); last if $buffer eq GZIP_NULL_BYTE ; - $comment .= $buffer + $comment .= $buffer } $keep .= $comment . GZIP_NULL_BYTE ; @@ -217,7 +217,7 @@ sub _readGzipHeader($) } if ($flag & GZIP_FLG_FHCRC) { - $self->smartReadExact(\$buffer, GZIP_FHCRC_SIZE) + $self->smartReadExact(\$buffer, GZIP_FHCRC_SIZE) or return $self->TruncatedHeader("FHCRC"); $HeaderCRC = unpack("v", $buffer) ; @@ -254,7 +254,7 @@ sub _readGzipHeader($) 'Comment' => $comment, 'Time' => $mtime, 'OsID' => $os, - 'OsName' => defined $GZIP_OS_Names{$os} + 'OsName' => defined $GZIP_OS_Names{$os} ? $GZIP_OS_Names{$os} : "Unknown", 'HeaderCRC' => $HeaderCRC, 'Flags' => $flag, @@ -286,7 +286,7 @@ IO::Uncompress::Gunzip - Read RFC 1952 files/buffers my $status = gunzip $input => $output [,OPTS] or die "gunzip failed: $GunzipError\n"; - my $z = new IO::Uncompress::Gunzip $input [OPTS] + my $z = IO::Uncompress::Gunzip->new( $input [OPTS] ) or die "gunzip failed: $GunzipError\n"; $status = $z->read($buffer) @@ -579,7 +579,7 @@ uncompressed data to a buffer, C<$buffer>. use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ; use IO::File ; - my $input = new IO::File "new( " \$buffer @@ -614,7 +614,7 @@ and if you want to compress each file one at a time, this will do the trick The format of the constructor for IO::Uncompress::Gunzip is shown below - my $z = new IO::Uncompress::Gunzip $input [OPTS] + my $z = IO::Uncompress::Gunzip->new( $input [OPTS] ) or die "IO::Uncompress::Gunzip failed: $GunzipError\n"; Returns an C object on success and undef on failure. @@ -1122,8 +1122,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2020 Paul Marquess. All rights reserved. +Copyright (c) 2005-2021 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. - diff --git a/cpan/IO-Compress/lib/IO/Uncompress/Inflate.pm b/cpan/IO-Compress/lib/IO/Uncompress/Inflate.pm index 3d576f952914..5621959af930 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/Inflate.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/Inflate.pm @@ -5,15 +5,15 @@ use strict ; use warnings; use bytes; -use IO::Compress::Base::Common 2.096 qw(:Status ); -use IO::Compress::Zlib::Constants 2.096 ; +use IO::Compress::Base::Common 2.100 qw(:Status ); +use IO::Compress::Zlib::Constants 2.100 ; -use IO::Uncompress::RawInflate 2.096 ; +use IO::Uncompress::RawInflate 2.100 ; require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $InflateError); -$VERSION = '2.096'; +$VERSION = '2.100'; $InflateError = ''; @ISA = qw(IO::Uncompress::RawInflate Exporter); @@ -62,14 +62,14 @@ sub ckMagic *$self->{HeaderPending} = $magic ; - return $self->HeaderError("Header size is " . - ZLIB_HEADER_SIZE . " bytes") + return $self->HeaderError("Header size is " . + ZLIB_HEADER_SIZE . " bytes") if length $magic != ZLIB_HEADER_SIZE; #return $self->HeaderError("CRC mismatch.") return undef if ! $self->isZlibMagic($magic) ; - + *$self->{Type} = 'rfc1950'; return $magic; } @@ -88,7 +88,7 @@ sub chkTrailer my $trailer = shift; my $ADLER32 = unpack("N", $trailer) ; - *$self->{Info}{ADLER32} = $ADLER32; + *$self->{Info}{ADLER32} = $ADLER32; return $self->TrailerError("CRC mismatch") if *$self->{Strict} && $ADLER32 != *$self->{Uncomp}->adler32() ; @@ -102,7 +102,7 @@ sub isZlibMagic my $self = shift; my $buffer = shift ; - return 0 + return 0 if length $buffer < ZLIB_HEADER_SIZE ; my $hdr = unpack("n", $buffer) ; @@ -114,16 +114,16 @@ sub isZlibMagic my $cm = bits($CMF, ZLIB_CMF_CM_OFFSET, ZLIB_CMF_CM_BITS) ; # Only Deflate supported - return $self->HeaderError("Not Deflate (CM is $cm)") + return $self->HeaderError("Not Deflate (CM is $cm)") if $cm != ZLIB_CMF_CM_DEFLATED ; # Max window value is 7 for Deflate. my $cinfo = bits($CMF, ZLIB_CMF_CINFO_OFFSET, ZLIB_CMF_CINFO_BITS) ; - return $self->HeaderError("CINFO > " . ZLIB_CMF_CINFO_MAX . - " (CINFO is $cinfo)") + return $self->HeaderError("CINFO > " . ZLIB_CMF_CINFO_MAX . + " (CINFO is $cinfo)") if $cinfo > ZLIB_CMF_CINFO_MAX ; - return 1; + return 1; } sub bits @@ -145,19 +145,19 @@ sub _readDeflateHeader # # *$self->{HeaderPending} = $buffer ; # -# return $self->HeaderError("Header size is " . -# ZLIB_HEADER_SIZE . " bytes") +# return $self->HeaderError("Header size is " . +# ZLIB_HEADER_SIZE . " bytes") # if length $buffer != ZLIB_HEADER_SIZE; # # return $self->HeaderError("CRC mismatch.") # if ! isZlibMagic($buffer) ; # } - + my ($CMF, $FLG) = unpack "C C", $buffer; my $FDICT = bits($FLG, ZLIB_FLG_FDICT_OFFSET, ZLIB_FLG_FDICT_BITS ), my $cm = bits($CMF, ZLIB_CMF_CM_OFFSET, ZLIB_CMF_CM_BITS) ; - $cm == ZLIB_CMF_CM_DEFLATED + $cm == ZLIB_CMF_CM_DEFLATED or return $self->HeaderError("Not Deflate (CM is $cm)") ; my $DICTID; @@ -208,7 +208,7 @@ IO::Uncompress::Inflate - Read RFC 1950 files/buffers my $status = inflate $input => $output [,OPTS] or die "inflate failed: $InflateError\n"; - my $z = new IO::Uncompress::Inflate $input [OPTS] + my $z = IO::Uncompress::Inflate->new( $input [OPTS] ) or die "inflate failed: $InflateError\n"; $status = $z->read($buffer) @@ -501,7 +501,7 @@ uncompressed data to a buffer, C<$buffer>. use IO::Uncompress::Inflate qw(inflate $InflateError) ; use IO::File ; - my $input = new IO::File "new( " \$buffer @@ -536,7 +536,7 @@ and if you want to compress each file one at a time, this will do the trick The format of the constructor for IO::Uncompress::Inflate is shown below - my $z = new IO::Uncompress::Inflate $input [OPTS] + my $z = IO::Uncompress::Inflate->new( $input [OPTS] ) or die "IO::Uncompress::Inflate failed: $InflateError\n"; Returns an C object on success and undef on failure. @@ -994,8 +994,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2020 Paul Marquess. All rights reserved. +Copyright (c) 2005-2021 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. - diff --git a/cpan/IO-Compress/lib/IO/Uncompress/RawInflate.pm b/cpan/IO-Compress/lib/IO/Uncompress/RawInflate.pm index b5a4b8a71ead..1a6c1f5860cc 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/RawInflate.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/RawInflate.pm @@ -5,16 +5,16 @@ use strict ; use warnings; use bytes; -use Compress::Raw::Zlib 2.096 ; -use IO::Compress::Base::Common 2.096 qw(:Status ); +use Compress::Raw::Zlib 2.100 ; +use IO::Compress::Base::Common 2.100 qw(:Status ); -use IO::Uncompress::Base 2.096 ; -use IO::Uncompress::Adapter::Inflate 2.096 ; +use IO::Uncompress::Base 2.100 ; +use IO::Uncompress::Adapter::Inflate 2.100 ; require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $RawInflateError); -$VERSION = '2.096'; +$VERSION = '2.100'; $RawInflateError = ''; @ISA = qw(IO::Uncompress::Base Exporter); @@ -25,16 +25,16 @@ push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; Exporter::export_ok_tags('all'); #{ -# # Execute at runtime +# # Execute at runtime # my %bad; # for my $module (qw(Compress::Raw::Zlib IO::Compress::Base::Common IO::Uncompress::Base IO::Uncompress::Adapter::Inflate)) # { # my $ver = ${ $module . "::VERSION"} ; -# +# # $bad{$module} = $ver # if $ver ne $VERSION; # } -# +# # if (keys %bad) # { # my $string = join "\n", map { "$_ $bad{$_}" } keys %bad; @@ -148,14 +148,14 @@ sub _isRawx my $buffer = ''; - $self->smartRead(\$buffer, *$self->{BlockSize}) >= 0 + $self->smartRead(\$buffer, *$self->{BlockSize}) >= 0 or return $self->saveErrorString(undef, "No data to read"); my $temp_buf = $magic . $buffer ; - *$self->{HeaderPending} = $temp_buf ; + *$self->{HeaderPending} = $temp_buf ; $buffer = ''; my $status = *$self->{Uncomp}->uncompr(\$temp_buf, \$buffer, $self->smartEof()) ; - + return $self->saveErrorString(undef, *$self->{Uncomp}{Error}, STATUS_ERROR) if $status == STATUS_ERROR; @@ -163,12 +163,12 @@ sub _isRawx return $self->saveErrorString(undef, "unexpected end of file", STATUS_ERROR) if $self->smartEof() && $status != STATUS_ENDSTREAM; - + #my $buf_len = *$self->{Uncomp}->uncompressedBytes(); my $buf_len = length $buffer; if ($status == STATUS_ENDSTREAM) { - if (*$self->{MultiStream} + if (*$self->{MultiStream} && (length $temp_buf || ! $self->smartEof())){ *$self->{NewStream} = 1 ; *$self->{EndStream} = 0 ; @@ -177,9 +177,9 @@ sub _isRawx *$self->{EndStream} = 1 ; } } - *$self->{HeaderPending} = $buffer ; - *$self->{InflatedBytesRead} = $buf_len ; - *$self->{TotalInflatedBytesRead} += $buf_len ; + *$self->{HeaderPending} = $buffer ; + *$self->{InflatedBytesRead} = $buf_len ; + *$self->{TotalInflatedBytesRead} += $buf_len ; *$self->{Type} = 'rfc1951'; $self->saveStatus(STATUS_OK); @@ -229,7 +229,7 @@ sub inflateSync return $self->saveErrorString(0, "unexpected end of file", STATUS_ERROR); } } - + $status = *$self->{Uncomp}->sync($temp_buf) ; if ($status == STATUS_OK) @@ -251,23 +251,23 @@ sub inflateSync # my $status ; # my $end_offset = 0; # -# $status = $self->scan() +# $status = $self->scan() # #or return $self->saveErrorString(undef, "Error Scanning: $$error_ref", $self->errorNo) ; # or return $self->saveErrorString(G_ERR, "Error Scanning: $status") # -# $status = $self->zap($end_offset) +# $status = $self->zap($end_offset) # or return $self->saveErrorString(G_ERR, "Error Zapping: $status"); # #or return $self->saveErrorString(undef, "Error Zapping: $$error_ref", $self->errorNo) ; # # #(*$obj->{Deflate}, $status) = $inf->createDeflate(); # ## *$obj->{Header} = *$inf->{Info}{Header}; -## *$obj->{UnCompSize_32bit} = +## *$obj->{UnCompSize_32bit} = ## *$obj->{BytesWritten} = *$inf->{UnCompSize_32bit} ; ## *$obj->{CompSize_32bit} = *$inf->{CompSize_32bit} ; # # -## if ( $outType eq 'buffer') +## if ( $outType eq 'buffer') ## { substr( ${ *$self->{Buffer} }, $end_offset) = '' } ## elsif ($outType eq 'handle' || $outType eq 'filename') { ## *$self->{FH} = *$inf->{FH} ; @@ -275,11 +275,11 @@ sub inflateSync ## *$obj->{FH}->flush() ; ## *$obj->{Handle} = 1 if $outType eq 'handle'; ## -## #seek(*$obj->{FH}, $end_offset, SEEK_SET) -## *$obj->{FH}->seek($end_offset, SEEK_SET) +## #seek(*$obj->{FH}, $end_offset, SEEK_SET) +## *$obj->{FH}->seek($end_offset, SEEK_SET) ## or return $obj->saveErrorString(undef, $!, $!) ; ## } -# +# #} sub scan @@ -292,7 +292,7 @@ sub scan my $buffer = '' ; my $len = 0; - $len = $self->_raw_read(\$buffer, 1) + $len = $self->_raw_read(\$buffer, 1) while ! *$self->{EndStream} && $len >= 0 ; #return $len if $len < 0 ? $len : 0 ; @@ -310,16 +310,16 @@ sub zap #printf "# block_offset $block_offset %x\n", $block_offset; my $byte ; ( $self->smartSeek($block_offset) && - $self->smartRead(\$byte, 1) ) - or return $self->saveErrorString(0, $!, $!); + $self->smartRead(\$byte, 1) ) + or return $self->saveErrorString(0, $!, $!); #printf "#byte is %x\n", unpack('C*',$byte); *$self->{Uncomp}->resetLastBlockByte($byte); #printf "#to byte is %x\n", unpack('C*',$byte); - ( $self->smartSeek($block_offset) && + ( $self->smartSeek($block_offset) && $self->smartWrite($byte) ) - or return $self->saveErrorString(0, $!, $!); + or return $self->saveErrorString(0, $!, $!); #$self->smartSeek($end_offset, 1); @@ -335,12 +335,12 @@ sub createDeflate -CRC32 => *$self->{Params}->getValue('crc32'), -ADLER32 => *$self->{Params}->getValue('adler32'), ); - - return wantarray ? ($status, $def) : $def ; + + return wantarray ? ($status, $def) : $def ; } -1; +1; __END__ @@ -356,7 +356,7 @@ IO::Uncompress::RawInflate - Read RFC 1951 files/buffers my $status = rawinflate $input => $output [,OPTS] or die "rawinflate failed: $RawInflateError\n"; - my $z = new IO::Uncompress::RawInflate $input [OPTS] + my $z = IO::Uncompress::RawInflate->new( $input [OPTS] ) or die "rawinflate failed: $RawInflateError\n"; $status = $z->read($buffer) @@ -646,7 +646,7 @@ uncompressed data to a buffer, C<$buffer>. use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ; use IO::File ; - my $input = new IO::File "new( " \$buffer @@ -681,7 +681,7 @@ and if you want to compress each file one at a time, this will do the trick The format of the constructor for IO::Uncompress::RawInflate is shown below - my $z = new IO::Uncompress::RawInflate $input [OPTS] + my $z = IO::Uncompress::RawInflate->new( $input [OPTS] ) or die "IO::Uncompress::RawInflate failed: $RawInflateError\n"; Returns an C object on success and undef on failure. @@ -1122,8 +1122,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2020 Paul Marquess. All rights reserved. +Copyright (c) 2005-2021 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. - diff --git a/cpan/IO-Compress/lib/IO/Uncompress/Unzip.pm b/cpan/IO-Compress/lib/IO/Uncompress/Unzip.pm index 24cd66e51ee3..55eb89e0103a 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/Unzip.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/Unzip.pm @@ -9,14 +9,14 @@ use warnings; use bytes; use IO::File; -use IO::Uncompress::RawInflate 2.096 ; -use IO::Compress::Base::Common 2.096 qw(:Status ); -use IO::Uncompress::Adapter::Inflate 2.096 ; -use IO::Uncompress::Adapter::Identity 2.096 ; -use IO::Compress::Zlib::Extra 2.096 ; -use IO::Compress::Zip::Constants 2.096 ; +use IO::Uncompress::RawInflate 2.100 ; +use IO::Compress::Base::Common 2.100 qw(:Status ); +use IO::Uncompress::Adapter::Inflate 2.100 ; +use IO::Uncompress::Adapter::Identity 2.100 ; +use IO::Compress::Zlib::Extra 2.100 ; +use IO::Compress::Zip::Constants 2.100 ; -use Compress::Raw::Zlib 2.096 () ; +use Compress::Raw::Zlib 2.100 () ; BEGIN { @@ -24,13 +24,13 @@ BEGIN local $SIG{__DIE__}; eval{ require IO::Uncompress::Adapter::Bunzip2 ; - import IO::Uncompress::Adapter::Bunzip2 } ; + IO::Uncompress::Adapter::Bunzip2->import() } ; eval{ require IO::Uncompress::Adapter::UnLzma ; - import IO::Uncompress::Adapter::UnLzma } ; + IO::Uncompress::Adapter::UnLzma->import() } ; eval{ require IO::Uncompress::Adapter::UnXz ; - import IO::Uncompress::Adapter::UnXz } ; + IO::Uncompress::Adapter::UnXz->import() } ; eval{ require IO::Uncompress::Adapter::UnZstd ; - import IO::Uncompress::Adapter::UnZstd } ; + IO::Uncompress::Adapter::UnZstd->import() } ; } @@ -38,7 +38,7 @@ require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $UnzipError, %headerLookup); -$VERSION = '2.096'; +$VERSION = '2.100'; $UnzipError = ''; @ISA = qw(IO::Uncompress::RawInflate Exporter); @@ -932,7 +932,7 @@ sub scanCentralDirectory $self->skip($filename_length ) ; - my $v64 = new U64 $compressedLength ; + my $v64 = U64->new( $compressedLength ); if (U64::full32 $compressedLength ) { $self->smartReadExact(\$buffer, $extra_length) ; @@ -1093,7 +1093,7 @@ IO::Uncompress::Unzip - Read zip files/buffers my $status = unzip $input => $output [,OPTS] or die "unzip failed: $UnzipError\n"; - my $z = new IO::Uncompress::Unzip $input [OPTS] + my $z = IO::Uncompress::Unzip->new( $input [OPTS] ) or die "unzip failed: $UnzipError\n"; $status = $z->read($buffer) @@ -1445,7 +1445,7 @@ uncompressed data to a buffer, C<$buffer>. use IO::Uncompress::Unzip qw(unzip $UnzipError) ; use IO::File ; - my $input = new IO::File "new( " \$buffer @@ -1457,7 +1457,7 @@ uncompressed data to a buffer, C<$buffer>. The format of the constructor for IO::Uncompress::Unzip is shown below - my $z = new IO::Uncompress::Unzip $input [OPTS] + my $z = IO::Uncompress::Unzip->new( $input [OPTS] ) or die "IO::Uncompress::Unzip failed: $UnzipError\n"; Returns an C object on success and undef on failure. @@ -1890,7 +1890,7 @@ stream at a time. use IO::Uncompress::Unzip qw($UnzipError); my $zipfile = "somefile.zip"; - my $u = new IO::Uncompress::Unzip $zipfile + my $u = IO::Uncompress::Unzip->new( $zipfile ) or die "Cannot open $zipfile: $UnzipError"; my $status; @@ -1965,8 +1965,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2020 Paul Marquess. All rights reserved. +Copyright (c) 2005-2021 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. - diff --git a/cpan/IO-Compress/private/MakeUtil.pm b/cpan/IO-Compress/private/MakeUtil.pm index 12fa26fd05f1..aa540c68fda3 100644 --- a/cpan/IO-Compress/private/MakeUtil.pm +++ b/cpan/IO-Compress/private/MakeUtil.pm @@ -42,14 +42,14 @@ sub MY::libscan return $path; } -sub MY::postamble +sub MY::postamble { return '' if $ENV{PERL_CORE} ; my @files = getPerlFiles('MANIFEST'); - # Note: Once you remove all the layers of shell/makefile escaping + # Note: Once you remove all the layers of shell/makefile escaping # the regular expression below reads # # /^\s*local\s*\(\s*\$^W\s*\)/ @@ -215,7 +215,7 @@ sub UpDowngrade foreach (@files) { #if (-l $_ ) { doUpDown($our_sub, $warn_sub, $_) } - #else + #else #{ doUpDownViaCopy($our_sub, $warn_sub, $_) } } @@ -234,7 +234,7 @@ sub doUpDown local ($^I) = ($^O eq 'VMS') ? "_bak" : ".bak"; local (@ARGV) = shift; - + while (<>) { print, last if /^__(END|DATA)__/ ; @@ -277,7 +277,7 @@ sub doUpDownViaCopy push @keep, $_; last ; } - + &{ $our_sub }() if $our_sub ; &{ $warn_sub }() if $warn_sub ; push @keep, $_; @@ -334,7 +334,7 @@ sub FindBrokenDependencies Compress::Zlib ); - + my @broken = (); foreach my $module ( grep { ! $thisModule{$_} } @modules) @@ -342,12 +342,12 @@ sub FindBrokenDependencies my $hasVersion = getInstalledVersion($module); # No need to upgrade if the module isn't installed at all - next + next if ! defined $hasVersion; # If already have C::Z version 1, then an upgrade to any of the # IO::Compress modules will not break it. - next + next if $module eq 'Compress::Zlib' && $hasVersion < 2; if ($hasVersion < $version) @@ -370,14 +370,12 @@ sub getInstalledVersion { no strict 'refs'; $version = ${ $module . "::VERSION" }; - $version = 0 + $version = 0 } - + return $version; } package MakeUtil ; 1; - - diff --git a/cpan/IO-Compress/t/000prereq.t b/cpan/IO-Compress/t/000prereq.t index 205e032573d9..f657083ad4f8 100644 --- a/cpan/IO-Compress/t/000prereq.t +++ b/cpan/IO-Compress/t/000prereq.t @@ -25,7 +25,7 @@ BEGIN if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - my $VERSION = '2.096'; + my $VERSION = '2.100'; my @NAMES = qw( Compress::Raw::Bzip2 Compress::Raw::Zlib @@ -60,7 +60,7 @@ BEGIN ); - my @OPT = qw( + my @OPT = qw( ); plan tests => 1 + 2 + @NAMES + @OPT + $extra ; @@ -76,21 +76,21 @@ BEGIN eval " require $name " ; if ($@) { - ok 1, "$name not available" + ok 1, "$name not available" } - else + else { my $ver = eval("\$${name}::VERSION"); - is $ver, $VERSION, "$name version should be $VERSION" + is $ver, $VERSION, "$name version should be $VERSION" or diag "$name version is $ver, need $VERSION" ; - } + } } # need zlib 1.2.0 or better - + cmp_ok Compress::Raw::Zlib::ZLIB_VERNUM(), ">=", 0x1200 - or diag "IO::Compress needs zlib 1.2.0 or better, you have " . Compress::Raw::Zlib::zlib_version(); - + or diag "IO::Compress needs zlib 1.2.0 or better, you have " . Compress::Raw::Zlib::zlib_version(); + use_ok('Scalar::Util') ; } @@ -99,4 +99,3 @@ ok gotScalarUtilXS(), "Got XS Version of Scalar::Util" or diag <can('new')->( $UncompressClass, $filename, -Strict => 1, -Append => 1 - ; + ); my $data = ''; $data = $init if defined $init ; @@ -66,7 +66,7 @@ sub myBZreadFile title "BlockSize100K => $stringValue"; my $err = "Parameter 'BlockSize100K' must be an unsigned int, got '$stringValue'"; my $bz ; - eval { $bz = new IO::Compress::Bzip2(\$buffer, BlockSize100K => $value) }; + eval { $bz = IO::Compress::Bzip2->new(\$buffer, BlockSize100K => $value) }; like $@, mkErr("IO::Compress::Bzip2: $err"), " value $stringValue is bad"; is $Bzip2Error, "IO::Compress::Bzip2: $err", @@ -80,7 +80,7 @@ sub myBZreadFile title "BlockSize100K => $stringValue"; my $err = "Parameter 'BlockSize100K' not between 1 and 9, got $stringValue"; my $bz ; - eval { $bz = new IO::Compress::Bzip2(\$buffer, BlockSize100K => $value) }; + eval { $bz = IO::Compress::Bzip2->new(\$buffer, BlockSize100K => $value) }; like $@, mkErr("IO::Compress::Bzip2: $err"), " value $stringValue is bad"; is $Bzip2Error, "IO::Compress::Bzip2: $err", @@ -94,7 +94,7 @@ sub myBZreadFile title "WorkFactor => $stringValue"; my $err = "Parameter 'WorkFactor' must be an unsigned int, got '$stringValue'"; my $bz ; - eval { $bz = new IO::Compress::Bzip2(\$buffer, WorkFactor => $value) }; + eval { $bz = IO::Compress::Bzip2->new(\$buffer, WorkFactor => $value) }; like $@, mkErr("IO::Compress::Bzip2: $err"), " value $stringValue is bad"; is $Bzip2Error, "IO::Compress::Bzip2: $err", @@ -108,7 +108,7 @@ sub myBZreadFile title "WorkFactor => $stringValue"; my $err = "Parameter 'WorkFactor' not between 0 and 250, got $stringValue"; my $bz ; - eval { $bz = new IO::Compress::Bzip2(\$buffer, WorkFactor => $value) }; + eval { $bz = IO::Compress::Bzip2->new(\$buffer, WorkFactor => $value) }; like $@, mkErr("IO::Compress::Bzip2: $err"), " value $stringValue is bad"; is $Bzip2Error, "IO::Compress::Bzip2: $err", @@ -130,7 +130,7 @@ sub myBZreadFile title "Small => $stringValue"; my $err = "Parameter 'Small' must be an int, got '$stringValue'"; my $bz ; - eval { $bz = new IO::Uncompress::Bunzip2(\$buffer, Small => $value) }; + eval { $bz = IO::Uncompress::Bunzip2->new(\$buffer, Small => $value) }; like $@, mkErr("IO::Uncompress::Bunzip2: $err"), " value $stringValue is bad"; is $Bunzip2Error, "IO::Uncompress::Bunzip2: $err", @@ -151,9 +151,9 @@ EOM for my $value ( 1 .. 9 ) { title "$CompressClass - BlockSize100K => $value"; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $bz ; - $bz = new IO::Compress::Bzip2($name, BlockSize100K => $value) + $bz = IO::Compress::Bzip2->new($name, BlockSize100K => $value) or diag $IO::Compress::Bzip2::Bzip2Error ; ok $bz, " bz object ok"; $bz->write($hello); @@ -165,9 +165,9 @@ EOM for my $value ( 0 .. 250 ) { title "$CompressClass - WorkFactor => $value"; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $bz ; - $bz = new IO::Compress::Bzip2($name, WorkFactor => $value); + $bz = IO::Compress::Bzip2->new($name, WorkFactor => $value); ok $bz, " bz object ok"; $bz->write($hello); $bz->close($hello); @@ -178,16 +178,16 @@ EOM for my $value ( 0 .. 1 ) { title "$UncompressClass - Small => $value"; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $bz ; - $bz = new IO::Compress::Bzip2($name); + $bz = IO::Compress::Bzip2->new($name); ok $bz, " bz object ok"; $bz->write($hello); $bz->close($hello); - my $fil = new $UncompressClass $name, + my $fil = $UncompressClass->can('new')->( $UncompressClass, $name, Append => 1, - Small => $value ; + Small => $value ); my $data = ''; 1 while $fil->read($data) > 0; @@ -200,7 +200,3 @@ EOM 1; - - - - diff --git a/cpan/IO-Compress/t/002any-transparent.t b/cpan/IO-Compress/t/002any-transparent.t index bb26bbcac0af..bb323928ec75 100644 --- a/cpan/IO-Compress/t/002any-transparent.t +++ b/cpan/IO-Compress/t/002any-transparent.t @@ -6,7 +6,7 @@ BEGIN { } use lib qw(t t/compress); - + use strict; use warnings; use bytes; @@ -38,7 +38,7 @@ EOM { title "AnyInflate with Non-compressed data (File $file)" ; - my $lex = new LexFile my $output; + my $lex = LexFile->new( my $output ); my $input ; if ($file) { @@ -52,12 +52,12 @@ EOM my $unc ; my $keep = $buffer ; - $unc = new IO::Uncompress::AnyInflate $input, -Transparent => 0 ; + $unc = IO::Uncompress::AnyInflate->new( $input, -Transparent => 0 ); ok ! $unc," no AnyInflate object when -Transparent => 0" ; is $buffer, $keep ; $buffer = $keep ; - $unc = new IO::Uncompress::AnyInflate \$buffer, -Transparent => 1 ; + $unc = IO::Uncompress::AnyInflate->new( \$buffer, -Transparent => 1 ); ok $unc, " AnyInflate object when -Transparent => 1" ; my $uncomp ; diff --git a/cpan/IO-Compress/t/004gziphdr.t b/cpan/IO-Compress/t/004gziphdr.t index 27a901354657..0ed4099ebe72 100644 --- a/cpan/IO-Compress/t/004gziphdr.t +++ b/cpan/IO-Compress/t/004gziphdr.t @@ -37,7 +37,7 @@ BEGIN { my $ThisOS_code = $Compress::Raw::Zlib::gzip_os_code; -my $lex = new LexFile my $name ; +my $lex = LexFile->new( my $name ); { title "Check Defaults"; @@ -63,12 +63,12 @@ my $lex = new LexFile my $name ; title "Check name can be different from filename" ; # Check Name can be different from filename # Comment and Extra can be set - # Can specify a zero Time + # Can specify a zero Time my $comment = "This is a Comment" ; my $extra = "A little something extra" ; my $aname = "a new name" ; - my $hdr = readHeaderInfo $name, + my $hdr = readHeaderInfo $name, -Strict => 0, -Name => $aname, -Comment => $comment, @@ -92,7 +92,7 @@ my $lex = new LexFile my $name ; # Check Time defaults to now # and that can have empty name, comment and extrafield my $before = time ; - my $hdr = readHeaderInfo $name, + my $hdr = readHeaderInfo $name, -TextFlag => 1, -Name => "", -Comment => "", @@ -121,7 +121,7 @@ my $lex = new LexFile my $name ; title "can have null extrafield" ; my $before = time ; - my $hdr = readHeaderInfo $name, + my $hdr = readHeaderInfo $name, -strict => 0, -Name => "a", -Comment => "b", @@ -144,7 +144,7 @@ my $lex = new LexFile my $name ; { title "can have undef name, comment, time and extrafield" ; - my $hdr = readHeaderInfo $name, + my $hdr = readHeaderInfo $name, -Name => undef, -Comment => undef, -ExtraField => undef, @@ -167,9 +167,9 @@ for my $value ( "0D", "0A", "0A0D", "0D0A", "0A0A", "0D0D") my $v = pack "h*", $value; my $comment = "my${v}comment$v"; - my $hdr = readHeaderInfo $name, + my $hdr = readHeaderInfo $name, Time => 0, - -TextFlag => 1, + -TextFlag => 1, -Name => "", -Comment => $comment, -ExtraField => ""; @@ -249,14 +249,14 @@ for my $value ( "0D", "0A", "0A0D", "0D0A", "0A0A", "0D0D") for my $code ( -1, undef, '', 'fred' ) { my $code_name = defined $code ? "'$code'" : "'undef'"; - eval { new IO::Compress::Gzip $name, -OS_Code => $code } ; + eval { IO::Compress::Gzip->new( $name, -OS_Code => $code ) } ; like $@, mkErr("^IO::Compress::Gzip: Parameter 'OS_Code' must be an unsigned int, got $code_name"), " Trap OS Code $code_name"; } for my $code ( qw( 256 ) ) { - eval { ok ! new IO::Compress::Gzip($name, OS_Code => $code) }; + eval { ok ! IO::Compress::Gzip->new($name, OS_Code => $code) }; like $@, mkErr("OS_Code must be between 0 and 255, got '$code'"), " Trap OS Code $code"; like $GzipError, "/OS_Code must be between 0 and 255, got '$code'/", @@ -285,34 +285,34 @@ for my $value ( "0D", "0A", "0A0D", "0D0A", "0A0A", "0D0D") [1, ['Xx' => '','AB' => 'Fred'] => [['Xx' => ''],['AB'=>'Fred']] ], [1, ['Xx' => '','Xx' => 'Fred'] => [['Xx' => ''],['Xx'=>'Fred']] ], [1, ['Xx' => '', - 'Xx' => 'Fred', + 'Xx' => 'Fred', 'Xx' => 'Fred'] => [['Xx' => ''],['Xx'=>'Fred'], ['Xx'=>'Fred']] ], [1, [ ['Xx' => 'a'], ['AB' => 'Fred'] ] => [['Xx' => 'a'],['AB'=>'Fred']] ], - [0, {'AB' => 'Fred', - 'Pq' => 'r', + [0, {'AB' => 'Fred', + 'Pq' => 'r', "\x01\x02" => "\x03"} => [['AB'=>'Fred'], - ['Pq'=>'r'], + ['Pq'=>'r'], ["\x01\x02"=>"\x03"]] ], - [1, ['AB' => 'z' x GZIP_FEXTRA_SUBFIELD_MAX_SIZE] => + [1, ['AB' => 'z' x GZIP_FEXTRA_SUBFIELD_MAX_SIZE] => [['AB'=>'z' x GZIP_FEXTRA_SUBFIELD_MAX_SIZE]] ], ); foreach my $test (@tests) { my ($order, $input, $result) = @$test ; - ok my $x = new IO::Compress::Gzip $name, + ok my $x = IO::Compress::Gzip->new( $name, -ExtraField => $input, - -HeaderCRC => 1 + -HeaderCRC => 1 ) or diag "GzipError is $GzipError" ; ; my $string = "abcd" ; ok $x->write($string) ; ok $x->close ; #is GZreadFile($name), $string ; - ok $x = new IO::Uncompress::Gunzip $name, + ok $x = IO::Uncompress::Gunzip->new( $name, #-Strict => 1, - -ParseExtra => 1 + -ParseExtra => 1 ) or diag "GunzipError is $GunzipError" ; ; my $hdr = $x->getHeaderInfo(); ok $hdr; @@ -331,7 +331,7 @@ for my $value ( "0D", "0A", "0A0D", "0D0A", "0A0A", "0D0D") eq_array $extra, $result; } else { eq_set $extra, $result; - } + } } } @@ -351,7 +351,7 @@ for my $value ( "0D", "0A", "0A0D", "0D0A", "0A0A", "0D0D") [ [ ['ab'=>'x'],{"a" => "fred"} ] => "Not list of lists"], [ [ ["aa"] ] => "SubField must have two parts"], [ [ ["aa", "b", "c"] ] => "SubField must have two parts"], - [ [ ["ab" => 'x' x (GZIP_FEXTRA_SUBFIELD_MAX_SIZE + 1) ] ] + [ [ ["ab" => 'x' x (GZIP_FEXTRA_SUBFIELD_MAX_SIZE + 1) ] ] => "SubField Data too long"], [ { 'abc', 1 } => "SubField ID not two chars long"], @@ -359,15 +359,15 @@ for my $value ( "0D", "0A", "0A0D", "0D0A", "0A0A", "0D0D") [ { "ab", \1 } => "SubField Data is a reference"], ); - + foreach my $test (@tests) { my ($input, $string) = @$test ; my $buffer ; my $x ; - eval { $x = new IO::Compress::Gzip \$buffer, -ExtraField => $input; }; - like $@, mkErr("$prefix$string"); - like $GzipError, "/$prefix$string/"; + eval { $x = IO::Compress::Gzip->new( \$buffer, -ExtraField => $input ); }; + like $@, mkErr("$prefix$string"); + like $GzipError, "/$prefix$string/"; ok ! $x ; } @@ -378,19 +378,19 @@ for my $value ( "0D", "0A", "0A0D", "0D0A", "0A0A", "0D0D") # Corrupt ExtraField my @tests = ( - ["Sub-field truncated", + ["Sub-field truncated", "Error with ExtraField Parameter: Truncated in FEXTRA Body Section", "Header Error: Truncated in FEXTRA Body Section", ['a', undef, undef] ], - ["Length of field incorrect", + ["Length of field incorrect", "Error with ExtraField Parameter: Truncated in FEXTRA Body Section", "Header Error: Truncated in FEXTRA Body Section", ["ab", 255, "abc"] ], - ["Length of 2nd field incorrect", + ["Length of 2nd field incorrect", "Error with ExtraField Parameter: Truncated in FEXTRA Body Section", "Header Error: Truncated in FEXTRA Body Section", ["ab", 3, "abc"], ["de", 7, "x"] ], - ["Length of 2nd field incorrect", + ["Length of 2nd field incorrect", "Error with ExtraField Parameter: SubField ID 2nd byte is 0x00", "Header Error: SubField ID 2nd byte is 0x00", ["a\x00", 3, "abc"], ["de", 7, "x"] ], @@ -418,31 +418,31 @@ for my $value ( "0D", "0A", "0A0D", "0D0A", "0A0A", "0D0D") my $buffer ; my $x ; - eval {$x = new IO::Compress::Gzip \$buffer, -ExtraField => $input, Strict => 1; }; - like $@, mkErr("$gzip_error"), " $name"; - like $GzipError, "/$gzip_error/", " $name"; + eval {$x = IO::Compress::Gzip->new( \$buffer, -ExtraField => $input, Strict => 1 ); }; + like $@, mkErr("$gzip_error"), " $name"; + like $GzipError, "/$gzip_error/", " $name"; ok ! $x, " IO::Compress::Gzip fails"; - like $GzipError, "/$gzip_error/", " $name"; + like $GzipError, "/$gzip_error/", " $name"; - foreach my $check (0, 1) + foreach my $check (0, 1) { - ok $x = new IO::Compress::Gzip \$buffer, - ExtraField => $input, - Strict => 0 + ok $x = IO::Compress::Gzip->new( \$buffer, + ExtraField => $input, + Strict => 0 ) or diag "GzipError is $GzipError" ; my $string = "abcd" ; $x->write($string) ; $x->close ; is anyUncompress(\$buffer), $string ; - $x = new IO::Uncompress::Gunzip \$buffer, + $x = IO::Uncompress::Gunzip->new( \$buffer, Strict => 0, Transparent => 0, - ParseExtra => $check; + ParseExtra => $check ); if ($check) { ok ! $x ; - like $GunzipError, "/^$gunzip_error/"; + like $GunzipError, "/^$gunzip_error/"; } else { ok $x ; @@ -456,13 +456,13 @@ for my $value ( "0D", "0A", "0A0D", "0D0A", "0A0A", "0D0D") { title 'Check Minimal'; - ok my $x = new IO::Compress::Gzip $name, -Minimal => 1; + ok my $x = IO::Compress::Gzip->new( $name, -Minimal => 1 ); my $string = "abcd" ; ok $x->write($string) ; ok $x->close ; #is GZreadFile($name), $string ; - ok $x = new IO::Uncompress::Gunzip $name ; + ok $x = IO::Uncompress::Gunzip->new( $name ); my $hdr = $x->getHeaderInfo(); ok $hdr; ok $hdr->{Time} == 0; @@ -482,11 +482,11 @@ for my $value ( "0D", "0A", "0A0D", "0D0A", "0A0A", "0D0D") title "Check Minimal + no compressed data"; # This is the smallest possible gzip file (20 bytes) - ok my $x = new IO::Compress::Gzip $name, -Minimal => 1; + ok my $x = IO::Compress::Gzip->new( $name, -Minimal => 1 ); isa_ok $x, "IO::Compress::Gzip"; ok $x->close, "closed" ; - ok $x = new IO::Uncompress::Gunzip $name, -Append => 0 ; + ok $x = IO::Uncompress::Gunzip->new( $name, -Append => 0 ); isa_ok $x, "IO::Uncompress::Gunzip"; my $data ; my $status = 1; @@ -528,7 +528,7 @@ some text EOM my $good = ''; - ok my $x = new IO::Compress::Gzip \$good, -HeaderCRC => 1 ; + ok my $x = IO::Compress::Gzip->new( \$good, -HeaderCRC => 1 ); ok $x->write($string) ; ok $x->close ; @@ -537,7 +537,7 @@ EOM my $buffer = $good ; substr($buffer, 0, 1) = 'x' ; - ok ! new IO::Uncompress::Gunzip \$buffer, -Transparent => 0 ; + ok ! IO::Uncompress::Gunzip->new( \$buffer, -Transparent => 0 ); ok $GunzipError =~ /Header Error: Bad Magic/; } @@ -546,7 +546,7 @@ EOM my $buffer = $good ; substr($buffer, 1, 1) = "\xFF" ; - ok ! new IO::Uncompress::Gunzip \$buffer, -Transparent => 0 ; + ok ! IO::Uncompress::Gunzip->new( \$buffer, -Transparent => 0 ); ok $GunzipError =~ /Header Error: Bad Magic/; #print "$GunzipError\n"; } @@ -556,7 +556,7 @@ EOM my $buffer = $good ; substr($buffer, 2, 1) = 'x' ; - ok ! new IO::Uncompress::Gunzip \$buffer, -Transparent => 0 ; + ok ! IO::Uncompress::Gunzip->new( \$buffer, -Transparent => 0 ); like $GunzipError, '/Header Error: Not Deflate \(CM is \d+\)/'; } @@ -565,7 +565,7 @@ EOM my $buffer = $good ; substr($buffer, 3, 1) = "\xff"; - ok ! new IO::Uncompress::Gunzip \$buffer, -Transparent => 0 ; + ok ! IO::Uncompress::Gunzip->new( \$buffer, -Transparent => 0 ); like $GunzipError, '/Header Error: Use of Reserved Bits in FLG field./'; } @@ -574,7 +574,7 @@ EOM my $buffer = $good ; substr($buffer, 10, 1) = chr((ord(substr($buffer, 10, 1)) + 1) & 0xFF); - ok ! new IO::Uncompress::Gunzip \$buffer, -Transparent => 0, Strict => 1 + ok ! IO::Uncompress::Gunzip->new( \$buffer, -Transparent => 0, Strict => 1 ) or print "# $GunzipError\n"; like $GunzipError, '/Header Error: CRC16 mismatch/' #or diag "buffer length " . length($buffer); @@ -587,10 +587,10 @@ EOM my $x ; my $store = "x" x GZIP_FEXTRA_MAX_SIZE ; { - my $z = new IO::Compress::Gzip(\$x, ExtraField => $store, Strict => 0) ; + my $z = IO::Compress::Gzip->new(\$x, ExtraField => $store, Strict => 0) ; ok $z, "Created IO::Compress::Gzip object" ; } - my $gunz = new IO::Uncompress::Gunzip \$x, Strict => 0; + my $gunz = IO::Uncompress::Gunzip->new( \$x, Strict => 0 ); ok $gunz, "Created IO::Uncompress::Gunzip object" ; my $hdr = $gunz->getHeaderInfo(); ok $hdr; @@ -601,7 +601,7 @@ EOM { title "Header Corruption - ExtraField too big"; my $x; - eval { new IO::Compress::Gzip(\$x, -ExtraField => "x" x (GZIP_FEXTRA_MAX_SIZE + 1)) ;}; + eval { IO::Compress::Gzip->new(\$x, -ExtraField => "x" x (GZIP_FEXTRA_MAX_SIZE + 1)) ;}; like $@, mkErr('Error with ExtraField Parameter: Too Large'); like $GzipError, '/Error with ExtraField Parameter: Too Large/'; } @@ -610,24 +610,24 @@ EOM title "Header Corruption - Create Name with Illegal Chars"; my $x; - eval { new IO::Compress::Gzip \$x, -Name => "fred\x02" }; + eval { IO::Compress::Gzip->new( \$x, -Name => "fred\x02" ) }; like $@, mkErr('Non ISO 8859-1 Character found in Name'); like $GzipError, '/Non ISO 8859-1 Character found in Name/'; - ok my $gz = new IO::Compress::Gzip \$x, + ok my $gz = IO::Compress::Gzip->new( \$x, -Strict => 0, - -Name => "fred\x02" ; - ok $gz->close(); + -Name => "fred\x02" ); + ok $gz->close(); - ok ! new IO::Uncompress::Gunzip \$x, + ok ! IO::Uncompress::Gunzip->new( \$x, -Transparent => 0, - -Strict => 1; + -Strict => 1 ); - like $GunzipError, '/Header Error: Non ISO 8859-1 Character found in Name/'; - ok my $gunzip = new IO::Uncompress::Gunzip \$x, - -Strict => 0; + like $GunzipError, '/Header Error: Non ISO 8859-1 Character found in Name/'; + ok my $gunzip = IO::Uncompress::Gunzip->new( \$x, + -Strict => 0 ); - my $hdr = $gunzip->getHeaderInfo() ; + my $hdr = $gunzip->getHeaderInfo() ; is $hdr->{Name}, "fred\x02"; @@ -636,47 +636,47 @@ EOM { title "Header Corruption - Null Chars in Name"; my $x; - eval { new IO::Compress::Gzip \$x, -Name => "\x00" }; + eval { IO::Compress::Gzip->new( \$x, -Name => "\x00" ) }; like $@, mkErr('Null Character found in Name'); like $GzipError, '/Null Character found in Name/'; - eval { new IO::Compress::Gzip \$x, -Name => "abc\x00" }; + eval { IO::Compress::Gzip->new( \$x, -Name => "abc\x00" ) }; like $@, mkErr('Null Character found in Name'); like $GzipError, '/Null Character found in Name/'; - ok my $gz = new IO::Compress::Gzip \$x, + ok my $gz = IO::Compress::Gzip->new( \$x, -Strict => 0, - -Name => "abc\x00de" ; - ok $gz->close() ; - ok my $gunzip = new IO::Uncompress::Gunzip \$x, - -Strict => 0; + -Name => "abc\x00de" ); + ok $gz->close() ; + ok my $gunzip = IO::Uncompress::Gunzip->new( \$x, + -Strict => 0 ); - my $hdr = $gunzip->getHeaderInfo() ; + my $hdr = $gunzip->getHeaderInfo() ; is $hdr->{Name}, "abc"; - + } { title "Header Corruption - Create Comment with Illegal Chars"; my $x; - eval { new IO::Compress::Gzip \$x, -Comment => "fred\x02" }; + eval { IO::Compress::Gzip->new( \$x, -Comment => "fred\x02" ) }; like $@, mkErr('Non ISO 8859-1 Character found in Comment'); like $GzipError, '/Non ISO 8859-1 Character found in Comment/'; - ok my $gz = new IO::Compress::Gzip \$x, + ok my $gz = IO::Compress::Gzip->new( \$x, -Strict => 0, - -Comment => "fred\x02" ; - ok $gz->close(); + -Comment => "fred\x02" ); + ok $gz->close(); - ok ! new IO::Uncompress::Gunzip \$x, Strict => 1, - -Transparent => 0; + ok ! IO::Uncompress::Gunzip->new( \$x, Strict => 1, + -Transparent => 0 ); like $GunzipError, '/Header Error: Non ISO 8859-1 Character found in Comment/'; - ok my $gunzip = new IO::Uncompress::Gunzip \$x, Strict => 0; + ok my $gunzip = IO::Uncompress::Gunzip->new( \$x, Strict => 0 ); - my $hdr = $gunzip->getHeaderInfo() ; + my $hdr = $gunzip->getHeaderInfo() ; is $hdr->{Comment}, "fred\x02"; @@ -685,25 +685,25 @@ EOM { title "Header Corruption - Null Char in Comment"; my $x; - eval { new IO::Compress::Gzip \$x, -Comment => "\x00" }; + eval { IO::Compress::Gzip->new( \$x, -Comment => "\x00" ) }; like $@, mkErr('Null Character found in Comment'); like $GzipError, '/Null Character found in Comment/'; - eval { new IO::Compress::Gzip \$x, -Comment => "abc\x00" } ; + eval { IO::Compress::Gzip->new( \$x, -Comment => "abc\x00" ) } ; like $@, mkErr('Null Character found in Comment'); like $GzipError, '/Null Character found in Comment/'; - ok my $gz = new IO::Compress::Gzip \$x, + ok my $gz = IO::Compress::Gzip->new( \$x, -Strict => 0, - -Comment => "abc\x00de" ; - ok $gz->close() ; - ok my $gunzip = new IO::Uncompress::Gunzip \$x, - -Strict => 0; + -Comment => "abc\x00de" ); + ok $gz->close() ; + ok my $gunzip = IO::Uncompress::Gunzip->new( \$x, + -Strict => 0 ); - my $hdr = $gunzip->getHeaderInfo() ; + my $hdr = $gunzip->getHeaderInfo() ; is $hdr->{Comment}, "abc"; - + } @@ -715,18 +715,18 @@ some text EOM my $truncated ; - ok my $x = new IO::Compress::Gzip \$truncated, -HeaderCRC => 1, Strict => 0, - -ExtraField => "hello" x 10 ; + ok my $x = IO::Compress::Gzip->new( \$truncated, -HeaderCRC => 1, Strict => 0, + -ExtraField => "hello" x 10 ); ok $x->write($string) ; ok $x->close ; substr($truncated, $index) = '' ; - #my $lex = new LexFile my $name ; + #my $lex = LexFile->new( my $name ); #writeFile($name, $truncated) ; - #my $g = new IO::Uncompress::Gunzip $name, -Transparent => 0; - my $g = new IO::Uncompress::Gunzip \$truncated, -Transparent => 0; - ok ! $g + #my $g = IO::Uncompress::Gunzip->new( $name, -Transparent => 0 ); + my $g = IO::Uncompress::Gunzip->new( \$truncated, -Transparent => 0 ); + ok ! $g or print "# $g\n" ; like($GunzipError, '/^Header Error: Truncated in FEXTRA/'); @@ -744,14 +744,14 @@ some text EOM my $truncated ; - ok my $x = new IO::Compress::Gzip \$truncated, -Name => $Name; + ok my $x = IO::Compress::Gzip->new( \$truncated, -Name => $Name ); ok $x->write($string) ; ok $x->close ; substr($truncated, $index) = '' ; - my $g = new IO::Uncompress::Gunzip \$truncated, -Transparent => 0; - ok ! $g + my $g = IO::Uncompress::Gunzip->new( \$truncated, -Transparent => 0 ); + ok ! $g or print "# $g\n" ; like $GunzipError, '/^Header Error: Truncated in FNAME Section/'; @@ -767,17 +767,17 @@ some text EOM my $truncated ; - ok my $x = new IO::Compress::Gzip \$truncated, -Comment => $Comment; + ok my $x = IO::Compress::Gzip->new( \$truncated, -Comment => $Comment ); ok $x->write($string) ; ok $x->close ; substr($truncated, $index) = '' ; - #my $lex = new LexFile my $name ; + #my $lex = LexFile->new( my $name ); #writeFile($name, $truncated) ; - #my $g = new IO::Uncompress::Gunzip $name, -Transparent => 0; - my $g = new IO::Uncompress::Gunzip \$truncated, -Transparent => 0; - ok ! $g + #my $g = IO::Uncompress::Gunzip->new( $name, -Transparent => 0 ); + my $g = IO::Uncompress::Gunzip->new( \$truncated, -Transparent => 0 ); + ok ! $g or print "# $g\n" ; like $GunzipError, '/^Header Error: Truncated in FCOMMENT Section/'; @@ -792,17 +792,16 @@ some text EOM my $truncated ; - ok my $x = new IO::Compress::Gzip \$truncated, -HeaderCRC => 1; + ok my $x = IO::Compress::Gzip->new( \$truncated, -HeaderCRC => 1 ); ok $x->write($string) ; ok $x->close ; substr($truncated, $index) = '' ; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); writeFile($name, $truncated) ; - my $g = new IO::Uncompress::Gunzip $name, -Transparent => 0; - #my $g = new IO::Uncompress::Gunzip \$truncated, -Transparent => 0; - ok ! $g + my $g = IO::Uncompress::Gunzip->new( $name, -Transparent => 0 ); + ok ! $g or print "# $g\n" ; like $GunzipError, '/^Header Error: Truncated in FHCRC Section/'; @@ -820,19 +819,19 @@ EOM my $good ; { - ok my $x = new IO::Compress::Gzip \$good ; + ok my $x = IO::Compress::Gzip->new( \$good ); ok $x->write($string) ; ok $x->close ; } writeFile($name, $good) ; - ok my $gunz = new IO::Uncompress::Gunzip $name, + ok my $gunz = IO::Uncompress::Gunzip->new( $name, -Append => 1, - -Strict => 1; + -Strict => 1 ); my $uncomp ; 1 while $gunz->read($uncomp) > 0 ; ok $gunz->close() ; - ok $uncomp eq $string + ok $uncomp eq $string or print "# got [$uncomp] wanted [$string]\n";; foreach my $trim (-8 .. -1) @@ -848,7 +847,7 @@ EOM foreach my $strict (0, 1) { - ok my $gunz = new IO::Uncompress::Gunzip $name, Append => 1, -Strict => $strict ; + ok my $gunz = IO::Uncompress::Gunzip->new( $name, Append => 1, -Strict => $strict ); my $uncomp ; my $status = 1; $status = $gunz->read($uncomp) while $status > 0; @@ -860,7 +859,7 @@ EOM else { is $status, 0, "status 0"; - ok ! $GunzipError, "no error" + ok ! $GunzipError, "no error" or diag "$GunzipError"; my $expected = substr($buffer, - $got); is $gunz->trailingData(), $expected_trailing, "trailing data"; @@ -881,9 +880,9 @@ EOM foreach my $strict (0, 1) { - ok my $gunz = new IO::Uncompress::Gunzip $name, + ok my $gunz = IO::Uncompress::Gunzip->new( $name, Append => 1, - -Strict => $strict ; + -Strict => $strict ); my $uncomp ; my $status = 1; $status = $gunz->read($uncomp) while $status > 0; @@ -916,9 +915,9 @@ EOM foreach my $strict (0, 1) { - ok my $gunz = new IO::Uncompress::Gunzip $name, + ok my $gunz = IO::Uncompress::Gunzip->new( $name, -Append => 1, - -Strict => $strict ; + -Strict => $strict ); my $uncomp ; my $status = 1; $status = $gunz->read($uncomp) while $status > 0; @@ -951,9 +950,9 @@ EOM foreach my $strict (0, 1) { - ok my $gunz = new IO::Uncompress::Gunzip $name, + ok my $gunz = IO::Uncompress::Gunzip->new( $name, -Append => 1, - -Strict => $strict ; + -Strict => $strict ); my $uncomp ; my $status = 1; $status = $gunz->read($uncomp) while $status > 0; @@ -980,11 +979,11 @@ EOM 'SubField ID not two chars long' ; my $buffer ; my $x ; - eval { $x = new IO::Compress::Gzip \$buffer, - -ExtraField => [ at => 'mouse', bad => 'dog'] ; + eval { $x = IO::Compress::Gzip->new( \$buffer, + -ExtraField => [ at => 'mouse', bad => 'dog'] ); }; - like $@, mkErr("$error"); - like $GzipError, "/$error/"; + like $@, mkErr("$error"); + like $GzipError, "/$error/"; ok ! $x ; } } diff --git a/cpan/IO-Compress/t/005defhdr.t b/cpan/IO-Compress/t/005defhdr.t index 28059ce2d11b..8d4d16310fcb 100644 --- a/cpan/IO-Compress/t/005defhdr.t +++ b/cpan/IO-Compress/t/005defhdr.t @@ -37,12 +37,12 @@ sub ReadHeaderInfo my %opts = @_ ; my $buffer ; - ok my $def = new IO::Compress::Deflate \$buffer, %opts ; + ok my $def = IO::Compress::Deflate->new( \$buffer, %opts ); is $def->write($string), length($string), "write" ; ok $def->close, "closed" ; #print "ReadHeaderInfo\n"; hexDump(\$buffer); - ok my $inf = new IO::Uncompress::Inflate \$buffer, Append => 1 ; + ok my $inf = IO::Uncompress::Inflate->new( \$buffer, Append => 1 ); my $uncomp = ""; #ok $inf->read($uncomp) ; my $actual = 0 ; @@ -67,12 +67,12 @@ sub ReadHeaderInfoZlib my %opts = @_ ; my $buffer ; - ok my $def = new Compress::Raw::Zlib::Deflate AppendOutput => 1, %opts ; + ok my $def = Compress::Raw::Zlib::Deflate->new( AppendOutput => 1, %opts ); cmp_ok $def->deflate($string, $buffer), '==', Z_OK; cmp_ok $def->flush($buffer), '==', Z_OK; #print "ReadHeaderInfoZlib\n"; hexDump(\$buffer); - - ok my $inf = new IO::Uncompress::Inflate \$buffer, Append => 1 ; + + ok my $inf = IO::Uncompress::Inflate->new( \$buffer, Append => 1 ); my $uncomp ; #ok $inf->read($uncomp) ; my $actual = 0 ; @@ -94,7 +94,7 @@ sub ReadHeaderInfoZlib sub printHeaderInfo { my $buffer = shift ; - my $inf = new IO::Uncompress::Inflate \$buffer ; + my $inf = IO::Uncompress::Inflate->new( \$buffer ); my $hdr = $inf->getHeaderInfo(); no warnings 'uninitialized' ; @@ -107,7 +107,7 @@ sub printHeaderInfo # Check the Deflate Header Parameters #======================================== -#my $lex = new LexFile my $name ; +#my $lex = LexFile->new( my $name ); { title "Check default header settings" ; @@ -210,7 +210,7 @@ some text EOM my $good ; - ok my $x = new IO::Compress::Deflate \$good ; + ok my $x = IO::Compress::Deflate->new( \$good ); ok $x->write($string) ; ok $x->close ; @@ -219,7 +219,7 @@ EOM my $buffer = $good ; substr($buffer, 0, 1) = "\x00" ; - ok ! new IO::Uncompress::Inflate \$buffer, -Transparent => 0 ; + ok ! IO::Uncompress::Inflate->new( \$buffer, -Transparent => 0 ); like $IO::Uncompress::Inflate::InflateError, '/Header Error: CRC mismatch/', "CRC mismatch"; } @@ -229,7 +229,7 @@ EOM my $buffer = $good ; substr($buffer, 1, 1) = "\x00" ; - ok ! new IO::Uncompress::Inflate \$buffer, -Transparent => 0 ; + ok ! IO::Uncompress::Inflate->new( \$buffer, -Transparent => 0 ); like $IO::Uncompress::Inflate::InflateError, '/Header Error: CRC mismatch/', "CRC mismatch"; } @@ -260,8 +260,8 @@ EOM substr($buffer, 0, 2) = $header; - my $un = new IO::Uncompress::Inflate \$buffer, -Transparent => 0 ; - ok ! new IO::Uncompress::Inflate \$buffer, -Transparent => 0 ; + my $un = IO::Uncompress::Inflate->new( \$buffer, -Transparent => 0 ); + ok ! IO::Uncompress::Inflate->new( \$buffer, -Transparent => 0 ); like $IO::Uncompress::Inflate::InflateError, '/Header Error: Not Deflate \(CM is 3\)/', " Not Deflate"; } @@ -277,7 +277,7 @@ EOM $string = $string x 1000; my $good ; - ok my $x = new IO::Compress::Deflate \$good ; + ok my $x = IO::Compress::Deflate->new( \$good ); ok $x->write($string) ; ok $x->close ; @@ -287,7 +287,7 @@ EOM foreach my $s (0, 1) { title "Trailer Corruption - Trailer truncated to $got bytes, strict $s" ; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $buffer = $good ; my $expected_trailing = substr($good, -4, 4) ; substr($expected_trailing, $trim) = ''; @@ -295,7 +295,7 @@ EOM substr($buffer, $trim) = ''; writeFile($name, $buffer) ; - ok my $gunz = new IO::Uncompress::Inflate $name, Append => 1, Strict => $s; + ok my $gunz = IO::Uncompress::Inflate->new( $name, Append => 1, Strict => $s ); my $uncomp ; if ($s) { @@ -322,10 +322,10 @@ EOM my $buffer = $good ; my $crc = unpack("N", substr($buffer, -4, 4)); substr($buffer, -4, 4) = pack('N', $crc+1); - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); writeFile($name, $buffer) ; - ok my $gunz = new IO::Uncompress::Inflate $name, Append => 1, Strict => 1; + ok my $gunz = IO::Uncompress::Inflate->new( $name, Append => 1, Strict => 1 ); my $uncomp ; my $status ; 1 while ($status = $gunz->read($uncomp)) > 0; @@ -343,10 +343,10 @@ EOM my $buffer = $good ; my $crc = unpack("N", substr($buffer, -4, 4)); substr($buffer, -4, 4) = pack('N', $crc+1); - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); writeFile($name, $buffer) ; - ok my $gunz = new IO::Uncompress::Inflate $name, Append => 1, Strict => 0; + ok my $gunz = IO::Uncompress::Inflate->new( $name, Append => 1, Strict => 0 ); my $uncomp ; my $status ; 1 while ($status = $gunz->read($uncomp)) > 0; diff --git a/cpan/IO-Compress/t/006zip.t b/cpan/IO-Compress/t/006zip.t index cfc53d79ab21..830009127a29 100644 --- a/cpan/IO-Compress/t/006zip.t +++ b/cpan/IO-Compress/t/006zip.t @@ -24,11 +24,11 @@ BEGIN { use_ok('IO::Compress::Zip', qw(:all)) ; use_ok('IO::Uncompress::Unzip', qw(unzip $UnzipError)) ; - eval { - require IO::Compress::Bzip2 ; - import IO::Compress::Bzip2 2.010 ; - require IO::Uncompress::Bunzip2 ; - import IO::Uncompress::Bunzip2 2.010 ; + eval { + require IO::Compress::Bzip2 ; + IO::Compress::Bzip2->import( 2.010 ); + require IO::Uncompress::Bunzip2 ; + IO::Uncompress::Bunzip2->import( 2.010 ); } ; } @@ -38,7 +38,7 @@ sub getContent { my $filename = shift; - my $u = new IO::Uncompress::Unzip $filename, Append => 1, @_ + my $u = IO::Uncompress::Unzip->new( $filename, Append => 1, @_ ) or die "Cannot open $filename: $UnzipError"; isa_ok $u, "IO::Uncompress::Unzip"; @@ -59,7 +59,7 @@ sub getContent } die "Error processing $filename: $status $!\n" - if $status < 0 ; + if $status < 0 ; return @content; } @@ -69,7 +69,7 @@ sub getContent { title "Create a simple zip - All Deflate"; - my $lex = new LexFile my $file1; + my $lex = LexFile->new( my $file1 ); my @content = ( 'hello', @@ -77,16 +77,16 @@ sub getContent 'goodbye ', ); - my $zip = new IO::Compress::Zip $file1, - Name => "one", Method => ZIP_CM_DEFLATE, Stream => 0; + my $zip = IO::Compress::Zip->new( $file1, + Name => "one", Method => ZIP_CM_DEFLATE, Stream => 0 ); isa_ok $zip, "IO::Compress::Zip"; - is $zip->write($content[0]), length($content[0]), "write"; + is $zip->write($content[0]), length($content[0]), "write"; $zip->newStream(Name=> "two", Method => ZIP_CM_DEFLATE); - is $zip->write($content[1]), length($content[1]), "write"; + is $zip->write($content[1]), length($content[1]), "write"; $zip->newStream(Name=> "three", Method => ZIP_CM_DEFLATE); - is $zip->write($content[2]), length($content[2]), "write"; - ok $zip->close(), "closed"; + is $zip->write($content[2]), length($content[2]), "write"; + ok $zip->close(), "closed"; my @got = getContent($file1); @@ -102,7 +102,7 @@ SKIP: skip "IO::Compress::Bzip2 not available", 9 unless defined $IO::Compress::Bzip2::VERSION; - my $lex = new LexFile my $file1; + my $lex = LexFile->new( my $file1 ); my @content = ( 'hello', @@ -110,16 +110,16 @@ SKIP: 'goodbye ', ); - my $zip = new IO::Compress::Zip $file1, - Name => "one", Method => ZIP_CM_BZIP2, Stream => 0; + my $zip = IO::Compress::Zip->new( $file1, + Name => "one", Method => ZIP_CM_BZIP2, Stream => 0 ); isa_ok $zip, "IO::Compress::Zip"; - is $zip->write($content[0]), length($content[0]), "write"; + is $zip->write($content[0]), length($content[0]), "write"; $zip->newStream(Name=> "two", Method => ZIP_CM_BZIP2); - is $zip->write($content[1]), length($content[1]), "write"; + is $zip->write($content[1]), length($content[1]), "write"; $zip->newStream(Name=> "three", Method => ZIP_CM_BZIP2); - is $zip->write($content[2]), length($content[2]), "write"; - ok $zip->close(), "closed"; + is $zip->write($content[2]), length($content[2]), "write"; + ok $zip->close(), "closed"; my @got = getContent($file1); @@ -135,7 +135,7 @@ SKIP: skip "IO::Compress::Bzip2 not available", 9 unless $IO::Compress::Bzip2::VERSION; - my $lex = new LexFile my $file1; + my $lex = LexFile->new( my $file1 ); my @content = ( 'hello', @@ -143,16 +143,16 @@ SKIP: 'goodbye ', ); - my $zip = new IO::Compress::Zip $file1, - Name => "one", Method => ZIP_CM_DEFLATE, Stream => 0; + my $zip = IO::Compress::Zip->new( $file1, + Name => "one", Method => ZIP_CM_DEFLATE, Stream => 0 ); isa_ok $zip, "IO::Compress::Zip"; - is $zip->write($content[0]), length($content[0]), "write"; + is $zip->write($content[0]), length($content[0]), "write"; $zip->newStream(Name=> "two", Method => ZIP_CM_BZIP2); - is $zip->write($content[1]), length($content[1]), "write"; + is $zip->write($content[1]), length($content[1]), "write"; $zip->newStream(Name=> "three", Method => ZIP_CM_DEFLATE); - is $zip->write($content[2]), length($content[2]), "write"; - ok $zip->close(), "closed"; + is $zip->write($content[2]), length($content[2]), "write"; + ok $zip->close(), "closed"; my @got = getContent($file1); @@ -164,7 +164,7 @@ SKIP: { title "Create a simple zip - All STORE"; - my $lex = new LexFile my $file1; + my $lex = LexFile->new( my $file1 ); my @content = ( 'hello', @@ -172,16 +172,16 @@ SKIP: 'goodbye ', ); - my $zip = new IO::Compress::Zip $file1, - Name => "one", Method => ZIP_CM_STORE, Stream => 0; + my $zip = IO::Compress::Zip->new( $file1, + Name => "one", Method => ZIP_CM_STORE, Stream => 0 ); isa_ok $zip, "IO::Compress::Zip"; - is $zip->write($content[0]), length($content[0]), "write"; + is $zip->write($content[0]), length($content[0]), "write"; $zip->newStream(Name=> "two", Method => ZIP_CM_STORE); - is $zip->write($content[1]), length($content[1]), "write"; + is $zip->write($content[1]), length($content[1]), "write"; $zip->newStream(Name=> "three", Method => ZIP_CM_STORE); - is $zip->write($content[2]), length($content[2]), "write"; - ok $zip->close(), "closed"; + is $zip->write($content[2]), length($content[2]), "write"; + ok $zip->close(), "closed"; my @got = getContent($file1); @@ -193,24 +193,24 @@ SKIP: { title "Create a simple zip - Deflate + STORE"; - my $lex = new LexFile my $file1; + my $lex = LexFile->new( my $file1 ); my @content = qw( - hello + hello and - goodbye + goodbye ); - my $zip = new IO::Compress::Zip $file1, - Name => "one", Method => ZIP_CM_DEFLATE, Stream => 0; + my $zip = IO::Compress::Zip->new( $file1, + Name => "one", Method => ZIP_CM_DEFLATE, Stream => 0 ); isa_ok $zip, "IO::Compress::Zip"; - is $zip->write($content[0]), length($content[0]), "write"; + is $zip->write($content[0]), length($content[0]), "write"; $zip->newStream(Name=> "two", Method => ZIP_CM_STORE); - is $zip->write($content[1]), length($content[1]), "write"; + is $zip->write($content[1]), length($content[1]), "write"; $zip->newStream(Name=> "three", Method => ZIP_CM_DEFLATE); - is $zip->write($content[2]), length($content[2]), "write"; - ok $zip->close(), "closed"; + is $zip->write($content[2]), length($content[2]), "write"; + ok $zip->close(), "closed"; my @got = getContent($file1); @@ -222,7 +222,7 @@ SKIP: { title "Create a simple zip - Deflate + zero length STORE"; - my $lex = new LexFile my $file1; + my $lex = LexFile->new( my $file1 ); my @content = ( 'hello ', @@ -230,16 +230,16 @@ SKIP: 'goodbye ', ); - my $zip = new IO::Compress::Zip $file1, - Name => "one", Method => ZIP_CM_DEFLATE, Stream => 0; + my $zip = IO::Compress::Zip->new( $file1, + Name => "one", Method => ZIP_CM_DEFLATE, Stream => 0 ); isa_ok $zip, "IO::Compress::Zip"; - is $zip->write($content[0]), length($content[0]), "write"; + is $zip->write($content[0]), length($content[0]), "write"; $zip->newStream(Name=> "two", Method => ZIP_CM_STORE); - is $zip->write($content[1]), length($content[1]), "write"; + is $zip->write($content[1]), length($content[1]), "write"; $zip->newStream(Name=> "three", Method => ZIP_CM_DEFLATE); - is $zip->write($content[2]), length($content[2]), "write"; - ok $zip->close(), "closed"; + is $zip->write($content[2]), length($content[2]), "write"; + ok $zip->close(), "closed"; my @got = getContent($file1); @@ -251,7 +251,7 @@ SKIP: { title "RT #72548"; - my $lex = new LexFile my $file1; + my $lex = LexFile->new( my $file1 ); my $blockSize = 1024 * 16; @@ -260,16 +260,16 @@ SKIP: "x" x ($blockSize + 1) ); - my $zip = new IO::Compress::Zip $file1, - Name => "one", Method => ZIP_CM_STORE, Stream => 0; + my $zip = IO::Compress::Zip->new( $file1, + Name => "one", Method => ZIP_CM_STORE, Stream => 0 ); isa_ok $zip, "IO::Compress::Zip"; - is $zip->write($content[0]), length($content[0]), "write"; + is $zip->write($content[0]), length($content[0]), "write"; $zip->newStream(Name=> "two", Method => ZIP_CM_STORE); - is $zip->write($content[1]), length($content[1]), "write"; + is $zip->write($content[1]), length($content[1]), "write"; - ok $zip->close(), "closed"; + ok $zip->close(), "closed"; my @got = getContent($file1, BlockSize => $blockSize); @@ -280,15 +280,15 @@ SKIP: { title "Zip file with a single zero-length file"; - my $lex = new LexFile my $file1; + my $lex = LexFile->new( my $file1 ); - my $zip = new IO::Compress::Zip $file1, - Name => "one", Method => ZIP_CM_STORE, Stream => 0; + my $zip = IO::Compress::Zip->new( $file1, + Name => "one", Method => ZIP_CM_STORE, Stream => 0 ); isa_ok $zip, "IO::Compress::Zip"; $zip->newStream(Name=> "two", Method => ZIP_CM_STORE); - ok $zip->close(), "closed"; + ok $zip->close(), "closed"; my @got = getContent($file1); @@ -307,13 +307,13 @@ for my $method (ZIP_CM_DEFLATE, ZIP_CM_STORE, ZIP_CM_BZIP2) my $content = "a single line\n"; my $zip ; - my $status = zip \$content => \$zip, - Method => $method, - Stream => 0, + my $status = zip \$content => \$zip, + Method => $method, + Stream => 0, Name => "123"; is $status, 1, " Created a zip file"; - my $u = new IO::Uncompress::Unzip \$zip; + my $u = IO::Uncompress::Unzip->new( \$zip ); isa_ok $u, "IO::Uncompress::Unzip"; is $u->getline, $content, " Read first line ok"; @@ -324,39 +324,39 @@ for my $method (ZIP_CM_DEFLATE, ZIP_CM_STORE, ZIP_CM_BZIP2) { title "isMethodAvailable" ; - + ok IO::Compress::Zip::isMethodAvailable(ZIP_CM_STORE), "ZIP_CM_STORE available"; ok IO::Compress::Zip::isMethodAvailable(ZIP_CM_DEFLATE), "ZIP_CM_DEFLATE available"; #ok IO::Compress::Zip::isMethodAvailable(ZIP_CM_STORE), "ZIP_CM_STORE available"; - - ok ! IO::Compress::Zip::isMethodAvailable(999), "999 not available"; + + ok ! IO::Compress::Zip::isMethodAvailable(999), "999 not available"; } { title "Member & Comment 0"; - my $lex = new LexFile my $file1; + my $lex = LexFile->new( my $file1 ); my $content = 'hello' ; - - my $zip = new IO::Compress::Zip $file1, - Name => "0", Comment => "0" ; + + my $zip = IO::Compress::Zip->new( $file1, + Name => "0", Comment => "0" ); isa_ok $zip, "IO::Compress::Zip"; - is $zip->write($content), length($content), "write"; + is $zip->write($content), length($content), "write"; - ok $zip->close(), "closed"; + ok $zip->close(), "closed"; - my $u = new IO::Uncompress::Unzip $file1, Append => 1, @_ + my $u = IO::Uncompress::Unzip->new( $file1, Append => 1, @_ ) or die "Cannot open $file1: $UnzipError"; isa_ok $u, "IO::Uncompress::Unzip"; my $name = $u->getHeaderInfo()->{Name}; - + is $u->getHeaderInfo()->{Name}, "0", "Name is '0'"; } @@ -365,12 +365,12 @@ for my $method (ZIP_CM_DEFLATE, ZIP_CM_STORE, ZIP_CM_BZIP2) title "nexStream regression"; # https://github.com/pmqs/IO-Compress/issues/3 - my $lex = new LexFile my $file1; + my $lex = LexFile->new( my $file1 ); my $content1 = qq["organisation_path","collection_occasion_key","episode_key"\n] ; - - my $zip = new IO::Compress::Zip $file1, - Name => "one"; + + my $zip = IO::Compress::Zip->new( $file1, + Name => "one" ); isa_ok $zip, "IO::Compress::Zip"; print $zip $content1; @@ -384,16 +384,16 @@ for my $method (ZIP_CM_DEFLATE, ZIP_CM_STORE, ZIP_CM_BZIP2) EOM print $zip $content2; - ok $zip->close(), "closed"; + ok $zip->close(), "closed"; - my $u = new IO::Uncompress::Unzip $file1, Append => 1, @_ + my $u = IO::Uncompress::Unzip->new( $file1, Append => 1, @_ ) or die "Cannot open $file1: $UnzipError"; isa_ok $u, "IO::Uncompress::Unzip"; my $name = $u->getHeaderInfo()->{Name}; - + is $u->getHeaderInfo()->{Name}, "one", "Name is 'one'"; ok $u->nextStream(), "nextStream OK"; diff --git a/cpan/IO-Compress/t/011-streamzip.t b/cpan/IO-Compress/t/011-streamzip.t index df3fbfb0fd84..181371a7c83e 100644 --- a/cpan/IO-Compress/t/011-streamzip.t +++ b/cpan/IO-Compress/t/011-streamzip.t @@ -15,11 +15,11 @@ use Test::More ; use CompTestUtils; use IO::Uncompress::Unzip 'unzip' ; -BEGIN -{ +BEGIN +{ plan(skip_all => "Needs Perl 5.005 or better - you have Perl $]" ) if $] < 5.005 ; - + # use Test::NoWarnings, if available my $extra = 0 ; $extra = 1 @@ -35,7 +35,7 @@ $Inc = '"-MExtUtils::testlib"' my $Perl = ($ENV{'FULLPERL'} or $^X or 'perl') ; $Perl = qq["$Perl"] if $^O eq 'MSWin32' ; - + $Perl = "$Perl $Inc -w" ; #$Perl .= " -Mblib " ; my $binDir = $ENV{PERL_CORE} ? "../ext/IO-Compress/bin/" @@ -43,7 +43,7 @@ my $binDir = $ENV{PERL_CORE} ? "../ext/IO-Compress/bin/" my $hello1 = <new( my $stderr ); sub check @@ -62,7 +62,7 @@ sub check my $command = shift ; my $expected = shift ; - my $lex = new LexFile my $stderr ; + my $lex = LexFile->new( my $stderr ); my $cmd = "$command 2>$stderr"; my $stdout = `$cmd` ; @@ -93,7 +93,7 @@ sub check title "streamzip" ; my ($infile, $outfile); - my $lex = new LexFile $infile, $outfile ; + my $lex = LexFile->new( $infile, $outfile ); writeFile($infile, $hello1) ; check "$Perl ${binDir}/streamzip <$infile >$outfile"; @@ -107,7 +107,7 @@ sub check title "streamzip" ; my ($infile, $outfile); - my $lex = new LexFile $infile, $outfile ; + my $lex = LexFile->new( $infile, $outfile ); writeFile($infile, $hello1) ; check "$Perl ${binDir}/streamzip -zipfile=$outfile <$infile"; diff --git a/cpan/IO-Compress/t/01misc.t b/cpan/IO-Compress/t/01misc.t index 7e0d6fd45614..36373db6300a 100644 --- a/cpan/IO-Compress/t/01misc.t +++ b/cpan/IO-Compress/t/01misc.t @@ -10,7 +10,7 @@ use strict; use warnings; use bytes; -use Test::More ; +use Test::More ; use CompTestUtils; BEGIN { @@ -36,35 +36,35 @@ EOM sub My::testParseParameters() { eval { ParseParameters(1, {}, 1) ; }; - like $@, mkErr(': Expected even number of parameters, got 1'), + like $@, mkErr(': Expected even number of parameters, got 1'), "Trap odd number of params"; eval { ParseParameters(1, {}, undef) ; }; - like $@, mkErr(': Expected even number of parameters, got 1'), + like $@, mkErr(': Expected even number of parameters, got 1'), "Trap odd number of params"; eval { ParseParameters(1, {}, []) ; }; - like $@, mkErr(': Expected even number of parameters, got 1'), + like $@, mkErr(': Expected even number of parameters, got 1'), "Trap odd number of params"; eval { ParseParameters(1, {'fred' => [Parse_boolean, 0]}, fred => 'joe') ; }; - like $@, mkErr("Parameter 'fred' must be an int, got 'joe'"), + like $@, mkErr("Parameter 'fred' must be an int, got 'joe'"), "wanted unsigned, got undef"; eval { ParseParameters(1, {'fred' => [Parse_unsigned, 0]}, fred => undef) ; }; - like $@, mkErr("Parameter 'fred' must be an unsigned int, got 'undef'"), + like $@, mkErr("Parameter 'fred' must be an unsigned int, got 'undef'"), "wanted unsigned, got undef"; eval { ParseParameters(1, {'fred' => [Parse_signed, 0]}, fred => undef) ; }; - like $@, mkErr("Parameter 'fred' must be a signed int, got 'undef'"), + like $@, mkErr("Parameter 'fred' must be a signed int, got 'undef'"), "wanted signed, got undef"; eval { ParseParameters(1, {'fred' => [Parse_signed, 0]}, fred => 'abc') ; }; - like $@, mkErr("Parameter 'fred' must be a signed int, got 'abc'"), + like $@, mkErr("Parameter 'fred' must be a signed int, got 'abc'"), "wanted signed, got 'abc'"; eval { ParseParameters(1, {'fred' => [Parse_code, undef]}, fred => 'abc') ; }; - like $@, mkErr("Parameter 'fred' must be a code reference, got 'abc'"), + like $@, mkErr("Parameter 'fred' must be a code reference, got 'abc'"), "wanted code, got 'abc'"; @@ -76,25 +76,25 @@ sub My::testParseParameters() if $Config{useithreads}; eval { ParseParameters(1, {'fred' => [Parse_writable_scalar, 0]}, fred => 'abc') ; }; - like $@, mkErr("Parameter 'fred' not writable"), + like $@, mkErr("Parameter 'fred' not writable"), "wanted writable, got readonly"; - skip '\\ returns mutable value in 5.19.3', 1 + skip '\\ returns mutable value in 5.19.3', 1 if $] >= 5.019003; eval { ParseParameters(1, {'fred' => [Parse_writable_scalar, 0]}, fred => \'abc') ; }; - like $@, mkErr("Parameter 'fred' not writable"), + like $@, mkErr("Parameter 'fred' not writable"), "wanted writable, got readonly"; } my @xx; eval { ParseParameters(1, {'fred' => [Parse_writable_scalar, 0]}, fred => \@xx) ; }; - like $@, mkErr("Parameter 'fred' not a scalar reference"), + like $@, mkErr("Parameter 'fred' not a scalar reference"), "wanted scalar reference"; local *ABC; eval { ParseParameters(1, {'fred' => [Parse_writable_scalar, 0]}, fred => *ABC) ; }; - like $@, mkErr("Parameter 'fred' not a scalar"), + like $@, mkErr("Parameter 'fred' not a scalar"), "wanted scalar"; eval { ParseParameters(1, {'fred' => [Parse_any, 0]}, fred => 1, fred => 2) ; }; @@ -137,58 +137,58 @@ sub My::testParseParameters() { my $got1 = ParseParameters(1, {'fred' => [Parse_writable_scalar, undef]}, $got) ; is $got1, $got, "Same object"; - + ok $got1->parsed('fred'), "parsed" ; $xx_ref = $got1->getValue('fred'); - + $$xx_ref = 777 ; is $xx, 777; } - for my $type (Parse_unsigned, Parse_signed, Parse_any) + for my $type (Parse_unsigned, Parse_signed, Parse_any) { my $value = 0; my $got1 ; eval { $got1 = ParseParameters(1, {'fred' => [$type, 1]}, fred => $value) } ; - + ok ! $@; ok $got1->parsed('fred'), "parsed ok" ; is $got1->getValue('fred'), 0; - } + } { # setValue/getValue my $value = 0; my $got1 ; eval { $got1 = ParseParameters(1, {'fred' => [Parse_any, 1]}, fred => $value) } ; - + ok ! $@; ok $got1->parsed('fred'), "parsed ok" ; is $got1->getValue('fred'), 0; $got1->setValue('fred' => undef); - is $got1->getValue('fred'), undef; - } - + is $got1->getValue('fred'), undef; + } + { # twice my $value = 0; - + my $got = IO::Compress::Base::Parameters::new(); - + ok $got->parse({'fred' => [Parse_any, 1]}, fred => $value) ; ok $got->parsed('fred'), "parsed ok" ; is $got->getValue('fred'), 0; - - ok $got->parse({'fred' => [Parse_any, 1]}, fred => undef) ; + + ok $got->parse({'fred' => [Parse_any, 1]}, fred => undef) ; ok $got->parsed('fred'), "parsed ok" ; - is $got->getValue('fred'), undef; - - ok $got->parse({'fred' => [Parse_any, 1]}, fred => 7) ; + is $got->getValue('fred'), undef; + + ok $got->parse({'fred' => [Parse_any, 1]}, fred => 7) ; ok $got->parsed('fred'), "parsed ok" ; - is $got->getValue('fred'), 7; - } + is $got->getValue('fred'), 7; + } } @@ -208,7 +208,7 @@ My::testParseParameters(); { title "whatIsInput" ; - my $lex = new LexFile my $out_file ; + my $lex = LexFile->new( my $out_file ); open FH, ">$out_file" ; is whatIsInput(*FH), 'handle', "Match filehandle" ; close FH ; @@ -227,7 +227,7 @@ My::testParseParameters(); { title "whatIsOutput" ; - my $lex = new LexFile my $out_file ; + my $lex = LexFile->new( my $out_file ); open FH, ">$out_file" ; is whatIsOutput(*FH), 'handle', "Match filehandle" ; close FH ; @@ -248,34 +248,34 @@ My::testParseParameters(); { title "U64" ; - my $x = new U64(); + my $x = U64->new(); is $x->getHigh, 0, " getHigh is 0"; is $x->getLow, 0, " getLow is 0"; ok ! $x->is64bit(), " ! is64bit"; - $x = new U64(1,2); + $x = U64->new(1,2); is $x->getHigh, 1, " getHigh is 1"; is $x->getLow, 2, " getLow is 2"; ok $x->is64bit(), " is64bit"; - $x = new U64(0xFFFFFFFF,2); + $x = U64->new(0xFFFFFFFF,2); is $x->getHigh, 0xFFFFFFFF, " getHigh is 0xFFFFFFFF"; is $x->getLow, 2, " getLow is 2"; ok $x->is64bit(), " is64bit"; - $x = new U64(7, 0xFFFFFFFF); + $x = U64->new(7, 0xFFFFFFFF); is $x->getHigh, 7, " getHigh is 7"; is $x->getLow, 0xFFFFFFFF, " getLow is 0xFFFFFFFF"; ok $x->is64bit(), " is64bit"; - $x = new U64(666); + $x = U64->new(666); is $x->getHigh, 0, " getHigh is 0"; is $x->getLow, 666, " getLow is 666"; ok ! $x->is64bit(), " ! is64bit"; title "U64 - add" ; - $x = new U64(0, 1); + $x = U64->new(0, 1); is $x->getHigh, 0, " getHigh is 0"; is $x->getLow, 1, " getLow is 1"; ok ! $x->is64bit(), " ! is64bit"; @@ -285,7 +285,7 @@ My::testParseParameters(); is $x->getLow, 2, " getLow is 2"; ok ! $x->is64bit(), " ! is64bit"; - $x = new U64(0, 0xFFFFFFFE); + $x = U64->new(0, 0xFFFFFFFE); is $x->getHigh, 0, " getHigh is 0"; is $x->getLow, 0xFFFFFFFE, " getLow is 0xFFFFFFFE"; is $x->get32bit(), 0xFFFFFFFE, " get32bit is 0xFFFFFFFE"; @@ -320,8 +320,8 @@ My::testParseParameters(); is $x->get64bit(), 0xFFFFFFFF+3, " get64bit is 0x100000002"; ok $x->is64bit(), " is64bit"; - $x = new U64(1, 0xFFFFFFFE); - my $y = new U64(2, 3); + $x = U64->new(1, 0xFFFFFFFE); + my $y = U64->new(2, 3); $x->add($y); is $x->getHigh, 4, " getHigh is 4"; @@ -330,7 +330,7 @@ My::testParseParameters(); title "U64 - subtract" ; - $x = new U64(0, 1); + $x = U64->new(0, 1); is $x->getHigh, 0, " getHigh is 0"; is $x->getLow, 1, " getLow is 1"; ok ! $x->is64bit(), " ! is64bit"; @@ -340,7 +340,7 @@ My::testParseParameters(); is $x->getLow, 0, " getLow is 0"; ok ! $x->is64bit(), " ! is64bit"; - $x = new U64(1, 0); + $x = U64->new(1, 0); is $x->getHigh, 1, " getHigh is 1"; is $x->getLow, 0, " getLow is 0"; is $x->get32bit(), 0, " get32bit is 0xFFFFFFFE"; @@ -354,16 +354,16 @@ My::testParseParameters(); is $x->get64bit(), 0xFFFFFFFF, " get64bit is 0xFFFFFFFF"; ok ! $x->is64bit(), " ! is64bit"; - $x = new U64(2, 2); - $y = new U64(1, 3); + $x = U64->new(2, 2); + $y = U64->new(1, 3); $x->subtract($y); is $x->getHigh, 0, " getHigh is 0"; is $x->getLow, 0xFFFFFFFF, " getLow is 1"; ok ! $x->is64bit(), " ! is64bit"; - $x = new U64(0x01CADCE2, 0x4E815983); - $y = new U64(0x19DB1DE, 0xD53E8000); # NTFS to Unix time delta + $x = U64->new(0x01CADCE2, 0x4E815983); + $y = U64->new(0x19DB1DE, 0xD53E8000); # NTFS to Unix time delta $x->subtract($y); is $x->getHigh, 0x2D2B03, " getHigh is 2D2B03"; @@ -372,17 +372,17 @@ My::testParseParameters(); title "U64 - equal" ; - $x = new U64(0, 1); + $x = U64->new(0, 1); is $x->getHigh, 0, " getHigh is 0"; is $x->getLow, 1, " getLow is 1"; ok ! $x->is64bit(), " ! is64bit"; - $y = new U64(0, 1); + $y = U64->new(0, 1); is $y->getHigh, 0, " getHigh is 0"; is $y->getLow, 1, " getLow is 1"; ok ! $y->is64bit(), " ! is64bit"; - my $z = new U64(0, 2); + my $z = U64->new(0, 2); is $z->getHigh, 0, " getHigh is 0"; is $z->getLow, 2, " getLow is 2"; ok ! $z->is64bit(), " ! is64bit"; @@ -391,14 +391,14 @@ My::testParseParameters(); ok !$x->equal($z), " ! equal"; title "U64 - clone" ; - $x = new U64(21, 77); + $x = U64->new(21, 77); $z = U64::clone($x); is $z->getHigh, 21, " getHigh is 21"; is $z->getLow, 77, " getLow is 77"; title "U64 - cmp.gt" ; - $x = new U64 1; - $y = new U64 0; + $x = U64->new( 1 ); + $y = U64->new( 0 ); cmp_ok $x->cmp($y), '>', 0, " cmp > 0"; is $x->gt($y), 1, " gt"; cmp_ok $y->cmp($x), '<', 0, " cmp < 0"; diff --git a/cpan/IO-Compress/t/020isize.t b/cpan/IO-Compress/t/020isize.t index 825e46fc1a61..b24bb98d04c6 100644 --- a/cpan/IO-Compress/t/020isize.t +++ b/cpan/IO-Compress/t/020isize.t @@ -13,8 +13,8 @@ use bytes; use Test::More ; use CompTestUtils; -BEGIN -{ +BEGIN +{ plan skip_all => "Lengthy Tests Disabled\n" . "set COMPRESS_ZLIB_RUN_ALL to run this test suite" unless defined $ENV{COMPRESS_ZLIB_RUN_ALL} ; @@ -33,7 +33,7 @@ BEGIN use_ok('IO::Compress::Gzip::Constants'); } -my $compressed ; +my $compressed ; my $expected_crc ; for my $wrap (0 .. 2) @@ -59,7 +59,7 @@ for my $wrap (0 .. 2) else { $expected_isize = $offset - 1; } - + sub gzipClosure { my $gzip = shift ; @@ -70,7 +70,7 @@ for my $wrap (0 .. 2) my $buff = 'x' x $inc ; my $left = $max ; - return + return sub { if ($max == 0 && $index == 0) { @@ -113,16 +113,16 @@ for my $wrap (0 .. 2) }; } - my $gzip = new IO::Compress::Gzip \$compressed, + my $gzip = IO::Compress::Gzip->new( \$compressed, -Append => 0, - -HeaderCRC => 1; + -HeaderCRC => 1 ); ok $gzip, " Created IO::Compress::Gzip object"; - my $gunzip = new IO::Uncompress::Gunzip gzipClosure($gzip, $size), + my $gunzip = IO::Uncompress::Gunzip->new( gzipClosure($gzip, $size), -BlockSize => 1024 * 500 , -Append => 0, - -Strict => 1; + -Strict => 1 ); ok $gunzip, " Created IO::Uncompress::Gunzip object"; @@ -147,12 +147,11 @@ for my $wrap (0 .. 2) my $gunzip_hdr = $gunzip->getHeaderInfo(); - is $gunzip_hdr->{ISIZE}, $expected_isize, + is $gunzip_hdr->{ISIZE}, $expected_isize, sprintf(" ISIZE is $expected_isize [0x%X]", $expected_isize); - is $gunzip_hdr->{CRC32}, $expected_crc, + is $gunzip_hdr->{CRC32}, $expected_crc, sprintf(" CRC32 is $expected_crc [0x%X]", $expected_crc); $expected_crc = 0 ; } } - diff --git a/cpan/IO-Compress/t/050interop-gzip.t b/cpan/IO-Compress/t/050interop-gzip.t index ae019c87acf2..77b9d76c50e9 100644 --- a/cpan/IO-Compress/t/050interop-gzip.t +++ b/cpan/IO-Compress/t/050interop-gzip.t @@ -19,7 +19,7 @@ my $GZIP ; sub ExternalGzipWorks { - my $lex = new LexFile my $outfile; + my $lex = LexFile->new( my $outfile ); my $content = qq { Lorem ipsum dolor sit amet, consectetuer adipiscing elit. Ut tempus odio id dolor. Camelus perlus. Larrius in lumen numen. Dolor en quiquum filia @@ -28,7 +28,7 @@ Lorem ipsum dolor sit amet, consectetuer adipiscing elit. Ut tempus odio id writeWithGzip($outfile, $content) or return 0; - + my $got ; readWithGzip($outfile, $got) or return 0; @@ -46,14 +46,14 @@ sub readWithGzip { my $file = shift ; - my $lex = new LexFile my $outfile; + my $lex = LexFile->new( my $outfile ); my $comp = "$GZIP -d -c" ; if ( system("$comp $file >$outfile") == 0 ) { $_[0] = readFile($outfile); - return 1 + return 1 } diag "'$comp' failed: \$?=$? \$!=$!"; @@ -71,13 +71,13 @@ sub writeWithGzip my $content = shift ; my $options = shift || ''; - my $lex = new LexFile my $infile; + my $lex = LexFile->new( my $infile ); writeFile($infile, $content); unlink $file ; my $comp = "$GZIP -c $options $infile >$file" ; - return 1 + return 1 if system($comp) == 0 ; diag "'$comp' failed: \$?=$? \$!=$!"; @@ -90,14 +90,14 @@ BEGIN { my $name = $^O =~ /mswin/i ? 'gzip.exe' : 'gzip'; my $split = $^O =~ /mswin/i ? ";" : ":"; - for my $dir (reverse split $split, $ENV{PATH}) + for my $dir (reverse split $split, $ENV{PATH}) { $GZIP = File::Spec->catfile($dir,$name) if -x File::Spec->catfile($dir,$name) } - # Handle spaces in path to gzip - $GZIP = "\"$GZIP\"" if defined $GZIP && $GZIP =~ /\s/; + # Handle spaces in path to gzip + $GZIP = "\"$GZIP\"" if defined $GZIP && $GZIP =~ /\s/; plan(skip_all => "Cannot find $name") if ! $GZIP ; @@ -105,7 +105,7 @@ BEGIN { plan(skip_all => "$name doesn't work as expected") if ! ExternalGzipWorks(); - + # use Test::NoWarnings, if available my $extra = 0 ; $extra = 1 @@ -124,7 +124,7 @@ BEGIN { my $file; my $file1; - my $lex = new LexFile $file, $file1; + my $lex = LexFile->new( $file, $file1 ); my $content = qq { Lorem ipsum dolor sit amet, consectetuer adipiscing elit. Ut tempus odio id dolor. Camelus perlus. Larrius in lumen numen. Dolor en quiquum filia @@ -143,5 +143,3 @@ Lorem ipsum dolor sit amet, consectetuer adipiscing elit. Ut tempus odio id ok readWithGzip($file1, $got), "readWithGzip ok"; is $got, $content, "got content"; } - - diff --git a/cpan/IO-Compress/t/101truncate-bzip2.t b/cpan/IO-Compress/t/101truncate-bzip2.t index d533f237a0df..e8e452560859 100644 --- a/cpan/IO-Compress/t/101truncate-bzip2.t +++ b/cpan/IO-Compress/t/101truncate-bzip2.t @@ -15,7 +15,7 @@ BEGIN { plan skip_all => "Lengthy Tests Disabled\n" . "set COMPRESS_ZLIB_RUN_ALL or COMPRESS_ZLIB_RUN_MOST to run this test suite" unless defined $ENV{COMPRESS_ZLIB_RUN_ALL} or defined $ENV{COMPRESS_ZLIB_RUN_MOST}; - + # use Test::NoWarnings, if available my $extra = 0 ; $extra = 1 diff --git a/cpan/IO-Compress/t/101truncate-deflate.t b/cpan/IO-Compress/t/101truncate-deflate.t index 49f9ae41ca54..1e8b58e35f4f 100644 --- a/cpan/IO-Compress/t/101truncate-deflate.t +++ b/cpan/IO-Compress/t/101truncate-deflate.t @@ -15,7 +15,7 @@ BEGIN { plan skip_all => "Lengthy Tests Disabled\n" . "set COMPRESS_ZLIB_RUN_ALL or COMPRESS_ZLIB_RUN_MOST to run this test suite" unless defined $ENV{COMPRESS_ZLIB_RUN_ALL} or defined $ENV{COMPRESS_ZLIB_RUN_MOST}; - + # use Test::NoWarnings, if available my $extra = 0 ; $extra = 1 diff --git a/cpan/IO-Compress/t/101truncate-gzip.t b/cpan/IO-Compress/t/101truncate-gzip.t index 16b2d0796389..df5d877e3f8d 100644 --- a/cpan/IO-Compress/t/101truncate-gzip.t +++ b/cpan/IO-Compress/t/101truncate-gzip.t @@ -16,7 +16,7 @@ BEGIN { plan skip_all => "Lengthy Tests Disabled\n" . "set COMPRESS_ZLIB_RUN_ALL or COMPRESS_ZLIB_RUN_MOST to run this test suite" unless defined $ENV{COMPRESS_ZLIB_RUN_ALL} or defined $ENV{COMPRESS_ZLIB_RUN_MOST}; - + # use Test::NoWarnings, if available my $extra = 0 ; $extra = 1 diff --git a/cpan/IO-Compress/t/101truncate-rawdeflate.t b/cpan/IO-Compress/t/101truncate-rawdeflate.t index 177a3d5b37f3..371ed5c4b078 100644 --- a/cpan/IO-Compress/t/101truncate-rawdeflate.t +++ b/cpan/IO-Compress/t/101truncate-rawdeflate.t @@ -15,7 +15,7 @@ BEGIN { plan skip_all => "Lengthy Tests Disabled\n" . "set COMPRESS_ZLIB_RUN_ALL or COMPRESS_ZLIB_RUN_MOST to run this test suite" unless defined $ENV{COMPRESS_ZLIB_RUN_ALL} or defined $ENV{COMPRESS_ZLIB_RUN_MOST}; - + # use Test::NoWarnings, if available my $extra = 0 ; $extra = 1 @@ -55,22 +55,22 @@ foreach my $CompressClass ( 'IO::Compress::RawDeflate') my $Error = getErrorRef($UncompressClass); my $compressed ; - ok( my $x = new IO::Compress::RawDeflate \$compressed); + ok( my $x = IO::Compress::RawDeflate->new( \$compressed ) ); ok $x->write($hello) ; ok $x->close ; - + my $cc = $compressed ; my $gz ; - ok($gz = new $UncompressClass(\$cc, + ok($gz = $UncompressClass->can('new')->( $UncompressClass, \$cc, -Transparent => 0)) or diag "$$Error\n"; my $un; is $gz->read($un, length($hello)), length($hello); ok $gz->close(); is $un, $hello ; - + for my $trans (0 .. 1) { title "Testing $CompressClass, Transparent = $trans"; @@ -82,19 +82,19 @@ foreach my $CompressClass ( 'IO::Compress::RawDeflate') ok 1, "Header size is $header_size" ; ok 1, "Trailer size is $trailer_size" ; - + title "Compressed Data Truncation"; foreach my $i (0 .. $blocksize) { - - my $lex = new LexFile my $name ; - + + my $lex = LexFile->new( my $name ); + ok 1, "Length $i" ; my $part = substr($compressed, 0, $i); writeFile($name, $part); - my $gz = new $UncompressClass $name, + my $gz = $UncompressClass->can('new')->( $UncompressClass, $name, -BlockSize => $blocksize, - -Transparent => $trans; + -Transparent => $trans ); if ($trans) { ok $gz; ok ! $gz->error() ; @@ -111,15 +111,15 @@ foreach my $CompressClass ( 'IO::Compress::RawDeflate') foreach my $i ($blocksize+1 .. length($compressed)-1) { - - my $lex = new LexFile my $name ; - + + my $lex = LexFile->new( my $name ); + ok 1, "Length $i" ; my $part = substr($compressed, 0, $i); writeFile($name, $part); - ok my $gz = new $UncompressClass $name, + ok my $gz = $UncompressClass->can('new')->( $UncompressClass, $name, -BlockSize => $blocksize, - -Transparent => $trans; + -Transparent => $trans ); my $un ; my $status = 1 ; $status = $gz->read($un) while $status > 0 ; @@ -129,6 +129,5 @@ foreach my $CompressClass ( 'IO::Compress::RawDeflate') $gz->close(); } } - -} +} diff --git a/cpan/IO-Compress/t/101truncate-zip.t b/cpan/IO-Compress/t/101truncate-zip.t index 80a0aee27514..94d4a8da9bfa 100644 --- a/cpan/IO-Compress/t/101truncate-zip.t +++ b/cpan/IO-Compress/t/101truncate-zip.t @@ -16,7 +16,7 @@ BEGIN { plan skip_all => "Lengthy Tests Disabled\n" . "set COMPRESS_ZLIB_RUN_ALL or COMPRESS_ZLIB_RUN_MOST to run this test suite" unless defined $ENV{COMPRESS_ZLIB_RUN_ALL} or defined $ENV{COMPRESS_ZLIB_RUN_MOST}; - + # use Test::NoWarnings, if available my $extra = 0 ; $extra = 1 diff --git a/cpan/IO-Compress/t/105oneshot-gzip-only.t b/cpan/IO-Compress/t/105oneshot-gzip-only.t index 0382df8e33b1..ff42b4f8840a 100644 --- a/cpan/IO-Compress/t/105oneshot-gzip-only.t +++ b/cpan/IO-Compress/t/105oneshot-gzip-only.t @@ -42,11 +42,11 @@ sub gzipGetHeader my $got ; ok IO::Compress::Gzip::gzip($in, \$out, %opts), " gzip ok" ; - ok IO::Uncompress::Gunzip::gunzip(\$out, \$got), " gunzip ok" + ok IO::Uncompress::Gunzip::gunzip(\$out, \$got), " gunzip ok" or diag $GunzipError ; is $got, $content, " got expected content" ; - my $gunz = new IO::Uncompress::Gunzip \$out, Strict => 0 + my $gunz = IO::Uncompress::Gunzip->new( \$out, Strict => 0 ) or diag "GunzipError is $IO::Uncompress::Gunzip::GunzipError" ; ok $gunz, " Created IO::Uncompress::Gunzip object"; my $hdr = $gunz->getHeaderInfo(); @@ -57,13 +57,13 @@ sub gzipGetHeader ok $gunz->close, " closed ok" ; return $hdr ; - + } { title "Check gzip header default NAME & MTIME settings" ; - my $lex = new LexFile my $file1; + my $lex = LexFile->new( my $file1 ); my $content = "hello "; my $hdr ; @@ -73,7 +73,7 @@ sub gzipGetHeader $mtime = (stat($file1))[9]; # make sure that the gzip file isn't created in the same # second as the input file - sleep 3 ; + sleep 3 ; $hdr = gzipGetHeader($file1, $content); is $hdr->{Name}, $file1, " Name is '$file1'"; @@ -83,7 +83,7 @@ sub gzipGetHeader writeFile($file1, $content); $mtime = (stat($file1))[9]; - sleep 3 ; + sleep 3 ; $hdr = gzipGetHeader($file1, $content, Name => "abcde"); is $hdr->{Name}, "abcde", " Name is 'abcde'" ; @@ -106,9 +106,9 @@ sub gzipGetHeader is $hdr->{Time}, 4321, " Time is 4321"; title "Filehandle doesn't have default Name or Time" ; - my $fh = new IO::File "< $file1" + my $fh = IO::File->new( "< $file1" ) or diag "Cannot open '$file1': $!\n" ; - sleep 3 ; + sleep 3 ; my $before = time ; $hdr = gzipGetHeader($fh, $content); my $after = time ; @@ -131,4 +131,3 @@ sub gzipGetHeader } # TODO add more error cases - diff --git a/cpan/IO-Compress/t/105oneshot-zip-bzip2-only.t b/cpan/IO-Compress/t/105oneshot-zip-bzip2-only.t index ed3f8c74dcb3..abeefa775376 100644 --- a/cpan/IO-Compress/t/105oneshot-zip-bzip2-only.t +++ b/cpan/IO-Compress/t/105oneshot-zip-bzip2-only.t @@ -18,8 +18,8 @@ BEGIN { if $] < 5.005 ; plan(skip_all => "IO::Compress::Bzip2 not available" ) - unless eval { require IO::Compress::Bzip2; - require IO::Uncompress::Bunzip2; + unless eval { require IO::Compress::Bzip2; + require IO::Uncompress::Bunzip2; 1 } ; @@ -48,11 +48,11 @@ sub zipGetHeader my $got ; ok zip($in, \$out, %opts), " zip ok" ; - ok unzip(\$out, \$got), " unzip ok" + ok unzip(\$out, \$got), " unzip ok" or diag $UnzipError ; is $got, $content, " got expected content" ; - my $gunz = new IO::Uncompress::Unzip \$out, Strict => 0 + my $gunz = IO::Uncompress::Unzip->new( \$out, Strict => 0 ) or diag "UnzipError is $IO::Uncompress::Unzip::UnzipError" ; ok $gunz, " Created IO::Uncompress::Unzip object"; my $hdr = $gunz->getHeaderInfo(); @@ -63,7 +63,7 @@ sub zipGetHeader ok $gunz->close, " closed ok" ; return $hdr ; - + } @@ -79,8 +79,8 @@ for my $input (0, 1) { title "Input $input, Stream $stream, Zip64 $zip64, Method $method"; - my $lex1 = new LexFile my $file1; - my $lex2 = new LexFile my $file2; + my $lex1 = LexFile->new( my $file1 ); + my $lex2 = LexFile->new( my $file2 ); my $content = "hello "; my $in ; @@ -95,9 +95,9 @@ for my $input (0, 1) } - ok zip($in => $file1 , Method => $method, + ok zip($in => $file1 , Method => $method, Zip64 => $zip64, - Stream => $stream), " zip ok" + Stream => $stream), " zip ok" or diag $ZipError ; my $got ; @@ -106,7 +106,7 @@ for my $input (0, 1) is $got, $content, " content ok"; - my $u = new IO::Uncompress::Unzip $file1 + my $u = IO::Uncompress::Unzip->new( $file1 ) or diag $ZipError ; my $hdr = $u->getHeaderInfo(); @@ -133,7 +133,7 @@ for my $stream (0, 1) my $file1; my $file2; my $zipfile; - my $lex = new LexFile $file1, $file2, $zipfile; + my $lex = LexFile->new( $file1, $file2, $zipfile ); my $content1 = "hello "; writeFile($file1, $content1); @@ -145,9 +145,9 @@ for my $stream (0, 1) $file2 => $content2, ); - ok zip([$file1, $file2] => $zipfile , Method => $method, + ok zip([$file1, $file2] => $zipfile , Method => $method, Zip64 => $zip64, - Stream => $stream), " zip ok" + Stream => $stream), " zip ok" or diag $ZipError ; for my $file ($file1, $file2) @@ -163,4 +163,3 @@ for my $stream (0, 1) } # TODO add more error cases - diff --git a/cpan/IO-Compress/t/105oneshot-zip-only.t b/cpan/IO-Compress/t/105oneshot-zip-only.t index b0d6a4334c4e..ea7b1b25b54f 100644 --- a/cpan/IO-Compress/t/105oneshot-zip-only.t +++ b/cpan/IO-Compress/t/105oneshot-zip-only.t @@ -46,7 +46,7 @@ sub zipGetHeader or diag $UnzipError ; is $got, $content, " got expected content" ; - my $gunz = new IO::Uncompress::Unzip \$out, Strict => 0 + my $gunz = IO::Uncompress::Unzip->new( \$out, Strict => 0 ) or diag "UnzipError is $IO::Uncompress::Unzip::UnzipError" ; ok $gunz, " Created IO::Uncompress::Unzip object"; my $hdr = $gunz->getHeaderInfo(); @@ -63,7 +63,7 @@ sub zipGetHeader { title "Check zip header default NAME & MTIME settings" ; - my $lex = new LexFile my $file1; + my $lex = LexFile->new( my $file1 ); my $content = "hello "; my $hdr ; @@ -108,7 +108,7 @@ sub zipGetHeader is $hdr->{Time} >> 1 , $useTime >> 1 , " Time is $useTime"; title "Filehandle doesn't have default Name or Time" ; - my $fh = new IO::File "< $file1" + my $fh = IO::File->new( "< $file1" ) or diag "Cannot open '$file1': $!\n" ; sleep 3 ; my $before = time ; @@ -135,7 +135,7 @@ sub zipGetHeader { title "Check CanonicalName & FilterName"; - my $lex = new LexFile my $file1; + my $lex = LexFile->new( my $file1 ); my $content = "hello" ; writeFile($file1, $content); @@ -222,7 +222,7 @@ for my $stream (0, 1) title "Stream $stream, Zip64 $zip64, Method $method"; - my $lex = new LexFile my $file1; + my $lex = LexFile->new( my $file1 ); my $content = "hello "; #writeFile($file1, $content); @@ -241,7 +241,7 @@ for my $stream (0, 1) is $got, $content, " content ok"; - my $u = new IO::Uncompress::Unzip $file1 + my $u = IO::Uncompress::Unzip->new( $file1 ) or diag $ZipError ; my $hdr = $u->getHeaderInfo(); @@ -266,7 +266,7 @@ for my $stream (0, 1) my $file1; my $file2; my $zipfile; - my $lex = new LexFile $file1, $file2, $zipfile; + my $lex = LexFile->new( $file1, $file2, $zipfile ); my $content1 = "hello "; writeFile($file1, $content1); diff --git a/cpan/IO-Compress/t/105oneshot-zip-store-only.t b/cpan/IO-Compress/t/105oneshot-zip-store-only.t index 641fb609a8c8..a7a1eb109a32 100644 --- a/cpan/IO-Compress/t/105oneshot-zip-store-only.t +++ b/cpan/IO-Compress/t/105oneshot-zip-store-only.t @@ -22,8 +22,8 @@ BEGIN { unless defined $ENV{COMPRESS_ZLIB_RUN_ALL} or defined $ENV{COMPRESS_ZLIB_RUN_MOST}; plan(skip_all => "IO::Compress::Bzip2 not available" ) - unless eval { require IO::Compress::Bzip2; - require IO::Uncompress::Bunzip2; + unless eval { require IO::Compress::Bzip2; + require IO::Uncompress::Bunzip2; 1 } ; @@ -86,7 +86,7 @@ for $content (@contents) ok zip(\$content => \$zipped , Method => ZIP_CM_STORE, Zip64 => $zip64, - Stream => $stream), " zip ok" + Stream => $stream), " zip ok" or diag $ZipError ; my $got ; @@ -99,4 +99,3 @@ for $content (@contents) } } } - diff --git a/cpan/IO-Compress/t/107multi-zip-only.t b/cpan/IO-Compress/t/107multi-zip-only.t index 40c7fef5e2ac..0a8e1ae0cb6b 100644 --- a/cpan/IO-Compress/t/107multi-zip-only.t +++ b/cpan/IO-Compress/t/107multi-zip-only.t @@ -49,9 +49,9 @@ EOM my $name = "n1"; -my $lex = new LexFile my $zipfile ; +my $lex = LexFile->new( my $zipfile ); -my $x = new IO::Compress::Zip($zipfile, Name => $name++, AutoClose => 1); +my $x = IO::Compress::Zip->new($zipfile, Name => $name++, AutoClose => 1); isa_ok $x, 'IO::Compress::Zip', ' $x' ; @@ -67,10 +67,10 @@ push @buffers, undef; { open F, ">>$zipfile"; print F "trailing"; - close F; + close F; } -my $u = new IO::Uncompress::Unzip $zipfile, Transparent => 1, MultiStream => 0 +my $u = IO::Uncompress::Unzip->new( $zipfile, Transparent => 1, MultiStream => 0 ) or die "Cannot open $zipfile: $UnzipError"; my @names ; diff --git a/cpan/IO-Compress/t/108anyunc-transparent.t b/cpan/IO-Compress/t/108anyunc-transparent.t index 687b1f5cd251..8d79a4669eca 100644 --- a/cpan/IO-Compress/t/108anyunc-transparent.t +++ b/cpan/IO-Compress/t/108anyunc-transparent.t @@ -6,7 +6,7 @@ BEGIN { } use lib qw(t t/compress); - + use strict; use warnings; use bytes; @@ -38,7 +38,7 @@ EOM { title "AnyUncompress with Non-compressed data (File $file)" ; - my $lex = new LexFile my $output; + my $lex = LexFile->new( my $output ); my $input ; if ($file) { @@ -52,12 +52,12 @@ EOM my $unc ; my $keep = $buffer ; - $unc = new IO::Uncompress::AnyUncompress $input, -Transparent => 0 ; + $unc = IO::Uncompress::AnyUncompress->new( $input, -Transparent => 0 ); ok ! $unc," no AnyUncompress object when -Transparent => 0" ; is $buffer, $keep ; $buffer = $keep ; - $unc = new IO::Uncompress::AnyUncompress \$buffer, -Transparent => 1 ; + $unc = IO::Uncompress::AnyUncompress->new( \$buffer, -Transparent => 1 ); ok $unc, " AnyUncompress object when -Transparent => 1" ; my $uncomp ; diff --git a/cpan/IO-Compress/t/111const-deflate.t b/cpan/IO-Compress/t/111const-deflate.t index 82a441414979..bdb2eca0f70e 100644 --- a/cpan/IO-Compress/t/111const-deflate.t +++ b/cpan/IO-Compress/t/111const-deflate.t @@ -26,75 +26,74 @@ BEGIN { { use Compress::Raw::Zlib ; - + my %all; for my $symbol (@Compress::Raw::Zlib::DEFLATE_CONSTANTS) { eval "defined Compress::Raw::Zlib::$symbol" ; $all{$symbol} = ! $@ ; - } - + } + my $pkg = 1; - - for my $module ( qw( Adapter::Deflate RawDeflate Deflate Gzip Zip )) + + for my $module ( qw( Adapter::Deflate RawDeflate Deflate Gzip Zip )) { - ++ $pkg ; + ++ $pkg ; eval <new( my $file1 ); my @names = ( 'alpha \N{GREEK SMALL LETTER ALPHA}', 'beta \N{GREEK SMALL LETTER BETA}', @@ -48,12 +48,12 @@ BEGIN { 'delta \N{GREEK SMALL LETTER DELTA}' ) ; - my @encoded = map { Encode::encode_utf8($_) } @names; + my @encoded = map { Encode::encode_utf8($_) } @names; my @n = @names; - my $zip = new IO::Compress::Zip $file1, - Name => $names[0], Efs => 1; + my $zip = IO::Compress::Zip->new( $file1, + Name => $names[0], Efs => 1 ); my $content = 'Hello, world!'; ok $zip->print($content), "print"; @@ -66,7 +66,7 @@ BEGIN { ok $zip->close(), "closed"; { - my $u = new IO::Uncompress::Unzip $file1, Efs => 1 + my $u = IO::Uncompress::Unzip->new( $file1, Efs => 1 ) or die "Cannot open $file1: $UnzipError"; my $status; @@ -88,7 +88,7 @@ BEGIN { } { - my $u = new IO::Uncompress::Unzip $file1, Efs => 0 + my $u = IO::Uncompress::Unzip->new( $file1, Efs => 0 ) or die "Cannot open $file1: $UnzipError"; my $status; @@ -107,14 +107,14 @@ BEGIN { or diag "Got " . Dumper(\@efs); is_deeply \@unzip_names, [@names], "Names round tripped" or diag "Got " . Dumper(\@unzip_names); - } + } } { title "Create a simple zip - language encoding flag not set"; - my $lex = new LexFile my $file1; + my $lex = LexFile->new( my $file1 ); my @names = ( 'alpha \N{GREEK SMALL LETTER ALPHA}', 'beta \N{GREEK SMALL LETTER BETA}', @@ -124,8 +124,8 @@ BEGIN { my @n = @names; - my $zip = new IO::Compress::Zip $file1, - Name => $names[0], Efs => 0; + my $zip = IO::Compress::Zip->new( $file1, + Name => $names[0], Efs => 0 ); my $content = 'Hello, world!'; ok $zip->print($content), "print"; @@ -137,7 +137,7 @@ BEGIN { ok $zip->print($content), "print"; ok $zip->close(), "closed"; - my $u = new IO::Uncompress::Unzip $file1, Efs => 0 + my $u = IO::Uncompress::Unzip->new( $file1, Efs => 0 ) or die "Cannot open $file1: $UnzipError"; my $status; @@ -161,19 +161,19 @@ BEGIN { { title "zip: EFS => 0 filename not valid utf8 - language encoding flag not set"; - my $lex = new LexFile my $file1; + my $lex = LexFile->new( my $file1 ); # Invalid UTF8 my $name = "a\xFF\x{100}"; - - my $zip = new IO::Compress::Zip $file1, - Name => $name, Efs => 0 ; + + my $zip = IO::Compress::Zip->new( $file1, + Name => $name, Efs => 0 ); ok $zip->print("abcd"), "print"; ok $zip->close(), "closed"; - my $u = new IO::Uncompress::Unzip $file1 - or die "Cannot open $file1: $UnzipError"; + my $u = IO::Uncompress::Unzip->new( $file1 ) + or die "Cannot open $file1: $UnzipError"; ok $u->getHeaderInfo()->{Name} eq $name, "got bad filename"; } @@ -184,8 +184,8 @@ BEGIN { my $filename = "t/files/bad-efs.zip" ; my $name = "\xF0\xA4\xAD"; - my $u = new IO::Uncompress::Unzip $filename, efs => 0 - or die "Cannot open $filename: $UnzipError"; + my $u = IO::Uncompress::Unzip->new( $filename, efs => 0 ) + or die "Cannot open $filename: $UnzipError"; ok $u->getHeaderInfo()->{Name} eq $name, "got bad filename"; } @@ -195,8 +195,8 @@ BEGIN { my $filename = "t/files/bad-efs.zip" ; my $name = "\xF0\xA4\xAD"; - - eval { my $u = new IO::Uncompress::Unzip $filename, efs => 1 + + eval { my $u = IO::Uncompress::Unzip->new( $filename, efs => 1 ) or die "Cannot open $filename: $UnzipError" }; like $@, qr/Zip Filename not UTF-8/, @@ -207,14 +207,14 @@ BEGIN { { title "EFS => 1 - filename not valid utf8 - catch bad content writing to zip"; - my $lex = new LexFile my $file1; + my $lex = LexFile->new( my $file1 ); # Invalid UTF8 my $name = "a\xFF\x{100}"; - - eval { my $zip = new IO::Compress::Zip $file1, - Name => $name, Efs => 1 } ; - like $@, qr/Wide character in zip filename/, + eval { my $zip = IO::Compress::Zip->new( $file1, + Name => $name, Efs => 1 ) } ; + + like $@, qr/Wide character in zip filename/, " wide characters in zip filename"; } \ No newline at end of file diff --git a/cpan/IO-Compress/t/compress/CompTestUtils.pm b/cpan/IO-Compress/t/compress/CompTestUtils.pm index c506632f90e3..61658c9296b6 100644 --- a/cpan/IO-Compress/t/compress/CompTestUtils.pm +++ b/cpan/IO-Compress/t/compress/CompTestUtils.pm @@ -9,13 +9,13 @@ use bytes; #use lib qw(t t/compress); use Carp ; -#use Test::More ; +#use Test::More ; sub title { - #diag "" ; + #diag "" ; ok(1, $_[0]) ; #diag "" ; } @@ -26,7 +26,7 @@ sub like_eval } BEGIN { - eval { + eval { require File::Temp; } ; @@ -38,7 +38,7 @@ BEGIN { our ($index); $index = '00000'; - + sub new { my $self = shift ; @@ -72,7 +72,7 @@ BEGIN { $index = '00000'; our ($useTempFile); our ($useTempDir); - + sub new { my $self = shift ; @@ -115,11 +115,11 @@ BEGIN { # autogenerate the name if none supplied $_ = "tmpdir" . $$ . "X" . $index ++ . ".tmp" ; } - foreach (@_) - { + foreach (@_) + { rmtree $_, {verbose => 0, safe => 1} - if -d $_; - mkdir $_, 0777 + if -d $_; + mkdir $_, 0777 } bless [ @_ ], $self ; } @@ -131,10 +131,10 @@ BEGIN { if (! $useTempFile) { my $self = shift ; - foreach (@$self) - { + foreach (@$self) + { rmtree $_, {verbose => 0, safe => 1} - if -d $_ ; + if -d $_ ; } } } @@ -150,15 +150,15 @@ sub readFile { my $pos = tell($f); seek($f, 0,0); - @strings = <$f> ; + @strings = <$f> ; seek($f, 0, $pos); } else { - open (F, "<$f") + open (F, "<$f") or croak "Cannot open $f: $!\n" ; binmode F; - @strings = ; + @strings = ; close F ; } @@ -175,7 +175,7 @@ sub writeFile { my($filename, @strings) = @_ ; 1 while unlink $filename ; - open (F, ">$filename") + open (F, ">$filename") or croak "Cannot open $filename: $!\n" ; binmode F; foreach (@strings) { @@ -191,10 +191,10 @@ sub GZreadFile my ($uncomp) = "" ; my $line = "" ; - my $fil = gzopen($filename, "rb") + my $fil = gzopen($filename, "rb") or croak "Cannopt open '$filename': $Compress::Zlib::gzerrno" ; - $uncomp .= $line + $uncomp .= $line while $fil->gzread($line) > 0; $fil->gzclose ; @@ -248,14 +248,14 @@ sub readHeaderInfo some text EOM - ok my $x = new IO::Compress::Gzip $name, %opts + ok my $x = IO::Compress::Gzip->new( $name, %opts ) or diag "GzipError is $IO::Compress::Gzip::GzipError" ; ok $x->write($string) ; ok $x->close ; #is GZreadFile($name), $string ; - ok my $gunz = new IO::Uncompress::Gunzip $name, Strict => 0 + ok my $gunz = IO::Uncompress::Gunzip->new( $name, Strict => 0 ) or diag "GunzipError is $IO::Uncompress::Gunzip::GunzipError" ; ok my $hdr = $gunz->getHeaderInfo(); my $uncomp ; @@ -562,12 +562,13 @@ sub anyUncompress } my $out = ''; - my $o = new IO::Uncompress::AnyUncompress \$data, - Append => 1, - Transparent => 0, + my $o = IO::Uncompress::AnyUncompress->new( \$data, + Append => 1, + Transparent => 0, RawInflate => 1, UnLzma => 1, @opts + ) or croak "Cannot open buffer/file: $AnyUncompressError" ; 1 while $o->read($out) > 0 ; @@ -622,13 +623,14 @@ sub getHeaders } my $out = ''; - my $o = new IO::Uncompress::AnyUncompress \$data, - MultiStream => 1, - Append => 1, - Transparent => 0, + my $o = IO::Uncompress::AnyUncompress->new( \$data, + MultiStream => 1, + Append => 1, + Transparent => 0, RawInflate => 1, UnLzma => 1, @opts + ) or croak "Cannot open buffer/file: $AnyUncompressError" ; 1 while $o->read($out) > 0 ; @@ -667,7 +669,7 @@ sub mkComplete ); } - my $z = new $class( \$buffer, %params) + my $z = $class->can('new')->( $class, \$buffer, %params) or croak "Cannot create $class object: $$Error"; $z->write($data); $z->close(); @@ -675,7 +677,7 @@ sub mkComplete my $unc = getInverse($class); anyUncompress(\$buffer) eq $data or die "bad bad bad"; - my $u = new $unc( \$buffer); + my $u = $unc->can('new')->( $unc, \$buffer); my $info = $u->getHeaderInfo() ; diff --git a/cpan/IO-Compress/t/compress/any.pl b/cpan/IO-Compress/t/compress/any.pl index c0da133ebedd..0569b5af10f2 100644 --- a/cpan/IO-Compress/t/compress/any.pl +++ b/cpan/IO-Compress/t/compress/any.pl @@ -1,6 +1,6 @@ use lib 't'; - + use strict; use warnings; use bytes; @@ -41,12 +41,12 @@ sub run my $string = "some text" x 100 ; my $buffer ; - my $x = new $CompressClass(\$buffer) ; + my $x = $CompressClass->can('new')->($CompressClass, \$buffer) ; ok $x, " create $CompressClass object" ; ok $x->write($string), " write to object" ; ok $x->close, " close ok" ; - my $lex = new LexFile my $output; + my $lex = LexFile->new( my $output ); my $input ; if ($file) { @@ -58,16 +58,16 @@ sub run } { - my $unc = new $AnyConstruct $input, Transparent => $trans, + my $unc = $AnyConstruct->can('new')->( $AnyConstruct, $input, Transparent => $trans, RawInflate => 1, @anyUnLz, - Append => 1 ; + Append => 1 ); - ok $unc, " Created $AnyClass object" + ok $unc, " Created $AnyClass object" or print "# $$AnyError\n"; my $uncomp ; 1 while $unc->read($uncomp) > 0 ; - #ok $unc->read($uncomp) > 0 + #ok $unc->read($uncomp) > 0 # or print "# $$AnyError\n"; my $y; is $unc->read($y, 1), 0, " at eof" ; @@ -78,16 +78,16 @@ sub run } { - my $unc = new $AnyConstruct $input, Transparent => $trans, + my $unc = $AnyConstruct->can('new')->( $AnyConstruct, $input, Transparent => $trans, RawInflate => 1, @anyUnLz, - Append => 1 ; + Append => 1 ); - ok $unc, " Created $AnyClass object" + ok $unc, " Created $AnyClass object" or print "# $$AnyError\n"; my $uncomp ; 1 while $unc->read($uncomp, 100) > 0 ; - #ok $unc->read($uncomp) > 0 + #ok $unc->read($uncomp) > 0 # or print "# $$AnyError\n"; my $y; is $unc->read($y, 1), 0, " at eof" ; diff --git a/cpan/IO-Compress/t/compress/anyunc.pl b/cpan/IO-Compress/t/compress/anyunc.pl index 2860e2571c70..8be9c7063e82 100644 --- a/cpan/IO-Compress/t/compress/anyunc.pl +++ b/cpan/IO-Compress/t/compress/anyunc.pl @@ -1,6 +1,6 @@ use lib 't'; - + use strict; use warnings; use bytes; @@ -37,12 +37,12 @@ sub run my $string = "some text" x 100 ; my $buffer ; - my $x = new $CompressClass(\$buffer) ; + my $x = $CompressClass->can('new')->( $CompressClass, \$buffer) ; ok $x, " create $CompressClass object" ; ok $x->write($string), " write to object" ; ok $x->close, " close ok" ; - my $lex = new LexFile my $output; + my $lex = LexFile->new( my $output ); my $input ; if ($file) { @@ -54,14 +54,14 @@ sub run } { - my $unc = new $AnyConstruct $input, Transparent => $trans - Append => 1 ; + my $unc = $AnyConstruct->can('new')->( $AnyConstruct, $input, Transparent => $trans + Append => 1 ); - ok $unc, " Created $AnyClass object" + ok $unc, " Created $AnyClass object" or print "# $$AnyError\n"; my $uncomp ; 1 while $unc->read($uncomp) > 0 ; - #ok $unc->read($uncomp) > 0 + #ok $unc->read($uncomp) > 0 # or print "# $$AnyError\n"; my $y; is $unc->read($y, 1), 0, " at eof" ; @@ -72,10 +72,10 @@ sub run } { - my $unc = new $AnyConstruct $input, Transparent => $trans, - Append =>1 ; + my $unc = $AnyConstruct->can('new')->( $AnyConstruct, $input, Transparent => $trans, + Append =>1 ); - ok $unc, " Created $AnyClass object" + ok $unc, " Created $AnyClass object" or print "# $$AnyError\n"; my $uncomp ; 1 while $unc->read($uncomp, 10) > 0 ; diff --git a/cpan/IO-Compress/t/compress/destroy.pl b/cpan/IO-Compress/t/compress/destroy.pl index 186520df1621..3882e2468d71 100644 --- a/cpan/IO-Compress/t/compress/destroy.pl +++ b/cpan/IO-Compress/t/compress/destroy.pl @@ -35,7 +35,7 @@ sub run { # Check that the class destructor will call close - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $hello = < 1 ; + ok my $x = $CompressClass->can('new')->( $CompressClass, $name, -AutoClose => 1 ); ok $x->write($hello) ; } @@ -56,59 +56,59 @@ sub run # Tied filehandle destructor - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $hello = < $name" ; + my $fh = IO::File->new( "> $name" ); { - ok my $x = new $CompressClass $fh, -AutoClose => 1 ; + ok my $x = $CompressClass->can('new')->( $CompressClass, $fh, -AutoClose => 1 ); $x->write($hello) ; } ok anyUncompress($name) eq $hello ; } - + { title "Testing DESTROY doesn't clobber \$! etc "; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $out; my $result; - + { - ok my $z = new $CompressClass($name); + ok my $z = $CompressClass->can('new')->( $CompressClass, $name ); $z->write("abc") ; $! = 22 ; cmp_ok $!, '==', 22, ' $! is 22'; } - + cmp_ok $!, '==', 22, " \$! has not been changed by $CompressClass destructor"; - + { my $uncomp; - ok my $x = new $UncompressClass($name, -Append => 1) ; - + ok my $x = $UncompressClass->can('new')->( $UncompressClass, $name, -Append => 1) ; + my $len ; 1 while ($len = $x->read($result)) > 0 ; - + $! = 22 ; cmp_ok $!, '==', 22, ' $! is 22'; - } - + } + cmp_ok $!, '==', 22, " \$! has not been changed by $UncompressClass destructor"; - + is $result, "abc", " Got uncompressed content ok"; - + } } diff --git a/cpan/IO-Compress/t/compress/encode.pl b/cpan/IO-Compress/t/compress/encode.pl index 860d0e46ce1b..a6ab50ec70f7 100644 --- a/cpan/IO-Compress/t/compress/encode.pl +++ b/cpan/IO-Compress/t/compress/encode.pl @@ -6,8 +6,8 @@ use Test::More ; use CompTestUtils; -BEGIN -{ +BEGIN +{ plan skip_all => "Encode is not available" if $] < 5.006 ; @@ -15,7 +15,7 @@ BEGIN plan skip_all => "Encode is not available" if $@ ; - + # use Test::NoWarnings, if available my $extra = 0 ; @@ -34,16 +34,16 @@ sub run my $UnError = getErrorRef($UncompressClass); - my $string = "\x{df}\x{100}\x80"; + my $string = "\x{df}\x{100}\x80"; my $encString = Encode::encode_utf8($string); my $buffer = $encString; #for my $from ( qw(filename filehandle buffer) ) { # my $input ; -# my $lex = new LexFile my $name ; +# my $lex = LexFile->new( my $name ); +# # -# # if ($from eq 'buffer') # { $input = \$buffer } # elsif ($from eq 'filename') @@ -53,14 +53,14 @@ sub run # } # elsif ($from eq 'filehandle') # { -# $input = new IO::File "<$name" ; +# $input = IO::File->new( "<$name" ); # } for my $to ( qw(filehandle buffer)) { title "OO Mode: To $to, Encode by hand"; - my $lex2 = new LexFile my $name2 ; + my $lex2 = LexFile->new( my $name2 ); my $output; my $buffer; @@ -72,29 +72,29 @@ sub run } elsif ($to eq 'filehandle') { - $output = new IO::File ">$name2" ; + $output = IO::File->new( ">$name2" ); } my $out ; - my $cs = new $CompressClass($output, AutoClose =>1); + my $cs = $CompressClass->can('new')->( $CompressClass, $output, AutoClose =>1); $cs->print($encString); $cs->close(); my $input; if ($to eq 'buffer') { $input = \$buffer } - else + else { $input = $name2 ; } - my $ucs = new $UncompressClass($input, Append => 1); + my $ucs = $UncompressClass->can('new')->( $UncompressClass, $input, Append => 1); my $got; 1 while $ucs->read($got) > 0 ; - + is $got, $encString, " Expected output"; - + my $decode = Encode::decode_utf8($got); @@ -108,36 +108,36 @@ sub run title "Catch wide characters"; my $out; - my $cs = new $CompressClass(\$out); + my $cs = $CompressClass->can('new')->( $CompressClass, \$out); my $a = "a\xFF\x{100}"; eval { $cs->syswrite($a) }; - like($@, qr/Wide character in ${CompressClass}::write/, + like($@, qr/Wide character in ${CompressClass}::write/, " wide characters in ${CompressClass}::write"); } - + { title "Unknown encoding"; my $output; - eval { my $cs = new $CompressClass(\$output, Encode => 'fred'); } ; - like($@, qr/${CompressClass}: Encoding 'fred' is not available/, + eval { my $cs = $CompressClass->can('new')->( $CompressClass, \$output, Encode => 'fred'); } ; + like($@, qr/${CompressClass}: Encoding 'fred' is not available/, " Encoding 'fred' is not available"); } - + { title "Encode option"; - + for my $to ( qw(filehandle filename buffer)) { title "Encode: To $to, Encode option"; - my $lex2 = new LexFile my $name2 ; + my $lex2 = LexFile->new( my $name2 ); my $output; my $buffer; if ($to eq 'buffer') - { - $output = \$buffer + { + $output = \$buffer } elsif ($to eq 'filename') { @@ -145,18 +145,18 @@ sub run } elsif ($to eq 'filehandle') { - $output = new IO::File ">$name2" ; + $output = IO::File->new( ">$name2" ); } my $out ; - my $cs = new $CompressClass($output, AutoClose =>1, Encode => 'utf8'); + my $cs = $CompressClass->can('new')->( $CompressClass, $output, AutoClose =>1, Encode => 'utf8'); ok $cs->print($string); ok $cs->close(); my $input; if ($to eq 'buffer') - { - $input = \$buffer + { + $input = \$buffer } elsif ($to eq 'filename') { @@ -164,35 +164,34 @@ sub run } else { - $input = new IO::File "<$name2" ; + $input = IO::File->new( "<$name2" ); } - + { - my $ucs = new $UncompressClass($input, AutoClose =>1, Append => 1); + my $ucs = $UncompressClass->can('new')->( $UncompressClass, $input, AutoClose =>1, Append => 1); my $got; 1 while $ucs->read($got) > 0 ; ok length($got) > 0; is $got, $encString, " Expected output"; - + my $decode = Encode::decode_utf8($got); - + is $decode, $string, " Expected output"; } - - + + # { -# my $ucs = new $UncompressClass($input, Append => 1, Decode => 'utf8'); +# my $ucs = $UncompressClass->can('new')->( $UncompressClass, $input, Append => 1, Decode => 'utf8'); # my $got; # 1 while $ucs->read($got) > 0 ; -# ok length($got) > 0; +# ok length($got) > 0; # is $got, $string, " Expected output"; -# } - } +# } + } } } - -1; +1; diff --git a/cpan/IO-Compress/t/compress/generic.pl b/cpan/IO-Compress/t/compress/generic.pl index d9695e88dced..2c24bb85e532 100644 --- a/cpan/IO-Compress/t/compress/generic.pl +++ b/cpan/IO-Compress/t/compress/generic.pl @@ -9,8 +9,8 @@ use CompTestUtils; our ($UncompressClass); -BEGIN -{ +BEGIN +{ # use Test::NoWarnings, if available my $extra = 0 ; @@ -27,10 +27,10 @@ sub myGZreadFile my $init = shift ; - my $fil = new $UncompressClass $filename, + my $fil = $UncompressClass->can('new')->( $UncompressClass, $filename, -Strict => 0, -Append => 1 - ; + ); my $data = ''; $data = $init if defined $init ; @@ -53,13 +53,13 @@ sub run title "Testing $CompressClass Errors"; # Buffer not writable - eval qq[\$a = new $CompressClass(\\1) ;] ; + eval qq[\$a = $CompressClass->new(\\1) ;] ; like $@, mkEvalErr("^$CompressClass: output buffer is read-only") ; - + my($out, $gz); - + my $x ; - $gz = new $CompressClass(\$x); + $gz = $CompressClass->can('new')->($CompressClass, \$x); foreach my $name (qw(read readline getc)) { @@ -83,20 +83,20 @@ sub run my $out = "" ; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); ok ! -e $name, " $name does not exist"; - - $a = new $UncompressClass "$name" ; + + $a = $UncompressClass->can('new')->( $UncompressClass, "$name" ); is $a, undef; my $gc ; - my $guz = new $CompressClass(\$gc); + my $guz = $CompressClass->can('new')->( $CompressClass, \$gc); $guz->write("abc") ; $guz->close(); my $x ; - my $gz = new $UncompressClass(\$gc); + my $gz = $UncompressClass->can('new')->( $UncompressClass, \$gc); foreach my $name (qw(print printf write)) { @@ -114,14 +114,14 @@ sub run my ($a, $x, @x) = ("","","") ; # Buffer not a scalar reference - eval qq[\$a = new $CompressClass \\\@x ;] ; + eval qq[\$a = $CompressClass->new( \\\@x );] ; like $@, mkEvalErr("^$CompressClass: output parameter not a filename, filehandle or scalar ref"); - + # Buffer not a scalar reference - eval qq[\$a = new $UncompressClass \\\@x ;] ; + eval qq[\$a = $UncompressClass->new( \\\@x );] ; like $@, mkEvalErr("^$UncompressClass: input parameter not a filename, filehandle, array ref or scalar ref"); } - + foreach my $Type ( $CompressClass, $UncompressClass) { # Check error handling with IO::Compress::Deflate and IO::Uncompress::Inflate @@ -129,27 +129,27 @@ sub run my ($a, $x, @x) = ("","","") ; # Odd number of parameters - eval qq[\$a = new $Type "abc", -Output ] ; + eval qq[\$a = $Type->new( "abc", -Output ) ] ; like $@, mkEvalErr("^$Type: Expected even number of parameters, got 1"); # Unknown parameter - eval qq[\$a = new $Type "anc", -Fred => 123 ;] ; + eval qq[\$a = $Type->new( "anc", -Fred => 123 );] ; like $@, mkEvalErr("^$Type: unknown key value\\(s\\) Fred"); # no in or out param - eval qq[\$a = new $Type ;] ; + eval qq[\$a = $Type->new();] ; like $@, mkEvalErr("^$Type: Missing (Input|Output) parameter"); - } + } { - # write a very simple compressed file - # and read back + # write a very simple compressed file + # and read back #======================================== - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $hello = <can('new')->( $CompressClass, $name ); is $x->autoflush(1), 0, "autoflush"; is $x->autoflush(1), 1, "autoflush"; ok $x->opened(), "opened"; @@ -171,7 +171,7 @@ sub run { my $uncomp; - ok my $x = new $UncompressClass $name, -Append => 1 ; + ok my $x = $UncompressClass->can('new')->( $UncompressClass, $name, -Append => 1 ); ok $x->opened(), "opened"; my $len ; @@ -187,12 +187,12 @@ sub run } { - # write a very simple compressed file - # and read back + # write a very simple compressed file + # and read back #======================================== - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $hello = <can('new')->( $CompressClass, $name ); is $x->write(''), 0, "Write empty string is ok"; is $x->write(undef), 0, "Write undef is ok"; @@ -211,7 +211,7 @@ sub run { my $uncomp; - my $x = new $UncompressClass $name ; + my $x = $UncompressClass->can('new')->( $UncompressClass, $name ); ok $x, "creates $UncompressClass $name" ; my $data = ''; @@ -225,11 +225,11 @@ sub run { # write a very simple file with using an IO filehandle - # and read back + # and read back #======================================== - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $hello = <$name" ; + my $fh = IO::File->new( ">$name" ); ok $fh, "opened file $name ok"; - my $x = new $CompressClass $fh ; + my $x = $CompressClass->can('new')->( $CompressClass, $fh ); ok $x, " created $CompressClass $fh" ; is $x->fileno(), fileno($fh), "fileno match" ; @@ -254,8 +254,8 @@ sub run my $uncomp; { my $x ; - ok my $fh1 = new IO::File "<$name" ; - ok $x = new $UncompressClass $fh1, -Append => 1 ; + ok my $fh1 = IO::File->new( "<$name" ); + ok $x = $UncompressClass->can('new')->( $UncompressClass, $fh1, -Append => 1 ); ok $x->fileno() == fileno $fh1 ; 1 while $x->read($uncomp) > 0 ; @@ -268,11 +268,11 @@ sub run { # write a very simple file with using a glob filehandle - # and read back + # and read back #======================================== - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); #my $name = "/tmp/fred"; my $hello = <$name" ; - - my $x = new $CompressClass *FH ; + + my $x = $CompressClass->can('new')->( $CompressClass, *FH ); ok $x, " create $CompressClass" ; is $x->fileno(), fileno(*FH), " fileno" ; @@ -299,10 +299,10 @@ sub run my $uncomp; { - title "$UncompressClass: Input from typeglob filehandle, append output"; + title "$UncompressClass: Input from typeglob filehandle, append output"; my $x ; ok open FH, "<$name" ; - ok $x = new $UncompressClass *FH, -Append => 1, Transparent => 0 + ok $x = $UncompressClass->can('new')->( $UncompressClass, *FH, -Append => 1, Transparent => 0 ) or diag $$UnError ; is $x->fileno(), fileno FH, " fileno ok" ; @@ -316,7 +316,7 @@ sub run } { - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); #my $name = "/tmp/fred"; my $hello = <&STDOUT"); my $dummy = fileno SAVEOUT; open STDOUT, ">$name" ; - - my $x = new $CompressClass '-' ; + + my $x = $CompressClass->can('new')->( $CompressClass, '-' ); $x->write($hello); $x->close; @@ -343,7 +343,7 @@ sub run #hexDump($name); { - title "Input from stdin via filename '-'"; + title "Input from stdin via filename '-'"; my $x ; my $uncomp ; @@ -352,7 +352,7 @@ sub run open(SAVEIN, "<&STDIN"); ok open(STDIN, "<$name"), " redirect STDIN"; my $dummy = fileno SAVEIN; - $x = new $UncompressClass '-', Append => 1, Transparent => 0 + $x = $UncompressClass->can('new')->( $UncompressClass, '-', Append => 1, Transparent => 0 ) or diag $$UnError ; ok $x, " created object" ; is $x->fileno(), $stdinFileno, " fileno ok" ; @@ -366,12 +366,12 @@ sub run } { - # write a compressed file to memory - # and read back + # write a compressed file to memory + # and read back #======================================== #my $name = "test.gz" ; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $hello = <can('new')->( $CompressClass, \$buffer) ; + ok ! defined $x->autoflush(1) ; ok ! defined $x->autoflush(1) ; ok ! defined $x->fileno() ; @@ -391,7 +391,7 @@ sub run ok $x->write($hello) ; ok $x->flush(); ok $x->close ; - + writeFile($name, $buffer) ; #is anyUncompress(\$buffer), $hello, " any ok"; } @@ -400,7 +400,7 @@ sub run my $uncomp; { my $x ; - ok $x = new $UncompressClass(\$buffer, Append => 1) ; + ok $x = $UncompressClass->can('new')->( $UncompressClass, \$buffer, Append => 1) ; ok ! defined $x->autoflush(1) ; ok ! defined $x->autoflush(1) ; @@ -422,17 +422,17 @@ sub run my $buffer = ''; { my $x ; - $x = new $CompressClass(\$buffer); + $x = $CompressClass->can('new')->( $CompressClass, \$buffer); ok $x, "new $CompressClass" ; ok $x->close, "close ok" ; - + } my $keep = $buffer ; my $uncomp= ''; { my $x ; - ok $x = new $UncompressClass(\$buffer, Append => 1) ; + ok $x = $UncompressClass->can('new')->( $UncompressClass, \$buffer, Append => 1) ; 1 while $x->read($uncomp) > 0 ; @@ -449,7 +449,7 @@ sub run #======================================== - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $hello = <can('new')->( $CompressClass, $name ); ok $x, " created $CompressClass object"; ok $x->write($hello), " write ok" ; @@ -492,7 +492,7 @@ sub run skip "zstd doesn't support trailing data", 11 if $CompressClass =~ /zstd/i ; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $hello = <$name" ; + ok $fh = IO::File->new( ">$name" ); print $fh $header ; my $x ; - ok $x = new $CompressClass $fh, - -AutoClose => 0 ; + ok $x = $CompressClass->can('new')->( $CompressClass, $fh, + -AutoClose => 0 ); ok $x->binmode(); ok $x->write($hello) ; @@ -519,12 +519,12 @@ sub run my ($fil, $uncomp) ; my $fh1 ; - ok $fh1 = new IO::File "<$name" ; + ok $fh1 = IO::File->new( "<$name" ); # skip leading junk my $line = <$fh1> ; ok $line eq $header ; - ok my $x = new $UncompressClass $fh1, Append => 1 ; + ok my $x = $UncompressClass->can('new')->( $UncompressClass, $fh1, Append => 1 ); ok $x->binmode(); 1 while $x->read($uncomp) > 0 ; @@ -554,7 +554,7 @@ sub run my $compressed ; { - ok my $x = new $CompressClass(\$compressed); + ok my $x = $CompressClass->can('new')->( $CompressClass, \$compressed); ok $x->write($hello) ; ok $x->close ; @@ -562,7 +562,7 @@ sub run } my $uncomp; - ok my $x = new $UncompressClass(\$compressed, Append => 1) ; + ok my $x = $UncompressClass->can('new')->( $UncompressClass, \$compressed, Append => 1) ; 1 while $x->read($uncomp) > 0 ; ok $uncomp eq $hello ; @@ -574,7 +574,7 @@ sub run # Write # these tests come almost 100% from IO::String - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $io = $CompressClass->new($name); @@ -604,7 +604,7 @@ sub run } my $foo = "1234567890"; - + is $io->syswrite($foo, length($foo)), length($foo), " syswrite ok" ; if ( $] < 5.6 ) { is $io->syswrite($foo, length $foo), length $foo, " syswrite ok" } @@ -643,22 +643,22 @@ sub run EOT - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my %opts = () ; - my $iow = new $CompressClass $name, %opts; - is $iow->input_line_number, undef; + my $iow = $CompressClass->can('new')->( $CompressClass, $name, %opts ); + is $iow->input_line_number, undef; $iow->print($str) ; - is $iow->input_line_number, undef; + is $iow->input_line_number, undef; $iow->close ; my @tmp; my $buf; { - my $io = new $UncompressClass $name ; - - is $., 0; - is $io->input_line_number, 0; + my $io = $UncompressClass->can('new')->( $UncompressClass, $name ); + + is $., 0; + is $io->input_line_number, 0; ok ! $io->eof, "eof"; is $io->tell(), 0, "tell 0" ; #my @lines = <$io>; @@ -667,10 +667,10 @@ sub run or print "# Got " . scalar(@lines) . " lines, expected 6\n" ; is $lines[1], "of a paragraph\n" ; is join('', @lines), $str ; - is $., 6; - is $io->input_line_number, 6; + is $., 6; + is $io->input_line_number, 6; is $io->tell(), length($str) ; - + ok $io->eof; ok ! ( defined($io->getline) || @@ -679,44 +679,44 @@ sub run defined($io->getc) || $io->read($buf, 100) != 0) ; } - - + + { local $/; # slurp mode my $io = $UncompressClass->new($name); - is $., 0, "line 0"; - is $io->input_line_number, 0; + is $., 0, "line 0"; + is $io->input_line_number, 0; ok ! $io->eof, "eof"; my @lines = $io->getlines; - is $., 1, "line 1"; - is $io->input_line_number, 1, "line number 1"; + is $., 1, "line 1"; + is $io->input_line_number, 1, "line number 1"; ok $io->eof, "eof" ; ok @lines == 1 && $lines[0] eq $str; - + $io = $UncompressClass->new($name); ok ! $io->eof; my $line = $io->getline(); ok $line eq $str; ok $io->eof; } - + { local $/ = ""; # paragraph mode my $io = $UncompressClass->new($name); - is $., 0; - is $io->input_line_number, 0; + is $., 0; + is $io->input_line_number, 0; ok ! $io->eof; my @lines = $io->getlines(); - is $., 2; - is $io->input_line_number, 2; + is $., 2; + is $io->input_line_number, 2; ok $io->eof; - ok @lines == 2 + ok @lines == 2 or print "# Got " . scalar(@lines) . " lines, expected 2\n" ; ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" or print "# $lines[0]\n"; ok $lines[1] eq "and a single line.\n\n"; } - + { # Record mode my $reclen = 7 ; @@ -725,15 +725,15 @@ sub run local $/ = \$reclen; my $io = $UncompressClass->new($name); - is $., 0; - is $io->input_line_number, 0; + is $., 0; + is $io->input_line_number, 0; ok ! $io->eof; my @lines = $io->getlines(); - is $., $expected_records; - is $io->input_line_number, $expected_records; + is $., $expected_records; + is $io->input_line_number, $expected_records; ok $io->eof; - is @lines, $expected_records, + is @lines, $expected_records, "Got $expected_records records\n" ; ok $lines[0] eq substr($str, 0, $reclen) or print "# $lines[0]\n"; @@ -751,26 +751,26 @@ sub run push(@lines, $a); $err++ if $. != ++$no; } - + ok $err == 0 ; ok $io->eof; - - is $., 3; - is $io->input_line_number, 3; - ok @lines == 3 + + is $., 3; + is $io->input_line_number, 3; + ok @lines == 3 or print "# Got " . scalar(@lines) . " lines, expected 3\n" ; ok join("-", @lines) eq "This- is- an example\n" . "of a paragraph\n\n\n" . "and a single line.\n\n"; } - - + + # Test read - + { my $io = $UncompressClass->new($name); - + eval { $io->read(1) } ; like $@, mkErr("buffer parameter is read-only"); @@ -781,18 +781,18 @@ sub run is $io->read($buf, 3), 3 ; is $buf, "Thi"; - + is $io->sysread($buf, 3, 2), 3 ; is $buf, "Ths i" or print "# [$buf]\n" ;; ok ! $io->eof; - + $buf = "ab" ; is $io->read($buf, 3, 4), 3 ; is $buf, "ab" . "\x00" x 2 . "s a" or print "# [$buf]\n" ;; ok ! $io->eof; - + # read the rest of the file $buf = ''; my $remain = length($str) - 9; @@ -812,15 +812,15 @@ sub run ok $io->eof; # $io->seek(-4, 2); - # + # # ok ! $io->eof; - # + # # ok read($io, $buf, 20) == 4 ; # ok $buf eq "e.\n\n"; - # + # # ok read($io, $buf, 20) == 0 ; # ok $buf eq ""; - # + # # ok ! $io->eof; } @@ -837,25 +837,25 @@ sub run and a single line. EOT - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); writeFile($name, $str); my @tmp; my $buf; { - my $io = new $UncompressClass $name, -Transparent => 1 ; - + my $io = $UncompressClass->can('new')->( $UncompressClass, $name, -Transparent => 1 ); + isa_ok $io, $UncompressClass ; ok ! $io->eof, "eof"; is $io->tell(), 0, "tell == 0" ; my @lines = $io->getlines(); - is @lines, 6, "got 6 lines"; + is @lines, 6, "got 6 lines"; ok $lines[1] eq "of a paragraph\n" ; ok join('', @lines) eq $str ; - is $., 6; - is $io->input_line_number, 6; + is $., 6; + is $io->input_line_number, 6; ok $io->tell() == length($str) ; - + ok $io->eof; ok ! ( defined($io->getline) || @@ -864,42 +864,42 @@ sub run defined($io->getc) || $io->read($buf, 100) != 0) ; } - - + + { local $/; # slurp mode my $io = $UncompressClass->new($name); ok ! $io->eof; my @lines = $io->getlines; - is $., 1; - is $io->input_line_number, 1; + is $., 1; + is $io->input_line_number, 1; ok $io->eof; ok @lines == 1 && $lines[0] eq $str; - + $io = $UncompressClass->new($name); ok ! $io->eof; my $line = $io->getline; - is $., 1; - is $io->input_line_number, 1; + is $., 1; + is $io->input_line_number, 1; is $line, $str; ok $io->eof; } - + { local $/ = ""; # paragraph mode my $io = $UncompressClass->new($name); ok ! $io->eof; my @lines = $io->getlines; - is $., 2; - is $io->input_line_number, 2; + is $., 2; + is $io->input_line_number, 2; ok $io->eof; - ok @lines == 2 + ok @lines == 2 or print "# expected 2 lines, got " . scalar(@lines) . "\n"; ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" or print "# [$lines[0]]\n" ; ok $lines[1] eq "and a single line.\n\n"; } - + { # Record mode my $reclen = 7 ; @@ -908,15 +908,15 @@ sub run local $/ = \$reclen; my $io = $UncompressClass->new($name); - is $., 0; - is $io->input_line_number, 0; + is $., 0; + is $io->input_line_number, 0; ok ! $io->eof; my @lines = $io->getlines(); - is $., $expected_records; - is $io->input_line_number, $expected_records; + is $., $expected_records; + is $io->input_line_number, $expected_records; ok $io->eof; - is @lines, $expected_records, + is @lines, $expected_records, "Got $expected_records records\n" ; ok $lines[0] eq substr($str, 0, $reclen) or print "# $lines[0]\n"; @@ -934,12 +934,12 @@ sub run push(@lines, $a); $err++ if $. != ++$no; } - - is $., 3; - is $io->input_line_number, 3; + + is $., 3; + is $io->input_line_number, 3; ok $err == 0 ; ok $io->eof; - + ok @lines == 3 ; ok join("-", @lines) eq @@ -947,30 +947,30 @@ sub run "of a paragraph\n\n\n" . "and a single line.\n\n"; } - - + + # Test Read - + { my $io = $UncompressClass->new($name); - + $buf = "abcd"; is $io->read($buf, 0), 0, "Requested 0 bytes" ; is $buf, "", "Buffer empty"; ok $io->read($buf, 3) == 3 ; ok $buf eq "Thi"; - + ok $io->sysread($buf, 3, 2) == 3 ; ok $buf eq "Ths i"; ok ! $io->eof; - + $buf = "ab" ; is $io->read($buf, 3, 4), 3 ; is $buf, "ab" . "\x00" x 2 . "s a" or print "# [$buf]\n" ;; ok ! $io->eof; - + # read the rest of the file $buf = ''; my $remain = length($str) - 9; @@ -990,15 +990,15 @@ sub run ok $io->eof; # $io->seek(-4, 2); - # + # # ok ! $io->eof; - # + # # ok read($io, $buf, 20) == 4 ; # ok $buf eq "e.\n\n"; - # + # # ok read($io, $buf, 20) == 0 ; # ok $buf eq ""; - # + # # ok ! $io->eof; } @@ -1029,24 +1029,24 @@ sub run { title "Read Tests - buf length $bufsize, Transparent $trans, Append $append" ; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); if ($trans) { writeFile($name, $str) ; } else { - my $iow = new $CompressClass $name; + my $iow = $CompressClass->can('new')->( $CompressClass, $name ); $iow->print($str) ; $iow->close ; } - - my $io = $UncompressClass->new($name, + + my $io = $UncompressClass->new($name, -Append => $append, -Transparent => $trans); - + my $buf; - + is $io->tell(), 0; if ($append) { @@ -1073,7 +1073,7 @@ sub run my $buffer ; my $buff ; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $first = "beginning" ; my $last = "the end" ; @@ -1095,7 +1095,7 @@ sub run $output = \$buffer; } - my $iow = new $CompressClass $output ; + my $iow = $CompressClass->can('new')->( $CompressClass, $output ); $iow->print($first) ; ok $iow->seek(5, SEEK_CUR) ; ok $iow->tell() == length($first)+5; @@ -1121,7 +1121,7 @@ sub run ok myGZreadFile($input) eq $first . "\x00" x 10 . $last ; my $io = $UncompressClass->new($input, Strict => 1); - ok $io->seek(length($first), SEEK_CUR) + ok $io->seek(length($first), SEEK_CUR) or diag $$UnError ; ok ! $io->eof; is $io->tell(), length($first); @@ -1146,9 +1146,9 @@ sub run title "seek error cases" ; my $b ; - my $a = new $CompressClass(\$b) ; + my $a = $CompressClass->can('new')->( $CompressClass, \$b) ; - ok ! $a->error() + ok ! $a->error() or die $a->error() ; eval { $a->seek(-1, 10) ; }; like $@, mkErr("^${CompressClass}::seek: unknown value, 10, for whence parameter"); @@ -1160,7 +1160,7 @@ sub run $a->close ; - my $u = new $UncompressClass(\$b) ; + my $u = $UncompressClass->can('new')->( $UncompressClass, \$b) ; eval { $u->seek(-1, 10) ; }; like $@, mkErr("^${UncompressClass}::seek: unknown value, 10, for whence parameter"); @@ -1171,7 +1171,7 @@ sub run eval { $u->seek(-1, SEEK_CUR) ; }; like $@, mkErr("^${UncompressClass}::seek: cannot seek backwards"); } - + foreach my $fb (qw(filename buffer filehandle)) { foreach my $append (0, 1) @@ -1179,7 +1179,7 @@ sub run { title "$CompressClass -- Append $append, Output to $fb" ; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $already = 'already'; my $buffer = $already; @@ -1194,17 +1194,17 @@ sub run } elsif ($fb eq 'filehandle') { - $output = new IO::File ">$name" ; + $output = IO::File->new( ">$name" ); print $output $buffer; } - my $a = new $CompressClass($output, Append => $append) ; + my $a = $CompressClass->can('new')->( $CompressClass, $output, Append => $append) ; ok $a, " Created $CompressClass"; my $string = "appended"; $a->write($string); $a->close ; - my $data ; + my $data ; if ($fb eq 'buffer') { $data = $buffer; @@ -1224,7 +1224,7 @@ sub run my $uncomp; - my $x = new $UncompressClass(\$data, Append => 1) ; + my $x = $UncompressClass->can('new')->( $UncompressClass, \$data, Append => 1) ; ok $x, " created $UncompressClass"; my $len ; @@ -1232,7 +1232,7 @@ sub run $x->close ; is $uncomp, $string, ' Got uncompressed data' ; - + } } } @@ -1243,13 +1243,13 @@ sub run { title "$UncompressClass -- InputLength, read from $type, good data => $good"; - my $compressed ; + my $compressed ; my $string = "some data"; my $appended = "append"; if ($good) { - my $c = new $CompressClass(\$compressed); + my $c = $CompressClass->can('new')->( $CompressClass, \$compressed); $c->write($string); $c->close(); } @@ -1261,7 +1261,7 @@ sub run my $comp_len = length $compressed; $compressed .= $appended; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $input ; writeFile ($name, $compressed); @@ -1275,12 +1275,12 @@ sub run } elsif ($type eq 'filehandle') { - my $fh = new IO::File "<$name" ; + my $fh = IO::File->new( "<$name" ); ok $fh, "opened file $name ok"; $input = $fh ; } - my $x = new $UncompressClass($input, + my $x = $UncompressClass->can('new')->( $UncompressClass, $input, InputLength => $comp_len, Transparent => 1) ; ok $x, " created $UncompressClass"; @@ -1302,20 +1302,20 @@ sub run } - + foreach my $append (0, 1) { title "$UncompressClass -- Append $append" ; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $string = "appended"; - my $compressed ; - my $c = new $CompressClass(\$compressed); + my $compressed ; + my $c = $CompressClass->can('new')->( $CompressClass, \$compressed); $c->write($string); $c->close(); - my $x = new $UncompressClass(\$compressed, Append => $append) ; + my $x = $UncompressClass->can('new')->( $UncompressClass, \$compressed, Append => $append) ; ok $x, " created $UncompressClass"; my $already = 'already'; @@ -1334,7 +1334,7 @@ sub run } is $output, $string, ' Got uncompressed data' ; } - + foreach my $file (0, 1) { @@ -1342,7 +1342,7 @@ sub run { title "ungetc, File $file, Transparent $trans" ; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $string = 'abcdeABCDE'; my $b ; @@ -1352,7 +1352,7 @@ sub run } else { - my $a = new $CompressClass(\$b) ; + my $a = $CompressClass->can('new')->( $CompressClass, \$b) ; $a->write($string); $a->close ; } @@ -1399,7 +1399,7 @@ sub run ok ! $u->eof(); is $u->read($buff), length($extra) ; is $buff, $extra; - + is $u->read($buff, 1), 0; ok $u->eof() ; @@ -1413,19 +1413,19 @@ sub run { title "write tests - invalid data" ; - #my $lex = new LexFile my $name1 ; + #my $lex = LexFile->new( my $name1 ); my($Answer); #ok ! -e $name1, " File $name1 does not exist"; my @data = ( - [ '{ }', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ], - [ '[ { } ]', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ], - [ '[ [ { } ] ]', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ], - [ '[ "" ]', "${CompressClass}::write: input filename is undef or null string" ], - [ '[ undef ]', "${CompressClass}::write: input filename is undef or null string" ], - [ '[ \$Answer ]',"${CompressClass}::write: input and output buffer are identical" ], - #[ "not readable", 'xx' ], + [ '{ }', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ], + [ '[ { } ]', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ], + [ '[ [ { } ] ]', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ], + [ '[ "" ]', "${CompressClass}::write: input filename is undef or null string" ], + [ '[ undef ]', "${CompressClass}::write: input filename is undef or null string" ], + [ '[ \$Answer ]',"${CompressClass}::write: input and output buffer are identical" ], + #[ "not readable", 'xx' ], # same filehandle twice, 'xx' ) ; @@ -1435,7 +1435,7 @@ sub run title "${CompressClass}::write( $send )"; my($copy); eval "\$copy = $send"; - my $x = new $CompressClass(\$Answer); + my $x = $CompressClass->can('new')->( $CompressClass, \$Answer); ok $x, " Created $CompressClass object"; eval { $x->write($copy) } ; #like $@, "/^$get/", " error - $get"; @@ -1443,8 +1443,8 @@ sub run } # @data = ( - # [ '[ $name1 ]', "input file '$name1' does not exist" ], - # #[ "not readable", 'xx' ], + # [ '[ $name1 ]', "input file '$name1' does not exist" ], + # #[ "not readable", 'xx' ], # # same filehandle twice, 'xx' # ) ; # @@ -1454,14 +1454,14 @@ sub run # title "${CompressClass}::write( $send )"; # my $copy; # eval "\$copy = $send"; - # my $x = new $CompressClass(\$Answer); + # my $x = $CompressClass->can('new')->( $CompressClass, \$Answer); # ok $x, " Created $CompressClass object"; # ok ! $x->write($copy), " write fails" ; # like $$Error, "/^$get/", " error - $get"; # } #exit; - + } @@ -1495,17 +1495,17 @@ sub run # # if (! ref $_[0]) # { - # $_[0] = $to + # $_[0] = $to # if $_[0] eq $from ; - # return ; + # return ; # # } # # if (ref $_[0] eq 'SCALAR') # { - # $_[0] = \$to + # $_[0] = \$to # if defined ${ $_[0] } && ${ $_[0] } eq $from ; - # return ; + # return ; # # } # @@ -1526,7 +1526,7 @@ sub run # my $file1 = "file1" ; # my $file2 = "file2" ; # my $file3 = "file3" ; - # my $lex = new LexFile $file1, $file2, $file3 ; + # my $lex = LexFile->new( $file1, $file2, $file3 ); # # writeFile($file1, "F1"); # writeFile($file2, "F2"); @@ -1564,15 +1564,15 @@ sub run # { # my ($send, $get) = @$data ; # - # my $fh1 = new IO::File "< $file1" ; - # my $fh2 = new IO::File "< $file2" ; - # my $fh3 = new IO::File "< $file3" ; + # my $fh1 = IO::File->new( "< $file1" ); + # my $fh2 = IO::File->new( "< $file2" ); + # my $fh3 = IO::File->new( "< $file3" ); # # title "${CompressClass}::write( $send )"; # my $copy; # eval "\$copy = $send"; # my $Answer ; - # my $x = new $CompressClass(\$Answer); + # my $x = $CompressClass->can('new')->( $CompressClass, \$Answer); # ok $x, " Created $CompressClass object"; # my $len = length $get; # is $x->write($copy), length($get), " write $len bytes"; @@ -1583,7 +1583,7 @@ sub run # # # } - # + # # } } @@ -1599,15 +1599,15 @@ sub run my $appended = "append"; my $string = "some data"; - my $compressed ; + my $compressed ; - my $c = new $CompressClass(\$compressed); + my $c = $CompressClass->can('new')->( $CompressClass, \$compressed); $c->close(); my $comp_len = length $compressed; $compressed .= $appended if $append && $CompressClass !~ /zstd/i; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $input ; writeFile ($name, $compressed); @@ -1621,7 +1621,7 @@ sub run } elsif ($type eq 'filehandle') { - my $fh = new IO::File "<$name" ; + my $fh = IO::File->new( "<$name" ); ok $fh, "opened file $name ok"; $input = $fh ; } @@ -1632,7 +1632,7 @@ sub run # Check that readline returns undef - my $x = new $UncompressClass $input, Transparent => 0 + my $x = $UncompressClass->can('new')->( $UncompressClass, $input, Transparent => 0 ) or diag "$$UnError" ; isa_ok $x, $UncompressClass; @@ -1648,12 +1648,12 @@ sub run # Check that read returns an empty string if ($type eq 'filehandle') { - my $fh = new IO::File "<$name" ; + my $fh = IO::File->new( "<$name" ); ok $fh, "opened file $name ok"; $input = $fh ; } - my $x = new $UncompressClass $input, Transparent => 0 + my $x = $UncompressClass->can('new')->( $UncompressClass, $input, Transparent => 0 ) or diag "$$UnError" ; isa_ok $x, $UncompressClass; @@ -1672,12 +1672,12 @@ sub run if ($type eq 'filehandle') { - my $fh = new IO::File "<$name" ; + my $fh = IO::File->new( "<$name" ); ok $fh, "opened file $name ok"; $input = $fh ; } - my $x = new $UncompressClass $input, Transparent => 0, - Append => 1 + my $x = $UncompressClass->can('new')->( $UncompressClass, $input, Transparent => 0, + Append => 1 ) or diag "$$UnError" ; isa_ok $x, $UncompressClass; @@ -1694,11 +1694,11 @@ sub run if ($type eq 'filehandle') { - my $fh = new IO::File "<$name" ; + my $fh = IO::File->new( "<$name" ); ok $fh, "opened file $name ok"; $input = $fh ; } - my $x = new $UncompressClass($input, Append => 1 ); + my $x = $UncompressClass->can('new')->( $UncompressClass, $input, Append => 1 ); isa_ok $x, $UncompressClass; my $buffer = "123"; @@ -1718,30 +1718,30 @@ sub run my $original = join '', map { chr } 0x00 .. 0xff ; $original .= "data1\r\ndata2\r\ndata3\r\n" ; - - + + title "$UncompressClass -- round trip test"; my $string = $original; - my $lex = new LexFile( my $name, my $compressed) ; + my $lex = LexFile->new( my $name, my $compressed) ; my $input ; writeFile ($name, $original); - my $c = new $CompressClass($compressed); + my $c = $CompressClass->can('new')->( $CompressClass, $compressed); isa_ok $c, $CompressClass; $c->print($string); $c->close(); - my $u = new $UncompressClass $compressed, Transparent => 0 + my $u = $UncompressClass->can('new')->( $UncompressClass, $compressed, Transparent => 0 ) or diag "$$UnError" ; isa_ok $u, $UncompressClass; my $buffer; is $u->read($buffer), length($original), "read bytes"; is $buffer, $original, " round tripped ok"; - - } + + } } 1; diff --git a/cpan/IO-Compress/t/compress/merge.pl b/cpan/IO-Compress/t/compress/merge.pl index 9cb359c1097f..a0442ed04150 100644 --- a/cpan/IO-Compress/t/compress/merge.pl +++ b/cpan/IO-Compress/t/compress/merge.pl @@ -3,15 +3,15 @@ use warnings; use bytes; -use Test::More ; +use Test::More ; use CompTestUtils; use Compress::Raw::Zlib 2 ; -BEGIN -{ - plan(skip_all => "Merge needs Zlib 1.2.1 or better - you have Zlib " - . Compress::Raw::Zlib::zlib_version()) +BEGIN +{ + plan(skip_all => "Merge needs Zlib 1.2.1 or better - you have Zlib " + . Compress::Raw::Zlib::zlib_version()) if ZLIB_VERNUM() < 0x1210 ; # use Test::NoWarnings, if available @@ -32,7 +32,7 @@ sub run my $Error = getErrorRef($CompressClass); my $UnError = getErrorRef($UncompressClass); - # Tests + # Tests # destination is a file that doesn't exist -- should work ok unless AnyDeflate # destination isn't compressed at all # destination is compressed but wrong format @@ -43,7 +43,7 @@ sub run { title "Misc error cases"; - eval { new Compress::Raw::Zlib::InflateScan Bufsize => 0} ; + eval { Compress::Raw::Zlib::InflateScan->new( Bufsize => 0 ) } ; like $@, mkErr("^Compress::Raw::Zlib::InflateScan::new: Bufsize must be >= 1, you specified 0"), " catch bufsize == 0"; eval { Compress::Raw::Zlib::inflateScanStream::createDeflateStream(undef, Bufsize => 0) } ; @@ -58,23 +58,23 @@ sub run { if ($to_file) { title "$CompressClass - Merge to filename that isn't writable" } - else + else { title "$CompressClass - Merge to filehandle that isn't writable" } - my $lex = new LexFile my $out_file ; + my $lex = LexFile->new( my $out_file ); # create empty file open F, ">$out_file" ; print F "x"; close F; ok -e $out_file, " file exists" ; ok !-z $out_file, " and is not empty" ; - + # make unwritable is chmod(0444, $out_file), 1, " chmod worked" ; ok -e $out_file, " still exists after chmod" ; SKIP: { - skip "Cannot create non-writable file", 3 + skip "Cannot create non-writable file", 3 if -w $out_file ; ok ! -w $out_file, " chmod made file unwritable" ; @@ -83,10 +83,10 @@ sub run if ($to_file) { $dest = $out_file } else - { $dest = new IO::File "<$out_file" } + { $dest = IO::File->new( "<$out_file" ) } my $gz = $CompressClass->new($dest, Merge => 1) ; - + ok ! $gz, " Did not create $CompressClass object"; ok $$Error, " Got error message" ; @@ -99,7 +99,7 @@ sub run # output is not compressed at all { - my $lex = new LexFile my $out_file ; + my $lex = LexFile->new( my $out_file ); foreach my $to_file ( qw(buffer file handle ) ) { @@ -120,7 +120,7 @@ sub run if ($to_file eq 'handle') { - $buffer = new IO::File "+<$out_file" + $buffer = IO::File->new( "+<$out_file" ) or die "# Cannot open $out_file: $!"; } else @@ -138,7 +138,7 @@ sub run # output is empty { - my $lex = new LexFile my $out_file ; + my $lex = LexFile->new( my $out_file ); foreach my $to_file ( qw(buffer file handle ) ) { @@ -159,7 +159,7 @@ sub run if ($to_file eq 'handle') { - $buffer = new IO::File "+<$out_file" + $buffer = IO::File->new( "+<$out_file" ) or die "# Cannot open $out_file: $!"; } else @@ -182,12 +182,12 @@ sub run { title "$CompressClass - Merge to file that doesn't exist"; - my $lex = new LexFile my $out_file ; - + my $lex = LexFile->new( my $out_file ); + ok ! -e $out_file, " Destination file, '$out_file', does not exist"; - ok my $gz1 = $CompressClass->new($out_file, Merge => 1) - or die "# $CompressClass->new failed: $$Error\n"; + ok my $gz1 = $CompressClass->can('new')->( $CompressClass, $out_file, Merge => 1) + or die "# $CompressClass->new(...) failed: $$Error\n"; #hexDump($buffer); $gz1->write("FGHI"); $gz1->close(); @@ -200,13 +200,13 @@ sub run { - my $lex = new LexFile my $out_file ; + my $lex = LexFile->new( my $out_file ); foreach my $to_file ( qw( buffer file handle ) ) { foreach my $content (undef, '', 'x', 'abcde') { - #next if ! defined $content && $to_file; + #next if ! defined $content && $to_file; my $buffer ; my $disp_content = defined $content ? $content : '' ; @@ -245,10 +245,10 @@ sub run # #} - my $dest = $buffer ; + my $dest = $buffer ; if ($to_file eq 'handle') { - $dest = new IO::File "+<$buffer" ; + $dest = IO::File->new( "+<$buffer" ); } my $gz1 = $CompressClass->new($dest, Merge => 1, AutoClose => 1) @@ -278,7 +278,7 @@ sub run my $buffer ; - my $lex = new LexFile my $out_file ; + my $lex = LexFile->new( my $out_file ); foreach my $to_file (0, 1) { @@ -298,7 +298,7 @@ sub run $buffer = \$x ; title "$TopType to Buffer, content is '$disp_content'"; } - + ok $Func->(\$content, $buffer), " Compress content"; #hexDump($buffer); diff --git a/cpan/IO-Compress/t/compress/multi.pl b/cpan/IO-Compress/t/compress/multi.pl index 48129a7c4526..06d78b983a2f 100644 --- a/cpan/IO-Compress/t/compress/multi.pl +++ b/cpan/IO-Compress/t/compress/multi.pl @@ -47,7 +47,7 @@ sub run even more stuff EOM - my $b0length = length $buffers[0]; + my $b0length = length $buffers[0]; my $bufcount = @buffers; { @@ -55,7 +55,7 @@ sub run my $gz ; my $hsize ; my %headers = () ; - + foreach my $fb ( qw( file filehandle buffer ) ) { @@ -71,11 +71,11 @@ sub run Strict => 1, Comment => "this is a comment", ExtraField => ["so" => "me extra"], - HeaderCRC => 1); + HeaderCRC => 1); } - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $output ; if ($fb eq 'buffer') { @@ -84,14 +84,14 @@ sub run } elsif ($fb eq 'filehandle') { - $output = new IO::File ">$name" ; + $output = IO::File->new( ">$name" ); } else { $output = $name ; } - my $x = new $CompressClass($output, AutoClose => 1, %headers); + my $x = $CompressClass->can('new')->($CompressClass, $output, AutoClose => 1, %headers); isa_ok $x, $CompressClass, ' $x' ; foreach my $buffer (@buffs) { @@ -106,12 +106,12 @@ sub run $cc = $output ; if ($fb eq 'filehandle') { - $cc = new IO::File "<$name" ; + $cc = IO::File->new( "<$name" ); } - my @opts = $unc ne $UncompressClass + my @opts = $unc ne $UncompressClass ? (RawInflate => 1) : (); - my $gz = new $unc($cc, + my $gz = $unc->can('new')->($unc, $cc, @opts, Strict => 1, AutoClose => 1, @@ -142,12 +142,12 @@ sub run $cc = $output ; if ($fb eq 'filehandle') { - $cc = new IO::File "<$name" ; + $cc = IO::File->new( "<$name" ); } - my @opts = $unc ne $UncompressClass + my @opts = $unc ne $UncompressClass ? (RawInflate => 1) : (); - my $gz = new $unc($cc, + my $gz = $unc->can('new')->( $unc, $cc, @opts, Strict => 1, AutoClose => 1, @@ -183,12 +183,12 @@ sub run $cc = $output ; if ($fb eq 'filehandle') { - $cc = new IO::File "<$name" ; + $cc = IO::File->new( "<$name" ); } - my @opts = $unc ne $UncompressClass + my @opts = $unc ne $UncompressClass ? (RawInflate => 1) : (); - my $gz = new $unc($cc, + my $gz = $unc->can('new')->( $unc, $cc, @opts, Strict => 1, AutoClose => 1, @@ -210,13 +210,13 @@ sub run $un .= $_; } is $., $lines, " \$. is $lines"; - + ok ! $gz->error(), " ! error()" or diag "Error is " . $gz->error() ; ok $gz->eof(), " eof()"; is $gz->streamCount(), $stream, " streamCount is $stream" or diag "Stream count is " . $gz->streamCount(); - is $un, $buff, " expected output" + is $un, $buff, " expected output" or diag "Stream count is " . $gz->streamCount(); ; #is $gz->tell(), length $buff, " tell is ok"; is $gz->nextStream(), 1, " nextStream ok"; diff --git a/cpan/IO-Compress/t/compress/newtied.pl b/cpan/IO-Compress/t/compress/newtied.pl index 41861e90721c..e5ced1439748 100644 --- a/cpan/IO-Compress/t/compress/newtied.pl +++ b/cpan/IO-Compress/t/compress/newtied.pl @@ -7,12 +7,12 @@ use CompTestUtils; our ($BadPerl, $UncompressClass); - -BEGIN -{ + +BEGIN +{ plan(skip_all => "Extra Tied Filehandle needs Perl 5.6 or better - you have Perl $]" ) if $] < 5.006 ; - + my $tests ; $BadPerl = ($] >= 5.006 and $] <= 5.008) ; @@ -44,10 +44,10 @@ sub myGZreadFile my $init = shift ; - my $fil = new $UncompressClass $filename, + my $fil = $UncompressClass->can('new')->( $UncompressClass, $filename, -Strict => 1, -Append => 1 - ; + ); my $data ; $data = $init if defined $init ; @@ -75,7 +75,7 @@ sub run # Write # these tests come almost 100% from IO::String - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $io = $CompressClass->new($name); @@ -101,7 +101,7 @@ sub run } my $foo = "1234567890"; - + ok syswrite($io, $foo, length($foo)) == length($foo) ; if ( $] < 5.6 ) { is $io->syswrite($foo, length $foo), length $foo } @@ -142,17 +142,17 @@ sub run EOT - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); - my $iow = new $CompressClass $name ; + my $iow = $CompressClass->can('new')->( $CompressClass, $name ); print $iow $str ; close $iow; my @tmp; my $buf; { - my $io = new $UncompressClass $name ; - + my $io = $UncompressClass->can('new')->( $UncompressClass, $name ); + ok ! $io->eof; ok ! eof $io; is $io->tell(), 0 ; @@ -162,11 +162,11 @@ sub run or print "# Got " . scalar(@lines) . " lines, expected 6\n" ; is $lines[1], "of a paragraph\n" ; is join('', @lines), $str ; - is $., 6; + is $., 6; #print "TELL says " . tell($io) , " should be ${ \length($str) }\n" ; is $io->tell(), length($str) ; is tell($io), length($str) ; - + ok $io->eof; ok eof $io; @@ -176,8 +176,8 @@ sub run defined($io->getc) || read($io, $buf, 100) != 0) ; } - - + + { local $/; # slurp mode my $io = $UncompressClass->new($name); @@ -185,27 +185,27 @@ sub run my @lines = $io->getlines; ok $io->eof; ok @lines == 1 && $lines[0] eq $str; - + $io = $UncompressClass->new($name); ok ! $io->eof; my $line = <$io>; ok $line eq $str; ok $io->eof; } - + { local $/ = ""; # paragraph mode my $io = $UncompressClass->new($name); ok ! $io->eof; my @lines = <$io>; ok $io->eof; - ok @lines == 2 + ok @lines == 2 or print "# Got " . scalar(@lines) . " lines, expected 2\n" ; ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" or print "# $lines[0]\n"; ok $lines[1] eq "and a single line.\n\n"; } - + { local $/ = "is"; my $io = $UncompressClass->new($name); @@ -217,26 +217,26 @@ sub run push(@lines, $_); $err++ if $. != ++$no; } - + ok $err == 0 ; ok $io->eof; - - ok @lines == 3 + + ok @lines == 3 or print "# Got " . scalar(@lines) . " lines, expected 3\n" ; ok join("-", @lines) eq "This- is- an example\n" . "of a paragraph\n\n\n" . "and a single line.\n\n"; } - - + + # Test read - + { my $io = $UncompressClass->new($name); ok $io, "opened ok" ; - + #eval { read($io, $buf, -1); } ; #like $@, mkErr("length parameter is negative"), "xxx $io $UncompressClass $RawInflateError" ; @@ -247,22 +247,22 @@ sub run ok read($io, $buf, 3) == 3 ; ok $buf eq "Thi"; - + ok sysread($io, $buf, 3, 2) == 3 ; ok $buf eq "Ths i" or print "# [$buf]\n" ;; ok ! $io->eof; - + # $io->seek(-4, 2); - # + # # ok ! $io->eof; - # + # # ok read($io, $buf, 20) == 4 ; # ok $buf eq "e.\n\n"; - # + # # ok read($io, $buf, 20) == 0 ; # ok $buf eq ""; - # + # # ok ! $io->eof; } @@ -273,11 +273,11 @@ sub run { title "seek tests" ; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $first = "beginning" ; my $last = "the end" ; - my $iow = new $CompressClass $name ; + my $iow = $CompressClass->can('new')->( $CompressClass, $name ); print $iow $first ; ok seek $iow, 10, SEEK_CUR ; is tell($iow), length($first)+10; @@ -305,7 +305,7 @@ sub run { # seek error cases my $b ; - my $a = new $CompressClass(\$b) ; + my $a = $CompressClass->can('new')->( $CompressClass, \$b) ; ok ! $a->error() ; eval { seek($a, -1, 10) ; }; @@ -318,7 +318,7 @@ sub run close $a ; - my $u = new $UncompressClass(\$b) ; + my $u = $UncompressClass->can('new')->( $UncompressClass, \$b) ; eval { seek($u, -1, 10) ; }; like $@, mkErr("seek: unknown value, 10, for whence parameter"); @@ -333,7 +333,7 @@ sub run { title 'fileno' ; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $hello = <$name" ; + ok $fh = IO::File->new( ">$name" ); my $x ; - ok $x = new $CompressClass $fh ; + ok $x = $CompressClass->can('new')->( $CompressClass, $fh ); ok $x->fileno() == fileno($fh) ; ok $x->fileno() == fileno($x) ; @@ -356,8 +356,8 @@ sub run my $uncomp; { my $x ; - ok my $fh1 = new IO::File "<$name" ; - ok $x = new $UncompressClass $fh1, -Append => 1 ; + ok my $fh1 = IO::File->new( "<$name" ); + ok $x = $UncompressClass->can('new')->( $UncompressClass, $fh1, -Append => 1 ); ok $x->fileno() == fileno $fh1 ; ok $x->fileno() == fileno $x ; diff --git a/cpan/IO-Compress/t/compress/oneshot.pl b/cpan/IO-Compress/t/compress/oneshot.pl index 790d1b2b0c6c..7e59fe58edd9 100644 --- a/cpan/IO-Compress/t/compress/oneshot.pl +++ b/cpan/IO-Compress/t/compress/oneshot.pl @@ -73,16 +73,16 @@ sub run my $in ; eval { $a = $Func->($in, \$x) ;} ; - like $@, mkErr("^$TopType: input filename is undef or null string"), + like $@, mkErr("^$TopType: input filename is undef or null string"), ' Input filename undef' ; - $in = ''; + $in = ''; eval { $a = $Func->($in, \$x) ;} ; - like $@, mkErr("^$TopType: input filename is undef or null string"), + like $@, mkErr("^$TopType: input filename is undef or null string"), ' Input filename empty' ; { - my $lex1 = new LexFile my $in ; + my $lex1 = LexFile->new( my $in ); writeFile($in, "abc"); my $out = $in ; eval { $a = $Func->($in, $out) ;} ; @@ -92,7 +92,7 @@ sub run { my $dir ; - my $lex = new LexDir $dir ; + my $lex = LexDir->new( $dir ); my $d = quotemeta $dir; $a = $Func->("$dir", \$x) ; @@ -109,7 +109,7 @@ sub run eval { $a = $Func->(\$in, \$in) ;} ; like $@, mkErr("^$TopType: input and output buffer are identical"), ' Input and Output buffer are the same'; - + SKIP: { # Threaded 5.6.x seems to have a problem comparing filehandles. @@ -118,12 +118,12 @@ sub run skip 'Cannot compare filehandles with threaded $]', 2 if $] >= 5.006 && $] < 5.007 && $Config{useithreads}; - my $lex = new LexFile my $out_file ; + my $lex = LexFile->new( my $out_file ); open OUT, ">$out_file" ; eval { $a = $Func->(\*OUT, \*OUT) ;} ; like $@, mkErr("^$TopType: input and output handle are identical"), ' Input and Output handle are the same'; - + close OUT; is -s $out_file, 0, " File zero length" ; } @@ -137,12 +137,12 @@ sub run eval { $a = $Func->(\$x, $object) ;} ; like $@, mkErr("^$TopType: illegal output parameter"), ' Bad Output Param'; - + # Buffer not a scalar reference eval { $a = $Func->(\$x, \%x) ;} ; like $@, mkErr("^$TopType: illegal output parameter"), ' Bad Output Param'; - + eval { $a = $Func->(\%x, \$x) ;} ; like $@, mkErr("^$TopType: illegal input parameter"), @@ -159,13 +159,13 @@ sub run $a = $Func->($filename, \$x) ; is $a, undef, " $TopType returned undef"; like $$Error, "/^input file '$filename' does not exist\$/", " input File '$filename' does not exist"; - + $filename = '/tmp/abd/abc.def'; ok ! -e $filename, " output File '$filename' does not exist"; $a = $Func->(\$x, $filename) ; is $a, undef, " $TopType returned undef"; like $$Error, ("/^(cannot open file '$filename'|input file '$filename' does not exist):/"), " output File '$filename' does not exist"; - + eval { $a = $Func->(\$x, '') } ; like $$Error, "/Need input fileglob for outout fileglob/", ' Output fileglob with no input fileglob'; @@ -199,7 +199,7 @@ sub run skip '\\ returns mutable value in 5.19.3', 1 if $] >= 5.019003; - + eval { $a = $Func->(\$in, \$out, TrailingData => \"abc") ;} ; like $@, mkErr("^$TopType: Parameter 'TrailingData' not writable"), ' TrailingData output not writable'; @@ -335,7 +335,7 @@ sub run { title "$TopType - From Array Ref to Array Ref content '$disp_content' Append $append" ; - my $lex = new LexFile my $in_file ; + my $lex = LexFile->new( my $in_file ); writeFile($in_file, $buffer); my @output = ('first') ; my @input = ($in_file); @@ -350,7 +350,7 @@ sub run { title "$TopType - From Buff to Filename content '$disp_content' Append $append" ; - my $lex = new LexFile my $out_file ; + my $lex = LexFile->new( my $out_file ); ok ! -e $out_file, " Output file does not exist"; writeFile($out_file, $already); @@ -365,11 +365,11 @@ sub run { title "$TopType - From Buff to Handle content '$disp_content' Append $append" ; - my $lex = new LexFile my $out_file ; + my $lex = LexFile->new( my $out_file ); ok ! -e $out_file, " Output file does not exist"; writeFile($out_file, $already); - my $of = new IO::File ">>$out_file" ; + my $of = IO::File->new( ">>$out_file" ); ok $of, " Created output filehandle" ; ok &$Func(\$buffer, $of, AutoClose => 1, Append => $append), ' Compressed ok' ; @@ -384,7 +384,7 @@ sub run { title "$TopType - From Filename to Filename content '$disp_content' Append $append" ; - my $lex = new LexFile(my $in_file, my $out_file) ; + my $lex = LexFile->new( my $in_file, my $out_file) ; writeFile($in_file, $buffer); ok ! -e $out_file, " Output file does not exist"; @@ -402,12 +402,12 @@ sub run { title "$TopType - From Filename to Handle content '$disp_content' Append $append" ; - my $lex = new LexFile(my $in_file, my $out_file) ; + my $lex = LexFile->new( my $in_file, my $out_file) ; writeFile($in_file, $buffer); ok ! -e $out_file, " Output file does not exist"; writeFile($out_file, $already); - my $out = new IO::File ">>$out_file" ; + my $out = IO::File->new( ">>$out_file" ); ok &$Func($in_file, $out, AutoClose => 1, Append => $append), ' Compressed ok' ; @@ -421,7 +421,7 @@ sub run { title "$TopType - From Filename to Buffer content '$disp_content' Append $append" ; - my $lex = new LexFile(my $in_file, my $out_file) ; + my $lex = LexFile->new( my $in_file, my $out_file) ; writeFile($in_file, $buffer); my $out = $already; @@ -433,18 +433,18 @@ sub run is $got, $buffer, " Uncompressed matches original"; } - + { title "$TopType - From Handle to Filename content '$disp_content' Append $append" ; - my $lex = new LexFile(my $in_file, my $out_file) ; + my $lex = LexFile->new( my $in_file, my $out_file) ; writeFile($in_file, $buffer); - my $in = new IO::File "<$in_file" ; + my $in = IO::File->new( "<$in_file" ); ok ! -e $out_file, " Output file does not exist"; writeFile($out_file, $already); - ok &$Func($in, $out_file, Append => $append), ' Compressed ok' + ok &$Func($in, $out_file, Append => $append), ' Compressed ok' or diag "error is $$Error" ; ok -e $out_file, " Created output file"; @@ -457,13 +457,13 @@ sub run { title "$TopType - From Handle to Handle content '$disp_content' Append $append" ; - my $lex = new LexFile(my $in_file, my $out_file) ; + my $lex = LexFile->new( my $in_file, my $out_file) ; writeFile($in_file, $buffer); - my $in = new IO::File "<$in_file" ; + my $in = IO::File->new( "<$in_file" ); ok ! -e $out_file, " Output file does not exist"; writeFile($out_file, $already); - my $out = new IO::File ">>$out_file" ; + my $out = IO::File->new( ">>$out_file" ); ok &$Func($in, $out, AutoClose => 1, Append => $append), ' Compressed ok' ; @@ -477,9 +477,9 @@ sub run { title "$TopType - From Handle to Buffer content '$disp_content' Append $append" ; - my $lex = new LexFile(my $in_file, my $out_file) ; + my $lex = LexFile->new( my $in_file, my $out_file) ; writeFile($in_file, $buffer); - my $in = new IO::File "<$in_file" ; + my $in = IO::File->new( "<$in_file" ); my $out = $already ; @@ -494,7 +494,7 @@ sub run { title "$TopType - From stdin (via '-') to Buffer content '$disp_content' Append $append" ; - my $lex = new LexFile(my $in_file, my $out_file) ; + my $lex = LexFile->new( my $in_file, my $out_file) ; writeFile($in_file, $buffer); open(SAVEIN, "<&STDIN"); @@ -503,7 +503,7 @@ sub run my $out = $already; - ok &$Func('-', \$out, Append => $append), ' Compressed ok' + ok &$Func('-', \$out, Append => $append), ' Compressed ok' or diag $$Error ; open(STDIN, "<&SAVEIN"); @@ -528,11 +528,11 @@ sub run my $FuncInverse = getTopFuncRef($TopTypeInverse); my $ErrorInverse = getErrorRef($TopTypeInverse); - my $lex = new LexFile(my $file1, my $file2) ; + my $lex = LexFile->new( my $file1, my $file2) ; writeFile($file1, $OriginalContent1); writeFile($file2, $OriginalContent2); - my $of = new IO::File "<$file1" ; + my $of = IO::File->new( "<$file1" ); ok $of, " Created output filehandle" ; #my @input = ( undef, "", $file2, \undef, \'', \"abcde", $of) ; @@ -574,7 +574,7 @@ sub run $of->open("<$file1") ; my $output ; - ok &$Func(\@input, \$output, MultiStream => $ms, AutoClose => 0), ' Compressed ok' + ok &$Func(\@input, \$output, MultiStream => $ms, AutoClose => 0), ' Compressed ok' or diag $$Error; my $got = anyUncompress([ \$output, MultiStream => $ms ]); @@ -587,7 +587,7 @@ sub run { title "$TopType - From Array Ref to Filename, MultiStream $ms" ; - my $lex = new LexFile( my $file3) ; + my $lex = LexFile->new( my $file3) ; # rewind the filehandle $of->open("<$file1") ; @@ -605,9 +605,9 @@ sub run { title "$TopType - From Array Ref to Filehandle, MultiStream $ms" ; - my $lex = new LexFile(my $file3) ; + my $lex = LexFile->new( my $file3) ; - my $fh3 = new IO::File ">$file3"; + my $fh3 = IO::File->new( ">$file3" ); # rewind the filehandle $of->open("<$file1") ; @@ -667,7 +667,7 @@ sub run title 'Round trip binary data that happens to include \r\n' ; - my $lex = new LexFile(my $file1, my $file2, my $file3) ; + my $lex = LexFile->new( my $file1, my $file2, my $file3) ; my $original = join '', map { chr } 0x00 .. 0xff ; $original .= "data1\r\ndata2\r\ndata3\r\n" ; @@ -678,7 +678,7 @@ sub run ok &$Func($file1 => $file2), ' Compressed ok' ; ok &$FuncInverse($file2 => $file3), ' Uncompressed ok' ; is readFile($file3), $original, " round tripped ok"; - + } foreach my $bit ($UncompressClass, @@ -692,7 +692,7 @@ sub run my $C_Func = getTopFuncRef($CompressClass); - + my $data = "mary had a little lamb" ; my $keep = $data ; my $extra = "after the main event"; @@ -705,7 +705,7 @@ sub run skip "zstd doesn't support trailing data", 9 if $CompressClass =~ /zstd/i ; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $input ; my $compressed ; @@ -720,7 +720,7 @@ sub run { writeFile($name, $compressed); - $input = new IO::File "<$name" ; + $input = IO::File->new( "<$name" ); } my $trailing; @@ -735,7 +735,7 @@ sub run } is $trailing . $rest, $extra, " Got trailing data"; - + } } @@ -751,10 +751,10 @@ sub run # # my @inFiles = map { "in$_.tmp" } 1..4; # my @outFiles = map { "out$_.tmp" } 1..4; -# my $lex = new LexFile(@inFiles, @outFiles); +# my $lex = LexFile->new( @inFiles, @outFiles); # # writeFile($_, "data $_") foreach @inFiles ; -# +# # { # title "$TopType - Hash Ref: to filename" ; # @@ -791,8 +791,8 @@ sub run # my @buffer ; # my %hash = ( $inFiles[0] => undef, # $inFiles[1] => undef, -# $inFiles[2] => undef, -# ); +# $inFiles[2] => undef, +# ); # # ok &$Func( \%hash ), ' Compressed ok' ; # @@ -845,10 +845,10 @@ sub run # # my @inFiles = map { "in$_.tmp" } 1..4; # my @outFiles = map { "out$_.tmp" } 1..4; -# my $lex = new LexFile(@inFiles, @outFiles); +# my $lex = LexFile->new( @inFiles, @outFiles); # # writeFile($_, "data $_") foreach @inFiles ; -# +# # # # # if (0) @@ -888,7 +888,7 @@ sub run # # title "$TopType - From Array Ref to Filename" ; # # # # my ($file3) = ("file3"); -# # my $lex = new LexFile($file3) ; +# # my $lex = LexFile->new( $file3) ; # # # # # rewind the filehandle # # $of->open("<$file1") ; @@ -906,9 +906,9 @@ sub run # # title "$TopType - From Array Ref to Filehandle" ; # # # # my ($file3) = ("file3"); -# # my $lex = new LexFile($file3) ; +# # my $lex = LexFile->new( $file3) ; # # -# # my $fh3 = new IO::File ">$file3"; +# # my $fh3 = IO::File->new( ">$file3" ); # # # # # rewind the filehandle # # $of->open("<$file1") ; @@ -936,7 +936,7 @@ sub run my $tmpDir1 ; my $tmpDir2 ; - my $lex = new LexDir($tmpDir1, $tmpDir2) ; + my $lex = LexDir->new($tmpDir1, $tmpDir2) ; my $d1 = quotemeta $tmpDir1 ; my $d2 = quotemeta $tmpDir2 ; @@ -951,7 +951,7 @@ sub run { title "$TopType - From FileGlob to FileGlob files [@$files]" ; - ok &$Func("<$tmpDir1/a*.tmp>" => "<$tmpDir2/a#1.tmp>"), ' Compressed ok' + ok &$Func("<$tmpDir1/a*.tmp>" => "<$tmpDir2/a#1.tmp>"), ' Compressed ok' or diag $$Error ; my @copy = @expected; @@ -967,7 +967,7 @@ sub run title "$TopType - From FileGlob to Array files [@$files]" ; my @buffer = ('first') ; - ok &$Func("<$tmpDir1/a*.tmp>" => \@buffer), ' Compressed ok' + ok &$Func("<$tmpDir1/a*.tmp>" => \@buffer), ' Compressed ok' or diag $$Error ; is shift @buffer, 'first'; @@ -987,8 +987,8 @@ sub run title "$TopType - From FileGlob to Buffer files [@$files], MS $ms" ; my $buffer ; - ok &$Func("<$tmpDir1/a*.tmp>" => \$buffer, - MultiStream => $ms), ' Compressed ok' + ok &$Func("<$tmpDir1/a*.tmp>" => \$buffer, + MultiStream => $ms), ' Compressed ok' or diag $$Error ; #hexDump(\$buffer); @@ -1003,10 +1003,10 @@ sub run { title "$TopType - From FileGlob to Filename files [@$files], MS $ms" ; - my $lex = new LexFile(my $filename) ; - + my $lex = LexFile->new( my $filename) ; + ok &$Func("<$tmpDir1/a*.tmp>" => $filename, - MultiStream => $ms), ' Compressed ok' + MultiStream => $ms), ' Compressed ok' or diag $$Error ; #hexDump(\$buffer); @@ -1021,11 +1021,11 @@ sub run { title "$TopType - From FileGlob to Filehandle files [@$files], MS $ms" ; - my $lex = new LexFile(my $filename) ; - my $fh = new IO::File ">$filename"; - - ok &$Func("<$tmpDir1/a*.tmp>" => $fh, - MultiStream => $ms, AutoClose => 1), ' Compressed ok' + my $lex = LexFile->new( my $filename) ; + my $fh = IO::File->new( ">$filename" ); + + ok &$Func("<$tmpDir1/a*.tmp>" => $fh, + MultiStream => $ms, AutoClose => 1), ' Compressed ok' or diag $$Error ; #hexDump(\$buffer); @@ -1050,7 +1050,7 @@ sub run my $TopType = getTopFuncName($bit); my $buffer = $OriginalContent1; - my $buffer2 = $OriginalContent2; + my $buffer2 = $OriginalContent2; my $keep_orig = $buffer; my $comp = compressBuffer($UncompressClass, $buffer) ; @@ -1096,7 +1096,7 @@ sub run { title "$TopType - From Buff to Filename, Append($append)" ; - my $lex = new LexFile(my $out_file) ; + my $lex = LexFile->new( my $out_file) ; if ($append) { writeFile($out_file, $incumbent) } else @@ -1114,15 +1114,15 @@ sub run { title "$TopType - From Buff to Handle, Append($append)" ; - my $lex = new LexFile(my $out_file) ; + my $lex = LexFile->new( my $out_file) ; my $of ; if ($append) { writeFile($out_file, $incumbent) ; - $of = new IO::File "+< $out_file" ; + $of = IO::File->new( "+< $out_file" ); } else { ok ! -e $out_file, " Output file does not exist" ; - $of = new IO::File "> $out_file" ; + $of = IO::File->new( "> $out_file" ); } isa_ok $of, 'IO::File', ' $of' ; @@ -1138,7 +1138,7 @@ sub run { title "$TopType - From Filename to Filename, Append($append)" ; - my $lex = new LexFile(my $in_file, my $out_file) ; + my $lex = LexFile->new( my $in_file, my $out_file) ; if ($append) { writeFile($out_file, $incumbent) } else @@ -1158,15 +1158,15 @@ sub run { title "$TopType - From Filename to Handle, Append($append)" ; - my $lex = new LexFile(my $in_file, my $out_file) ; + my $lex = LexFile->new( my $in_file, my $out_file) ; my $out ; if ($append) { writeFile($out_file, $incumbent) ; - $out = new IO::File "+< $out_file" ; + $out = IO::File->new( "+< $out_file" ); } else { ok ! -e $out_file, " Output file does not exist" ; - $out = new IO::File "> $out_file" ; + $out = IO::File->new( "> $out_file" ); } isa_ok $out, 'IO::File', ' $out' ; @@ -1184,7 +1184,7 @@ sub run { title "$TopType - From Filename to Buffer, Append($append)" ; - my $lex = new LexFile(my $in_file) ; + my $lex = LexFile->new( my $in_file) ; writeFile($in_file, $comp); my $output ; @@ -1199,14 +1199,14 @@ sub run { title "$TopType - From Handle to Filename, Append($append)" ; - my $lex = new LexFile(my $in_file, my $out_file) ; + my $lex = LexFile->new( my $in_file, my $out_file) ; if ($append) { writeFile($out_file, $incumbent) } else { ok ! -e $out_file, " Output file does not exist" } writeFile($in_file, $comp); - my $in = new IO::File "<$in_file" ; + my $in = IO::File->new( "<$in_file" ); ok &$Func($in, $out_file, Append => $append, @opts), ' Uncompressed ok' ; @@ -1220,20 +1220,20 @@ sub run { title "$TopType - From Handle to Handle, Append($append)" ; - my $lex = new LexFile(my $in_file, my $out_file) ; + my $lex = LexFile->new( my $in_file, my $out_file) ; my $out ; if ($append) { writeFile($out_file, $incumbent) ; - $out = new IO::File "+< $out_file" ; + $out = IO::File->new( "+< $out_file" ); } else { ok ! -e $out_file, " Output file does not exist" ; - $out = new IO::File "> $out_file" ; + $out = IO::File->new( "> $out_file" ); } isa_ok $out, 'IO::File', ' $out' ; writeFile($in_file, $comp); - my $in = new IO::File "<$in_file" ; + my $in = IO::File->new( "<$in_file" ); ok &$Func($in, $out, Append => $append, AutoClose => 1, @opts), ' Uncompressed ok' ; @@ -1247,9 +1247,9 @@ sub run { title "$TopType - From Filename to Buffer, Append($append)" ; - my $lex = new LexFile(my $in_file) ; + my $lex = LexFile->new( my $in_file) ; writeFile($in_file, $comp); - my $in = new IO::File "<$in_file" ; + my $in = IO::File->new( "<$in_file" ); my $output ; $output = $incumbent if $append ; @@ -1263,7 +1263,7 @@ sub run { title "$TopType - From stdin (via '-') to Buffer content, Append($append) " ; - my $lex = new LexFile(my $in_file) ; + my $lex = LexFile->new( my $in_file) ; writeFile($in_file, $comp); open(SAVEIN, "<&STDIN"); @@ -1273,7 +1273,7 @@ sub run my $output ; $output = $incumbent if $append ; - ok &$Func('-', \$output, Append => $append, @opts), ' Uncompressed ok' + ok &$Func('-', \$output, Append => $append, @opts), ' Uncompressed ok' or diag $$Error ; open(STDIN, "<&SAVEIN"); @@ -1286,14 +1286,14 @@ sub run { title "$TopType - From Handle to Buffer, InputLength" ; - my $lex = new LexFile(my $in_file, my $out_file) ; + my $lex = LexFile->new( my $in_file, my $out_file) ; my $out ; my $expected = $buffer ; my $appended = 'appended'; my $len_appended = length $appended; writeFile($in_file, $comp . $appended . $comp . $appended) ; - my $in = new IO::File "<$in_file" ; + my $in = IO::File->new( "<$in_file" ); ok &$Func($in, \$out, Transparent => 0, InputLength => length $comp, @opts), ' Uncompressed ok' ; @@ -1317,7 +1317,7 @@ sub run { title "$TopType - From stdin (via $stdin) to Buffer content, InputLength" ; - my $lex = new LexFile my $in_file ; + my $lex = LexFile->new( my $in_file ); my $expected = $buffer ; my $appended = 'appended'; my $len_appended = length $appended; @@ -1329,7 +1329,7 @@ sub run my $output ; - ok &$Func($stdin, \$output, Transparent => 0, InputLength => length $comp, @opts), ' Uncompressed ok' + ok &$Func($stdin, \$output, Transparent => 0, InputLength => length $comp, @opts), ' Uncompressed ok' or diag $$Error ; my $buff ; @@ -1366,12 +1366,12 @@ sub run my $incumbent = "incumbent data" ; - my $lex = new LexFile(my $file1, my $file2) ; + my $lex = LexFile->new( my $file1, my $file2) ; writeFile($file1, compressBuffer($UncompressClass, $OriginalContent1)); writeFile($file2, compressBuffer($UncompressClass, $OriginalContent2)); - my $of = new IO::File "<$file1" ; + my $of = IO::File->new( "<$file1" ); ok $of, " Created output filehandle" ; #my @input = ($file2, \$undef, \$null, \$comp, $of) ; @@ -1393,7 +1393,7 @@ sub run { title "$TopType - From ArrayRef to Filename" ; - my $lex = new LexFile my $output; + my $lex = LexFile->new( my $output ); $of->open("<$file1") ; ok &$Func(\@input, $output, AutoClose => 0, @opts), ' UnCompressed ok' ; @@ -1404,8 +1404,8 @@ sub run { title "$TopType - From ArrayRef to Filehandle" ; - my $lex = new LexFile my $output; - my $fh = new IO::File ">$output" ; + my $lex = LexFile->new( my $output ); + my $fh = IO::File->new( ">$output" ); $of->open("<$file1") ; ok &$Func(\@input, $fh, AutoClose => 0, @opts), ' UnCompressed ok' ; @@ -1422,8 +1422,8 @@ sub run ok &$Func(\@input, \@output, AutoClose => 0, @opts), ' UnCompressed ok' ; is_deeply \@input, \@keep, " Input array not changed" ; - is_deeply [map { defined $$_ ? $$_ : "" } @output], - ['first', @expected], + is_deeply [map { defined $$_ ? $$_ : "" } @output], + ['first', @expected], " Got Expected uncompressed data"; } @@ -1441,7 +1441,7 @@ sub run my $tmpDir1 ; my $tmpDir2 ; - my $lex = new LexDir($tmpDir1, $tmpDir2) ; + my $lex = LexDir->new($tmpDir1, $tmpDir2) ; my $d1 = quotemeta $tmpDir1 ; my $d2 = quotemeta $tmpDir2 ; @@ -1460,7 +1460,7 @@ sub run { title "$TopType - From FileGlob to FileGlob" ; - ok &$Func("<$tmpDir1/a*.tmp>" => "<$tmpDir2/a#1.tmp>", @opts), ' UnCompressed ok' + ok &$Func("<$tmpDir1/a*.tmp>" => "<$tmpDir2/a#1.tmp>", @opts), ' UnCompressed ok' or diag $$Error ; my @copy = @expected; @@ -1476,7 +1476,7 @@ sub run title "$TopType - From FileGlob to Arrayref" ; my @output = (\'first'); - ok &$Func("<$tmpDir1/a*.tmp>" => \@output, @opts), ' UnCompressed ok' + ok &$Func("<$tmpDir1/a*.tmp>" => \@output, @opts), ' UnCompressed ok' or diag $$Error ; my @copy = ('first', @expected); @@ -1492,7 +1492,7 @@ sub run title "$TopType - From FileGlob to Buffer" ; my $output ; - ok &$Func("<$tmpDir1/a*.tmp>" => \$output, @opts), ' UnCompressed ok' + ok &$Func("<$tmpDir1/a*.tmp>" => \$output, @opts), ' UnCompressed ok' or diag $$Error ; is $output, join('', @expected), " got expected uncompressed data"; @@ -1501,9 +1501,9 @@ sub run { title "$TopType - From FileGlob to Filename" ; - my $lex = new LexFile my $output ; + my $lex = LexFile->new( my $output ); ok ! -e $output, " $output does not exist" ; - ok &$Func("<$tmpDir1/a*.tmp>" => $output, @opts), ' UnCompressed ok' + ok &$Func("<$tmpDir1/a*.tmp>" => $output, @opts), ' UnCompressed ok' or diag $$Error ; ok -e $output, " $output does exist" ; @@ -1513,9 +1513,9 @@ sub run { title "$TopType - From FileGlob to Filehandle" ; - my $lex = new LexFile my $output ; - my $fh = new IO::File ">$output" ; - ok &$Func("<$tmpDir1/a*.tmp>" => $fh, AutoClose => 1, @opts), ' UnCompressed ok' + my $lex = LexFile->new( my $output ); + my $fh = IO::File->new( ">$output" ); + ok &$Func("<$tmpDir1/a*.tmp>" => $fh, AutoClose => 1, @opts), ' UnCompressed ok' or diag $$Error ; ok -e $output, " $output does exist" ; @@ -1534,7 +1534,7 @@ sub run title "More write tests" ; - my $lex = new LexFile(my $file1, my $file2, my $file3) ; + my $lex = LexFile->new( my $file1, my $file2, my $file3) ; writeFile($file1, "F1"); writeFile($file2, "F2"); @@ -1551,9 +1551,9 @@ sub run # { # my ($send, $get) = @$data ; # -# my $fh1 = new IO::File "< $file1" ; -# my $fh2 = new IO::File "< $file2" ; -# my $fh3 = new IO::File "< $file3" ; +# my $fh1 = IO::File->new( "< $file1" ); +# my $fh2 = IO::File->new( "< $file2" ); +# my $fh3 = IO::File->new( "< $file3" ); # # title "$send"; # my ($copy); @@ -1587,9 +1587,9 @@ sub run { my ($send, $get) = @$data ; - my $fh1 = new IO::File "< $file1" ; - my $fh2 = new IO::File "< $file2" ; - my $fh3 = new IO::File "< $file3" ; + my $fh1 = IO::File->new( "< $file1" ); + my $fh2 = IO::File->new( "< $file2" ); + my $fh3 = IO::File->new( "< $file3" ); title "$send"; my($copy); @@ -1604,8 +1604,8 @@ sub run } @data = ( - '[""]', - '[undef]', + '[""]', + '[undef]', ) ; @@ -1616,7 +1616,7 @@ sub run eval "\$copy = $send"; my $Answer ; eval { &$Func($copy, \$Answer) } ; - like $@, mkErr("^$TopFuncName: input filename is undef or null string"), + like $@, mkErr("^$TopFuncName: input filename is undef or null string"), " got error message"; } @@ -1624,11 +1624,11 @@ sub run { - # check setting $\ + # check setting $\ my $CompFunc = getTopFuncRef($CompressClass); my $UncompFunc = getTopFuncRef($UncompressClass); - my $lex = new LexFile my $file ; + my $lex = LexFile->new( my $file ); local $\ = "\n" ; my $input = "hello world"; @@ -1664,7 +1664,7 @@ sub run is $output, $input, "round trip ok" ; } - + } # TODO add more error cases diff --git a/cpan/IO-Compress/t/compress/prime.pl b/cpan/IO-Compress/t/compress/prime.pl index cae424c7aed9..2b0af2835d7c 100644 --- a/cpan/IO-Compress/t/compress/prime.pl +++ b/cpan/IO-Compress/t/compress/prime.pl @@ -13,7 +13,7 @@ BEGIN plan skip_all => "Lengthy Tests Disabled\n" . "set COMPRESS_ZLIB_RUN_ALL or COMPRESS_ZLIB_RUN_MOST to run this test suite" unless defined $ENV{COMPRESS_ZLIB_RUN_ALL} or defined $ENV{COMPRESS_ZLIB_RUN_MOST}; - + # use Test::NoWarnings, if available $extra = 0 ; $extra = 1 @@ -54,11 +54,11 @@ sub run for my $useBuf (0 .. 1) { print "#\n# BlockSize $blocksize, Length $i, Buffer $useBuf\n#\n" ; - my $lex = new LexFile my $name ; - + my $lex = LexFile->new( my $name ); + my $prime = substr($compressed, 0, $i); my $rest = substr($compressed, $i); - + my $start ; if ($useBuf) { $start = \$rest ; @@ -68,20 +68,20 @@ sub run writeFile($name, $rest); } - #my $gz = new $UncompressClass $name, - my $gz = new $UncompressClass $start, + #my $gz = $UncompressClass->can('new')->( $UncompressClass, $name, + my $gz = $UncompressClass->can('new')->( $UncompressClass, $start, -Append => 1, -BlockSize => $blocksize, -Prime => $prime, -Transparent => 0 - ; + ); ok $gz; ok ! $gz->error() ; my $un ; my $status = 1 ; $status = $gz->read($un) while $status > 0 ; is $status, 0 ; - ok ! $gz->error() + ok ! $gz->error() or print "Error is '" . $gz->error() . "'\n"; is $un, $hello ; ok $gz->eof() ; @@ -90,5 +90,5 @@ sub run } } } - + 1; diff --git a/cpan/IO-Compress/t/compress/tied.pl b/cpan/IO-Compress/t/compress/tied.pl index 4552e1733ab4..98f9dcc4813d 100644 --- a/cpan/IO-Compress/t/compress/tied.pl +++ b/cpan/IO-Compress/t/compress/tied.pl @@ -8,9 +8,9 @@ use CompTestUtils; our ($BadPerl, $UncompressClass); - -BEGIN -{ + +BEGIN +{ plan(skip_all => "Tied Filehandle needs Perl 5.005 or better" ) if $] < 5.005 ; @@ -32,10 +32,10 @@ BEGIN plan tests => $tests + $extra ; } - - + + use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); - + sub myGZreadFile @@ -44,10 +44,10 @@ sub myGZreadFile my $init = shift ; - my $fil = new $UncompressClass $filename, + my $fil = $UncompressClass->can('new')->( $UncompressClass, $filename, -Strict => 1, -Append => 1 - ; + ); my $data ; $data = $init if defined $init ; @@ -71,9 +71,9 @@ sub run title "Testing $CompressClass"; - + my $x ; - my $gz = new $CompressClass(\$x); + my $gz = $CompressClass->can('new')->( $CompressClass, \$x); my $buff ; @@ -95,12 +95,12 @@ sub run title "Testing $UncompressClass"; my $gc ; - my $guz = new $CompressClass(\$gc); + my $guz = $CompressClass->can('new')->( $CompressClass, \$gc); $guz->write("abc") ; $guz->close(); my $x ; - my $gz = new $UncompressClass(\$gc); + my $gz = $UncompressClass->can('new')->( $UncompressClass, \$gc); my $buff ; @@ -125,7 +125,7 @@ sub run # Write # these tests come almost 100% from IO::String - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $io = $CompressClass->new($name); @@ -148,7 +148,7 @@ sub run } my $foo = "1234567890"; - + ok syswrite($io, $foo, length($foo)) == length($foo) ; if ( $] < 5.6 ) { is $io->syswrite($foo, length $foo), length $foo } @@ -188,17 +188,17 @@ sub run EOT - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); - my $iow = new $CompressClass $name ; + my $iow = $CompressClass->can('new')->( $CompressClass, $name ); print $iow $str ; close $iow; my @tmp; my $buf; { - my $io = new $UncompressClass $name ; - + my $io = $UncompressClass->can('new')->( $UncompressClass, $name ); + ok ! $io->eof, " Not EOF"; is $io->tell(), 0, " Tell is 0" ; my @lines = <$io>; @@ -206,9 +206,9 @@ sub run or print "# Got " . scalar(@lines) . " lines, expected 6\n" ; is $lines[1], "of a paragraph\n" ; is join('', @lines), $str ; - is $., 6; + is $., 6; is $io->tell(), length($str) ; - + ok $io->eof; ok ! ( defined($io->getline) || @@ -217,8 +217,8 @@ sub run defined($io->getc) || read($io, $buf, 100) != 0) ; } - - + + { local $/; # slurp mode my $io = $UncompressClass->new($name); @@ -226,27 +226,27 @@ sub run my @lines = $io->getlines; ok $io->eof; ok @lines == 1 && $lines[0] eq $str; - + $io = $UncompressClass->new($name); ok ! $io->eof; my $line = <$io>; ok $line eq $str; ok $io->eof; } - + { local $/ = ""; # paragraph mode my $io = $UncompressClass->new($name); ok ! $io->eof; my @lines = <$io>; ok $io->eof; - ok @lines == 2 + ok @lines == 2 or print "# Got " . scalar(@lines) . " lines, expected 2\n" ; ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" or print "# $lines[0]\n"; ok $lines[1] eq "and a single line.\n\n"; } - + { local $/ = "is"; my $io = $UncompressClass->new($name); @@ -258,24 +258,24 @@ sub run push(@lines, $_); $err++ if $. != ++$no; } - + ok $err == 0 ; ok $io->eof; - - ok @lines == 3 + + ok @lines == 3 or print "# Got " . scalar(@lines) . " lines, expected 3\n" ; ok join("-", @lines) eq "This- is- an example\n" . "of a paragraph\n\n\n" . "and a single line.\n\n"; } - - + + # Test read - + { my $io = $UncompressClass->new($name); - + if (! $BadPerl) { eval { read($io, $buf, -1) } ; @@ -286,22 +286,22 @@ sub run ok read($io, $buf, 3) == 3 ; ok $buf eq "Thi"; - + ok sysread($io, $buf, 3, 2) == 3 ; ok $buf eq "Ths i" or print "# [$buf]\n" ;; ok ! $io->eof; - + # $io->seek(-4, 2); - # + # # ok ! $io->eof; - # + # # ok read($io, $buf, 20) == 4 ; # ok $buf eq "e.\n\n"; - # + # # ok read($io, $buf, 20) == 0 ; # ok $buf eq ""; - # + # # ok ! $io->eof; } @@ -319,24 +319,24 @@ sub run EOT - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); writeFile($name, $str); my @tmp; my $buf; { - my $io = new $UncompressClass $name, -Transparent => 1 ; - + my $io = $UncompressClass->can('new')->( $UncompressClass, $name, -Transparent => 1 ); + ok defined $io; ok ! $io->eof; ok $io->tell() == 0 ; my @lines = <$io>; - ok @lines == 6; + ok @lines == 6; ok $lines[1] eq "of a paragraph\n" ; ok join('', @lines) eq $str ; - ok $. == 6; + ok $. == 6; ok $io->tell() == length($str) ; - + ok $io->eof; ok ! ( defined($io->getline) || @@ -345,8 +345,8 @@ sub run defined($io->getc) || read($io, $buf, 100) != 0) ; } - - + + { local $/; # slurp mode my $io = $UncompressClass->new($name); @@ -354,27 +354,27 @@ sub run my @lines = $io->getlines; ok $io->eof; ok @lines == 1 && $lines[0] eq $str; - + $io = $UncompressClass->new($name); ok ! $io->eof; my $line = <$io>; ok $line eq $str; ok $io->eof; } - + { local $/ = ""; # paragraph mode my $io = $UncompressClass->new($name); ok ! $io->eof; my @lines = <$io>; ok $io->eof; - ok @lines == 2 + ok @lines == 2 or print "# expected 2 lines, got " . scalar(@lines) . "\n"; ok $lines[0] eq "This is an example\nof a paragraph\n\n\n" or print "# [$lines[0]]\n" ; ok $lines[1] eq "and a single line.\n\n"; } - + { local $/ = "is"; my $io = $UncompressClass->new($name); @@ -386,40 +386,40 @@ sub run push(@lines, $_); $err++ if $. != ++$no; } - + ok $err == 0 ; ok $io->eof; - + ok @lines == 3 ; ok join("-", @lines) eq "This- is- an example\n" . "of a paragraph\n\n\n" . "and a single line.\n\n"; } - - + + # Test read - + { my $io = $UncompressClass->new($name); - + ok read($io, $buf, 3) == 3 ; ok $buf eq "Thi"; - + ok sysread($io, $buf, 3, 2) == 3 ; ok $buf eq "Ths i"; ok ! $io->eof; - + # $io->seek(-4, 2); - # + # # ok ! $io->eof; - # + # # ok read($io, $buf, 20) == 4 ; # ok $buf eq "e.\n\n"; - # + # # ok read($io, $buf, 20) == 0 ; # ok $buf eq ""; - # + # # ok ! $io->eof; } @@ -450,24 +450,24 @@ sub run { title "Read Tests - buf length $bufsize, Transparent $trans, Append $append" ; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); if ($trans) { writeFile($name, $str) ; } else { - my $iow = new $CompressClass $name ; + my $iow = $CompressClass->can('new')->( $CompressClass, $name ); print $iow $str ; close $iow; } - - my $io = $UncompressClass->new($name, + + my $io = $UncompressClass->new($name, -Append => $append, -Transparent => $trans); - + my $buf; - + is $io->tell(), 0; if ($append) { diff --git a/cpan/IO-Compress/t/compress/truncate.pl b/cpan/IO-Compress/t/compress/truncate.pl index 24fe176ce8a1..555114dba7d4 100644 --- a/cpan/IO-Compress/t/compress/truncate.pl +++ b/cpan/IO-Compress/t/compress/truncate.pl @@ -13,7 +13,7 @@ sub run my $UncompressClass = getInverse($CompressClass); my $Error = getErrorRef($CompressClass); my $UnError = getErrorRef($UncompressClass); - + # my $hello = <new( my $name ); my $input; - + title "Fingerprint Truncation - length $i, Transparent $trans"; my $part = substr($compressed, 0, $i); @@ -68,9 +68,9 @@ sub run $input = \$part; } - my $gz = new $UncompressClass $input, + my $gz = $UncompressClass->can('new')->( $UncompressClass, $input, -BlockSize => $blocksize, - -Transparent => $trans; + -Transparent => $trans ); if ($trans) { ok $gz; ok ! $gz->error() ; @@ -92,9 +92,9 @@ sub run # foreach my $i ($fingerprint_size .. $header_size -1) { - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $input; - + title "Header Truncation - length $i, Source $fb, Transparent $trans"; my $part = substr($compressed, 0, $i); @@ -107,10 +107,10 @@ sub run { $input = \$part; } - - ok ! defined new $UncompressClass $input, + + ok ! defined $UncompressClass->can('new')->( $UncompressClass, $input, -BlockSize => $blocksize, - -Transparent => $trans; + -Transparent => $trans ); #ok $gz->eof() ; } @@ -118,15 +118,15 @@ sub run # In this case the uncompression object will have been created, # so need to check that subsequent reads from the object fail if ($header_size > 0) - { + { for my $mode (qw(block line para record slurp)) { title "Corruption after header - Mode $mode, Source $fb, Transparent $trans"; - - my $lex = new LexFile my $name ; + + my $lex = LexFile->new( my $name ); my $input; - + my $part = substr($compressed, 0, $header_size); # Append corrupt data $part .= "\xFF" x 100 ; @@ -139,11 +139,11 @@ sub run { $input = \$part; } - - ok my $gz = new $UncompressClass $input, + + ok my $gz = $UncompressClass->can('new')->( $UncompressClass, $input, -Strict => 1, -BlockSize => $blocksize, - -Transparent => $trans + -Transparent => $trans ) or diag $$UnError; my $un ; @@ -184,19 +184,19 @@ sub run } # Back to truncation tests - + foreach my $i ($header_size .. length($compressed) - 1 - $trailer_size) { next if $i == 0 ; - + for my $mode (qw(block line)) { title "Compressed Data Truncation - length $i, MOde $mode, Source $fb, Transparent $trans"; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $input; - + my $part = substr($compressed, 0, $i); if ($fb eq 'filehandle') { @@ -207,11 +207,11 @@ sub run { $input = \$part; } - - ok my $gz = new $UncompressClass $input, + + ok my $gz = $UncompressClass->can('new')->( $UncompressClass, $input, -Strict => 1, -BlockSize => $blocksize, - -Transparent => $trans + -Transparent => $trans ) or diag $$UnError; my $un ; @@ -227,12 +227,12 @@ sub run } ok $gz->error() ; cmp_ok $gz->errorNo(), '<', 0 ; - # ok $gz->eof() + # ok $gz->eof() # or die "EOF"; $gz->close(); } } - + # RawDeflate and Zstandard do not have a trailer next if $CompressClass eq 'IO::Compress::RawDeflate' ; next if $CompressClass eq 'IO::Compress::Zstd' ; @@ -242,9 +242,9 @@ sub run { foreach my $lax (0, 1) { - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $input; - + ok 1, "Compressed Trailer Truncation - Length $i, Lax $lax, Transparent $trans" ; my $part = substr($compressed, 0, $i); if ($fb eq 'filehandle') @@ -256,12 +256,12 @@ sub run { $input = \$part; } - - ok my $gz = new $UncompressClass $input, + + ok my $gz = $UncompressClass->can('new')->( $UncompressClass, $input, -BlockSize => $blocksize, -Strict => !$lax, - -Append => 1, - -Transparent => $trans; + -Append => 1, + -Transparent => $trans ); my $un = ''; my $status = 1 ; $status = $gz->read($un) while $status > 0 ; @@ -269,7 +269,7 @@ sub run if ($lax) { is $un, $hello; - is $status, 0 + is $status, 0 or diag "Status $status Error is " . $gz->error() ; ok $gz->eof() or diag "Status $status Error is " . $gz->error() ; @@ -277,13 +277,13 @@ sub run } else { - cmp_ok $status, "<", 0 + cmp_ok $status, "<", 0 or diag "Status $status Error is " . $gz->error() ; ok $gz->eof() or diag "Status $status Error is " . $gz->error() ; ok $gz->error() ; } - + $gz->close(); } } @@ -292,4 +292,3 @@ sub run } 1; - diff --git a/cpan/IO-Compress/t/compress/zlib-generic.pl b/cpan/IO-Compress/t/compress/zlib-generic.pl index 94e5da9f723b..5c4e3fc8210f 100644 --- a/cpan/IO-Compress/t/compress/zlib-generic.pl +++ b/cpan/IO-Compress/t/compress/zlib-generic.pl @@ -6,8 +6,8 @@ use Test::More ; use CompTestUtils; -BEGIN -{ +BEGIN +{ # use Test::NoWarnings, if available my $extra = 0 ; $extra = 1 @@ -32,10 +32,10 @@ sub myGZreadFile my $init = shift ; - my $fil = new $UncompressClass $filename, + my $fil = $UncompressClass->can('new')->( $UncompressClass, $filename, -Strict => 1, -Append => 1 - ; + ); my $data = ''; $data = $init if defined $init ; @@ -65,7 +65,7 @@ sub myGZreadFile title "flush" ; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $hello = <can('new')->( $CompressClass, $name ); ok $x->write($hello), "write" ; ok $x->flush(Z_FINISH), "flush"; @@ -83,7 +83,7 @@ sub myGZreadFile { my $uncomp; - ok my $x = new $UncompressClass $name, -Append => 1 ; + ok my $x = $UncompressClass->can('new')->( $UncompressClass, $name, -Append => 1 ); my $len ; 1 while ($len = $x->read($uncomp)) > 0 ; @@ -104,16 +104,16 @@ sub myGZreadFile my $buffer = ''; { my $x ; - ok $x = new $CompressClass(\$buffer) ; + ok $x = $CompressClass->can('new')->( $CompressClass, \$buffer); ok $x->close ; - + } my $keep = $buffer ; my $uncomp= ''; { my $x ; - ok $x = new $UncompressClass(\$buffer, Append => 1) ; + ok $x = $UncompressClass->can('new')->( $UncompressClass, \$buffer, Append => 1) ; 1 while $x->read($uncomp) > 0 ; @@ -125,21 +125,21 @@ sub myGZreadFile } - + { title "inflateSync on plain file"; my $hello = "I am a HAL 9000 computer" x 2001 ; - my $k = new $UncompressClass(\$hello, Transparent => 1); + my $k = $UncompressClass->can('new')->( $UncompressClass, \$hello, Transparent => 1); ok $k ; - + # Skip to the flush point -- no-op for plain file my $status = $k->inflateSync(); - is $status, 1 + is $status, 1 or diag $k->error() ; - - my $rest; + + my $rest; is $k->read($rest, length($hello)), length($hello) or diag $k->error() ; ok $rest eq $hello ; @@ -156,23 +156,23 @@ sub myGZreadFile my $goodbye = "Will I dream?" x 2010; my ($x, $err, $answer, $X, $Z, $status); my $Answer ; - - ok ($x = new $CompressClass(\$Answer)); + + ok ($x = $CompressClass->can('new')->( $CompressClass, \$Answer)); ok $x ; - + is $x->write($hello), length($hello); - + # create a flush point ok $x->flush(Z_FULL_FLUSH) ; - + is $x->write($goodbye), length($goodbye); - + ok $x->close() ; - + my $k; - $k = new $UncompressClass(\$Answer, BlockSize => 1); + $k = $UncompressClass->can('new')->( $UncompressClass, \$Answer, BlockSize => 1); ok $k ; - + my $initial; is $k->read($initial, 1), 1 ; is $initial, substr($hello, 0, 1); @@ -181,9 +181,9 @@ sub myGZreadFile $status = $k->inflateSync(); is $status, 1, " inflateSync returned 1" or diag $k->error() ; - - my $rest; - is $k->read($rest, length($hello) + length($goodbye)), + + my $rest; + is $k->read($rest, length($hello) + length($goodbye)), length($goodbye) or diag $k->error() ; ok $rest eq $goodbye, " got expected output" ; @@ -199,26 +199,26 @@ sub myGZreadFile my $hello = "I am a HAL 9000 computer" x 2001 ; my ($x, $err, $answer, $X, $Z, $status); my $Answer ; - - ok ($x = new $CompressClass(\$Answer)); + + ok ($x = $CompressClass->can('new')->( $CompressClass, \$Answer)); ok $x ; - + is $x->write($hello), length($hello); - + ok $x->close() ; - - my $k = new $UncompressClass(\$Answer, BlockSize => 1); + + my $k = $UncompressClass->can('new')->( $UncompressClass, \$Answer, BlockSize => 1); ok $k ; - + my $initial; is $k->read($initial, 1), 1 ; is $initial, substr($hello, 0, 1); # Skip to the flush point $status = $k->inflateSync(); - is $status, 0 + is $status, 0 or diag $k->error() ; - + ok $k->close(); is $k->inflateSync(), 0 ; } @@ -227,7 +227,3 @@ sub myGZreadFile 1; - - - - diff --git a/cpan/IO-Compress/t/cz-01version.t b/cpan/IO-Compress/t/cz-01version.t index ff10f32b106e..12574aa91cb8 100644 --- a/cpan/IO-Compress/t/cz-01version.t +++ b/cpan/IO-Compress/t/cz-01version.t @@ -11,8 +11,8 @@ use warnings ; use Test::More ; -BEGIN -{ +BEGIN +{ # use Test::NoWarnings, if available my $extra = 0 ; $extra = 1 @@ -20,13 +20,13 @@ BEGIN plan tests => 2 + $extra ; - use_ok('Compress::Zlib', 2) ; + use_ok('Compress::Zlib', 2) ; } # Check zlib_version and ZLIB_VERSION are the same. SKIP: { - skip "TEST_SKIP_VERSION_CHECK is set", 1 + skip "TEST_SKIP_VERSION_CHECK is set", 1 if $ENV{TEST_SKIP_VERSION_CHECK}; my $zlib_h = ZLIB_VERSION ; my $libz = Compress::Zlib::zlib_version; @@ -35,10 +35,10 @@ SKIP: { or diag < 1} ) ) ; ok $x ; ok $err == Z_OK ; - + my $Answer = ''; foreach (@hello) { @@ -158,20 +158,20 @@ foreach (@hello) $Answer .= $X ; } - + ok $status == Z_OK ; ok ((($X, $status) = $x->flush())[1] == Z_OK ) ; $Answer .= $X ; - - + + my @Answer = split('', $Answer) ; - + my $k; ok (($k, $err) = inflateInit( {-Bufsize => 1}) ) ; ok $k ; ok $err == Z_OK ; - + my $GOT = ''; my $Z; foreach (@Answer) @@ -179,9 +179,9 @@ foreach (@Answer) ($Z, $status) = $k->inflate($_) ; $GOT .= $Z ; last if $status == Z_STREAM_END or $status != Z_OK ; - + } - + ok $status == Z_STREAM_END ; ok $GOT eq $hello ; @@ -190,11 +190,11 @@ title 'deflate/inflate - small buffer with a number'; # ============================== $hello = 6529 ; - + ok (($x, $err) = deflateInit( {-Bufsize => 1} ) ) ; ok $x ; ok $err == Z_OK ; - + ok !defined $x->msg() ; ok $x->total_in() == 0 ; ok $x->total_out() == 0 ; @@ -204,19 +204,19 @@ $Answer = ''; $Answer .= $X ; } - + ok $status == Z_OK ; ok ((($X, $status) = $x->flush())[1] == Z_OK ) ; $Answer .= $X ; - + ok !defined $x->msg() ; ok $x->total_in() == length $hello ; ok $x->total_out() == length $Answer ; - + @Answer = split('', $Answer) ; - + ok (($k, $err) = inflateInit( {-Bufsize => 1}) ) ; ok $k ; ok $err == Z_OK ; @@ -224,16 +224,16 @@ ok $err == Z_OK ; ok !defined $k->msg() ; ok $k->total_in() == 0 ; ok $k->total_out() == 0 ; - + $GOT = ''; foreach (@Answer) { ($Z, $status) = $k->inflate($_) ; $GOT .= $Z ; last if $status == Z_STREAM_END or $status != Z_OK ; - + } - + ok $status == Z_STREAM_END ; ok $GOT eq $hello ; @@ -242,27 +242,27 @@ is $k->total_in(), length $Answer ; ok $k->total_out() == length $hello ; - + title 'deflate/inflate - larger buffer'; # ============================== ok $x = deflateInit() ; - + ok ((($X, $status) = $x->deflate($contents))[1] == Z_OK) ; my $Y = $X ; - - + + ok ((($X, $status) = $x->flush() )[1] == Z_OK ) ; $Y .= $X ; - - - + + + ok $k = inflateInit() ; - + ($Z, $status) = $k->inflate($Y) ; - + ok $status == Z_STREAM_END ; ok $contents eq $Z ; @@ -272,7 +272,7 @@ title 'deflate/inflate - preset dictionary'; my $dictionary = "hello" ; ok $x = deflateInit({-Level => Z_BEST_COMPRESSION, -Dictionary => $dictionary}) ; - + my $dictID = $x->dict_adler() ; ($X, $status) = $x->deflate($hello) ; @@ -281,9 +281,9 @@ ok $status == Z_OK ; ok $status == Z_OK ; $X .= $Y ; $x = 0 ; - + ok $k = inflateInit(-Dictionary => $dictionary) ; - + ($Z, $status) = $k->inflate($X); ok $status == Z_STREAM_END ; ok $k->dict_adler() == $dictID; @@ -296,7 +296,7 @@ ok $hello eq $Z ; #print "status=[$status] hello=[$hello] Z=[$Z]\n"; #} #ok $status == Z_STREAM_END ; -#ok $hello eq $Z +#ok $hello eq $Z # or print "status=[$status] hello=[$hello] Z=[$Z]\n"; @@ -306,19 +306,19 @@ ok $hello eq $Z ; title 'inflate - check remaining buffer after Z_STREAM_END'; # =================================================== - + { ok $x = deflateInit(-Level => Z_BEST_COMPRESSION ) ; - + ($X, $status) = $x->deflate($hello) ; ok $status == Z_OK ; ($Y, $status) = $x->flush() ; ok $status == Z_OK ; $X .= $Y ; $x = 0 ; - + ok $k = inflateInit() ; - + my $first = substr($X, 0, 2) ; my $last = substr($X, 2) ; ($Z, $status) = $k->inflate($first); @@ -337,9 +337,9 @@ title 'inflate - check remaining buffer after Z_STREAM_END'; title 'memGzip & memGunzip'; { my ($name, $name1, $name2, $name3); - my $lex = new LexFile $name, $name1, $name2, $name3 ; + my $lex = LexFile->new( $name, $name1, $name2, $name3 ); my $buffer = <gzread($uncomp, 0), 0 ; ok (($x = $fil->gzread($uncomp)) == $len) ; - + ok ! $fil->gzclose ; ok $uncomp eq $buffer ; - + #1 while unlink $name ; # now check that memGunzip can deal with it. @@ -376,10 +376,10 @@ EOM ok defined $ungzip ; ok $buffer eq $ungzip ; is $gzerrno, 0; - - # now do the same but use a reference - $dest = memGzip(\$buffer) ; + # now do the same but use a reference + + $dest = memGzip(\$buffer) ; ok length $dest ; is $gzerrno, 0; @@ -391,13 +391,13 @@ EOM # uncompress with gzopen ok $fil = gzopen($name1, "rb") ; - + ok (($x = $fil->gzread($uncomp)) == $len) ; - + ok ! $fil->gzclose ; ok $uncomp eq $buffer ; - + # now check that memGunzip can deal with it. my $keep = $dest; $ungzip = memGunzip(\$dest) ; @@ -459,7 +459,7 @@ EOM ok ! defined $ungzip ; cmp_ok $gzerrno, "==", Z_DATA_ERROR ; - + #1 while unlink $name ; # check corrupt header -- too short @@ -520,7 +520,7 @@ EOM { title "Check all bytes can be handled"; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $data = join '', map { chr } 0x00 .. 0xFF; $data .= "\r\nabd\r\n"; @@ -548,7 +548,7 @@ title 'memGunzip with a gzopen created file'; { my $name = "test.gz" ; my $buffer = < 1, -WindowBits => -MAX_WBITS() ) ) ; ok $x ; ok $err == Z_OK ; - + $Answer = ''; foreach (@hello) { ($X, $status) = $x->deflate($_) ; last unless $status == Z_OK ; - + $Answer .= $X ; } - + ok $status == Z_OK ; - + ok ((($X, $status) = $x->flush())[1] == Z_OK ) ; $Answer .= $X ; - - + + @Answer = split('', $Answer) ; - # Undocumented corner -- extra byte needed to get inflate to return - # Z_STREAM_END when done. - push @Answer, " " ; - + # Undocumented corner -- extra byte needed to get inflate to return + # Z_STREAM_END when done. + push @Answer, " " ; + ok (($k, $err) = inflateInit(-Bufsize => 1, -WindowBits => -MAX_WBITS()) ) ; ok $k ; ok $err == Z_OK ; - + $GOT = ''; foreach (@Answer) { ($Z, $status) = $k->inflate($_) ; $GOT .= $Z ; last if $status == Z_STREAM_END or $status != Z_OK ; - + } - + ok $status == Z_STREAM_END ; ok $GOT eq $hello ; - + } { @@ -626,32 +626,32 @@ EOM my $hello = "I am a HAL 9000 computer" x 2001 ; my $goodbye = "Will I dream?" x 2010; my ($err, $answer, $X, $status, $Answer); - + ok (($x, $err) = deflateInit() ) ; ok $x ; ok $err == Z_OK ; - + ($Answer, $status) = $x->deflate($hello) ; ok $status == Z_OK ; - + # create a flush point ok ((($X, $status) = $x->flush(Z_FULL_FLUSH))[1] == Z_OK ) ; $Answer .= $X ; - + ($X, $status) = $x->deflate($goodbye) ; ok $status == Z_OK ; $Answer .= $X ; - + ok ((($X, $status) = $x->flush())[1] == Z_OK ) ; $Answer .= $X ; - + my ($first, @Answer) = split('', $Answer) ; - + my $k; ok (($k, $err) = inflateInit()) ; ok $k ; ok $err == Z_OK ; - + ($Z, $status) = $k->inflate($first) ; ok $status == Z_OK ; @@ -661,11 +661,11 @@ EOM my $byte = shift @Answer; $status = $k->inflateSync($byte) ; last unless $status == Z_DATA_ERROR; - + } ok $status == Z_OK; - + my $GOT = ''; my $Z = ''; foreach (@Answer) @@ -675,9 +675,9 @@ EOM $GOT .= $Z if defined $Z ; # print "x $status\n"; last if $status == Z_STREAM_END or $status != Z_OK ; - + } - + # zlib 1.0.9 returns Z_STREAM_END here, all others return Z_DATA_ERROR ok $status == Z_DATA_ERROR || $status == Z_STREAM_END ; ok $GOT eq $goodbye ; @@ -687,19 +687,19 @@ EOM $Answer =~ /^(.)(.*)$/ ; my ($initial, $rest) = ($1, $2); - + ok (($k, $err) = inflateInit()) ; ok $k ; ok $err == Z_OK ; - + ($Z, $status) = $k->inflate($initial) ; ok $status == Z_OK ; $status = $k->inflateSync($rest) ; ok $status == Z_OK; - + ($GOT, $status) = $k->inflate($rest) ; - + ok $status == Z_DATA_ERROR ; ok $Z . $GOT eq $goodbye ; } @@ -710,7 +710,7 @@ EOM my $hello = "I am a HAL 9000 computer" x 2001 ; my $goodbye = "Will I dream?" x 2010; my ($input, $err, $answer, $X, $status, $Answer); - + ok (($x, $err) = deflateInit(-Level => Z_BEST_COMPRESSION, -Strategy => Z_DEFAULT_STRATEGY) ) ; ok $x ; @@ -718,11 +718,11 @@ EOM ok $x->get_Level() == Z_BEST_COMPRESSION; ok $x->get_Strategy() == Z_DEFAULT_STRATEGY; - + ($Answer, $status) = $x->deflate($hello) ; ok $status == Z_OK ; $input .= $hello; - + # error cases eval { $x->deflateParams() }; #like $@, mkErr("^Compress::Raw::Zlib::deflateParams needs Level and/or Strategy"); @@ -736,56 +736,56 @@ EOM ok $x->get_Level() == Z_BEST_COMPRESSION; ok $x->get_Strategy() == Z_DEFAULT_STRATEGY; - + # change both Level & Strategy $status = $x->deflateParams(-Level => Z_BEST_SPEED, -Strategy => Z_HUFFMAN_ONLY) ; ok $status == Z_OK ; - + ok $x->get_Level() == Z_BEST_SPEED; ok $x->get_Strategy() == Z_HUFFMAN_ONLY; - + ($X, $status) = $x->deflate($goodbye) ; ok $status == Z_OK ; $Answer .= $X ; $input .= $goodbye; - - # change only Level + + # change only Level $status = $x->deflateParams(-Level => Z_NO_COMPRESSION) ; ok $status == Z_OK ; - + ok $x->get_Level() == Z_NO_COMPRESSION; ok $x->get_Strategy() == Z_HUFFMAN_ONLY; - + ($X, $status) = $x->deflate($goodbye) ; ok $status == Z_OK ; $Answer .= $X ; $input .= $goodbye; - + # change only Strategy $status = $x->deflateParams(-Strategy => Z_FILTERED) ; ok $status == Z_OK ; - + ok $x->get_Level() == Z_NO_COMPRESSION; ok $x->get_Strategy() == Z_FILTERED; - + ($X, $status) = $x->deflate($goodbye) ; ok $status == Z_OK ; $Answer .= $X ; $input .= $goodbye; - + ok ((($X, $status) = $x->flush())[1] == Z_OK ) ; $Answer .= $X ; - + my ($first, @Answer) = split('', $Answer) ; - + my $k; ok (($k, $err) = inflateInit()) ; ok $k ; ok $err == Z_OK ; - + ($Z, $status) = $k->inflate($Answer) ; - ok $status == Z_STREAM_END + ok $status == Z_STREAM_END or print "# status $status\n"; ok $Z eq $input ; } @@ -840,28 +840,28 @@ if ($] >= 5.005) # test inflate with a substr ok my $x = deflateInit() ; - + ok ((my ($X, $status) = $x->deflate($contents))[1] == Z_OK) ; - + my $Y = $X ; - - + + ok ((($X, $status) = $x->flush() )[1] == Z_OK ) ; $Y .= $X ; - + my $append = "Appended" ; $Y .= $append ; - + ok $k = inflateInit() ; - + #($Z, $status) = $k->inflate(substr($Y, 0, -1)) ; ($Z, $status) = $k->inflate(substr($Y, 0)) ; - + ok $status == Z_STREAM_END ; ok $contents eq $Z ; is $Y, $append; - + } if ($] >= 5.005) @@ -869,27 +869,27 @@ if ($] >= 5.005) # deflate/inflate in scalar context ok my $x = deflateInit() ; - + my $X = $x->deflate($contents); - + my $Y = $X ; - - + + $X = $x->flush(); $Y .= $X ; - + my $append = "Appended" ; $Y .= $append ; - + ok $k = inflateInit() ; - + $Z = $k->inflate(substr($Y, 0, -1)) ; #$Z = $k->inflate(substr($Y, 0)) ; - + ok $contents eq $Z ; is $Y, $append; - + } { @@ -897,8 +897,8 @@ if ($] >= 5.005) # CRC32 of this data should have the high bit set # value in ascii is ZgRNtjgSUW - my $data = "\x5a\x67\x52\x4e\x74\x6a\x67\x53\x55\x57"; - my $expected_crc = 0xCF707A2B ; # 3480255019 + my $data = "\x5a\x67\x52\x4e\x74\x6a\x67\x53\x55\x57"; + my $expected_crc = 0xCF707A2B ; # 3480255019 my $crc = crc32($data) ; is $crc, $expected_crc; @@ -912,7 +912,7 @@ if ($] >= 5.005) my $data = "\x6c\x70\x73\x63\x4f\x56\x73\x41\x4a\x69\x55\x66" . "\x4e\x43\x6f\x6d\x6b\x4f\x66\x57\x59\x42\x63\x50" . "\x68\x48\x5a\x5b\x62\x54"; - my $expected_crc = 0xAAD60AC7 ; # 2866154183 + my $expected_crc = 0xAAD60AC7 ; # 2866154183 my $crc = adler32($data) ; is $crc, $expected_crc; } @@ -930,11 +930,11 @@ if ($] >= 5.005) ok length $compressed > 4096 ; ok my $out = memGunzip(\$compressed) ; is $gzerrno, 0; - + ok $contents eq $out ; is length $out, length $contents ; - + } @@ -946,7 +946,7 @@ some text EOM my $good ; - ok my $x = new IO::Compress::Gzip \$good, Append => 1, -HeaderCRC => 1 ; + ok my $x = IO::Compress::Gzip->new( \$good, Append => 1, -HeaderCRC => 1 ); ok $x->write($string) ; ok $x->close ; @@ -996,8 +996,8 @@ some text EOM my $truncated ; - ok my $x = new IO::Compress::Gzip \$truncated, Append => 1, -HeaderCRC => 1, Strict => 0, - -ExtraField => "hello" x 10 ; + ok my $x = IO::Compress::Gzip->new( \$truncated, Append => 1, -HeaderCRC => 1, Strict => 0, + -ExtraField => "hello" x 10 ); ok $x->write($string) ; ok $x->close ; @@ -1018,7 +1018,7 @@ some text EOM my $truncated ; - ok my $x = new IO::Compress::Gzip \$truncated, Append => 1, -Name => $Name; + ok my $x = IO::Compress::Gzip->new( \$truncated, Append => 1, -Name => $Name ); ok $x->write($string) ; ok $x->close ; @@ -1037,7 +1037,7 @@ some text EOM my $truncated ; - ok my $x = new IO::Compress::Gzip \$truncated, -Comment => $Comment; + ok my $x = IO::Compress::Gzip->new( \$truncated, -Comment => $Comment ); ok $x->write($string) ; ok $x->close ; @@ -1054,7 +1054,7 @@ some text EOM my $truncated ; - ok my $x = new IO::Compress::Gzip \$truncated, -HeaderCRC => 1; + ok my $x = IO::Compress::Gzip->new( \$truncated, -HeaderCRC => 1 ); ok $x->write($string) ; ok $x->close ; @@ -1071,19 +1071,19 @@ some text EOM my $buffer ; - ok my $x = new IO::Compress::Gzip \$buffer, + ok my $x = IO::Compress::Gzip->new( \$buffer, -Append => 1, -Strict => 0, -HeaderCRC => 1, -Name => "Fred", -ExtraField => "Extra", - -Comment => 'Comment'; + -Comment => 'Comment' ); ok $x->write($string) ; ok $x->close ; ok defined $buffer ; - ok my $got = memGunzip($buffer) + ok my $got = memGunzip($buffer) or diag "gzerrno is $gzerrno" ; is $got, $string ; is $gzerrno, 0; @@ -1098,7 +1098,7 @@ some text EOM my $good ; - ok my $x = new IO::Compress::Gzip \$good, Append => 1 ; + ok my $x = IO::Compress::Gzip->new( \$good, Append => 1 ); ok $x->write($string) ; ok $x->close ; @@ -1176,7 +1176,7 @@ sub trickle title "Append & MultiStream Tests"; # rt.24041 - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $data1 = "the is the first"; my $data2 = "and this is the second"; my $trailing = "some trailing data"; @@ -1185,7 +1185,7 @@ sub trickle title "One file"; $fil = gzopen($name, "wb") ; - ok $fil, "opened first file"; + ok $fil, "opened first file"; is $fil->gzwrite($data1), length $data1, "write data1" ; ok ! $fil->gzclose(), "Closed"; @@ -1194,7 +1194,7 @@ sub trickle title "Two files"; $fil = gzopen($name, "ab") ; - ok $fil, "opened second file"; + ok $fil, "opened second file"; is $fil->gzwrite($data2), length $data2, "write data2" ; ok ! $fil->gzclose(), "Closed"; @@ -1214,12 +1214,12 @@ sub trickle title "gzclose & gzflush return codes"; # rt.29215 - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $data1 = "the is some text"; my $status; $fil = gzopen($name, "wb") ; - ok $fil, "opened first file"; + ok $fil, "opened first file"; is $fil->gzwrite($data1), length $data1, "write data1" ; $status = $fil->gzflush(0xfff); ok $status, "flush not ok" ; @@ -1233,17 +1233,17 @@ sub trickle { title "repeated calls to flush - no compression"; - my ($err, $x, $X, $status, $data); - + my ($err, $x, $X, $status, $data); + ok( ($x, $err) = deflateInit ( ), "Create deflate object" ); isa_ok $x, "Compress::Raw::Zlib::deflateStream" ; cmp_ok $err, '==', Z_OK, "status is Z_OK" ; - + ($data, $status) = $x->flush(Z_SYNC_FLUSH) ; - cmp_ok $status, '==', Z_OK, "flush returned Z_OK" ; + cmp_ok $status, '==', Z_OK, "flush returned Z_OK" ; ($data, $status) = $x->flush(Z_SYNC_FLUSH) ; - cmp_ok $status, '==', Z_OK, "second flush returned Z_OK" ; + cmp_ok $status, '==', Z_OK, "second flush returned Z_OK" ; is $data, "", "no output from second flush"; } @@ -1251,18 +1251,18 @@ sub trickle title "repeated calls to flush - after compression"; my $hello = "I am a HAL 9000 computer" ; - my ($err, $x, $X, $status, $data); - + my ($err, $x, $X, $status, $data); + ok( ($x, $err) = deflateInit ( ), "Create deflate object" ); isa_ok $x, "Compress::Raw::Zlib::deflateStream" ; cmp_ok $err, '==', Z_OK, "status is Z_OK" ; - + ($data, $status) = $x->deflate($hello) ; cmp_ok $status, '==', Z_OK, "deflate returned Z_OK" ; - + ($data, $status) = $x->flush(Z_SYNC_FLUSH) ; - cmp_ok $status, '==', Z_OK, "flush returned Z_OK" ; + cmp_ok $status, '==', Z_OK, "flush returned Z_OK" ; ($data, $status) = $x->flush(Z_SYNC_FLUSH) ; - cmp_ok $status, '==', Z_OK, "second flush returned Z_OK" ; + cmp_ok $status, '==', Z_OK, "second flush returned Z_OK" ; is $data, "", "no output from second flush"; } diff --git a/cpan/IO-Compress/t/cz-06gzsetp.t b/cpan/IO-Compress/t/cz-06gzsetp.t index b2cc687f5ab4..e45fa4d8af32 100644 --- a/cpan/IO-Compress/t/cz-06gzsetp.t +++ b/cpan/IO-Compress/t/cz-06gzsetp.t @@ -9,10 +9,10 @@ use lib qw(t t/compress); use strict; use warnings; use bytes; - + use Test::More ; use CompTestUtils; - + use Compress::Zlib 2 ; use IO::Compress::Gzip ; @@ -26,9 +26,9 @@ use IO::Uncompress::RawInflate ; our ($extra); - -BEGIN -{ + +BEGIN +{ # use Test::NoWarnings, if available $extra = 0 ; $extra = 1 @@ -43,12 +43,12 @@ plan tests => 51 + $extra ; # Check zlib_version and ZLIB_VERSION are the same. SKIP: { - skip "TEST_SKIP_VERSION_CHECK is set", 1 + skip "TEST_SKIP_VERSION_CHECK is set", 1 if $ENV{TEST_SKIP_VERSION_CHECK}; is Compress::Zlib::zlib_version, ZLIB_VERSION, "ZLIB_VERSION matches Compress::Zlib::zlib_version" ; } - + { # gzsetparams title "Testing gzsetparams"; @@ -59,13 +59,13 @@ SKIP: { my $len_goodbye = length $goodbye; my ($input, $err, $answer, $X, $status, $Answer); - - my $lex = new LexFile my $name ; + + my $lex = LexFile->new( my $name ); ok my $x = gzopen($name, "wb"); $input .= $hello; is $x->gzwrite($hello), $len_hello, "gzwrite returned $len_hello" ; - + # Error cases eval { $x->gzsetparams() }; like $@, mkErr('^Usage: Compress::Zlib::gzFile::gzsetparams\(file, level, strategy\)'); @@ -73,14 +73,14 @@ SKIP: { # Change both Level & Strategy $status = $x->gzsetparams(Z_BEST_SPEED, Z_HUFFMAN_ONLY) ; cmp_ok $status, '==', Z_OK, "status is Z_OK"; - + $input .= $goodbye; is $x->gzwrite($goodbye), $len_goodbye, "gzwrite returned $len_goodbye" ; - + ok ! $x->gzclose, "closed" ; ok my $k = gzopen($name, "rb") ; - + # calling gzsetparams on reading is not allowed. $status = $k->gzsetparams(Z_BEST_SPEED, Z_HUFFMAN_ONLY) ; cmp_ok $status, '==', Z_STREAM_ERROR, "status is Z_STREAM_ERROR" ; @@ -116,29 +116,29 @@ foreach my $CompressClass ('IO::Compress::Gzip', #my ($input, $err, $answer, $X, $status, $Answer); my $compressed; - ok my $x = new $CompressClass(\$compressed) ; + ok my $x = $CompressClass->can('new')->( $CompressClass, \$compressed) ; my $input .= $hello; is $x->write($hello), $len_hello, "wrote $len_hello bytes" ; - + # Change both Level & Strategy ok $x->deflateParams(Z_BEST_SPEED, Z_HUFFMAN_ONLY), "deflateParams ok"; $input .= $goodbye; is $x->write($goodbye), $len_goodbye, "wrote $len_goodbye bytes" ; - + ok $x->close, "closed $CompressClass object" ; - my $k = new $UncompressClass(\$compressed); + my $k = $UncompressClass->can('new')->( $UncompressClass, \$compressed); isa_ok $k, $UncompressClass; - + my $len = length $input ; my $uncompressed; - is $k->read($uncompressed, $len), $len + is $k->read($uncompressed, $len), $len or diag "$IO::Uncompress::Gunzip::GunzipError" ; - ok $uncompressed eq $input, "got expected uncompressed data" - or diag("unc len = " . length($uncompressed) . ", input len = " . + ok $uncompressed eq $input, "got expected uncompressed data" + or diag("unc len = " . length($uncompressed) . ", input len = " . length($input) . "\n") ; ok $k->eof, "eof" ; ok $k->close, "closed" ; diff --git a/cpan/IO-Compress/t/cz-08encoding.t b/cpan/IO-Compress/t/cz-08encoding.t index ed5971bc8acb..951efa44b513 100644 --- a/cpan/IO-Compress/t/cz-08encoding.t +++ b/cpan/IO-Compress/t/cz-08encoding.t @@ -38,7 +38,7 @@ BEGIN # Check zlib_version and ZLIB_VERSION are the same. SKIP: { - skip "TEST_SKIP_VERSION_CHECK is set", 1 + skip "TEST_SKIP_VERSION_CHECK is set", 1 if $ENV{TEST_SKIP_VERSION_CHECK}; is Compress::Zlib::zlib_version, ZLIB_VERSION, "ZLIB_VERSION matches Compress::Zlib::zlib_version" ; @@ -47,13 +47,13 @@ SKIP: { { title "memGzip" ; # length of this string is 2 characters - my $s = "\x{df}\x{100}"; + my $s = "\x{df}\x{100}"; my $cs = memGzip(Encode::encode_utf8($s)); # length stored at end of gzip file should be 4 my ($crc, $len) = unpack ("VV", substr($cs, -8, 8)); - + is $len, 4, " length is 4"; } @@ -65,7 +65,7 @@ SKIP: { is memGunzip(my $x = $co), $s, " match uncompressed"; utf8::upgrade($co); - + my $un = memGunzip($co); ok $un, " got uncompressed"; @@ -75,7 +75,7 @@ SKIP: { { title "compress/uncompress"; - my $s = "\x{df}\x{100}"; + my $s = "\x{df}\x{100}"; my $s_copy = $s ; my $ces = compress(Encode::encode_utf8($s_copy)); @@ -84,21 +84,21 @@ SKIP: { my $un = Encode::decode_utf8(uncompress($ces)); is $un, $s, " decode_utf8 ok"; - + utf8::upgrade($ces); $un = Encode::decode_utf8(uncompress($ces)); is $un, $s, " decode_utf8 ok"; - + } { title "gzopen" ; - my $s = "\x{df}\x{100}"; + my $s = "\x{df}\x{100}"; my $byte_len = length( Encode::encode_utf8($s) ); my ($uncomp) ; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); ok my $fil = gzopen($name, "wb"), " gzopen for write ok" ; is $fil->gzwrite(Encode::encode_utf8($s)), $byte_len, " wrote $byte_len bytes" ; @@ -131,7 +131,7 @@ SKIP: { eval { uncompress($a) }; like($@, qr/Wide character in uncompress/, " wide characters in uncompress"); - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); ok my $fil = gzopen($name, "wb"), " gzopen for write ok" ; eval { $fil->gzwrite($a); } ; @@ -139,4 +139,3 @@ SKIP: { ok ! $fil->gzclose, " gzclose ok" ; } - diff --git a/cpan/IO-Compress/t/cz-14gzopen.t b/cpan/IO-Compress/t/cz-14gzopen.t index 3d6a0626ee7c..59a4d82bec07 100644 --- a/cpan/IO-Compress/t/cz-14gzopen.t +++ b/cpan/IO-Compress/t/cz-14gzopen.t @@ -28,156 +28,156 @@ BEGIN { { SKIP: { - skip "TEST_SKIP_VERSION_CHECK is set", 1 + skip "TEST_SKIP_VERSION_CHECK is set", 1 if $ENV{TEST_SKIP_VERSION_CHECK}; # Check zlib_version and ZLIB_VERSION are the same. is Compress::Zlib::zlib_version, ZLIB_VERSION, "ZLIB_VERSION matches Compress::Zlib::zlib_version" ; } } - + { # gzip tests #=========== - + #my $name = "test.gz" ; - my $lex = new LexFile my $name ; - + my $lex = LexFile->new( my $name ); + my $hello = <gzerror(), 0, "gzerror() returned 0"; - + is $fil->gztell(), 0, "gztell returned 0"; is $gzerrno, 0, 'gzerrno is 0'; - + is $fil->gzwrite($hello), $len ; is $gzerrno, 0, 'gzerrno is 0'; - + is $fil->gztell(), $len, "gztell returned $len"; is $gzerrno, 0, 'gzerrno is 0'; - + ok ! $fil->gzclose ; - + ok $fil = gzopen($name, "rb") ; - + ok ! $fil->gzeof() ; is $gzerrno, 0, 'gzerrno is 0'; is $fil->gztell(), 0; - - is $fil->gzread($uncomp), $len; - + + is $fil->gzread($uncomp), $len; + is $fil->gztell(), $len; ok $fil->gzeof() ; - + # gzread after eof bahavior - + my $xyz = "123" ; is $fil->gzread($xyz), 0, "gzread returns 0 on eof" ; is $xyz, "", "gzread on eof zaps the output buffer [Match 1,x behavior]" ; - + ok ! $fil->gzclose ; ok $fil->gzeof() ; - + ok $hello eq $uncomp ; } { title 'check that a number can be gzipped'; - my $lex = new LexFile my $name ; - - + my $lex = LexFile->new( my $name ); + + my $number = 7603 ; my $num_len = 4 ; - + ok my $fil = gzopen($name, "wb") ; - + is $gzerrno, 0; - + is $fil->gzwrite($number), $num_len, "gzwrite returned $num_len" ; is $gzerrno, 0, 'gzerrno is 0'; ok ! $fil->gzflush(Z_FINISH) ; - + is $gzerrno, 0, 'gzerrno is 0'; - + ok ! $fil->gzclose ; - + cmp_ok $gzerrno, '==', 0; - + ok $fil = gzopen($name, "rb") ; - + my $uncomp; ok ((my $x = $fil->gzread($uncomp)) == $num_len) ; - + ok $fil->gzerror() == 0 || $fil->gzerror() == Z_STREAM_END; ok $gzerrno == 0 || $gzerrno == Z_STREAM_END; ok $fil->gzeof() ; - + ok ! $fil->gzclose ; ok $fil->gzeof() ; - + ok $gzerrno == 0 or print "# gzerrno is $gzerrno\n" ; - + 1 while unlink $name ; - + ok $number == $uncomp ; ok $number eq $uncomp ; } { title "now a bigger gzip test"; - + my $text = 'text' ; - my $lex = new LexFile my $file ; - - + my $lex = LexFile->new( my $file ); + + ok my $f = gzopen($file, "wb") ; - + # generate a long random string my $contents = '' ; foreach (1 .. 5000) { $contents .= chr int rand 256 } - + my $len = length $contents ; - + is $f->gzwrite($contents), $len ; - + ok ! $f->gzclose ; - + ok $f = gzopen($file, "rb") ; - + ok ! $f->gzeof() ; - + my $uncompressed ; is $f->gzread($uncompressed, $len), $len ; - - is $contents, $uncompressed - - or print "# Length orig $len" . + + is $contents, $uncompressed + + or print "# Length orig $len" . ", Length uncompressed " . length($uncompressed) . "\n" ; - + ok $f->gzeof() ; ok ! $f->gzclose ; - + } { title "gzip - readline tests"; # ====================== - + # first create a small gzipped text file - my $lex = new LexFile my $name ; - + my $lex = LexFile->new( my $name ); + my @text = (<gzwrite($text), length($text) ; ok ! $fil->gzclose ; - + # now try to read it back in ok $fil = gzopen($name, "rb") ; ok ! $fil->gzeof() ; @@ -204,15 +204,15 @@ EOM is $line, $text[$i] ; ok ! $fil->gzeof() ; } - + # now read the last line ok $fil->gzreadline($line) > 0; is $line, $text[-1] ; ok $fil->gzeof() ; - + # read past the eof is $fil->gzreadline($line), 0; - + ok $fil->gzeof() ; ok ! $fil->gzclose ; ok $fil->gzeof() ; @@ -220,7 +220,7 @@ EOM { title "A text file with a very long line (bigger than the internal buffer)"; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $line1 = ("abcdefghijklmnopq" x 2000) . "\n" ; my $line2 = "second line\n" ; @@ -228,7 +228,7 @@ EOM ok my $fil = gzopen($name, "wb"), " gzopen ok" ; is $fil->gzwrite($text), length $text, " gzwrite ok" ; ok ! $fil->gzclose, " gzclose" ; - + # now try to read it back in ok $fil = gzopen($name, "rb"), " gzopen" ; ok ! $fil->gzeof(), "! eof" ; @@ -236,13 +236,13 @@ EOM my @got = (); my $line; while ($fil->gzreadline($line) > 0) { - $got[$i] = $line ; + $got[$i] = $line ; ++ $i ; } is $i, 2, " looped twice" ; is $got[0], $line1, " got line 1" ; is $got[1], $line2, " hot line 2" ; - + ok $fil->gzeof(), " gzeof" ; ok ! $fil->gzclose, " gzclose" ; ok $fil->gzeof(), " gzeof" ; @@ -250,30 +250,30 @@ EOM { title "a text file which is not terminated by an EOL"; - - my $lex = new LexFile my $name ; - + + my $lex = LexFile->new( my $name ); + my $line1 = "hello hello, I'm back again\n" ; my $line2 = "there is no end in sight" ; - + my $text = $line1 . $line2 ; ok my $fil = gzopen($name, "wb"), " gzopen" ; is $fil->gzwrite($text), length $text, " gzwrite" ; ok ! $fil->gzclose, " gzclose" ; - + # now try to read it back in ok $fil = gzopen($name, "rb"), " gzopen" ; - my @got = () ; + my @got = () ; my $i = 0 ; my $line; while ($fil->gzreadline($line) > 0) { - $got[$i] = $line ; + $got[$i] = $line ; ++ $i ; } is $i, 2, " got 2 lines" ; is $got[0], $line1, " line 1 ok" ; is $got[1], $line2, " line 2 ok" ; - + ok $fil->gzeof(), " gzeof" ; ok ! $fil->gzclose, " gzclose" ; } @@ -281,23 +281,23 @@ EOM { title 'mix gzread and gzreadline'; - + # case 1: read a line, then a block. The block is # smaller than the internal block used by # gzreadline - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $line1 = "hello hello, I'm back again\n" ; - my $line2 = "abc" x 200 ; + my $line2 = "abc" x 200 ; my $line3 = "def" x 200 ; my $line; - + my $text = $line1 . $line2 . $line3 ; my $fil; ok $fil = gzopen($name, "wb"), ' gzopen for write ok' ; is $fil->gzwrite($text), length $text, ' gzwrite ok' ; is $fil->gztell(), length $text, ' gztell ok' ; ok ! $fil->gzclose, ' gzclose ok' ; - + # now try to read it back in ok $fil = gzopen($name, "rb"), ' gzopen for read ok' ; ok ! $fil->gzeof(), ' !gzeof' ; @@ -319,12 +319,12 @@ EOM { title "Pass gzopen a filehandle - use IO::File" ; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $hello = "hello" ; my $len = length $hello ; - my $f = new IO::File ">$name" ; + my $f = IO::File->new( ">$name" ); ok $f; my $fil; @@ -334,11 +334,11 @@ EOM ok ! $fil->gzclose ; - $f = new IO::File "<$name" ; + $f = IO::File->new( "<$name" ); ok $fil = gzopen($name, "rb") ; my $uncomp; my $x; - ok (($x = $fil->gzread($uncomp)) == $len) + ok (($x = $fil->gzread($uncomp)) == $len) or print "# length $x, expected $len\n" ; ok $fil->gzeof() ; @@ -352,7 +352,7 @@ EOM { title "Pass gzopen a filehandle - use open" ; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $hello = "hello" ; my $len = length $hello ; @@ -389,7 +389,7 @@ foreach my $stdio ( ['-', '-'], [*STDIN, *STDOUT]) title "Pass gzopen a filehandle - use $stdin" ; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $hello = "hello" ; my $len = length $hello ; @@ -397,12 +397,12 @@ foreach my $stdio ( ['-', '-'], [*STDIN, *STDOUT]) ok open(SAVEOUT, ">&STDOUT"), " save STDOUT"; my $dummy = fileno SAVEOUT; ok open(STDOUT, ">$name"), " redirect STDOUT" ; - + my $status = 0 ; my $fil = gzopen($stdout, "wb") ; - $status = $fil && + $status = $fil && ($fil->gzwrite($hello) == $len) && ($fil->gzclose == 0) ; @@ -417,7 +417,7 @@ foreach my $stdio ( ['-', '-'], [*STDIN, *STDOUT]) ok $fil = gzopen($stdin, "rb") ; my $uncomp; my $x; - ok (($x = $fil->gzread($uncomp)) == $len) + ok (($x = $fil->gzread($uncomp)) == $len) or print "# length $x, expected $len\n" ; ok $fil->gzeof() ; @@ -433,7 +433,7 @@ foreach my $stdio ( ['-', '-'], [*STDIN, *STDOUT]) { title 'test parameters for gzopen'; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $fil; @@ -462,7 +462,7 @@ foreach my $stdio ( ['-', '-'], [*STDIN, *STDOUT]) { title 'Read operations when opened for writing'; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $fil; ok $fil = gzopen($name, "wb"), ' gzopen for writing' ; ok !$fil->gzeof(), ' !eof'; ; @@ -473,7 +473,7 @@ foreach my $stdio ( ['-', '-'], [*STDIN, *STDOUT]) { title 'write operations when opened for reading'; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $text = "hello" ; my $fil; ok $fil = gzopen($name, "wb"), " gzopen for writing" ; @@ -489,22 +489,22 @@ foreach my $stdio ( ['-', '-'], [*STDIN, *STDOUT]) SKIP: { - skip "Cannot create non-writable file", 3 + skip "Cannot create non-writable file", 3 if $^O eq 'cygwin'; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); writeFile($name, "abc"); - chmod 0444, $name + chmod 0444, $name or skip "Cannot create non-writable file", 3 ; - skip "Cannot create non-writable file", 3 + skip "Cannot create non-writable file", 3 if -w $name ; ok ! -w $name, " input file not writable"; my $fil = gzopen($name, "wb") ; ok !$fil, " gzopen returns undef" ; - ok $gzerrno, " gzerrno ok" or + ok $gzerrno, " gzerrno ok" or diag " gzerrno $gzerrno\n"; chmod 0777, $name ; @@ -512,14 +512,14 @@ foreach my $stdio ( ['-', '-'], [*STDIN, *STDOUT]) SKIP: { - my $lex = new LexFile my $name ; - skip "Cannot create non-readable file", 3 + my $lex = LexFile->new( my $name ); + skip "Cannot create non-readable file", 3 if $^O eq 'cygwin'; writeFile($name, "abc"); chmod 0222, $name ; - skip "Cannot create non-readable file", 3 + skip "Cannot create non-readable file", 3 if -r $name ; ok ! -r $name, " input file not readable"; @@ -536,7 +536,7 @@ foreach my $stdio ( ['-', '-'], [*STDIN, *STDOUT]) title "gzseek" ; my $buff ; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $first = "beginning" ; my $last = "the end" ; @@ -580,11 +580,11 @@ foreach my $stdio ( ['-', '-'], [*STDIN, *STDOUT]) { # seek error cases - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $a = gzopen($name, "w"); - ok ! $a->gzerror() + ok ! $a->gzerror() or print "# gzerrno is $Compress::Zlib::gzerrno \n" ; eval { $a->gzseek(-1, 10) ; }; like $@, mkErr("gzseek: unknown value, 10, for whence parameter"); @@ -610,7 +610,7 @@ foreach my $stdio ( ['-', '-'], [*STDIN, *STDOUT]) { title "gzread ver 1.x compat -- the output buffer is always zapped."; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $a = gzopen($name, "w"); $a->gzwrite("fred"); @@ -632,7 +632,7 @@ foreach my $stdio ( ['-', '-'], [*STDIN, *STDOUT]) { title 'gzreadline does not support $/'; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); my $a = gzopen($name, "w"); my $text = "fred\n"; @@ -656,12 +656,12 @@ foreach my $stdio ( ['-', '-'], [*STDIN, *STDOUT]) { title 'gzflush called twice with Z_SYNC_FLUSH - no compression'; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); ok my $a = gzopen($name, "w"); - + + is $a->gzflush(Z_SYNC_FLUSH), Z_OK, "gzflush returns Z_OK"; is $a->gzflush(Z_SYNC_FLUSH), Z_OK, "gzflush returns Z_OK"; - is $a->gzflush(Z_SYNC_FLUSH), Z_OK, "gzflush returns Z_OK"; } @@ -669,13 +669,13 @@ foreach my $stdio ( ['-', '-'], [*STDIN, *STDOUT]) { title 'gzflush called twice - after compression'; - my $lex = new LexFile my $name ; + my $lex = LexFile->new( my $name ); ok my $a = gzopen($name, "w"); my $text = "fred\n"; my $len = length $text; is $a->gzwrite($text), length($text), "gzwrite ok"; - + + is $a->gzflush(Z_SYNC_FLUSH), Z_OK, "gzflush returns Z_OK"; is $a->gzflush(Z_SYNC_FLUSH), Z_OK, "gzflush returns Z_OK"; - is $a->gzflush(Z_SYNC_FLUSH), Z_OK, "gzflush returns Z_OK"; } diff --git a/cpan/IO-Compress/t/globmapper.t b/cpan/IO-Compress/t/globmapper.t index 0c60aa6b21d2..c97beb610a35 100644 --- a/cpan/IO-Compress/t/globmapper.t +++ b/cpan/IO-Compress/t/globmapper.t @@ -13,8 +13,8 @@ use Test::More ; use CompTestUtils; -BEGIN -{ +BEGIN +{ plan(skip_all => "File::GlobMapper needs Perl 5.005 or better - you have Perl $]" ) if $] < 5.005 ; @@ -26,7 +26,7 @@ Perl $]" ) plan tests => 68 + $extra ; - use_ok('File::GlobMapper') ; + use_ok('File::GlobMapper') ; } { @@ -36,21 +36,21 @@ Perl $]" ) for my $delim ( qw/ ( ) { } [ ] / ) { - $gm = new File::GlobMapper("${delim}abc", '*.X'); + $gm = File::GlobMapper->new("${delim}abc", '*.X'); ok ! $gm, " new failed" ; - is $File::GlobMapper::Error, "Unmatched $delim in input fileglob", + is $File::GlobMapper::Error, "Unmatched $delim in input fileglob", " catch unmatched $delim"; } for my $delim ( qw/ ( ) [ ] / ) { - $gm = new File::GlobMapper("{${delim}abc}", '*.X'); + $gm = File::GlobMapper->new("{${delim}abc}", '*.X'); ok ! $gm, " new failed" ; - is $File::GlobMapper::Error, "Unmatched $delim in input fileglob", + is $File::GlobMapper::Error, "Unmatched $delim in input fileglob", " catch unmatched $delim inside {}"; } - + } { @@ -58,10 +58,10 @@ Perl $]" ) #my $tmpDir = 'td'; my $tmpDir ; - my $lex = new LexDir $tmpDir; + my $lex = LexDir->new( $tmpDir ); my $d = quotemeta $tmpDir; - my $gm = new File::GlobMapper("$d/Z*", '*.X'); + my $gm = File::GlobMapper->new("$d/Z*", '*.X'); ok $gm, " created GlobMapper object" ; my $map = $gm->getFileMap() ; @@ -77,12 +77,12 @@ Perl $]" ) #my $tmpDir = 'td'; my $tmpDir ; - my $lex = new LexDir $tmpDir; + my $lex = LexDir->new( $tmpDir ); #mkdir $tmpDir, 0777 ; touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; - my $gm = new File::GlobMapper("$tmpDir/ab*.tmp", "*X"); + my $gm = File::GlobMapper->new("$tmpDir/ab*.tmp", "*X"); ok $gm, " created GlobMapper object" ; my $map = $gm->getFileMap() ; @@ -106,12 +106,12 @@ Perl $]" ) #my $tmpDir = 'td'; my $tmpDir ; - my $lex = new LexDir $tmpDir; + my $lex = LexDir->new( $tmpDir ); #mkdir $tmpDir, 0777 ; touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; - my $gm = new File::GlobMapper("$tmpDir/abc2.tmp", "$tmpDir/abc2.tmp"); + my $gm = File::GlobMapper->new("$tmpDir/abc2.tmp", "$tmpDir/abc2.tmp"); ok $gm, " created GlobMapper object" ; my $map = $gm->getFileMap() ; @@ -130,12 +130,12 @@ Perl $]" ) title 'test wildcard mapping of {} in destination'; my $tmpDir ;#= 'td'; - my $lex = new LexDir $tmpDir; + my $lex = LexDir->new( $tmpDir ); #mkdir $tmpDir, 0777 ; touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; - my $gm = new File::GlobMapper("$tmpDir/abc{1,3}.tmp", "*.X"); + my $gm = File::GlobMapper->new("$tmpDir/abc{1,3}.tmp", "*.X"); #diag "Input pattern is $gm->{InputPattern}"; ok $gm, " created GlobMapper object" ; @@ -146,7 +146,7 @@ Perl $]" ) [map { "$tmpDir/$_" } qw(abc3.tmp abc3.tmp.X)], ], " got mapping"; - $gm = new File::GlobMapper("$tmpDir/abc{1,3}.tmp", "$tmpDir/X.#1.X") + $gm = File::GlobMapper->new("$tmpDir/abc{1,3}.tmp", "$tmpDir/X.#1.X") or diag $File::GlobMapper::Error ; #diag "Input pattern is $gm->{InputPattern}"; ok $gm, " created GlobMapper object" ; @@ -165,13 +165,13 @@ Perl $]" ) title 'test wildcard mapping of multiple * to #'; my $tmpDir ;#= 'td'; - my $lex = new LexDir $tmpDir; + my $lex = LexDir->new( $tmpDir ); #mkdir $tmpDir, 0777 ; touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; - my $gm = new File::GlobMapper("$tmpDir/*b(*).tmp", "$tmpDir/X-#2-#1-X"); - ok $gm, " created GlobMapper object" + my $gm = File::GlobMapper->new("$tmpDir/*b(*).tmp", "$tmpDir/X-#2-#1-X"); + ok $gm, " created GlobMapper object" or diag $File::GlobMapper::Error ; my $map = $gm->getFileMap() ; @@ -187,12 +187,12 @@ Perl $]" ) title 'test wildcard mapping of multiple ? to #'; my $tmpDir ;#= 'td'; - my $lex = new LexDir $tmpDir; + my $lex = LexDir->new( $tmpDir ); #mkdir $tmpDir, 0777 ; touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; - my $gm = new File::GlobMapper("$tmpDir/?b(*).tmp", "$tmpDir/X-#2-#1-X"); + my $gm = File::GlobMapper->new("$tmpDir/?b(*).tmp", "$tmpDir/X-#2-#1-X"); ok $gm, " created GlobMapper object" ; my $map = $gm->getFileMap() ; @@ -208,12 +208,12 @@ Perl $]" ) title 'test wildcard mapping of multiple ?,* and [] to #'; my $tmpDir ;#= 'td'; - my $lex = new LexDir $tmpDir; + my $lex = LexDir->new( $tmpDir ); #mkdir $tmpDir, 0777 ; touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; - my $gm = new File::GlobMapper("$tmpDir/?b[a-z]*.tmp", "$tmpDir/X-#3-#2-#1-X"); + my $gm = File::GlobMapper->new("$tmpDir/?b[a-z]*.tmp", "$tmpDir/X-#3-#2-#1-X"); ok $gm, " created GlobMapper object" ; #diag "Input pattern is $gm->{InputPattern}"; @@ -230,12 +230,12 @@ Perl $]" ) title 'input glob matches a file multiple times'; my $tmpDir ;#= 'td'; - my $lex = new LexDir $tmpDir; + my $lex = LexDir->new( $tmpDir ); #mkdir $tmpDir, 0777 ; touch "$tmpDir/abc.tmp"; - my $gm = new File::GlobMapper("$tmpDir/{a*,*c}.tmp", '*.X'); + my $gm = File::GlobMapper->new("$tmpDir/{a*,*c}.tmp", '*.X'); ok $gm, " created GlobMapper object" ; my $map = $gm->getFileMap() ; @@ -253,12 +253,12 @@ Perl $]" ) title 'multiple input files map to one output file'; my $tmpDir ;#= 'td'; - my $lex = new LexDir $tmpDir; + my $lex = LexDir->new( $tmpDir ); #mkdir $tmpDir, 0777 ; touch map { "$tmpDir/$_.tmp" } qw( abc def) ; - my $gm = new File::GlobMapper("$tmpDir/*.tmp", "$tmpDir/fred"); + my $gm = File::GlobMapper->new("$tmpDir/*.tmp", "$tmpDir/fred"); ok ! $gm, " did not create GlobMapper object" ; is $File::GlobMapper::Error, 'multiple input files map to one output file', " Error is expected" ; @@ -273,13 +273,13 @@ Perl $]" ) title "globmap" ; my $tmpDir ;#= 'td'; - my $lex = new LexDir $tmpDir; + my $lex = LexDir->new( $tmpDir ); #mkdir $tmpDir, 0777 ; touch map { "$tmpDir/$_.tmp" } qw( abc1 abc2 abc3 ) ; my $map = File::GlobMapper::globmap("$tmpDir/*b*.tmp", "$tmpDir/X-#2-#1-X"); - ok $map, " got map" + ok $map, " got map" or diag $File::GlobMapper::Error ; is @{ $map }, 3, " returned 3 maps"; @@ -305,4 +305,3 @@ Perl $]" ) # {} and {,} are special cases # {ab*,de*} # {abc,{},{de,f}} => abc {} de f - diff --git a/cpan/IPC-SysV/.gitignore b/cpan/IPC-SysV/.gitignore index 2a06e93b553d..6531b6b8ed84 100644 --- a/cpan/IPC-SysV/.gitignore +++ b/cpan/IPC-SysV/.gitignore @@ -1 +1,2 @@ *.inc +!/Makefile.PL diff --git a/cpan/IPC-SysV/SysV.xs b/cpan/IPC-SysV/SysV.xs index 6a0329cfe8a9..6690718aa859 100644 --- a/cpan/IPC-SysV/SysV.xs +++ b/cpan/IPC-SysV/SysV.xs @@ -379,7 +379,7 @@ memwrite(addr, sv, pos, size) char *caddr = (char *) sv2addr(addr); STRLEN len; const char *src = SvPV_const(sv, len); - int n = ((int) len > size) ? size : (int) len; + unsigned int n = ((unsigned int) len > size) ? size : (unsigned int) len; Copy(src, caddr + pos, n, char); if (n < size) { diff --git a/cpan/IPC-SysV/lib/IPC/Msg.pm b/cpan/IPC-SysV/lib/IPC/Msg.pm index 051539da1c06..281b22020172 100644 --- a/cpan/IPC-SysV/lib/IPC/Msg.pm +++ b/cpan/IPC-SysV/lib/IPC/Msg.pm @@ -15,7 +15,7 @@ use strict; use vars qw($VERSION); use Carp; -$VERSION = '2.08'; +$VERSION = '2.09'; # Figure out if we have support for native sized types my $N = do { my $foo = eval { pack "L!", 0 }; $@ ? '' : '!' }; @@ -42,7 +42,7 @@ my $N = do { my $foo = eval { pack "L!", 0 }; $@ ? '' : '!' }; } sub new { - @_ == 3 || croak 'new IPC::Msg ( KEY , FLAGS )'; + @_ == 3 || croak 'IPC::Msg->new( KEY , FLAGS )'; my $class = shift; my $id = msgget($_[0],$_[1]); diff --git a/cpan/IPC-SysV/lib/IPC/Semaphore.pm b/cpan/IPC-SysV/lib/IPC/Semaphore.pm index 9284e7acaf5d..a8f61b26c8e6 100644 --- a/cpan/IPC-SysV/lib/IPC/Semaphore.pm +++ b/cpan/IPC-SysV/lib/IPC/Semaphore.pm @@ -16,7 +16,7 @@ use strict; use vars qw($VERSION); use Carp; -$VERSION = '2.08'; +$VERSION = '2.09'; # Figure out if we have support for native sized types my $N = do { my $foo = eval { pack "L!", 0 }; $@ ? '' : '!' }; @@ -39,7 +39,7 @@ my $N = do { my $foo = eval { pack "L!", 0 }; $@ ? '' : '!' }; } sub new { - @_ == 4 || croak 'new ' . __PACKAGE__ . '( KEY, NSEMS, FLAGS )'; + @_ == 4 || croak __PACKAGE__ . '->new( KEY, NSEMS, FLAGS )'; my $class = shift; my $id = semget($_[0],$_[1],$_[2]); diff --git a/cpan/IPC-SysV/lib/IPC/SharedMem.pm b/cpan/IPC-SysV/lib/IPC/SharedMem.pm index 5ebec7bb2967..e1fbc850b3c2 100644 --- a/cpan/IPC-SysV/lib/IPC/SharedMem.pm +++ b/cpan/IPC-SysV/lib/IPC/SharedMem.pm @@ -15,7 +15,7 @@ use strict; use vars qw($VERSION); use Carp; -$VERSION = '2.08'; +$VERSION = '2.09'; # Figure out if we have support for native sized types my $N = do { my $foo = eval { pack "L!", 0 }; $@ ? '' : '!' }; diff --git a/cpan/IPC-SysV/lib/IPC/SysV.pm b/cpan/IPC-SysV/lib/IPC/SysV.pm index 0d531723eb0f..ebafceb9385e 100644 --- a/cpan/IPC-SysV/lib/IPC/SysV.pm +++ b/cpan/IPC-SysV/lib/IPC/SysV.pm @@ -18,7 +18,7 @@ use Config; require Exporter; @ISA = qw(Exporter); -$VERSION = '2.08'; +$VERSION = '2.09'; # To support new constants, just add them to @EXPORT_OK # and the C/XS code will be generated automagically. diff --git a/cpan/IPC-SysV/t/ipcsysv.t b/cpan/IPC-SysV/t/ipcsysv.t index 277490b4e3b4..8bbea07fd0f7 100644 --- a/cpan/IPC-SysV/t/ipcsysv.t +++ b/cpan/IPC-SysV/t/ipcsysv.t @@ -13,8 +13,8 @@ use warnings; our %Config; BEGIN { - require Test::More; import Test::More; - require Config; import Config; + require Test::More; Test::More->import; + require Config; Config->import; if ($ENV{'PERL_CORE'} && $Config{'extensions'} !~ m[\bIPC/SysV\b]) { plan(skip_all => 'IPC::SysV was not built'); diff --git a/cpan/IPC-SysV/t/msg.t b/cpan/IPC-SysV/t/msg.t index b31beb1a303e..c216202e06be 100644 --- a/cpan/IPC-SysV/t/msg.t +++ b/cpan/IPC-SysV/t/msg.t @@ -18,8 +18,8 @@ BEGIN { @INC = '../lib' if -d '../lib' && -d '../ext'; } - require Test::More; import Test::More; - require Config; import Config; + require Test::More; Test::More->import; + require Config; Config->import; if ($ENV{'PERL_CORE'} && $Config{'extensions'} !~ m[\bIPC/SysV\b]) { plan(skip_all => 'IPC::SysV was not built'); @@ -44,7 +44,7 @@ my $msq = sub { return $code->(); } return $code->(); -}->(sub { new IPC::Msg(IPC_PRIVATE, S_IRWXU | S_IRWXG | S_IRWXO) }); +}->(sub { IPC::Msg->new(IPC_PRIVATE, S_IRWXU | S_IRWXG | S_IRWXO) }); unless (defined $msq) { my $info = "IPC::Msg->new failed: $!"; diff --git a/cpan/IPC-SysV/t/pod.t b/cpan/IPC-SysV/t/pod.t index 3cc06d86c539..d3fee6b30545 100644 --- a/cpan/IPC-SysV/t/pod.t +++ b/cpan/IPC-SysV/t/pod.t @@ -18,8 +18,8 @@ BEGIN { @INC = '../lib' if -d '../lib' && -d '../ext'; } - require Test::More; import Test::More; - require Config; import Config; + require Test::More; Test::More->import; + require Config; Config->import; if ($ENV{'PERL_CORE'} && $Config{'extensions'} !~ m[\bIPC/SysV\b]) { plan(skip_all => 'IPC::SysV was not built'); @@ -51,12 +51,12 @@ eval { require Test::Pod; $Test::Pod::VERSION >= 0.95 or die "Test::Pod version only $Test::Pod::VERSION"; - import Test::Pod tests => scalar @pods; + Test::Pod->import( tests => scalar @pods ); }; if ($@) { require Test::More; - import Test::More skip_all => "testing pod requires Test::Pod"; + Test::More->import( skip_all => "testing pod requires Test::Pod" ); } else { for my $pod (@pods) { diff --git a/cpan/IPC-SysV/t/podcov.t b/cpan/IPC-SysV/t/podcov.t index 7aa2da9178ee..7067482ec8c1 100644 --- a/cpan/IPC-SysV/t/podcov.t +++ b/cpan/IPC-SysV/t/podcov.t @@ -18,8 +18,8 @@ BEGIN { @INC = '../lib' if -d '../lib' && -d '../ext'; } - require Test::More; import Test::More; - require Config; import Config; + require Test::More; Test::More->import; + require Config; Config->import; if ($ENV{'PERL_CORE'} && $Config{'extensions'} !~ m[\bIPC/SysV\b]) { plan(skip_all => 'IPC::SysV was not built'); diff --git a/cpan/IPC-SysV/t/sem.t b/cpan/IPC-SysV/t/sem.t index 2c0da6ba3385..1f1d06a97b84 100644 --- a/cpan/IPC-SysV/t/sem.t +++ b/cpan/IPC-SysV/t/sem.t @@ -18,8 +18,8 @@ BEGIN { @INC = '../lib' if -d '../lib' && -d '../ext'; } - require Test::More; import Test::More; - require Config; import Config; + require Test::More; Test::More->import; + require Config; Config->import; if ($ENV{'PERL_CORE'} && $Config{'extensions'} !~ m[\bIPC/SysV\b]) { plan(skip_all => 'IPC::SysV was not built'); diff --git a/cpan/IPC-SysV/t/shm.t b/cpan/IPC-SysV/t/shm.t index 454c18625f4c..5f4282ce4f0d 100644 --- a/cpan/IPC-SysV/t/shm.t +++ b/cpan/IPC-SysV/t/shm.t @@ -18,8 +18,8 @@ BEGIN { @INC = '../lib' if -d '../lib' && -d '../ext'; } - require Test::More; import Test::More; - require Config; import Config; + require Test::More; Test::More->import; + require Config; Config->import; if ($ENV{'PERL_CORE'} && $Config{'extensions'} !~ m[\bIPC/SysV\b]) { plan(skip_all => 'IPC::SysV was not built'); diff --git a/cpan/PerlIO-via-QuotedPrint/lib/PerlIO/via/QuotedPrint.pm b/cpan/PerlIO-via-QuotedPrint/lib/PerlIO/via/QuotedPrint.pm index 8135e176403b..d02ec682ae56 100644 --- a/cpan/PerlIO-via-QuotedPrint/lib/PerlIO/via/QuotedPrint.pm +++ b/cpan/PerlIO-via-QuotedPrint/lib/PerlIO/via/QuotedPrint.pm @@ -1,10 +1,19 @@ +# Copyright (C) 2002-2004, 2012 Elizabeth Mattijsen. All rights reserved. +# Copyright (C) 2015 Steve Hay. All rights reserved. + +# This module is free software; you can redistribute it and/or modify it under +# the same terms as Perl itself, i.e. under the terms of either the GNU General +# Public License or the Artistic License, as specified in the F file. + package PerlIO::via::QuotedPrint; -$VERSION= '0.08'; +use 5.008001; # be as strict as possible use strict; +our $VERSION = '0.09'; + # modules that we need use MIME::QuotedPrint (); # no need to pollute this namespace @@ -61,17 +70,13 @@ PerlIO::via::QuotedPrint - PerlIO layer for quoted-printable strings =head1 SYNOPSIS - use PerlIO::via::QuotedPrint; + use PerlIO::via::QuotedPrint; - open( my $in, '<:via(QuotedPrint)', 'file.qp' ) - or die "Can't open file.qp for reading: $!\n"; - - open( my $out, '>:via(QuotedPrint)', 'file.qp' ) - or die "Can't open file.qp for writing: $!\n"; - -=head1 VERSION + open(my $in, '<:via(QuotedPrint)', 'file.qp') or + die "Can't open file.qp for reading: $!\n"; -This documentation describes version 0.08. + open(my $out, '>:via(QuotedPrint)', 'file.qp') or + die "Can't open file.qp for writing: $!\n"; =head1 DESCRIPTION @@ -79,24 +84,93 @@ This module implements a PerlIO layer that works on files encoded in the quoted-printable format. It will decode from quoted-printable while reading from a handle, and it will encode as quoted-printable while writing to a handle. -=head1 REQUIRED MODULES +=head1 EXPORTS + +I. + +=head1 KNOWN BUGS + +I. + +=head1 FEEDBACK - MIME::QuotedPrint (any) +Patches, bug reports, suggestions or any other feedback is welcome. + +Patches can be sent as GitHub pull requests at +L. + +Bug reports and suggestions can be made on the CPAN Request Tracker at +L. + +Currently active requests on the CPAN Request Tracker can be viewed at +L. + +Please test this distribution. See CPAN Testers Reports at +L for details of how to get involved. + +Previous test results on CPAN Testers Reports can be viewed at +L. + +Please rate this distribution on CPAN Ratings at +L. =head1 SEE ALSO -L, L, L, -L, L, L. +L, +L. =head1 ACKNOWLEDGEMENTS -Based on example that was initially added to MIME::QuotedPrint.pm for the -5.8.0 distribution of Perl. +Based on an example in the standard library module MIME::QuotedPrint in Perl +(version 5.8.0). + +=head1 AVAILABILITY + +The latest version of this module is available from CPAN (see +L for details) at + +L or + +L or + +L. + +The latest source code is available from GitHub at +L. + +=head1 INSTALLATION + +See the F file. + +=head1 AUTHOR + +Elizabeth Mattijsen ELE. + +Steve Hay ELE is now maintaining +PerlIO::via::QuotedPrint as of version 0.08. =head1 COPYRIGHT -Copyright (c) 2002, 2003, 2004, 2012 Elizabeth Mattijsen. All rights reserved. -This library is free software; you can redistribute it and/or modify it under -the same terms as Perl itself. +Copyright (C) 2002-2004, 2012 Elizabeth Mattijsen. All rights reserved. + +Copyright (C) 2015, 2020 Steve Hay. All rights reserved. + +=head1 LICENCE + +This module is free software; you can redistribute it and/or modify it under +the same terms as Perl itself, i.e. under the terms of either the GNU General +Public License or the Artistic License, as specified in the F file. + +=head1 VERSION + +Version 0.09 + +=head1 DATE + +08 Dec 2020 + +=head1 HISTORY + +See the F file. =cut diff --git a/cpan/PerlIO-via-QuotedPrint/t/QuotedPrint.t b/cpan/PerlIO-via-QuotedPrint/t/QuotedPrint.t index 33366bd5657e..5270fb4691ba 100644 --- a/cpan/PerlIO-via-QuotedPrint/t/QuotedPrint.t +++ b/cpan/PerlIO-via-QuotedPrint/t/QuotedPrint.t @@ -1,4 +1,9 @@ -BEGIN { # Magic Perl CORE pragma +use 5.008001; + +use strict; +use warnings; + +BEGIN { # Magic Perl CORE pragma unless (find PerlIO::Layer 'perlio') { print "1..0 # Skip: PerlIO not used\n"; exit 0; @@ -8,8 +13,6 @@ BEGIN { # Magic Perl CORE pragma } } -use strict; -use warnings; use Test::More tests => 11; BEGIN { use_ok('PerlIO::via::QuotedPrint') } @@ -34,16 +37,16 @@ ok( "opening '$file' for writing" ); -ok( (print $out $decoded), 'print to file' ); -ok( close( $out ), 'closing encoding handle' ); +ok( (print $out $decoded), 'print to file' ); +ok( close( $out ), 'closing encoding handle' ); # Check encoding without layers { local $/ = undef; -ok( open( my $test,$file ), 'opening without layer' ); -is( $encoded,readline( $test ), 'check encoded content' ); -ok( close( $test ), 'close test handle' ); +ok( open( my $test, '<', $file ), 'opening without layer' ); +is( $encoded,readline( $test ), 'check encoded content' ); +ok( close( $test ), 'close test handle' ); } # Check decoding _with_ layers @@ -52,10 +55,10 @@ ok( open( my $in,'<:via(QuotedPrint)', $file ), "opening '$file' for reading" ); -is( $decoded,join( '',<$in> ), 'check decoding' ); -ok( close( $in ), 'close decoding handle' ); +is( $decoded,join( '',<$in> ), 'check decoding' ); +ok( close( $in ), 'close decoding handle' ); # Remove whatever we created now -ok( unlink( $file ), "remove test file '$file'" ); +ok( unlink( $file ), "remove test file '$file'" ); 1 while unlink $file; # multiversioned filesystems diff --git a/cpan/PerlIO-via-QuotedPrint/t/changes.t b/cpan/PerlIO-via-QuotedPrint/t/changes.t new file mode 100644 index 000000000000..bd743ad1e6e0 --- /dev/null +++ b/cpan/PerlIO-via-QuotedPrint/t/changes.t @@ -0,0 +1,48 @@ +#!perl +#=============================================================================== +# +# t/changes.t +# +# DESCRIPTION +# Test script to check CPAN::Changes conformance. +# +# COPYRIGHT +# Copyright (C) 2015 Steve Hay. All rights reserved. +# +# LICENCE +# This script is free software; you can redistribute it and/or modify it under +# the same terms as Perl itself, i.e. under the terms of either the GNU +# General Public License or the Artistic License, as specified in the LICENCE +# file. +# +#=============================================================================== + +use 5.008001; + +use strict; +use warnings; + +use Test::More; + +#=============================================================================== +# MAIN PROGRAM +#=============================================================================== + +MAIN: { + plan skip_all => 'Author testing only' unless $ENV{AUTHOR_TESTING}; + + my $ok = eval { + require Test::CPAN::Changes; + Test::CPAN::Changes->import(); + 1; + }; + + if (not $ok) { + plan skip_all => 'Test::CPAN::Changes required to test Changes'; + } + else { + changes_ok(); + } +} + +#=============================================================================== diff --git a/cpan/PerlIO-via-QuotedPrint/t/critic.t b/cpan/PerlIO-via-QuotedPrint/t/critic.t new file mode 100644 index 000000000000..882853a85e99 --- /dev/null +++ b/cpan/PerlIO-via-QuotedPrint/t/critic.t @@ -0,0 +1,48 @@ +#!perl +#=============================================================================== +# +# t/critic.t +# +# DESCRIPTION +# Test script to check Perl::Critic conformance. +# +# COPYRIGHT +# Copyright (C) 2015 Steve Hay. All rights reserved. +# +# LICENCE +# This script is free software; you can redistribute it and/or modify it under +# the same terms as Perl itself, i.e. under the terms of either the GNU +# General Public License or the Artistic License, as specified in the LICENCE +# file. +# +#=============================================================================== + +use 5.008001; + +use strict; +use warnings; + +use Test::More; + +#=============================================================================== +# MAIN PROGRAM +#=============================================================================== + +MAIN: { + plan skip_all => 'Author testing only' unless $ENV{AUTHOR_TESTING}; + + my $ok = eval { + require Test::Perl::Critic; + Test::Perl::Critic->import(-profile => ''); + 1; + }; + + if (not $ok) { + plan skip_all => 'Test::Perl::Critic required to test with Perl::Critic'; + } + else { + all_critic_ok('.'); + } +} + +#=============================================================================== diff --git a/cpan/PerlIO-via-QuotedPrint/t/pod.t b/cpan/PerlIO-via-QuotedPrint/t/pod.t new file mode 100644 index 000000000000..0e269bc087c4 --- /dev/null +++ b/cpan/PerlIO-via-QuotedPrint/t/pod.t @@ -0,0 +1,51 @@ +#!perl +#=============================================================================== +# +# t/pod.t +# +# DESCRIPTION +# Test script to check POD. +# +# COPYRIGHT +# Copyright (C) 2015 Steve Hay. All rights reserved. +# +# LICENCE +# This script is free software; you can redistribute it and/or modify it under +# the same terms as Perl itself, i.e. under the terms of either the GNU +# General Public License or the Artistic License, as specified in the LICENCE +# file. +# +#=============================================================================== + +use 5.008001; + +use strict; +use warnings; + +use Test::More; + +#=============================================================================== +# MAIN PROGRAM +#=============================================================================== + +MAIN: { + plan skip_all => 'Author testing only' unless $ENV{AUTHOR_TESTING}; + + my $ok = eval { + require Test::Pod; + Test::Pod->import(); + 1; + }; + + if (not $ok) { + plan skip_all => 'Test::Pod required to test POD'; + } + elsif ($Test::Pod::VERSION < 1.00) { + plan skip_all => 'Test::Pod 1.00 or higher required to test POD'; + } + else { + all_pod_files_ok(); + } +} + +#=============================================================================== diff --git a/cpan/PerlIO-via-QuotedPrint/t/pod_coverage.t b/cpan/PerlIO-via-QuotedPrint/t/pod_coverage.t new file mode 100644 index 000000000000..d733da90100c --- /dev/null +++ b/cpan/PerlIO-via-QuotedPrint/t/pod_coverage.t @@ -0,0 +1,54 @@ +#!perl +#=============================================================================== +# +# t/pod_coverage.t +# +# DESCRIPTION +# Test script to check POD coverage. +# +# COPYRIGHT +# Copyright (C) 2015 Steve Hay. All rights reserved. +# +# LICENCE +# This script is free software; you can redistribute it and/or modify it under +# the same terms as Perl itself, i.e. under the terms of either the GNU +# General Public License or the Artistic License, as specified in the LICENCE +# file. +# +#=============================================================================== + +use 5.008001; + +use strict; +use warnings; + +use Test::More; + +#=============================================================================== +# MAIN PROGRAM +#=============================================================================== + +MAIN: { + plan skip_all => 'Author testing only' unless $ENV{AUTHOR_TESTING}; + + my $ok = eval { + require Test::Pod::Coverage; + Test::Pod::Coverage->import(); + 1; + }; + + if (not $ok) { + plan skip_all => 'Test::Pod::Coverage required to test POD coverage'; + } + elsif ($Test::Pod::Coverage::VERSION < 0.08) { + plan skip_all => 'Test::Pod::Coverage 0.08 or higher required to test POD coverage'; + } + else { + plan tests => 1; + pod_coverage_ok('PerlIO::via::QuotedPrint', { + also_private => [qw(FILL PUSHED WRITE)] + }); + } +} + +#=============================================================================== diff --git a/cpan/Pod-Perldoc/.gitignore b/cpan/Pod-Perldoc/.gitignore new file mode 100644 index 000000000000..e54624d60d99 --- /dev/null +++ b/cpan/Pod-Perldoc/.gitignore @@ -0,0 +1 @@ +!/Makefile.PL diff --git a/cpan/Pod-Simple/lib/Pod/Simple.pm b/cpan/Pod-Simple/lib/Pod/Simple.pm index 504baff706f0..f2544d0ef10c 100644 --- a/cpan/Pod-Simple/lib/Pod/Simple.pm +++ b/cpan/Pod-Simple/lib/Pod/Simple.pm @@ -18,7 +18,7 @@ use vars qw( ); @ISA = ('Pod::Simple::BlackBox'); -$VERSION = '3.41'; +$VERSION = '3.42'; @Known_formatting_codes = qw(I B C L E F S X Z); %Known_formatting_codes = map(($_=>1), @Known_formatting_codes); diff --git a/cpan/Pod-Simple/lib/Pod/Simple/BlackBox.pm b/cpan/Pod-Simple/lib/Pod/Simple/BlackBox.pm index 17b8f6d7db1a..03dede7c34ca 100644 --- a/cpan/Pod-Simple/lib/Pod/Simple/BlackBox.pm +++ b/cpan/Pod-Simple/lib/Pod/Simple/BlackBox.pm @@ -22,7 +22,7 @@ use integer; # vroom! use strict; use Carp (); use vars qw($VERSION ); -$VERSION = '3.41'; +$VERSION = '3.42'; #use constant DEBUG => 7; sub my_qr ($$) { @@ -139,10 +139,8 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) # An attempt to match the pod portions of a line. This is not fool proof, # but is good enough to serve as part of the heuristic for guessing the pod # encoding if not specified. - my $format_codes = join "", '[', grep { / ^ [A-Za-z] $/x } - keys %{$self->{accept_codes}}; - $format_codes .= ']'; - my $pod_chars_re = qr/ ^ = [A-Za-z]+ | $format_codes < /x; + my $codes = join '', grep { / ^ [A-Za-z] $/x } sort keys %{$self->{accept_codes}}; + my $pod_chars_re = qr/ ^ = [A-Za-z]+ | [\Q$codes\E] < /x; my $line; foreach my $source_line (@_) { diff --git a/cpan/Pod-Simple/lib/Pod/Simple/Checker.pm b/cpan/Pod-Simple/lib/Pod/Simple/Checker.pm index 1f94afe8d020..65f4d54243f9 100644 --- a/cpan/Pod-Simple/lib/Pod/Simple/Checker.pm +++ b/cpan/Pod-Simple/lib/Pod/Simple/Checker.pm @@ -9,7 +9,7 @@ use Carp (); use Pod::Simple::Methody (); use Pod::Simple (); use vars qw( @ISA $VERSION ); -$VERSION = '3.41'; +$VERSION = '3.42'; @ISA = ('Pod::Simple::Methody'); BEGIN { *DEBUG = defined(&Pod::Simple::DEBUG) ? \&Pod::Simple::DEBUG diff --git a/cpan/Pod-Simple/lib/Pod/Simple/Debug.pm b/cpan/Pod-Simple/lib/Pod/Simple/Debug.pm index 1e089ccf1bdc..6b9aa327c01d 100644 --- a/cpan/Pod-Simple/lib/Pod/Simple/Debug.pm +++ b/cpan/Pod-Simple/lib/Pod/Simple/Debug.pm @@ -2,7 +2,7 @@ require 5; package Pod::Simple::Debug; use strict; use vars qw($VERSION ); -$VERSION = '3.41'; +$VERSION = '3.42'; sub import { my($value,$variable); diff --git a/cpan/Pod-Simple/lib/Pod/Simple/DumpAsText.pm b/cpan/Pod-Simple/lib/Pod/Simple/DumpAsText.pm index dad0b69cb288..a22603043bdd 100644 --- a/cpan/Pod-Simple/lib/Pod/Simple/DumpAsText.pm +++ b/cpan/Pod-Simple/lib/Pod/Simple/DumpAsText.pm @@ -1,7 +1,7 @@ require 5; package Pod::Simple::DumpAsText; -$VERSION = '3.41'; +$VERSION = '3.42'; use Pod::Simple (); BEGIN {@ISA = ('Pod::Simple')} diff --git a/cpan/Pod-Simple/lib/Pod/Simple/DumpAsXML.pm b/cpan/Pod-Simple/lib/Pod/Simple/DumpAsXML.pm index 4531f9ce7878..024e4b7b8195 100644 --- a/cpan/Pod-Simple/lib/Pod/Simple/DumpAsXML.pm +++ b/cpan/Pod-Simple/lib/Pod/Simple/DumpAsXML.pm @@ -1,7 +1,7 @@ require 5; package Pod::Simple::DumpAsXML; -$VERSION = '3.41'; +$VERSION = '3.42'; use Pod::Simple (); BEGIN {@ISA = ('Pod::Simple')} diff --git a/cpan/Pod-Simple/lib/Pod/Simple/HTML.pm b/cpan/Pod-Simple/lib/Pod/Simple/HTML.pm index 8ad7572c56c4..f930a512172c 100644 --- a/cpan/Pod-Simple/lib/Pod/Simple/HTML.pm +++ b/cpan/Pod-Simple/lib/Pod/Simple/HTML.pm @@ -9,7 +9,7 @@ use vars qw( $Doctype_decl $Content_decl ); @ISA = ('Pod::Simple::PullParser'); -$VERSION = '3.41'; +$VERSION = '3.42'; BEGIN { if(defined &DEBUG) { } # no-op elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG } diff --git a/cpan/Pod-Simple/lib/Pod/Simple/HTMLBatch.pm b/cpan/Pod-Simple/lib/Pod/Simple/HTMLBatch.pm index 144387ebc016..6a06173f471c 100644 --- a/cpan/Pod-Simple/lib/Pod/Simple/HTMLBatch.pm +++ b/cpan/Pod-Simple/lib/Pod/Simple/HTMLBatch.pm @@ -5,7 +5,7 @@ use strict; use vars qw( $VERSION $HTML_RENDER_CLASS $HTML_EXTENSION $CSS $JAVASCRIPT $SLEEPY $SEARCH_CLASS @ISA ); -$VERSION = '3.41'; +$VERSION = '3.42'; @ISA = (); # Yup, we're NOT a subclass of Pod::Simple::HTML! # TODO: nocontents stylesheets. Strike some of the color variations? diff --git a/cpan/Pod-Simple/lib/Pod/Simple/LinkSection.pm b/cpan/Pod-Simple/lib/Pod/Simple/LinkSection.pm index ced4c3f4d26c..a6898caec438 100644 --- a/cpan/Pod-Simple/lib/Pod/Simple/LinkSection.pm +++ b/cpan/Pod-Simple/lib/Pod/Simple/LinkSection.pm @@ -6,7 +6,7 @@ package Pod::Simple::LinkSection; use strict; use Pod::Simple::BlackBox; use vars qw($VERSION ); -$VERSION = '3.41'; +$VERSION = '3.42'; use overload( # So it'll stringify nice '""' => \&Pod::Simple::BlackBox::stringify_lol, diff --git a/cpan/Pod-Simple/lib/Pod/Simple/Methody.pm b/cpan/Pod-Simple/lib/Pod/Simple/Methody.pm index d8fd3f2626e8..45e26cf46370 100644 --- a/cpan/Pod-Simple/lib/Pod/Simple/Methody.pm +++ b/cpan/Pod-Simple/lib/Pod/Simple/Methody.pm @@ -4,7 +4,7 @@ package Pod::Simple::Methody; use strict; use Pod::Simple (); use vars qw(@ISA $VERSION); -$VERSION = '3.41'; +$VERSION = '3.42'; @ISA = ('Pod::Simple'); # Yes, we could use named variables, but I want this to be impose diff --git a/cpan/Pod-Simple/lib/Pod/Simple/Progress.pm b/cpan/Pod-Simple/lib/Pod/Simple/Progress.pm index 5840c8cff44e..77de9ae86f43 100644 --- a/cpan/Pod-Simple/lib/Pod/Simple/Progress.pm +++ b/cpan/Pod-Simple/lib/Pod/Simple/Progress.pm @@ -1,7 +1,7 @@ require 5; package Pod::Simple::Progress; -$VERSION = '3.41'; +$VERSION = '3.42'; use strict; # Objects of this class are used for noting progress of an diff --git a/cpan/Pod-Simple/lib/Pod/Simple/PullParser.pm b/cpan/Pod-Simple/lib/Pod/Simple/PullParser.pm index 133dd2ff8471..57aad9ac085b 100644 --- a/cpan/Pod-Simple/lib/Pod/Simple/PullParser.pm +++ b/cpan/Pod-Simple/lib/Pod/Simple/PullParser.pm @@ -1,6 +1,6 @@ require 5; package Pod::Simple::PullParser; -$VERSION = '3.41'; +$VERSION = '3.42'; use Pod::Simple (); BEGIN {@ISA = ('Pod::Simple')} diff --git a/cpan/Pod-Simple/lib/Pod/Simple/PullParserEndToken.pm b/cpan/Pod-Simple/lib/Pod/Simple/PullParserEndToken.pm index 8a138f548300..dbff3df249d1 100644 --- a/cpan/Pod-Simple/lib/Pod/Simple/PullParserEndToken.pm +++ b/cpan/Pod-Simple/lib/Pod/Simple/PullParserEndToken.pm @@ -5,7 +5,7 @@ use Pod::Simple::PullParserToken (); use strict; use vars qw(@ISA $VERSION); @ISA = ('Pod::Simple::PullParserToken'); -$VERSION = '3.41'; +$VERSION = '3.42'; sub new { # Class->new(tagname); my $class = shift; diff --git a/cpan/Pod-Simple/lib/Pod/Simple/PullParserStartToken.pm b/cpan/Pod-Simple/lib/Pod/Simple/PullParserStartToken.pm index c3b56d529d10..1ab33cc6e0ab 100644 --- a/cpan/Pod-Simple/lib/Pod/Simple/PullParserStartToken.pm +++ b/cpan/Pod-Simple/lib/Pod/Simple/PullParserStartToken.pm @@ -5,7 +5,7 @@ use Pod::Simple::PullParserToken (); use strict; use vars qw(@ISA $VERSION); @ISA = ('Pod::Simple::PullParserToken'); -$VERSION = '3.41'; +$VERSION = '3.42'; sub new { # Class->new(tagname, optional_attrhash); my $class = shift; diff --git a/cpan/Pod-Simple/lib/Pod/Simple/PullParserTextToken.pm b/cpan/Pod-Simple/lib/Pod/Simple/PullParserTextToken.pm index dd60a951e972..cdce959db4ba 100644 --- a/cpan/Pod-Simple/lib/Pod/Simple/PullParserTextToken.pm +++ b/cpan/Pod-Simple/lib/Pod/Simple/PullParserTextToken.pm @@ -5,7 +5,7 @@ use Pod::Simple::PullParserToken (); use strict; use vars qw(@ISA $VERSION); @ISA = ('Pod::Simple::PullParserToken'); -$VERSION = '3.41'; +$VERSION = '3.42'; sub new { # Class->new(text); my $class = shift; diff --git a/cpan/Pod-Simple/lib/Pod/Simple/PullParserToken.pm b/cpan/Pod-Simple/lib/Pod/Simple/PullParserToken.pm index f4b00d2aff90..63a2dabe6f33 100644 --- a/cpan/Pod-Simple/lib/Pod/Simple/PullParserToken.pm +++ b/cpan/Pod-Simple/lib/Pod/Simple/PullParserToken.pm @@ -3,7 +3,7 @@ require 5; package Pod::Simple::PullParserToken; # Base class for tokens gotten from Pod::Simple::PullParser's $parser->get_token @ISA = (); -$VERSION = '3.41'; +$VERSION = '3.42'; use strict; sub new { # Class->new('type', stuff...); ## Overridden in derived classes anyway diff --git a/cpan/Pod-Simple/lib/Pod/Simple/RTF.pm b/cpan/Pod-Simple/lib/Pod/Simple/RTF.pm index 9f9c2aca578f..10e05c5d0a4f 100644 --- a/cpan/Pod-Simple/lib/Pod/Simple/RTF.pm +++ b/cpan/Pod-Simple/lib/Pod/Simple/RTF.pm @@ -8,7 +8,7 @@ package Pod::Simple::RTF; use strict; use vars qw($VERSION @ISA %Escape $WRAP %Tagmap); -$VERSION = '3.41'; +$VERSION = '3.42'; use Pod::Simple::PullParser (); BEGIN {@ISA = ('Pod::Simple::PullParser')} diff --git a/cpan/Pod-Simple/lib/Pod/Simple/Search.pm b/cpan/Pod-Simple/lib/Pod/Simple/Search.pm index 0fbad86de6b1..ad610654c998 100644 --- a/cpan/Pod-Simple/lib/Pod/Simple/Search.pm +++ b/cpan/Pod-Simple/lib/Pod/Simple/Search.pm @@ -3,7 +3,7 @@ package Pod::Simple::Search; use strict; use vars qw($VERSION $MAX_VERSION_WITHIN $SLEEPY); -$VERSION = '3.41'; ## Current version of this package +$VERSION = '3.42'; ## Current version of this package BEGIN { *DEBUG = sub () {0} unless defined &DEBUG; } # set DEBUG level use Carp (); diff --git a/cpan/Pod-Simple/lib/Pod/Simple/SimpleTree.pm b/cpan/Pod-Simple/lib/Pod/Simple/SimpleTree.pm index 63c82cafc1c0..38a2704f8766 100644 --- a/cpan/Pod-Simple/lib/Pod/Simple/SimpleTree.pm +++ b/cpan/Pod-Simple/lib/Pod/Simple/SimpleTree.pm @@ -5,7 +5,7 @@ use strict; use Carp (); use Pod::Simple (); use vars qw( $ATTR_PAD @ISA $VERSION $SORT_ATTRS); -$VERSION = '3.41'; +$VERSION = '3.42'; BEGIN { @ISA = ('Pod::Simple'); *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG; diff --git a/cpan/Pod-Simple/lib/Pod/Simple/Text.pm b/cpan/Pod-Simple/lib/Pod/Simple/Text.pm index 7feb4c504b81..2f0254ec37d3 100644 --- a/cpan/Pod-Simple/lib/Pod/Simple/Text.pm +++ b/cpan/Pod-Simple/lib/Pod/Simple/Text.pm @@ -6,7 +6,7 @@ use Carp (); use Pod::Simple::Methody (); use Pod::Simple (); use vars qw( @ISA $VERSION $FREAKYMODE); -$VERSION = '3.41'; +$VERSION = '3.42'; @ISA = ('Pod::Simple::Methody'); BEGIN { *DEBUG = defined(&Pod::Simple::DEBUG) ? \&Pod::Simple::DEBUG diff --git a/cpan/Pod-Simple/lib/Pod/Simple/TextContent.pm b/cpan/Pod-Simple/lib/Pod/Simple/TextContent.pm index affb917edc17..ccbf4242214f 100644 --- a/cpan/Pod-Simple/lib/Pod/Simple/TextContent.pm +++ b/cpan/Pod-Simple/lib/Pod/Simple/TextContent.pm @@ -6,7 +6,7 @@ use strict; use Carp (); use Pod::Simple (); use vars qw( @ISA $VERSION ); -$VERSION = '3.41'; +$VERSION = '3.42'; @ISA = ('Pod::Simple'); sub new { diff --git a/cpan/Pod-Simple/lib/Pod/Simple/TiedOutFH.pm b/cpan/Pod-Simple/lib/Pod/Simple/TiedOutFH.pm index 93d9804c6ed2..cbf58b370694 100644 --- a/cpan/Pod-Simple/lib/Pod/Simple/TiedOutFH.pm +++ b/cpan/Pod-Simple/lib/Pod/Simple/TiedOutFH.pm @@ -4,7 +4,7 @@ package Pod::Simple::TiedOutFH; use Symbol ('gensym'); use Carp (); use vars qw($VERSION ); -$VERSION = '3.41'; +$VERSION = '3.42'; #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/cpan/Pod-Simple/lib/Pod/Simple/Transcode.pm b/cpan/Pod-Simple/lib/Pod/Simple/Transcode.pm index 8cb71d1aebb5..bdb7181af646 100644 --- a/cpan/Pod-Simple/lib/Pod/Simple/Transcode.pm +++ b/cpan/Pod-Simple/lib/Pod/Simple/Transcode.pm @@ -3,7 +3,7 @@ require 5; package Pod::Simple::Transcode; use strict; use vars qw($VERSION @ISA); -$VERSION = '3.41'; +$VERSION = '3.42'; BEGIN { if(defined &DEBUG) {;} # Okay diff --git a/cpan/Pod-Simple/lib/Pod/Simple/TranscodeDumb.pm b/cpan/Pod-Simple/lib/Pod/Simple/TranscodeDumb.pm index 3f9d09d894de..96e6a544102e 100644 --- a/cpan/Pod-Simple/lib/Pod/Simple/TranscodeDumb.pm +++ b/cpan/Pod-Simple/lib/Pod/Simple/TranscodeDumb.pm @@ -5,7 +5,7 @@ require 5; package Pod::Simple::TranscodeDumb; use strict; use vars qw($VERSION %Supported); -$VERSION = '3.41'; +$VERSION = '3.42'; # This module basically pretends it knows how to transcode, except # only for null-transcodings! We use this when Encode isn't # available. diff --git a/cpan/Pod-Simple/lib/Pod/Simple/TranscodeSmart.pm b/cpan/Pod-Simple/lib/Pod/Simple/TranscodeSmart.pm index 4d1004d8daa1..3f3224f917bf 100644 --- a/cpan/Pod-Simple/lib/Pod/Simple/TranscodeSmart.pm +++ b/cpan/Pod-Simple/lib/Pod/Simple/TranscodeSmart.pm @@ -9,7 +9,7 @@ use strict; use Pod::Simple; require Encode; use vars qw($VERSION ); -$VERSION = '3.41'; +$VERSION = '3.42'; sub is_dumb {0} sub is_smart {1} diff --git a/cpan/Pod-Simple/lib/Pod/Simple/XHTML.pm b/cpan/Pod-Simple/lib/Pod/Simple/XHTML.pm index d4f59dd1ed5d..9049ce755ff2 100644 --- a/cpan/Pod-Simple/lib/Pod/Simple/XHTML.pm +++ b/cpan/Pod-Simple/lib/Pod/Simple/XHTML.pm @@ -45,7 +45,7 @@ declare the output character set as UTF-8 before parsing, like so: package Pod::Simple::XHTML; use strict; use vars qw( $VERSION @ISA $HAS_HTML_ENTITIES ); -$VERSION = '3.41'; +$VERSION = '3.42'; use Pod::Simple::Methody (); @ISA = ('Pod::Simple::Methody'); diff --git a/cpan/Pod-Simple/lib/Pod/Simple/XMLOutStream.pm b/cpan/Pod-Simple/lib/Pod/Simple/XMLOutStream.pm index a85520991ed7..a891a3341f5b 100644 --- a/cpan/Pod-Simple/lib/Pod/Simple/XMLOutStream.pm +++ b/cpan/Pod-Simple/lib/Pod/Simple/XMLOutStream.pm @@ -5,7 +5,7 @@ use strict; use Carp (); use Pod::Simple (); use vars qw( $ATTR_PAD @ISA $VERSION $SORT_ATTRS); -$VERSION = '3.41'; +$VERSION = '3.42'; BEGIN { @ISA = ('Pod::Simple'); *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG; diff --git a/cpan/Scalar-List-Utils/.gitignore b/cpan/Scalar-List-Utils/.gitignore new file mode 100644 index 000000000000..e54624d60d99 --- /dev/null +++ b/cpan/Scalar-List-Utils/.gitignore @@ -0,0 +1 @@ +!/Makefile.PL diff --git a/cpan/Socket/.gitignore b/cpan/Socket/.gitignore index 2a06e93b553d..6531b6b8ed84 100644 --- a/cpan/Socket/.gitignore +++ b/cpan/Socket/.gitignore @@ -1 +1,2 @@ *.inc +!/Makefile.PL diff --git a/cpan/Socket/Makefile.PL b/cpan/Socket/Makefile.PL index b69f50c9c789..3250737ac94d 100644 --- a/cpan/Socket/Makefile.PL +++ b/cpan/Socket/Makefile.PL @@ -170,8 +170,7 @@ my @names = ( AF_WAN AF_X25 AI_ADDRCONFIG AI_ALL AI_CANONIDN AI_CANONNAME AI_IDN - AI_IDN_ALLOW_UNASSIGNED AI_IDN_USE_STD3_ASCII_RULES AI_NUMERICHOST - AI_NUMERICSERV AI_PASSIVE AI_V4MAPPED + AI_NUMERICHOST AI_NUMERICSERV AI_PASSIVE AI_V4MAPPED EAI_ADDRFAMILY EAI_AGAIN EAI_BADFLAGS EAI_BADHINTS EAI_FAIL EAI_FAMILY EAI_NODATA EAI_NONAME EAI_PROTOCOL EAI_SERVICE EAI_SOCKTYPE EAI_SYSTEM @@ -198,8 +197,7 @@ my @names = ( MSG_MCAST MSG_NOSIGNAL MSG_RST MSG_SYN MSG_TRUNC MSG_URG MSG_WAITALL MSG_WIRE - NI_DGRAM NI_IDN NI_IDN_ALLOW_UNASSIGNED NI_IDN_USE_STD3_ASCII_RULES - NI_NAMEREQD NI_NOFQDN NI_NUMERICHOST NI_NUMERICSERV + NI_DGRAM NI_IDN NI_NAMEREQD NI_NOFQDN NI_NUMERICHOST NI_NUMERICSERV PF_802 PF_AAL PF_APPLETALK PF_CCITT PF_CHAOS PF_CTF PF_DATAKIT PF_DECnet PF_DLI PF_ECMA PF_GOSIP PF_HYLINK PF_IMPLINK PF_INET PF_INET6 diff --git a/cpan/Socket/Socket.pm b/cpan/Socket/Socket.pm index f156699d0516..fe47ef67ec0a 100644 --- a/cpan/Socket/Socket.pm +++ b/cpan/Socket/Socket.pm @@ -3,7 +3,7 @@ package Socket; use strict; { use v5.6.1; } -our $VERSION = '2.030'; +our $VERSION = '2.031'; =head1 NAME @@ -110,7 +110,7 @@ level. =head2 IP_PMTUDISC_WANT, IP_PMTUDISC_DONT, ... -Socket option value contants for C socket option. +Socket option value constants for C socket option. =head2 IPTOS_LOWDELAY, IPTOS_THROUGHPUT, IPTOS_RELIABILITY, ... @@ -837,6 +837,14 @@ BEGIN { *LF = \LF(); *CRLF = \CRLF(); +# The four deprecated addrinfo constants +foreach my $name (qw( AI_IDN_ALLOW_UNASSIGNED AI_IDN_USE_STD3_ASCII_RULES NI_IDN_ALLOW_UNASSIGNED NI_IDN_USE_STD3_ASCII_RULES )) { + no strict 'refs'; + *$name = sub { + croak "The addrinfo constant $name is deprecated"; + }; +} + sub sockaddr_in { if (@_ == 6 && !wantarray) { # perl5.001m compat; use this && die my($af, $port, @quad) = @_; @@ -916,13 +924,9 @@ if( defined &getaddrinfo ) { # Constants we don't support. Export them, but croak if anyone tries to # use them - AI_IDN => 64, - AI_CANONIDN => 128, - AI_IDN_ALLOW_UNASSIGNED => 256, - AI_IDN_USE_STD3_ASCII_RULES => 512, - NI_IDN => 32, - NI_IDN_ALLOW_UNASSIGNED => 64, - NI_IDN_USE_STD3_ASCII_RULES => 128, + AI_IDN => 64, + AI_CANONIDN => 128, + NI_IDN => 32, # Error constants we'll never return, so it doesn't matter what value # these have, nor that we don't provide strings for them @@ -992,7 +996,7 @@ sub fake_getaddrinfo # to talk AF_INET. If not we'd have to return no addresses at all. :) $flags &= ~(AI_V4MAPPED()|AI_ALL()|AI_ADDRCONFIG()); - $flags & (AI_IDN()|AI_CANONIDN()|AI_IDN_ALLOW_UNASSIGNED()|AI_IDN_USE_STD3_ASCII_RULES()) and + $flags & (AI_IDN()|AI_CANONIDN()) and croak "Socket::getaddrinfo() does not support IDN"; $flags == 0 or return fake_makeerr( EAI_BADFLAGS() ); @@ -1090,7 +1094,7 @@ sub fake_getnameinfo my $flag_namereqd = $flags & NI_NAMEREQD(); $flags &= ~NI_NAMEREQD(); my $flag_dgram = $flags & NI_DGRAM() ; $flags &= ~NI_DGRAM(); - $flags & (NI_IDN()|NI_IDN_ALLOW_UNASSIGNED()|NI_IDN_USE_STD3_ASCII_RULES()) and + $flags & NI_IDN() and croak "Socket::getnameinfo() does not support IDN"; $flags == 0 or return fake_makeerr( EAI_BADFLAGS() ); diff --git a/cpan/Socket/Socket.xs b/cpan/Socket/Socket.xs index e46c93e17192..31ffdf0670b9 100644 --- a/cpan/Socket/Socket.xs +++ b/cpan/Socket/Socket.xs @@ -764,20 +764,33 @@ inet_aton(host) char * host CODE: { +#ifdef HAS_GETADDRINFO + struct addrinfo *res; + struct addrinfo hints = {0}; + hints.ai_family = AF_INET; + if (!getaddrinfo(host, NULL, &hints, &res)) { + ST(0) = sv_2mortal(newSVpvn( + (char *)&(((struct sockaddr_in *)res->ai_addr)->sin_addr.s_addr), + 4)); + freeaddrinfo(res); + XSRETURN(1); + } +#else struct in_addr ip_address; struct hostent * phe; - if ((*host != '\0') && inet_aton(host, &ip_address)) { ST(0) = sv_2mortal(newSVpvn((char *)&ip_address, sizeof(ip_address))); XSRETURN(1); } #ifdef HAS_GETHOSTBYNAME + /* gethostbyname is not thread-safe */ phe = gethostbyname(host); if (phe && phe->h_addrtype == AF_INET && phe->h_length == 4) { ST(0) = sv_2mortal(newSVpvn((char *)phe->h_addr, phe->h_length)); XSRETURN(1); } -#endif +#endif /* HAS_GETHOSTBYNAME */ +#endif /* HAS_GETADDRINFO */ XSRETURN_UNDEF; } @@ -794,10 +807,10 @@ inet_ntoa(ip_address_sv) ip_address = SvPVbyte(ip_address_sv, addrlen); if (addrlen == sizeof(addr) || addrlen == 4) addr.s_addr = - (ip_address[0] & 0xFF) << 24 | - (ip_address[1] & 0xFF) << 16 | - (ip_address[2] & 0xFF) << 8 | - (ip_address[3] & 0xFF); + (unsigned long)(ip_address[0] & 0xFF) << 24 | + (unsigned long)(ip_address[1] & 0xFF) << 16 | + (unsigned long)(ip_address[2] & 0xFF) << 8 | + (unsigned long)(ip_address[3] & 0xFF); else croak("Bad arg length for %s, length is %" UVuf ", should be %" UVuf, @@ -974,8 +987,12 @@ pack_sockaddr_in(port_sv, ip_address_sv) STRLEN addrlen; unsigned short port = 0; char * ip_address; - if (SvOK(port_sv)) + if (SvOK(port_sv)) { port = SvUV(port_sv); + if (SvUV(port_sv) > 0xFFFF) + warn("Port number above 0xFFFF, will be truncated to %d for %s", + port, "Socket::pack_sockaddr_in"); + } if (!SvOK(ip_address_sv)) croak("Undefined address for %s", "Socket::pack_sockaddr_in"); if (DO_UTF8(ip_address_sv) && !sv_utf8_downgrade(ip_address_sv, 1)) @@ -1049,8 +1066,12 @@ pack_sockaddr_in6(port_sv, sin6_addr, scope_id=0, flowinfo=0) struct sockaddr_in6 sin6; char * addrbytes; STRLEN addrlen; - if (SvOK(port_sv)) + if (SvOK(port_sv)) { port = SvUV(port_sv); + if (SvUV(port_sv) > 0xFFFF) + warn("Port number above 0xFFFF, will be truncated to %d for %s", + port, "Socket::pack_sockaddr_in6"); + } if (!SvOK(sin6_addr)) croak("Undefined address for %s", "Socket::pack_sockaddr_in6"); if (DO_UTF8(sin6_addr) && !sv_utf8_downgrade(sin6_addr, 1)) diff --git a/cpan/Socket/t/sockaddr.t b/cpan/Socket/t/sockaddr.t index 395d96af7fbd..b95d2c296150 100644 --- a/cpan/Socket/t/sockaddr.t +++ b/cpan/Socket/t/sockaddr.t @@ -12,7 +12,7 @@ use Socket qw( sockaddr_family sockaddr_un ); -use Test::More tests => 46; +use Test::More tests => 50; # inet_aton, inet_ntoa { @@ -83,8 +83,8 @@ SKIP: { is(sockaddr_family(scalar sockaddr_in(200,v10.30.50.70)), AF_INET, 'sockaddr_in in scalar context packs'); - my $warnings = 0; - local $SIG{__WARN__} = sub { $warnings++ }; + my $warnings = ""; + local $SIG{__WARN__} = sub { $warnings .= $_[0]; }; ok( !eval { pack_sockaddr_in 0, undef; 1 }, 'pack_sockaddr_in undef addr is fatal' ); ok( !eval { unpack_sockaddr_in undef; 1 }, @@ -93,14 +93,19 @@ SKIP: { ok( eval { pack_sockaddr_in undef, "\0\0\0\0"; 1 }, 'pack_sockaddr_in undef port is allowed' ); - is( $warnings, 0, 'undefined values produced no warnings' ); + is( $warnings, "", 'undefined values produced no warnings' ); + + ok( eval { pack_sockaddr_in 98765, "\0\0\0\0"; 1 }, + 'pack_sockaddr_in oversized port is allowed' ); + like( $warnings, qr/^Port number above 0xFFFF, will be truncated to 33229 for Socket::pack_sockaddr_in at /, + 'pack_sockaddr_in oversized port warning' ); } # pack_sockaddr_in6, unpack_sockaddr_in6 # sockaddr_in6 SKIP: { - skip "No AF_INET6", 13 unless my $AF_INET6 = eval { Socket::AF_INET6() }; - skip "Cannot pack_sockaddr_in6()", 13 unless my $sin6 = eval { Socket::pack_sockaddr_in6(0x1234, "0123456789abcdef", 0, 89) }; + skip "No AF_INET6", 15 unless my $AF_INET6 = eval { Socket::AF_INET6() }; + skip "Cannot pack_sockaddr_in6()", 15 unless my $sin6 = eval { Socket::pack_sockaddr_in6(0x1234, "0123456789abcdef", 0, 89) }; ok(defined $sin6, 'pack_sockaddr_in6 defined'); @@ -119,8 +124,8 @@ SKIP: { is(sockaddr_family(scalar Socket::sockaddr_in6(0x1357, "02468ace13579bdf")), $AF_INET6, 'sockaddr_in6 in scalar context packs' ); - my $warnings = 0; - local $SIG{__WARN__} = sub { $warnings++ }; + my $warnings = ""; + local $SIG{__WARN__} = sub { $warnings .= $_[0]; }; ok( !eval { Socket::pack_sockaddr_in6( 0, undef ); 1 }, 'pack_sockaddr_in6 undef addr is fatal' ); ok( !eval { Socket::unpack_sockaddr_in6( undef ); 1 }, @@ -129,7 +134,12 @@ SKIP: { ok( eval { Socket::pack_sockaddr_in6( undef, "\0"x16 ); 1 }, 'pack_sockaddr_in6 undef port is allowed' ); - is( $warnings, 0, 'undefined values produced no warnings' ); + is( $warnings, "", 'undefined values produced no warnings' ); + + ok( eval { Socket::pack_sockaddr_in6( 98765, "\0"x16 ); 1 }, + 'pack_sockaddr_in6 oversized port is allowed' ); + like( $warnings, qr/^Port number above 0xFFFF, will be truncated to 33229 for Socket::pack_sockaddr_in6 at /, + 'pack_sockaddr_in6 oversized port warning' ); } # sockaddr_un on abstract paths diff --git a/cpan/Socket/t/socketpair.t b/cpan/Socket/t/socketpair.t index 29c5f74ccebd..a803302db93f 100644 --- a/cpan/Socket/t/socketpair.t +++ b/cpan/Socket/t/socketpair.t @@ -68,8 +68,9 @@ if( !$Config{d_alarm} ) { } elsif( !$can_fork ) { plan skip_all => "fork() not implemented on this platform"; } else { + my ($lefth, $righth); # This should fail but not die if there is real socketpair - eval {socketpair LEFT, RIGHT, -1, -1, -1}; + eval {socketpair $lefth, $righth, -1, -1, -1}; if ($@ =~ /^Unsupported socket function "socketpair" called/ || $! =~ /^The operation requested is not supported./) { # Stratus VOS plan skip_all => 'No socketpair (real or emulated)'; @@ -86,90 +87,95 @@ if( !$Config{d_alarm} ) { # But we'll install an alarm handler in case any of the races below fail. $SIG{ALRM} = sub {die "Unexpected alarm during testing"}; -ok (socketpair (LEFT, RIGHT, AF_UNIX, SOCK_STREAM, PF_UNSPEC), - "socketpair (LEFT, RIGHT, AF_UNIX, SOCK_STREAM, PF_UNSPEC)") - or print STDERR "# \$\! = $!\n"; - -if ($has_perlio) { - binmode(LEFT, ":bytes"); - binmode(RIGHT, ":bytes"); -} - my @left = ("hello ", "world\n"); my @right = ("perl ", "rules!"); # Not like I'm trying to bias any survey here. -foreach (@left) { - # is (syswrite (LEFT, $_), length $_, "write " . _qq ($_) . " to left"); - is (syswrite (LEFT, $_), length $_, "syswrite to left"); -} -foreach (@right) { - # is (syswrite (RIGHT, $_), length $_, "write " . _qq ($_) . " to right"); - is (syswrite (RIGHT, $_), length $_, "syswrite to right"); -} - -# stream socket, so our writes will become joined: -my ($buffer, $expect); -$expect = join '', @right; -undef $buffer; -is (read (LEFT, $buffer, length $expect), length $expect, "read on left"); -is ($buffer, $expect, "content what we expected?"); -$expect = join '', @left; -undef $buffer; -is (read (RIGHT, $buffer, length $expect), length $expect, "read on right"); -is ($buffer, $expect, "content what we expected?"); - -ok (shutdown(LEFT, SHUT_WR), "shutdown left for writing"); -# This will hang forever if eof is buggy, and alarm doesn't interrupt system -# Calls. Hence the child process minder. -SKIP: { - skip "SCO Unixware / OSR have a bug with shutdown",2 if $^O =~ /^(?:svr|sco)/; - local $SIG{ALRM} = sub { warn "EOF on right took over 3 seconds" }; - local $TODO = "Known problems with unix sockets on $^O" - if $^O eq 'hpux' || $^O eq 'super-ux'; - alarm 3; - $! = 0; - ok (eof RIGHT, "right is at EOF"); - local $TODO = "Known problems with unix sockets on $^O" - if $^O eq 'unicos' || $^O eq 'unicosmk'; - is ($!, '', 'and $! should report no error'); - alarm 60; -} +my @gripping = (chr 255, chr 127); -my $err = $!; -$SIG{PIPE} = 'IGNORE'; -{ - local $SIG{ALRM} = - sub { warn "syswrite to left didn't fail within 3 seconds" }; - alarm 3; - # Split the system call from the is() - is() does IO so - # (say) a flush may do a seek which on a pipe may disturb errno - my $ans = syswrite (LEFT, "void"); - $err = $!; - is ($ans, undef, "syswrite to shutdown left should fail"); - alarm 60; -} { - # This may need skipping on some OSes - restoring value saved above - # should help - $! = $err; - ok (($!{EPIPE} or $!{ESHUTDOWN}), '$! should be EPIPE or ESHUTDOWN') - or printf STDERR "# \$\! = %d (%s)\n", $err, $err; -} + my ($lefth, $righth); -my @gripping = (chr 255, chr 127); -foreach (@gripping) { - is (syswrite (RIGHT, $_), length $_, "syswrite to right"); -} + ok (socketpair ($lefth, $righth, AF_UNIX, SOCK_STREAM, PF_UNSPEC), + "socketpair (\$lefth, \$righth, AF_UNIX, SOCK_STREAM, PF_UNSPEC)") + or print STDERR "# \$\! = $!\n"; + + if ($has_perlio) { + binmode($lefth, ":bytes"); + binmode($righth, ":bytes"); + } + + foreach (@left) { + # is (syswrite ($lefth, $_), length $_, "write " . _qq ($_) . " to left"); + is (syswrite ($lefth, $_), length $_, "syswrite to left"); + } + foreach (@right) { + # is (syswrite ($righth, $_), length $_, "write " . _qq ($_) . " to right"); + is (syswrite ($righth, $_), length $_, "syswrite to right"); + } + + # stream socket, so our writes will become joined: + my ($buffer, $expect); + $expect = join '', @right; + undef $buffer; + is (read ($lefth, $buffer, length $expect), length $expect, "read on left"); + is ($buffer, $expect, "content what we expected?"); + $expect = join '', @left; + undef $buffer; + is (read ($righth, $buffer, length $expect), length $expect, "read on right"); + is ($buffer, $expect, "content what we expected?"); + + ok (shutdown($lefth, SHUT_WR), "shutdown left for writing"); + # This will hang forever if eof is buggy, and alarm doesn't interrupt system + # Calls. Hence the child process minder. + SKIP: { + skip "SCO Unixware / OSR have a bug with shutdown",2 if $^O =~ /^(?:svr|sco)/; + local $SIG{ALRM} = sub { warn "EOF on right took over 3 seconds" }; + local $TODO = "Known problems with unix sockets on $^O" + if $^O eq 'hpux' || $^O eq 'super-ux'; + alarm 3; + $! = 0; + ok (eof $righth, "right is at EOF"); + local $TODO = "Known problems with unix sockets on $^O" + if $^O eq 'unicos' || $^O eq 'unicosmk'; + is ($!, '', 'and $! should report no error'); + alarm 60; + } + + my $err = $!; + $SIG{PIPE} = 'IGNORE'; + { + local $SIG{ALRM} = + sub { warn "syswrite to left didn't fail within 3 seconds" }; + alarm 3; + # Split the system call from the is() - is() does IO so + # (say) a flush may do a seek which on a pipe may disturb errno + my $ans = syswrite ($lefth, "void"); + $err = $!; + is ($ans, undef, "syswrite to shutdown left should fail"); + alarm 60; + } + { + # This may need skipping on some OSes - restoring value saved above + # should help + $! = $err; + ok (($!{EPIPE} or $!{ESHUTDOWN}), '$! should be EPIPE or ESHUTDOWN') + or printf STDERR "# \$\! = %d (%s)\n", $err, $err; + } + + foreach (@gripping) { + is (syswrite ($righth, $_), length $_, "syswrite to right"); + } -ok (!eof LEFT, "left is not at EOF"); + ok (!eof $lefth, "left is not at EOF"); -$expect = join '', @gripping; -undef $buffer; -is (read (LEFT, $buffer, length $expect), length $expect, "read on left"); -is ($buffer, $expect, "content what we expected?"); + $expect = join '', @gripping; + undef $buffer; + is (read ($lefth, $buffer, length $expect), length $expect, "read on left"); + is ($buffer, $expect, "content what we expected?"); -ok (close LEFT, "close left"); -ok (close RIGHT, "close right"); + ok (close $lefth, "close left"); + ok (close $righth, "close right"); +} # And now datagrams @@ -177,44 +183,49 @@ ok (close RIGHT, "close right"); # guarantee that the stack won't drop a UDP packet, even if it is for localhost. SKIP: { - skip "No usable SOCK_DGRAM for socketpair", 24 if ($^O =~ /^(MSWin32|os2)\z/); skip "alarm doesn't interrupt I/O on this Perl", 24 if "$]" < 5.008; + + my $success = socketpair my $lefth, my $righth, AF_UNIX, SOCK_DGRAM, PF_UNSPEC; + + skip "No useable SOCK_DGRAM for socketpair", 24 if !$success and + ($!{EAFNOSUPPORT} or $!{EOPNOTSUPP} or $!{EPROTONOSUPPORT} or $!{EPROTOTYPE}); + # Maybe this test is redundant now? + skip "No usable SOCK_DGRAM for socketpair", 24 if ($^O =~ /^(MSWin32|os2)\z/); local $TODO = "socketpair not supported on $^O" if $^O eq 'nto'; - ok (socketpair (LEFT, RIGHT, AF_UNIX, SOCK_DGRAM, PF_UNSPEC), - "socketpair (LEFT, RIGHT, AF_UNIX, SOCK_DGRAM, PF_UNSPEC)") + ok ($success, "socketpair (\$left, \$righth, AF_UNIX, SOCK_DGRAM, PF_UNSPEC)") or print STDERR "# \$\! = $!\n"; if ($has_perlio) { - binmode(LEFT, ":bytes"); - binmode(RIGHT, ":bytes"); + binmode($lefth, ":bytes"); + binmode($righth, ":bytes"); } foreach (@left) { - # is (syswrite (LEFT, $_), length $_, "write " . _qq ($_) . " to left"); - is (syswrite (LEFT, $_), length $_, "syswrite to left"); + # is (syswrite ($lefth, $_), length $_, "write " . _qq ($_) . " to left"); + is (syswrite ($lefth, $_), length $_, "syswrite to left"); } foreach (@right) { - # is (syswrite (RIGHT, $_), length $_, "write " . _qq ($_) . " to right"); - is (syswrite (RIGHT, $_), length $_, "syswrite to right"); + # is (syswrite ($righth, $_), length $_, "write " . _qq ($_) . " to right"); + is (syswrite ($righth, $_), length $_, "syswrite to right"); } # stream socket, so our writes will become joined: - my ($total); + my ($total, $buffer); $total = join '', @right; - foreach $expect (@right) { + foreach my $expect (@right) { undef $buffer; - is (sysread (LEFT, $buffer, length $total), length $expect, "read on left"); + is (sysread ($lefth, $buffer, length $total), length $expect, "read on left"); is ($buffer, $expect, "content what we expected?"); } $total = join '', @left; - foreach $expect (@left) { + foreach my $expect (@left) { undef $buffer; - is (sysread (RIGHT, $buffer, length $total), length $expect, "read on right"); + is (sysread ($righth, $buffer, length $total), length $expect, "read on right"); is ($buffer, $expect, "content what we expected?"); } - ok (shutdown(LEFT, 1), "shutdown left for writing"); + ok (shutdown($lefth, 1), "shutdown left for writing"); # eof uses buffering. eof is indicated by a sysread of zero. # but for a datagram socket there's no way it can know nothing will ever be @@ -227,7 +238,7 @@ SKIP: { print "# Approximate forever as 3 seconds. Wait 'forever'...\n"; alarm 3; undef $buffer; - is (sysread (RIGHT, $buffer, 1), undef, + is (sysread ($righth, $buffer, 1), undef, "read on right should be interrupted"); is ($alarmed, 1, "alarm should have fired"); } @@ -235,18 +246,18 @@ SKIP: { alarm 30; foreach (@gripping) { - is (syswrite (RIGHT, $_), length $_, "syswrite to right"); + is (syswrite ($righth, $_), length $_, "syswrite to right"); } $total = join '', @gripping; - foreach $expect (@gripping) { + foreach my $expect (@gripping) { undef $buffer; - is (sysread (LEFT, $buffer, length $total), length $expect, "read on left"); + is (sysread ($lefth, $buffer, length $total), length $expect, "read on left"); is ($buffer, $expect, "content what we expected?"); } - ok (close LEFT, "close left"); - ok (close RIGHT, "close right"); + ok (close $lefth, "close left"); + ok (close $righth, "close right"); } # end of DGRAM SKIP diff --git a/cpan/Sys-Syslog/.gitignore b/cpan/Sys-Syslog/.gitignore index d94e453f6cf8..b2bd5aa30711 100644 --- a/cpan/Sys-Syslog/.gitignore +++ b/cpan/Sys-Syslog/.gitignore @@ -10,3 +10,5 @@ Syslog.c Syslog.o blib/ pm_to_blib +!/Makefile.PL +!/fallback/*.inc diff --git a/cpan/Test-Harness/lib/App/Prove.pm b/cpan/Test-Harness/lib/App/Prove.pm index 9298726d24ff..a33fe971ffa2 100644 --- a/cpan/Test-Harness/lib/App/Prove.pm +++ b/cpan/Test-Harness/lib/App/Prove.pm @@ -18,11 +18,11 @@ App::Prove - Implements the C command. =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/App/Prove/State.pm b/cpan/Test-Harness/lib/App/Prove/State.pm index 0b61a8245907..006d4f871237 100644 --- a/cpan/Test-Harness/lib/App/Prove/State.pm +++ b/cpan/Test-Harness/lib/App/Prove/State.pm @@ -25,11 +25,11 @@ App::Prove::State - State storage for the C command. =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/App/Prove/State/Result.pm b/cpan/Test-Harness/lib/App/Prove/State/Result.pm index 8f89c775aff3..fb5e2d52d21c 100644 --- a/cpan/Test-Harness/lib/App/Prove/State/Result.pm +++ b/cpan/Test-Harness/lib/App/Prove/State/Result.pm @@ -14,11 +14,11 @@ App::Prove::State::Result - Individual test suite results. =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/App/Prove/State/Result/Test.pm b/cpan/Test-Harness/lib/App/Prove/State/Result/Test.pm index b795280f307a..f4cddace3859 100644 --- a/cpan/Test-Harness/lib/App/Prove/State/Result/Test.pm +++ b/cpan/Test-Harness/lib/App/Prove/State/Result/Test.pm @@ -9,11 +9,11 @@ App::Prove::State::Result::Test - Individual test results. =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Base.pm b/cpan/Test-Harness/lib/TAP/Base.pm index 78e07ab0547d..289f093bc6f5 100644 --- a/cpan/Test-Harness/lib/TAP/Base.pm +++ b/cpan/Test-Harness/lib/TAP/Base.pm @@ -12,11 +12,11 @@ and L =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; use constant GOT_TIME_HIRES => do { eval 'use Time::HiRes qw(time);'; diff --git a/cpan/Test-Harness/lib/TAP/Formatter/Base.pm b/cpan/Test-Harness/lib/TAP/Formatter/Base.pm index bf65e12ca157..a9c0e3b04b08 100644 --- a/cpan/Test-Harness/lib/TAP/Formatter/Base.pm +++ b/cpan/Test-Harness/lib/TAP/Formatter/Base.pm @@ -58,11 +58,11 @@ TAP::Formatter::Base - Base class for harness output delegates =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Formatter/Color.pm b/cpan/Test-Harness/lib/TAP/Formatter/Color.pm index 79807901012c..0f08edfe7878 100644 --- a/cpan/Test-Harness/lib/TAP/Formatter/Color.pm +++ b/cpan/Test-Harness/lib/TAP/Formatter/Color.pm @@ -39,11 +39,11 @@ TAP::Formatter::Color - Run Perl test scripts with color =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Formatter/Console.pm b/cpan/Test-Harness/lib/TAP/Formatter/Console.pm index 1c82ef43c6cd..3217099a7124 100644 --- a/cpan/Test-Harness/lib/TAP/Formatter/Console.pm +++ b/cpan/Test-Harness/lib/TAP/Formatter/Console.pm @@ -11,11 +11,11 @@ TAP::Formatter::Console - Harness output delegate for default console output =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Formatter/Console/ParallelSession.pm b/cpan/Test-Harness/lib/TAP/Formatter/Console/ParallelSession.pm index 6826b4e379f0..7f6767c70004 100644 --- a/cpan/Test-Harness/lib/TAP/Formatter/Console/ParallelSession.pm +++ b/cpan/Test-Harness/lib/TAP/Formatter/Console/ParallelSession.pm @@ -41,11 +41,11 @@ TAP::Formatter::Console::ParallelSession - Harness output delegate for parallel =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Formatter/Console/Session.pm b/cpan/Test-Harness/lib/TAP/Formatter/Console/Session.pm index 492bdd7b081c..8c2f95734dc3 100644 --- a/cpan/Test-Harness/lib/TAP/Formatter/Console/Session.pm +++ b/cpan/Test-Harness/lib/TAP/Formatter/Console/Session.pm @@ -26,11 +26,11 @@ TAP::Formatter::Console::Session - Harness output delegate for default console o =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Formatter/File.pm b/cpan/Test-Harness/lib/TAP/Formatter/File.pm index ced7b3f85eab..5a3a55813e10 100644 --- a/cpan/Test-Harness/lib/TAP/Formatter/File.pm +++ b/cpan/Test-Harness/lib/TAP/Formatter/File.pm @@ -13,11 +13,11 @@ TAP::Formatter::File - Harness output delegate for file output =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Formatter/File/Session.pm b/cpan/Test-Harness/lib/TAP/Formatter/File/Session.pm index 3403540e40b7..fb7b1829bae9 100644 --- a/cpan/Test-Harness/lib/TAP/Formatter/File/Session.pm +++ b/cpan/Test-Harness/lib/TAP/Formatter/File/Session.pm @@ -10,11 +10,11 @@ TAP::Formatter::File::Session - Harness output delegate for file output =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Formatter/Session.pm b/cpan/Test-Harness/lib/TAP/Formatter/Session.pm index 2022220aaaff..a26048d9d95c 100644 --- a/cpan/Test-Harness/lib/TAP/Formatter/Session.pm +++ b/cpan/Test-Harness/lib/TAP/Formatter/Session.pm @@ -23,11 +23,11 @@ TAP::Formatter::Session - Abstract base class for harness output delegate =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 METHODS diff --git a/cpan/Test-Harness/lib/TAP/Harness.pm b/cpan/Test-Harness/lib/TAP/Harness.pm index a2f6daf1dbde..1b8ee87a659e 100644 --- a/cpan/Test-Harness/lib/TAP/Harness.pm +++ b/cpan/Test-Harness/lib/TAP/Harness.pm @@ -16,11 +16,11 @@ TAP::Harness - Run test scripts with statistics =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; $ENV{HARNESS_ACTIVE} = 1; $ENV{HARNESS_VERSION} = $VERSION; @@ -619,6 +619,10 @@ sub _aggregate_parallel { my ( $parser, $session ) = $self->make_parser($job); $mux->add( $parser, [ $session, $job ] ); + + # The job has started: begin the timers + $parser->start_time( $parser->get_time ); + $parser->start_times( $parser->get_times ); } if ( my ( $parser, $stash, $result ) = $mux->next ) { diff --git a/cpan/Test-Harness/lib/TAP/Harness/Env.pm b/cpan/Test-Harness/lib/TAP/Harness/Env.pm index 077626df2deb..78e75fb92dab 100644 --- a/cpan/Test-Harness/lib/TAP/Harness/Env.pm +++ b/cpan/Test-Harness/lib/TAP/Harness/Env.pm @@ -7,7 +7,7 @@ use constant IS_VMS => ( $^O eq 'VMS' ); use TAP::Object; use Text::ParseWords qw/shellwords/; -our $VERSION = '3.42'; +our $VERSION = '3.43'; # Get the parts of @INC which are changed from the stock list AND # preserve reordering of stock directories. @@ -126,7 +126,7 @@ TAP::Harness::Env - Parsing harness related environmental variables where approp =head1 VERSION -Version 3.42 +Version 3.43 =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Object.pm b/cpan/Test-Harness/lib/TAP/Object.pm index e9da17f4ff1d..d3063c2b27a4 100644 --- a/cpan/Test-Harness/lib/TAP/Object.pm +++ b/cpan/Test-Harness/lib/TAP/Object.pm @@ -9,11 +9,11 @@ TAP::Object - Base class that provides common functionality to all C mod =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser.pm b/cpan/Test-Harness/lib/TAP/Parser.pm index 34f411048e38..e8d51b12c8a9 100644 --- a/cpan/Test-Harness/lib/TAP/Parser.pm +++ b/cpan/Test-Harness/lib/TAP/Parser.pm @@ -27,11 +27,11 @@ TAP::Parser - Parse L output =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; my $DEFAULT_TAP_VERSION = 12; my $MAX_TAP_VERSION = 13; @@ -1384,8 +1384,8 @@ sub _iter { my $state = 'INIT'; my $state_table = $self->_make_state_table; - $self->start_time( $self->get_time ); - $self->start_times( $self->get_times ); + $self->start_time( $self->get_time ) unless $self->{start_time}; + $self->start_times( $self->get_times ) unless $self->{start_times}; # Make next_state closure my $next_state = sub { diff --git a/cpan/Test-Harness/lib/TAP/Parser/Aggregator.pm b/cpan/Test-Harness/lib/TAP/Parser/Aggregator.pm index 65be445f308a..1f4ff5d96125 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Aggregator.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Aggregator.pm @@ -12,11 +12,11 @@ TAP::Parser::Aggregator - Aggregate TAP::Parser results =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/Grammar.pm b/cpan/Test-Harness/lib/TAP/Parser/Grammar.pm index ff0f2aa2ad76..0cf4d5b4c7d5 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Grammar.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Grammar.pm @@ -14,11 +14,11 @@ TAP::Parser::Grammar - A grammar for the Test Anything Protocol. =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/Iterator.pm b/cpan/Test-Harness/lib/TAP/Parser/Iterator.pm index fab48cb2bed2..b516929b053f 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Iterator.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Iterator.pm @@ -11,11 +11,11 @@ TAP::Parser::Iterator - Base class for TAP source iterators =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/Iterator/Array.pm b/cpan/Test-Harness/lib/TAP/Parser/Iterator/Array.pm index 5a098cca7c06..3ea348d60865 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Iterator/Array.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Iterator/Array.pm @@ -11,11 +11,11 @@ TAP::Parser::Iterator::Array - Iterator for array-based TAP sources =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/Iterator/Process.pm b/cpan/Test-Harness/lib/TAP/Parser/Iterator/Process.pm index a121485aec44..8e95a44a23cb 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Iterator/Process.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Iterator/Process.pm @@ -16,11 +16,11 @@ TAP::Parser::Iterator::Process - Iterator for process-based TAP sources =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm b/cpan/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm index 2a21485357fa..305453124fd7 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm @@ -11,11 +11,11 @@ TAP::Parser::Iterator::Stream - Iterator for filehandle-based TAP sources =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/IteratorFactory.pm b/cpan/Test-Harness/lib/TAP/Parser/IteratorFactory.pm index cd677028bd86..3529c2f86c60 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/IteratorFactory.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/IteratorFactory.pm @@ -16,11 +16,11 @@ TAP::Parser::IteratorFactory - Figures out which SourceHandler objects to use fo =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/Multiplexer.pm b/cpan/Test-Harness/lib/TAP/Parser/Multiplexer.pm index 16af2d308541..164e9af47712 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Multiplexer.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Multiplexer.pm @@ -17,11 +17,11 @@ TAP::Parser::Multiplexer - Multiplex multiple TAP::Parsers =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result.pm b/cpan/Test-Harness/lib/TAP/Parser/Result.pm index c8927968dbe5..698402ab83e1 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result.pm @@ -24,11 +24,11 @@ TAP::Parser::Result - Base class for TAP::Parser output objects =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/Bailout.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Bailout.pm index facae6fe8e4f..38ee45853ca7 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/Bailout.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Bailout.pm @@ -11,11 +11,11 @@ TAP::Parser::Result::Bailout - Bailout result token. =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/Comment.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Comment.pm index 0f99b57b08e1..a07308ea8111 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/Comment.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Comment.pm @@ -11,11 +11,11 @@ TAP::Parser::Result::Comment - Comment result token. =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/Plan.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Plan.pm index 9db060e90df7..1029694d57c9 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/Plan.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Plan.pm @@ -11,11 +11,11 @@ TAP::Parser::Result::Plan - Plan result token. =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/Pragma.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Pragma.pm index c7a26beeedd6..897e0da65848 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/Pragma.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Pragma.pm @@ -11,11 +11,11 @@ TAP::Parser::Result::Pragma - TAP pragma token. =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/Test.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Test.pm index b3bd224c16f2..e2c9781e16fb 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/Test.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Test.pm @@ -11,11 +11,11 @@ TAP::Parser::Result::Test - Test result token. =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/Unknown.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Unknown.pm index d735ed165acd..cc04c8a385db 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/Unknown.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Unknown.pm @@ -11,11 +11,11 @@ TAP::Parser::Result::Unknown - Unknown result token. =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/Version.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Version.pm index 5f4cb932bd30..8a2bd7ec442c 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/Version.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Version.pm @@ -11,11 +11,11 @@ TAP::Parser::Result::Version - TAP syntax version token. =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/YAML.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/YAML.pm index a88b8da1f7ea..17de945ef062 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/YAML.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/YAML.pm @@ -11,11 +11,11 @@ TAP::Parser::Result::YAML - YAML result token. =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/ResultFactory.pm b/cpan/Test-Harness/lib/TAP/Parser/ResultFactory.pm index 27776ea05c76..54d29a265daf 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/ResultFactory.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/ResultFactory.pm @@ -29,11 +29,11 @@ TAP::Parser::ResultFactory - Factory for creating TAP::Parser output objects =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head2 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Scheduler.pm b/cpan/Test-Harness/lib/TAP/Parser/Scheduler.pm index e13d68e087ba..7e3ddc2c086b 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Scheduler.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Scheduler.pm @@ -13,11 +13,11 @@ TAP::Parser::Scheduler - Schedule tests during parallel testing =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm b/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm index b765ab27b0e1..bfcb0f76b3b9 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm @@ -10,11 +10,11 @@ TAP::Parser::Scheduler::Job - A single testing job. =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm b/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm index 47bc28fc9135..29f5c0daf16c 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm @@ -10,11 +10,11 @@ TAP::Parser::Scheduler::Spinner - A no-op job. =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/Source.pm b/cpan/Test-Harness/lib/TAP/Parser/Source.pm index 5bd85e37f71f..74c22cce8b41 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Source.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Source.pm @@ -14,11 +14,11 @@ TAP::Parser::Source - a TAP source & meta data about it =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler.pm b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler.pm index 0156b99fd68b..f80c1ca25c16 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler.pm @@ -12,11 +12,11 @@ TAP::Parser::SourceHandler - Base class for different TAP source handlers =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Executable.pm b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Executable.pm index 376e8d148d89..0ad412bc4924 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Executable.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Executable.pm @@ -16,11 +16,11 @@ TAP::Parser::SourceHandler::Executable - Stream output from an executable TAP so =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/File.pm b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/File.pm index 7e1843759e8f..48f98210519d 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/File.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/File.pm @@ -16,11 +16,11 @@ TAP::Parser::SourceHandler::File - Stream TAP from a text file. =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Handle.pm b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Handle.pm index a0a051340f70..751e68aa307b 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Handle.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Handle.pm @@ -16,11 +16,11 @@ TAP::Parser::SourceHandler::Handle - Stream TAP from an IO::Handle or a GLOB. =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Perl.pm b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Perl.pm index c2ea252ec2ab..26b408a4583d 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Perl.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Perl.pm @@ -21,11 +21,11 @@ TAP::Parser::SourceHandler::Perl - Stream TAP from a Perl executable =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/RawTAP.pm b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/RawTAP.pm index 2ef77118bc86..9bf3b272a8ea 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/RawTAP.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/RawTAP.pm @@ -16,11 +16,11 @@ TAP::Parser::SourceHandler::RawTAP - Stream output from raw TAP in a scalar/arra =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm b/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm index 1a8185eb6b5b..eafc37aa0c79 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm @@ -5,7 +5,7 @@ use warnings; use base 'TAP::Object'; -our $VERSION = '3.42'; +our $VERSION = '3.43'; # TODO: # Handle blessed object syntax @@ -269,7 +269,7 @@ TAP::Parser::YAMLish::Reader - Read YAMLish data from iterator =head1 VERSION -Version 3.42 +Version 3.43 =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm b/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm index 904244ae110e..9d6366c32531 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm @@ -5,7 +5,7 @@ use warnings; use base 'TAP::Object'; -our $VERSION = '3.42'; +our $VERSION = '3.43'; my $ESCAPE_CHAR = qr{ [ \x00-\x1f \" ] }x; my $ESCAPE_KEY = qr{ (?: ^\W ) | $ESCAPE_CHAR }x; @@ -146,7 +146,7 @@ TAP::Parser::YAMLish::Writer - Write YAMLish data =head1 VERSION -Version 3.42 +Version 3.43 =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/Test/Harness.pm b/cpan/Test-Harness/lib/Test/Harness.pm index 6cce46e3b622..7084d624e1d0 100644 --- a/cpan/Test-Harness/lib/Test/Harness.pm +++ b/cpan/Test-Harness/lib/Test/Harness.pm @@ -31,11 +31,11 @@ Test::Harness - Run Perl standard test scripts with statistics =head1 VERSION -Version 3.42 +Version 3.43 =cut -our $VERSION = '3.42'; +our $VERSION = '3.43'; # Backwards compatibility for exportable variable names. *verbose = *Verbose; diff --git a/cpan/Test-Harness/t/source.t b/cpan/Test-Harness/t/source.t index 767892c5723f..77cf44269745 100644 --- a/cpan/Test-Harness/t/source.t +++ b/cpan/Test-Harness/t/source.t @@ -242,11 +242,12 @@ SKIP: { my $symlink = File::Spec->catfile( $dir, 'source_link.T' ); my $source = TAP::Parser::Source->new; - eval { symlink( File::Spec->rel2abs($test), $symlink ) }; + my $did_symlink = eval { symlink( File::Spec->rel2abs($test), $symlink ) }; if ( my $e = $@ ) { diag($@); die "aborting test"; } + skip "symlink not successful: $!", 9 unless $did_symlink; $source->raw( \$symlink ); my $meta = $source->assemble_meta; diff --git a/cpan/Test-Simple/lib/Test/Builder.pm b/cpan/Test-Simple/lib/Test/Builder.pm index 2d938889c6c9..6c3cceec9975 100644 --- a/cpan/Test-Simple/lib/Test/Builder.pm +++ b/cpan/Test-Simple/lib/Test/Builder.pm @@ -4,7 +4,7 @@ use 5.006; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; BEGIN { if( $] < 5.008 ) { @@ -963,10 +963,13 @@ sub cmp_ok { my($pack, $file, $line) = $ctx->trace->call(); my $warning_bits = $ctx->trace->warning_bits; + # convert this to a code string so the BEGIN doesn't have to close + # over it, which can lead to issues with Devel::Cover + my $bits_code = defined $warning_bits ? qq["\Q$warning_bits\E"] : 'undef'; # This is so that warnings come out at the caller's level $succ = eval qq[ -BEGIN {\${^WARNING_BITS} = \$warning_bits}; +BEGIN {\${^WARNING_BITS} = $bits_code}; #line $line "(eval in cmp_ok) $file" \$test = (\$got $type \$expect); 1; diff --git a/cpan/Test-Simple/lib/Test/Builder/Formatter.pm b/cpan/Test-Simple/lib/Test/Builder/Formatter.pm index 3356f3b6f1de..e2acbc58314f 100644 --- a/cpan/Test-Simple/lib/Test/Builder/Formatter.pm +++ b/cpan/Test-Simple/lib/Test/Builder/Formatter.pm @@ -2,7 +2,7 @@ package Test::Builder::Formatter; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; BEGIN { require Test2::Formatter::TAP; our @ISA = qw(Test2::Formatter::TAP) } diff --git a/cpan/Test-Simple/lib/Test/Builder/Module.pm b/cpan/Test-Simple/lib/Test/Builder/Module.pm index 59adcce7c878..40cf5d61f7d9 100644 --- a/cpan/Test-Simple/lib/Test/Builder/Module.pm +++ b/cpan/Test-Simple/lib/Test/Builder/Module.pm @@ -7,7 +7,7 @@ use Test::Builder; require Exporter; our @ISA = qw(Exporter); -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; =head1 NAME diff --git a/cpan/Test-Simple/lib/Test/Builder/Tester.pm b/cpan/Test-Simple/lib/Test/Builder/Tester.pm index cda01c6af319..5bbe300fb354 100644 --- a/cpan/Test-Simple/lib/Test/Builder/Tester.pm +++ b/cpan/Test-Simple/lib/Test/Builder/Tester.pm @@ -1,7 +1,7 @@ package Test::Builder::Tester; use strict; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; use Test::Builder; use Symbol; diff --git a/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm b/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm index 3f6694ac1ed5..1fb4a694c013 100644 --- a/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm +++ b/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm @@ -1,7 +1,7 @@ package Test::Builder::Tester::Color; use strict; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; require Test::Builder::Tester; diff --git a/cpan/Test-Simple/lib/Test/Builder/TodoDiag.pm b/cpan/Test-Simple/lib/Test/Builder/TodoDiag.pm index 127fddbfdf41..6e04f5c53d6c 100644 --- a/cpan/Test-Simple/lib/Test/Builder/TodoDiag.pm +++ b/cpan/Test-Simple/lib/Test/Builder/TodoDiag.pm @@ -2,7 +2,7 @@ package Test::Builder::TodoDiag; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; BEGIN { require Test2::Event::Diag; our @ISA = qw(Test2::Event::Diag) } diff --git a/cpan/Test-Simple/lib/Test/More.pm b/cpan/Test-Simple/lib/Test/More.pm index 4028930b41d0..7212d25d6af5 100644 --- a/cpan/Test-Simple/lib/Test/More.pm +++ b/cpan/Test-Simple/lib/Test/More.pm @@ -17,7 +17,7 @@ sub _carp { return warn @_, " at $file line $line\n"; } -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; use Test::Builder::Module; our @ISA = qw(Test::Builder::Module); diff --git a/cpan/Test-Simple/lib/Test/Simple.pm b/cpan/Test-Simple/lib/Test/Simple.pm index 30e811c9be88..b8a6c7ca402b 100644 --- a/cpan/Test-Simple/lib/Test/Simple.pm +++ b/cpan/Test-Simple/lib/Test/Simple.pm @@ -4,7 +4,7 @@ use 5.006; use strict; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; use Test::Builder::Module; our @ISA = qw(Test::Builder::Module); diff --git a/cpan/Test-Simple/lib/Test/Tester.pm b/cpan/Test-Simple/lib/Test/Tester.pm index c31a36fa3eac..506734ea8bc0 100644 --- a/cpan/Test-Simple/lib/Test/Tester.pm +++ b/cpan/Test-Simple/lib/Test/Tester.pm @@ -18,7 +18,7 @@ require Exporter; use vars qw( @ISA @EXPORT ); -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; @EXPORT = qw( run_tests check_tests check_test cmp_results show_space ); @ISA = qw( Exporter ); diff --git a/cpan/Test-Simple/lib/Test/Tester/Capture.pm b/cpan/Test-Simple/lib/Test/Tester/Capture.pm index 8e15594901f4..71324b03d18e 100644 --- a/cpan/Test-Simple/lib/Test/Tester/Capture.pm +++ b/cpan/Test-Simple/lib/Test/Tester/Capture.pm @@ -2,7 +2,7 @@ use strict; package Test::Tester::Capture; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; use Test::Builder; diff --git a/cpan/Test-Simple/lib/Test/Tester/CaptureRunner.pm b/cpan/Test-Simple/lib/Test/Tester/CaptureRunner.pm index 38ffb46a843f..ffd6e99f2e8c 100644 --- a/cpan/Test-Simple/lib/Test/Tester/CaptureRunner.pm +++ b/cpan/Test-Simple/lib/Test/Tester/CaptureRunner.pm @@ -3,7 +3,7 @@ use strict; package Test::Tester::CaptureRunner; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; use Test::Tester::Capture; diff --git a/cpan/Test-Simple/lib/Test/Tester/Delegate.pm b/cpan/Test-Simple/lib/Test/Tester/Delegate.pm index 7ff59d6048ec..826c21e71e31 100644 --- a/cpan/Test-Simple/lib/Test/Tester/Delegate.pm +++ b/cpan/Test-Simple/lib/Test/Tester/Delegate.pm @@ -3,7 +3,7 @@ use warnings; package Test::Tester::Delegate; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; use Scalar::Util(); diff --git a/cpan/Test-Simple/lib/Test/use/ok.pm b/cpan/Test-Simple/lib/Test/use/ok.pm index 6758b34d7833..1e2f0df2c1ca 100644 --- a/cpan/Test-Simple/lib/Test/use/ok.pm +++ b/cpan/Test-Simple/lib/Test/use/ok.pm @@ -1,7 +1,7 @@ package Test::use::ok; use 5.005; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; __END__ diff --git a/cpan/Test-Simple/lib/Test2.pm b/cpan/Test-Simple/lib/Test2.pm index 68f7622474f3..7b8984beaf21 100644 --- a/cpan/Test-Simple/lib/Test2.pm +++ b/cpan/Test-Simple/lib/Test2.pm @@ -2,7 +2,7 @@ package Test2; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; 1; diff --git a/cpan/Test-Simple/lib/Test2/API.pm b/cpan/Test-Simple/lib/Test2/API.pm index 30d30fdae81a..6c663468ab0c 100644 --- a/cpan/Test-Simple/lib/Test2/API.pm +++ b/cpan/Test-Simple/lib/Test2/API.pm @@ -9,7 +9,7 @@ BEGIN { $ENV{TEST2_ACTIVE} = 1; } -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; my $INST; diff --git a/cpan/Test-Simple/lib/Test2/API/Breakage.pm b/cpan/Test-Simple/lib/Test2/API/Breakage.pm index 9cb3e932f57e..b661b9e2b8af 100644 --- a/cpan/Test-Simple/lib/Test2/API/Breakage.pm +++ b/cpan/Test-Simple/lib/Test2/API/Breakage.pm @@ -2,7 +2,7 @@ package Test2::API::Breakage; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; use Test2::Util qw/pkg_to_file/; diff --git a/cpan/Test-Simple/lib/Test2/API/Context.pm b/cpan/Test-Simple/lib/Test2/API/Context.pm index c79f4d6e19f7..f94993c8e85f 100644 --- a/cpan/Test-Simple/lib/Test2/API/Context.pm +++ b/cpan/Test-Simple/lib/Test2/API/Context.pm @@ -2,7 +2,7 @@ package Test2::API::Context; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; use Carp qw/confess croak/; diff --git a/cpan/Test-Simple/lib/Test2/API/Instance.pm b/cpan/Test-Simple/lib/Test2/API/Instance.pm index 1f7593fd3895..8a0ef99e3d30 100644 --- a/cpan/Test-Simple/lib/Test2/API/Instance.pm +++ b/cpan/Test-Simple/lib/Test2/API/Instance.pm @@ -2,7 +2,7 @@ package Test2::API::Instance; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; our @CARP_NOT = qw/Test2::API Test2::API::Instance Test2::IPC::Driver Test2::Formatter/; use Carp qw/confess carp/; diff --git a/cpan/Test-Simple/lib/Test2/API/InterceptResult.pm b/cpan/Test-Simple/lib/Test2/API/InterceptResult.pm index fdf866258823..a679ac4806ef 100644 --- a/cpan/Test-Simple/lib/Test2/API/InterceptResult.pm +++ b/cpan/Test-Simple/lib/Test2/API/InterceptResult.pm @@ -2,7 +2,7 @@ package Test2::API::InterceptResult; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; use Scalar::Util qw/blessed/; use Test2::Util qw/pkg_to_file/; diff --git a/cpan/Test-Simple/lib/Test2/API/InterceptResult/Event.pm b/cpan/Test-Simple/lib/Test2/API/InterceptResult/Event.pm index c0db58e43585..860f4966ee8a 100644 --- a/cpan/Test-Simple/lib/Test2/API/InterceptResult/Event.pm +++ b/cpan/Test-Simple/lib/Test2/API/InterceptResult/Event.pm @@ -2,7 +2,7 @@ package Test2::API::InterceptResult::Event; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; use List::Util qw/first/; use Test2::Util qw/pkg_to_file/; diff --git a/cpan/Test-Simple/lib/Test2/API/InterceptResult/Facet.pm b/cpan/Test-Simple/lib/Test2/API/InterceptResult/Facet.pm index e1877bf502b2..ca4a9b38b5bd 100644 --- a/cpan/Test-Simple/lib/Test2/API/InterceptResult/Facet.pm +++ b/cpan/Test-Simple/lib/Test2/API/InterceptResult/Facet.pm @@ -2,7 +2,7 @@ package Test2::API::InterceptResult::Facet; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; BEGIN { require Test2::EventFacet; diff --git a/cpan/Test-Simple/lib/Test2/API/InterceptResult/Hub.pm b/cpan/Test-Simple/lib/Test2/API/InterceptResult/Hub.pm index 15b2afccbcbb..aeb92c7b54e4 100644 --- a/cpan/Test-Simple/lib/Test2/API/InterceptResult/Hub.pm +++ b/cpan/Test-Simple/lib/Test2/API/InterceptResult/Hub.pm @@ -2,7 +2,7 @@ package Test2::API::InterceptResult::Hub; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) } use Test2::Util::HashBase; diff --git a/cpan/Test-Simple/lib/Test2/API/InterceptResult/Squasher.pm b/cpan/Test-Simple/lib/Test2/API/InterceptResult/Squasher.pm index facf16c85c4d..ace805e7816d 100644 --- a/cpan/Test-Simple/lib/Test2/API/InterceptResult/Squasher.pm +++ b/cpan/Test-Simple/lib/Test2/API/InterceptResult/Squasher.pm @@ -2,7 +2,7 @@ package Test2::API::InterceptResult::Squasher; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; use Carp qw/croak/; use List::Util qw/first/; diff --git a/cpan/Test-Simple/lib/Test2/API/Stack.pm b/cpan/Test-Simple/lib/Test2/API/Stack.pm index 2d5d1f049a2a..b5585a8ef4af 100644 --- a/cpan/Test-Simple/lib/Test2/API/Stack.pm +++ b/cpan/Test-Simple/lib/Test2/API/Stack.pm @@ -2,7 +2,7 @@ package Test2::API::Stack; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; use Test2::Hub(); diff --git a/cpan/Test-Simple/lib/Test2/Event.pm b/cpan/Test-Simple/lib/Test2/Event.pm index afd876ce34f5..99a6fd43cb1c 100644 --- a/cpan/Test-Simple/lib/Test2/Event.pm +++ b/cpan/Test-Simple/lib/Test2/Event.pm @@ -2,7 +2,7 @@ package Test2::Event; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; use Scalar::Util qw/blessed reftype/; use Carp qw/croak/; diff --git a/cpan/Test-Simple/lib/Test2/Event/Bail.pm b/cpan/Test-Simple/lib/Test2/Event/Bail.pm index eef1f5688ac7..9b5092def83d 100644 --- a/cpan/Test-Simple/lib/Test2/Event/Bail.pm +++ b/cpan/Test-Simple/lib/Test2/Event/Bail.pm @@ -2,7 +2,7 @@ package Test2::Event::Bail; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } diff --git a/cpan/Test-Simple/lib/Test2/Event/Diag.pm b/cpan/Test-Simple/lib/Test2/Event/Diag.pm index f696c9000117..fb7523523384 100644 --- a/cpan/Test-Simple/lib/Test2/Event/Diag.pm +++ b/cpan/Test-Simple/lib/Test2/Event/Diag.pm @@ -2,7 +2,7 @@ package Test2::Event::Diag; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } diff --git a/cpan/Test-Simple/lib/Test2/Event/Encoding.pm b/cpan/Test-Simple/lib/Test2/Event/Encoding.pm index 917142df3310..831fcebb4da5 100644 --- a/cpan/Test-Simple/lib/Test2/Event/Encoding.pm +++ b/cpan/Test-Simple/lib/Test2/Event/Encoding.pm @@ -2,7 +2,7 @@ package Test2::Event::Encoding; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; use Carp qw/croak/; diff --git a/cpan/Test-Simple/lib/Test2/Event/Exception.pm b/cpan/Test-Simple/lib/Test2/Event/Exception.pm index b890fc231341..a02a6012ac18 100644 --- a/cpan/Test-Simple/lib/Test2/Event/Exception.pm +++ b/cpan/Test-Simple/lib/Test2/Event/Exception.pm @@ -2,7 +2,7 @@ package Test2::Event::Exception; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } diff --git a/cpan/Test-Simple/lib/Test2/Event/Fail.pm b/cpan/Test-Simple/lib/Test2/Event/Fail.pm index af09cbf2bd06..7a1eaa94f24e 100644 --- a/cpan/Test-Simple/lib/Test2/Event/Fail.pm +++ b/cpan/Test-Simple/lib/Test2/Event/Fail.pm @@ -2,7 +2,7 @@ package Test2::Event::Fail; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; use Test2::EventFacet::Info; diff --git a/cpan/Test-Simple/lib/Test2/Event/Generic.pm b/cpan/Test-Simple/lib/Test2/Event/Generic.pm index ce8c1487c8b6..409fb77bc496 100644 --- a/cpan/Test-Simple/lib/Test2/Event/Generic.pm +++ b/cpan/Test-Simple/lib/Test2/Event/Generic.pm @@ -5,7 +5,7 @@ use warnings; use Carp qw/croak/; use Scalar::Util qw/reftype/; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase; diff --git a/cpan/Test-Simple/lib/Test2/Event/Note.pm b/cpan/Test-Simple/lib/Test2/Event/Note.pm index cfa0e270c083..13613f8c9612 100644 --- a/cpan/Test-Simple/lib/Test2/Event/Note.pm +++ b/cpan/Test-Simple/lib/Test2/Event/Note.pm @@ -2,7 +2,7 @@ package Test2::Event::Note; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } diff --git a/cpan/Test-Simple/lib/Test2/Event/Ok.pm b/cpan/Test-Simple/lib/Test2/Event/Ok.pm index 9b3c43bc2639..d39c1dbf844a 100644 --- a/cpan/Test-Simple/lib/Test2/Event/Ok.pm +++ b/cpan/Test-Simple/lib/Test2/Event/Ok.pm @@ -2,7 +2,7 @@ package Test2::Event::Ok; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } diff --git a/cpan/Test-Simple/lib/Test2/Event/Pass.pm b/cpan/Test-Simple/lib/Test2/Event/Pass.pm index f43f0d11e870..b5050459ce7d 100644 --- a/cpan/Test-Simple/lib/Test2/Event/Pass.pm +++ b/cpan/Test-Simple/lib/Test2/Event/Pass.pm @@ -2,7 +2,7 @@ package Test2::Event::Pass; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; use Test2::EventFacet::Info; diff --git a/cpan/Test-Simple/lib/Test2/Event/Plan.pm b/cpan/Test-Simple/lib/Test2/Event/Plan.pm index 7b1531ddacee..cc9d8049e33d 100644 --- a/cpan/Test-Simple/lib/Test2/Event/Plan.pm +++ b/cpan/Test-Simple/lib/Test2/Event/Plan.pm @@ -2,7 +2,7 @@ package Test2::Event::Plan; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } diff --git a/cpan/Test-Simple/lib/Test2/Event/Skip.pm b/cpan/Test-Simple/lib/Test2/Event/Skip.pm index ebc5ff1f60f8..75d7db1bd8ed 100644 --- a/cpan/Test-Simple/lib/Test2/Event/Skip.pm +++ b/cpan/Test-Simple/lib/Test2/Event/Skip.pm @@ -2,7 +2,7 @@ package Test2::Event::Skip; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) } diff --git a/cpan/Test-Simple/lib/Test2/Event/Subtest.pm b/cpan/Test-Simple/lib/Test2/Event/Subtest.pm index ac5ca0a483e1..89081fa2251a 100644 --- a/cpan/Test-Simple/lib/Test2/Event/Subtest.pm +++ b/cpan/Test-Simple/lib/Test2/Event/Subtest.pm @@ -2,7 +2,7 @@ package Test2::Event::Subtest; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) } use Test2::Util::HashBase qw{subevents buffered subtest_id subtest_uuid}; diff --git a/cpan/Test-Simple/lib/Test2/Event/TAP/Version.pm b/cpan/Test-Simple/lib/Test2/Event/TAP/Version.pm index d283a07e743d..bb90cc5f4920 100644 --- a/cpan/Test-Simple/lib/Test2/Event/TAP/Version.pm +++ b/cpan/Test-Simple/lib/Test2/Event/TAP/Version.pm @@ -2,7 +2,7 @@ package Test2::Event::TAP::Version; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; use Carp qw/croak/; diff --git a/cpan/Test-Simple/lib/Test2/Event/V2.pm b/cpan/Test-Simple/lib/Test2/Event/V2.pm index 913a72cac8de..accab090d6cb 100644 --- a/cpan/Test-Simple/lib/Test2/Event/V2.pm +++ b/cpan/Test-Simple/lib/Test2/Event/V2.pm @@ -2,7 +2,7 @@ package Test2::Event::V2; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; use Scalar::Util qw/reftype/; use Carp qw/croak/; diff --git a/cpan/Test-Simple/lib/Test2/Event/Waiting.pm b/cpan/Test-Simple/lib/Test2/Event/Waiting.pm index d2d4467b930b..0f92a910b79a 100644 --- a/cpan/Test-Simple/lib/Test2/Event/Waiting.pm +++ b/cpan/Test-Simple/lib/Test2/Event/Waiting.pm @@ -2,7 +2,7 @@ package Test2::Event::Waiting; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } diff --git a/cpan/Test-Simple/lib/Test2/EventFacet.pm b/cpan/Test-Simple/lib/Test2/EventFacet.pm index a1c25b297497..171e005f8593 100644 --- a/cpan/Test-Simple/lib/Test2/EventFacet.pm +++ b/cpan/Test-Simple/lib/Test2/EventFacet.pm @@ -2,7 +2,7 @@ package Test2::EventFacet; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; use Test2::Util::HashBase qw/-details/; use Carp qw/croak/; diff --git a/cpan/Test-Simple/lib/Test2/EventFacet/About.pm b/cpan/Test-Simple/lib/Test2/EventFacet/About.pm index 92406dbb807a..50dfa4dfe01c 100644 --- a/cpan/Test-Simple/lib/Test2/EventFacet/About.pm +++ b/cpan/Test-Simple/lib/Test2/EventFacet/About.pm @@ -2,7 +2,7 @@ package Test2::EventFacet::About; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{ -package -no_display -uuid -eid }; diff --git a/cpan/Test-Simple/lib/Test2/EventFacet/Amnesty.pm b/cpan/Test-Simple/lib/Test2/EventFacet/Amnesty.pm index c6a398ec68b3..fb65846f16d5 100644 --- a/cpan/Test-Simple/lib/Test2/EventFacet/Amnesty.pm +++ b/cpan/Test-Simple/lib/Test2/EventFacet/Amnesty.pm @@ -2,7 +2,7 @@ package Test2::EventFacet::Amnesty; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; sub is_list { 1 } diff --git a/cpan/Test-Simple/lib/Test2/EventFacet/Assert.pm b/cpan/Test-Simple/lib/Test2/EventFacet/Assert.pm index f3f5a93fe058..ffe2b054393b 100644 --- a/cpan/Test-Simple/lib/Test2/EventFacet/Assert.pm +++ b/cpan/Test-Simple/lib/Test2/EventFacet/Assert.pm @@ -2,7 +2,7 @@ package Test2::EventFacet::Assert; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{ -pass -no_debug -number }; diff --git a/cpan/Test-Simple/lib/Test2/EventFacet/Control.pm b/cpan/Test-Simple/lib/Test2/EventFacet/Control.pm index 6775c170294f..891d38f6dd4d 100644 --- a/cpan/Test-Simple/lib/Test2/EventFacet/Control.pm +++ b/cpan/Test-Simple/lib/Test2/EventFacet/Control.pm @@ -2,7 +2,7 @@ package Test2::EventFacet::Control; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{ -global -terminate -halt -has_callback -encoding -phase }; diff --git a/cpan/Test-Simple/lib/Test2/EventFacet/Error.pm b/cpan/Test-Simple/lib/Test2/EventFacet/Error.pm index 16cfa42bc658..407e7e736802 100644 --- a/cpan/Test-Simple/lib/Test2/EventFacet/Error.pm +++ b/cpan/Test-Simple/lib/Test2/EventFacet/Error.pm @@ -2,7 +2,7 @@ package Test2::EventFacet::Error; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; sub facet_key { 'errors' } sub is_list { 1 } diff --git a/cpan/Test-Simple/lib/Test2/EventFacet/Hub.pm b/cpan/Test-Simple/lib/Test2/EventFacet/Hub.pm index a1bb14d9e7df..35a75c13a72c 100644 --- a/cpan/Test-Simple/lib/Test2/EventFacet/Hub.pm +++ b/cpan/Test-Simple/lib/Test2/EventFacet/Hub.pm @@ -2,7 +2,7 @@ package Test2::EventFacet::Hub; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; sub is_list { 1 } sub facet_key { 'hubs' } diff --git a/cpan/Test-Simple/lib/Test2/EventFacet/Info.pm b/cpan/Test-Simple/lib/Test2/EventFacet/Info.pm index 1f877f119028..2aa38e96bd7d 100644 --- a/cpan/Test-Simple/lib/Test2/EventFacet/Info.pm +++ b/cpan/Test-Simple/lib/Test2/EventFacet/Info.pm @@ -2,7 +2,7 @@ package Test2::EventFacet::Info; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; sub is_list { 1 } diff --git a/cpan/Test-Simple/lib/Test2/EventFacet/Info/Table.pm b/cpan/Test-Simple/lib/Test2/EventFacet/Info/Table.pm index 750a834a9712..351e88b4fa84 100644 --- a/cpan/Test-Simple/lib/Test2/EventFacet/Info/Table.pm +++ b/cpan/Test-Simple/lib/Test2/EventFacet/Info/Table.pm @@ -2,7 +2,7 @@ package Test2::EventFacet::Info::Table; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; use Carp qw/confess/; diff --git a/cpan/Test-Simple/lib/Test2/EventFacet/Meta.pm b/cpan/Test-Simple/lib/Test2/EventFacet/Meta.pm index 88de563ac68c..17f78bd59d49 100644 --- a/cpan/Test-Simple/lib/Test2/EventFacet/Meta.pm +++ b/cpan/Test-Simple/lib/Test2/EventFacet/Meta.pm @@ -2,7 +2,7 @@ package Test2::EventFacet::Meta; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use vars qw/$AUTOLOAD/; diff --git a/cpan/Test-Simple/lib/Test2/EventFacet/Parent.pm b/cpan/Test-Simple/lib/Test2/EventFacet/Parent.pm index 4f440c0f25a7..82521cd63d56 100644 --- a/cpan/Test-Simple/lib/Test2/EventFacet/Parent.pm +++ b/cpan/Test-Simple/lib/Test2/EventFacet/Parent.pm @@ -2,7 +2,7 @@ package Test2::EventFacet::Parent; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; use Carp qw/confess/; diff --git a/cpan/Test-Simple/lib/Test2/EventFacet/Plan.pm b/cpan/Test-Simple/lib/Test2/EventFacet/Plan.pm index 91ed3f63ec38..99349b357550 100644 --- a/cpan/Test-Simple/lib/Test2/EventFacet/Plan.pm +++ b/cpan/Test-Simple/lib/Test2/EventFacet/Plan.pm @@ -2,7 +2,7 @@ package Test2::EventFacet::Plan; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{ -count -skip -none }; diff --git a/cpan/Test-Simple/lib/Test2/EventFacet/Render.pm b/cpan/Test-Simple/lib/Test2/EventFacet/Render.pm index a04cc59f2351..8cc8b7a8e52b 100644 --- a/cpan/Test-Simple/lib/Test2/EventFacet/Render.pm +++ b/cpan/Test-Simple/lib/Test2/EventFacet/Render.pm @@ -2,7 +2,7 @@ package Test2::EventFacet::Render; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; sub is_list { 1 } diff --git a/cpan/Test-Simple/lib/Test2/EventFacet/Trace.pm b/cpan/Test-Simple/lib/Test2/EventFacet/Trace.pm index 87e452bdd0b6..6c4e4550b519 100644 --- a/cpan/Test-Simple/lib/Test2/EventFacet/Trace.pm +++ b/cpan/Test-Simple/lib/Test2/EventFacet/Trace.pm @@ -2,7 +2,7 @@ package Test2::EventFacet::Trace; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } diff --git a/cpan/Test-Simple/lib/Test2/Formatter.pm b/cpan/Test-Simple/lib/Test2/Formatter.pm index bec33fede79b..981baba2d1da 100644 --- a/cpan/Test-Simple/lib/Test2/Formatter.pm +++ b/cpan/Test-Simple/lib/Test2/Formatter.pm @@ -2,7 +2,7 @@ package Test2::Formatter; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; my %ADDED; diff --git a/cpan/Test-Simple/lib/Test2/Formatter/TAP.pm b/cpan/Test-Simple/lib/Test2/Formatter/TAP.pm index 8dc2cc96881b..0b1e9475d005 100644 --- a/cpan/Test-Simple/lib/Test2/Formatter/TAP.pm +++ b/cpan/Test-Simple/lib/Test2/Formatter/TAP.pm @@ -2,7 +2,7 @@ package Test2::Formatter::TAP; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; use Test2::Util qw/clone_io/; diff --git a/cpan/Test-Simple/lib/Test2/Hub.pm b/cpan/Test-Simple/lib/Test2/Hub.pm index 8b8f1a9de38a..207099b25028 100644 --- a/cpan/Test-Simple/lib/Test2/Hub.pm +++ b/cpan/Test-Simple/lib/Test2/Hub.pm @@ -2,7 +2,7 @@ package Test2::Hub; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; use Carp qw/carp croak confess/; diff --git a/cpan/Test-Simple/lib/Test2/Hub/Interceptor.pm b/cpan/Test-Simple/lib/Test2/Hub/Interceptor.pm index f8c03af571d5..13930c55bd47 100644 --- a/cpan/Test-Simple/lib/Test2/Hub/Interceptor.pm +++ b/cpan/Test-Simple/lib/Test2/Hub/Interceptor.pm @@ -2,7 +2,7 @@ package Test2::Hub::Interceptor; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; use Test2::Hub::Interceptor::Terminator(); diff --git a/cpan/Test-Simple/lib/Test2/Hub/Interceptor/Terminator.pm b/cpan/Test-Simple/lib/Test2/Hub/Interceptor/Terminator.pm index a360c34ffa79..b37f505745bf 100644 --- a/cpan/Test-Simple/lib/Test2/Hub/Interceptor/Terminator.pm +++ b/cpan/Test-Simple/lib/Test2/Hub/Interceptor/Terminator.pm @@ -2,7 +2,7 @@ package Test2::Hub::Interceptor::Terminator; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; 1; diff --git a/cpan/Test-Simple/lib/Test2/Hub/Subtest.pm b/cpan/Test-Simple/lib/Test2/Hub/Subtest.pm index e2aaa8788f1d..7c75eed0a878 100644 --- a/cpan/Test-Simple/lib/Test2/Hub/Subtest.pm +++ b/cpan/Test-Simple/lib/Test2/Hub/Subtest.pm @@ -2,7 +2,7 @@ package Test2::Hub::Subtest; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) } use Test2::Util::HashBase qw/nested exit_code manual_skip_all/; diff --git a/cpan/Test-Simple/lib/Test2/IPC.pm b/cpan/Test-Simple/lib/Test2/IPC.pm index 20c316306933..1f6478b6add0 100644 --- a/cpan/Test-Simple/lib/Test2/IPC.pm +++ b/cpan/Test-Simple/lib/Test2/IPC.pm @@ -2,7 +2,7 @@ package Test2::IPC; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; use Test2::API::Instance; diff --git a/cpan/Test-Simple/lib/Test2/IPC/Driver.pm b/cpan/Test-Simple/lib/Test2/IPC/Driver.pm index 19d24100871d..35978070e201 100644 --- a/cpan/Test-Simple/lib/Test2/IPC/Driver.pm +++ b/cpan/Test-Simple/lib/Test2/IPC/Driver.pm @@ -2,7 +2,7 @@ package Test2::IPC::Driver; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; use Carp qw/confess/; diff --git a/cpan/Test-Simple/lib/Test2/IPC/Driver/Files.pm b/cpan/Test-Simple/lib/Test2/IPC/Driver/Files.pm index de1c3f230ebd..a443c9193a1e 100644 --- a/cpan/Test-Simple/lib/Test2/IPC/Driver/Files.pm +++ b/cpan/Test-Simple/lib/Test2/IPC/Driver/Files.pm @@ -2,7 +2,7 @@ package Test2::IPC::Driver::Files; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; BEGIN { require Test2::IPC::Driver; our @ISA = qw(Test2::IPC::Driver) } diff --git a/cpan/Test-Simple/lib/Test2/Tools/Tiny.pm b/cpan/Test-Simple/lib/Test2/Tools/Tiny.pm index 1c7fef6c3bba..c9c5bb3215c2 100644 --- a/cpan/Test-Simple/lib/Test2/Tools/Tiny.pm +++ b/cpan/Test-Simple/lib/Test2/Tools/Tiny.pm @@ -16,7 +16,7 @@ use Test2::API qw/context run_subtest test2_stack/; use Test2::Hub::Interceptor(); use Test2::Hub::Interceptor::Terminator(); -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; BEGIN { require Exporter; our @ISA = qw(Exporter) } our @EXPORT = qw{ diff --git a/cpan/Test-Simple/lib/Test2/Util.pm b/cpan/Test-Simple/lib/Test2/Util.pm index 5f683894f067..b78f80a9040d 100644 --- a/cpan/Test-Simple/lib/Test2/Util.pm +++ b/cpan/Test-Simple/lib/Test2/Util.pm @@ -2,7 +2,7 @@ package Test2::Util; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; use POSIX(); use Config qw/%Config/; diff --git a/cpan/Test-Simple/lib/Test2/Util/ExternalMeta.pm b/cpan/Test-Simple/lib/Test2/Util/ExternalMeta.pm index 8504d3016c35..cfa0a5699b8d 100644 --- a/cpan/Test-Simple/lib/Test2/Util/ExternalMeta.pm +++ b/cpan/Test-Simple/lib/Test2/Util/ExternalMeta.pm @@ -2,7 +2,7 @@ package Test2::Util::ExternalMeta; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; use Carp qw/croak/; diff --git a/cpan/Test-Simple/lib/Test2/Util/Facets2Legacy.pm b/cpan/Test-Simple/lib/Test2/Util/Facets2Legacy.pm index 35fcace671f8..0e0ed65dbbcb 100644 --- a/cpan/Test-Simple/lib/Test2/Util/Facets2Legacy.pm +++ b/cpan/Test-Simple/lib/Test2/Util/Facets2Legacy.pm @@ -2,7 +2,7 @@ package Test2::Util::Facets2Legacy; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; use Carp qw/croak confess/; use Scalar::Util qw/blessed/; diff --git a/cpan/Test-Simple/lib/Test2/Util/HashBase.pm b/cpan/Test-Simple/lib/Test2/Util/HashBase.pm index 94a6725ff6a4..da1bf916a85b 100644 --- a/cpan/Test-Simple/lib/Test2/Util/HashBase.pm +++ b/cpan/Test-Simple/lib/Test2/Util/HashBase.pm @@ -2,7 +2,7 @@ package Test2::Util::HashBase; use strict; use warnings; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; ################################################################# # # diff --git a/cpan/Test-Simple/lib/Test2/Util/Trace.pm b/cpan/Test-Simple/lib/Test2/Util/Trace.pm index b1b4e529b8c0..b374064cbe48 100644 --- a/cpan/Test-Simple/lib/Test2/Util/Trace.pm +++ b/cpan/Test-Simple/lib/Test2/Util/Trace.pm @@ -6,7 +6,7 @@ use strict; our @ISA = ('Test2::EventFacet::Trace'); -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; 1; diff --git a/cpan/Test-Simple/lib/ok.pm b/cpan/Test-Simple/lib/ok.pm index a8813433beaa..880e4371bb58 100644 --- a/cpan/Test-Simple/lib/ok.pm +++ b/cpan/Test-Simple/lib/ok.pm @@ -1,5 +1,5 @@ package ok; -our $VERSION = '1.302182'; +our $VERSION = '1.302183'; use strict; use Test::More (); diff --git a/cpan/Test-Simple/t/Legacy/Regression/is_capture.t b/cpan/Test-Simple/t/Legacy/Regression/is_capture.t new file mode 100644 index 000000000000..1b8c73e10c45 --- /dev/null +++ b/cpan/Test-Simple/t/Legacy/Regression/is_capture.t @@ -0,0 +1,20 @@ +use strict; +use warnings; +use Test2::Tools::Tiny; + +# this test is only relevant under Devel::Cover + +require Test::More; + +my $destroy = 0; +sub CountDestroy::DESTROY { $destroy++ } + +my $obj = bless {}, 'CountDestroy'; + +Test::More::is($obj, $obj, 'compare object to itself using is'); + +undef $obj; + +is $destroy, 1, 'undef object destroyed after being passed to is'; + +done_testing; diff --git a/cpan/Text-Balanced/lib/Text/Balanced.pm b/cpan/Text-Balanced/lib/Text/Balanced.pm index f1a5780a0b9e..324a023f3855 100644 --- a/cpan/Text-Balanced/lib/Text/Balanced.pm +++ b/cpan/Text-Balanced/lib/Text/Balanced.pm @@ -1,35 +1,44 @@ +# Copyright (C) 1997-2001 Damian Conway. All rights reserved. +# Copyright (C) 2009 Adam Kennedy. +# Copyright (C) 2015 Steve Hay. All rights reserved. + +# This module is free software; you can redistribute it and/or modify it under +# the same terms as Perl itself, i.e. under the terms of either the GNU General +# Public License or the Artistic License, as specified in the F file. + package Text::Balanced; # EXTRACT VARIOUSLY DELIMITED TEXT SEQUENCES FROM STRINGS. # FOR FULL DOCUMENTATION SEE Balanced.pod -use 5.005; +use 5.008001; use strict; use Exporter (); -use SelfLoader; use vars qw { $VERSION @ISA %EXPORT_TAGS }; BEGIN { - $VERSION = '2.03'; - @ISA = 'Exporter'; - %EXPORT_TAGS = ( - ALL => [ qw{ - &extract_delimited - &extract_bracketed - &extract_quotelike - &extract_codeblock - &extract_variable - &extract_tagged - &extract_multiple - &gen_delimited_pat - &gen_extract_tagged - &delimited_pat - } ], - ); + $VERSION = '2.04'; + @ISA = 'Exporter'; + %EXPORT_TAGS = ( + ALL => [ qw{ + &extract_delimited + &extract_bracketed + &extract_quotelike + &extract_codeblock + &extract_variable + &extract_tagged + &extract_multiple + &gen_delimited_pat + &gen_extract_tagged + &delimited_pat + } ], + ); } Exporter::export_ok_tags('ALL'); +## no critic (Subroutines::ProhibitSubroutinePrototypes) + # PROTOTYPES sub _match_bracketed($$$$$$); @@ -40,80 +49,80 @@ sub _match_quotelike($$$$); # HANDLE RETURN VALUES IN VARIOUS CONTEXTS sub _failmsg { - my ($message, $pos) = @_; - $@ = bless { - error => $message, - pos => $pos, - }, 'Text::Balanced::ErrorMsg'; + my ($message, $pos) = @_; + $@ = bless { + error => $message, + pos => $pos, + }, 'Text::Balanced::ErrorMsg'; } sub _fail { - my ($wantarray, $textref, $message, $pos) = @_; - _failmsg $message, $pos if $message; - return (undef, $$textref, undef) if $wantarray; - return undef; + my ($wantarray, $textref, $message, $pos) = @_; + _failmsg $message, $pos if $message; + return (undef, $$textref, undef) if $wantarray; + return; } sub _succeed { - $@ = undef; - my ($wantarray,$textref) = splice @_, 0, 2; - my ($extrapos, $extralen) = @_ > 18 - ? splice(@_, -2, 2) - : (0, 0); - my ($startlen, $oppos) = @_[5,6]; - my $remainderpos = $_[2]; - if ( $wantarray ) { - my @res; - while (my ($from, $len) = splice @_, 0, 2) { - push @res, substr($$textref, $from, $len); - } - if ( $extralen ) { # CORRECT FILLET - my $extra = substr($res[0], $extrapos-$oppos, $extralen, "\n"); - $res[1] = "$extra$res[1]"; - eval { substr($$textref,$remainderpos,0) = $extra; - substr($$textref,$extrapos,$extralen,"\n")} ; - #REARRANGE HERE DOC AND FILLET IF POSSIBLE - pos($$textref) = $remainderpos-$extralen+1; # RESET \G - } else { - pos($$textref) = $remainderpos; # RESET \G - } - return @res; - } else { - my $match = substr($$textref,$_[0],$_[1]); - substr($match,$extrapos-$_[0]-$startlen,$extralen,"") if $extralen; - my $extra = $extralen - ? substr($$textref, $extrapos, $extralen)."\n" : ""; - eval {substr($$textref,$_[4],$_[1]+$_[5])=$extra} ; #CHOP OUT PREFIX & MATCH, IF POSSIBLE - pos($$textref) = $_[4]; # RESET \G - return $match; - } + $@ = undef; + my ($wantarray,$textref) = splice @_, 0, 2; + my ($extrapos, $extralen) = @_ > 18 + ? splice(@_, -2, 2) + : (0, 0); + my ($startlen, $oppos) = @_[5,6]; + my $remainderpos = $_[2]; + if ( $wantarray ) { + my @res; + while (my ($from, $len) = splice @_, 0, 2) { + push @res, substr($$textref, $from, $len); + } + if ( $extralen ) { # CORRECT FILLET + my $extra = substr($res[0], $extrapos-$oppos, $extralen, "\n"); + $res[1] = "$extra$res[1]"; + eval { substr($$textref,$remainderpos,0) = $extra; + substr($$textref,$extrapos,$extralen,"\n")} ; + #REARRANGE HERE DOC AND FILLET IF POSSIBLE + pos($$textref) = $remainderpos-$extralen+1; # RESET \G + } else { + pos($$textref) = $remainderpos; # RESET \G + } + return @res; + } else { + my $match = substr($$textref,$_[0],$_[1]); + substr($match,$extrapos-$_[0]-$startlen,$extralen,"") if $extralen; + my $extra = $extralen + ? substr($$textref, $extrapos, $extralen)."\n" : ""; + eval {substr($$textref,$_[4],$_[1]+$_[5])=$extra} ; #CHOP OUT PREFIX & MATCH, IF POSSIBLE + pos($$textref) = $_[4]; # RESET \G + return $match; + } } # BUILD A PATTERN MATCHING A SIMPLE DELIMITED STRING sub gen_delimited_pat($;$) # ($delimiters;$escapes) { - my ($dels, $escs) = @_; - return "" unless $dels =~ /\S/; - $escs = '\\' unless $escs; - $escs .= substr($escs,-1) x (length($dels)-length($escs)); - my @pat = (); - my $i; - for ($i=0; $i\0-\377/[[(({{</) - { - return _fail $wantarray, $textref, - "Did not find a suitable bracket in delimiter: \"$_[1]\"", - 0; - } - my $posbug = pos; - $ldel = join('|', map { quotemeta $_ } split('', $ldel)); - $rdel = join('|', map { quotemeta $_ } split('', $rdel)); - pos = $posbug; - - my $startpos = pos $$textref || 0; - my @match = _match_bracketed($textref,$pre, $ldel, $qdel, $quotelike, $rdel); - - return _fail ($wantarray, $textref) unless @match; - - return _succeed ( $wantarray, $textref, - $match[2], $match[5]+2, # MATCH - @match[8,9], # REMAINDER - @match[0,1], # PREFIX - ); + my $textref = defined $_[0] ? \$_[0] : \$_; + my $ldel = defined $_[1] ? $_[1] : '{([<'; + my $pre = defined $_[2] ? $_[2] : '\s*'; + my $wantarray = wantarray; + my $qdel = ""; + my $quotelike; + $ldel =~ s/'//g and $qdel .= q{'}; + $ldel =~ s/"//g and $qdel .= q{"}; + $ldel =~ s/`//g and $qdel .= q{`}; + $ldel =~ s/q//g and $quotelike = 1; + $ldel =~ tr/[](){}<>\0-\377/[[(({{</) + { + return _fail $wantarray, $textref, + "Did not find a suitable bracket in delimiter: \"$_[1]\"", + 0; + } + my $posbug = pos; + $ldel = join('|', map { quotemeta $_ } split('', $ldel)); + $rdel = join('|', map { quotemeta $_ } split('', $rdel)); + pos = $posbug; + + my $startpos = pos $$textref || 0; + my @match = _match_bracketed($textref,$pre, $ldel, $qdel, $quotelike, $rdel); + + return _fail ($wantarray, $textref) unless @match; + + return _succeed ( $wantarray, $textref, + $match[2], $match[5]+2, # MATCH + @match[8,9], # REMAINDER + @match[0,1], # PREFIX + ); } -sub _match_bracketed($$$$$$) # $textref, $pre, $ldel, $qdel, $quotelike, $rdel +sub _match_bracketed($$$$$$) # $textref, $pre, $ldel, $qdel, $quotelike, $rdel { - my ($textref, $pre, $ldel, $qdel, $quotelike, $rdel) = @_; - my ($startpos, $ldelpos, $endpos) = (pos $$textref = pos $$textref||0); - unless ($$textref =~ m/\G$pre/gc) - { - _failmsg "Did not find prefix: /$pre/", $startpos; - return; - } - - $ldelpos = pos $$textref; - - unless ($$textref =~ m/\G($ldel)/gc) - { - _failmsg "Did not find opening bracket after prefix: \"$pre\"", - pos $$textref; - pos $$textref = $startpos; - return; - } - - my @nesting = ( $1 ); - my $textlen = length $$textref; - while (pos $$textref < $textlen) - { - next if $$textref =~ m/\G\\./gcs; - - if ($$textref =~ m/\G($ldel)/gc) - { - push @nesting, $1; - } - elsif ($$textref =~ m/\G($rdel)/gc) - { - my ($found, $brackettype) = ($1, $1); - if ($#nesting < 0) - { - _failmsg "Unmatched closing bracket: \"$found\"", - pos $$textref; - pos $$textref = $startpos; - return; - } - my $expected = pop(@nesting); - $expected =~ tr/({[/; - if ($expected ne $brackettype) - { - _failmsg qq{Mismatched closing bracket: expected "$expected" but found "$found"}, - pos $$textref; - pos $$textref = $startpos; - return; - } - last if $#nesting < 0; - } - elsif ($qdel && $$textref =~ m/\G([$qdel])/gc) - { - $$textref =~ m/\G[^\\$1]*(?:\\.[^\\$1]*)*(\Q$1\E)/gsc and next; - _failmsg "Unmatched embedded quote ($1)", - pos $$textref; - pos $$textref = $startpos; - return; - } - elsif ($quotelike && _match_quotelike($textref,"",1,0)) - { - next; - } - - else { $$textref =~ m/\G(?:[a-zA-Z0-9]+|.)/gcs } - } - if ($#nesting>=0) - { - _failmsg "Unmatched opening bracket(s): " - . join("..",@nesting)."..", - pos $$textref; - pos $$textref = $startpos; - return; - } - - $endpos = pos $$textref; - - return ( - $startpos, $ldelpos-$startpos, # PREFIX - $ldelpos, 1, # OPENING BRACKET - $ldelpos+1, $endpos-$ldelpos-2, # CONTENTS - $endpos-1, 1, # CLOSING BRACKET - $endpos, length($$textref)-$endpos, # REMAINDER - ); + my ($textref, $pre, $ldel, $qdel, $quotelike, $rdel) = @_; + my ($startpos, $ldelpos, $endpos) = (pos $$textref = pos $$textref||0); + unless ($$textref =~ m/\G$pre/gc) + { + _failmsg "Did not find prefix: /$pre/", $startpos; + return; + } + + $ldelpos = pos $$textref; + + unless ($$textref =~ m/\G($ldel)/gc) + { + _failmsg "Did not find opening bracket after prefix: \"$pre\"", + pos $$textref; + pos $$textref = $startpos; + return; + } + + my @nesting = ( $1 ); + my $textlen = length $$textref; + while (pos $$textref < $textlen) + { + next if $$textref =~ m/\G\\./gcs; + + if ($$textref =~ m/\G($ldel)/gc) + { + push @nesting, $1; + } + elsif ($$textref =~ m/\G($rdel)/gc) + { + my ($found, $brackettype) = ($1, $1); + if ($#nesting < 0) + { + _failmsg "Unmatched closing bracket: \"$found\"", + pos $$textref; + pos $$textref = $startpos; + return; + } + my $expected = pop(@nesting); + $expected =~ tr/({[/; + if ($expected ne $brackettype) + { + _failmsg qq{Mismatched closing bracket: expected "$expected" but found "$found"}, + pos $$textref; + pos $$textref = $startpos; + return; + } + last if $#nesting < 0; + } + elsif ($qdel && $$textref =~ m/\G([$qdel])/gc) + { + $$textref =~ m/\G[^\\$1]*(?:\\.[^\\$1]*)*(\Q$1\E)/gsc and next; + _failmsg "Unmatched embedded quote ($1)", + pos $$textref; + pos $$textref = $startpos; + return; + } + elsif ($quotelike && _match_quotelike($textref,"",1,0)) + { + next; + } + + else { $$textref =~ m/\G(?:[a-zA-Z0-9]+|.)/gcs } + } + if ($#nesting>=0) + { + _failmsg "Unmatched opening bracket(s): " + . join("..",@nesting)."..", + pos $$textref; + pos $$textref = $startpos; + return; + } + + $endpos = pos $$textref; + + return ( + $startpos, $ldelpos-$startpos, # PREFIX + $ldelpos, 1, # OPENING BRACKET + $ldelpos+1, $endpos-$ldelpos-2, # CONTENTS + $endpos-1, 1, # CLOSING BRACKET + $endpos, length($$textref)-$endpos, # REMAINDER + ); } sub _revbracket($) { - my $brack = reverse $_[0]; - $brack =~ tr/[({/; - return $brack; + my $brack = reverse $_[0]; + $brack =~ tr/[({/; + return $brack; } my $XMLNAME = q{[a-zA-Z_:][a-zA-Z0-9_:.-]*}; sub extract_tagged (;$$$$$) # ($text, $opentag, $closetag, $pre, \%options) { - my $textref = defined $_[0] ? \$_[0] : \$_; - my $ldel = $_[1]; - my $rdel = $_[2]; - my $pre = defined $_[3] ? $_[3] : '\s*'; - my %options = defined $_[4] ? %{$_[4]} : (); - my $omode = defined $options{fail} ? $options{fail} : ''; - my $bad = ref($options{reject}) eq 'ARRAY' ? join('|', @{$options{reject}}) - : defined($options{reject}) ? $options{reject} - : '' - ; - my $ignore = ref($options{ignore}) eq 'ARRAY' ? join('|', @{$options{ignore}}) - : defined($options{ignore}) ? $options{ignore} - : '' - ; - - if (!defined $ldel) { $ldel = '<\w+(?:' . gen_delimited_pat(q{'"}) . '|[^>])*>'; } - $@ = undef; - - my @match = _match_tagged($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore); - - return _fail(wantarray, $textref) unless @match; - return _succeed wantarray, $textref, - $match[2], $match[3]+$match[5]+$match[7], # MATCH - @match[8..9,0..1,2..7]; # REM, PRE, BITS + my $textref = defined $_[0] ? \$_[0] : \$_; + my $ldel = $_[1]; + my $rdel = $_[2]; + my $pre = defined $_[3] ? $_[3] : '\s*'; + my %options = defined $_[4] ? %{$_[4]} : (); + my $omode = defined $options{fail} ? $options{fail} : ''; + my $bad = ref($options{reject}) eq 'ARRAY' ? join('|', @{$options{reject}}) + : defined($options{reject}) ? $options{reject} + : '' + ; + my $ignore = ref($options{ignore}) eq 'ARRAY' ? join('|', @{$options{ignore}}) + : defined($options{ignore}) ? $options{ignore} + : '' + ; + + if (!defined $ldel) { $ldel = '<\w+(?:' . gen_delimited_pat(q{'"}) . '|[^>])*>'; } + $@ = undef; + + my @match = _match_tagged($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore); + + return _fail(wantarray, $textref) unless @match; + return _succeed wantarray, $textref, + $match[2], $match[3]+$match[5]+$match[7], # MATCH + @match[8..9,0..1,2..7]; # REM, PRE, BITS } -sub _match_tagged # ($$$$$$$) +sub _match_tagged # ($$$$$$$) { - my ($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore) = @_; - my $rdelspec; - - my ($startpos, $opentagpos, $textpos, $parapos, $closetagpos, $endpos) = ( pos($$textref) = pos($$textref)||0 ); - - unless ($$textref =~ m/\G($pre)/gc) - { - _failmsg "Did not find prefix: /$pre/", pos $$textref; - goto failed; - } - - $opentagpos = pos($$textref); - - unless ($$textref =~ m/\G$ldel/gc) - { - _failmsg "Did not find opening tag: /$ldel/", pos $$textref; - goto failed; - } - - $textpos = pos($$textref); - - if (!defined $rdel) - { - $rdelspec = substr($$textref, $-[0], $+[0] - $-[0]); - unless ($rdelspec =~ s/\A([[(<{]+)($XMLNAME).*/ quotemeta "$1\/$2". _revbracket($1) /oes) - { - _failmsg "Unable to construct closing tag to match: $rdel", - pos $$textref; - goto failed; - } - } - else - { - $rdelspec = eval "qq{$rdel}" || do { - my $del; - for (qw,~ ! ^ & * ) _ + - = } ] : " ; ' > . ? / | ',) - { next if $rdel =~ /\Q$_/; $del = $_; last } - unless ($del) { - use Carp; - croak "Can't interpolate right delimiter $rdel" - } - eval "qq$del$rdel$del"; - }; - } - - while (pos($$textref) < length($$textref)) - { - next if $$textref =~ m/\G\\./gc; - - if ($$textref =~ m/\G(\n[ \t]*\n)/gc ) - { - $parapos = pos($$textref) - length($1) - unless defined $parapos; - } - elsif ($$textref =~ m/\G($rdelspec)/gc ) - { - $closetagpos = pos($$textref)-length($1); - goto matched; - } - elsif ($ignore && $$textref =~ m/\G(?:$ignore)/gc) - { - next; - } - elsif ($bad && $$textref =~ m/\G($bad)/gcs) - { - pos($$textref) -= length($1); # CUT OFF WHATEVER CAUSED THE SHORTNESS - goto short if ($omode eq 'PARA' || $omode eq 'MAX'); - _failmsg "Found invalid nested tag: $1", pos $$textref; - goto failed; - } - elsif ($$textref =~ m/\G($ldel)/gc) - { - my $tag = $1; - pos($$textref) -= length($tag); # REWIND TO NESTED TAG - unless (_match_tagged(@_)) # MATCH NESTED TAG - { - goto short if $omode eq 'PARA' || $omode eq 'MAX'; - _failmsg "Found unbalanced nested tag: $tag", - pos $$textref; - goto failed; - } - } - else { $$textref =~ m/./gcs } - } + my ($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore) = @_; + my $rdelspec; + + my ($startpos, $opentagpos, $textpos, $parapos, $closetagpos, $endpos) = ( pos($$textref) = pos($$textref)||0 ); + + unless ($$textref =~ m/\G($pre)/gc) + { + _failmsg "Did not find prefix: /$pre/", pos $$textref; + goto failed; + } + + $opentagpos = pos($$textref); + + unless ($$textref =~ m/\G$ldel/gc) + { + _failmsg "Did not find opening tag: /$ldel/", pos $$textref; + goto failed; + } + + $textpos = pos($$textref); + + if (!defined $rdel) + { + $rdelspec = substr($$textref, $-[0], $+[0] - $-[0]); + unless ($rdelspec =~ s/\A([[(<{]+)($XMLNAME).*/ quotemeta "$1\/$2". _revbracket($1) /oes) + { + _failmsg "Unable to construct closing tag to match: $rdel", + pos $$textref; + goto failed; + } + } + else + { + ## no critic (BuiltinFunctions::ProhibitStringyEval) + $rdelspec = eval "qq{$rdel}" || do { + my $del; + for (qw,~ ! ^ & * ) _ + - = } ] : " ; ' > . ? / | ',) + { next if $rdel =~ /\Q$_/; $del = $_; last } + unless ($del) { + use Carp; + croak "Can't interpolate right delimiter $rdel" + } + eval "qq$del$rdel$del"; + }; + } + + while (pos($$textref) < length($$textref)) + { + next if $$textref =~ m/\G\\./gc; + + if ($$textref =~ m/\G(\n[ \t]*\n)/gc ) + { + $parapos = pos($$textref) - length($1) + unless defined $parapos; + } + elsif ($$textref =~ m/\G($rdelspec)/gc ) + { + $closetagpos = pos($$textref)-length($1); + goto matched; + } + elsif ($ignore && $$textref =~ m/\G(?:$ignore)/gc) + { + next; + } + elsif ($bad && $$textref =~ m/\G($bad)/gcs) + { + pos($$textref) -= length($1); # CUT OFF WHATEVER CAUSED THE SHORTNESS + goto short if ($omode eq 'PARA' || $omode eq 'MAX'); + _failmsg "Found invalid nested tag: $1", pos $$textref; + goto failed; + } + elsif ($$textref =~ m/\G($ldel)/gc) + { + my $tag = $1; + pos($$textref) -= length($tag); # REWIND TO NESTED TAG + unless (_match_tagged(@_)) # MATCH NESTED TAG + { + goto short if $omode eq 'PARA' || $omode eq 'MAX'; + _failmsg "Found unbalanced nested tag: $tag", + pos $$textref; + goto failed; + } + } + else { $$textref =~ m/./gcs } + } short: - $closetagpos = pos($$textref); - goto matched if $omode eq 'MAX'; - goto failed unless $omode eq 'PARA'; - - if (defined $parapos) { pos($$textref) = $parapos } - else { $parapos = pos($$textref) } - - return ( - $startpos, $opentagpos-$startpos, # PREFIX - $opentagpos, $textpos-$opentagpos, # OPENING TAG - $textpos, $parapos-$textpos, # TEXT - $parapos, 0, # NO CLOSING TAG - $parapos, length($$textref)-$parapos, # REMAINDER - ); - + $closetagpos = pos($$textref); + goto matched if $omode eq 'MAX'; + goto failed unless $omode eq 'PARA'; + + if (defined $parapos) { pos($$textref) = $parapos } + else { $parapos = pos($$textref) } + + return ( + $startpos, $opentagpos-$startpos, # PREFIX + $opentagpos, $textpos-$opentagpos, # OPENING TAG + $textpos, $parapos-$textpos, # TEXT + $parapos, 0, # NO CLOSING TAG + $parapos, length($$textref)-$parapos, # REMAINDER + ); + matched: - $endpos = pos($$textref); - return ( - $startpos, $opentagpos-$startpos, # PREFIX - $opentagpos, $textpos-$opentagpos, # OPENING TAG - $textpos, $closetagpos-$textpos, # TEXT - $closetagpos, $endpos-$closetagpos, # CLOSING TAG - $endpos, length($$textref)-$endpos, # REMAINDER - ); + $endpos = pos($$textref); + return ( + $startpos, $opentagpos-$startpos, # PREFIX + $opentagpos, $textpos-$opentagpos, # OPENING TAG + $textpos, $closetagpos-$textpos, # TEXT + $closetagpos, $endpos-$closetagpos, # CLOSING TAG + $endpos, length($$textref)-$endpos, # REMAINDER + ); failed: - _failmsg "Did not find closing tag", pos $$textref unless $@; - pos($$textref) = $startpos; - return; + _failmsg "Did not find closing tag", pos $$textref unless $@; + pos($$textref) = $startpos; + return; } sub extract_variable (;$$) { - my $textref = defined $_[0] ? \$_[0] : \$_; - return ("","","") unless defined $$textref; - my $pre = defined $_[1] ? $_[1] : '\s*'; + my $textref = defined $_[0] ? \$_[0] : \$_; + return ("","","") unless defined $$textref; + my $pre = defined $_[1] ? $_[1] : '\s*'; - my @match = _match_variable($textref,$pre); + my @match = _match_variable($textref,$pre); - return _fail wantarray, $textref unless @match; + return _fail wantarray, $textref unless @match; - return _succeed wantarray, $textref, - @match[2..3,4..5,0..1]; # MATCH, REMAINDER, PREFIX + return _succeed wantarray, $textref, + @match[2..3,4..5,0..1]; # MATCH, REMAINDER, PREFIX } sub _match_variable($$) @@ -438,582 +448,581 @@ sub _match_variable($$) # $# # $^ # $$ - my ($textref, $pre) = @_; - my $startpos = pos($$textref) = pos($$textref)||0; - unless ($$textref =~ m/\G($pre)/gc) - { - _failmsg "Did not find prefix: /$pre/", pos $$textref; - return; - } - my $varpos = pos($$textref); - unless ($$textref =~ m{\G\$\s*(?!::)(\d+|[][&`'+*./|,";%=~:?!\@<>()-]|\^[a-z]?)}gci) - { - unless ($$textref =~ m/\G((\$#?|[*\@\%]|\\&)+)/gc) - { - _failmsg "Did not find leading dereferencer", pos $$textref; - pos $$textref = $startpos; - return; - } - my $deref = $1; - - unless ($$textref =~ m/\G\s*(?:::|')?(?:[_a-z]\w*(?:::|'))*[_a-z]\w*/gci - or _match_codeblock($textref, "", '\{', '\}', '\{', '\}', 0) - or $deref eq '$#' or $deref eq '$$' ) - { - _failmsg "Bad identifier after dereferencer", pos $$textref; - pos $$textref = $startpos; - return; - } - } - - while (1) - { - next if $$textref =~ m/\G\s*(?:->)?\s*[{]\w+[}]/gc; - next if _match_codeblock($textref, - qr/\s*->\s*(?:[_a-zA-Z]\w+\s*)?/, - qr/[({[]/, qr/[)}\]]/, - qr/[({[]/, qr/[)}\]]/, 0); - next if _match_codeblock($textref, - qr/\s*/, qr/[{[]/, qr/[}\]]/, - qr/[{[]/, qr/[}\]]/, 0); - next if _match_variable($textref,'\s*->\s*'); - next if $$textref =~ m/\G\s*->\s*\w+(?![{([])/gc; - last; - } - - my $endpos = pos($$textref); - return ($startpos, $varpos-$startpos, - $varpos, $endpos-$varpos, - $endpos, length($$textref)-$endpos - ); + my ($textref, $pre) = @_; + my $startpos = pos($$textref) = pos($$textref)||0; + unless ($$textref =~ m/\G($pre)/gc) + { + _failmsg "Did not find prefix: /$pre/", pos $$textref; + return; + } + my $varpos = pos($$textref); + unless ($$textref =~ m{\G\$\s*(?!::)(\d+|[][&`'+*./|,";%=~:?!\@<>()-]|\^[a-z]?)}gci) + { + unless ($$textref =~ m/\G((\$#?|[*\@\%]|\\&)+)/gc) + { + _failmsg "Did not find leading dereferencer", pos $$textref; + pos $$textref = $startpos; + return; + } + my $deref = $1; + + unless ($$textref =~ m/\G\s*(?:::|')?(?:[_a-z]\w*(?:::|'))*[_a-z]\w*/gci + or _match_codeblock($textref, "", '\{', '\}', '\{', '\}', 0) + or $deref eq '$#' or $deref eq '$$' ) + { + _failmsg "Bad identifier after dereferencer", pos $$textref; + pos $$textref = $startpos; + return; + } + } + + while (1) + { + next if $$textref =~ m/\G\s*(?:->)?\s*[{]\w+[}]/gc; + next if _match_codeblock($textref, + qr/\s*->\s*(?:[_a-zA-Z]\w+\s*)?/, + qr/[({[]/, qr/[)}\]]/, + qr/[({[]/, qr/[)}\]]/, 0); + next if _match_codeblock($textref, + qr/\s*/, qr/[{[]/, qr/[}\]]/, + qr/[{[]/, qr/[}\]]/, 0); + next if _match_variable($textref,'\s*->\s*'); + next if $$textref =~ m/\G\s*->\s*\w+(?![{([])/gc; + last; + } + + my $endpos = pos($$textref); + return ($startpos, $varpos-$startpos, + $varpos, $endpos-$varpos, + $endpos, length($$textref)-$endpos + ); } sub extract_codeblock (;$$$$$) { - my $textref = defined $_[0] ? \$_[0] : \$_; - my $wantarray = wantarray; - my $ldel_inner = defined $_[1] ? $_[1] : '{'; - my $pre = defined $_[2] ? $_[2] : '\s*'; - my $ldel_outer = defined $_[3] ? $_[3] : $ldel_inner; - my $rd = $_[4]; - my $rdel_inner = $ldel_inner; - my $rdel_outer = $ldel_outer; - my $posbug = pos; - for ($ldel_inner, $ldel_outer) { tr/[]()<>{}\0-\377/[[((<<{{/ds } - for ($rdel_inner, $rdel_outer) { tr/[]()<>{}\0-\377/]]))>>}}/ds } - for ($ldel_inner, $ldel_outer, $rdel_inner, $rdel_outer) - { - $_ = '('.join('|',map { quotemeta $_ } split('',$_)).')' - } - pos = $posbug; - - my @match = _match_codeblock($textref, $pre, - $ldel_outer, $rdel_outer, - $ldel_inner, $rdel_inner, - $rd); - return _fail($wantarray, $textref) unless @match; - return _succeed($wantarray, $textref, - @match[2..3,4..5,0..1] # MATCH, REMAINDER, PREFIX - ); + my $textref = defined $_[0] ? \$_[0] : \$_; + my $wantarray = wantarray; + my $ldel_inner = defined $_[1] ? $_[1] : '{'; + my $pre = defined $_[2] ? $_[2] : '\s*'; + my $ldel_outer = defined $_[3] ? $_[3] : $ldel_inner; + my $rd = $_[4]; + my $rdel_inner = $ldel_inner; + my $rdel_outer = $ldel_outer; + my $posbug = pos; + for ($ldel_inner, $ldel_outer) { tr/[]()<>{}\0-\377/[[((<<{{/ds } + for ($rdel_inner, $rdel_outer) { tr/[]()<>{}\0-\377/]]))>>}}/ds } + for ($ldel_inner, $ldel_outer, $rdel_inner, $rdel_outer) + { + $_ = '('.join('|',map { quotemeta $_ } split('',$_)).')' + } + pos = $posbug; + + my @match = _match_codeblock($textref, $pre, + $ldel_outer, $rdel_outer, + $ldel_inner, $rdel_inner, + $rd); + return _fail($wantarray, $textref) unless @match; + return _succeed($wantarray, $textref, + @match[2..3,4..5,0..1] # MATCH, REMAINDER, PREFIX + ); } sub _match_codeblock($$$$$$$) { - my ($textref, $pre, $ldel_outer, $rdel_outer, $ldel_inner, $rdel_inner, $rd) = @_; - my $startpos = pos($$textref) = pos($$textref) || 0; - unless ($$textref =~ m/\G($pre)/gc) - { - _failmsg qq{Did not match prefix /$pre/ at"} . - substr($$textref,pos($$textref),20) . - q{..."}, - pos $$textref; - return; - } - my $codepos = pos($$textref); - unless ($$textref =~ m/\G($ldel_outer)/gc) # OUTERMOST DELIMITER - { - _failmsg qq{Did not find expected opening bracket at "} . - substr($$textref,pos($$textref),20) . - q{..."}, - pos $$textref; - pos $$textref = $startpos; - return; - } - my $closing = $1; - $closing =~ tr/([<{/)]>}/; - my $matched; - my $patvalid = 1; - while (pos($$textref) < length($$textref)) - { - $matched = ''; - if ($rd && $$textref =~ m#\G(\Q(?)\E|\Q(s?)\E|\Q(s)\E)#gc) - { - $patvalid = 0; - next; - } - - if ($$textref =~ m/\G\s*#.*/gc) - { - next; - } - - if ($$textref =~ m/\G\s*($rdel_outer)/gc) - { - unless ($matched = ($closing && $1 eq $closing) ) - { - next if $1 eq '>'; # MIGHT BE A "LESS THAN" - _failmsg q{Mismatched closing bracket at "} . - substr($$textref,pos($$textref),20) . - qq{...". Expected '$closing'}, - pos $$textref; - } - last; - } - - if (_match_variable($textref,'\s*') || - _match_quotelike($textref,'\s*',$patvalid,$patvalid) ) - { - $patvalid = 0; - next; - } - - - # NEED TO COVER MANY MORE CASES HERE!!! - if ($$textref =~ m#\G\s*(?!$ldel_inner) - ( [-+*x/%^&|.]=? - | [!=]~ - | =(?!>) - | (\*\*|&&|\|\||<<|>>)=? - | split|grep|map|return - | [([] - )#gcx) - { - $patvalid = 1; - next; - } - - if ( _match_codeblock($textref, '\s*', $ldel_inner, $rdel_inner, $ldel_inner, $rdel_inner, $rd) ) - { - $patvalid = 1; - next; - } - - if ($$textref =~ m/\G\s*$ldel_outer/gc) - { - _failmsg q{Improperly nested codeblock at "} . - substr($$textref,pos($$textref),20) . - q{..."}, - pos $$textref; - last; - } - - $patvalid = 0; - $$textref =~ m/\G\s*(\w+|[-=>]>|.|\Z)/gc; - } - continue { $@ = undef } - - unless ($matched) - { - _failmsg 'No match found for opening bracket', pos $$textref - unless $@; - return; - } - - my $endpos = pos($$textref); - return ( $startpos, $codepos-$startpos, - $codepos, $endpos-$codepos, - $endpos, length($$textref)-$endpos, - ); + my ($textref, $pre, $ldel_outer, $rdel_outer, $ldel_inner, $rdel_inner, $rd) = @_; + my $startpos = pos($$textref) = pos($$textref) || 0; + unless ($$textref =~ m/\G($pre)/gc) + { + _failmsg qq{Did not match prefix /$pre/ at"} . + substr($$textref,pos($$textref),20) . + q{..."}, + pos $$textref; + return; + } + my $codepos = pos($$textref); + unless ($$textref =~ m/\G($ldel_outer)/gc) # OUTERMOST DELIMITER + { + _failmsg qq{Did not find expected opening bracket at "} . + substr($$textref,pos($$textref),20) . + q{..."}, + pos $$textref; + pos $$textref = $startpos; + return; + } + my $closing = $1; + $closing =~ tr/([<{/)]>}/; + my $matched; + my $patvalid = 1; + while (pos($$textref) < length($$textref)) + { + $matched = ''; + if ($rd && $$textref =~ m#\G(\Q(?)\E|\Q(s?)\E|\Q(s)\E)#gc) + { + $patvalid = 0; + next; + } + + if ($$textref =~ m/\G\s*#.*/gc) + { + next; + } + + if ($$textref =~ m/\G\s*($rdel_outer)/gc) + { + unless ($matched = ($closing && $1 eq $closing) ) + { + next if $1 eq '>'; # MIGHT BE A "LESS THAN" + _failmsg q{Mismatched closing bracket at "} . + substr($$textref,pos($$textref),20) . + qq{...". Expected '$closing'}, + pos $$textref; + } + last; + } + + if (_match_variable($textref,'\s*') || + _match_quotelike($textref,'\s*',$patvalid,$patvalid) ) + { + $patvalid = 0; + next; + } + + + # NEED TO COVER MANY MORE CASES HERE!!! + if ($$textref =~ m#\G\s*(?!$ldel_inner) + ( [-+*x/%^&|.]=? + | [!=]~ + | =(?!>) + | (\*\*|&&|\|\||<<|>>)=? + | split|grep|map|return + | [([] + )#gcx) + { + $patvalid = 1; + next; + } + + if ( _match_codeblock($textref, '\s*', $ldel_inner, $rdel_inner, $ldel_inner, $rdel_inner, $rd) ) + { + $patvalid = 1; + next; + } + + if ($$textref =~ m/\G\s*$ldel_outer/gc) + { + _failmsg q{Improperly nested codeblock at "} . + substr($$textref,pos($$textref),20) . + q{..."}, + pos $$textref; + last; + } + + $patvalid = 0; + $$textref =~ m/\G\s*(\w+|[-=>]>|.|\Z)/gc; + } + continue { $@ = undef } + + unless ($matched) + { + _failmsg 'No match found for opening bracket', pos $$textref + unless $@; + return; + } + + my $endpos = pos($$textref); + return ( $startpos, $codepos-$startpos, + $codepos, $endpos-$codepos, + $endpos, length($$textref)-$endpos, + ); } my %mods = ( - 'none' => '[cgimsox]*', - 'm' => '[cgimsox]*', - 's' => '[cegimsox]*', - 'tr' => '[cds]*', - 'y' => '[cds]*', - 'qq' => '', - 'qx' => '', - 'qw' => '', - 'qr' => '[imsx]*', - 'q' => '', - ); + 'none' => '[cgimsox]*', + 'm' => '[cgimsox]*', + 's' => '[cegimsox]*', + 'tr' => '[cds]*', + 'y' => '[cds]*', + 'qq' => '', + 'qx' => '', + 'qw' => '', + 'qr' => '[imsx]*', + 'q' => '', +); sub extract_quotelike (;$$) { - my $textref = $_[0] ? \$_[0] : \$_; - my $wantarray = wantarray; - my $pre = defined $_[1] ? $_[1] : '\s*'; - - my @match = _match_quotelike($textref,$pre,1,0); - return _fail($wantarray, $textref) unless @match; - return _succeed($wantarray, $textref, - $match[2], $match[18]-$match[2], # MATCH - @match[18,19], # REMAINDER - @match[0,1], # PREFIX - @match[2..17], # THE BITS - @match[20,21], # ANY FILLET? - ); + my $textref = $_[0] ? \$_[0] : \$_; + my $wantarray = wantarray; + my $pre = defined $_[1] ? $_[1] : '\s*'; + + my @match = _match_quotelike($textref,$pre,1,0); + return _fail($wantarray, $textref) unless @match; + return _succeed($wantarray, $textref, + $match[2], $match[18]-$match[2], # MATCH + @match[18,19], # REMAINDER + @match[0,1], # PREFIX + @match[2..17], # THE BITS + @match[20,21], # ANY FILLET? + ); }; -sub _match_quotelike($$$$) # ($textref, $prepat, $allow_raw_match) +sub _match_quotelike($$$$) # ($textref, $prepat, $allow_raw_match) { - my ($textref, $pre, $rawmatch, $qmark) = @_; - - my ($textlen,$startpos, - $oppos, - $preld1pos,$ld1pos,$str1pos,$rd1pos, - $preld2pos,$ld2pos,$str2pos,$rd2pos, - $modpos) = ( length($$textref), pos($$textref) = pos($$textref) || 0 ); - - unless ($$textref =~ m/\G($pre)/gc) - { - _failmsg qq{Did not find prefix /$pre/ at "} . - substr($$textref, pos($$textref), 20) . - q{..."}, - pos $$textref; - return; - } - $oppos = pos($$textref); - - my $initial = substr($$textref,$oppos,1); - - if ($initial && $initial =~ m|^[\"\'\`]| - || $rawmatch && $initial =~ m|^/| - || $qmark && $initial =~ m|^\?|) - { - unless ($$textref =~ m/ \Q$initial\E [^\\$initial]* (\\.[^\\$initial]*)* \Q$initial\E /gcsx) - { - _failmsg qq{Did not find closing delimiter to match '$initial' at "} . - substr($$textref, $oppos, 20) . - q{..."}, - pos $$textref; - pos $$textref = $startpos; - return; - } - $modpos= pos($$textref); - $rd1pos = $modpos-1; - - if ($initial eq '/' || $initial eq '?') - { - $$textref =~ m/\G$mods{none}/gc - } - - my $endpos = pos($$textref); - return ( - $startpos, $oppos-$startpos, # PREFIX - $oppos, 0, # NO OPERATOR - $oppos, 1, # LEFT DEL - $oppos+1, $rd1pos-$oppos-1, # STR/PAT - $rd1pos, 1, # RIGHT DEL - $modpos, 0, # NO 2ND LDEL - $modpos, 0, # NO 2ND STR - $modpos, 0, # NO 2ND RDEL - $modpos, $endpos-$modpos, # MODIFIERS - $endpos, $textlen-$endpos, # REMAINDER - ); - } - - unless ($$textref =~ m{\G(\b(?:m|s|qq|qx|qw|q|qr|tr|y)\b(?=\s*\S)|<<)}gc) - { - _failmsg q{No quotelike operator found after prefix at "} . - substr($$textref, pos($$textref), 20) . - q{..."}, - pos $$textref; - pos $$textref = $startpos; - return; - } - - my $op = $1; - $preld1pos = pos($$textref); - if ($op eq '<<') { - $ld1pos = pos($$textref); - my $label; - if ($$textref =~ m{\G([A-Za-z_]\w*)}gc) { - $label = $1; - } - elsif ($$textref =~ m{ \G ' ([^'\\]* (?:\\.[^'\\]*)*) ' - | \G " ([^"\\]* (?:\\.[^"\\]*)*) " - | \G ` ([^`\\]* (?:\\.[^`\\]*)*) ` - }gcsx) { - $label = $+; - } - else { - $label = ""; - } - my $extrapos = pos($$textref); - $$textref =~ m{.*\n}gc; - $str1pos = pos($$textref)--; - unless ($$textref =~ m{.*?\n(?=\Q$label\E\n)}gc) { - _failmsg qq{Missing here doc terminator ('$label') after "} . - substr($$textref, $startpos, 20) . - q{..."}, - pos $$textref; - pos $$textref = $startpos; - return; - } - $rd1pos = pos($$textref); + my ($textref, $pre, $rawmatch, $qmark) = @_; + + my ($textlen,$startpos, + $oppos, + $preld1pos,$ld1pos,$str1pos,$rd1pos, + $preld2pos,$ld2pos,$str2pos,$rd2pos, + $modpos) = ( length($$textref), pos($$textref) = pos($$textref) || 0 ); + + unless ($$textref =~ m/\G($pre)/gc) + { + _failmsg qq{Did not find prefix /$pre/ at "} . + substr($$textref, pos($$textref), 20) . + q{..."}, + pos $$textref; + return; + } + $oppos = pos($$textref); + + my $initial = substr($$textref,$oppos,1); + + if ($initial && $initial =~ m|^[\"\'\`]| + || $rawmatch && $initial =~ m|^/| + || $qmark && $initial =~ m|^\?|) + { + unless ($$textref =~ m/ \Q$initial\E [^\\$initial]* (\\.[^\\$initial]*)* \Q$initial\E /gcsx) + { + _failmsg qq{Did not find closing delimiter to match '$initial' at "} . + substr($$textref, $oppos, 20) . + q{..."}, + pos $$textref; + pos $$textref = $startpos; + return; + } + $modpos= pos($$textref); + $rd1pos = $modpos-1; + + if ($initial eq '/' || $initial eq '?') + { + $$textref =~ m/\G$mods{none}/gc + } + + my $endpos = pos($$textref); + return ( + $startpos, $oppos-$startpos, # PREFIX + $oppos, 0, # NO OPERATOR + $oppos, 1, # LEFT DEL + $oppos+1, $rd1pos-$oppos-1, # STR/PAT + $rd1pos, 1, # RIGHT DEL + $modpos, 0, # NO 2ND LDEL + $modpos, 0, # NO 2ND STR + $modpos, 0, # NO 2ND RDEL + $modpos, $endpos-$modpos, # MODIFIERS + $endpos, $textlen-$endpos, # REMAINDER + ); + } + + unless ($$textref =~ m{\G(\b(?:m|s|qq|qx|qw|q|qr|tr|y)\b(?=\s*\S)|<<)}gc) + { + _failmsg q{No quotelike operator found after prefix at "} . + substr($$textref, pos($$textref), 20) . + q{..."}, + pos $$textref; + pos $$textref = $startpos; + return; + } + + my $op = $1; + $preld1pos = pos($$textref); + if ($op eq '<<') { + $ld1pos = pos($$textref); + my $label; + if ($$textref =~ m{\G([A-Za-z_]\w*)}gc) { + $label = $1; + } + elsif ($$textref =~ m{ \G ' ([^'\\]* (?:\\.[^'\\]*)*) ' + | \G " ([^"\\]* (?:\\.[^"\\]*)*) " + | \G ` ([^`\\]* (?:\\.[^`\\]*)*) ` + }gcsx) { + $label = $+; + } + else { + $label = ""; + } + my $extrapos = pos($$textref); + $$textref =~ m{.*\n}gc; + $str1pos = pos($$textref)--; + unless ($$textref =~ m{.*?\n(?=\Q$label\E\n)}gc) { + _failmsg qq{Missing here doc terminator ('$label') after "} . + substr($$textref, $startpos, 20) . + q{..."}, + pos $$textref; + pos $$textref = $startpos; + return; + } + $rd1pos = pos($$textref); $$textref =~ m{\Q$label\E\n}gc; - $ld2pos = pos($$textref); - return ( - $startpos, $oppos-$startpos, # PREFIX - $oppos, length($op), # OPERATOR - $ld1pos, $extrapos-$ld1pos, # LEFT DEL - $str1pos, $rd1pos-$str1pos, # STR/PAT - $rd1pos, $ld2pos-$rd1pos, # RIGHT DEL - $ld2pos, 0, # NO 2ND LDEL - $ld2pos, 0, # NO 2ND STR - $ld2pos, 0, # NO 2ND RDEL - $ld2pos, 0, # NO MODIFIERS - $ld2pos, $textlen-$ld2pos, # REMAINDER - $extrapos, $str1pos-$extrapos, # FILLETED BIT - ); - } - - $$textref =~ m/\G\s*/gc; - $ld1pos = pos($$textref); - $str1pos = $ld1pos+1; - - unless ($$textref =~ m/\G(\S)/gc) # SHOULD USE LOOKAHEAD - { - _failmsg "No block delimiter found after quotelike $op", - pos $$textref; - pos $$textref = $startpos; - return; - } - pos($$textref) = $ld1pos; # HAVE TO DO THIS BECAUSE LOOKAHEAD BROKEN - my ($ldel1, $rdel1) = ("\Q$1","\Q$1"); - if ($ldel1 =~ /[[(<{]/) - { - $rdel1 =~ tr/[({/; - defined(_match_bracketed($textref,"",$ldel1,"","",$rdel1)) - || do { pos $$textref = $startpos; return }; + $ld2pos = pos($$textref); + return ( + $startpos, $oppos-$startpos, # PREFIX + $oppos, length($op), # OPERATOR + $ld1pos, $extrapos-$ld1pos, # LEFT DEL + $str1pos, $rd1pos-$str1pos, # STR/PAT + $rd1pos, $ld2pos-$rd1pos, # RIGHT DEL + $ld2pos, 0, # NO 2ND LDEL + $ld2pos, 0, # NO 2ND STR + $ld2pos, 0, # NO 2ND RDEL + $ld2pos, 0, # NO MODIFIERS + $ld2pos, $textlen-$ld2pos, # REMAINDER + $extrapos, $str1pos-$extrapos, # FILLETED BIT + ); + } + + $$textref =~ m/\G\s*/gc; + $ld1pos = pos($$textref); + $str1pos = $ld1pos+1; + + unless ($$textref =~ m/\G(\S)/gc) # SHOULD USE LOOKAHEAD + { + _failmsg "No block delimiter found after quotelike $op", + pos $$textref; + pos $$textref = $startpos; + return; + } + pos($$textref) = $ld1pos; # HAVE TO DO THIS BECAUSE LOOKAHEAD BROKEN + my ($ldel1, $rdel1) = ("\Q$1","\Q$1"); + if ($ldel1 =~ /[[(<{]/) + { + $rdel1 =~ tr/[({/; + defined(_match_bracketed($textref,"",$ldel1,"","",$rdel1)) + || do { pos $$textref = $startpos; return }; $ld2pos = pos($$textref); $rd1pos = $ld2pos-1; - } - else - { - $$textref =~ /\G$ldel1[^\\$ldel1]*(\\.[^\\$ldel1]*)*$ldel1/gcs - || do { pos $$textref = $startpos; return }; + } + else + { + $$textref =~ /\G$ldel1[^\\$ldel1]*(\\.[^\\$ldel1]*)*$ldel1/gcs + || do { pos $$textref = $startpos; return }; $ld2pos = $rd1pos = pos($$textref)-1; - } - - my $second_arg = $op =~ /s|tr|y/ ? 1 : 0; - if ($second_arg) - { - my ($ldel2, $rdel2); - if ($ldel1 =~ /[[(<{]/) - { - unless ($$textref =~ /\G\s*(\S)/gc) # SHOULD USE LOOKAHEAD - { - _failmsg "Missing second block for quotelike $op", - pos $$textref; - pos $$textref = $startpos; - return; - } - $ldel2 = $rdel2 = "\Q$1"; - $rdel2 =~ tr/[({/; - } - else - { - $ldel2 = $rdel2 = $ldel1; - } - $str2pos = $ld2pos+1; - - if ($ldel2 =~ /[[(<{]/) - { - pos($$textref)--; # OVERCOME BROKEN LOOKAHEAD - defined(_match_bracketed($textref,"",$ldel2,"","",$rdel2)) - || do { pos $$textref = $startpos; return }; - } - else - { - $$textref =~ /[^\\$ldel2]*(\\.[^\\$ldel2]*)*$ldel2/gcs - || do { pos $$textref = $startpos; return }; - } - $rd2pos = pos($$textref)-1; - } - else - { - $ld2pos = $str2pos = $rd2pos = $rd1pos; - } - - $modpos = pos $$textref; - - $$textref =~ m/\G($mods{$op})/gc; - my $endpos = pos $$textref; - - return ( - $startpos, $oppos-$startpos, # PREFIX - $oppos, length($op), # OPERATOR - $ld1pos, 1, # LEFT DEL - $str1pos, $rd1pos-$str1pos, # STR/PAT - $rd1pos, 1, # RIGHT DEL - $ld2pos, $second_arg, # 2ND LDEL (MAYBE) - $str2pos, $rd2pos-$str2pos, # 2ND STR (MAYBE) - $rd2pos, $second_arg, # 2ND RDEL (MAYBE) - $modpos, $endpos-$modpos, # MODIFIERS - $endpos, $textlen-$endpos, # REMAINDER - ); + } + + my $second_arg = $op =~ /s|tr|y/ ? 1 : 0; + if ($second_arg) + { + my ($ldel2, $rdel2); + if ($ldel1 =~ /[[(<{]/) + { + unless ($$textref =~ /\G\s*(\S)/gc) # SHOULD USE LOOKAHEAD + { + _failmsg "Missing second block for quotelike $op", + pos $$textref; + pos $$textref = $startpos; + return; + } + $ldel2 = $rdel2 = "\Q$1"; + $rdel2 =~ tr/[({/; + } + else + { + $ldel2 = $rdel2 = $ldel1; + } + $str2pos = $ld2pos+1; + + if ($ldel2 =~ /[[(<{]/) + { + pos($$textref)--; # OVERCOME BROKEN LOOKAHEAD + defined(_match_bracketed($textref,"",$ldel2,"","",$rdel2)) + || do { pos $$textref = $startpos; return }; + } + else + { + $$textref =~ /[^\\$ldel2]*(\\.[^\\$ldel2]*)*$ldel2/gcs + || do { pos $$textref = $startpos; return }; + } + $rd2pos = pos($$textref)-1; + } + else + { + $ld2pos = $str2pos = $rd2pos = $rd1pos; + } + + $modpos = pos $$textref; + + $$textref =~ m/\G($mods{$op})/gc; + my $endpos = pos $$textref; + + return ( + $startpos, $oppos-$startpos, # PREFIX + $oppos, length($op), # OPERATOR + $ld1pos, 1, # LEFT DEL + $str1pos, $rd1pos-$str1pos, # STR/PAT + $rd1pos, 1, # RIGHT DEL + $ld2pos, $second_arg, # 2ND LDEL (MAYBE) + $str2pos, $rd2pos-$str2pos, # 2ND STR (MAYBE) + $rd2pos, $second_arg, # 2ND RDEL (MAYBE) + $modpos, $endpos-$modpos, # MODIFIERS + $endpos, $textlen-$endpos, # REMAINDER + ); } my $def_func = [ - sub { extract_variable($_[0], '') }, - sub { extract_quotelike($_[0],'') }, - sub { extract_codeblock($_[0],'{}','') }, + sub { extract_variable($_[0], '') }, + sub { extract_quotelike($_[0],'') }, + sub { extract_codeblock($_[0],'{}','') }, ]; -sub extract_multiple (;$$$$) # ($text, $functions_ref, $max_fields, $ignoreunknown) +sub extract_multiple (;$$$$) # ($text, $functions_ref, $max_fields, $ignoreunknown) { - my $textref = defined($_[0]) ? \$_[0] : \$_; - my $posbug = pos; - my ($lastpos, $firstpos); - my @fields = (); - - #for ($$textref) - { - my @func = defined $_[1] ? @{$_[1]} : @{$def_func}; - my $max = defined $_[2] && $_[2]>0 ? $_[2] : 1_000_000_000; - my $igunk = $_[3]; - - pos $$textref ||= 0; - - unless (wantarray) - { - use Carp; - carp "extract_multiple reset maximal count to 1 in scalar context" - if $^W && defined($_[2]) && $max > 1; - $max = 1 - } - - my $unkpos; - my $func; - my $class; - - my @class; - foreach $func ( @func ) - { - if (ref($func) eq 'HASH') - { - push @class, (keys %$func)[0]; - $func = (values %$func)[0]; - } - else - { - push @class, undef; - } - } - - FIELD: while (pos($$textref) < length($$textref)) - { - my ($field, $rem); - my @bits; - foreach my $i ( 0..$#func ) - { - my $pref; - $func = $func[$i]; - $class = $class[$i]; - $lastpos = pos $$textref; - if (ref($func) eq 'CODE') - { ($field,$rem,$pref) = @bits = $func->($$textref) } - elsif (ref($func) eq 'Text::Balanced::Extractor') - { @bits = $field = $func->extract($$textref) } - elsif( $$textref =~ m/\G$func/gc ) - { @bits = $field = defined($1) - ? $1 - : substr($$textref, $-[0], $+[0] - $-[0]) + my $textref = defined($_[0]) ? \$_[0] : \$_; + my $posbug = pos; + my ($lastpos, $firstpos); + my @fields = (); + + #for ($$textref) + { + my @func = defined $_[1] ? @{$_[1]} : @{$def_func}; + my $max = defined $_[2] && $_[2]>0 ? $_[2] : 1_000_000_000; + my $igunk = $_[3]; + + pos $$textref ||= 0; + + unless (wantarray) + { + use Carp; + carp "extract_multiple reset maximal count to 1 in scalar context" + if $^W && defined($_[2]) && $max > 1; + $max = 1 + } + + my $unkpos; + my $class; + + my @class; + foreach my $func ( @func ) + { + if (ref($func) eq 'HASH') + { + push @class, (keys %$func)[0]; + $func = (values %$func)[0]; + } + else + { + push @class, undef; + } + } + + FIELD: while (pos($$textref) < length($$textref)) + { + my ($field, $rem); + my @bits; + foreach my $i ( 0..$#func ) + { + my $pref; + my $func = $func[$i]; + $class = $class[$i]; + $lastpos = pos $$textref; + if (ref($func) eq 'CODE') + { ($field,$rem,$pref) = @bits = $func->($$textref) } + elsif (ref($func) eq 'Text::Balanced::Extractor') + { @bits = $field = $func->extract($$textref) } + elsif( $$textref =~ m/\G$func/gc ) + { @bits = $field = defined($1) + ? $1 + : substr($$textref, $-[0], $+[0] - $-[0]) + } + $pref ||= ""; + if (defined($field) && length($field)) + { + if (!$igunk) { + $unkpos = $lastpos + if length($pref) && !defined($unkpos); + if (defined $unkpos) + { + push @fields, substr($$textref, $unkpos, $lastpos-$unkpos).$pref; + $firstpos = $unkpos unless defined $firstpos; + undef $unkpos; + last FIELD if @fields == $max; + } } - $pref ||= ""; - if (defined($field) && length($field)) - { - if (!$igunk) { - $unkpos = $lastpos - if length($pref) && !defined($unkpos); - if (defined $unkpos) - { - push @fields, substr($$textref, $unkpos, $lastpos-$unkpos).$pref; - $firstpos = $unkpos unless defined $firstpos; - undef $unkpos; - last FIELD if @fields == $max; - } - } - push @fields, $class - ? bless (\$field, $class) - : $field; - $firstpos = $lastpos unless defined $firstpos; - $lastpos = pos $$textref; - last FIELD if @fields == $max; - next FIELD; - } - } - if ($$textref =~ /\G(.)/gcs) - { - $unkpos = pos($$textref)-1 - unless $igunk || defined $unkpos; - } - } - - if (defined $unkpos) - { - push @fields, substr($$textref, $unkpos); - $firstpos = $unkpos unless defined $firstpos; - $lastpos = length $$textref; - } - last; - } - - pos $$textref = $lastpos; - return @fields if wantarray; - - $firstpos ||= 0; - eval { substr($$textref,$firstpos,$lastpos-$firstpos)=""; - pos $$textref = $firstpos }; - return $fields[0]; + push @fields, $class + ? bless (\$field, $class) + : $field; + $firstpos = $lastpos unless defined $firstpos; + $lastpos = pos $$textref; + last FIELD if @fields == $max; + next FIELD; + } + } + if ($$textref =~ /\G(.)/gcs) + { + $unkpos = pos($$textref)-1 + unless $igunk || defined $unkpos; + } + } + + if (defined $unkpos) + { + push @fields, substr($$textref, $unkpos); + $firstpos = $unkpos unless defined $firstpos; + $lastpos = length $$textref; + } + last; + } + + pos $$textref = $lastpos; + return @fields if wantarray; + + $firstpos ||= 0; + eval { substr($$textref,$firstpos,$lastpos-$firstpos)=""; + pos $$textref = $firstpos }; + return $fields[0]; } sub gen_extract_tagged # ($opentag, $closetag, $pre, \%options) { - my $ldel = $_[0]; - my $rdel = $_[1]; - my $pre = defined $_[2] ? $_[2] : '\s*'; - my %options = defined $_[3] ? %{$_[3]} : (); - my $omode = defined $options{fail} ? $options{fail} : ''; - my $bad = ref($options{reject}) eq 'ARRAY' ? join('|', @{$options{reject}}) - : defined($options{reject}) ? $options{reject} - : '' - ; - my $ignore = ref($options{ignore}) eq 'ARRAY' ? join('|', @{$options{ignore}}) - : defined($options{ignore}) ? $options{ignore} - : '' - ; - - if (!defined $ldel) { $ldel = '<\w+(?:' . gen_delimited_pat(q{'"}) . '|[^>])*>'; } - - my $posbug = pos; - for ($ldel, $pre, $bad, $ignore) { $_ = qr/$_/ if $_ } - pos = $posbug; - - my $closure = sub - { - my $textref = defined $_[0] ? \$_[0] : \$_; - my @match = Text::Balanced::_match_tagged($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore); - - return _fail(wantarray, $textref) unless @match; - return _succeed wantarray, $textref, - $match[2], $match[3]+$match[5]+$match[7], # MATCH - @match[8..9,0..1,2..7]; # REM, PRE, BITS - }; - - bless $closure, 'Text::Balanced::Extractor'; + my $ldel = $_[0]; + my $rdel = $_[1]; + my $pre = defined $_[2] ? $_[2] : '\s*'; + my %options = defined $_[3] ? %{$_[3]} : (); + my $omode = defined $options{fail} ? $options{fail} : ''; + my $bad = ref($options{reject}) eq 'ARRAY' ? join('|', @{$options{reject}}) + : defined($options{reject}) ? $options{reject} + : '' + ; + my $ignore = ref($options{ignore}) eq 'ARRAY' ? join('|', @{$options{ignore}}) + : defined($options{ignore}) ? $options{ignore} + : '' + ; + + if (!defined $ldel) { $ldel = '<\w+(?:' . gen_delimited_pat(q{'"}) . '|[^>])*>'; } + + my $posbug = pos; + for ($ldel, $pre, $bad, $ignore) { $_ = qr/$_/ if $_ } + pos = $posbug; + + my $closure = sub + { + my $textref = defined $_[0] ? \$_[0] : \$_; + my @match = Text::Balanced::_match_tagged($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore); + + return _fail(wantarray, $textref) unless @match; + return _succeed wantarray, $textref, + $match[2], $match[3]+$match[5]+$match[7], # MATCH + @match[8..9,0..1,2..7]; # REM, PRE, BITS + }; + + bless $closure, 'Text::Balanced::Extractor'; } package Text::Balanced::Extractor; -sub extract($$) # ($self, $text) +sub extract($$) # ($self, $text) { - &{$_[0]}($_[1]); + &{$_[0]}($_[1]); } package Text::Balanced::ErrorMsg; @@ -1032,83 +1041,76 @@ Text::Balanced - Extract delimited text sequences from strings. =head1 SYNOPSIS - use Text::Balanced qw ( - extract_delimited - extract_bracketed - extract_quotelike - extract_codeblock - extract_variable - extract_tagged - extract_multiple - gen_delimited_pat - gen_extract_tagged - ); + use Text::Balanced qw ( + extract_delimited + extract_bracketed + extract_quotelike + extract_codeblock + extract_variable + extract_tagged + extract_multiple + gen_delimited_pat + gen_extract_tagged + ); - # Extract the initial substring of $text that is delimited by - # two (unescaped) instances of the first character in $delim. + # Extract the initial substring of $text that is delimited by + # two (unescaped) instances of the first character in $delim. - ($extracted, $remainder) = extract_delimited($text,$delim); + ($extracted, $remainder) = extract_delimited($text,$delim); + # Extract the initial substring of $text that is bracketed + # with a delimiter(s) specified by $delim (where the string + # in $delim contains one or more of '(){}[]<>'). - # Extract the initial substring of $text that is bracketed - # with a delimiter(s) specified by $delim (where the string - # in $delim contains one or more of '(){}[]<>'). + ($extracted, $remainder) = extract_bracketed($text,$delim); - ($extracted, $remainder) = extract_bracketed($text,$delim); + # Extract the initial substring of $text that is bounded by + # an XML tag. + ($extracted, $remainder) = extract_tagged($text); - # Extract the initial substring of $text that is bounded by - # an XML tag. + # Extract the initial substring of $text that is bounded by + # a C...C pair. Don't allow nested C tags - ($extracted, $remainder) = extract_tagged($text); + ($extracted, $remainder) = + extract_tagged($text,"BEGIN","END",undef,{bad=>["BEGIN"]}); + # Extract the initial substring of $text that represents a + # Perl "quote or quote-like operation" - # Extract the initial substring of $text that is bounded by - # a C...C pair. Don't allow nested C tags + ($extracted, $remainder) = extract_quotelike($text); - ($extracted, $remainder) = - extract_tagged($text,"BEGIN","END",undef,{bad=>["BEGIN"]}); + # Extract the initial substring of $text that represents a block + # of Perl code, bracketed by any of character(s) specified by $delim + # (where the string $delim contains one or more of '(){}[]<>'). + ($extracted, $remainder) = extract_codeblock($text,$delim); - # Extract the initial substring of $text that represents a - # Perl "quote or quote-like operation" + # Extract the initial substrings of $text that would be extracted by + # one or more sequential applications of the specified functions + # or regular expressions - ($extracted, $remainder) = extract_quotelike($text); + @extracted = extract_multiple($text, + [ \&extract_bracketed, + \&extract_quotelike, + \&some_other_extractor_sub, + qr/[xyz]*/, + 'literal', + ]); + # Create a string representing an optimized pattern (a la Friedl) + # that matches a substring delimited by any of the specified characters + # (in this case: any type of quote or a slash) - # Extract the initial substring of $text that represents a block - # of Perl code, bracketed by any of character(s) specified by $delim - # (where the string $delim contains one or more of '(){}[]<>'). + $patstring = gen_delimited_pat(q{'"`/}); - ($extracted, $remainder) = extract_codeblock($text,$delim); + # Generate a reference to an anonymous sub that is just like extract_tagged + # but pre-compiled and optimized for a specific pair of tags, and + # consequently much faster (i.e. 3 times faster). It uses qr// for better + # performance on repeated calls. - - # Extract the initial substrings of $text that would be extracted by - # one or more sequential applications of the specified functions - # or regular expressions - - @extracted = extract_multiple($text, - [ \&extract_bracketed, - \&extract_quotelike, - \&some_other_extractor_sub, - qr/[xyz]*/, - 'literal', - ]); - -# Create a string representing an optimized pattern (a la Friedl) -# that matches a substring delimited by any of the specified characters -# (in this case: any type of quote or a slash) - - $patstring = gen_delimited_pat(q{'"`/}); - -# Generate a reference to an anonymous sub that is just like extract_tagged -# but pre-compiled and optimized for a specific pair of tags, and consequently -# much faster (i.e. 3 times faster). It uses qr// for better performance on -# repeated calls, so it only works under Perl 5.005 or later. - - $extract_head = gen_extract_tagged('',''); - - ($extracted, $remainder) = $extract_head->($text); + $extract_head = gen_extract_tagged('',''); + ($extracted, $remainder) = $extract_head->($text); =head1 DESCRIPTION @@ -1128,7 +1130,7 @@ they extract an occurrence of the substring appearing immediately at the current matching position in the string (like a C<\G>-anchored regex would). -=head2 General behaviour in list contexts +=head2 General Behaviour in List Contexts In a list context, all the subroutines return a list, the first three elements of which are always: @@ -1150,31 +1152,31 @@ extracted string). On failure, the entire string is returned. The skipped prefix (i.e. the characters before the extracted string). On failure, C is returned. -=back +=back Note that in a list context, the contents of the original input text (the first -argument) are not modified in any way. +argument) are not modified in any way. However, if the input text was passed in a variable, that variable's C value is updated to point at the first character after the extracted text. That means that in a list context the various subroutines can be used much like regular expressions. For example: - while ( $next = (extract_quotelike($text))[0] ) - { - # process next quote-like (in $next) - } + while ( $next = (extract_quotelike($text))[0] ) + { + # process next quote-like (in $next) + } -=head2 General behaviour in scalar and void contexts +=head2 General Behaviour in Scalar and Void Contexts In a scalar context, the extracted string is returned, having first been removed from the input text. Thus, the following code also processes each quote-like operation, but actually removes them from $text: - while ( $next = extract_quotelike($text) ) - { - # process next quote-like (in $next) - } + while ( $next = extract_quotelike($text) ) + { + # process next quote-like (in $next) + } Note that if the input text is a read-only string (i.e. a literal), no attempt is made to remove the extracted text. @@ -1183,7 +1185,7 @@ In a void context the behaviour of the extraction subroutines is exactly the same as in a scalar context, except (of course) that the extracted substring is not returned. -=head2 A note about prefixes +=head2 A Note About Prefixes Prefix patterns are matched without any trailing modifiers (C etc.) This can bite you if you're expecting a prefix specification like @@ -1194,19 +1196,23 @@ pattern will only succeed if the

tag is on the current line, since To overcome this limitation, you need to turn on /s matching within the prefix pattern, using the C<(?s)> directive: '(?s).*?(?=

)' -=head2 C +=head2 Functions + +=over 4 + +=item C The C function formalizes the common idiom of extracting a single-character-delimited substring from the start of a string. For example, to extract a single-quote delimited string, the following code is typically used: - ($remainder = $text) =~ s/\A('(\\.|[^'])*')//s; - $extracted = $1; + ($remainder = $text) =~ s/\A('(\\.|[^'])*')//s; + $extracted = $1; but with C it can be simplified to: - ($extracted,$remainder) = extract_delimited($text, "'"); + ($extracted,$remainder) = extract_delimited($text, "'"); C takes up to four scalars (the input text, the delimiters, a prefix pattern to be skipped, and any escape characters) @@ -1240,42 +1246,42 @@ removed from the beginning of the first argument. Examples: - # Remove a single-quoted substring from the very beginning of $text: + # Remove a single-quoted substring from the very beginning of $text: - $substring = extract_delimited($text, "'", ''); + $substring = extract_delimited($text, "'", ''); - # Remove a single-quoted Pascalish substring (i.e. one in which - # doubling the quote character escapes it) from the very - # beginning of $text: + # Remove a single-quoted Pascalish substring (i.e. one in which + # doubling the quote character escapes it) from the very + # beginning of $text: - $substring = extract_delimited($text, "'", '', "'"); + $substring = extract_delimited($text, "'", '', "'"); - # Extract a single- or double- quoted substring from the - # beginning of $text, optionally after some whitespace - # (note the list context to protect $text from modification): + # Extract a single- or double- quoted substring from the + # beginning of $text, optionally after some whitespace + # (note the list context to protect $text from modification): - ($substring) = extract_delimited $text, q{"'}; + ($substring) = extract_delimited $text, q{"'}; - # Delete the substring delimited by the first '/' in $text: + # Delete the substring delimited by the first '/' in $text: - $text = join '', (extract_delimited($text,'/','[^/]*')[2,1]; + $text = join '', (extract_delimited($text,'/','[^/]*')[2,1]; Note that this last example is I the same as deleting the first quote-like pattern. For instance, if C<$text> contained the string: - "if ('./cmd' =~ m/$UNIXCMD/s) { $cmd = $1; }" - + "if ('./cmd' =~ m/$UNIXCMD/s) { $cmd = $1; }" + then after the deletion it would contain: - "if ('.$UNIXCMD/s) { $cmd = $1; }" + "if ('.$UNIXCMD/s) { $cmd = $1; }" not: - "if ('./cmd' =~ ms) { $cmd = $1; }" - + "if ('./cmd' =~ ms) { $cmd = $1; }" + See L<"extract_quotelike"> for a (partial) solution to this problem. -=head2 C +=item C Like C<"extract_delimited">, the C function takes up to three optional scalar arguments: a string to extract from, a delimiter @@ -1307,15 +1313,15 @@ balanced and correctly nested within the substring, and any other kind of For example, given the string: - $text = "{ an '[irregularly :-(] {} parenthesized >:-)' string }"; + $text = "{ an '[irregularly :-(] {} parenthesized >:-)' string }"; then a call to C in a list context: - @result = extract_bracketed( $text, '{}' ); + @result = extract_bracketed( $text, '{}' ); would return: - ( "{ an '[irregularly :-(] {} parenthesized >:-)' string }" , "" , "" ) + ( "{ an '[irregularly :-(] {} parenthesized >:-)' string }" , "" , "" ) since both sets of C<'{..}'> brackets are properly nested and evenly balanced. (In a scalar context just the first element of the array would be returned. In @@ -1323,18 +1329,18 @@ a void context, C<$text> would be replaced by an empty string.) Likewise the call in: - @result = extract_bracketed( $text, '{[' ); + @result = extract_bracketed( $text, '{[' ); would return the same result, since all sets of both types of specified delimiter brackets are correctly nested and balanced. However, the call in: - @result = extract_bracketed( $text, '{([<' ); + @result = extract_bracketed( $text, '{([<' ); would fail, returning: - ( undef , "{ an '[irregularly :-(] {} parenthesized >:-)' string }" ); + ( undef , "{ an '[irregularly :-(] {} parenthesized >:-)' string }" ); because the embedded pairs of C<'(..)'>s and C<'[..]'>s are "cross-nested" and the embedded C<'E'> is unbalanced. (In a scalar context, this call would @@ -1348,37 +1354,37 @@ However, if a particular species of quote character is included in the delimiter specification, then that type of quote will be correctly handled. for example, if C<$text> is: - $text = 'link'; + $text = 'link'; then - @result = extract_bracketed( $text, '<">' ); + @result = extract_bracketed( $text, '<">' ); returns: - ( '', 'link', "" ) + ( '', 'link', "" ) as expected. Without the specification of C<"> as an embedded quoter: - @result = extract_bracketed( $text, '<>' ); + @result = extract_bracketed( $text, '<>' ); the result would be: - ( 'link', "" ) + ( 'link', "" ) In addition to the quote delimiters C<'>, C<">, and C<`>, full Perl quote-like quoting (i.e. q{string}, qq{string}, etc) can be specified by including the letter 'q' as a delimiter. Hence: - @result = extract_bracketed( $text, '' ); + @result = extract_bracketed( $text, '' ); would correctly match something like this: - $text = ''; + $text = ''; See also: C<"extract_quotelike"> and C<"extract_codeblock">. -=head2 C +=item C C extracts any valid Perl variable or variable-involved expression, including scalars, arrays, hashes, array @@ -1429,11 +1435,10 @@ failure. In addition, the original input text has the returned substring In a void context, the input text just has the matched substring (and any specified prefix) removed. - -=head2 C +=item C C extracts and segments text between (balanced) -specified tags. +specified tags. The subroutine takes up to five optional arguments: @@ -1451,12 +1456,12 @@ that matches any standard XML tag is used. =item 3. -A string specifying a pattern to be matched at the closing tag. +A string specifying a pattern to be matched at the closing tag. If the pattern string is omitted (or C) then the closing tag is constructed by inserting a C after any leading bracket characters in the actual opening tag that was matched (I the pattern that matched the tag). For example, if the opening tag pattern -is specified as C<'{{\w+}}'> and actually matched the opening tag +is specified as C<'{{\w+}}'> and actually matched the opening tag C<"{{DATA}}">, then the constructed closing tag would be C<"{{/DATA}}">. =item 4. @@ -1487,7 +1492,7 @@ an HTML link (which should not contain nested links) use: =item C $listref> The list reference contains one or more strings specifying patterns -that are I be be treated as nested tags within the tagged text +that are I to be treated as nested tags within the tagged text (even if they would match the start tag pattern). For example, to extract an arbitrary XML tag, but ignore "empty" elements: @@ -1508,7 +1513,7 @@ C returns the complete text up to the point of failure. If the string is "PARA", C returns only the first paragraph after the tag (up to the first line that is either empty or contains only whitespace characters). -If the string is "", the the default behaviour (i.e. failure) is reinstated. +If the string is "", the default behaviour (i.e. failure) is reinstated. For example, suppose the start tag "/para" introduces a paragraph, which then continues until the next "/endpara" tag or until another "/para" tag is @@ -1575,9 +1580,7 @@ text has the returned substring (and any prefix) removed from it. In a void context, the input text just has the matched substring (and any specified prefix) removed. -=head2 C - -(Note: This subroutine is only available under Perl5.005) +=item C C generates a new anonymous subroutine which extracts text between (balanced) specified tags. In other words, @@ -1589,7 +1592,7 @@ C, is that those generated subroutines: =over 4 -=item * +=item * do not have to reparse tag specification or parsing options every time they are called (whereas C has to effectively rebuild @@ -1598,7 +1601,7 @@ its tag parser on every call); =item * make use of the new qr// construct to pre-compile the regexes they use -(whereas C uses standard string variable interpolation +(whereas C uses standard string variable interpolation to create tag-matching patterns). =back @@ -1618,16 +1621,14 @@ equivalent to: return $extractor->($text); } -(although C is not currently implemented that way, in order -to preserve pre-5.005 compatibility). +(although C is not currently implemented that way). -Using C to create extraction functions for specific tags +Using C to create extraction functions for specific tags is a good idea if those functions are going to be called more than once, since their performance is typically twice as good as the more general-purpose C. - -=head2 C +=item C C attempts to recognize, extract, and segment any one of the various Perl quotes and quotelike operators (see @@ -1636,7 +1637,7 @@ delimiters (for the quotelike operators), and trailing modifiers are all caught. For example, in: extract_quotelike 'q # an octothorpe: \# (not the end of the q!) #' - + extract_quotelike ' "You said, \"Use sed\"." ' extract_quotelike ' s{([A-Z]{1,8}\.[A-Z]{3})} /\L$1\E/; ' @@ -1664,7 +1665,7 @@ will be extracted as if it were: This behaviour is identical to that of the actual compiler. C takes two arguments: the text to be processed and -a prefix to be matched at the very beginning of the text. If no prefix +a prefix to be matched at the very beginning of the text. If no prefix is specified, optional whitespace is the default. If no text is given, C<$_> is used. @@ -1710,7 +1711,7 @@ the left delimiter of the second block of the operation =item [8] -the text of the second block of the operation +the text of the second block of the operation (that is, the replacement of a substitution or the translation list of a translation), @@ -1757,7 +1758,7 @@ Examples: print "$op is not a pattern matching operation\n"; } -=head2 C and "here documents" +=item C C can successfully extract "here documents" from an input string, but with an important caveat in list contexts. @@ -1842,7 +1843,7 @@ you can pass the input variable as an interpolated literal: $quotelike = extract_quotelike("$var"); -=head2 C +=item C C attempts to recognize and extract a balanced bracket delimited substring that may contain unbalanced brackets @@ -1861,7 +1862,7 @@ Omitting the third argument (prefix argument) implies optional whitespace at the Omitting the fourth argument (outermost delimiter brackets) indicates that the value of the second argument is to be used for the outermost delimiters. -Once the prefix an dthe outermost opening delimiter bracket have been +Once the prefix and the outermost opening delimiter bracket have been recognized, code blocks are extracted by stepping through the input text and trying the following alternatives in sequence: @@ -1933,9 +1934,9 @@ SE')>> the '>' character is only treated as a delimited at the outermost level of the code block, so the directive is parsed correctly. -=head2 C +=item C -The C subroutine takes a string to be processed and a +The C subroutine takes a string to be processed and a list of extractors (subroutines or regular expressions) to apply to that string. In an array context C returns an array of substrings @@ -1947,7 +1948,7 @@ extracted substring removed from it. In all contexts C starts at the current C of the string, and sets that C appropriately after it matches. -Hence, the aim of of a call to C in a list context +Hence, the aim of a call to C in a list context is to split the processed string into as many non-overlapping fields as possible, by repeatedly applying each of the specified extractors to the remainder of the string. Thus C is @@ -1982,11 +1983,11 @@ An number specifying the maximum number of fields to return. If this argument is omitted (or C), split continues as long as possible. If the third argument is I, then extraction continues until I fields -have been successfully extracted, or until the string has been completely +have been successfully extracted, or until the string has been completely processed. -Note that in scalar and void contexts the value of this argument is -automatically reset to 1 (under C<-w>, a warning is issued if the argument +Note that in scalar and void contexts the value of this argument is +automatically reset to 1 (under C<-w>, a warning is issued if the argument has to be reset). =item 4. @@ -2026,7 +2027,7 @@ return value of the extractor will be blessed. If an extractor returns a defined value, that value is immediately treated as the next extracted field and pushed onto the list of fields. If the extractor was specified in a hash reference, the field is also -blessed into the appropriate class, +blessed into the appropriate class, If the extractor fails to match (in the case of a regex extractor), or returns an empty list or an undefined value (in the case of a subroutine extractor), it is assumed to have failed to extract. @@ -2080,7 +2081,7 @@ If you wanted the commas preserved as separate fields (i.e. like split does if your split pattern has capturing parentheses), you would just make the last parameter undefined (or remove it). -=head2 C +=item C The C subroutine takes a single (string) argument and > builds a Friedl-style optimized regex that matches a string delimited @@ -2119,11 +2120,12 @@ If more delimiters than escape chars are specified, the last escape char is used for the remaining delimiters. If no escape char is specified for a given specified delimiter, '\' is used. -=head2 C +=item C Note that C was previously called C. That name may still be used, but is now deprecated. - + +=back =head1 DIAGNOSTICS @@ -2170,7 +2172,7 @@ a closing bracket where none was expected. =item C -C, C or C ran +C, C or C ran out of characters in the text before closing one or more levels of nested brackets. @@ -2257,25 +2259,125 @@ to match the original opening tag (and the failure mode was not =back -=head1 AUTHOR +=head1 EXPORTS -Damian Conway (damian@conway.org) +The following symbols are, or can be, exported by this module: -=head1 BUGS AND IRRITATIONS +=over 4 + +=item Default Exports + +I. + +=item Optional Exports + +C, +C, +C, +C, +C, +C, +C, +C, +C, +C. + +=item Export Tags + +=over 4 + +=item C<:ALL> + +C, +C, +C, +C, +C, +C, +C, +C, +C, +C. + +=back + +=back + +=head1 KNOWN BUGS + +See L. + +=head1 FEEDBACK + +Patches, bug reports, suggestions or any other feedback is welcome. + +Patches can be sent as GitHub pull requests at +L. + +Bug reports and suggestions can be made on the CPAN Request Tracker at +L. + +Currently active requests on the CPAN Request Tracker can be viewed at +L. -There are undoubtedly serious bugs lurking somewhere in this code, if -only because parts of it give the impression of understanding a great deal -more about Perl than they really do. +Please test this distribution. See CPAN Testers Reports at +L for details of how to get involved. -Bug reports and other feedback are most welcome. +Previous test results on CPAN Testers Reports can be viewed at +L. + +Please rate this distribution on CPAN Ratings at +L. + +=head1 AVAILABILITY + +The latest version of this module is available from CPAN (see +L for details) at + +L or + +L or + +L. + +The latest source code is available from GitHub at +L. + +=head1 INSTALLATION + +See the F file. + +=head1 AUTHOR + +Damian Conway ELE. + +Steve Hay ELE is now maintaining +Text::Balanced as of version 2.03. =head1 COPYRIGHT -Copyright 1997 - 2001 Damian Conway. All Rights Reserved. +Copyright (C) 1997-2001 Damian Conway. All rights reserved. + +Copyright (C) 2009 Adam Kennedy. + +Copyright (C) 2015, 2020 Steve Hay. All rights reserved. + +=head1 LICENCE + +This module is free software; you can redistribute it and/or modify it under the +same terms as Perl itself, i.e. under the terms of either the GNU General Public +License or the Artistic License, as specified in the F file. + +=head1 VERSION + +Version 2.04 + +=head1 DATE + +11 Dec 2020 -Some (minor) parts copyright 2009 Adam Kennedy. +=head1 HISTORY -This module is free software. It may be used, redistributed -and/or modified under the same terms as Perl itself. +See the F file. =cut diff --git a/cpan/Text-Balanced/t/01_compile.t b/cpan/Text-Balanced/t/01_compile.t index 77c109999553..a6e91911c72e 100644 --- a/cpan/Text-Balanced/t/01_compile.t +++ b/cpan/Text-Balanced/t/01_compile.t @@ -1,10 +1,9 @@ #!/usr/bin/perl +use 5.008001; + use strict; -BEGIN { - $| = 1; - $^W = 1; -} +use warnings; use Test::More tests => 1; diff --git a/cpan/Text-Balanced/t/02_extbrk.t b/cpan/Text-Balanced/t/02_extbrk.t index a36025ddb02c..5da792f1f041 100644 --- a/cpan/Text-Balanced/t/02_extbrk.t +++ b/cpan/Text-Balanced/t/02_extbrk.t @@ -1,52 +1,60 @@ # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' +use 5.008001; + +use strict; +use warnings; + ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) +my $loaded = 0; BEGIN { $| = 1; print "1..19\n"; } END {print "not ok 1\n" unless $loaded;} use Text::Balanced qw ( extract_bracketed ); $loaded = 1; print "ok 1\n"; -$count=2; +my $count=2; use vars qw( $DEBUG ); sub debug { print "\t>>>",@_ if $DEBUG } ######################### End of black magic. +## no critic (BuiltinFunctions::ProhibitStringyEval) -$cmd = "print"; -$neg = 0; +my $cmd = "print"; +my $neg = 0; +my $str; while (defined($str = )) { - chomp $str; - if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } - elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } - elsif (!$str || $str =~ /\A#/) { $neg = 0; next } - $str =~ s/\\n/\n/g; - debug "\tUsing: $cmd\n"; - debug "\t on: [$str]\n"; - - $var = eval "() = $cmd"; - debug "\t list got: [$var]\n"; - debug "\t list left: [$str]\n"; - print "not " if (substr($str,pos($str),1) eq ';')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; - - pos $str = 0; - $var = eval $cmd; - $var = "" unless defined $var; - debug "\t scalar got: [$var]\n"; - debug "\t scalar left: [$str]\n"; - print "not " if ($str =~ '\A;')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; + chomp $str; + if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } + elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } + elsif (!$str || $str =~ /\A#/) { $neg = 0; next } + $str =~ s/\\n/\n/g; + debug "\tUsing: $cmd\n"; + debug "\t on: [$str]\n"; + + my $var = eval "() = $cmd"; + debug "\t list got: [$var]\n"; + debug "\t list left: [$str]\n"; + print "not " if (substr($str,pos($str),1) eq ';')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; + + pos $str = 0; + $var = eval $cmd; + $var = "" unless defined $var; + debug "\t scalar got: [$var]\n"; + debug "\t scalar left: [$str]\n"; + print "not " if ($str =~ '\A;')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; } __DATA__ diff --git a/cpan/Text-Balanced/t/03_extcbk.t b/cpan/Text-Balanced/t/03_extcbk.t index 83081ae28d42..398d2771bac0 100644 --- a/cpan/Text-Balanced/t/03_extcbk.t +++ b/cpan/Text-Balanced/t/03_extcbk.t @@ -1,53 +1,61 @@ # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' +use 5.008001; + +use strict; +use warnings; + ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) +my $loaded = 0; BEGIN { $| = 1; print "1..41\n"; } END {print "not ok 1\n" unless $loaded;} use Text::Balanced qw ( extract_codeblock ); $loaded = 1; print "ok 1\n"; -$count=2; +my $count=2; use vars qw( $DEBUG ); sub debug { print "\t>>>",@_ if $DEBUG } ######################### End of black magic. +## no critic (BuiltinFunctions::ProhibitStringyEval) -$cmd = "print"; -$neg = 0; +my $cmd = "print"; +my $neg = 0; +my $str; while (defined($str = )) { - chomp $str; - if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } - elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } - elsif (!$str || $str =~ /\A#/) { $neg = 0; next } - $str =~ s/\\n/\n/g; - debug "\tUsing: $cmd\n"; - debug "\t on: [$str]\n"; - - my @res; - $var = eval "\@res = $cmd"; - debug "\t Failed: $@ at " . $@+0 .")" if $@; - debug "\t list got: [" . join("|", map {defined $_ ? $_ : ''} @res) . "]\n"; - debug "\t list left: [$str]\n"; - print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; - print "ok ", $count++; - print "\n"; - - pos $str = 0; - $var = eval $cmd; - $var = "" unless defined $var; - debug "\t scalar got: [$var]\n"; - debug "\t scalar left: [$str]\n"; - print "not " if ($str =~ '\A;')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; + chomp $str; + if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } + elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } + elsif (!$str || $str =~ /\A#/) { $neg = 0; next } + $str =~ s/\\n/\n/g; + debug "\tUsing: $cmd\n"; + debug "\t on: [$str]\n"; + + my @res; + my $var = eval "\@res = $cmd"; + debug "\t Failed: $@ at " . $@+0 .")" if $@; + debug "\t list got: [" . join("|", map {defined $_ ? $_ : ''} @res) . "]\n"; + debug "\t list left: [$str]\n"; + print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; + print "ok ", $count++; + print "\n"; + + pos $str = 0; + $var = eval $cmd; + $var = "" unless defined $var; + debug "\t scalar got: [$var]\n"; + debug "\t scalar left: [$str]\n"; + print "not " if ($str =~ '\A;')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; } __DATA__ diff --git a/cpan/Text-Balanced/t/04_extdel.t b/cpan/Text-Balanced/t/04_extdel.t index c5ca88eebfde..b2f94cf51cfa 100644 --- a/cpan/Text-Balanced/t/04_extdel.t +++ b/cpan/Text-Balanced/t/04_extdel.t @@ -1,52 +1,60 @@ # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' +use 5.008001; + +use strict; +use warnings; + ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) +my $loaded = 0; BEGIN { $| = 1; print "1..45\n"; } END {print "not ok 1\n" unless $loaded;} use Text::Balanced qw ( extract_delimited ); $loaded = 1; print "ok 1\n"; -$count=2; +my $count=2; use vars qw( $DEBUG ); sub debug { print "\t>>>",@_ if $DEBUG } ######################### End of black magic. +## no critic (BuiltinFunctions::ProhibitStringyEval) -$cmd = "print"; -$neg = 0; +my $cmd = "print"; +my $neg = 0; +my $str; while (defined($str = )) { - chomp $str; - if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } - elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } - elsif (!$str || $str =~ /\A#/) { $neg = 0; next } - $str =~ s/\\n/\n/g; - debug "\tUsing: $cmd\n"; - debug "\t on: [$str]\n"; + chomp $str; + if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } + elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } + elsif (!$str || $str =~ /\A#/) { $neg = 0; next } + $str =~ s/\\n/\n/g; + debug "\tUsing: $cmd\n"; + debug "\t on: [$str]\n"; - $var = eval "() = $cmd"; - debug "\t list got: [$var]\n"; - debug "\t list left: [$str]\n"; - print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; + my $var = eval "() = $cmd"; + debug "\t list got: [$var]\n"; + debug "\t list left: [$str]\n"; + print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; - pos $str = 0; - $var = eval $cmd; - $var = "" unless defined $var; - debug "\t scalar got: [$var]\n"; - debug "\t scalar left: [$str]\n"; - print "not " if ($str =~ '\A;')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; + pos $str = 0; + $var = eval $cmd; + $var = "" unless defined $var; + debug "\t scalar got: [$var]\n"; + debug "\t scalar left: [$str]\n"; + print "not " if ($str =~ '\A;')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; } __DATA__ diff --git a/cpan/Text-Balanced/t/05_extmul.t b/cpan/Text-Balanced/t/05_extmul.t index 2ac1b19ffd02..9a9711b4f600 100644 --- a/cpan/Text-Balanced/t/05_extmul.t +++ b/cpan/Text-Balanced/t/05_extmul.t @@ -1,17 +1,23 @@ # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' +use 5.008001; + +use strict; +use warnings; + ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) +my $loaded = 0; BEGIN { $| = 1; print "1..86\n"; } END {print "not ok 1\n" unless $loaded;} use Text::Balanced qw ( :ALL ); $loaded = 1; print "ok 1\n"; -$count=2; +my $count=2; use vars qw( $DEBUG ); sub debug { print "\t>>>",@_ if $DEBUG } @@ -19,62 +25,62 @@ sub debug { print "\t>>>",@_ if $DEBUG } sub expect { - local $^W; - my ($l1, $l2) = @_; - - if (@$l1 != @$l2) - { - print "\@l1: ", join(", ", @$l1), "\n"; - print "\@l2: ", join(", ", @$l2), "\n"; - print "not "; - } - else - { - for (my $i = 0; $i < @$l1; $i++) - { - if ($l1->[$i] ne $l2->[$i]) - { - print "field $i: '$l1->[$i]' ne '$l2->[$i]'\n"; - print "not "; - last; - } - } - } - - print "ok $count\n"; - $count++; + local $^W; + my ($l1, $l2) = @_; + + if (@$l1 != @$l2) + { + print "\@l1: ", join(", ", @$l1), "\n"; + print "\@l2: ", join(", ", @$l2), "\n"; + print "not "; + } + else + { + for (my $i = 0; $i < @$l1; $i++) + { + if ($l1->[$i] ne $l2->[$i]) + { + print "field $i: '$l1->[$i]' ne '$l2->[$i]'\n"; + print "not "; + last; + } + } + } + + print "ok $count\n"; + $count++; } sub divide { - my ($text, @index) = @_; - my @bits = (); - unshift @index, 0; - push @index, length($text); - for ( my $i= 0; $i < $#index; $i++) - { - push @bits, substr($text, $index[$i], $index[$i+1]-$index[$i]); - } - pop @bits; - return @bits; + my ($text, @index) = @_; + my @bits = (); + unshift @index, 0; + push @index, length($text); + for ( my $i= 0; $i < $#index; $i++) + { + push @bits, substr($text, $index[$i], $index[$i+1]-$index[$i]); + } + pop @bits; + return @bits; } -$stdtext1 = q{$var = do {"val" && $val;};}; +my $stdtext1 = q{$var = do {"val" && $val;};}; # TESTS 2-4 -$text = $stdtext1; -expect [ extract_multiple($text,undef,1) ], - [ divide $stdtext1 => 4 ]; +my $text = $stdtext1; +expect [ extract_multiple($text,undef,1) ], + [ divide $stdtext1 => 4 ]; expect [ pos $text], [ 4 ]; expect [ $text ], [ $stdtext1 ]; # TESTS 5-7 $text = $stdtext1; -expect [ scalar extract_multiple($text,undef,1) ], - [ divide $stdtext1 => 4 ]; +expect [ scalar extract_multiple($text,undef,1) ], + [ divide $stdtext1 => 4 ]; expect [ pos $text], [ 0 ]; expect [ $text ], [ substr($stdtext1,4) ]; @@ -82,16 +88,16 @@ expect [ $text ], [ substr($stdtext1,4) ]; # TESTS 8-10 $text = $stdtext1; -expect [ extract_multiple($text,undef,2) ], - [ divide($stdtext1 => 4, 10) ]; +expect [ extract_multiple($text,undef,2) ], + [ divide($stdtext1 => 4, 10) ]; expect [ pos $text], [ 10 ]; expect [ $text ], [ $stdtext1 ]; # TESTS 11-13 $text = $stdtext1; -expect [ eval{local$^W;scalar extract_multiple($text,undef,2)} ], - [ substr($stdtext1,0,4) ]; +expect [ eval{local$^W;scalar extract_multiple($text,undef,2)} ], + [ substr($stdtext1,0,4) ]; expect [ pos $text], [ 0 ]; expect [ $text ], [ substr($stdtext1,4) ]; @@ -99,16 +105,16 @@ expect [ $text ], [ substr($stdtext1,4) ]; # TESTS 14-16 $text = $stdtext1; -expect [ extract_multiple($text,undef,3) ], - [ divide($stdtext1 => 4, 10, 26) ]; +expect [ extract_multiple($text,undef,3) ], + [ divide($stdtext1 => 4, 10, 26) ]; expect [ pos $text], [ 26 ]; expect [ $text ], [ $stdtext1 ]; # TESTS 17-19 $text = $stdtext1; -expect [ eval{local$^W;scalar extract_multiple($text,undef,3)} ], - [ substr($stdtext1,0,4) ]; +expect [ eval{local$^W;scalar extract_multiple($text,undef,3)} ], + [ substr($stdtext1,0,4) ]; expect [ pos $text], [ 0 ]; expect [ $text ], [ substr($stdtext1,4) ]; @@ -116,16 +122,16 @@ expect [ $text ], [ substr($stdtext1,4) ]; # TESTS 20-22 $text = $stdtext1; -expect [ extract_multiple($text,undef,4) ], - [ divide($stdtext1 => 4, 10, 26, 27) ]; +expect [ extract_multiple($text,undef,4) ], + [ divide($stdtext1 => 4, 10, 26, 27) ]; expect [ pos $text], [ 27 ]; expect [ $text ], [ $stdtext1 ]; # TESTS 23-25 $text = $stdtext1; -expect [ eval{local$^W;scalar extract_multiple($text,undef,4)} ], - [ substr($stdtext1,0,4) ]; +expect [ eval{local$^W;scalar extract_multiple($text,undef,4)} ], + [ substr($stdtext1,0,4) ]; expect [ pos $text], [ 0 ]; expect [ $text ], [ substr($stdtext1,4) ]; @@ -133,8 +139,8 @@ expect [ $text ], [ substr($stdtext1,4) ]; # TESTS 26-28 $text = $stdtext1; -expect [ extract_multiple($text,undef,5) ], - [ divide($stdtext1 => 4, 10, 26, 27) ]; +expect [ extract_multiple($text,undef,5) ], + [ divide($stdtext1 => 4, 10, 26, 27) ]; expect [ pos $text], [ 27 ]; expect [ $text ], [ $stdtext1 ]; @@ -142,8 +148,8 @@ expect [ $text ], [ $stdtext1 ]; # TESTS 29-31 $text = $stdtext1; -expect [ eval{local$^W;scalar extract_multiple($text,undef,5)} ], - [ substr($stdtext1,0,4) ]; +expect [ eval{local$^W;scalar extract_multiple($text,undef,5)} ], + [ substr($stdtext1,0,4) ]; expect [ pos $text], [ 0 ]; expect [ $text ], [ substr($stdtext1,4) ]; @@ -151,19 +157,19 @@ expect [ $text ], [ substr($stdtext1,4) ]; # TESTS 32-34 -$stdtext2 = q{$var = "val" && (1,2,3);}; +my $stdtext2 = q{$var = "val" && (1,2,3);}; $text = $stdtext2; -expect [ extract_multiple($text) ], - [ divide($stdtext2 => 4, 7, 12, 24) ]; +expect [ extract_multiple($text) ], + [ divide($stdtext2 => 4, 7, 12, 24) ]; expect [ pos $text], [ 24 ]; expect [ $text ], [ $stdtext2 ]; # TESTS 35-37 $text = $stdtext2; -expect [ scalar extract_multiple($text) ], - [ substr($stdtext2,0,4) ]; +expect [ scalar extract_multiple($text) ], + [ substr($stdtext2,0,4) ]; expect [ pos $text], [ 0 ]; expect [ $text ], [ substr($stdtext2,4) ]; @@ -171,16 +177,16 @@ expect [ $text ], [ substr($stdtext2,4) ]; # TESTS 38-40 $text = $stdtext2; -expect [ extract_multiple($text,[\&extract_bracketed]) ], - [ substr($stdtext2,0,16), substr($stdtext2,16,7), substr($stdtext2,23) ]; +expect [ extract_multiple($text,[\&extract_bracketed]) ], + [ substr($stdtext2,0,16), substr($stdtext2,16,7), substr($stdtext2,23) ]; expect [ pos $text], [ 24 ]; expect [ $text ], [ $stdtext2 ]; # TESTS 41-43 $text = $stdtext2; -expect [ scalar extract_multiple($text,[\&extract_bracketed]) ], - [ substr($stdtext2,0,16) ]; +expect [ scalar extract_multiple($text,[\&extract_bracketed]) ], + [ substr($stdtext2,0,16) ]; expect [ pos $text], [ 0 ]; expect [ $text ], [ substr($stdtext2,15) ]; @@ -188,16 +194,16 @@ expect [ $text ], [ substr($stdtext2,15) ]; # TESTS 44-46 $text = $stdtext2; -expect [ extract_multiple($text,[\&extract_variable]) ], - [ substr($stdtext2,0,4), substr($stdtext2,4) ]; +expect [ extract_multiple($text,[\&extract_variable]) ], + [ substr($stdtext2,0,4), substr($stdtext2,4) ]; expect [ pos $text], [ length($text) ]; expect [ $text ], [ $stdtext2 ]; # TESTS 47-49 $text = $stdtext2; -expect [ scalar extract_multiple($text,[\&extract_variable]) ], - [ substr($stdtext2,0,4) ]; +expect [ scalar extract_multiple($text,[\&extract_variable]) ], + [ substr($stdtext2,0,4) ]; expect [ pos $text], [ 0 ]; expect [ $text ], [ substr($stdtext2,4) ]; @@ -205,16 +211,16 @@ expect [ $text ], [ substr($stdtext2,4) ]; # TESTS 50-52 $text = $stdtext2; -expect [ extract_multiple($text,[\&extract_quotelike]) ], - [ substr($stdtext2,0,7), substr($stdtext2,7,5), substr($stdtext2,12) ]; +expect [ extract_multiple($text,[\&extract_quotelike]) ], + [ substr($stdtext2,0,7), substr($stdtext2,7,5), substr($stdtext2,12) ]; expect [ pos $text], [ length($text) ]; expect [ $text ], [ $stdtext2 ]; # TESTS 53-55 $text = $stdtext2; -expect [ scalar extract_multiple($text,[\&extract_quotelike]) ], - [ substr($stdtext2,0,7) ]; +expect [ scalar extract_multiple($text,[\&extract_quotelike]) ], + [ substr($stdtext2,0,7) ]; expect [ pos $text], [ 0 ]; expect [ $text ], [ substr($stdtext2,6) ]; @@ -222,16 +228,16 @@ expect [ $text ], [ substr($stdtext2,6) ]; # TESTS 56-58 $text = $stdtext2; -expect [ extract_multiple($text,[\&extract_quotelike],2,1) ], - [ substr($stdtext2,7,5) ]; +expect [ extract_multiple($text,[\&extract_quotelike],2,1) ], + [ substr($stdtext2,7,5) ]; expect [ pos $text], [ 23 ]; expect [ $text ], [ $stdtext2 ]; # TESTS 59-61 $text = $stdtext2; -expect [ eval{local$^W;scalar extract_multiple($text,[\&extract_quotelike],2,1)} ], - [ substr($stdtext2,7,5) ]; +expect [ eval{local$^W;scalar extract_multiple($text,[\&extract_quotelike],2,1)} ], + [ substr($stdtext2,7,5) ]; expect [ pos $text], [ 6 ]; expect [ $text ], [ substr($stdtext2,0,6). substr($stdtext2,12) ]; @@ -239,16 +245,16 @@ expect [ $text ], [ substr($stdtext2,0,6). substr($stdtext2,12) ]; # TESTS 62-64 $text = $stdtext2; -expect [ extract_multiple($text,[\&extract_quotelike],1,1) ], - [ substr($stdtext2,7,5) ]; +expect [ extract_multiple($text,[\&extract_quotelike],1,1) ], + [ substr($stdtext2,7,5) ]; expect [ pos $text], [ 12 ]; expect [ $text ], [ $stdtext2 ]; # TESTS 65-67 $text = $stdtext2; -expect [ scalar extract_multiple($text,[\&extract_quotelike],1,1) ], - [ substr($stdtext2,7,5) ]; +expect [ scalar extract_multiple($text,[\&extract_quotelike],1,1) ], + [ substr($stdtext2,7,5) ]; expect [ pos $text], [ 6 ]; expect [ $text ], [ substr($stdtext2,0,6). substr($stdtext2,12) ]; @@ -257,8 +263,8 @@ expect [ $text ], [ substr($stdtext2,0,6). substr($stdtext2,12) ]; my $stdtext3 = "a,b,c"; $_ = $stdtext3; -expect [ extract_multiple(undef, [ sub { /\G[a-z]/gc && $& } ]) ], - [ divide($stdtext3 => 1,2,3,4,5) ]; +expect [ extract_multiple(undef, [ sub { /\G[a-z]/gc && $& } ]) ], + [ divide($stdtext3 => 1,2,3,4,5) ]; expect [ pos ], [ 5 ]; expect [ $_ ], [ $stdtext3 ]; @@ -266,8 +272,8 @@ expect [ $_ ], [ $stdtext3 ]; # TESTS 71-73 $_ = $stdtext3; -expect [ scalar extract_multiple(undef, [ sub { /\G[a-z]/gc && $& } ]) ], - [ divide($stdtext3 => 1) ]; +expect [ scalar extract_multiple(undef, [ sub { /\G[a-z]/gc && $& } ]) ], + [ divide($stdtext3 => 1) ]; expect [ pos ], [ 0 ]; expect [ $_ ], [ substr($stdtext3,1) ]; @@ -276,8 +282,8 @@ expect [ $_ ], [ substr($stdtext3,1) ]; # TESTS 74-76 $_ = $stdtext3; -expect [ extract_multiple(undef, [ qr/\G[a-z]/ ]) ], - [ divide($stdtext3 => 1,2,3,4,5) ]; +expect [ extract_multiple(undef, [ qr/\G[a-z]/ ]) ], + [ divide($stdtext3 => 1,2,3,4,5) ]; expect [ pos ], [ 5 ]; expect [ $_ ], [ $stdtext3 ]; @@ -285,8 +291,8 @@ expect [ $_ ], [ $stdtext3 ]; # TESTS 77-79 $_ = $stdtext3; -expect [ scalar extract_multiple(undef, [ qr/\G[a-z]/ ]) ], - [ divide($stdtext3 => 1) ]; +expect [ scalar extract_multiple(undef, [ qr/\G[a-z]/ ]) ], + [ divide($stdtext3 => 1) ]; expect [ pos ], [ 0 ]; expect [ $_ ], [ substr($stdtext3,1) ]; @@ -295,8 +301,8 @@ expect [ $_ ], [ substr($stdtext3,1) ]; # TESTS 80-82 $_ = $stdtext3; -expect [ extract_multiple(undef, [ q/([a-z]),?/ ]) ], - [ qw(a b c) ]; +expect [ extract_multiple(undef, [ q/([a-z]),?/ ]) ], + [ qw(a b c) ]; expect [ pos ], [ 5 ]; expect [ $_ ], [ $stdtext3 ]; @@ -304,8 +310,8 @@ expect [ $_ ], [ $stdtext3 ]; # TESTS 83-85 $_ = $stdtext3; -expect [ scalar extract_multiple(undef, [ q/([a-z]),?/ ]) ], - [ divide($stdtext3 => 1) ]; +expect [ scalar extract_multiple(undef, [ q/([a-z]),?/ ]) ], + [ divide($stdtext3 => 1) ]; expect [ pos ], [ 0 ]; expect [ $_ ], [ substr($stdtext3,2) ]; @@ -315,5 +321,5 @@ expect [ $_ ], [ substr($stdtext3,2) ]; # Fails in Text-Balanced-1.95 with result ['1 ', '""', '1234'] $_ = q{ ""1234}; -expect [ extract_multiple(undef, [\&extract_quotelike]) ], - [ ' ', '""', '1234' ]; +expect [ extract_multiple(undef, [\&extract_quotelike]) ], + [ ' ', '""', '1234' ]; diff --git a/cpan/Text-Balanced/t/06_extqlk.t b/cpan/Text-Balanced/t/06_extqlk.t index 6badc0ee18d5..e32ca7d13034 100644 --- a/cpan/Text-Balanced/t/06_extqlk.t +++ b/cpan/Text-Balanced/t/06_extqlk.t @@ -2,17 +2,23 @@ # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' +use 5.008001; + +use strict; +use warnings; + ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) +my $loaded = 0; BEGIN { $| = 1; print "1..95\n"; } END {print "not ok 1\n" unless $loaded;} use Text::Balanced qw ( extract_quotelike ); $loaded = 1; print "ok 1\n"; -$count=2; +my $count=2; use vars qw( $DEBUG ); #$DEBUG=1; sub debug { print "\t>>>",@_ if $ENV{DEBUG} } @@ -20,48 +26,50 @@ sub esc { my $x = shift||''; $x =~ s/\n/\\n/gs; $x } ######################### End of black magic. +## no critic (BuiltinFunctions::ProhibitStringyEval) -$cmd = "print"; -$neg = 0; +my $cmd = "print"; +my $neg = 0; +my $str; while (defined($str = )) { - chomp $str; - if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } - elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } - elsif (!$str || $str =~ /\A#/) { $neg = 0; next } - my $setup_cmd = ($str =~ s/\A\{(.*)\}//) ? $1 : ''; - my $tests = 'sl'; - $str =~ s/\\n/\n/g; - my $orig = $str; - - eval $setup_cmd if $setup_cmd ne ''; - if($tests =~ /l/) { - debug "\tUsing: $cmd\n"; - debug "\t on: [" . esc($setup_cmd) . "][" . esc($str) . "]\n"; - my @res; - eval qq{\@res = $cmd; }; - debug "\t got:\n" . join "", map { "\t\t\t$_: [" . esc($res[$_]) . "]\n"} (0..$#res); - debug "\t left: [" . esc($str) . "]\n"; - debug "\t pos: [" . esc(substr($str,pos($str))) . "...]\n"; - print "not " if (substr($str,pos($str),1) eq ';')==$neg; - print "ok ", $count++; - print "\n"; - } - - eval $setup_cmd if $setup_cmd ne ''; - if($tests =~ /s/) { - $str = $orig; - debug "\tUsing: scalar $cmd\n"; - debug "\t on: [" . esc($str) . "]\n"; - $var = eval $cmd; - print " ($@)" if $@ && $DEBUG; - $var = "" unless defined $var; - debug "\t scalar got: [" . esc($var) . "]\n"; - debug "\t scalar left: [" . esc($str) . "]\n"; - print "not " if ($str =~ '\A;')==$neg; - print "ok ", $count++; - print "\n"; - } + chomp $str; + if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } + elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } + elsif (!$str || $str =~ /\A#/) { $neg = 0; next } + my $setup_cmd = ($str =~ s/\A\{(.*)\}//) ? $1 : ''; + my $tests = 'sl'; + $str =~ s/\\n/\n/g; + my $orig = $str; + + eval $setup_cmd if $setup_cmd ne ''; + if($tests =~ /l/) { + debug "\tUsing: $cmd\n"; + debug "\t on: [" . esc($setup_cmd) . "][" . esc($str) . "]\n"; + my @res; + eval qq{\@res = $cmd; }; + debug "\t got:\n" . join "", map { "\t\t\t$_: [" . esc($res[$_]) . "]\n"} (0..$#res); + debug "\t left: [" . esc($str) . "]\n"; + debug "\t pos: [" . esc(substr($str,pos($str))) . "...]\n"; + print "not " if (substr($str,pos($str),1) eq ';')==$neg; + print "ok ", $count++; + print "\n"; + } + + eval $setup_cmd if $setup_cmd ne ''; + if($tests =~ /s/) { + $str = $orig; + debug "\tUsing: scalar $cmd\n"; + debug "\t on: [" . esc($str) . "]\n"; + my $var = eval $cmd; + print " ($@)" if $@ && $DEBUG; + $var = "" unless defined $var; + debug "\t scalar got: [" . esc($var) . "]\n"; + debug "\t scalar left: [" . esc($str) . "]\n"; + print "not " if ($str =~ '\A;')==$neg; + print "ok ", $count++; + print "\n"; + } } # fails in Text::Balanced 1.95 @@ -71,7 +79,7 @@ print "not " if $z[0] eq ''; print "ok ", $count++; print "\n"; - + __DATA__ # USING: extract_quotelike($str); @@ -92,9 +100,9 @@ __DATA__ <<""; done()\nline1\nline2\n\n and next <<; done()\nline1\nline2\n\n and next # fails in Text::Balanced 1.95 -<{pat}>{$self->{sub}}; # CAN'T HANDLE '>' in '->' -s-$self->{pap}-$self->{sub}-; # CAN'T HANDLE '-' in '->' -<{pat}>{$self->{sub}}; # CAN'T HANDLE '>' in '->' +s-$self->{pap}-$self->{sub}-; # CAN'T HANDLE '-' in '->' +<>>",@_ if $DEBUG } ######################### End of black magic. +## no critic (BuiltinFunctions::ProhibitStringyEval) -$cmd = "print"; -$neg = 0; +my $cmd = "print"; +my $neg = 0; +my $str; while (defined($str = )) { - chomp $str; - if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } - elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } - elsif (!$str || $str =~ /\A#/) { $neg = 0; next } - $str =~ s/\\n/\n/g; - debug "\tUsing: $cmd\n"; - debug "\t on: [$str]\n"; - - my @res; - $var = eval "\@res = $cmd"; - debug "\t list got: [" . join("|",map {defined $_ ? $_ : ''} @res) . "]\n"; - debug "\t list left: [$str]\n"; - print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; - - pos $str = 0; - $var = eval $cmd; - $var = "" unless defined $var; - debug "\t scalar got: [$var]\n"; - debug "\t scalar left: [$str]\n"; - print "not " if ($str =~ '\A;')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; + chomp $str; + if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } + elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } + elsif (!$str || $str =~ /\A#/) { $neg = 0; next } + $str =~ s/\\n/\n/g; + debug "\tUsing: $cmd\n"; + debug "\t on: [$str]\n"; + + my @res; + my $var = eval "\@res = $cmd"; + debug "\t list got: [" . join("|",map {defined $_ ? $_ : ''} @res) . "]\n"; + debug "\t list left: [$str]\n"; + print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; + + pos $str = 0; + $var = eval $cmd; + $var = "" unless defined $var; + debug "\t scalar got: [$var]\n"; + debug "\t scalar left: [$str]\n"; + print "not " if ($str =~ '\A;')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; } __DATA__ # USING: gen_extract_tagged("BEGIN([A-Z]+)",'END$1',"(?s).*?(?=BEGIN)")->($str); - ignore\n this and then BEGINHERE at the ENDHERE; - ignore\n this and then BEGINTHIS at the ENDTHIS; + ignore\n this and then BEGINHERE at the ENDHERE; + ignore\n this and then BEGINTHIS at the ENDTHIS; # USING: extract_tagged($str,"BEGIN([A-Z]+)",'END$1',"(?s).*?(?=BEGIN)"); - ignore\n this and then BEGINHERE at the ENDHERE; - ignore\n this and then BEGINTHIS at the ENDTHIS; + ignore\n this and then BEGINHERE at the ENDHERE; + ignore\n this and then BEGINTHIS at the ENDTHIS; # USING: extract_tagged($str,"BEGIN([A-Z]+)",'END$1',"(?s).*?(?=BEGIN)"); - ignore\n this and then BEGINHERE at the ENDHERE; - ignore\n this and then BEGINTHIS at the ENDTHIS; + ignore\n this and then BEGINHERE at the ENDHERE; + ignore\n this and then BEGINTHIS at the ENDTHIS; # THIS SHOULD FAIL - ignore\n this and then BEGINTHIS at the ENDTHAT; + ignore\n this and then BEGINTHIS at the ENDTHAT; # USING: extract_tagged($str,"BEGIN","END","(?s).*?(?=BEGIN)"); - ignore\n this and then BEGIN at the END; + ignore\n this and then BEGIN at the END; # USING: extract_tagged($str); - some text; + some text; # USING: extract_tagged($str,qr/<[A-Z]+>/,undef, undef, {ignore=>["
"]}); - aaabbb
cccddd; + aaabbb
cccddd; # USING: extract_tagged($str,"BEGIN","END"); - BEGIN at the BEGIN keyword and END at the END; - BEGIN at the beginning and end at the END; + BEGIN at the BEGIN keyword and END at the END; + BEGIN at the beginning and end at the END; # USING: extract_tagged($str,undef,undef,undef,{ignore=>["<[^>]*/>"]}); - aaabbb
cccddd; + aaabbb
cccddd; # USING: extract_tagged($str,";","-",undef,{reject=>[";"],fail=>"MAX"}); - ; at the ;-) keyword + ; at the ;-) keyword # USING: extract_tagged($str,"<[A-Z]+>",undef, undef, {ignore=>["
"]}); - aaabbb
cccddd; + aaabbb
cccddd; # THESE SHOULD FAIL - BEGIN at the beginning and end at the end; - BEGIN at the BEGIN keyword and END at the end; + BEGIN at the beginning and end at the end; + BEGIN at the BEGIN keyword and END at the end; # TEST EXTRACTION OF TAGGED STRINGS # USING: extract_tagged($str,"BEGIN","END",undef,{reject=>["BEGIN","END"]}); # THESE SHOULD FAIL - BEGIN at the BEGIN keyword and END at the end; + BEGIN at the BEGIN keyword and END at the end; # USING: extract_tagged($str,";","-",undef,{reject=>[";"],fail=>"PARA"}); - ; at the ;-) keyword + ; at the ;-) keyword # USING: extract_tagged($str); - some text; - some textother text; - some textother text; - some text; + some text; + some textother text; + some textother text; + some text; # THESE SHOULD FAIL - some text - some textother text; - some textother text; + some text + some textother text; + some textother text; diff --git a/cpan/Text-Balanced/t/08_extvar.t b/cpan/Text-Balanced/t/08_extvar.t index a33ac919ecab..f527b843e0c4 100644 --- a/cpan/Text-Balanced/t/08_extvar.t +++ b/cpan/Text-Balanced/t/08_extvar.t @@ -1,53 +1,61 @@ # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' +use 5.008001; + +use strict; +use warnings; + ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) +my $loaded = 0; BEGIN { $| = 1; print "1..183\n"; } END {print "not ok 1\n" unless $loaded;} use Text::Balanced qw ( extract_variable ); $loaded = 1; print "ok 1\n"; -$count=2; +my $count=2; use vars qw( $DEBUG ); sub debug { print "\t>>>",@_ if $DEBUG } ######################### End of black magic. +## no critic (BuiltinFunctions::ProhibitStringyEval) -$cmd = "print"; -$neg = 0; +my $cmd = "print"; +my $neg = 0; +my $str; while (defined($str = )) { - chomp $str; - if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } - elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } - elsif (!$str || $str =~ /\A#/) { $neg = 0; next } - $str =~ s/\\n/\n/g; - debug "\tUsing: $cmd\n"; - debug "\t on: [$str]\n"; + chomp $str; + if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } + elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } + elsif (!$str || $str =~ /\A#/) { $neg = 0; next } + $str =~ s/\\n/\n/g; + debug "\tUsing: $cmd\n"; + debug "\t on: [$str]\n"; - my @res; - $var = eval "\@res = $cmd"; - debug "\t list got: [" . join("|",map {defined $_ ? $_ : ''} @res) . "]\n"; - debug "\t list left: [$str]\n"; - print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; + my @res; + my $var = eval "\@res = $cmd"; + debug "\t list got: [" . join("|",map {defined $_ ? $_ : ''} @res) . "]\n"; + debug "\t list left: [$str]\n"; + print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; - pos $str = 0; - $var = eval $cmd; - $var = "" unless defined $var; - debug "\t scalar got: [$var]\n"; - debug "\t scalar left: [$str]\n"; - print "not " if ($str =~ '\A;')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; + pos $str = 0; + $var = eval $cmd; + $var = "" unless defined $var; + debug "\t scalar got: [$var]\n"; + debug "\t scalar left: [$str]\n"; + print "not " if ($str =~ '\A;')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; } __DATA__ diff --git a/cpan/Text-Balanced/t/09_gentag.t b/cpan/Text-Balanced/t/09_gentag.t index 0dd55a5f3fa9..1a82ae1e211e 100644 --- a/cpan/Text-Balanced/t/09_gentag.t +++ b/cpan/Text-Balanced/t/09_gentag.t @@ -1,102 +1,115 @@ # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' +use 5.008001; + +use strict; +use warnings; + ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) +my $loaded = 0; BEGIN { $| = 1; print "1..37\n"; } END {print "not ok 1\n" unless $loaded;} use Text::Balanced qw ( gen_extract_tagged ); $loaded = 1; print "ok 1\n"; -$count=2; +my $count=2; use vars qw( $DEBUG ); sub debug { print "\t>>>",@_ if $DEBUG } ######################### End of black magic. +## no critic (BuiltinFunctions::ProhibitStringyEval) -$cmd = "print"; -$neg = 0; +my $cmd = "print"; +my $neg = 0; +my $str; while (defined($str = )) { - chomp $str; - $str =~ s/\\n/\n/g; - if ($str =~ s/\A# USING://) - { - $neg = 0; - eval{local$^W;*f = eval $str || die}; - next; - } - elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } - elsif (!$str || $str =~ /\A#/) { $neg = 0; next } - $str =~ s/\\n/\n/g; - debug "\tUsing: $cmd\n"; - debug "\t on: [$str]\n"; - - my @res; - $var = eval { @res = f($str) }; - debug "\t list got: [" . join("|",map {defined $_ ? $_ : ''} @res) . "]\n"; - debug "\t list left: [$str]\n"; - print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; - - pos $str = 0; - $var = eval { scalar f($str) }; - $var = "" unless defined $var; - debug "\t scalar got: [$var]\n"; - debug "\t scalar left: [$str]\n"; - print "not " if ($str =~ '\A;')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; + chomp $str; + $str =~ s/\\n/\n/g; + if ($str =~ s/\A# USING://) + { + $neg = 0; + eval { + # Capture "Subroutine main::f redefined" warning + my @warnings; + local $SIG{__WARN__} = sub { push @warnings, shift; }; + *f = eval $str || die; + }; + next; + } + elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } + elsif (!$str || $str =~ /\A#/) { $neg = 0; next } + $str =~ s/\\n/\n/g; + debug "\tUsing: $cmd\n"; + debug "\t on: [$str]\n"; + + my @res; + my $var = eval { @res = f($str) }; + debug "\t list got: [" . join("|",map {defined $_ ? $_ : ''} @res) . "]\n"; + debug "\t list left: [$str]\n"; + print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; + + pos $str = 0; + $var = eval { scalar f($str) }; + $var = "" unless defined $var; + debug "\t scalar got: [$var]\n"; + debug "\t scalar left: [$str]\n"; + print "not " if ($str =~ '\A;')==$neg; + print "ok ", $count++; + print " ($@)" if $@ && $DEBUG; + print "\n"; } __DATA__ # USING: gen_extract_tagged('{','}'); - { a test }; + { a test }; # USING: gen_extract_tagged(qr/<[A-Z]+>/,undef, undef, {ignore=>["
"]}); - aaabbb
cccddd; + aaabbb
cccddd; # USING: gen_extract_tagged("BEGIN","END"); - BEGIN at the BEGIN keyword and END at the END; - BEGIN at the beginning and end at the END; + BEGIN at the BEGIN keyword and END at the END; + BEGIN at the beginning and end at the END; # USING: gen_extract_tagged(undef,undef,undef,{ignore=>["<[^>]*/>"]}); - aaabbb
cccddd; + aaabbb
cccddd; # USING: gen_extract_tagged(";","-",undef,{reject=>[";"],fail=>"MAX"}); - ; at the ;-) keyword + ; at the ;-) keyword # USING: gen_extract_tagged("<[A-Z]+>",undef, undef, {ignore=>["
"]}); - aaabbb
cccddd; + aaabbb
cccddd; # THESE SHOULD FAIL - BEGIN at the beginning and end at the end; - BEGIN at the BEGIN keyword and END at the end; + BEGIN at the beginning and end at the end; + BEGIN at the BEGIN keyword and END at the end; # TEST EXTRACTION OF TAGGED STRINGS # USING: gen_extract_tagged("BEGIN","END",undef,{reject=>["BEGIN","END"]}); # THESE SHOULD FAIL - BEGIN at the BEGIN keyword and END at the end; + BEGIN at the BEGIN keyword and END at the end; # USING: gen_extract_tagged(";","-",undef,{reject=>[";"],fail=>"PARA"}); - ; at the ;-) keyword + ; at the ;-) keyword # USING: gen_extract_tagged(); - some text; - some textother text; - some textother text; - some text; + some text; + some textother text; + some textother text; + some text; # THESE SHOULD FAIL - some text - some textother text; - some textother text; + some text + some textother text; + some textother text; diff --git a/cpan/Text-Balanced/t/94_changes.t b/cpan/Text-Balanced/t/94_changes.t new file mode 100644 index 000000000000..400ec890938a --- /dev/null +++ b/cpan/Text-Balanced/t/94_changes.t @@ -0,0 +1,48 @@ +#!perl +#=============================================================================== +# +# t/94_changes.t +# +# DESCRIPTION +# Test script to check CPAN::Changes conformance. +# +# COPYRIGHT +# Copyright (C) 2015 Steve Hay. All rights reserved. +# +# LICENCE +# This script is free software; you can redistribute it and/or modify it under +# the same terms as Perl itself, i.e. under the terms of either the GNU +# General Public License or the Artistic License, as specified in the LICENCE +# file. +# +#=============================================================================== + +use 5.008001; + +use strict; +use warnings; + +use Test::More; + +#=============================================================================== +# MAIN PROGRAM +#=============================================================================== + +MAIN: { + plan skip_all => 'Author testing only' unless $ENV{AUTHOR_TESTING}; + + my $ok = eval { + require Test::CPAN::Changes; + Test::CPAN::Changes->import(); + 1; + }; + + if (not $ok) { + plan skip_all => 'Test::CPAN::Changes required to test Changes'; + } + else { + changes_ok(); + } +} + +#=============================================================================== diff --git a/cpan/Text-Balanced/t/95_critic.t b/cpan/Text-Balanced/t/95_critic.t new file mode 100644 index 000000000000..1e575423eb78 --- /dev/null +++ b/cpan/Text-Balanced/t/95_critic.t @@ -0,0 +1,48 @@ +#!perl +#=============================================================================== +# +# t/95_critic.t +# +# DESCRIPTION +# Test script to check Perl::Critic conformance. +# +# COPYRIGHT +# Copyright (C) 2015 Steve Hay. All rights reserved. +# +# LICENCE +# This script is free software; you can redistribute it and/or modify it under +# the same terms as Perl itself, i.e. under the terms of either the GNU +# General Public License or the Artistic License, as specified in the LICENCE +# file. +# +#=============================================================================== + +use 5.008001; + +use strict; +use warnings; + +use Test::More; + +#=============================================================================== +# MAIN PROGRAM +#=============================================================================== + +MAIN: { + plan skip_all => 'Author testing only' unless $ENV{AUTHOR_TESTING}; + + my $ok = eval { + require Test::Perl::Critic; + Test::Perl::Critic->import(-profile => ''); + 1; + }; + + if (not $ok) { + plan skip_all => 'Test::Perl::Critic required to test with Perl::Critic'; + } + else { + all_critic_ok('.'); + } +} + +#=============================================================================== diff --git a/cpan/Text-Balanced/t/96_pmv.t b/cpan/Text-Balanced/t/96_pmv.t new file mode 100644 index 000000000000..e1197da5de5a --- /dev/null +++ b/cpan/Text-Balanced/t/96_pmv.t @@ -0,0 +1,32 @@ +#!/usr/bin/perl + +# Test that our declared minimum Perl version matches our syntax + +use 5.008001; + +use strict; +use warnings; + +use Test::More; + +my @MODULES = ( + 'Perl::MinimumVersion 1.20', + 'Test::MinimumVersion 0.101082', +); + +# Don't run tests for installs +use Test::More; +unless ( $ENV{AUTHOR_TESTING} ) { + plan( skip_all => "Author testing only" ); +} + +# Load the testing modules +foreach my $MODULE ( @MODULES ) { + ## no critic (BuiltinFunctions::ProhibitStringyEval) + eval "use $MODULE"; + if ( $@ ) { + plan( skip_all => "$MODULE not available for testing" ); + } +} + +all_minimum_version_from_mymetayml_ok(); diff --git a/cpan/Text-Balanced/t/97_pod.t b/cpan/Text-Balanced/t/97_pod.t new file mode 100644 index 000000000000..d0f4caec64a1 --- /dev/null +++ b/cpan/Text-Balanced/t/97_pod.t @@ -0,0 +1,32 @@ +#!/usr/bin/perl + +# Test that the syntax of our POD documentation is valid + +use 5.008001; + +use strict; +use warnings; + +use Test::More; + +my @MODULES = ( + 'Pod::Simple 3.07', + 'Test::Pod 1.26', +); + +# Don't run tests for installs +use Test::More; +unless ( $ENV{AUTHOR_TESTING} ) { + plan( skip_all => "Author testing only" ); +} + +# Load the testing modules +foreach my $MODULE ( @MODULES ) { + ## no critic (BuiltinFunctions::ProhibitStringyEval) + eval "use $MODULE"; + if ( $@ ) { + plan( skip_all => "$MODULE not available for testing" ); + } +} + +all_pod_files_ok(); diff --git a/cpan/Text-Balanced/t/98_pod_coverage.t b/cpan/Text-Balanced/t/98_pod_coverage.t new file mode 100644 index 000000000000..cce4f94c6088 --- /dev/null +++ b/cpan/Text-Balanced/t/98_pod_coverage.t @@ -0,0 +1,51 @@ +#!perl +#=============================================================================== +# +# t/99_pod_coverage.t +# +# DESCRIPTION +# Test script to check POD coverage. +# +# COPYRIGHT +# Copyright (C) 2015 Steve Hay. All rights reserved. +# +# LICENCE +# This script is free software; you can redistribute it and/or modify it under +# the same terms as Perl itself, i.e. under the terms of either the GNU +# General Public License or the Artistic License, as specified in the LICENCE +# file. +# +#=============================================================================== + +use 5.008001; + +use strict; +use warnings; + +use Test::More; + +#=============================================================================== +# MAIN PROGRAM +#=============================================================================== + +MAIN: { + plan skip_all => 'Author testing only' unless $ENV{AUTHOR_TESTING}; + + my $ok = eval { + require Test::Pod::Coverage; + Test::Pod::Coverage->import(); + 1; + }; + + if (not $ok) { + plan skip_all => 'Test::Pod::Coverage required to test POD coverage'; + } + elsif ($Test::Pod::Coverage::VERSION < 0.08) { + plan skip_all => 'Test::Pod::Coverage 0.08 or higher required to test POD coverage'; + } + else { + all_pod_coverage_ok(); + } +} + +#=============================================================================== diff --git a/cpan/Unicode-Collate/.gitignore b/cpan/Unicode-Collate/.gitignore index 424c745c1253..47489b4d1f9f 100644 --- a/cpan/Unicode-Collate/.gitignore +++ b/cpan/Unicode-Collate/.gitignore @@ -1 +1,2 @@ *.h +!/Makefile.PL diff --git a/cpan/Win32/.gitignore b/cpan/Win32/.gitignore new file mode 100644 index 000000000000..e54624d60d99 --- /dev/null +++ b/cpan/Win32/.gitignore @@ -0,0 +1 @@ +!/Makefile.PL diff --git a/cpan/Win32API-File/.gitignore b/cpan/Win32API-File/.gitignore new file mode 100644 index 000000000000..e54624d60d99 --- /dev/null +++ b/cpan/Win32API-File/.gitignore @@ -0,0 +1 @@ +!/Makefile.PL diff --git a/cpan/libnet/.gitignore b/cpan/libnet/.gitignore new file mode 100644 index 000000000000..e54624d60d99 --- /dev/null +++ b/cpan/libnet/.gitignore @@ -0,0 +1 @@ +!/Makefile.PL diff --git a/cpan/libnet/Makefile.PL b/cpan/libnet/Makefile.PL index 73be0a165449..df525269b217 100644 --- a/cpan/libnet/Makefile.PL +++ b/cpan/libnet/Makefile.PL @@ -7,7 +7,7 @@ # Makefile creation script. # # COPYRIGHT -# Copyright (C) 2014, 2015 Steve Hay. All rights reserved. +# Copyright (C) 2014-2015, 2020 Steve Hay. All rights reserved. # # LICENCE # This script is free software; you can redistribute it and/or modify it under @@ -66,7 +66,7 @@ MAIN: { ABSTRACT => 'Collection of network protocol modules', AUTHOR => 'Graham Barr , Steve Hay ', LICENSE => 'perl_5', - VERSION => '3.11', + VERSION => '3.13', META_MERGE => { 'meta-spec' => { @@ -76,7 +76,7 @@ MAIN: { resources => { repository => { type => 'git', - url => 'https://github.com/steve-m-hay/perl-libnet.git' + web => 'https://github.com/steve-m-hay/perl-libnet' } }, diff --git a/cpan/libnet/lib/Net/Cmd.pm b/cpan/libnet/lib/Net/Cmd.pm index b695f64dd056..41df8a264ac7 100644 --- a/cpan/libnet/lib/Net/Cmd.pm +++ b/cpan/libnet/lib/Net/Cmd.pm @@ -1,7 +1,7 @@ # Net::Cmd.pm # # Copyright (C) 1995-2006 Graham Barr. All rights reserved. -# Copyright (C) 2013-2016 Steve Hay. All rights reserved. +# Copyright (C) 2013-2016, 2020 Steve Hay. All rights reserved. # This module is free software; you can redistribute it and/or modify it under # the same terms as Perl itself, i.e. under the terms of either the GNU General # Public License or the Artistic License, as specified in the F file. @@ -26,7 +26,7 @@ BEGIN { } } -our $VERSION = "3.11"; +our $VERSION = "3.13"; our @ISA = qw(Exporter); our @EXPORT = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING); @@ -100,7 +100,7 @@ sub _print_isa { sub debug { - @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([LEVEL])'; + @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([$level])'; my ($cmd, $level) = @_; my $pkg = ref($cmd) || $cmd; @@ -175,7 +175,7 @@ sub status { sub set_status { - @_ == 3 or croak 'usage: $obj->set_status(CODE, MESSAGE)'; + @_ == 3 or croak 'usage: $obj->set_status($code, $resp)'; my $cmd = shift; my ($code, $resp) = @_; @@ -661,59 +661,59 @@ C, C or C) then you must provide the following methods by other means yourself: C and C. -=head1 USER METHODS +=head2 Public Methods These methods provide a user interface to the C object. =over 4 -=item debug ( VALUE ) +=item C -Set the level of debug information for this object. If C is not given +Set the level of debug information for this object. If C<$level> is not given then the current state is returned. Otherwise the state is changed to -C and the previous state returned. +C<$level> and the previous state returned. Different packages may implement different levels of debug but a non-zero value results in copies of all commands and responses also being sent to STDERR. -If C is C then the debug level will be set to the default +If C<$level> is C then the debug level will be set to the default debug level for the class. This method can also be called as a I method to set/get the default debug level for a given class. -=item message () +=item C Returns the text message returned from the last command. In a scalar context it returns a single string, in a list context it will return each line as a separate element. (See L below.) -=item code () +=item C Returns the 3-digit code from the last command. If a command is pending then the value 0 is returned. (See L below.) -=item ok () +=item C Returns non-zero if the last code value was greater than zero and less than 400. This holds true for most command servers. Servers where this does not hold may override this method. -=item status () +=item C Returns the most significant digit of the current status code. If a command is pending then C is returned. -=item datasend ( DATA ) +=item C Send data to the remote server, converting LF to CRLF. Any line starting with a '.' will be prefixed with another '.'. -C may be an array or a reference to an array. -The C passed in must be encoded by the caller to octets of whatever +C<$data> may be an array or a reference to an array. +The C<$data> passed in must be encoded by the caller to octets of whatever encoding is required, e.g. by using the Encode module's C function. -=item dataend () +=item C End the sending of data to the remote server. This is done by ensuring that the data already sent ends with CRLF then sending '.CRLF' to end the @@ -722,28 +722,28 @@ returns true if C returns CMD_OK. =back -=head1 CLASS METHODS +=head2 Protected Methods These methods are not intended to be called by the user, but used or over-ridden by a sub-class of C =over 4 -=item debug_print ( DIR, TEXT ) +=item C -Print debugging information. C denotes the direction I being +Print debugging information. C<$dir> denotes the direction I being data being sent to the server. Calls C before printing to STDERR. -=item debug_text ( DIR, TEXT ) +=item C -This method is called to print debugging information. TEXT is +This method is called to print debugging information. C<$text> is the text being sent. The method should return the text to be printed. This is primarily meant for the use of modules such as FTP where passwords are sent, but we do not want to display them in the debugging information. -=item command ( CMD [, ARGS, ... ]) +=item C Send a command to the command server. All arguments are first joined with a space character and CRLF is appended, this string is then sent to the @@ -751,24 +751,24 @@ command server. Returns undef upon failure. -=item unsupported () +=item C Sets the status code to 580 and the response text to 'Unsupported command'. Returns zero. -=item response () +=item C Obtain a response from the server. Upon success the most significant digit of the status code is returned. Upon failure, timeout etc., I is returned. -=item parse_response ( TEXT ) +=item C This method is called by C as a method with one argument. It should return an array of 2 values, the 3-digit status code and a flag which is true when this is part of a multi-line response and this line is not the last. -=item getline () +=item C Retrieve one line, delimited by CRLF, from the remote server. Returns I upon failure. @@ -776,26 +776,26 @@ upon failure. B: If you do use this method for any reason, please remember to add some C calls into your method. -=item ungetline ( TEXT ) +=item C Unget a line of text from the server. -=item rawdatasend ( DATA ) +=item C -Send data to the remote server without performing any conversions. C +Send data to the remote server without performing any conversions. C<$data> is a scalar. -As with C, the C passed in must be encoded by the caller +As with C, the C<$data> passed in must be encoded by the caller to octets of whatever encoding is required, e.g. by using the Encode module's C function. -=item read_until_dot () +=item C Read data from the remote server until a line consisting of a single '.'. Any lines starting with '..' will have one of the '.'s removed. Returns a reference to a list containing the lines, or I upon failure. -=item tied_fh () +=item C Returns a filehandle tied to the Net::Cmd object. After issuing a command, you may read from this filehandle using read() or <>. The @@ -807,7 +807,7 @@ See the Net::POP3 and Net::SMTP modules for examples of this. =back -=head1 PSEUDO RESPONSES +=head2 Pseudo Responses Normally the values returned by C and C are obtained from the remote server, but in a few circumstances, as @@ -847,22 +847,47 @@ or otherwise trap this error. =head1 EXPORTS -C exports six subroutines, five of these, C, C, -C, C and C, correspond to possible results -of C and C. The sixth is C. +The following symbols are, or can be, exported by this module: + +=over 4 + +=item Default Exports + +C, +C, +C, +C, +C, +C. + +(These correspond to possible results of C and C.) + +=item Optional Exports + +I. + +=item Export Tags + +I. + +=back + +=head1 KNOWN BUGS + +See L. =head1 AUTHOR -Graham Barr EFE. +Graham Barr ELE. -Steve Hay EFE is now maintaining libnet as of version -1.22_02. +Steve Hay ELE is now maintaining +libnet as of version 1.22_02. =head1 COPYRIGHT Copyright (C) 1995-2006 Graham Barr. All rights reserved. -Copyright (C) 2013-2016 Steve Hay. All rights reserved. +Copyright (C) 2013-2016, 2020 Steve Hay. All rights reserved. =head1 LICENCE @@ -870,4 +895,16 @@ This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself, i.e. under the terms of either the GNU General Public License or the Artistic License, as specified in the F file. +=head1 VERSION + +Version 3.13 + +=head1 DATE + +23 Dec 2020 + +=head1 HISTORY + +See the F file. + =cut diff --git a/cpan/libnet/lib/Net/Config.pm b/cpan/libnet/lib/Net/Config.pm index 4f822a40a45e..2f8417f01a59 100644 --- a/cpan/libnet/lib/Net/Config.pm +++ b/cpan/libnet/lib/Net/Config.pm @@ -1,7 +1,7 @@ # Net::Config.pm # # Copyright (C) 2000 Graham Barr. All rights reserved. -# Copyright (C) 2013-2014, 2016 Steve Hay. All rights reserved. +# Copyright (C) 2013-2014, 2016, 2020 Steve Hay. All rights reserved. # This module is free software; you can redistribute it and/or modify it under # the same terms as Perl itself, i.e. under the terms of either the GNU General # Public License or the Artistic License, as specified in the F file. @@ -18,7 +18,7 @@ use Socket qw(inet_aton inet_ntoa); our @EXPORT = qw(%NetConfig); our @ISA = qw(Net::LocalCfg Exporter); -our $VERSION = "3.11"; +our $VERSION = "3.13"; our($CONFIGURE, $LIBNET_CFG); @@ -159,7 +159,7 @@ For example } __END__ -=head1 METHODS +=head2 Class Methods C defines the following methods. They are methods as they are invoked as class methods. This is because C inherits from @@ -167,7 +167,7 @@ C so you can override these methods if you want. =over 4 -=item requires_firewall ( HOST ) +=item C Attempts to determine if a given host is outside your firewall. Possible return values are. @@ -181,7 +181,7 @@ the configuration data. =back -=head1 NetConfig VALUES +=head2 NetConfig Values =over 4 @@ -323,18 +323,42 @@ If true then C will check each hostname given that it exists =back +=head1 EXPORTS + +The following symbols are, or can be, exported by this module: + +=over 4 + +=item Default Exports + +C<%NetConfig>. + +=item Optional Exports + +I. + +=item Export Tags + +I. + +=back + +=head1 KNOWN BUGS + +I. + =head1 AUTHOR -Graham Barr EFE. +Graham Barr ELE. -Steve Hay EFE is now maintaining libnet as of version -1.22_02. +Steve Hay ELE is now maintaining +libnet as of version 1.22_02. =head1 COPYRIGHT -Copyright (C) 1998-2011 Graham Barr. All rights reserved. +Copyright (C) 2000 Graham Barr. All rights reserved. -Copyright (C) 2013-2014, 2016 Steve Hay. All rights reserved. +Copyright (C) 2013-2014, 2016, 2020 Steve Hay. All rights reserved. =head1 LICENCE @@ -342,4 +366,16 @@ This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself, i.e. under the terms of either the GNU General Public License or the Artistic License, as specified in the F file. +=head1 VERSION + +Version 3.13 + +=head1 DATE + +23 Dec 2020 + +=head1 HISTORY + +See the F file. + =cut diff --git a/cpan/libnet/lib/Net/Domain.pm b/cpan/libnet/lib/Net/Domain.pm index 556cc1598075..d69ac5ba8051 100644 --- a/cpan/libnet/lib/Net/Domain.pm +++ b/cpan/libnet/lib/Net/Domain.pm @@ -1,7 +1,7 @@ # Net::Domain.pm # # Copyright (C) 1995-1998 Graham Barr. All rights reserved. -# Copyright (C) 2013-2014 Steve Hay. All rights reserved. +# Copyright (C) 2013-2014, 2020 Steve Hay. All rights reserved. # This module is free software; you can redistribute it and/or modify it under # the same terms as Perl itself, i.e. under the terms of either the GNU General # Public License or the Artistic License, as specified in the F file. @@ -19,7 +19,7 @@ use Net::Config; our @ISA = qw(Exporter); our @EXPORT_OK = qw(hostname hostdomain hostfqdn domainname); -our $VERSION = "3.11"; +our $VERSION = "3.13"; my ($host, $domain, $fqdn) = (undef, undef, undef); @@ -321,40 +321,71 @@ of the current host. From this determine the host-name and the host-domain. Each of the functions will return I if the FQDN cannot be determined. +=head2 Functions + =over 4 -=item hostfqdn () +=item C Identify and return the FQDN of the current host. -=item domainname () +=item C -An alias for hostfqdn (). +An alias for hostfqdn(). -=item hostname () +=item C Returns the smallest part of the FQDN which can be used to identify the host. -=item hostdomain () +=item C Returns the remainder of the FQDN after the I has been removed. =back +=head1 EXPORTS + +The following symbols are, or can be, exported by this module: + +=over 4 + +=item Default Exports + +I. + +=item Optional Exports + +C, +C, +C, +C. + +=item Export Tags + +I. + +=back + + +=head1 KNOWN BUGS + +See L. + =head1 AUTHOR -Graham Barr EFE. +Graham Barr ELE. -Adapted from Sys::Hostname by David Sundstrom EFE. +Adapted from Sys::Hostname by David Sundstrom +ELE. -Steve Hay EFE is now maintaining libnet as of version -1.22_02. +Steve Hay ELE is now maintaining +libnet as of version 1.22_02. =head1 COPYRIGHT Copyright (C) 1995-1998 Graham Barr. All rights reserved. -Copyright (C) 2013-2014 Steve Hay. All rights reserved. +Copyright (C) 2013-2014, 2020 Steve Hay. All rights reserved. =head1 LICENCE @@ -362,4 +393,16 @@ This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself, i.e. under the terms of either the GNU General Public License or the Artistic License, as specified in the F file. +=head1 VERSION + +Version 3.13 + +=head1 DATE + +23 Dec 2020 + +=head1 HISTORY + +See the F file. + =cut diff --git a/cpan/libnet/lib/Net/FTP.pm b/cpan/libnet/lib/Net/FTP.pm index 14153be0d0c0..37836bf6578b 100644 --- a/cpan/libnet/lib/Net/FTP.pm +++ b/cpan/libnet/lib/Net/FTP.pm @@ -1,7 +1,7 @@ # Net::FTP.pm # # Copyright (C) 1995-2004 Graham Barr. All rights reserved. -# Copyright (C) 2013-2017 Steve Hay. All rights reserved. +# Copyright (C) 2013-2017, 2020 Steve Hay. All rights reserved. # This module is free software; you can redistribute it and/or modify it under # the same terms as Perl itself, i.e. under the terms of either the GNU General # Public License or the Artistic License, as specified in the F file. @@ -23,7 +23,7 @@ use Net::Config; use Socket; use Time::Local; -our $VERSION = '3.11'; +our $VERSION = '3.13'; our $IOCLASS; my $family_key; @@ -110,10 +110,13 @@ sub new { # use SNI if supported by IO::Socket::SSL $pkg->can_client_sni ? (SSL_hostname => $hostname):(), # reuse SSL session of control connection in data connections - SSL_session_cache => Net::FTP::_SSL_SingleSessionCache->new, + SSL_session_cache_size => 10, + SSL_session_key => $hostname, ); # user defined SSL arg $tlsargs{$_} = $arg{$_} for(grep { m{^SSL_} } keys %arg); + $tlsargs{SSL_reuse_ctx} = IO::Socket::SSL::SSL_Context->new(%tlsargs) + or return; } elsif ($arg{SSL}) { croak("IO::Socket::SSL >= 2.007 needed for SSL support"); @@ -262,7 +265,7 @@ sub mdtm { $ftp->_MDTM($file) && $ftp->message =~ /((\d\d)(\d\d\d?))(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/ - ? timegm($8, $7, $6, $5, $4 - 1, $2 eq '19' ? $3 : ($1 - 1900)) + ? timegm($8, $7, $6, $5, $4 - 1, $2 eq '19' ? ($3 + 1900) : $1) : undef; } @@ -426,7 +429,7 @@ sub login { sub account { - @_ == 2 or croak 'usage: $ftp->account( ACCT )'; + @_ == 2 or croak 'usage: $ftp->account($acct)'; my $ftp = shift; my $acct = shift; $ftp->_ACCT($acct) == CMD_OK; @@ -452,7 +455,7 @@ sub _auth_id { sub authorize { - @_ >= 1 || @_ <= 3 or croak 'usage: $ftp->authorize( [AUTH [, RESP]])'; + @_ >= 1 || @_ <= 3 or croak 'usage: $ftp->authorize([$auth[, $resp]])'; my ($ftp, $auth, $resp) = &_auth_id; @@ -466,12 +469,12 @@ sub authorize { sub rename { - @_ == 3 or croak 'usage: $ftp->rename(FROM, TO)'; + @_ == 3 or croak 'usage: $ftp->rename($oldname, $newname)'; - my ($ftp, $from, $to) = @_; + my ($ftp, $oldname, $newname) = @_; - $ftp->_RNFR($from) - && $ftp->_RNTO($to); + $ftp->_RNFR($oldname) + && $ftp->_RNTO($newname); } @@ -619,7 +622,7 @@ sub get { sub cwd { - @_ == 1 || @_ == 2 or croak 'usage: $ftp->cwd( [ DIR ] )'; + @_ == 1 || @_ == 2 or croak 'usage: $ftp->cwd([$dir])'; my ($ftp, $dir) = @_; @@ -656,7 +659,7 @@ sub pwd { # Initial version contributed by Dinkum Software # sub rmdir { - @_ == 2 || @_ == 3 or croak('usage: $ftp->rmdir( DIR [, RECURSE ] )'); + @_ == 2 || @_ == 3 or croak('usage: $ftp->rmdir($dir[, $recurse])'); # Pick off the args my ($ftp, $dir, $recurse) = @_; @@ -702,7 +705,7 @@ sub rmdir { sub restart { - @_ == 2 || croak 'usage: $ftp->restart( BYTE_OFFSET )'; + @_ == 2 || croak 'usage: $ftp->restart($where)'; my ($ftp, $where) = @_; @@ -713,7 +716,7 @@ sub restart { sub mkdir { - @_ == 2 || @_ == 3 or croak 'usage: $ftp->mkdir( DIR [, RECURSE ] )'; + @_ == 2 || @_ == 3 or croak 'usage: $ftp->mkdir($dir[, $recurse])'; my ($ftp, $dir, $recurse) = @_; @@ -758,7 +761,7 @@ sub mkdir { sub delete { - @_ == 2 || croak 'usage: $ftp->delete( FILENAME )'; + @_ == 2 || croak 'usage: $ftp->delete($filename)'; $_[0]->_DELE($_[1]); } @@ -881,12 +884,12 @@ sub _store_cmd { sub port { - @_ == 1 || @_ == 2 or croak 'usage: $self->port([PORT])'; + @_ == 1 || @_ == 2 or croak 'usage: $self->port([$port])'; return _eprt('PORT',@_); } sub eprt { - @_ == 1 || @_ == 2 or croak 'usage: $self->eprt([PORT])'; + @_ == 1 || @_ == 2 or croak 'usage: $self->eprt([$port])'; return _eprt('EPRT',@_); } @@ -959,7 +962,7 @@ sub unique_name { sub supported { - @_ == 2 or croak 'usage: $ftp->supported( CMD )'; + @_ == 2 or croak 'usage: $ftp->supported($cmd)'; my $ftp = shift; my $cmd = uc shift; my $hash = ${*$ftp}{'net_ftp_supported'} ||= {}; @@ -1282,36 +1285,36 @@ sub pasv_xfer { sub pasv_wait { - @_ == 2 or croak 'usage: $ftp->pasv_wait(NON_PASV_FTP)'; + @_ == 2 or croak 'usage: $ftp->pasv_wait($non_pasv_server)'; - my ($ftp, $non_pasv) = @_; + my ($ftp, $non_pasv_server) = @_; my ($file, $rin, $rout); vec($rin = '', fileno($ftp), 1) = 1; select($rout = $rin, undef, undef, undef); my $dres = $ftp->response(); - my $sres = $non_pasv->response(); + my $sres = $non_pasv_server->response(); return unless $dres == CMD_OK && $sres == CMD_OK; return - unless $ftp->ok() && $non_pasv->ok(); + unless $ftp->ok() && $non_pasv_server->ok(); return $1 if $ftp->message =~ /unique file name:\s*(\S*)\s*\)/; return $1 - if $non_pasv->message =~ /unique file name:\s*(\S*)\s*\)/; + if $non_pasv_server->message =~ /unique file name:\s*(\S*)\s*\)/; return 1; } sub feature { - @_ == 2 or croak 'usage: $ftp->feature( NAME )'; - my ($ftp, $feat) = @_; + @_ == 2 or croak 'usage: $ftp->feature($name)'; + my ($ftp, $name) = @_; my $feature = ${*$ftp}{net_ftp_feature} ||= do { my @feat; @@ -1329,7 +1332,7 @@ sub feature { \@feat; }; - return grep { /^\Q$feat\E\b/i } @$feature; + return grep { /^\Q$name\E\b/i } @$feature; } @@ -1397,25 +1400,6 @@ sub _SYST { shift->unsupported(@_) } sub _STRU { shift->unsupported(@_) } sub _REIN { shift->unsupported(@_) } -{ - # Session Cache with single entry - # used to make sure that we reuse same session for control and data channels - package Net::FTP::_SSL_SingleSessionCache; - sub new { my $x; return bless \$x,shift } - sub add_session { - my ($cache,$key,$session) = @_; - Net::SSLeay::SESSION_free($$cache) if $$cache; - $$cache = $session; - } - sub get_session { - my $cache = shift; - return $$cache - } - sub DESTROY { - my $cache = shift; - Net::SSLeay::SESSION_free($$cache) if $$cache; - } -} 1; @@ -1456,7 +1440,7 @@ and explicit FTPS as defined in RFC4217. The Net::FTP class is a subclass of Net::Cmd and (depending on avaibility) of IO::Socket::IP, IO::Socket::INET6 or IO::Socket::INET. -=head1 OVERVIEW +=head2 Overview FTP stands for File Transfer Protocol. It is a way of transferring files between networked machines. The protocol defines a client @@ -1487,19 +1471,19 @@ this if you really know what you're doing). This class does not support the EBCDIC or byte formats, and will default to binary instead if they are attempted. -=head1 CONSTRUCTOR +=head2 Class Methods =over 4 -=item new ([ HOST ] [, OPTIONS ]) +=item C -This is the constructor for a new Net::FTP object. C is the +This is the constructor for a new Net::FTP object. C<$host> is the name of the remote host to which an FTP connection is required. -C is optional. If C is not given then it may instead be +C<$host> is optional. If C<$host> is not given then it may instead be passed as the C option described below. -C are passed in a hash like fashion, using key and value pairs. +C<%options> are passed in a hash like fashion, using key and value pairs. Possible options are: B - FTP host to connect to. It may be a single scalar, as defined for @@ -1570,7 +1554,7 @@ be in $@ =back -=head1 METHODS +=head2 Object Methods Unless otherwise stated all methods return either a I or I value, with I meaning that the operation was a success. When a method @@ -1583,7 +1567,7 @@ documented here. =over 4 -=item login ([LOGIN [,PASSWORD [, ACCOUNT] ] ]) +=item C Log into the remote FTP server with the given login information. If no arguments are given then the C uses the C @@ -1595,114 +1579,114 @@ will be used for password. If the connection is via a firewall then the C method will be called with no arguments. -=item starttls () +=item C Upgrade existing plain connection to SSL. The SSL arguments have to be given in C already because they are needed for data connections too. -=item stoptls () +=item C Downgrade existing SSL connection back to plain. This is needed to work with some FTP helpers at firewalls, which need to see the PORT and PASV commands and responses to dynamically open the necessary ports. In this case C is usually only done to protect the authorization. -=item prot ( LEVEL ) +=item C Set what type of data channel protection the client and server will be using. -Only Cs "C" (clear) and "P" (private) are supported. +Only C<$level>s "C" (clear) and "P" (private) are supported. -=item host () +=item C Returns the value used by the constructor, and passed to the IO::Socket super class to connect to the host. -=item account( ACCT ) +=item C Set a string identifying the user's account. -=item authorize ( [AUTH [, RESP]]) +=item C This is a protocol used by some firewall ftp proxies. It is used to authorise the user to send data out. If both arguments are not specified then C uses C to do a lookup. -=item site (ARGS) +=item C Send a SITE command to the remote server and wait for a response. Returns most significant digit of the response code. -=item ascii () +=item C Transfer file in ASCII. CRLF translation will be done if required -=item binary () +=item C Transfer file in binary mode. No transformation will be done. B: If both server and client machines use the same line ending for text files, then it will be faster to transfer all files in binary mode. -=item type ( [ TYPE ] ) +=item C Set or get if files will be transferred in ASCII or binary mode. -=item rename ( OLDNAME, NEWNAME ) +=item C -Rename a file on the remote FTP server from C to C. This +Rename a file on the remote FTP server from C<$oldname> to C<$newname>. This is done by sending the RNFR and RNTO commands. -=item delete ( FILENAME ) +=item C -Send a request to the server to delete C. +Send a request to the server to delete C<$filename>. -=item cwd ( [ DIR ] ) +=item C Attempt to change directory to the directory given in C<$dir>. If C<$dir> is C<"..">, the FTP C command is used to attempt to move up one directory. If no directory is given then an attempt is made to change the directory to the root directory. -=item cdup () +=item C Change directory to the parent of the current directory. -=item passive ( [ PASSIVE ] ) +=item C Set or get if data connections will be initiated in passive mode. -=item pwd () +=item C Returns the full pathname of the current directory. -=item restart ( WHERE ) +=item C Set the byte offset at which to begin the next data transfer. Net::FTP simply records this value and uses it when during the next data transfer. For this reason this method will not return an error, but setting it may cause a subsequent data transfer to fail. -=item rmdir ( DIR [, RECURSE ]) +=item C -Remove the directory with the name C. If C is I then +Remove the directory with the name C<$dir>. If C<$recurse> is I then C will attempt to delete everything inside the directory. -=item mkdir ( DIR [, RECURSE ]) +=item C -Create a new directory with the name C. If C is I then +Create a new directory with the name C<$dir>. If C<$recurse> is I then C will attempt to create all the directories in the given path. Returns the full pathname to the new directory. -=item alloc ( SIZE [, RECORD_SIZE] ) +=item C The alloc command allows you to give the ftp server a hint about the size of the file about to be transferred using the ALLO ftp command. Some storage systems use this to make intelligent decisions about how to store the file. -The C argument represents the size of the file in bytes. The -C argument indicates a maximum record or page size for files +The C<$size> argument represents the size of the file in bytes. The +C<$record_size> argument indicates a maximum record or page size for files sent with a record or page structure. The size of the file will be determined, and sent to the server @@ -1710,70 +1694,70 @@ automatically for normal files so that this method need only be called if you are transferring data from a socket, named pipe, or other stream not associated with a normal file. -=item ls ( [ DIR ] ) +=item C -Get a directory listing of C, or the current directory. +Get a directory listing of C<$dir>, or the current directory. In an array context, returns a list of lines returned from the server. In a scalar context, returns a reference to a list. -=item dir ( [ DIR ] ) +=item C -Get a directory listing of C, or the current directory in long format. +Get a directory listing of C<$dir>, or the current directory in long format. In an array context, returns a list of lines returned from the server. In a scalar context, returns a reference to a list. -=item get ( REMOTE_FILE [, LOCAL_FILE [, WHERE]] ) +=item C -Get C from the server and store locally. C may be +Get C<$remote_file> from the server and store locally. C<$local_file> may be a filename or a filehandle. If not specified, the file will be stored in the current directory with the same leafname as the remote file. -If C is given then the first C bytes of the file will +If C<$where> is given then the first C<$where> bytes of the file will not be transferred, and the remaining bytes will be appended to the local file if it already exists. -Returns C, or the generated local file name if C +Returns C<$local_file>, or the generated local file name if C<$local_file> is not given. If an error was encountered undef is returned. -=item put ( LOCAL_FILE [, REMOTE_FILE ] ) +=item C -Put a file on the remote server. C may be a name or a filehandle. -If C is a filehandle then C must be specified. If -C is not specified then the file will be stored in the current -directory with the same leafname as C. +Put a file on the remote server. C<$local_file> may be a name or a filehandle. +If C<$local_file> is a filehandle then C<$remote_file> must be specified. If +C<$remote_file> is not specified then the file will be stored in the current +directory with the same leafname as C<$local_file>. -Returns C, or the generated remote filename if C +Returns C<$remote_file>, or the generated remote filename if C<$remote_file> is not given. B: If for some reason the transfer does not complete and an error is returned then the contents that had been transferred will not be remove automatically. -=item put_unique ( LOCAL_FILE [, REMOTE_FILE ] ) +=item C Same as put but uses the C command. Returns the name of the file on the server. -=item append ( LOCAL_FILE [, REMOTE_FILE ] ) +=item C Same as put but appends to the file on the remote server. -Returns C, or the generated remote filename if C +Returns C<$remote_file>, or the generated remote filename if C<$remote_file> is not given. -=item unique_name () +=item C Returns the name of the last file stored on the server using the C command. -=item mdtm ( FILE ) +=item C Returns the I of the given file -=item size ( FILE ) +=item C Returns the size in bytes for the given file as stored on the remote server. @@ -1783,11 +1767,11 @@ and the remote server and local machine have different ideas about "End Of Line" then the size of file on the local machine after transfer may be different. -=item supported ( CMD ) +=item C Returns TRUE if the remote server supports the given command. -=item hash ( [FILEHANDLE_GLOB_REF],[ BYTES_PER_HASH_MARK] ) +=item C Called without parameters, or with the first argument false, hash marks are suppressed. If the first argument is true but not a reference to a @@ -1796,7 +1780,7 @@ of bytes per hash mark printed, and defaults to 1024. In all cases the return value is a reference to an array of two: the filehandle glob reference and the bytes per hash mark. -=item feature ( NAME ) +=item C Determine if the server supports the specified feature. The return value is a list of lines the server responded with to describe the @@ -1822,33 +1806,33 @@ reference to a C based object. =over 4 -=item nlst ( [ DIR ] ) +=item C Send an C command to the server, with an optional parameter. -=item list ( [ DIR ] ) +=item C Same as C but using the C command -=item retr ( FILE ) +=item C -Begin the retrieval of a file called C from the remote server. +Begin the retrieval of a file called C<$file> from the remote server. -=item stor ( FILE ) +=item C -Tell the server that you wish to store a file. C is the +Tell the server that you wish to store a file. C<$file> is the name of the new file that should be created. -=item stou ( FILE ) +=item C Same as C but using the C command. The name of the unique file which was created on the server will be available via the C method after the data connection has been closed. -=item appe ( FILE ) +=item C Tell the server that we want to append some data to the end of a file -called C. If this file does not exist then create it. +called C<$file>. If this file does not exist then create it. =back @@ -1862,17 +1846,17 @@ C and those that do not require data connections. =over 4 -=item port ( [ PORT ] ) +=item C -=item eprt ( [ PORT ] ) +=item C -Send a C (IPv4) or C (IPv6) command to the server. If C is +Send a C (IPv4) or C (IPv6) command to the server. If C<$port> is specified then it is sent to the server. If not, then a listen socket is created and the correct information sent to the server. -=item pasv () +=item C -=item epsv () +=item C Tell the server to go into passive mode (C for IPv4, C for IPv6). Returns the text that represents the port on which the server is listening, this @@ -1886,38 +1870,38 @@ servers, providing that these two servers can connect directly to each other. =over 4 -=item pasv_xfer ( SRC_FILE, DEST_SERVER [, DEST_FILE ] ) +=item C This method will do a file transfer between two remote ftp servers. If -C is omitted then the leaf name of C will be used. +C<$dest_file> is omitted then the leaf name of C<$src_file> will be used. -=item pasv_xfer_unique ( SRC_FILE, DEST_SERVER [, DEST_FILE ] ) +=item C Like C but the file is stored on the remote server using the STOU command. -=item pasv_wait ( NON_PASV_SERVER ) +=item C This method can be used to wait for a transfer to complete between a passive server and a non-passive server. The method should be called on the passive server with the C object for the non-passive server passed as an argument. -=item abort () +=item C Abort the current data transfer. -=item quit () +=item C Send the QUIT command to the remote FTP server and close the socket connection. =back -=head2 Methods for the adventurous +=head2 Methods for the Adventurous =over 4 -=item quot (CMD [,ARGS]) +=item C Send a command, that Net::FTP does not directly support, to the remote server and wait for a response. @@ -1927,62 +1911,83 @@ Returns most significant digit of the response code. B This call should only be used on commands that do not require data connections. Misuse of this method can hang the connection. -=item can_inet6 () +=item C Returns whether we can use IPv6. -=item can_ssl () +=item C Returns whether we can use SSL. =back -=head1 THE dataconn CLASS +=head2 The dataconn Class Some of the methods defined in C return an object which will be derived from the C class. See L for more details. -=head1 UNIMPLEMENTED +=head2 Unimplemented The following RFC959 commands have not been implemented: =over 4 -=item B +=item C Mount a different file system structure without changing login or accounting information. -=item B +=item C Ask the server for "helpful information" (that's what the RFC says) on the commands it accepts. -=item B +=item C Specifies transfer mode (stream, block or compressed) for file to be transferred. -=item B +=item C Request remote server system identification. -=item B +=item C Request remote server status. -=item B +=item C Specifies file structure for file to be transferred. -=item B +=item C Reinitialize the connection, flushing all I/O and account information. =back -=head1 REPORTING BUGS +=head1 EXAMPLES + +For an example of the use of Net::FTP see + +=over 4 + +=item L + +C is a program that can retrieve, send, or list files via +the FTP protocol in a non-interactive manner. + +=back + +=head1 EXPORTS + +I. + +=head1 KNOWN BUGS + +See L. + +=head2 Reporting Bugs When reporting bugs/problems please include as much information as possible. It may be difficult for me to reproduce the problem as almost every setup @@ -1994,51 +1999,42 @@ passed to the constructor, and the output sent with the bug report. If you cannot include a small script then please include a Debug trace from a run of your program which does yield the problem. -=head1 AUTHOR - -Graham Barr EFE. - -Steve Hay EFE is now maintaining libnet as of version -1.22_02. - =head1 SEE ALSO L, L, -L +L; -ftp(1), ftpd(8), RFC 959, RFC 2428, RFC 4217 -http://www.ietf.org/rfc/rfc959.txt -http://www.ietf.org/rfc/rfc2428.txt -http://www.ietf.org/rfc/rfc4217.txt +L, +L; -=head1 USE EXAMPLES +L, +L, +L. -For an example of the use of Net::FTP see +=head1 ACKNOWLEDGEMENTS -=over 4 +Henry Gabryjelski ELE - for the +suggestion of creating directories recursively. -=item http://www.csh.rit.edu/~adam/Progs/ +Nathan Torkington ELE - for some +input on the documentation. -C is a program that can retrieve, send, or list files via -the FTP protocol in a non-interactive manner. +Roderick Schertler ELE - for +various inputs -=back - -=head1 CREDITS - -Henry Gabryjelski - for the suggestion of creating directories -recursively. +=head1 AUTHOR -Nathan Torkington - for some input on the documentation. +Graham Barr ELE. -Roderick Schertler - for various inputs +Steve Hay ELE is now maintaining +libnet as of version 1.22_02. =head1 COPYRIGHT Copyright (C) 1995-2004 Graham Barr. All rights reserved. -Copyright (C) 2013-2017 Steve Hay. All rights reserved. +Copyright (C) 2013-2017, 2020 Steve Hay. All rights reserved. =head1 LICENCE @@ -2046,4 +2042,16 @@ This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself, i.e. under the terms of either the GNU General Public License or the Artistic License, as specified in the F file. +=head1 VERSION + +Version 3.13 + +=head1 DATE + +23 Dec 2020 + +=head1 HISTORY + +See the F file. + =cut diff --git a/cpan/libnet/lib/Net/FTP/A.pm b/cpan/libnet/lib/Net/FTP/A.pm index 0ea1ba2fbd23..53446386c180 100644 --- a/cpan/libnet/lib/Net/FTP/A.pm +++ b/cpan/libnet/lib/Net/FTP/A.pm @@ -13,7 +13,7 @@ use Carp; use Net::FTP::dataconn; our @ISA = qw(Net::FTP::dataconn); -our $VERSION = "3.11"; +our $VERSION = "3.13"; our $buf; diff --git a/cpan/libnet/lib/Net/FTP/E.pm b/cpan/libnet/lib/Net/FTP/E.pm index 30b371a58b14..9b1370778a8d 100644 --- a/cpan/libnet/lib/Net/FTP/E.pm +++ b/cpan/libnet/lib/Net/FTP/E.pm @@ -8,6 +8,6 @@ use warnings; use Net::FTP::I; our @ISA = qw(Net::FTP::I); -our $VERSION = "3.11"; +our $VERSION = "3.13"; 1; diff --git a/cpan/libnet/lib/Net/FTP/I.pm b/cpan/libnet/lib/Net/FTP/I.pm index ec46ab0fdabd..726cba197c33 100644 --- a/cpan/libnet/lib/Net/FTP/I.pm +++ b/cpan/libnet/lib/Net/FTP/I.pm @@ -13,7 +13,7 @@ use Carp; use Net::FTP::dataconn; our @ISA = qw(Net::FTP::dataconn); -our $VERSION = "3.11"; +our $VERSION = "3.13"; our $buf; diff --git a/cpan/libnet/lib/Net/FTP/L.pm b/cpan/libnet/lib/Net/FTP/L.pm index d9a88576d991..ac5e27ebadcd 100644 --- a/cpan/libnet/lib/Net/FTP/L.pm +++ b/cpan/libnet/lib/Net/FTP/L.pm @@ -8,6 +8,6 @@ use warnings; use Net::FTP::I; our @ISA = qw(Net::FTP::I); -our $VERSION = "3.11"; +our $VERSION = "3.13"; 1; diff --git a/cpan/libnet/lib/Net/FTP/dataconn.pm b/cpan/libnet/lib/Net/FTP/dataconn.pm index 337b0e999bc5..5a257e677ffa 100644 --- a/cpan/libnet/lib/Net/FTP/dataconn.pm +++ b/cpan/libnet/lib/Net/FTP/dataconn.pm @@ -13,7 +13,7 @@ use Carp; use Errno; use Net::Cmd; -our $VERSION = '3.11'; +our $VERSION = '3.13'; $Net::FTP::IOCLASS or die "please load Net::FTP before Net::FTP::dataconn"; our @ISA = $Net::FTP::IOCLASS; @@ -137,6 +137,22 @@ __END__ Net::FTP::dataconn - FTP Client data connection class +=head1 SYNOPSIS + + # Perform IO operations on an FTP client data connection object: + + $num_bytes_read = $obj->read($buffer, $size); + $num_bytes_read = $obj->read($buffer, $size, $timeout); + + $num_bytes_written = $obj->write($buffer, $size); + $num_bytes_written = $obj->write($buffer, $size, $timeout); + + $num_bytes_read_so_far = $obj->bytes_read(); + + $obj->abort(); + + $closed_successfully = $obj->close(); + =head1 DESCRIPTION Some of the methods defined in C return an object which will @@ -147,31 +163,31 @@ be performed using these. =over 4 -=item read ( BUFFER, SIZE [, TIMEOUT ] ) +=item C -Read C bytes of data from the server and place it into C, also -performing any translation necessary. C is optional, if not +Read C<$size> bytes of data from the server and place it into C<$buffer>, also +performing any translation necessary. C<$timeout> is optional, if not given, the timeout value from the command connection will be used. Returns the number of bytes read before any translation. -=item write ( BUFFER, SIZE [, TIMEOUT ] ) +=item C -Write C bytes of data from C to the server, also -performing any translation necessary. C is optional, if not +Write C<$size> bytes of data from C<$buffer> to the server, also +performing any translation necessary. C<$timeout> is optional, if not given, the timeout value from the command connection will be used. Returns the number of bytes written before any translation. -=item bytes_read () +=item C Returns the number of bytes read so far. -=item abort () +=item C Abort the current data transfer. -=item close () +=item C Close the data connection and get a response from the FTP server. Returns I if the connection was closed successfully and the first digit of @@ -179,4 +195,43 @@ the response from the server was a '2'. =back +=head1 EXPORTS + +I. + +=head1 KNOWN BUGS + +I. + +=head1 AUTHOR + +Graham Barr ELE. + +Steve Hay ELE is now maintaining +libnet as of version 1.22_02. + +=head1 COPYRIGHT + +Copyright (C) 1997-2010 Graham Barr. All rights reserved. + +Copyright (C) 2013-2014, 2020 Steve Hay. All rights reserved. + +=head1 LICENCE + +This module is free software; you can redistribute it and/or modify it under the +same terms as Perl itself, i.e. under the terms of either the GNU General Public +License or the Artistic License, as specified in the F file. + +=head1 VERSION + +Version 3.13 + +=head1 DATE + +23 Dec 2020 + +=head1 HISTORY + +See the F file. + =cut diff --git a/cpan/libnet/lib/Net/NNTP.pm b/cpan/libnet/lib/Net/NNTP.pm index 0c22930148a5..3187f519619f 100644 --- a/cpan/libnet/lib/Net/NNTP.pm +++ b/cpan/libnet/lib/Net/NNTP.pm @@ -1,7 +1,7 @@ # Net::NNTP.pm # # Copyright (C) 1995-1997 Graham Barr. All rights reserved. -# Copyright (C) 2013-2016 Steve Hay. All rights reserved. +# Copyright (C) 2013-2016, 2020 Steve Hay. All rights reserved. # This module is free software; you can redistribute it and/or modify it under # the same terms as Perl itself, i.e. under the terms of either the GNU General # Public License or the Artistic License, as specified in the F file. @@ -19,7 +19,7 @@ use Net::Cmd; use Net::Config; use Time::Local; -our $VERSION = "3.11"; +our $VERSION = "3.13"; # Code for detecting if we can use SSL my $ssl_class = eval { @@ -96,7 +96,6 @@ sub new { if ($arg{SSL}) { Net::NNTP::_SSL->start_SSL($obj,%arg) or next; } - last: } return @@ -176,7 +175,7 @@ sub starttls { sub article { - @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->article( [ MSGID ], [ FH ] )'; + @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->article([{$msgid|$msgnum}[, $fh]])'; my $nntp = shift; my @fh; @@ -189,7 +188,7 @@ sub article { sub articlefh { - @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->articlefh( [ MSGID ] )'; + @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->articlefh([{$msgid|$msgnum}])'; my $nntp = shift; return unless $nntp->_ARTICLE(@_); @@ -198,7 +197,7 @@ sub articlefh { sub authinfo { - @_ == 3 or croak 'usage: $nntp->authinfo( USER, PASS )'; + @_ == 3 or croak 'usage: $nntp->authinfo($user, $pass)'; my ($nntp, $user, $pass) = @_; $nntp->_AUTHINFO("USER", $user) == CMD_MORE @@ -207,7 +206,7 @@ sub authinfo { sub authinfo_simple { - @_ == 3 or croak 'usage: $nntp->authinfo( USER, PASS )'; + @_ == 3 or croak 'usage: $nntp->authinfo_simple($user, $pass)'; my ($nntp, $user, $pass) = @_; $nntp->_AUTHINFO('SIMPLE') == CMD_MORE @@ -216,7 +215,7 @@ sub authinfo_simple { sub body { - @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->body( [ MSGID ], [ FH ] )'; + @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->body([{$msgid|$msgnum}[, $fh]])'; my $nntp = shift; my @fh; @@ -229,7 +228,7 @@ sub body { sub bodyfh { - @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->bodyfh( [ MSGID ] )'; + @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->bodyfh([{$msgid|$msgnum}])'; my $nntp = shift; return unless $nntp->_BODY(@_); return $nntp->tied_fh; @@ -237,7 +236,7 @@ sub bodyfh { sub head { - @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->head( [ MSGID ], [ FH ] )'; + @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->head([{$msgid|$msgnum}[, $fh]])'; my $nntp = shift; my @fh; @@ -250,7 +249,7 @@ sub head { sub headfh { - @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->headfh( [ MSGID ] )'; + @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->headfh([{$msgid|$msgnum}])'; my $nntp = shift; return unless $nntp->_HEAD(@_); return $nntp->tied_fh; @@ -258,7 +257,7 @@ sub headfh { sub nntpstat { - @_ == 1 || @_ == 2 or croak 'usage: $nntp->nntpstat( [ MSGID ] )'; + @_ == 1 || @_ == 2 or croak 'usage: $nntp->nntpstat([{$msgid|$msgnum}])'; my $nntp = shift; $nntp->_STAT(@_) && $nntp->message =~ /(<[^>]+>)/o @@ -268,7 +267,7 @@ sub nntpstat { sub group { - @_ == 1 || @_ == 2 or croak 'usage: $nntp->group( [ GROUP ] )'; + @_ == 1 || @_ == 2 or croak 'usage: $nntp->group([$group])'; my $nntp = shift; my $grp = ${*$nntp}{'net_nntp_group'}; @@ -308,11 +307,11 @@ sub help { sub ihave { - @_ >= 2 or croak 'usage: $nntp->ihave( MESSAGE-ID [, MESSAGE ])'; - my $nntp = shift; - my $mid = shift; + @_ >= 2 or croak 'usage: $nntp->ihave($msgid[, $message])'; + my $nntp = shift; + my $msgid = shift; - $nntp->_IHAVE($mid) && $nntp->datasend(@_) + $nntp->_IHAVE($msgid) && $nntp->datasend(@_) ? @_ == 0 || $nntp->dataend : undef; } @@ -339,15 +338,15 @@ sub list { sub newgroups { - @_ >= 2 or croak 'usage: $nntp->newgroups( SINCE [, DISTRIBUTIONS ])'; + @_ >= 2 or croak 'usage: $nntp->newgroups($since[, $distributions])'; my $nntp = shift; - my $time = _timestr(shift); - my $dist = shift || ""; + my $since = _timestr(shift); + my $distributions = shift || ""; - $dist = join(",", @{$dist}) - if ref($dist); + $distributions = join(",", @{$distributions}) + if ref($distributions); - $nntp->_NEWGROUPS($time, $dist) + $nntp->_NEWGROUPS($since, $distributions) ? $nntp->_grouplist : undef; } @@ -355,20 +354,20 @@ sub newgroups { sub newnews { @_ >= 2 && @_ <= 4 - or croak 'usage: $nntp->newnews( SINCE [, GROUPS [, DISTRIBUTIONS ]])'; + or croak 'usage: $nntp->newnews($since[, $groups[, $distributions]])'; my $nntp = shift; - my $time = _timestr(shift); - my $grp = @_ ? shift: $nntp->group; - my $dist = shift || ""; + my $since = _timestr(shift); + my $groups = @_ ? shift : $nntp->group; + my $distributions = shift || ""; - $grp ||= "*"; - $grp = join(",", @{$grp}) - if ref($grp); + $groups ||= "*"; + $groups = join(",", @{$groups}) + if ref($groups); - $dist = join(",", @{$dist}) - if ref($dist); + $distributions = join(",", @{$distributions}) + if ref($distributions); - $nntp->_NEWNEWS($grp, $time, $dist) + $nntp->_NEWNEWS($groups, $since, $distributions) ? $nntp->_articlelist : undef; } @@ -385,7 +384,7 @@ sub next { sub post { - @_ >= 1 or croak 'usage: $nntp->post( [ MESSAGE ] )'; + @_ >= 1 or croak 'usage: $nntp->post([$message])'; my $nntp = shift; $nntp->_POST() && $nntp->datasend(@_) @@ -423,7 +422,7 @@ sub slave { sub active { - @_ == 1 || @_ == 2 or croak 'usage: $nntp->active( [ PATTERN ] )'; + @_ == 1 || @_ == 2 or croak 'usage: $nntp->active([$pattern])'; my $nntp = shift; $nntp->_LIST('ACTIVE', @_) @@ -453,7 +452,7 @@ sub distributions { sub distribution_patterns { - @_ == 1 or croak 'usage: $nntp->distributions()'; + @_ == 1 or croak 'usage: $nntp->distribution_patterns()'; my $nntp = shift; my $arr; @@ -468,7 +467,7 @@ sub distribution_patterns { sub newsgroups { - @_ == 1 || @_ == 2 or croak 'usage: $nntp->newsgroups( [ PATTERN ] )'; + @_ == 1 || @_ == 2 or croak 'usage: $nntp->newsgroups([$pattern])'; my $nntp = shift; $nntp->_LIST('NEWSGROUPS', @_) @@ -498,7 +497,7 @@ sub subscriptions { sub listgroup { - @_ == 1 || @_ == 2 or croak 'usage: $nntp->listgroup( [ GROUP ] )'; + @_ == 1 || @_ == 2 or croak 'usage: $nntp->listgroup([$group])'; my $nntp = shift; $nntp->_LISTGROUP(@_) @@ -516,7 +515,7 @@ sub reader { sub xgtitle { - @_ == 1 || @_ == 2 or croak 'usage: $nntp->xgtitle( [ PATTERN ] )'; + @_ == 1 || @_ == 2 or croak 'usage: $nntp->xgtitle([$pattern])'; my $nntp = shift; $nntp->_XGTITLE(@_) @@ -526,19 +525,19 @@ sub xgtitle { sub xhdr { - @_ >= 2 && @_ <= 4 or croak 'usage: $nntp->xhdr( HEADER, [ MESSAGE-SPEC ] )'; + @_ >= 2 && @_ <= 4 or croak 'usage: $nntp->xhdr($header[, $message_spec])'; my $nntp = shift; - my $hdr = shift; - my $arg = _msg_arg(@_); + my $header = shift; + my $arg = _msg_arg(@_); - $nntp->_XHDR($hdr, $arg) + $nntp->_XHDR($header, $arg) ? $nntp->_description : undef; } sub xover { - @_ == 2 || @_ == 3 or croak 'usage: $nntp->xover( MESSAGE-SPEC )'; + @_ == 2 || @_ == 3 or croak 'usage: $nntp->xover($message_spec)'; my $nntp = shift; my $arg = _msg_arg(@_); @@ -549,27 +548,27 @@ sub xover { sub xpat { - @_ == 4 || @_ == 5 or croak '$nntp->xpat( HEADER, PATTERN, MESSAGE-SPEC )'; + @_ == 4 || @_ == 5 or croak 'usage: $nntp->xpat($header, $pattern, $message_spec )'; my $nntp = shift; - my $hdr = shift; - my $pat = shift; - my $arg = _msg_arg(@_); + my $header = shift; + my $pattern = shift; + my $arg = _msg_arg(@_); - $pat = join(" ", @$pat) - if ref($pat); + $pattern = join(" ", @$pattern) + if ref($pattern); - $nntp->_XPAT($hdr, $arg, $pat) + $nntp->_XPAT($header, $arg, $pattern) ? $nntp->_description : undef; } sub xpath { - @_ == 2 or croak 'usage: $nntp->xpath( MESSAGE-ID )'; - my ($nntp, $mid) = @_; + @_ == 2 or croak 'usage: $nntp->xpath($message_id)'; + my ($nntp, $message_id) = @_; return - unless $nntp->_XPATH($mid); + unless $nntp->_XPATH($message_id); my $m; ($m = $nntp->message) =~ s/^\d+\s+//o; @@ -580,7 +579,7 @@ sub xpath { sub xrover { - @_ == 2 || @_ == 3 or croak 'usage: $nntp->xrover( MESSAGE-SPEC )'; + @_ == 2 || @_ == 3 or croak 'usage: $nntp->xrover($message_spec)'; my $nntp = shift; my $arg = _msg_arg(@_); @@ -596,7 +595,7 @@ sub date { $nntp->_DATE && $nntp->message =~ /(\d{4})(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/ - ? timegm($6, $5, $4, $3, $2 - 1, $1 - 1900) + ? timegm($6, $5, $4, $3, $2 - 1, $1) : undef; } @@ -807,20 +806,20 @@ explicit TLS encryption, i.e. NNTPS or NNTP+STARTTLS. The Net::NNTP class is a subclass of Net::Cmd and (depending on avaibility) of IO::Socket::IP, IO::Socket::INET6 or IO::Socket::INET. -=head1 CONSTRUCTOR +=head2 Class Methods =over 4 -=item new ( [ HOST ] [, OPTIONS ]) +=item C -This is the constructor for a new Net::NNTP object. C is the +This is the constructor for a new Net::NNTP object. C<$host> is the name of the remote host to which a NNTP connection is required. If not given then it may be passed as the C option described below. If no host is passed then two environment variables are checked, first C then C, then C is checked, and if a host is not found then C is used. -C are passed in a hash like fashion, using key and value pairs. +C<%options> are passed in a hash like fashion, using key and value pairs. Possible options are: B - NNTP host to connect to. It may be a single scalar, as defined for @@ -857,7 +856,7 @@ class. Alternatively B can be used. =back -=head1 METHODS +=head2 Object Methods Unless otherwise stated all methods return either a I or I value, with I meaning that the operation was a success. When a method @@ -870,58 +869,58 @@ documented here. =over 4 -=item host () +=item C Returns the value used by the constructor, and passed to IO::Socket::INET, to connect to the host. -=item starttls () +=item C Upgrade existing plain connection to SSL. Any arguments necessary for SSL must be given in C already. -=item article ( [ MSGID|MSGNUM ], [FH] ) +=item C Retrieve the header, a blank line, then the body (text) of the specified article. -If C is specified then it is expected to be a valid filehandle +If C<$fh> is specified then it is expected to be a valid filehandle and the result will be printed to it, on success a true value will be -returned. If C is not specified then the return value, on success, +returned. If C<$fh> is not specified then the return value, on success, will be a reference to an array containing the article requested, each entry in the array will contain one line of the article. If no arguments are passed then the current article in the currently selected newsgroup is fetched. -C is a numeric id of an article in the current newsgroup, and -will change the current article pointer. C is the message id of +C<$msgnum> is a numeric id of an article in the current newsgroup, and +will change the current article pointer. C<$msgid> is the message id of an article as shown in that article's header. It is anticipated that the -client will obtain the C from a list provided by the C +client will obtain the C<$msgid> from a list provided by the C command, from references contained within another article, or from the message-id provided in the response to some other commands. If there is an error then C will be returned. -=item body ( [ MSGID|MSGNUM ], [FH] ) +=item C Like C
but only fetches the body of the article. -=item head ( [ MSGID|MSGNUM ], [FH] ) +=item C Like C
but only fetches the headers for the article. -=item articlefh ( [ MSGID|MSGNUM ] ) +=item C -=item bodyfh ( [ MSGID|MSGNUM ] ) +=item C -=item headfh ( [ MSGID|MSGNUM ] ) +=item C These are similar to article(), body() and head(), but rather than returning the requested data directly, they return a tied filehandle from which to read the article. -=item nntpstat ( [ MSGID|MSGNUM ] ) +=item C The C command is similar to the C
command except that no text is returned. When selecting by message number within a group, @@ -934,9 +933,9 @@ selection by message-id does B alter the "current article pointer". Returns the message-id of the "current article". -=item group ( [ GROUP ] ) +=item C -Set and/or get the current group. If C is not given then information +Set and/or get the current group. If C<$group> is not given then information is returned on the current group. In a scalar context it returns the group name. @@ -945,45 +944,45 @@ In an array context the return value is a list containing, the number of articles in the group, the number of the first article, the number of the last article and the group name. -=item help ( ) +=item C Request help text (a short summary of commands that are understood by this implementation) from the server. Returns the text or undef upon failure. -=item ihave ( MSGID [, MESSAGE ]) +=item C The C command informs the server that the client has an article -whose id is C. If the server desires a copy of that -article and C has been given then it will be sent. +whose id is C<$msgid>. If the server desires a copy of that +article and C<$message> has been given then it will be sent. -Returns I if the server desires the article and C was +Returns I if the server desires the article and C<$message> was successfully sent, if specified. -If C is not specified then the message must be sent using the +If C<$message> is not specified then the message must be sent using the C and C methods from L -C can be either an array of lines or a reference to an array +C<$message> can be either an array of lines or a reference to an array and must be encoded by the caller to octets of whatever encoding is required, e.g. by using the Encode module's C function. -=item last () +=item C Set the "current article pointer" to the previous article in the current newsgroup. Returns the message-id of the article. -=item date () +=item C Returns the date on the remote server. This date will be in a UNIX time format (seconds since 1970) -=item postok () +=item C C will return I if the servers initial response indicated that it will allow posting. -=item authinfo ( USER, PASS ) +=item C Authenticates to the server (using the original AUTHINFO USER / AUTHINFO PASS form, defined in RFC2980) using the supplied username and password. Please @@ -991,61 +990,61 @@ note that the password is sent in clear text to the server. This command should not be used with valuable passwords unless the connection to the server is somehow protected. -=item authinfo_simple ( USER, PASS ) +=item C Authenticates to the server (using the proposed NNTP V2 AUTHINFO SIMPLE form, defined and deprecated in RFC2980) using the supplied username and password. As with L the password is sent in clear text. -=item list () +=item C Obtain information about all the active newsgroups. The results is a reference to a hash where the key is a group name and each value is a reference to an array. The elements in this array are:- the last article number in the group, the first article number in the group and any information flags about the group. -=item newgroups ( SINCE [, DISTRIBUTIONS ]) +=item C -C is a time value and C is either a distribution +C<$since> is a time value and C<$distributions> is either a distribution pattern or a reference to a list of distribution patterns. The result is the same as C, but the -groups return will be limited to those created after C and, if -specified, in one of the distribution areas in C. +groups return will be limited to those created after C<$since> and, if +specified, in one of the distribution areas in C<$distributions>. -=item newnews ( SINCE [, GROUPS [, DISTRIBUTIONS ]]) +=item C -C is a time value. C is either a group pattern or a reference -to a list of group patterns. C is either a distribution +C<$since> is a time value. C<$groups> is either a group pattern or a reference +to a list of group patterns. C<$distributions> is either a distribution pattern or a reference to a list of distribution patterns. Returns a reference to a list which contains the message-ids of all news posted -after C, that are in a groups which matched C and a -distribution which matches C. +after C<$since>, that are in a groups which matched C<$groups> and a +distribution which matches C<$distributions>. -=item next () +=item C Set the "current article pointer" to the next article in the current newsgroup. Returns the message-id of the article. -=item post ( [ MESSAGE ] ) +=item C -Post a new article to the news server. If C is specified and posting +Post a new article to the news server. If C<$message> is specified and posting is allowed then the message will be sent. -If C is not specified then the message must be sent using the +If C<$message> is not specified then the message must be sent using the C and C methods from L -C can be either an array of lines or a reference to an array +C<$message> can be either an array of lines or a reference to an array and must be encoded by the caller to octets of whatever encoding is required, e.g. by using the Encode module's C function. -The message, either sent via C or as the C +The message, either sent via C or as the C<$message> parameter, must be in the format as described by RFC822 and must contain From:, Newsgroups: and Subject: headers. -=item postfh () +=item C Post a new article to the news server using a tied filehandle. If posting is allowed, this method will return a tied filehandle that you @@ -1054,85 +1053,85 @@ explicitly close() the filehandle when you are finished posting the article, and the return value from the close() call will indicate whether the message was successfully posted. -=item slave () +=item C Tell the remote server that I am not a user client, but probably another news server. -=item quit () +=item C Quit the remote server and close the socket connection. -=item can_inet6 () +=item C Returns whether we can use IPv6. -=item can_ssl () +=item C Returns whether we can use SSL. =back -=head2 Extension methods +=head2 Extension Methods These methods use commands that are not part of the RFC977 documentation. Some servers may not support all of them. =over 4 -=item newsgroups ( [ PATTERN ] ) +=item C Returns a reference to a hash where the keys are all the group names which -match C, or all of the groups if no pattern is specified, and +match C<$pattern>, or all of the groups if no pattern is specified, and each value contains the description text for the group. -=item distributions () +=item C Returns a reference to a hash where the keys are all the possible distribution names and the values are the distribution descriptions. -=item distribution_patterns () +=item C Returns a reference to an array where each element, itself an array reference, consists of the three fields of a line of the distrib.pats list maintained by some NNTP servers, namely: a weight, a wildmat and a value which the client may use to construct a Distribution header. -=item subscriptions () +=item C Returns a reference to a list which contains a list of groups which are recommended for a new user to subscribe to. -=item overview_fmt () +=item C Returns a reference to an array which contain the names of the fields returned by C. -=item active_times () +=item C Returns a reference to a hash where the keys are the group names and each value is a reference to an array containing the time the groups was created and an identifier, possibly an Email address, of the creator. -=item active ( [ PATTERN ] ) +=item C Similar to C but only active groups that match the pattern are returned. -C can be a group pattern. +C<$pattern> can be a group pattern. -=item xgtitle ( PATTERN ) +=item C Returns a reference to a hash where the keys are all the group names which -match C and each value is the description text for the group. +match C<$pattern> and each value is the description text for the group. -=item xhdr ( HEADER, MESSAGE-SPEC ) +=item C -Obtain the header field C
for all the messages specified. +Obtain the header field C<$header> for all the messages specified. The return value will be a reference to a hash where the keys are the message numbers and each value contains the text of the requested header for that message. -=item xover ( MESSAGE-SPEC ) +=item C The return value will be a reference to a hash where the keys are the message numbers and each value contains @@ -1141,17 +1140,17 @@ message. The names of the fields can be obtained by calling C. -=item xpath ( MESSAGE-ID ) +=item C Returns the path name to the file on the server which contains the specified message. -=item xpat ( HEADER, PATTERN, MESSAGE-SPEC) +=item C The result is the same as C except the is will be restricted to -headers where the text of the header matches C +headers where the text of the header matches C<$pattern> -=item xrover () +=item C The XROVER command returns reference information for the article(s) specified. @@ -1159,12 +1158,12 @@ specified. Returns a reference to a HASH where the keys are the message numbers and the values are the References: lines from the articles -=item listgroup ( [ GROUP ] ) +=item C -Returns a reference to a list of all the active messages in C, or -the current group if C is not specified. +Returns a reference to a list of all the active messages in C<$group>, or +the current group if C<$group> is not specified. -=item reader () +=item C Tell the server that you are a reader and not another server. @@ -1179,7 +1178,7 @@ the response is harmless. =back -=head1 UNSUPPORTED +=head2 Unsupported The following NNTP command are unsupported by the package, and there are no plans to do so. @@ -1189,16 +1188,16 @@ no plans to do so. XSEARCH XINDEX -=head1 DEFINITIONS +=head2 Definitions =over 4 -=item MESSAGE-SPEC +=item $message_spec -C is either a single message-id, a single message number, or +C<$message_spec> is either a single message-id, a single message number, or a reference to a list of two message numbers. -If C is a reference to a list of two message numbers and the +If C<$message_spec> is a reference to a list of two message numbers and the second number in a range is less than or equal to the first then the range represents all messages in the group after the first message number. @@ -1206,7 +1205,7 @@ B For compatibility reasons only with earlier versions of Net::NNTP a message spec can be passed as a list of two numbers, this is deprecated and a reference to the list should now be passed -=item PATTERN +=item $pattern The C protocol uses the C format for patterns. The WILDMAT format was first developed by Rich Salz based on @@ -1275,23 +1274,31 @@ with a and ends with d. =back +=head1 EXPORTS + +I. + +=head1 KNOWN BUGS + +See L. + =head1 SEE ALSO L, -L +L. =head1 AUTHOR -Graham Barr EFE. +Graham Barr ELE. -Steve Hay EFE is now maintaining libnet as of version -1.22_02. +Steve Hay ELE is now maintaining +libnet as of version 1.22_02. =head1 COPYRIGHT Copyright (C) 1995-1997 Graham Barr. All rights reserved. -Copyright (C) 2013-2016 Steve Hay. All rights reserved. +Copyright (C) 2013-2016, 2020 Steve Hay. All rights reserved. =head1 LICENCE @@ -1299,4 +1306,16 @@ This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself, i.e. under the terms of either the GNU General Public License or the Artistic License, as specified in the F file. +=head1 VERSION + +Version 3.13 + +=head1 DATE + +23 Dec 2020 + +=head1 HISTORY + +See the F file. + =cut diff --git a/cpan/libnet/lib/Net/Netrc.pm b/cpan/libnet/lib/Net/Netrc.pm index 46fba2787c36..50688eefd62f 100644 --- a/cpan/libnet/lib/Net/Netrc.pm +++ b/cpan/libnet/lib/Net/Netrc.pm @@ -1,7 +1,7 @@ # Net::Netrc.pm # # Copyright (C) 1995-1998 Graham Barr. All rights reserved. -# Copyright (C) 2013-2014 Steve Hay. All rights reserved. +# Copyright (C) 2013-2014, 2020 Steve Hay. All rights reserved. # This module is free software; you can redistribute it and/or modify it under # the same terms as Perl itself, i.e. under the terms of either the GNU General # Public License or the Artistic License, as specified in the F file. @@ -16,7 +16,7 @@ use warnings; use Carp; use FileHandle; -our $VERSION = "3.11"; +our $VERSION = "3.13"; our $TESTING; @@ -224,7 +224,7 @@ second the ownership permissions should be such that only the owner has read and write access. If these conditions are not met then a warning is output and the .netrc file is not read. -=head1 THE .netrc FILE +=head2 The F<.netrc> File The .netrc file contains login and initialization information used by the auto-login process. It resides in the user's home directory. The following @@ -276,7 +276,7 @@ with I. =back -=head1 CONSTRUCTOR +=head2 Class Methods The constructor for a C object is not called new as it does not really create a new object. But instead is called C as this is @@ -284,11 +284,11 @@ essentially what it does. =over 4 -=item lookup ( MACHINE [, LOGIN ]) +=item C -Lookup and return a reference to the entry for C. If C is given -then the entry returned will have the given login. If C is not given then -the first entry in the .netrc file for C will be returned. +Lookup and return a reference to the entry for C<$machine>. If C<$login> is given +then the entry returned will have the given login. If C<$login> is not given then +the first entry in the .netrc file for C<$machine> will be returned. If a matching entry cannot be found, and a default entry exists, then a reference to the default entry is returned. @@ -298,45 +298,52 @@ no .netrc file is found, then C is returned. =back -=head1 METHODS +=head2 Object Methods =over 4 -=item login () +=item C Return the login id for the netrc entry -=item password () +=item C Return the password for the netrc entry -=item account () +=item C Return the account information for the netrc entry -=item lpa () +=item C Return a list of login, password and account information for the netrc entry =back -=head1 AUTHOR +=head1 EXPORTS + +I. -Graham Barr EFE. +=head1 KNOWN BUGS -Steve Hay EFE is now maintaining libnet as of version -1.22_02. +See L. =head1 SEE ALSO -L, -L +L. + +=head1 AUTHOR + +Graham Barr ELE. + +Steve Hay ELE is now maintaining +libnet as of version 1.22_02. =head1 COPYRIGHT Copyright (C) 1995-1998 Graham Barr. All rights reserved. -Copyright (C) 2013-2014 Steve Hay. All rights reserved. +Copyright (C) 2013-2014, 2020 Steve Hay. All rights reserved. =head1 LICENCE @@ -344,4 +351,16 @@ This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself, i.e. under the terms of either the GNU General Public License or the Artistic License, as specified in the F file. +=head1 VERSION + +Version 3.13 + +=head1 DATE + +23 Dec 2020 + +=head1 HISTORY + +See the F file. + =cut diff --git a/cpan/libnet/lib/Net/POP3.pm b/cpan/libnet/lib/Net/POP3.pm index 0811025b0a26..55f7be1342e3 100644 --- a/cpan/libnet/lib/Net/POP3.pm +++ b/cpan/libnet/lib/Net/POP3.pm @@ -1,7 +1,7 @@ # Net::POP3.pm # # Copyright (C) 1995-2004 Graham Barr. All rights reserved. -# Copyright (C) 2013-2016 Steve Hay. All rights reserved. +# Copyright (C) 2013-2016, 2020 Steve Hay. All rights reserved. # This module is free software; you can redistribute it and/or modify it under # the same terms as Perl itself, i.e. under the terms of either the GNU General # Public License or the Artistic License, as specified in the F file. @@ -18,7 +18,7 @@ use IO::Socket; use Net::Cmd; use Net::Config; -our $VERSION = "3.11"; +our $VERSION = "3.13"; # Code for detecting if we can use SSL my $ssl_class = eval { @@ -124,7 +124,7 @@ sub debug_text { $_[2] =~ /^(pass|rpop)/i ? "$1 ....\n" : $_[2]; } sub login { - @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->login( USER, PASS )'; + @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->login([$user[, $pass]])'; my ($me, $user, $pass) = @_; if (@_ <= 2) { @@ -147,7 +147,7 @@ sub starttls { } sub apop { - @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->apop( USER, PASS )'; + @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->apop([$user[, $pass]])'; my ($me, $user, $pass) = @_; my $banner; my $md; @@ -180,13 +180,13 @@ sub apop { sub user { - @_ == 2 or croak 'usage: $pop3->user( USER )'; + @_ == 2 or croak 'usage: $pop3->user($user)'; $_[0]->_USER($_[1]) ? 1 : undef; } sub pass { - @_ == 2 or croak 'usage: $pop3->pass( PASS )'; + @_ == 2 or croak 'usage: $pop3->pass($pass)'; my ($me, $pass) = @_; @@ -225,7 +225,7 @@ sub last { sub top { - @_ == 2 || @_ == 3 or croak 'usage: $pop3->top( MSGNUM [, NUMLINES ])'; + @_ == 2 || @_ == 3 or croak 'usage: $pop3->top($msgnum[, $numlines])'; my $me = shift; return @@ -247,7 +247,7 @@ sub popstat { sub list { - @_ == 1 || @_ == 2 or croak 'usage: $pop3->list( [ MSGNUM ] )'; + @_ == 1 || @_ == 2 or croak 'usage: $pop3->list([$msgnum])'; my $me = shift; return @@ -268,7 +268,7 @@ sub list { sub get { - @_ == 2 or @_ == 3 or croak 'usage: $pop3->get( MSGNUM [, FH ])'; + @_ == 2 or @_ == 3 or croak 'usage: $pop3->get($msgnum[, $fh])'; my $me = shift; return @@ -279,7 +279,7 @@ sub get { sub getfh { - @_ == 2 or croak 'usage: $pop3->getfh( MSGNUM )'; + @_ == 2 or croak 'usage: $pop3->getfh($msgnum)'; my $me = shift; return unless $me->_RETR(shift); @@ -288,7 +288,7 @@ sub getfh { sub delete { - @_ == 2 or croak 'usage: $pop3->delete( MSGNUM )'; + @_ == 2 or croak 'usage: $pop3->delete($msgnum)'; my $me = shift; return 0 unless $me->_DELE(@_); ${*$me}{'net_pop3_deleted'} = 1; @@ -296,7 +296,7 @@ sub delete { sub uidl { - @_ == 1 || @_ == 2 or croak 'usage: $pop3->uidl( [ MSGNUM ] )'; + @_ == 1 || @_ == 2 or croak 'usage: $pop3->uidl([$msgnum])'; my $me = shift; my $uidl; @@ -319,7 +319,7 @@ sub uidl { sub ping { - @_ == 2 or croak 'usage: $pop3->ping( USER )'; + @_ == 2 or croak 'usage: $pop3->ping($user)'; my $me = shift; return () unless $me->_PING(@_) && $me->message =~ /(\d+)\D+(\d+)/; @@ -635,21 +635,20 @@ on the object. The Net::POP3 class is a subclass of Net::Cmd and (depending on avaibility) of IO::Socket::IP, IO::Socket::INET6 or IO::Socket::INET. - -=head1 CONSTRUCTOR +=head2 Class Methods =over 4 -=item new ( [ HOST ] [, OPTIONS ] ) +=item C -This is the constructor for a new Net::POP3 object. C is the +This is the constructor for a new Net::POP3 object. C<$host> is the name of the remote host to which an POP3 connection is required. -C is optional. If C is not given then it may instead be +C<$host> is optional. If C<$host> is not given then it may instead be passed as the C option described below. If neither is given then the C specified in C will be used. -C are passed in a hash like fashion, using key and value pairs. +C<%options> are passed in a hash like fashion, using key and value pairs. Possible options are: B - POP3 host to connect to. It may be a single scalar, as defined for @@ -681,7 +680,7 @@ B - Enable debugging information =back -=head1 METHODS +=head2 Object Methods Unless otherwise stated all methods return either a I or I value, with I meaning that the operation was a success. When a method @@ -694,26 +693,26 @@ documented here. =over 4 -=item host () +=item C Returns the value used by the constructor, and passed to IO::Socket::INET, to connect to the host. -=item auth ( USERNAME, PASSWORD ) +=item C Attempt SASL authentication. -=item user ( USER ) +=item C Send the USER command. -=item pass ( PASS ) +=item C Send the PASS command. Returns the number of messages in the mailbox. -=item login ( [ USER [, PASS ]] ) +=item C -Send both the USER and PASS commands. If C is not given the +Send both the USER and PASS commands. If C<$pass> is not given the C uses C to lookup the password using the host and username. If the username is not specified then the current user name will be used. @@ -724,25 +723,25 @@ will give a true value in a boolean context, but zero in a numeric context. If there was an error authenticating the user then I will be returned. -=item starttls ( SSLARGS ) +=item C Upgrade existing plain connection to SSL. You can use SSL arguments as documented in L, but it will usually use the right arguments already. -=item apop ( [ USER [, PASS ]] ) +=item C -Authenticate with the server identifying as C with password C. +Authenticate with the server identifying as C<$user> with password C<$pass>. Similar to L, but the password is not sent in clear text. To use this method you must have the Digest::MD5 or the MD5 module installed, otherwise this method will return I. -=item banner () +=item C Return the sever's connection banner -=item capa () +=item C Return a reference to a hash of the capabilities of the server. APOP is added as a pseudo capability. Note that I've been unable to @@ -750,109 +749,117 @@ find a list of the standard capability values, and some appear to be multi-word and some are not. We make an attempt at intelligently parsing them, but it may not be correct. -=item capabilities () +=item C Just like capa, but only uses a cache from the last time we asked the server, so as to avoid asking more than once. -=item top ( MSGNUM [, NUMLINES ] ) +=item C -Get the header and the first C of the body for the message -C. Returns a reference to an array which contains the lines of text +Get the header and the first C<$numlines> of the body for the message +C<$msgnum>. Returns a reference to an array which contains the lines of text read from the server. -=item list ( [ MSGNUM ] ) +=item C If called with an argument the C returns the size of the message in octets. If called without arguments a reference to a hash is returned. The -keys will be the C's of all undeleted messages and the values will +keys will be the C<$msgnum>'s of all undeleted messages and the values will be their size in octets. -=item get ( MSGNUM [, FH ] ) +=item C -Get the message C from the remote mailbox. If C is not given +Get the message C<$msgnum> from the remote mailbox. If C<$fh> is not given then get returns a reference to an array which contains the lines of -text read from the server. If C is given then the lines returned -from the server are printed to the filehandle C. +text read from the server. If C<$fh> is given then the lines returned +from the server are printed to the filehandle C<$fh>. -=item getfh ( MSGNUM ) +=item C As per get(), but returns a tied filehandle. Reading from this filehandle returns the requested message. The filehandle will return EOF at the end of the message and should not be reused. -=item last () +=item C -Returns the highest C of all the messages accessed. +Returns the highest C<$msgnum> of all the messages accessed. -=item popstat () +=item C Returns a list of two elements. These are the number of undeleted elements and the size of the mbox in octets. -=item ping ( USER ) +=item C Returns a list of two elements. These are the number of new messages -and the total number of messages for C. +and the total number of messages for C<$user>. -=item uidl ( [ MSGNUM ] ) +=item C -Returns a unique identifier for C if given. If C is not +Returns a unique identifier for C<$msgnum> if given. If C<$msgnum> is not given C returns a reference to a hash where the keys are the message numbers and the values are the unique identifiers. -=item delete ( MSGNUM ) +=item C -Mark message C to be deleted from the remote mailbox. All messages +Mark message C<$msgnum> to be deleted from the remote mailbox. All messages that are marked to be deleted will be removed from the remote mailbox when the server connection closed. -=item reset () +=item C Reset the status of the remote POP3 server. This includes resetting the status of all messages to not be deleted. -=item quit () +=item C Quit and close the connection to the remote POP3 server. Any messages marked as deleted will be deleted from the remote mailbox. -=item can_inet6 () +=item C Returns whether we can use IPv6. -=item can_ssl () +=item C Returns whether we can use SSL. =back -=head1 NOTES +=head2 Notes If a C object goes out of scope before C method is called then the C method will called before the connection is closed. This means that any messages marked to be deleted will not be. +=head1 EXPORTS + +I. + +=head1 KNOWN BUGS + +See L. + =head1 SEE ALSO L, L, -L +L. =head1 AUTHOR -Graham Barr EFE. +Graham Barr ELE. -Steve Hay EFE is now maintaining libnet as of version -1.22_02. +Steve Hay ELE is now maintaining +libnet as of version 1.22_02. =head1 COPYRIGHT Copyright (C) 1995-2004 Graham Barr. All rights reserved. -Copyright (C) 2013-2016 Steve Hay. All rights reserved. +Copyright (C) 2013-2016, 2020 Steve Hay. All rights reserved. =head1 LICENCE @@ -860,4 +867,16 @@ This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself, i.e. under the terms of either the GNU General Public License or the Artistic License, as specified in the F file. +=head1 VERSION + +Version 3.13 + +=head1 DATE + +23 Dec 2020 + +=head1 HISTORY + +See the F file. + =cut diff --git a/cpan/libnet/lib/Net/SMTP.pm b/cpan/libnet/lib/Net/SMTP.pm index 5eaf4220b62b..354ed8e38f32 100644 --- a/cpan/libnet/lib/Net/SMTP.pm +++ b/cpan/libnet/lib/Net/SMTP.pm @@ -1,7 +1,7 @@ # Net::SMTP.pm # # Copyright (C) 1995-2004 Graham Barr. All rights reserved. -# Copyright (C) 2013-2016 Steve Hay. All rights reserved. +# Copyright (C) 2013-2016, 2020 Steve Hay. All rights reserved. # This module is free software; you can redistribute it and/or modify it under # the same terms as Perl itself, i.e. under the terms of either the GNU General # Public License or the Artistic License, as specified in the F file. @@ -19,7 +19,7 @@ use Net::Cmd; use Net::Config; use Socket; -our $VERSION = "3.11"; +our $VERSION = "3.13"; # Code for detecting if we can use SSL my $ssl_class = eval { @@ -663,57 +663,23 @@ explicit TLS encryption, i.e. SMTPS or SMTP+STARTTLS. The Net::SMTP class is a subclass of Net::Cmd and (depending on avaibility) of IO::Socket::IP, IO::Socket::INET6 or IO::Socket::INET. -=head1 EXAMPLES - -This example prints the mail domain name of the SMTP server known as mailhost: - - #!/usr/local/bin/perl -w - - use Net::SMTP; - - $smtp = Net::SMTP->new('mailhost'); - print $smtp->domain,"\n"; - $smtp->quit; - -This example sends a small message to the postmaster at the SMTP server -known as mailhost: - - #!/usr/local/bin/perl -w - - use Net::SMTP; - - my $smtp = Net::SMTP->new('mailhost'); - - $smtp->mail($ENV{USER}); - if ($smtp->to('postmaster')) { - $smtp->data(); - $smtp->datasend("To: postmaster\n"); - $smtp->datasend("\n"); - $smtp->datasend("A simple test message\n"); - $smtp->dataend(); - } else { - print "Error: ", $smtp->message(); - } - - $smtp->quit; - -=head1 CONSTRUCTOR +=head2 Class Methods =over 4 -=item new ( [ HOST ] [, OPTIONS ] ) +=item C -This is the constructor for a new Net::SMTP object. C is the +This is the constructor for a new Net::SMTP object. C<$host> is the name of the remote host to which an SMTP connection is required. On failure C will be returned and C<$@> will contain the reason for the failure. -C is optional. If C is not given then it may instead be +C<$host> is optional. If C<$host> is not given then it may instead be passed as the C option described below. If neither is given then the C specified in C will be used. -C are passed in a hash like fashion, using key and value pairs. +C<%options> are passed in a hash like fashion, using key and value pairs. Possible options are: B - SMTP requires that you identify yourself. This option @@ -748,16 +714,14 @@ class. Alternatively B can be used. B - Maximum time, in seconds, to wait for a response from the SMTP server (default: 120) -B - If true the all ADDRESS arguments must be as +B - If true then all C<$address> arguments must be as defined by C in RFC2822. If not given, or false, then Net::SMTP will attempt to extract the address from the value passed. B - Enable debugging information - Example: - $smtp = Net::SMTP->new('mailhost', Hello => 'my.mail.domain', Timeout => 30, @@ -788,7 +752,7 @@ Example: =back -=head1 METHODS +=head1 Object Methods Unless otherwise stated all methods return either a I or I value, with I meaning that the operation was a success. When a method @@ -801,60 +765,60 @@ documented here. =over 4 -=item banner () +=item C Returns the banner message which the server replied with when the initial connection was made. -=item domain () +=item C Returns the domain that the remote SMTP server identified itself as during connection. -=item hello ( DOMAIN ) +=item C Tell the remote server the mail domain which you are in using the EHLO command (or HELO if EHLO fails). Since this method is invoked automatically when the Net::SMTP object is constructed the user should normally not have to call it manually. -=item host () +=item C Returns the value used by the constructor, and passed to IO::Socket::INET, to connect to the host. -=item etrn ( DOMAIN ) +=item C -Request a queue run for the DOMAIN given. +Request a queue run for the C<$domain> given. -=item starttls ( SSLARGS ) +=item C Upgrade existing plain connection to SSL. You can use SSL arguments as documented in L, but it will usually use the right arguments already. -=item auth ( USERNAME, PASSWORD ) +=item C -=item auth ( SASL ) +=item C Attempt SASL authentication. Requires Authen::SASL module. The first form constructs a new Authen::SASL object using the given username and password; the second form uses the given Authen::SASL object. -=item mail ( ADDRESS [, OPTIONS] ) +=item C -=item send ( ADDRESS ) +=item C -=item send_or_mail ( ADDRESS ) +=item C -=item send_and_mail ( ADDRESS ) +=item C -Send the appropriate command to the server MAIL, SEND, SOML or SAML. C
+Send the appropriate command to the server MAIL, SEND, SOML or SAML. C<$address> is the address of the sender. This initiates the sending of a message. The method C should be called for each address that the message is to be sent to. -The C method can some additional ESMTP OPTIONS which is passed +The C method can take some additional ESMTP C<%options> which is passed in hash like fashion, using key and value pairs. Possible options are: Size => @@ -872,13 +836,13 @@ Status Notification). The submitter address in C option is expected to be in a format as required by RFC 2554, in an RFC2821-quoted form and xtext-encoded, or <> . -=item reset () +=item C Reset the status of the server. This may be called after a message has been initiated, but before any data has been sent, to cancel the sending of the message. -=item recipient ( ADDRESS [, ADDRESS, [...]] [, OPTIONS ] ) +=item C Notify the server that the current message should be sent to all of the addresses given. Each address is sent as a separate command to the server. @@ -886,7 +850,7 @@ Should the sending of any address result in a failure then the process is aborted and a I value is returned. It is up to the user to call C if they so desire. -The C method can also pass additional case-sensitive OPTIONS as an +The C method can also pass additional case-sensitive C<%options> as an anonymous hash using key and value pairs. Possible options are: Notify => ['NEVER'] or ['SUCCESS','FAILURE','DELAY'] (see below) @@ -919,8 +883,9 @@ that a DSN not be returned to the sender under any conditions." $smtp->recipient(@recipients, { Notify => ['NEVER'], SkipBad => 1 }); # Good You may use any combination of these three values 'SUCCESS','FAILURE','DELAY' in -the anonymous array reference as defined by RFC3461 (see http://www.ietf.org/rfc/rfc3461.txt -for more information. Note: quotations in this topic from same.). +the anonymous array reference as defined by RFC3461 (see +L for more information. Note: quotations +in this topic from same.). A Notify parameter of 'SUCCESS' or 'FAILURE' "requests that a DSN be issued on successful delivery or delivery failure, respectively." @@ -943,67 +908,67 @@ sent to. The machine that generates a DSN will use this address to inform the sender, because he can't know if recipients get rewritten by mail servers. It is expected to be in a format as required by RFC3461, xtext-encoded. -=item to ( ADDRESS [, ADDRESS [...]] ) +=item C -=item cc ( ADDRESS [, ADDRESS [...]] ) +=item C -=item bcc ( ADDRESS [, ADDRESS [...]] ) +=item C Synonyms for C. -=item data ( [ DATA ] ) +=item C Initiate the sending of the data from the current message. -C may be a reference to a list or a list and must be encoded by the +C<$data> may be a reference to a list or a list and must be encoded by the caller to octets of whatever encoding is required, e.g. by using the Encode module's C function. -If specified the contents of C and a termination string C<".\r\n"> is +If specified the contents of C<$data> and a termination string C<".\r\n"> is sent to the server. The result will be true if the data was accepted. -If C is not specified then the result will indicate that the server +If C<$data> is not specified then the result will indicate that the server wishes the data to be sent. The data must then be sent using the C and C methods described in L. -=item bdat ( DATA ) +=item C -=item bdatlast ( DATA ) +=item C -Use the alternate DATA command "BDAT" of the data chunking service extension +Use the alternate C<$data> command "BDAT" of the data chunking service extension defined in RFC1830 for efficiently sending large MIME messages. -=item expand ( ADDRESS ) +=item C Request the server to expand the given address Returns an array which contains the text read from the server. -=item verify ( ADDRESS ) +=item C -Verify that C
is a legitimate mailing address. +Verify that C<$address> is a legitimate mailing address. Most sites usually disable this feature in their SMTP service configuration. Use "Debug => 1" option under new() to see if disabled. -=item help ( [ $subject ] ) +=item C Request help text from the server. Returns the text or undef upon failure -=item quit () +=item C Send the QUIT command to the remote SMTP server and close the socket connection. -=item can_inet6 () +=item C Returns whether we can use IPv6. -=item can_ssl () +=item C Returns whether we can use SSL. =back -=head1 ADDRESSES +=head2 Addresses Net::SMTP attempts to DWIM with addresses that are passed. For example an application might extract The From: line from an email @@ -1019,23 +984,65 @@ accept the address surrounded by angle brackets. "funny user"@domain RIGHT, recommended <"funny user"@domain> OK +=head1 EXAMPLES + +This example prints the mail domain name of the SMTP server known as mailhost: + + #!/usr/local/bin/perl -w + + use Net::SMTP; + + $smtp = Net::SMTP->new('mailhost'); + print $smtp->domain,"\n"; + $smtp->quit; + +This example sends a small message to the postmaster at the SMTP server +known as mailhost: + + #!/usr/local/bin/perl -w + + use Net::SMTP; + + my $smtp = Net::SMTP->new('mailhost'); + + $smtp->mail($ENV{USER}); + if ($smtp->to('postmaster')) { + $smtp->data(); + $smtp->datasend("To: postmaster\n"); + $smtp->datasend("\n"); + $smtp->datasend("A simple test message\n"); + $smtp->dataend(); + } else { + print "Error: ", $smtp->message(); + } + + $smtp->quit; + +=head1 EXPORTS + +I. + +=head1 KNOWN BUGS + +See L. + =head1 SEE ALSO L, -L +L. =head1 AUTHOR -Graham Barr EFE. +Graham Barr ELE. -Steve Hay EFE is now maintaining libnet as of version -1.22_02. +Steve Hay ELE is now maintaining +libnet as of version 1.22_02. =head1 COPYRIGHT Copyright (C) 1995-2004 Graham Barr. All rights reserved. -Copyright (C) 2013-2016 Steve Hay. All rights reserved. +Copyright (C) 2013-2016, 2020 Steve Hay. All rights reserved. =head1 LICENCE @@ -1043,4 +1050,16 @@ This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself, i.e. under the terms of either the GNU General Public License or the Artistic License, as specified in the F file. +=head1 VERSION + +Version 3.13 + +=head1 DATE + +23 Dec 2020 + +=head1 HISTORY + +See the F file. + =cut diff --git a/cpan/libnet/lib/Net/Time.pm b/cpan/libnet/lib/Net/Time.pm index d049408538fd..7f0a724cd3a4 100644 --- a/cpan/libnet/lib/Net/Time.pm +++ b/cpan/libnet/lib/Net/Time.pm @@ -1,7 +1,7 @@ # Net::Time.pm # # Copyright (C) 1995-2004 Graham Barr. All rights reserved. -# Copyright (C) 2014 Steve Hay. All rights reserved. +# Copyright (C) 2014, 2020 Steve Hay. All rights reserved. # This module is free software; you can redistribute it and/or modify it under # the same terms as Perl itself, i.e. under the terms of either the GNU General # Public License or the Artistic License, as specified in the F file. @@ -22,7 +22,7 @@ use Net::Config; our @ISA = qw(Exporter); our @EXPORT_OK = qw(inet_time inet_daytime); -our $VERSION = "3.11"; +our $VERSION = "3.13"; our $TIMEOUT = 120; @@ -123,37 +123,64 @@ Net::Time - time and daytime network client interface C provides subroutines that obtain the time on a remote machine. +=head2 Functions + =over 4 -=item inet_time ( [HOST [, PROTOCOL [, TIMEOUT]]]) +=item C -Obtain the time on C, or some default host if C is not given +Obtain the time on C<$host>, or some default host if C<$host> is not given or not defined, using the protocol as defined in RFC868. The optional -argument C should define the protocol to use, either C or +argument C<$protocol> should define the protocol to use, either C or C. The result will be a time value in the same units as returned by time() or I upon failure. -=item inet_daytime ( [HOST [, PROTOCOL [, TIMEOUT]]]) +=item C -Obtain the time on C, or some default host if C is not given +Obtain the time on C<$host>, or some default host if C<$host> is not given or not defined, using the protocol as defined in RFC867. The optional -argument C should define the protocol to use, either C or +argument C<$protocol> should define the protocol to use, either C or C. The result will be an ASCII string or I upon failure. =back +=head1 EXPORTS + +The following symbols are, or can be, exported by this module: + +=over 4 + +=item Default Exports + +I. + +=item Optional Exports + +C, +C. + +=item Export Tags + +I. + +=back + +=head1 KNOWN BUGS + +I. + =head1 AUTHOR -Graham Barr EFE. +Graham Barr ELE. -Steve Hay EFE is now maintaining libnet as of version -1.22_02. +Steve Hay ELE is now maintaining +libnet as of version 1.22_02. =head1 COPYRIGHT Copyright (C) 1995-2004 Graham Barr. All rights reserved. -Copyright (C) 2014 Steve Hay. All rights reserved. +Copyright (C) 2014, 2020 Steve Hay. All rights reserved. =head1 LICENCE @@ -161,4 +188,16 @@ This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself, i.e. under the terms of either the GNU General Public License or the Artistic License, as specified in the F file. +=head1 VERSION + +Version 3.13 + +=head1 DATE + +23 Dec 2020 + +=head1 HISTORY + +See the F file. + =cut diff --git a/cpan/libnet/lib/Net/libnetFAQ.pod b/cpan/libnet/lib/Net/libnetFAQ.pod index bcc53479ba9b..4a3b183cd126 100644 --- a/cpan/libnet/lib/Net/libnetFAQ.pod +++ b/cpan/libnet/lib/Net/libnetFAQ.pod @@ -9,23 +9,25 @@ libnetFAQ - libnet Frequently Asked Questions This document is distributed with the libnet distribution, and is also available on the libnet web page at - http://search.cpan.org/dist/libnet/ +L =head2 How to contribute to this document You may report corrections, additions, and suggestions on the CPAN Request Tracker at - http://rt.cpan.org/Public/Bug/Report.html?Queue=libnet +L =head1 Author and Copyright Information Copyright (C) 1997-1998 Graham Barr. All rights reserved. -This document is free; you can redistribute it and/or modify it -under the terms of the Artistic License. +This document is free; you can redistribute it and/or modify it under +the same terms as Perl itself, i.e. under the terms of either the GNU +General Public License or the Artistic License, as specified in the +F file. -Steve Hay EFE is now maintaining libnet as of version -1.22_02. +Steve Hay ELE is now maintaining +libnet as of version 1.22_02. =head2 Disclaimer @@ -70,7 +72,7 @@ on any machine that perl runs on. The latest libnet release is always on CPAN, you will find it in - http://search.cpan.org/dist/libnet/ +L =head1 Using Net::FTP diff --git a/cpan/libnet/t/config.t b/cpan/libnet/t/config.t index 3c29a03d0ddd..897ca211c0c6 100644 --- a/cpan/libnet/t/config.t +++ b/cpan/libnet/t/config.t @@ -5,15 +5,21 @@ use 5.008001; use strict; use warnings; +use Test::More; + BEGIN { if (!eval { require Socket }) { - print "1..0 # no Socket\n"; exit 0; + plan skip_all => "no Socket"; + } + elsif (ord('A') == 193 && !eval { require Convert::EBCDIC }) { + plan skip_all => "EBCDIC but no Convert::EBCDIC"; + } + else { + plan tests => 10; } + undef *{Socket::inet_aton}; undef *{Socket::inet_ntoa}; - if (ord('A') == 193 && !eval { require Convert::EBCDIC }) { - print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0; - } $INC{'Socket.pm'} = 1; } @@ -45,13 +51,8 @@ sub inet_ntoa { return $names{$_[0]}; } -package main; - -(my $libnet_t = __FILE__) =~ s/config.t/libnet_t.pl/; -require $libnet_t; - -print "1..10\n"; +package main; use Net::Config; ok( exists $INC{'Net/Config.pm'}, 'Net::Config should have been used' ); diff --git a/cpan/libnet/t/datasend.t b/cpan/libnet/t/datasend.t index 0aea9d4a39d8..7902c17d47e2 100644 --- a/cpan/libnet/t/datasend.t +++ b/cpan/libnet/t/datasend.t @@ -5,12 +5,17 @@ use 5.008001; use strict; use warnings; +use Test::More; + BEGIN { if (!eval { require Socket }) { - print "1..0 # no Socket\n"; exit 0; + plan skip_all => "no Socket"; + } + elsif (ord('A') == 193 && !eval { require Convert::EBCDIC }) { + plan skip_all => "EBCDIC but no Convert::EBCDIC"; } - if (ord('A') == 193 && !eval { require Convert::EBCDIC }) { - print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0; + else { + plan tests => 54; } } @@ -41,11 +46,6 @@ BEGIN { } } -(my $libnet_t = __FILE__) =~ s/datasend.t/libnet_t.pl/; -require $libnet_t or die; - -print "1..54\n"; - sub check { my $expect = pop; my $cmd = Foo->new; diff --git a/cpan/libnet/t/ftp.t b/cpan/libnet/t/ftp.t index 16cb868460b2..69af504a5271 100644 --- a/cpan/libnet/t/ftp.t +++ b/cpan/libnet/t/ftp.t @@ -7,7 +7,7 @@ use warnings; BEGIN { if (!eval { require Socket }) { - print "1..0 # Skip: no Socket module\n"; exit 0; + print "1..0 # Skip: no Socket\n"; exit 0; } if (ord('A') == 193 && !eval { require Convert::EBCDIC }) { print "1..0 # Skip: EBCDIC but no Convert::EBCDIC\n"; exit 0; diff --git a/cpan/libnet/t/hostname.t b/cpan/libnet/t/hostname.t index 55031bf34509..5e20b819a9a1 100644 --- a/cpan/libnet/t/hostname.t +++ b/cpan/libnet/t/hostname.t @@ -7,10 +7,10 @@ use warnings; BEGIN { if (!eval { require Socket }) { - print "1..0 # no Socket\n"; exit 0; + print "1..0 # Skip: no Socket\n"; exit 0; } if (ord('A') == 193 && !eval { require Convert::EBCDIC }) { - print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0; + print "1..0 # Skip: EBCDIC but no Convert::EBCDIC\n"; exit 0; } } @@ -18,7 +18,7 @@ use Net::Domain qw(hostname domainname hostdomain hostfqdn); use Net::Config; unless($NetConfig{test_hosts}) { - print "1..0\n"; + print "1..0 # Skip: test_hosts not enabled in config\n"; exit 0; } diff --git a/cpan/libnet/t/libnet_t.pl b/cpan/libnet/t/libnet_t.pl deleted file mode 100644 index cc512ca592c8..000000000000 --- a/cpan/libnet/t/libnet_t.pl +++ /dev/null @@ -1,41 +0,0 @@ -use 5.008001; - -use strict; -use warnings; - -my $number = 0; -sub ok { - my ($condition, $name) = @_; - - my $message = $condition ? "ok " : "not ok "; - $message .= ++$number; - $message .= " # $name" if defined $name; - print $message, "\n"; - return $condition; -} - -sub is { - my ($got, $expected, $name) = @_; - - for ($got, $expected) { - $_ = 'undef' unless defined $_; - } - - unless (ok($got eq $expected, $name)) { - warn "Got: '$got'\nExpected: '$expected'\n" . join(' ', caller) . "\n"; - } -} - -sub skip { - my ($reason, $num) = @_; - $reason ||= ''; - $number ||= 1; - - for (1 .. $num) { - $number++; - print "ok $number # skip $reason\n"; - } -} - -1; - diff --git a/cpan/libnet/t/netrc.t b/cpan/libnet/t/netrc.t index e270b368bc24..ba0183c1a5cc 100644 --- a/cpan/libnet/t/netrc.t +++ b/cpan/libnet/t/netrc.t @@ -5,17 +5,21 @@ use 5.008001; use strict; use warnings; +use Test::More; + BEGIN { if (!eval { require Socket }) { - print "1..0 # no Socket\n"; exit 0; + plan skip_all => "no Socket"; + } + elsif (ord('A') == 193 && !eval { require Convert::EBCDIC }) { + plan skip_all => "EBCDIC but no Convert::EBCDIC"; } - if (ord('A') == 193 && !eval { require Convert::EBCDIC }) { - print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0; + else { + plan tests => 20; } } use Cwd; -print "1..20\n"; # for testing _readrc $ENV{HOME} = Cwd::cwd(); @@ -36,9 +40,6 @@ my @stat; # for testing _readrc $INC{'FileHandle.pm'} = 1; -(my $libnet_t = __FILE__) =~ s/\w+.t$/libnet_t.pl/; -require $libnet_t; - # now that the tricks are out of the way... eval { require Net::Netrc; }; ok( !$@, 'should be able to require() Net::Netrc safely' ); diff --git a/cpan/libnet/t/nntp.t b/cpan/libnet/t/nntp.t index 559f3985548f..b346caaf5330 100644 --- a/cpan/libnet/t/nntp.t +++ b/cpan/libnet/t/nntp.t @@ -7,10 +7,10 @@ use warnings; BEGIN { if (!eval { require Socket }) { - print "1..0 # no Socket\n"; exit 0; + print "1..0 # Skip: no Socket\n"; exit 0; } if (ord('A') == 193 && !eval { require Convert::EBCDIC }) { - print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0; + print "1..0 # Skip: EBCDIC but no Convert::EBCDIC\n"; exit 0; } } @@ -18,8 +18,13 @@ use Net::Config; use Net::NNTP; use Net::Cmd qw(CMD_REJECT); -unless(@{$NetConfig{nntp_hosts}} && $NetConfig{test_hosts}) { - print "1..0\n"; +unless(@{$NetConfig{nntp_hosts}}) { + print "1..0 # Skip: no nntp_hosts defined in config\n"; + exit; +} + +unless($NetConfig{test_hosts}) { + print "1..0 # Skip: test_hosts not enabled in config\n"; exit; } diff --git a/cpan/libnet/t/nntp_ipv6.t b/cpan/libnet/t/nntp_ipv6.t index 768489a1afdd..af1ba1631ef6 100644 --- a/cpan/libnet/t/nntp_ipv6.t +++ b/cpan/libnet/t/nntp_ipv6.t @@ -5,10 +5,20 @@ use 5.008001; use strict; use warnings; +use Test::More; + +BEGIN { + if (!eval { require Socket }) { + plan skip_all => "no Socket"; + } + elsif (ord('A') == 193 && !eval { require Convert::EBCDIC }) { + plan skip_all => "EBCDIC but no Convert::EBCDIC"; + } +} + use Config; use File::Temp 'tempfile'; use Net::NNTP; -use Test::More; my $debug = 0; # Net::NNTP->new( Debug => .. ) diff --git a/cpan/libnet/t/nntp_ssl.t b/cpan/libnet/t/nntp_ssl.t index e6a4fe5f23b2..5120e9210eb9 100644 --- a/cpan/libnet/t/nntp_ssl.t +++ b/cpan/libnet/t/nntp_ssl.t @@ -5,10 +5,20 @@ use 5.008001; use strict; use warnings; +use Test::More; + +BEGIN { + if (!eval { require Socket }) { + plan skip_all => "no Socket"; + } + elsif (ord('A') == 193 && !eval { require Convert::EBCDIC }) { + plan skip_all => "EBCDIC but no Convert::EBCDIC"; + } +} + use Config; use File::Temp 'tempfile'; use Net::NNTP; -use Test::More; my $debug = 0; # Net::NNTP Debug => .. diff --git a/cpan/libnet/t/pop3_ipv6.t b/cpan/libnet/t/pop3_ipv6.t index db311283e06f..e68412279ce2 100644 --- a/cpan/libnet/t/pop3_ipv6.t +++ b/cpan/libnet/t/pop3_ipv6.t @@ -5,10 +5,20 @@ use 5.008001; use strict; use warnings; +use Test::More; + +BEGIN { + if (!eval { require Socket }) { + plan skip_all => "no Socket"; + } + elsif (ord('A') == 193 && !eval { require Convert::EBCDIC }) { + plan skip_all => "EBCDIC but no Convert::EBCDIC"; + } +} + use Config; use File::Temp 'tempfile'; use Net::POP3; -use Test::More; my $debug = 0; # Net::POP3->new( Debug => .. ) diff --git a/cpan/libnet/t/pop3_ssl.t b/cpan/libnet/t/pop3_ssl.t index 356de40acb35..12d31ecc58b0 100644 --- a/cpan/libnet/t/pop3_ssl.t +++ b/cpan/libnet/t/pop3_ssl.t @@ -5,10 +5,20 @@ use 5.008001; use strict; use warnings; +use Test::More; + +BEGIN { + if (!eval { require Socket }) { + plan skip_all => "no Socket"; + } + elsif (ord('A') == 193 && !eval { require Convert::EBCDIC }) { + plan skip_all => "EBCDIC but no Convert::EBCDIC"; + } +} + use Config; use File::Temp 'tempfile'; use Net::POP3; -use Test::More; my $debug = 0; # Net::POP3 Debug => .. diff --git a/cpan/libnet/t/require.t b/cpan/libnet/t/require.t index 70ec1f67f09c..cc14b4bc0d63 100644 --- a/cpan/libnet/t/require.t +++ b/cpan/libnet/t/require.t @@ -7,10 +7,10 @@ use warnings; BEGIN { if (!eval { require Socket }) { - print "1..0 # no Socket\n"; exit 0; + print "1..0 # Skip: no Socket\n"; exit 0; } if (ord('A') == 193 && !eval { require Convert::EBCDIC }) { - print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0; + print "1..0 # Skip: EBCDIC but no Convert::EBCDIC\n"; exit 0; } } diff --git a/cpan/libnet/t/smtp.t b/cpan/libnet/t/smtp.t index 9d6f65a484dd..e2cd6eb83efb 100644 --- a/cpan/libnet/t/smtp.t +++ b/cpan/libnet/t/smtp.t @@ -7,18 +7,23 @@ use warnings; BEGIN { if (!eval { require Socket }) { - print "1..0 # no Socket\n"; exit 0; + print "1..0 # Skip: no Socket\n"; exit 0; } - if (ord('A') == 193 && eval { require Convert::EBCDIC }) { - print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0; + if (ord('A') == 193 && !eval { require Convert::EBCDIC }) { + print "1..0 # Skip: EBCDIC but no Convert::EBCDIC\n"; exit 0; } } use Net::Config; use Net::SMTP; -unless(@{$NetConfig{smtp_hosts}} && $NetConfig{test_hosts}) { - print "1..0\n"; +unless(@{$NetConfig{smtp_hosts}}) { + print "1..0 # Skip: no smtp_hosts defined in config\n"; + exit 0; +} + +unless($NetConfig{test_hosts}) { + print "1..0 # Skip: test_hosts not enabled in config\n"; exit 0; } diff --git a/cpan/libnet/t/smtp_ipv6.t b/cpan/libnet/t/smtp_ipv6.t index f430721dcc21..d0bdb906bbaa 100644 --- a/cpan/libnet/t/smtp_ipv6.t +++ b/cpan/libnet/t/smtp_ipv6.t @@ -5,10 +5,20 @@ use 5.008001; use strict; use warnings; +use Test::More; + +BEGIN { + if (!eval { require Socket }) { + plan skip_all => "no Socket"; + } + elsif (ord('A') == 193 && !eval { require Convert::EBCDIC }) { + plan skip_all => "EBCDIC but no Convert::EBCDIC"; + } +} + use Config; use File::Temp 'tempfile'; use Net::SMTP; -use Test::More; my $debug = 0; # Net::SMTP->new( Debug => .. ) diff --git a/cpan/libnet/t/smtp_ssl.t b/cpan/libnet/t/smtp_ssl.t index 7290176b23f8..314dcb708a8e 100644 --- a/cpan/libnet/t/smtp_ssl.t +++ b/cpan/libnet/t/smtp_ssl.t @@ -5,10 +5,20 @@ use 5.008001; use strict; use warnings; +use Test::More; + +BEGIN { + if (!eval { require Socket }) { + plan skip_all => "no Socket"; + } + elsif (ord('A') == 193 && !eval { require Convert::EBCDIC }) { + plan skip_all => "EBCDIC but no Convert::EBCDIC"; + } +} + use Config; use File::Temp 'tempfile'; use Net::SMTP; -use Test::More; my $debug = 0; # Net::SMTP Debug => .. diff --git a/cpan/libnet/t/time.t b/cpan/libnet/t/time.t index 6dcba3a3e052..1b02d606cf63 100644 --- a/cpan/libnet/t/time.t +++ b/cpan/libnet/t/time.t @@ -5,22 +5,24 @@ use 5.008001; use strict; use warnings; +use Test::More; + BEGIN { if (!eval { require Socket }) { - print "1..0 # no Socket\n"; exit 0; + plan skip_all => "no Socket"; + } + elsif (ord('A') == 193 && !eval { require Convert::EBCDIC }) { + plan skip_all => "EBCDIC but no Convert::EBCDIC"; } - if (ord('A') == 193 && !eval { require Convert::EBCDIC }) { - print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0; + else { + plan tests => 12; } + $INC{'IO/Socket.pm'} = 1; $INC{'IO/Select.pm'} = 1; $INC{'IO/Socket/INET.pm'} = 1; } -(my $libnet_t = __FILE__) =~ s/time.t/libnet_t.pl/; -require $libnet_t; - -print "1..12\n"; # cannot use(), otherwise it will use IO::Socket and IO::Select eval{ require Net::Time; }; ok( !$@, 'should be able to require() Net::Time safely' ); diff --git a/cpan/podlators/.gitignore b/cpan/podlators/.gitignore index 146b3be431fe..8539efd423bb 100644 --- a/cpan/podlators/.gitignore +++ b/cpan/podlators/.gitignore @@ -18,3 +18,4 @@ /podlators-*.tar.gz.asc /scripts/pod2man /scripts/pod2text +!/Makefile.PL diff --git a/cv.h b/cv.h index 5a3a25f8b9e4..435dee626126 100644 --- a/cv.h +++ b/cv.h @@ -63,7 +63,7 @@ See L. /* these CvPADLIST/CvRESERVED asserts can be reverted one day, once stabilized */ #define CvPADLIST(sv) (*(assert_(!CvISXSUB((CV*)(sv))) \ - &(((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_padlist_u.xcv_padlist))) + &(((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_padlist_u.xcv_padlist))) /* CvPADLIST_set is not public API, it can be removed one day, once stabilized */ #ifdef DEBUGGING # define CvPADLIST_set(sv, padlist) Perl_set_padlist((CV*)sv, padlist) @@ -71,7 +71,7 @@ See L. # define CvPADLIST_set(sv, padlist) (CvPADLIST(sv) = (padlist)) #endif #define CvHSCXT(sv) *(assert_(CvISXSUB((CV*)(sv))) \ - &(((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_padlist_u.xcv_hscxt)) + &(((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_padlist_u.xcv_hscxt)) #ifdef DEBUGGING # if PTRSIZE == 8 # define PoisonPADLIST(sv) \ @@ -92,20 +92,20 @@ See L. /* These two are sometimes called on non-CVs */ #define CvPROTO(sv) \ - ( \ - SvPOK(sv) \ - ? SvTYPE(sv) == SVt_PVCV && CvAUTOLOAD(sv) \ - ? SvEND(sv)+1 : SvPVX_const(sv) \ - : NULL \ - ) + ( \ + SvPOK(sv) \ + ? SvTYPE(sv) == SVt_PVCV && CvAUTOLOAD(sv) \ + ? SvEND(sv)+1 : SvPVX_const(sv) \ + : NULL \ + ) #define CvPROTOLEN(sv) \ - ( \ - SvPOK(sv) \ - ? SvTYPE(sv) == SVt_PVCV && CvAUTOLOAD(sv) \ - ? SvLEN(sv)-SvCUR(sv)-2 \ - : SvCUR(sv) \ - : 0 \ - ) + ( \ + SvPOK(sv) \ + ? SvTYPE(sv) == SVt_PVCV && CvAUTOLOAD(sv) \ + ? SvLEN(sv)-SvCUR(sv)-2 \ + : SvCUR(sv) \ + : 0 \ + ) #define CVf_METHOD 0x0001 /* CV is explicitly marked as a method */ #define CVf_LVALUE 0x0002 /* CV return value can be used as lvalue */ @@ -117,9 +117,9 @@ See L. #define CVf_CLONED 0x0040 /* a clone of one of those */ #define CVf_ANON 0x0080 /* CV is not pointed to by a GV */ #define CVf_UNIQUE 0x0100 /* sub is only called once (eg PL_main_cv, - * require, eval). */ + * require, eval). */ #define CVf_NODEBUG 0x0200 /* no DB::sub indirection for this CV - (esp. useful for special XSUBs) */ + (esp. useful for special XSUBs) */ #define CVf_CVGV_RC 0x0400 /* CvGV is reference counted */ #if defined(PERL_CORE) || defined(PERL_EXT) # define CVf_SLABBED 0x0800 /* Holds refcount on op slab */ @@ -226,8 +226,8 @@ PERL_STATIC_INLINE HEK * CvNAME_HEK(CV *sv) { return CvNAMED(sv) - ? ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_hek - : 0; + ? ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_hek + : 0; } /* helper for the common pattern: @@ -242,11 +242,11 @@ CvNAME_HEK(CV *sv) /* This lowers the reference count of the previous value, but does *not* increment the reference count of the new value. */ #define CvNAME_HEK_set(cv, hek) ( \ - CvNAME_HEK((CV *)(cv)) \ - ? unshare_hek(SvANY((CV *)(cv))->xcv_gv_u.xcv_hek) \ - : (void)0, \ - ((XPVCV*)MUTABLE_PTR(SvANY(cv)))->xcv_gv_u.xcv_hek = (hek), \ - CvNAMED_on(cv) \ + CvNAME_HEK((CV *)(cv)) \ + ? unshare_hek(SvANY((CV *)(cv))->xcv_gv_u.xcv_hek) \ + : (void)0, \ + ((XPVCV*)MUTABLE_PTR(SvANY(cv)))->xcv_gv_u.xcv_hek = (hek), \ + CvNAMED_on(cv) \ ) /* diff --git a/cygwin/cygwin.c b/cygwin/cygwin.c index 3bb5818e5858..53b04c67e66a 100644 --- a/cygwin/cygwin.c +++ b/cygwin/cygwin.c @@ -35,16 +35,16 @@ do_spawnvp (const char *path, const char * const *argv) rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand); childpid = spawnvp(_P_NOWAIT,path,argv); if (childpid < 0) { - status = -1; - if(ckWARN(WARN_EXEC)) - Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn \"%s\": %s", - path,Strerror (errno)); + status = -1; + if(ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn \"%s\": %s", + path,Strerror (errno)); } else { - do { - result = wait4pid(childpid, &status, 0); - } while (result == -1 && errno == EINTR); - if(result < 0) - status = -1; + do { + result = wait4pid(childpid, &status, 0); + } while (result == -1 && errno == EINTR); + if(result < 0) + status = -1; } (void)rsignal_restore(SIGINT, &ihand); (void)rsignal_restore(SIGQUIT, &qhand); @@ -98,7 +98,7 @@ do_spawn (char *cmd) ENTER; while (*cmd && isSPACE(*cmd)) - cmd++; + cmd++; if (strBEGINs (cmd,"/bin/sh") && isSPACE (cmd[7])) cmd+=5; @@ -106,32 +106,32 @@ do_spawn (char *cmd) /* save an extra exec if possible */ /* see if there are shell metacharacters in it */ if (strstr (cmd,"...")) - goto doshell; + goto doshell; if (*cmd=='.' && isSPACE (cmd[1])) - goto doshell; + goto doshell; if (strBEGINs (cmd,"exec") && isSPACE (cmd[4])) - goto doshell; + goto doshell; for (s=cmd; *s && isALPHA (*s); s++) ; /* catch VAR=val gizmo */ if (*s=='=') goto doshell; for (s=cmd; *s; s++) - if (strchr (metachars,*s)) - { - if (*s=='\n' && s[1]=='\0') - { - *s='\0'; - break; - } - doshell: - command[0] = "sh"; - command[1] = "-c"; - command[2] = cmd; - command[3] = NULL; - - result = do_spawnvp("sh",command); - goto leave; - } + if (strchr (metachars,*s)) + { + if (*s=='\n' && s[1]=='\0') + { + *s='\0'; + break; + } + doshell: + command[0] = "sh"; + command[1] = "-c"; + command[2] = cmd; + command[3] = NULL; + + result = do_spawnvp("sh",command); + goto leave; + } Newx (argv, (s-cmd)/2+2, const char*); SAVEFREEPV(argv); @@ -139,18 +139,18 @@ do_spawn (char *cmd) SAVEFREEPV(cmd); a=argv; for (s=cmd; *s;) { - while (*s && isSPACE (*s)) s++; - if (*s) - *(a++)=s; - while (*s && !isSPACE (*s)) s++; - if (*s) - *s++='\0'; + while (*s && isSPACE (*s)) s++; + if (*s) + *(a++)=s; + while (*s && !isSPACE (*s)) s++; + if (*s) + *s++='\0'; } *a = (char*)NULL; if (!argv[0]) result = -1; else - result = do_spawnvp(argv[0],(const char * const *)argv); + result = do_spawnvp(argv[0],(const char * const *)argv); leave: LEAVE; return result; @@ -167,7 +167,7 @@ wide_to_utf8(const wchar_t *wbuf) /* Here and elsewhere in this file, we have a critical section to prevent * another thread from changing the locale out from under us. XXX But why * not just use uvchr_to_utf8? */ - LOCALE_LOCK; + SETLOCALE_LOCK; oldlocale = setlocale(LC_CTYPE, NULL); setlocale(LC_CTYPE, "utf-8"); @@ -180,7 +180,7 @@ wide_to_utf8(const wchar_t *wbuf) if (oldlocale) setlocale(LC_CTYPE, oldlocale); else setlocale(LC_CTYPE, "C"); - LOCALE_UNLOCK; + SETLOCALE_UNLOCK; return buf; } @@ -193,7 +193,7 @@ utf8_to_wide(const char *buf) char *oldlocale; int wlen = sizeof(wchar_t)*strlen(buf); - LOCALE_LOCK; + SETLOCALE_LOCK; oldlocale = setlocale(LC_CTYPE, NULL); @@ -205,7 +205,7 @@ utf8_to_wide(const char *buf) if (oldlocale) setlocale(LC_CTYPE, oldlocale); else setlocale(LC_CTYPE, "C"); - LOCALE_UNLOCK; + SETLOCALE_UNLOCK; return wbuf; } @@ -221,12 +221,12 @@ XS(Cygwin_cwd) There is Cwd->cwd() usage in the wild, and previous versions didn't die. */ if(items > 1) - Perl_croak(aTHX_ "Usage: Cwd::cwd()"); + Perl_croak(aTHX_ "Usage: Cwd::cwd()"); if((cwd = getcwd(NULL, -1))) { - ST(0) = sv_2mortal(newSVpv(cwd, 0)); - free(cwd); - SvTAINTED_on(ST(0)); - XSRETURN(1); + ST(0) = sv_2mortal(newSVpv(cwd, 0)); + free(cwd); + SvTAINTED_on(ST(0)); + XSRETURN(1); } XSRETURN_UNDEF; } @@ -243,7 +243,7 @@ XS(XS_Cygwin_pid_to_winpid) pid = (pid_t)SvIV(ST(0)); if ((RETVAL = cygwin_internal(CW_CYGWIN_PID_TO_WINPID, pid)) > 0) { - XSprePUSH; PUSHi((IV)RETVAL); + XSprePUSH; PUSHi((IV)RETVAL); XSRETURN(1); } XSRETURN_UNDEF; @@ -288,10 +288,10 @@ XS(XS_Cygwin_win_to_posix_path) src_path = SvPV(ST(0), len); if (items == 2) - absolute_flag = SvTRUE(ST(1)); + absolute_flag = SvTRUE(ST(1)); if (!len) - Perl_croak(aTHX_ "can't convert empty path"); + Perl_croak(aTHX_ "can't convert empty path"); isutf8 = SvUTF8(ST(0)); #if (CYGWIN_VERSION_API_MINOR >= 181) @@ -299,72 +299,72 @@ XS(XS_Cygwin_win_to_posix_path) Size calculation: On overflow let cygwin_conv_path calculate the final size. */ if (isutf8) { - int what = absolute_flag ? CCP_WIN_W_TO_POSIX : CCP_WIN_W_TO_POSIX | CCP_RELATIVE; - STRLEN wlen = sizeof(wchar_t)*(len + 260 + 1001); - wchar_t *wpath = (wchar_t *) safemalloc(sizeof(wchar_t)*len); - wchar_t *wbuf = (wchar_t *) safemalloc(wlen); - if (!IN_BYTES) { - mbstate_t mbs; + int what = absolute_flag ? CCP_WIN_W_TO_POSIX : CCP_WIN_W_TO_POSIX | CCP_RELATIVE; + STRLEN wlen = sizeof(wchar_t)*(len + 260 + 1001); + wchar_t *wpath = (wchar_t *) safemalloc(sizeof(wchar_t)*len); + wchar_t *wbuf = (wchar_t *) safemalloc(wlen); + if (!IN_BYTES) { + mbstate_t mbs; char *oldlocale; - LOCALE_LOCK; + SETLOCALE_LOCK; oldlocale = setlocale(LC_CTYPE, NULL); setlocale(LC_CTYPE, "utf-8"); - /* utf8_to_uvchr_buf(src_path, src_path + wlen, wpath) or Encoding::_utf8_to_bytes(sv, "UCS-2BE"); */ - wlen = mbsrtowcs(wpath, (const char**)&src_path, wlen, &mbs); - if (wlen > 0) - err = cygwin_conv_path(what, wpath, wbuf, wlen); + /* utf8_to_uvchr_buf(src_path, src_path + wlen, wpath) or Encoding::_utf8_to_bytes(sv, "UCS-2BE"); */ + wlen = mbsrtowcs(wpath, (const char**)&src_path, wlen, &mbs); + if (wlen > 0) + err = cygwin_conv_path(what, wpath, wbuf, wlen); if (oldlocale) setlocale(LC_CTYPE, oldlocale); else setlocale(LC_CTYPE, "C"); - LOCALE_UNLOCK; - } else { /* use bytes; assume already ucs-2 encoded bytestream */ - err = cygwin_conv_path(what, src_path, wbuf, wlen); - } - if (err == ENOSPC) { /* our space assumption was wrong, not enough space */ - int newlen = cygwin_conv_path(what, wpath, wbuf, 0); - wbuf = (wchar_t *) realloc(&wbuf, newlen); - err = cygwin_conv_path(what, wpath, wbuf, newlen); - wlen = newlen; - } - /* utf16_to_utf8(*p, *d, bytlen, *newlen) */ - posix_path = (char *) safemalloc(wlen*3); - Perl_utf16_to_utf8(aTHX_ (U8*)&wpath, (U8*)posix_path, wlen*2, &len); - /* - wlen = wcsrtombs(NULL, (const wchar_t **)&wbuf, wlen, NULL); - posix_path = (char *) safemalloc(wlen+1); - wcsrtombs(posix_path, (const wchar_t **)&wbuf, wlen, NULL); - */ + SETLOCALE_UNLOCK; + } else { /* use bytes; assume already ucs-2 encoded bytestream */ + err = cygwin_conv_path(what, src_path, wbuf, wlen); + } + if (err == ENOSPC) { /* our space assumption was wrong, not enough space */ + int newlen = cygwin_conv_path(what, wpath, wbuf, 0); + wbuf = (wchar_t *) realloc(&wbuf, newlen); + err = cygwin_conv_path(what, wpath, wbuf, newlen); + wlen = newlen; + } + /* utf16_to_utf8(*p, *d, bytlen, *newlen) */ + posix_path = (char *) safemalloc(wlen*3); + Perl_utf16_to_utf8(aTHX_ (U8*)&wpath, (U8*)posix_path, wlen*2, &len); + /* + wlen = wcsrtombs(NULL, (const wchar_t **)&wbuf, wlen, NULL); + posix_path = (char *) safemalloc(wlen+1); + wcsrtombs(posix_path, (const wchar_t **)&wbuf, wlen, NULL); + */ } else { - int what = absolute_flag ? CCP_WIN_A_TO_POSIX : CCP_WIN_A_TO_POSIX | CCP_RELATIVE; - posix_path = (char *) safemalloc (len + 260 + 1001); - err = cygwin_conv_path(what, src_path, posix_path, len + 260 + 1001); - if (err == ENOSPC) { /* our space assumption was wrong, not enough space */ - int newlen = cygwin_conv_path(what, src_path, posix_path, 0); - posix_path = (char *) realloc(&posix_path, newlen); - err = cygwin_conv_path(what, src_path, posix_path, newlen); - } + int what = absolute_flag ? CCP_WIN_A_TO_POSIX : CCP_WIN_A_TO_POSIX | CCP_RELATIVE; + posix_path = (char *) safemalloc (len + 260 + 1001); + err = cygwin_conv_path(what, src_path, posix_path, len + 260 + 1001); + if (err == ENOSPC) { /* our space assumption was wrong, not enough space */ + int newlen = cygwin_conv_path(what, src_path, posix_path, 0); + posix_path = (char *) realloc(&posix_path, newlen); + err = cygwin_conv_path(what, src_path, posix_path, newlen); + } } #else posix_path = (char *) safemalloc (len + 260 + 1001); if (absolute_flag) - err = cygwin_conv_to_full_posix_path(src_path, posix_path); + err = cygwin_conv_to_full_posix_path(src_path, posix_path); else - err = cygwin_conv_to_posix_path(src_path, posix_path); + err = cygwin_conv_to_posix_path(src_path, posix_path); #endif if (!err) { - EXTEND(SP, 1); - ST(0) = sv_2mortal(newSVpv(posix_path, 0)); - if (isutf8) { /* src was utf-8, so result should also */ - /* TODO: convert ANSI (local windows encoding) to utf-8 on cygwin-1.5 */ - SvUTF8_on(ST(0)); - } - safefree(posix_path); + EXTEND(SP, 1); + ST(0) = sv_2mortal(newSVpv(posix_path, 0)); + if (isutf8) { /* src was utf-8, so result should also */ + /* TODO: convert ANSI (local windows encoding) to utf-8 on cygwin-1.5 */ + SvUTF8_on(ST(0)); + } + safefree(posix_path); XSRETURN(1); } else { - safefree(posix_path); - XSRETURN_UNDEF; + safefree(posix_path); + XSRETURN_UNDEF; } } @@ -382,79 +382,79 @@ XS(XS_Cygwin_posix_to_win_path) src_path = SvPVx(ST(0), len); if (items == 2) - absolute_flag = SvTRUE(ST(1)); + absolute_flag = SvTRUE(ST(1)); if (!len) - Perl_croak(aTHX_ "can't convert empty path"); + Perl_croak(aTHX_ "can't convert empty path"); isutf8 = SvUTF8(ST(0)); #if (CYGWIN_VERSION_API_MINOR >= 181) /* Check utf8 flag and use wide api then. Size calculation: On overflow let cygwin_conv_path calculate the final size. */ if (isutf8) { - int what = absolute_flag ? CCP_POSIX_TO_WIN_W : CCP_POSIX_TO_WIN_W | CCP_RELATIVE; - int wlen = sizeof(wchar_t)*(len + 260 + 1001); - wchar_t *wpath = (wchar_t *) safemalloc(sizeof(wchar_t)*len); - wchar_t *wbuf = (wchar_t *) safemalloc(wlen); - char *oldlocale; - - LOCALE_LOCK; - - oldlocale = setlocale(LC_CTYPE, NULL); - setlocale(LC_CTYPE, "utf-8"); - if (!IN_BYTES) { - mbstate_t mbs; - /* utf8_to_uvchr_buf(src_path, src_path + wlen, wpath) or Encoding::_utf8_to_bytes(sv, "UCS-2BE"); */ - wlen = mbsrtowcs(wpath, (const char**)&src_path, wlen, &mbs); - if (wlen > 0) - err = cygwin_conv_path(what, wpath, wbuf, wlen); - } else { /* use bytes; assume already ucs-2 encoded bytestream */ - err = cygwin_conv_path(what, src_path, wbuf, wlen); - } - if (err == ENOSPC) { /* our space assumption was wrong, not enough space */ - int newlen = cygwin_conv_path(what, wpath, wbuf, 0); - wbuf = (wchar_t *) realloc(&wbuf, newlen); - err = cygwin_conv_path(what, wpath, wbuf, newlen); - wlen = newlen; - } - /* also see utf8.c: Perl_utf16_to_utf8() or Encoding::_bytes_to_utf8(sv, "UCS-2BE"); */ - wlen = wcsrtombs(NULL, (const wchar_t **)&wbuf, wlen, NULL); - win_path = (char *) safemalloc(wlen+1); - wcsrtombs(win_path, (const wchar_t **)&wbuf, wlen, NULL); - if (oldlocale) setlocale(LC_CTYPE, oldlocale); - else setlocale(LC_CTYPE, "C"); - - LOCALE_UNLOCK; + int what = absolute_flag ? CCP_POSIX_TO_WIN_W : CCP_POSIX_TO_WIN_W | CCP_RELATIVE; + int wlen = sizeof(wchar_t)*(len + 260 + 1001); + wchar_t *wpath = (wchar_t *) safemalloc(sizeof(wchar_t)*len); + wchar_t *wbuf = (wchar_t *) safemalloc(wlen); + char *oldlocale; + + SETLOCALE_LOCK; + + oldlocale = setlocale(LC_CTYPE, NULL); + setlocale(LC_CTYPE, "utf-8"); + if (!IN_BYTES) { + mbstate_t mbs; + /* utf8_to_uvchr_buf(src_path, src_path + wlen, wpath) or Encoding::_utf8_to_bytes(sv, "UCS-2BE"); */ + wlen = mbsrtowcs(wpath, (const char**)&src_path, wlen, &mbs); + if (wlen > 0) + err = cygwin_conv_path(what, wpath, wbuf, wlen); + } else { /* use bytes; assume already ucs-2 encoded bytestream */ + err = cygwin_conv_path(what, src_path, wbuf, wlen); + } + if (err == ENOSPC) { /* our space assumption was wrong, not enough space */ + int newlen = cygwin_conv_path(what, wpath, wbuf, 0); + wbuf = (wchar_t *) realloc(&wbuf, newlen); + err = cygwin_conv_path(what, wpath, wbuf, newlen); + wlen = newlen; + } + /* also see utf8.c: Perl_utf16_to_utf8() or Encoding::_bytes_to_utf8(sv, "UCS-2BE"); */ + wlen = wcsrtombs(NULL, (const wchar_t **)&wbuf, wlen, NULL); + win_path = (char *) safemalloc(wlen+1); + wcsrtombs(win_path, (const wchar_t **)&wbuf, wlen, NULL); + if (oldlocale) setlocale(LC_CTYPE, oldlocale); + else setlocale(LC_CTYPE, "C"); + + SETLOCALE_UNLOCK; } else { - int what = absolute_flag ? CCP_POSIX_TO_WIN_A : CCP_POSIX_TO_WIN_A | CCP_RELATIVE; - win_path = (char *) safemalloc(len + 260 + 1001); - err = cygwin_conv_path(what, src_path, win_path, len + 260 + 1001); - if (err == ENOSPC) { /* our space assumption was wrong, not enough space */ - int newlen = cygwin_conv_path(what, src_path, win_path, 0); - win_path = (char *) realloc(&win_path, newlen); - err = cygwin_conv_path(what, src_path, win_path, newlen); - } + int what = absolute_flag ? CCP_POSIX_TO_WIN_A : CCP_POSIX_TO_WIN_A | CCP_RELATIVE; + win_path = (char *) safemalloc(len + 260 + 1001); + err = cygwin_conv_path(what, src_path, win_path, len + 260 + 1001); + if (err == ENOSPC) { /* our space assumption was wrong, not enough space */ + int newlen = cygwin_conv_path(what, src_path, win_path, 0); + win_path = (char *) realloc(&win_path, newlen); + err = cygwin_conv_path(what, src_path, win_path, newlen); + } } #else if (isutf8) - Perl_warn(aTHX_ "can't convert utf8 path"); + Perl_warn(aTHX_ "can't convert utf8 path"); win_path = (char *) safemalloc(len + 260 + 1001); if (absolute_flag) - err = cygwin_conv_to_full_win32_path(src_path, win_path); + err = cygwin_conv_to_full_win32_path(src_path, win_path); else - err = cygwin_conv_to_win32_path(src_path, win_path); + err = cygwin_conv_to_win32_path(src_path, win_path); #endif if (!err) { - EXTEND(SP, 1); - ST(0) = sv_2mortal(newSVpv(win_path, 0)); - if (isutf8) { - SvUTF8_on(ST(0)); - } - safefree(win_path); - XSRETURN(1); + EXTEND(SP, 1); + ST(0) = sv_2mortal(newSVpv(win_path, 0)); + if (isutf8) { + SvUTF8_on(ST(0)); + } + safefree(win_path); + XSRETURN(1); } else { - safefree(win_path); - XSRETURN_UNDEF; + safefree(win_path); + XSRETURN_UNDEF; } } @@ -469,12 +469,12 @@ XS(XS_Cygwin_mount_table) setmntent (0, 0); while ((mnt = getmntent (0))) { - AV* av = newAV(); - av_push(av, newSVpvn(mnt->mnt_dir, strlen(mnt->mnt_dir))); - av_push(av, newSVpvn(mnt->mnt_fsname, strlen(mnt->mnt_fsname))); - av_push(av, newSVpvn(mnt->mnt_type, strlen(mnt->mnt_type))); - av_push(av, newSVpvn(mnt->mnt_opts, strlen(mnt->mnt_opts))); - XPUSHs(sv_2mortal(newRV_noinc((SV*)av))); + AV* av = newAV(); + av_push(av, newSVpvn(mnt->mnt_dir, strlen(mnt->mnt_dir))); + av_push(av, newSVpvn(mnt->mnt_fsname, strlen(mnt->mnt_fsname))); + av_push(av, newSVpvn(mnt->mnt_type, strlen(mnt->mnt_type))); + av_push(av, newSVpvn(mnt->mnt_opts, strlen(mnt->mnt_opts))); + XPUSHs(sv_2mortal(newRV_noinc((SV*)av))); } endmntent (0); PUTBACK; @@ -493,13 +493,13 @@ XS(XS_Cygwin_mount_flags) pathname = SvPV_nolen(ST(0)); if (strEQ(pathname, "/cygdrive")) { - char user[PATH_MAX]; - char system[PATH_MAX]; - char user_flags[PATH_MAX]; - char system_flags[PATH_MAX]; + char user[PATH_MAX]; + char system[PATH_MAX]; + char user_flags[PATH_MAX]; + char system_flags[PATH_MAX]; - cygwin_internal (CW_GET_CYGDRIVE_INFO, user, system, - user_flags, system_flags); + cygwin_internal (CW_GET_CYGDRIVE_INFO, user, system, + user_flags, system_flags); if (strlen(user) > 0) { sprintf(flags, "%s,cygdrive,%s", user_flags, user); @@ -507,56 +507,56 @@ XS(XS_Cygwin_mount_flags) sprintf(flags, "%s,cygdrive,%s", system_flags, system); } - ST(0) = sv_2mortal(newSVpv(flags, 0)); - XSRETURN(1); + ST(0) = sv_2mortal(newSVpv(flags, 0)); + XSRETURN(1); } else { - struct mntent *mnt; - int found = 0; - setmntent (0, 0); - while ((mnt = getmntent (0))) { - if (strEQ(pathname, mnt->mnt_dir)) { - strcpy(flags, mnt->mnt_type); - if (strlen(mnt->mnt_opts) > 0) { - strcat(flags, ","); - strcat(flags, mnt->mnt_opts); - } - found++; - break; - } - } - endmntent (0); - - /* Check if arg is the current volume moint point if not default, - * and then use CW_GET_CYGDRIVE_INFO also. - */ - if (!found) { - char user[PATH_MAX]; - char system[PATH_MAX]; - char user_flags[PATH_MAX]; - char system_flags[PATH_MAX]; - - cygwin_internal (CW_GET_CYGDRIVE_INFO, user, system, - user_flags, system_flags); - - if (strlen(user) > 0) { - if (strNE(user,pathname)) { - sprintf(flags, "%s,cygdrive,%s", user_flags, user); - found++; - } - } else { - if (strNE(user,pathname)) { - sprintf(flags, "%s,cygdrive,%s", system_flags, system); - found++; - } - } - } - if (found) { - ST(0) = sv_2mortal(newSVpv(flags, 0)); - XSRETURN(1); - } else { - XSRETURN_UNDEF; - } + struct mntent *mnt; + int found = 0; + setmntent (0, 0); + while ((mnt = getmntent (0))) { + if (strEQ(pathname, mnt->mnt_dir)) { + strcpy(flags, mnt->mnt_type); + if (strlen(mnt->mnt_opts) > 0) { + strcat(flags, ","); + strcat(flags, mnt->mnt_opts); + } + found++; + break; + } + } + endmntent (0); + + /* Check if arg is the current volume moint point if not default, + * and then use CW_GET_CYGDRIVE_INFO also. + */ + if (!found) { + char user[PATH_MAX]; + char system[PATH_MAX]; + char user_flags[PATH_MAX]; + char system_flags[PATH_MAX]; + + cygwin_internal (CW_GET_CYGDRIVE_INFO, user, system, + user_flags, system_flags); + + if (strlen(user) > 0) { + if (strNE(user,pathname)) { + sprintf(flags, "%s,cygdrive,%s", user_flags, user); + found++; + } + } else { + if (strNE(user,pathname)) { + sprintf(flags, "%s,cygdrive,%s", system_flags, system); + found++; + } + } + } + if (found) { + ST(0) = sv_2mortal(newSVpv(flags, 0)); + XSRETURN(1); + } else { + XSRETURN_UNDEF; + } } } diff --git a/deb.c b/deb.c index bd6e538977bc..e2d734135c2e 100644 --- a/deb.c +++ b/deb.c @@ -66,10 +66,10 @@ Perl_vdeb(pTHX_ const char *pat, va_list *args) PERL_ARGS_ASSERT_VDEB; if (DEBUG_v_TEST) - PerlIO_printf(Perl_debug_log, "(%ld:%s:%ld)\t", - (long)PerlProc_getpid(), display_file, line); + PerlIO_printf(Perl_debug_log, "(%ld:%s:%ld)\t", + (long)PerlProc_getpid(), display_file, line); else - PerlIO_printf(Perl_debug_log, "(%s:%ld)\t", display_file, line); + PerlIO_printf(Perl_debug_log, "(%s:%ld)\t", display_file, line); (void) PerlIO_vprintf(Perl_debug_log, pat, *args); #else PERL_UNUSED_CONTEXT; @@ -83,15 +83,15 @@ Perl_debstackptrs(pTHX) { #ifdef DEBUGGING PerlIO_printf(Perl_debug_log, - "%8" UVxf " %8" UVxf " %8" IVdf " %8" IVdf " %8" IVdf "\n", - PTR2UV(PL_curstack), PTR2UV(PL_stack_base), - (IV)*PL_markstack_ptr, (IV)(PL_stack_sp-PL_stack_base), - (IV)(PL_stack_max-PL_stack_base)); + "%8" UVxf " %8" UVxf " %8" IVdf " %8" IVdf " %8" IVdf "\n", + PTR2UV(PL_curstack), PTR2UV(PL_stack_base), + (IV)*PL_markstack_ptr, (IV)(PL_stack_sp-PL_stack_base), + (IV)(PL_stack_max-PL_stack_base)); PerlIO_printf(Perl_debug_log, - "%8" UVxf " %8" UVxf " %8" UVuf " %8" UVuf " %8" UVuf "\n", - PTR2UV(PL_mainstack), PTR2UV(AvARRAY(PL_curstack)), - PTR2UV(PL_mainstack), PTR2UV(AvFILLp(PL_curstack)), - PTR2UV(AvMAX(PL_curstack))); + "%8" UVxf " %8" UVxf " %8" UVuf " %8" UVuf " %8" UVuf "\n", + PTR2UV(PL_mainstack), PTR2UV(AvARRAY(PL_curstack)), + PTR2UV(PL_mainstack), PTR2UV(AvFILLp(PL_curstack)), + PTR2UV(AvMAX(PL_curstack))); #else PERL_UNUSED_CONTEXT; #endif /* DEBUGGING */ @@ -110,7 +110,7 @@ Perl_debstackptrs(pTHX) STATIC void S_deb_stack_n(pTHX_ SV** stack_base, I32 stack_min, I32 stack_max, - I32 mark_min, I32 mark_max) + I32 mark_min, I32 mark_max) { #ifdef DEBUGGING I32 i = stack_max - 30; @@ -119,30 +119,30 @@ S_deb_stack_n(pTHX_ SV** stack_base, I32 stack_min, I32 stack_max, PERL_ARGS_ASSERT_DEB_STACK_N; if (i < stack_min) - i = stack_min; + i = stack_min; while (++markscan <= PL_markstack + mark_max) - if (*markscan >= i) - break; + if (*markscan >= i) + break; if (i > stack_min) - PerlIO_printf(Perl_debug_log, "... "); + PerlIO_printf(Perl_debug_log, "... "); if (stack_base[0] != &PL_sv_undef || stack_max < 0) - PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n"); + PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n"); do { - ++i; - if (markscan <= PL_markstack + mark_max && *markscan < i) { - do { - ++markscan; - (void)PerlIO_putc(Perl_debug_log, '*'); - } - while (markscan <= PL_markstack + mark_max && *markscan < i); - PerlIO_printf(Perl_debug_log, " "); - } - if (i > stack_max) - break; - PerlIO_printf(Perl_debug_log, "%-4s ", SvPEEK(stack_base[i])); + ++i; + if (markscan <= PL_markstack + mark_max && *markscan < i) { + do { + ++markscan; + (void)PerlIO_putc(Perl_debug_log, '*'); + } + while (markscan <= PL_markstack + mark_max && *markscan < i); + PerlIO_printf(Perl_debug_log, " "); + } + if (i > stack_max) + break; + PerlIO_printf(Perl_debug_log, "%-4s ", SvPEEK(stack_base[i])); } while (1); PerlIO_printf(Perl_debug_log, "\n"); @@ -164,14 +164,14 @@ Perl_debstack(pTHX) { #ifndef SKIP_DEBUGGING if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_) - return 0; + return 0; PerlIO_printf(Perl_debug_log, " => "); deb_stack_n(PL_stack_base, - 0, - PL_stack_sp - PL_stack_base, - PL_curstackinfo->si_markoff, - PL_markstack_ptr - PL_markstack); + 0, + PL_stack_sp - PL_stack_base, + PL_curstackinfo->si_markoff, + PL_markstack_ptr - PL_markstack); #endif /* SKIP_DEBUGGING */ @@ -209,7 +209,7 @@ Perl_deb_stack_all(pTHX) /* rewind to start of chain */ si = PL_curstackinfo; while (si->si_prev) - si = si->si_prev; + si = si->si_prev; si_ix=0; for (;;) @@ -218,107 +218,107 @@ Perl_deb_stack_all(pTHX) const char * const si_name = si_name_ix < C_ARRAY_LENGTH(si_names) ? si_names[si_name_ix] : "????"; - I32 ix; - PerlIO_printf(Perl_debug_log, "STACK %" IVdf ": %s\n", - (IV)si_ix, si_name); - - for (ix=0; ix<=si->si_cxix; ix++) { - - const PERL_CONTEXT * const cx = &(si->si_cxstack[ix]); - PerlIO_printf(Perl_debug_log, - " CX %" IVdf ": %-6s => ", - (IV)ix, PL_block_type[CxTYPE(cx)] - ); - /* substitution contexts don't save stack pointers etc) */ - if (CxTYPE(cx) == CXt_SUBST) - PerlIO_printf(Perl_debug_log, "\n"); - else { - - /* Find the current context's stack range by searching - * forward for any higher contexts using this stack; failing - * that, it will be equal to the size of the stack for old - * stacks, or PL_stack_sp for the current stack - */ - - I32 i, stack_min, stack_max, mark_min, mark_max; - const PERL_CONTEXT *cx_n = NULL; - const PERL_SI *si_n; + I32 ix; + PerlIO_printf(Perl_debug_log, "STACK %" IVdf ": %s\n", + (IV)si_ix, si_name); + + for (ix=0; ix<=si->si_cxix; ix++) { + + const PERL_CONTEXT * const cx = &(si->si_cxstack[ix]); + PerlIO_printf(Perl_debug_log, + " CX %" IVdf ": %-6s => ", + (IV)ix, PL_block_type[CxTYPE(cx)] + ); + /* substitution contexts don't save stack pointers etc) */ + if (CxTYPE(cx) == CXt_SUBST) + PerlIO_printf(Perl_debug_log, "\n"); + else { + + /* Find the current context's stack range by searching + * forward for any higher contexts using this stack; failing + * that, it will be equal to the size of the stack for old + * stacks, or PL_stack_sp for the current stack + */ + + I32 i, stack_min, stack_max, mark_min, mark_max; + const PERL_CONTEXT *cx_n = NULL; + const PERL_SI *si_n; /* there's a separate argument stack per SI, so only * search this one */ - for (i=ix+1; i<=si->si_cxix; i++) { + for (i=ix+1; i<=si->si_cxix; i++) { const PERL_CONTEXT *this_cx = &(si->si_cxstack[i]); if (CxTYPE(this_cx) == CXt_SUBST) - continue; - cx_n = this_cx; - break; - } - - stack_min = cx->blk_oldsp; - - if (cx_n) { - stack_max = cx_n->blk_oldsp; - } - else if (si == PL_curstackinfo) { - stack_max = PL_stack_sp - AvARRAY(si->si_stack); - } - else { - stack_max = AvFILLp(si->si_stack); - } + continue; + cx_n = this_cx; + break; + } + + stack_min = cx->blk_oldsp; + + if (cx_n) { + stack_max = cx_n->blk_oldsp; + } + else if (si == PL_curstackinfo) { + stack_max = PL_stack_sp - AvARRAY(si->si_stack); + } + else { + stack_max = AvFILLp(si->si_stack); + } /* for the markstack, there's only one stack shared * between all SIs */ - si_n = si; - i = ix; - cx_n = NULL; - for (;;) { - i++; - if (i > si_n->si_cxix) { - if (si_n == PL_curstackinfo) - break; - else { - si_n = si_n->si_next; - i = 0; - } - } - if (CxTYPE(&(si_n->si_cxstack[i])) == CXt_SUBST) - continue; - cx_n = &(si_n->si_cxstack[i]); - break; - } - - mark_min = cx->blk_oldmarksp; - if (cx_n) { - mark_max = cx_n->blk_oldmarksp; - } - else { - mark_max = PL_markstack_ptr - PL_markstack; - } - - deb_stack_n(AvARRAY(si->si_stack), - stack_min, stack_max, mark_min, mark_max); - - if (CxTYPE(cx) == CXt_EVAL || CxTYPE(cx) == CXt_SUB - || CxTYPE(cx) == CXt_FORMAT) - { - const OP * const retop = cx->blk_sub.retop; - - PerlIO_printf(Perl_debug_log, " retop=%s\n", - retop ? OP_NAME(retop) : "(null)" - ); - } - } - } /* next context */ - - - if (si == PL_curstackinfo) - break; - si = si->si_next; - si_ix++; - if (!si) - break; /* shouldn't happen, but just in case.. */ + si_n = si; + i = ix; + cx_n = NULL; + for (;;) { + i++; + if (i > si_n->si_cxix) { + if (si_n == PL_curstackinfo) + break; + else { + si_n = si_n->si_next; + i = 0; + } + } + if (CxTYPE(&(si_n->si_cxstack[i])) == CXt_SUBST) + continue; + cx_n = &(si_n->si_cxstack[i]); + break; + } + + mark_min = cx->blk_oldmarksp; + if (cx_n) { + mark_max = cx_n->blk_oldmarksp; + } + else { + mark_max = PL_markstack_ptr - PL_markstack; + } + + deb_stack_n(AvARRAY(si->si_stack), + stack_min, stack_max, mark_min, mark_max); + + if (CxTYPE(cx) == CXt_EVAL || CxTYPE(cx) == CXt_SUB + || CxTYPE(cx) == CXt_FORMAT) + { + const OP * const retop = cx->blk_sub.retop; + + PerlIO_printf(Perl_debug_log, " retop=%s\n", + retop ? OP_NAME(retop) : "(null)" + ); + } + } + } /* next context */ + + + if (si == PL_curstackinfo) + break; + si = si->si_next; + si_ix++; + if (!si) + break; /* shouldn't happen, but just in case.. */ } /* next stackinfo */ PerlIO_printf(Perl_debug_log, "\n"); diff --git a/dist/Carp/.gitignore b/dist/Carp/.gitignore new file mode 100644 index 000000000000..e54624d60d99 --- /dev/null +++ b/dist/Carp/.gitignore @@ -0,0 +1 @@ +!/Makefile.PL diff --git a/dist/Carp/lib/Carp.pm b/dist/Carp/lib/Carp.pm index 109b7fec7703..df563d06a251 100644 --- a/dist/Carp/lib/Carp.pm +++ b/dist/Carp/lib/Carp.pm @@ -211,7 +211,7 @@ BEGIN { } -our $VERSION = '1.50'; +our $VERSION = '1.52'; $VERSION =~ tr/_//d; our $MaxEvalLen = 0; @@ -284,7 +284,7 @@ sub shortmess { my $cgc = _cgc(); # Icky backwards compatibility wrapper. :-( - local @CARP_NOT = $cgc ? $cgc->() : caller(); + local @CARP_NOT = scalar( $cgc ? $cgc->() : caller() ); shortmess_heavy(@_); } @@ -944,10 +944,10 @@ This variable sets a general argument formatter to display references. Plain scalars and objects that implement C will not go through this formatter. Calling C from within this function is not supported. -local $Carp::RefArgFormatter = sub { - require Data::Dumper; - Data::Dumper::Dump($_[0]); # not necessarily safe -}; + local $Carp::RefArgFormatter = sub { + require Data::Dumper; + Data::Dumper->Dump($_[0]); # not necessarily safe + }; =head2 @CARP_NOT diff --git a/dist/Carp/lib/Carp/Heavy.pm b/dist/Carp/lib/Carp/Heavy.pm index a9b803c76ad6..fdb3e52ef616 100644 --- a/dist/Carp/lib/Carp/Heavy.pm +++ b/dist/Carp/lib/Carp/Heavy.pm @@ -2,7 +2,7 @@ package Carp::Heavy; use Carp (); -our $VERSION = '1.50'; +our $VERSION = '1.52'; $VERSION =~ tr/_//d; # Carp::Heavy was merged into Carp in version 1.12. Any mismatched versions diff --git a/dist/Devel-PPPort/.gitignore b/dist/Devel-PPPort/.gitignore index 0fa82e0976ce..857c79fe887b 100644 --- a/dist/Devel-PPPort/.gitignore +++ b/dist/Devel-PPPort/.gitignore @@ -19,3 +19,6 @@ PPPort.bs /Devel-PPPort-*.tar.gz /Devel-PPPort-*/ /t/*.t +!/Makefile.PL +!/module2.c +!/module3.c diff --git a/dist/ExtUtils-CBuilder/.gitignore b/dist/ExtUtils-CBuilder/.gitignore new file mode 100644 index 000000000000..e54624d60d99 --- /dev/null +++ b/dist/ExtUtils-CBuilder/.gitignore @@ -0,0 +1 @@ +!/Makefile.PL diff --git a/dist/ExtUtils-CBuilder/Changes b/dist/ExtUtils-CBuilder/Changes index bb7e565062a1..5cb89e424040 100644 --- a/dist/ExtUtils-CBuilder/Changes +++ b/dist/ExtUtils-CBuilder/Changes @@ -1,5 +1,12 @@ Revision history for Perl extension ExtUtils::CBuilder. +0.280235 - 2020-11-01 + + Fix: + + - Fix compilation on darwin with XCode 12 (-Werror=implicit-function-declaration) + Thanks to DrHyde for the patch. + 0.280234 - 2020-01-21 Update: diff --git a/dist/ExtUtils-CBuilder/Makefile.PL b/dist/ExtUtils-CBuilder/Makefile.PL index 7dac2abac378..5b7dd5dc7447 100644 --- a/dist/ExtUtils-CBuilder/Makefile.PL +++ b/dist/ExtUtils-CBuilder/Makefile.PL @@ -1,4 +1,4 @@ -# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.012. +# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.015. use strict; use warnings; @@ -29,7 +29,7 @@ my %WriteMakefileArgs = ( "TEST_REQUIRES" => { "Test::More" => "0.47" }, - "VERSION" => "0.280234", + "VERSION" => "0.280235", "test" => { "TESTS" => "t/*.t" } diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder.pm index 60b1662d58ee..3286015ef3fd 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder.pm @@ -7,7 +7,7 @@ use Perl::OSType qw/os_type/; use warnings; use strict; -our $VERSION = '0.280234'; # VERSION +our $VERSION = '0.280235'; # VERSION our @ISA; # We only use this once - don't waste a symbol table entry on it. diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Base.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Base.pm index 638014352c63..a72a7cb34f78 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Base.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Base.pm @@ -9,7 +9,7 @@ use Text::ParseWords; use IPC::Cmd qw(can_run); use File::Temp qw(tempfile); -our $VERSION = '0.280234'; # VERSION +our $VERSION = '0.280235'; # VERSION # More details about C/C++ compilers: # http://developers.sun.com/sunstudio/documentation/product/compiler.jsp diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Unix.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Unix.pm index e73933fea1f5..4005366e4454 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Unix.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Unix.pm @@ -4,7 +4,7 @@ use warnings; use strict; use ExtUtils::CBuilder::Base; -our $VERSION = '0.280234'; # VERSION +our $VERSION = '0.280235'; # VERSION our @ISA = qw(ExtUtils::CBuilder::Base); sub link_executable { diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/VMS.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/VMS.pm index dc3e91b7b984..f0ce477441e7 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/VMS.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/VMS.pm @@ -4,7 +4,7 @@ use warnings; use strict; use ExtUtils::CBuilder::Base; -our $VERSION = '0.280234'; # VERSION +our $VERSION = '0.280235'; # VERSION our @ISA = qw(ExtUtils::CBuilder::Base); use File::Spec::Functions qw(catfile catdir); diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows.pm index 35093d16f12d..b017d7ab5a93 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows.pm @@ -8,7 +8,7 @@ use File::Spec; use ExtUtils::CBuilder::Base; use IO::File; -our $VERSION = '0.280234'; # VERSION +our $VERSION = '0.280235'; # VERSION our @ISA = qw(ExtUtils::CBuilder::Base); =begin comment diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/BCC.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/BCC.pm index 98bdb2d367fe..35e80278db82 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/BCC.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/BCC.pm @@ -1,6 +1,6 @@ package ExtUtils::CBuilder::Platform::Windows::BCC; -our $VERSION = '0.280234'; # VERSION +our $VERSION = '0.280235'; # VERSION use strict; use warnings; diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/GCC.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/GCC.pm index 5854d57a8f31..46650e94cd20 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/GCC.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/GCC.pm @@ -1,6 +1,6 @@ package ExtUtils::CBuilder::Platform::Windows::GCC; -our $VERSION = '0.280234'; # VERSION +our $VERSION = '0.280235'; # VERSION use warnings; use strict; diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/MSVC.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/MSVC.pm index 6a9158020bd1..3f8337da78ae 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/MSVC.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/MSVC.pm @@ -1,6 +1,6 @@ package ExtUtils::CBuilder::Platform::Windows::MSVC; -our $VERSION = '0.280234'; # VERSION +our $VERSION = '0.280235'; # VERSION use warnings; use strict; diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/aix.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/aix.pm index 8b1572d782af..57ceb8a22fc7 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/aix.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/aix.pm @@ -5,7 +5,7 @@ use strict; use ExtUtils::CBuilder::Platform::Unix; use File::Spec; -our $VERSION = '0.280234'; # VERSION +our $VERSION = '0.280235'; # VERSION our @ISA = qw(ExtUtils::CBuilder::Platform::Unix); sub need_prelink { 1 } diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/android.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/android.pm index 70eb6cf98709..591651537329 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/android.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/android.pm @@ -6,7 +6,7 @@ use File::Spec; use ExtUtils::CBuilder::Platform::Unix; use Config; -our $VERSION = '0.280234'; # VERSION +our $VERSION = '0.280235'; # VERSION our @ISA = qw(ExtUtils::CBuilder::Platform::Unix); # The Android linker will not recognize symbols from diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/cygwin.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/cygwin.pm index 40d93357ffe4..9474bfda5e1b 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/cygwin.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/cygwin.pm @@ -5,7 +5,7 @@ use strict; use File::Spec; use ExtUtils::CBuilder::Platform::Unix; -our $VERSION = '0.280234'; # VERSION +our $VERSION = '0.280235'; # VERSION our @ISA = qw(ExtUtils::CBuilder::Platform::Unix); # TODO: If a specific exe_file name is requested, if the exe created diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/darwin.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/darwin.pm index 28deb76580e2..3787f39d0049 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/darwin.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/darwin.pm @@ -4,7 +4,7 @@ use warnings; use strict; use ExtUtils::CBuilder::Platform::Unix; -our $VERSION = '0.280234'; # VERSION +our $VERSION = '0.280235'; # VERSION our @ISA = qw(ExtUtils::CBuilder::Platform::Unix); sub compile { @@ -15,6 +15,10 @@ sub compile { # it's mistakenly in Config.pm as both. Make the correction here. local $cf->{ccflags} = $cf->{ccflags}; $cf->{ccflags} =~ s/-flat_namespace//; + + # XCode 12 makes this fatal, breaking tons of XS modules + $cf->{ccflags} .= ($cf->{ccflags} ? ' ' : '').'-Wno-error=implicit-function-declaration'; + $self->SUPER::compile(@_); } diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/dec_osf.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/dec_osf.pm index 1185f06344fc..98cb235f98a0 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/dec_osf.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/dec_osf.pm @@ -5,7 +5,7 @@ use strict; use ExtUtils::CBuilder::Platform::Unix; use File::Spec; -our $VERSION = '0.280234'; # VERSION +our $VERSION = '0.280235'; # VERSION our @ISA = qw(ExtUtils::CBuilder::Platform::Unix); sub link_executable { diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/os2.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/os2.pm index b9fae17c28f5..8e1377f12c25 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/os2.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/os2.pm @@ -4,7 +4,7 @@ use warnings; use strict; use ExtUtils::CBuilder::Platform::Unix; -our $VERSION = '0.280234'; # VERSION +our $VERSION = '0.280235'; # VERSION our @ISA = qw(ExtUtils::CBuilder::Platform::Unix); sub need_prelink { 1 } diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm index 18ed08f7c8a3..39f9df933b66 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm @@ -11,7 +11,7 @@ use Symbol; our $VERSION; BEGIN { - $VERSION = '3.41'; + $VERSION = '3.42'; require ExtUtils::ParseXS::Constants; ExtUtils::ParseXS::Constants->VERSION($VERSION); require ExtUtils::ParseXS::CountLines; ExtUtils::ParseXS::CountLines->VERSION($VERSION); require ExtUtils::ParseXS::Utilities; ExtUtils::ParseXS::Utilities->VERSION($VERSION); @@ -42,6 +42,7 @@ use ExtUtils::ParseXS::Utilities qw( our @EXPORT_OK = qw( process_file report_error_count + errors ); ############################## @@ -1012,6 +1013,7 @@ sub report_error_count { return $Singleton->{errors}||0; } } +*errors = \&report_error_count; # Input: ($self, $_, @{ $self->{line} }) == unparsed input. # Output: ($_, @{ $self->{line} }) == (rest of line, following lines). diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Constants.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Constants.pm index a972b63da7a1..869836c37f7a 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Constants.pm +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Constants.pm @@ -3,7 +3,7 @@ use strict; use warnings; use Symbol; -our $VERSION = '3.41'; +our $VERSION = '3.42'; =head1 NAME diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/CountLines.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/CountLines.pm index bb6450e457bd..57aa90d90f7e 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/CountLines.pm +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/CountLines.pm @@ -1,7 +1,7 @@ package ExtUtils::ParseXS::CountLines; use strict; -our $VERSION = '3.41'; +our $VERSION = '3.42'; our $SECTION_END_MARKER; diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Eval.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Eval.pm index 97aea542cd98..45c4ba167295 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Eval.pm +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Eval.pm @@ -2,7 +2,7 @@ package ExtUtils::ParseXS::Eval; use strict; use warnings; -our $VERSION = '3.41'; +our $VERSION = '3.42'; =head1 NAME diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm index 37b89deed5ed..faf53cbc74f5 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm @@ -5,7 +5,7 @@ use Exporter; use File::Spec; use ExtUtils::ParseXS::Constants (); -our $VERSION = '3.41'; +our $VERSION = '3.42'; our (@ISA, @EXPORT_OK); @ISA = qw(Exporter); diff --git a/dist/ExtUtils-ParseXS/lib/perlxs.pod b/dist/ExtUtils-ParseXS/lib/perlxs.pod index 6a48d7e23ad6..4a339ddfd998 100644 --- a/dist/ExtUtils-ParseXS/lib/perlxs.pod +++ b/dist/ExtUtils-ParseXS/lib/perlxs.pod @@ -2103,7 +2103,8 @@ File C: Interface to some ONC+ RPC bind library functions. #include "perl.h" #include "XSUB.h" - #include + /* Note: On glibc 2.13 and earlier, this needs be */ + #include typedef struct netconfig Netconfig; @@ -2163,6 +2164,8 @@ File C: Perl test program for the RPC extension. print "time = $a\n"; print "netconf = $netconf\n"; +In Makefile.PL add -ltirpc and -I/usr/include/tirpc. + =head1 CAVEATS XS code has full access to system calls including C library functions. diff --git a/dist/ExtUtils-ParseXS/lib/perlxstut.pod b/dist/ExtUtils-ParseXS/lib/perlxstut.pod index f9fe9e76fe90..8e1372167073 100644 --- a/dist/ExtUtils-ParseXS/lib/perlxstut.pod +++ b/dist/ExtUtils-ParseXS/lib/perlxstut.pod @@ -115,14 +115,15 @@ Mytest directory. The file Makefile.PL should look something like this: use ExtUtils::MakeMaker; + # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( - NAME => 'Mytest', - VERSION_FROM => 'Mytest.pm', # finds $VERSION - LIBS => [''], # e.g., '-lm' - DEFINE => '', # e.g., '-DHAVE_SOMETHING' - INC => '', # e.g., '-I/usr/include/other' + NAME => 'Mytest', + VERSION_FROM => 'Mytest.pm', # finds $VERSION + LIBS => [''], # e.g., '-lm' + DEFINE => '', # e.g., '-DHAVE_SOMETHING' + INC => '-I', # e.g., '-I. -I/usr/include/other' ); The file Mytest.pm should start with something like this: @@ -276,9 +277,9 @@ when the test is correct, "not ok" when it is not. # so read its man page ( perldoc Test::More ) for help writing this # test script. - is(&Mytest::is_even(0), 1); - is(&Mytest::is_even(1), 0); - is(&Mytest::is_even(2), 1); + is( Mytest::is_even(0), 1 ); + is( Mytest::is_even(1), 0 ); + is( Mytest::is_even(2), 1 ); We will be calling the test script through the command "C". You should see output that looks something like this: @@ -390,16 +391,32 @@ Add the following to the end of Mytest.xs: Edit the Makefile.PL file so that the corresponding line looks like this: - 'LIBS' => ['-lm'], # e.g., '-lm' + LIBS => ['-lm'], # e.g., '-lm' Generate the Makefile and run make. Change the test number in Mytest.t to "9" and add the following tests: - $i = -1.5; &Mytest::round($i); is( $i, -2.0 ); - $i = -1.1; &Mytest::round($i); is( $i, -1.0 ); - $i = 0.0; &Mytest::round($i); is( $i, 0.0 ); - $i = 0.5; &Mytest::round($i); is( $i, 1.0 ); - $i = 1.2; &Mytest::round($i); is( $i, 1.0 ); + my $i; + + $i = -1.5; + Mytest::round($i); + is( $i, -2.0, 'Rounding -1.5 to -2.0' ); + + $i = -1.1; + Mytest::round($i); + is( $i, -1.0, 'Rounding -1.1 to -1.0' ); + + $i = 0.0; + Mytest::round($i); + is( $i, 0.0, 'Rounding 0.0 to 0.0' ); + + $i = 0.5; + Mytest::round($i); + is( $i, 1.0, 'Rounding 0.5 to 1.0' ); + + $i = 1.2; + Mytest::round($i); + is( $i, 1.0, 'Rounding 1.2 to 1.0' ); Running "C" should now print out that all nine tests are okay. @@ -407,7 +424,7 @@ Notice that in these new test cases, the argument passed to round was a scalar variable. You might be wondering if you can round a constant or literal. To see what happens, temporarily add the following line to Mytest.t: - &Mytest::round(3); + Mytest::round(3); Run "C" and notice that Perl dies with a fatal error. Perl won't let you change the value of constants! @@ -534,7 +551,7 @@ In the mylib directory, create a file mylib.h that looks like this: Also create a file mylib.c that looks like this: #include - #include "./mylib.h" + #include "mylib.h" double foo(int a, long b, const char *c) @@ -547,9 +564,9 @@ And finally create a file Makefile.PL that looks like this: use ExtUtils::MakeMaker; $Verbose = 1; WriteMakefile( - NAME => 'Mytest2::mylib', - SKIP => [qw(all static static_lib dynamic dynamic_lib)], - clean => {'FILES' => 'libmylib$(LIB_EXT)'}, + NAME => 'Mytest2::mylib', + SKIP => [qw(all static static_lib dynamic dynamic_lib)], + clean => {'FILES' => 'libmylib$(LIB_EXT)'}, ); @@ -576,7 +593,7 @@ on Win32 systems. We will now create the main top-level Mytest2 files. Change to the directory above Mytest2 and run the following command: - % h2xs -O -n Mytest2 ./Mytest2/mylib/mylib.h + % h2xs -O -n Mytest2 Mytest2/mylib/mylib.h This will print out a warning about overwriting Mytest2, but that's okay. Our files are stored in Mytest2/mylib, and will be untouched. @@ -587,12 +604,12 @@ will be generating a library in it. Let's add the argument MYEXTLIB to the WriteMakefile call so that it looks like this: WriteMakefile( - 'NAME' => 'Mytest2', - 'VERSION_FROM' => 'Mytest2.pm', # finds $VERSION - 'LIBS' => [''], # e.g., '-lm' - 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' - 'INC' => '', # e.g., '-I/usr/include/other' - 'MYEXTLIB' => 'mylib/libmylib$(LIB_EXT)', + NAME => 'Mytest2', + VERSION_FROM => 'Mytest2.pm', # finds $VERSION + LIBS => [''], # e.g., '-lm' + DEFINE => '', # e.g., '-DHAVE_SOMETHING' + INC => '', # e.g., '-I/usr/include/other' + MYEXTLIB => 'mylib/libmylib$(LIB_EXT)', ); and then at the end add a subroutine (which will override the pre-existing @@ -606,9 +623,7 @@ with "cd"! '; } -Let's also fix the MANIFEST file so that it accurately reflects the contents -of our extension. The single line that says "mylib" should be replaced by -the following three lines: +Let's also fix the MANIFEST file by appending the following three lines: mylib/Makefile.PL mylib/mylib.c @@ -642,12 +657,12 @@ Now run perl on the top-level Makefile.PL. Notice that it also created a Makefile in the mylib directory. Run make and watch that it does cd into the mylib directory and run make in there as well. -Now edit the Mytest2.t script and change the number of tests to "4", +Now edit the Mytest2.t script and change the number of tests to "5", and add the following lines to the end of the script: - is( &Mytest2::foo(1, 2, "Hello, world!"), 7 ); - is( &Mytest2::foo(1, 2, "0.0"), 7 ); - ok( abs(&Mytest2::foo(0, 0, "-3.4") - 0.6) <= 0.01 ); + is( Mytest2::foo( 1, 2, "Hello, world!" ), 7 ); + is( Mytest2::foo( 1, 2, "0.0" ), 7 ); + ok( abs( Mytest2::foo( 0, 0, "-3.4" ) - 0.6 ) <= 0.01 ); (When dealing with floating-point comparisons, it is best to not check for equality, but rather that the difference between the expected and actual @@ -1017,9 +1032,12 @@ after the include of "XSUB.h": Also add the following code segment to Mytest.t while incrementing the "9" tests to "11": - @a = &Mytest::statfs("/blech"); + my @a; + + @a = Mytest::statfs("/blech"); ok( scalar(@a) == 1 && $a[0] == 2 ); - @a = &Mytest::statfs("/"); + + @a = Mytest::statfs("/"); is( scalar(@a), 7 ); =head2 New Things in this Example @@ -1152,7 +1170,7 @@ Mytest.xs: And add the following code to Mytest.t, while incrementing the "11" tests to "13": - $results = Mytest::multi_statfs([ '/', '/blech' ]); + my $results = Mytest::multi_statfs([ '/', '/blech' ]); ok( ref $results->[0] ); ok( ! ref $results->[1] ); @@ -1246,21 +1264,24 @@ typeglobs and stuff. Well, it isn't. Suppose that for some strange reason we need a wrapper around the standard C library function C. This is all we need: - #define PERLIO_NOT_STDIO 0 - #define PERL_NO_GET_CONTEXT - #include "EXTERN.h" - #include "perl.h" - #include "XSUB.h" + #define PERLIO_NOT_STDIO 0 /* For co-existence with stdio only */ + #define PERL_NO_GET_CONTEXT /* This is more efficient */ + #include "EXTERN.h" + #include "perl.h" + #include "XSUB.h" - #include + #include - int - fputs(s, stream) - char * s - FILE * stream + int + fputs(s, stream) + char * s + FILE * stream The real work is done in the standard typemap. +For more details, see +L. + B you lose all the fine stuff done by the perlio layers. This calls the stdio function C, which knows nothing about them. @@ -1382,7 +1403,7 @@ Some systems may have installed Perl version 5 as "perl5". =head1 See also For more information, consult L, L, L, L, -and L. +L, and L =head1 Author @@ -1396,6 +1417,8 @@ by Nick Ing-Simmons. Changes for h2xs as of Perl 5.8.x by Renee Baecker +This document is now maintained as part of Perl itself. + =head2 Last Changed -2012-01-20 +2020-10-05 diff --git a/dist/IO/.gitignore b/dist/IO/.gitignore index 577c72624314..7703c927477f 100644 --- a/dist/IO/.gitignore +++ b/dist/IO/.gitignore @@ -1 +1,2 @@ !/poll.c +!/Makefile.PL diff --git a/dist/IO/ChangeLog b/dist/IO/ChangeLog index 52f74dff4ab2..087592e3a0c1 100644 --- a/dist/IO/ChangeLog +++ b/dist/IO/ChangeLog @@ -1,3 +1,7 @@ +IO 1.45 + * Put IO::Socket constructor error messages in $IO::Socket::errstr as well + as $@, to encourage better practices + IO 1.44 * IO::Handle::error() now checks both the input and output stream for error. This is an issue for sockets and character devices. GH #6799 diff --git a/dist/IO/IO.pm b/dist/IO/IO.pm index 5b637df61dcc..c5d954b7f703 100644 --- a/dist/IO/IO.pm +++ b/dist/IO/IO.pm @@ -7,7 +7,7 @@ use Carp; use strict; use warnings; -our $VERSION = "1.44"; +our $VERSION = "1.45"; XSLoader::load 'IO', $VERSION; sub import { diff --git a/dist/IO/lib/IO/Dir.pm b/dist/IO/lib/IO/Dir.pm index 3a14ca8983b4..60174b2522e3 100644 --- a/dist/IO/lib/IO/Dir.pm +++ b/dist/IO/lib/IO/Dir.pm @@ -18,7 +18,7 @@ use File::stat; use File::Spec; our @ISA = qw(Tie::Hash Exporter); -our $VERSION = "1.41"; +our $VERSION = "1.45"; our @EXPORT_OK = qw(DIR_UNLINK); diff --git a/dist/IO/lib/IO/File.pm b/dist/IO/lib/IO/File.pm index cf51d9bf6366..856fdcabc249 100644 --- a/dist/IO/lib/IO/File.pm +++ b/dist/IO/lib/IO/File.pm @@ -135,7 +135,7 @@ require Exporter; our @ISA = qw(IO::Handle IO::Seekable Exporter); -our $VERSION = "1.41"; +our $VERSION = "1.45"; our @EXPORT = @IO::Seekable::EXPORT; diff --git a/dist/IO/lib/IO/Handle.pm b/dist/IO/lib/IO/Handle.pm index 45b6d4f5200e..1f2f83bd2428 100644 --- a/dist/IO/lib/IO/Handle.pm +++ b/dist/IO/lib/IO/Handle.pm @@ -270,7 +270,7 @@ use IO (); # Load the XS module require Exporter; our @ISA = qw(Exporter); -our $VERSION = "1.42"; +our $VERSION = "1.45"; our @EXPORT_OK = qw( autoflush diff --git a/dist/IO/lib/IO/Pipe.pm b/dist/IO/lib/IO/Pipe.pm index c3ceb862336f..73cdf32eff85 100644 --- a/dist/IO/lib/IO/Pipe.pm +++ b/dist/IO/lib/IO/Pipe.pm @@ -13,7 +13,7 @@ use strict; use Carp; use Symbol; -our $VERSION = "1.41"; +our $VERSION = "1.45"; sub new { my $type = shift; diff --git a/dist/IO/lib/IO/Poll.pm b/dist/IO/lib/IO/Poll.pm index 3fe0179626f9..77083f4d6de6 100644 --- a/dist/IO/lib/IO/Poll.pm +++ b/dist/IO/lib/IO/Poll.pm @@ -12,7 +12,7 @@ use IO::Handle; use Exporter (); our @ISA = qw(Exporter); -our $VERSION = "1.41"; +our $VERSION = "1.45"; our @EXPORT = qw( POLLIN POLLOUT diff --git a/dist/IO/lib/IO/Seekable.pm b/dist/IO/lib/IO/Seekable.pm index 2370dcb89a06..7c103b50f498 100644 --- a/dist/IO/lib/IO/Seekable.pm +++ b/dist/IO/lib/IO/Seekable.pm @@ -106,7 +106,7 @@ require Exporter; our @EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END); our @ISA = qw(Exporter); -our $VERSION = "1.41"; +our $VERSION = "1.45"; sub seek { @_ == 3 or croak 'usage: $io->seek(POS, WHENCE)'; diff --git a/dist/IO/lib/IO/Select.pm b/dist/IO/lib/IO/Select.pm index 35a47ccbe052..2367d95c8bc8 100644 --- a/dist/IO/lib/IO/Select.pm +++ b/dist/IO/lib/IO/Select.pm @@ -10,7 +10,7 @@ use strict; use warnings::register; require Exporter; -our $VERSION = "1.42"; +our $VERSION = "1.45"; our @ISA = qw(Exporter); # This is only so we can do version checking diff --git a/dist/IO/lib/IO/Socket.pm b/dist/IO/lib/IO/Socket.pm index ad8966dd2268..7f298155b5ce 100644 --- a/dist/IO/lib/IO/Socket.pm +++ b/dist/IO/lib/IO/Socket.pm @@ -23,10 +23,12 @@ require IO::Socket::UNIX if ($^O ne 'epoc' && $^O ne 'symbian'); our @ISA = qw(IO::Handle); -our $VERSION = "1.44"; +our $VERSION = "1.45"; our @EXPORT_OK = qw(sockatmark); +our $errstr; + sub import { my $pkg = shift; if (@_ && $_[0] eq 'sockatmark') { # not very extensible but for now, fast @@ -132,11 +134,11 @@ sub connect { # set we now emulate the behavior in Linux # - Karthik Rajagopalan $err = $sock->getsockopt(SOL_SOCKET,SO_ERROR); - $@ = "connect: $err"; + $errstr = $@ = "connect: $err"; } elsif(!@$w[0]) { $err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1); - $@ = "connect: timeout"; + $errstr = $@ = "connect: timeout"; } elsif (!connect($sock,$addr) && not ($!{EISCONN} || ($^O eq 'MSWin32' && @@ -147,12 +149,12 @@ sub connect { # Windows sets errno to WSAEINVAL (10022) (pre-5.19.4) or # EINVAL (22) (5.19.4 onwards). $err = $!; - $@ = "connect: $!"; + $errstr = $@ = "connect: $!"; } } elsif ($blocking || !($!{EINPROGRESS} || $!{EWOULDBLOCK})) { $err = $!; - $@ = "connect: $!"; + $errstr = $@ = "connect: $!"; } } @@ -246,7 +248,7 @@ sub accept { my $sel = IO::Select->new( $sock ); unless ($sel->can_read($timeout)) { - $@ = 'accept: timeout'; + $errstr = $@ = 'accept: timeout'; $! = (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1); return; } @@ -530,6 +532,18 @@ by default, be either C or C. Other domains can be used if a proper subclass for the domain family is registered. All other arguments will be passed to the C method of the package for that domain. +If the constructor fails it will return C and set the C<$errstr> package +variable to contain an error message. + + $sock = IO::Socket->new(...) + or die "Cannot create socket - $IO::Socket::errstr\n"; + +For legacy reasons the error message is also set into the global C<$@> +variable, and you may still find older code which looks here instead. + + $sock = IO::Socket->new(...) + or die "Cannot create socket - $@\n"; + =head1 METHODS C inherits all methods from L and implements the @@ -832,7 +846,7 @@ Let's create a TCP server on C. LocalPort => 3333, ReusePort => 1, Listen => 5, - ) || die "Can't open socket: $@"; + ) || die "Can't open socket: $IO::Socket::errstr"; say "Waiting on 3333"; while (1) { @@ -873,7 +887,7 @@ A client for such a server could be proto => 'tcp', PeerPort => 3333, PeerHost => '0.0.0.0', - ) || die "Can't open socket: $@"; + ) || die "Can't open socket: $IO::Socket::errstr"; say "Sending Hello World!"; my $size = $client->send("Hello World!"); diff --git a/dist/IO/lib/IO/Socket/INET.pm b/dist/IO/lib/IO/Socket/INET.pm index 8688f375b5f7..d315731e87f1 100644 --- a/dist/IO/lib/IO/Socket/INET.pm +++ b/dist/IO/lib/IO/Socket/INET.pm @@ -14,7 +14,7 @@ use Exporter; use Errno; our @ISA = qw(IO::Socket); -our $VERSION = "1.41"; +our $VERSION = "1.45"; my $EINVAL = exists(&Errno::EINVAL) ? Errno::EINVAL() : 1; @@ -79,7 +79,7 @@ sub _sock_info { if(defined $proto && $proto =~ /\D/) { my $num = _get_proto_number($proto); unless (defined $num) { - $@ = "Bad protocol '$proto'"; + $IO::Socket::errstr = $@ = "Bad protocol '$proto'"; return; } $proto = $num; @@ -94,7 +94,7 @@ sub _sock_info { $port = $serv[2] || $defport || $pnum; unless (defined $port) { - $@ = "Bad service '$origport'"; + $IO::Socket::errstr = $@ = "Bad service '$origport'"; return; } @@ -113,7 +113,7 @@ sub _error { { local($!); my $title = ref($sock).": "; - $@ = join("", $_[0] =~ /^$title/ ? "" : $title, @_); + $IO::Socket::errstr = $@ = join("", $_[0] =~ /^$title/ ? "" : $title, @_); $sock->close() if(defined fileno($sock)); } @@ -404,14 +404,19 @@ Examples: Proto => udp, LocalAddr => 'localhost', Broadcast => 1 ) - or die "Can't bind : $@\n"; + or die "Can't bind : $IO::Socket::errstr\n"; -B +If the constructor fails it will return C and set the +C<$IO::Socket::errstr> package variable to contain an error message. -As of VERSION 1.18 all IO::Socket objects have autoflush turned on -by default. This was not the case with earlier releases. + $sock = IO::Socket::INET->new(...) + or die "Cannot create socket - $IO::Socket::errstr\n"; -B +For legacy reasons the error message is also set into the global C<$@> +variable, and you may still find older code which looks here instead. + + $sock = IO::Socket::INET->new(...) + or die "Cannot create socket - $@\n"; =back diff --git a/dist/IO/lib/IO/Socket/UNIX.pm b/dist/IO/lib/IO/Socket/UNIX.pm index 14d0b27a8ce7..261edc46ec10 100644 --- a/dist/IO/lib/IO/Socket/UNIX.pm +++ b/dist/IO/lib/IO/Socket/UNIX.pm @@ -11,7 +11,7 @@ use IO::Socket; use Carp; our @ISA = qw(IO::Socket); -our $VERSION = "1.42"; +our $VERSION = "1.45"; IO::Socket::UNIX->register_domain( AF_UNIX ); @@ -127,6 +127,18 @@ be a C specification. If the C argument is given, but false, the queue size will be set to 5. +If the constructor fails it will return C and set the +C<$IO::Socket::errstr> package variable to contain an error message. + + $sock = IO::Socket::UNIX->new(...) + or die "Cannot create socket - $IO::Socket::errstr\n"; + +For legacy reasons the error message is also set into the global C<$@> +variable, and you may still find older code which looks here instead. + + $sock = IO::Socket::UNIX->new(...) + or die "Cannot create socket - $@\n"; + =back =head1 METHODS diff --git a/dist/IO/poll.c b/dist/IO/poll.c index 344a406b529c..3ddaa22db4f2 100644 --- a/dist/IO/poll.c +++ b/dist/IO/poll.c @@ -61,74 +61,74 @@ poll(struct pollfd *fds, unsigned long nfds, int timeout) FD_ZERO(&efd); for(i = 0 ; i < (int)nfds ; i++) { - int events = fds[i].events; - int fd = fds[i].fd; + int events = fds[i].events; + int fd = fds[i].fd; - fds[i].revents = 0; + fds[i].revents = 0; - if(fd < 0 || FD_ISSET(fd, &ifd)) - continue; + if(fd < 0 || FD_ISSET(fd, &ifd)) + continue; - if(fd > n) - n = fd; + if(fd > n) + n = fd; - if(events & POLL_CAN_READ) - FD_SET(fd, &rfd); + if(events & POLL_CAN_READ) + FD_SET(fd, &rfd); - if(events & POLL_CAN_WRITE) - FD_SET(fd, &wfd); + if(events & POLL_CAN_WRITE) + FD_SET(fd, &wfd); - if(events & POLL_HAS_EXCP) - FD_SET(fd, &efd); + if(events & POLL_HAS_EXCP) + FD_SET(fd, &efd); } if(timeout >= 0) { - timebuf.tv_sec = timeout / 1000; - timebuf.tv_usec = (timeout % 1000) * 1000; - tbuf = &timebuf; + timebuf.tv_sec = timeout / 1000; + timebuf.tv_usec = (timeout % 1000) * 1000; + tbuf = &timebuf; } err = select(n+1,&rfd,&wfd,&efd,tbuf); if(err < 0) { #ifdef HAS_FSTAT - if(errno == EBADF) { - for(i = 0 ; i < nfds ; i++) { - struct stat buf; - if((fstat(fds[i].fd,&buf) < 0) && (errno == EBADF)) { - FD_SET(fds[i].fd, &ifd); - goto again; - } - } - } + if(errno == EBADF) { + for(i = 0 ; i < nfds ; i++) { + struct stat buf; + if((fstat(fds[i].fd,&buf) < 0) && (errno == EBADF)) { + FD_SET(fds[i].fd, &ifd); + goto again; + } + } + } #endif /* HAS_FSTAT */ - return err; + return err; } count = 0; for(i = 0 ; i < (int)nfds ; i++) { - int revents = (fds[i].events & POLL_EVENTS_MASK); - int fd = fds[i].fd; + int revents = (fds[i].events & POLL_EVENTS_MASK); + int fd = fds[i].fd; - if(fd < 0) - continue; + if(fd < 0) + continue; - if(FD_ISSET(fd, &ifd)) - revents = POLLNVAL; - else { - if(!FD_ISSET(fd, &rfd)) - revents &= ~POLL_CAN_READ; + if(FD_ISSET(fd, &ifd)) + revents = POLLNVAL; + else { + if(!FD_ISSET(fd, &rfd)) + revents &= ~POLL_CAN_READ; - if(!FD_ISSET(fd, &wfd)) - revents &= ~POLL_CAN_WRITE; + if(!FD_ISSET(fd, &wfd)) + revents &= ~POLL_CAN_WRITE; - if(!FD_ISSET(fd, &efd)) - revents &= ~POLL_HAS_EXCP; - } + if(!FD_ISSET(fd, &efd)) + revents &= ~POLL_HAS_EXCP; + } - if((fds[i].revents = revents) != 0) - count++; + if((fds[i].revents = revents) != 0) + count++; } return count; diff --git a/dist/IO/t/io_sock.t b/dist/IO/t/io_sock.t index 3bc5118cbc7b..c7b6bb63856b 100644 --- a/dist/IO/t/io_sock.t +++ b/dist/IO/t/io_sock.t @@ -129,7 +129,7 @@ if(my $pid = fork()) { $sock->close; } else { - print "# $@\n"; + print "# $IO::Socket::errstr\n"; print "not ok 6\n"; print "not ok 7\n"; print "not ok 8\n"; @@ -146,7 +146,7 @@ if(my $pid = fork()) { $sock->close; } else { - print "# $@\n"; + print "# $IO::Socket::errstr\n"; print "not ok 10\n"; } diff --git a/dist/IO/t/io_sock_errstr.t b/dist/IO/t/io_sock_errstr.t new file mode 100644 index 000000000000..dc75c44fad53 --- /dev/null +++ b/dist/IO/t/io_sock_errstr.t @@ -0,0 +1,34 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +plan tests => 3; + +use Errno qw( EINVAL ); + +# Keep this unit test in a file of its own because we need to override +# connect() globally +BEGIN { + *CORE::GLOBAL::connect = sub { $! = EINVAL; return undef }; +} + +my $EINVAL_STR = do { local $! = EINVAL; "$!" }; + +use IO::Socket; + +# test that error strings turn up in both places +my $sock = IO::Socket::INET->new( + PeerHost => "localhost", + PeerPort => 1, +); +my $e = $@; + +ok(!defined $sock, 'fails to connect with CORE::GLOBAL::connect override'); + +is($IO::Socket::errstr, "IO::Socket::INET: connect: $EINVAL_STR", + 'error message appears in $IO::Socket::errstr'); +is($e, "IO::Socket::INET: connect: $EINVAL_STR", + 'error message appeared in $@'); diff --git a/dist/Module-CoreList/.gitignore b/dist/Module-CoreList/.gitignore new file mode 100644 index 000000000000..e54624d60d99 --- /dev/null +++ b/dist/Module-CoreList/.gitignore @@ -0,0 +1 @@ +!/Makefile.PL diff --git a/dist/Module-CoreList/Changes b/dist/Module-CoreList/Changes index bca8d50630dd..21aaecedc9ca 100644 --- a/dist/Module-CoreList/Changes +++ b/dist/Module-CoreList/Changes @@ -1,3 +1,15 @@ +5.20210220 + - Updated for v5.33.7 + +5.20210123 + - Updated for v5.32.1 + +5.20210120 + - Updated for v5.33.6 + +5.20201220 + - Updated for v5.33.5 + 5.20201120 - Updated for v5.33.4 diff --git a/dist/Module-CoreList/lib/Module/CoreList.pm b/dist/Module-CoreList/lib/Module/CoreList.pm index a4c1ed1387c5..130bb1b7b171 100644 --- a/dist/Module-CoreList/lib/Module/CoreList.pm +++ b/dist/Module-CoreList/lib/Module/CoreList.pm @@ -4,7 +4,7 @@ use strict; our ( %released, %version, %families, %upstream, %bug_tracker, %deprecated, %delta ); use version; -our $VERSION = '5.20201120'; +our $VERSION = '5.20210220'; sub PKG_PATTERN () { q#\A[a-zA-Z_][0-9a-zA-Z_]*(?:(::|')[0-9a-zA-Z_]+)*\z# } sub _looks_like_invocant ($) { local $@; !!eval { $_[0]->isa(__PACKAGE__) } } @@ -371,6 +371,10 @@ sub changes_between { 5.033002 => '2020-09-20', 5.033003 => '2020-10-20', 5.033004 => '2020-11-20', + 5.033005 => '2020-12-20', + 5.033006 => '2021-01-20', + 5.032001 => '2021-01-23', + 5.033007 => '2021-02-20', ); for my $version ( sort { $a <=> $b } keys %released ) { @@ -17710,7 +17714,6 @@ for my $version ( sort { $a <=> $b } keys %released ) { 'Test::Tester::CaptureRunner'=> '1.302181', 'Test::Tester::Delegate'=> '1.302181', 'Test::use::ok' => '1.302181', - 'Win32API::File::inc::ExtUtils::Myconst2perl'=> '1', 'ok' => '1.302181', 'overload' => '1.32', }, @@ -17915,10 +17918,414 @@ for my $version ( sort { $a <=> $b } keys %released ) { 5.033004 => { delta_from => 5.033003, changed => { + 'B' => '1.82', 'B::Op_private' => '5.033004', 'Config' => '5.033004', + 'Cwd' => '3.79', + 'ExtUtils::CBuilder' => '0.280235', + 'ExtUtils::CBuilder::Base'=> '0.280235', + 'ExtUtils::CBuilder::Platform::Unix'=> '0.280235', + 'ExtUtils::CBuilder::Platform::VMS'=> '0.280235', + 'ExtUtils::CBuilder::Platform::Windows'=> '0.280235', + 'ExtUtils::CBuilder::Platform::Windows::BCC'=> '0.280235', + 'ExtUtils::CBuilder::Platform::Windows::GCC'=> '0.280235', + 'ExtUtils::CBuilder::Platform::Windows::MSVC'=> '0.280235', + 'ExtUtils::CBuilder::Platform::aix'=> '0.280235', + 'ExtUtils::CBuilder::Platform::android'=> '0.280235', + 'ExtUtils::CBuilder::Platform::cygwin'=> '0.280235', + 'ExtUtils::CBuilder::Platform::darwin'=> '0.280235', + 'ExtUtils::CBuilder::Platform::dec_osf'=> '0.280235', + 'ExtUtils::CBuilder::Platform::os2'=> '0.280235', + 'ExtUtils::Command' => '7.56', + 'ExtUtils::Command::MM' => '7.56', + 'ExtUtils::Liblist' => '7.56', + 'ExtUtils::Liblist::Kid'=> '7.56', + 'ExtUtils::MM' => '7.56', + 'ExtUtils::MM_AIX' => '7.56', + 'ExtUtils::MM_Any' => '7.56', + 'ExtUtils::MM_BeOS' => '7.56', + 'ExtUtils::MM_Cygwin' => '7.56', + 'ExtUtils::MM_DOS' => '7.56', + 'ExtUtils::MM_Darwin' => '7.56', + 'ExtUtils::MM_MacOS' => '7.56', + 'ExtUtils::MM_NW5' => '7.56', + 'ExtUtils::MM_OS2' => '7.56', + 'ExtUtils::MM_OS390' => '7.56', + 'ExtUtils::MM_QNX' => '7.56', + 'ExtUtils::MM_UWIN' => '7.56', + 'ExtUtils::MM_Unix' => '7.56', + 'ExtUtils::MM_VMS' => '7.56', + 'ExtUtils::MM_VOS' => '7.56', + 'ExtUtils::MM_Win32' => '7.56', + 'ExtUtils::MM_Win95' => '7.56', + 'ExtUtils::MY' => '7.56', + 'ExtUtils::MakeMaker' => '7.56', + 'ExtUtils::MakeMaker::Config'=> '7.56', + 'ExtUtils::MakeMaker::Locale'=> '7.56', + 'ExtUtils::MakeMaker::version'=> '7.56', + 'ExtUtils::MakeMaker::version::regex'=> '7.56', + 'ExtUtils::Mkbootstrap' => '7.56', + 'ExtUtils::Mksymlists' => '7.56', + 'ExtUtils::testlib' => '7.56', + 'File::Fetch' => '1.00', + 'File::Path' => '2.18', + 'File::Spec' => '3.79', + 'File::Spec::AmigaOS' => '3.79', + 'File::Spec::Cygwin' => '3.79', + 'File::Spec::Epoc' => '3.79', + 'File::Spec::Functions' => '3.79', + 'File::Spec::Mac' => '3.79', + 'File::Spec::OS2' => '3.79', + 'File::Spec::Unix' => '3.79', + 'File::Spec::VMS' => '3.79', + 'IPC::Msg' => '2.09', + 'IPC::Semaphore' => '2.09', + 'IPC::SharedMem' => '2.09', + 'IPC::SysV' => '2.09', 'Module::CoreList' => '5.20201120', 'Module::CoreList::Utils'=> '5.20201120', + 'Net::Ping' => '2.74', + 'Pod::Html' => '1.26', + 'Pod::Simple' => '3.42', + 'Pod::Simple::BlackBox' => '3.42', + 'Pod::Simple::Checker' => '3.42', + 'Pod::Simple::Debug' => '3.42', + 'Pod::Simple::DumpAsText'=> '3.42', + 'Pod::Simple::DumpAsXML'=> '3.42', + 'Pod::Simple::HTML' => '3.42', + 'Pod::Simple::HTMLBatch'=> '3.42', + 'Pod::Simple::LinkSection'=> '3.42', + 'Pod::Simple::Methody' => '3.42', + 'Pod::Simple::Progress' => '3.42', + 'Pod::Simple::PullParser'=> '3.42', + 'Pod::Simple::PullParserEndToken'=> '3.42', + 'Pod::Simple::PullParserStartToken'=> '3.42', + 'Pod::Simple::PullParserTextToken'=> '3.42', + 'Pod::Simple::PullParserToken'=> '3.42', + 'Pod::Simple::RTF' => '3.42', + 'Pod::Simple::Search' => '3.42', + 'Pod::Simple::SimpleTree'=> '3.42', + 'Pod::Simple::Text' => '3.42', + 'Pod::Simple::TextContent'=> '3.42', + 'Pod::Simple::TiedOutFH'=> '3.42', + 'Pod::Simple::Transcode'=> '3.42', + 'Pod::Simple::TranscodeDumb'=> '3.42', + 'Pod::Simple::TranscodeSmart'=> '3.42', + 'Pod::Simple::XHTML' => '3.42', + 'Pod::Simple::XMLOutStream'=> '3.42', + 'Test2' => '1.302183', + 'Test2::API' => '1.302183', + 'Test2::API::Breakage' => '1.302183', + 'Test2::API::Context' => '1.302183', + 'Test2::API::Instance' => '1.302183', + 'Test2::API::InterceptResult'=> '1.302183', + 'Test2::API::InterceptResult::Event'=> '1.302183', + 'Test2::API::InterceptResult::Facet'=> '1.302183', + 'Test2::API::InterceptResult::Hub'=> '1.302183', + 'Test2::API::InterceptResult::Squasher'=> '1.302183', + 'Test2::API::Stack' => '1.302183', + 'Test2::Event' => '1.302183', + 'Test2::Event::Bail' => '1.302183', + 'Test2::Event::Diag' => '1.302183', + 'Test2::Event::Encoding'=> '1.302183', + 'Test2::Event::Exception'=> '1.302183', + 'Test2::Event::Fail' => '1.302183', + 'Test2::Event::Generic' => '1.302183', + 'Test2::Event::Note' => '1.302183', + 'Test2::Event::Ok' => '1.302183', + 'Test2::Event::Pass' => '1.302183', + 'Test2::Event::Plan' => '1.302183', + 'Test2::Event::Skip' => '1.302183', + 'Test2::Event::Subtest' => '1.302183', + 'Test2::Event::TAP::Version'=> '1.302183', + 'Test2::Event::V2' => '1.302183', + 'Test2::Event::Waiting' => '1.302183', + 'Test2::EventFacet' => '1.302183', + 'Test2::EventFacet::About'=> '1.302183', + 'Test2::EventFacet::Amnesty'=> '1.302183', + 'Test2::EventFacet::Assert'=> '1.302183', + 'Test2::EventFacet::Control'=> '1.302183', + 'Test2::EventFacet::Error'=> '1.302183', + 'Test2::EventFacet::Hub'=> '1.302183', + 'Test2::EventFacet::Info'=> '1.302183', + 'Test2::EventFacet::Info::Table'=> '1.302183', + 'Test2::EventFacet::Meta'=> '1.302183', + 'Test2::EventFacet::Parent'=> '1.302183', + 'Test2::EventFacet::Plan'=> '1.302183', + 'Test2::EventFacet::Render'=> '1.302183', + 'Test2::EventFacet::Trace'=> '1.302183', + 'Test2::Formatter' => '1.302183', + 'Test2::Formatter::TAP' => '1.302183', + 'Test2::Hub' => '1.302183', + 'Test2::Hub::Interceptor'=> '1.302183', + 'Test2::Hub::Interceptor::Terminator'=> '1.302183', + 'Test2::Hub::Subtest' => '1.302183', + 'Test2::IPC' => '1.302183', + 'Test2::IPC::Driver' => '1.302183', + 'Test2::IPC::Driver::Files'=> '1.302183', + 'Test2::Tools::Tiny' => '1.302183', + 'Test2::Util' => '1.302183', + 'Test2::Util::ExternalMeta'=> '1.302183', + 'Test2::Util::Facets2Legacy'=> '1.302183', + 'Test2::Util::HashBase' => '1.302183', + 'Test2::Util::Trace' => '1.302183', + 'Test::Builder' => '1.302183', + 'Test::Builder::Formatter'=> '1.302183', + 'Test::Builder::Module' => '1.302183', + 'Test::Builder::Tester' => '1.302183', + 'Test::Builder::Tester::Color'=> '1.302183', + 'Test::Builder::TodoDiag'=> '1.302183', + 'Test::More' => '1.302183', + 'Test::Simple' => '1.302183', + 'Test::Tester' => '1.302183', + 'Test::Tester::Capture' => '1.302183', + 'Test::Tester::CaptureRunner'=> '1.302183', + 'Test::Tester::Delegate'=> '1.302183', + 'Test::use::ok' => '1.302183', + 'XS::APItest' => '1.13', + 'ok' => '1.302183', + 'perlfaq' => '5.20201107', + }, + removed => { + } + }, + 5.033005 => { + delta_from => 5.033004, + changed => { + 'App::Prove' => '3.43', + 'App::Prove::State' => '3.43', + 'App::Prove::State::Result'=> '3.43', + 'App::Prove::State::Result::Test'=> '3.43', + 'B::Op_private' => '5.033005', + 'Carp' => '1.51', + 'Carp::Heavy' => '1.51', + 'Config' => '5.033005', + 'Config::Perl::V' => '0.33', + 'Cwd' => '3.80', + 'DynaLoader' => '1.49', + 'Encode' => '3.08', + 'Encode::GSM0338' => '2.09', + 'ExtUtils::Install' => '2.20', + 'ExtUtils::Installed' => '2.20', + 'ExtUtils::Packlist' => '2.20', + 'ExtUtils::ParseXS' => '3.42', + 'ExtUtils::ParseXS::Constants'=> '3.42', + 'ExtUtils::ParseXS::CountLines'=> '3.42', + 'ExtUtils::ParseXS::Eval'=> '3.42', + 'ExtUtils::ParseXS::Utilities'=> '3.42', + 'File::Copy' => '2.35', + 'File::Find' => '1.38', + 'File::Spec' => '3.80', + 'File::Spec::AmigaOS' => '3.80', + 'File::Spec::Cygwin' => '3.80', + 'File::Spec::Epoc' => '3.80', + 'File::Spec::Functions' => '3.80', + 'File::Spec::Mac' => '3.80', + 'File::Spec::OS2' => '3.80', + 'File::Spec::Unix' => '3.80', + 'File::Spec::VMS' => '3.80', + 'File::Spec::Win32' => '3.80', + 'Module::CoreList' => '5.20201220', + 'Module::CoreList::Utils'=> '5.20201220', + 'Net::Cmd' => '3.12', + 'Net::Config' => '3.12', + 'Net::Domain' => '3.12', + 'Net::FTP' => '3.12', + 'Net::FTP::A' => '3.12', + 'Net::FTP::E' => '3.12', + 'Net::FTP::I' => '3.12', + 'Net::FTP::L' => '3.12', + 'Net::FTP::dataconn' => '3.12', + 'Net::NNTP' => '3.12', + 'Net::Netrc' => '3.12', + 'Net::POP3' => '3.12', + 'Net::SMTP' => '3.12', + 'Net::Time' => '3.12', + 'ODBM_File' => '1.17', + 'Opcode' => '1.49', + 'POSIX' => '1.96', + 'PerlIO::via::QuotedPrint'=> '0.09', + 'TAP::Base' => '3.43', + 'TAP::Formatter::Base' => '3.43', + 'TAP::Formatter::Color' => '3.43', + 'TAP::Formatter::Console'=> '3.43', + 'TAP::Formatter::Console::ParallelSession'=> '3.43', + 'TAP::Formatter::Console::Session'=> '3.43', + 'TAP::Formatter::File' => '3.43', + 'TAP::Formatter::File::Session'=> '3.43', + 'TAP::Formatter::Session'=> '3.43', + 'TAP::Harness' => '3.43', + 'TAP::Harness::Env' => '3.43', + 'TAP::Object' => '3.43', + 'TAP::Parser' => '3.43', + 'TAP::Parser::Aggregator'=> '3.43', + 'TAP::Parser::Grammar' => '3.43', + 'TAP::Parser::Iterator' => '3.43', + 'TAP::Parser::Iterator::Array'=> '3.43', + 'TAP::Parser::Iterator::Process'=> '3.43', + 'TAP::Parser::Iterator::Stream'=> '3.43', + 'TAP::Parser::IteratorFactory'=> '3.43', + 'TAP::Parser::Multiplexer'=> '3.43', + 'TAP::Parser::Result' => '3.43', + 'TAP::Parser::Result::Bailout'=> '3.43', + 'TAP::Parser::Result::Comment'=> '3.43', + 'TAP::Parser::Result::Plan'=> '3.43', + 'TAP::Parser::Result::Pragma'=> '3.43', + 'TAP::Parser::Result::Test'=> '3.43', + 'TAP::Parser::Result::Unknown'=> '3.43', + 'TAP::Parser::Result::Version'=> '3.43', + 'TAP::Parser::Result::YAML'=> '3.43', + 'TAP::Parser::ResultFactory'=> '3.43', + 'TAP::Parser::Scheduler'=> '3.43', + 'TAP::Parser::Scheduler::Job'=> '3.43', + 'TAP::Parser::Scheduler::Spinner'=> '3.43', + 'TAP::Parser::Source' => '3.43', + 'TAP::Parser::SourceHandler'=> '3.43', + 'TAP::Parser::SourceHandler::Executable'=> '3.43', + 'TAP::Parser::SourceHandler::File'=> '3.43', + 'TAP::Parser::SourceHandler::Handle'=> '3.43', + 'TAP::Parser::SourceHandler::Perl'=> '3.43', + 'TAP::Parser::SourceHandler::RawTAP'=> '3.43', + 'TAP::Parser::YAMLish::Reader'=> '3.43', + 'TAP::Parser::YAMLish::Writer'=> '3.43', + 'Test::Harness' => '3.43', + 'Text::Balanced' => '2.04', + 'Time::HiRes' => '1.9766', + 'XS::APItest' => '1.14', + 'warnings' => '1.49', + }, + removed => { + } + }, + 5.033006 => { + delta_from => 5.033005, + changed => { + 'B::Op_private' => '5.033006', + 'Carp' => '1.52', + 'Carp::Heavy' => '1.52', + 'Compress::Raw::Bzip2' => '2.100', + 'Compress::Raw::Zlib' => '2.100', + 'Compress::Zlib' => '2.100', + 'Config' => '5.033006', + 'DynaLoader' => '1.50', + 'ExtUtils::Command' => '7.58', + 'ExtUtils::Command::MM' => '7.58', + 'ExtUtils::Liblist' => '7.58', + 'ExtUtils::Liblist::Kid'=> '7.58', + 'ExtUtils::MM' => '7.58', + 'ExtUtils::MM_AIX' => '7.58', + 'ExtUtils::MM_Any' => '7.58', + 'ExtUtils::MM_BeOS' => '7.58', + 'ExtUtils::MM_Cygwin' => '7.58', + 'ExtUtils::MM_DOS' => '7.58', + 'ExtUtils::MM_Darwin' => '7.58', + 'ExtUtils::MM_MacOS' => '7.58', + 'ExtUtils::MM_NW5' => '7.58', + 'ExtUtils::MM_OS2' => '7.58', + 'ExtUtils::MM_OS390' => '7.58', + 'ExtUtils::MM_QNX' => '7.58', + 'ExtUtils::MM_UWIN' => '7.58', + 'ExtUtils::MM_Unix' => '7.58', + 'ExtUtils::MM_VMS' => '7.58', + 'ExtUtils::MM_VOS' => '7.58', + 'ExtUtils::MM_Win32' => '7.58', + 'ExtUtils::MM_Win95' => '7.58', + 'ExtUtils::MY' => '7.58', + 'ExtUtils::MakeMaker' => '7.58', + 'ExtUtils::MakeMaker::Config'=> '7.58', + 'ExtUtils::MakeMaker::Locale'=> '7.58', + 'ExtUtils::MakeMaker::version'=> '7.58', + 'ExtUtils::MakeMaker::version::regex'=> '7.58', + 'ExtUtils::Manifest' => '1.73', + 'ExtUtils::Mkbootstrap' => '7.58', + 'ExtUtils::Mksymlists' => '7.58', + 'ExtUtils::testlib' => '7.58', + 'GDBM_File' => '1.19', + 'IO' => '1.45', + 'IO::Compress::Adapter::Bzip2'=> '2.100', + 'IO::Compress::Adapter::Deflate'=> '2.100', + 'IO::Compress::Adapter::Identity'=> '2.100', + 'IO::Compress::Base' => '2.100', + 'IO::Compress::Base::Common'=> '2.100', + 'IO::Compress::Bzip2' => '2.100', + 'IO::Compress::Deflate' => '2.100', + 'IO::Compress::Gzip' => '2.100', + 'IO::Compress::Gzip::Constants'=> '2.100', + 'IO::Compress::RawDeflate'=> '2.100', + 'IO::Compress::Zip' => '2.100', + 'IO::Compress::Zip::Constants'=> '2.100', + 'IO::Compress::Zlib::Constants'=> '2.100', + 'IO::Compress::Zlib::Extra'=> '2.100', + 'IO::Dir' => '1.45', + 'IO::File' => '1.45', + 'IO::Handle' => '1.45', + 'IO::Pipe' => '1.45', + 'IO::Poll' => '1.45', + 'IO::Seekable' => '1.45', + 'IO::Select' => '1.45', + 'IO::Socket' => '1.45', + 'IO::Socket::INET' => '1.45', + 'IO::Socket::UNIX' => '1.45', + 'IO::Uncompress::Adapter::Bunzip2'=> '2.100', + 'IO::Uncompress::Adapter::Identity'=> '2.100', + 'IO::Uncompress::Adapter::Inflate'=> '2.100', + 'IO::Uncompress::AnyInflate'=> '2.100', + 'IO::Uncompress::AnyUncompress'=> '2.100', + 'IO::Uncompress::Base' => '2.100', + 'IO::Uncompress::Bunzip2'=> '2.100', + 'IO::Uncompress::Gunzip'=> '2.100', + 'IO::Uncompress::Inflate'=> '2.100', + 'IO::Uncompress::RawInflate'=> '2.100', + 'IO::Uncompress::Unzip' => '2.100', + 'Module::CoreList' => '5.20210120', + 'Module::CoreList::Utils'=> '5.20210120', + 'Net::Cmd' => '3.13', + 'Net::Config' => '3.13', + 'Net::Domain' => '3.13', + 'Net::FTP' => '3.13', + 'Net::FTP::A' => '3.13', + 'Net::FTP::E' => '3.13', + 'Net::FTP::I' => '3.13', + 'Net::FTP::L' => '3.13', + 'Net::FTP::dataconn' => '3.13', + 'Net::NNTP' => '3.13', + 'Net::Netrc' => '3.13', + 'Net::POP3' => '3.13', + 'Net::SMTP' => '3.13', + 'Net::Time' => '3.13', + 'POSIX' => '1.97', + 'Socket' => '2.031', + 'XS::APItest' => '1.15', + 'feature' => '1.62', + 'warnings' => '1.50', + }, + removed => { + } + }, + 5.032001 => { + delta_from => 5.032000, + changed => { + 'B::Op_private' => '5.032001', + 'Config' => '5.032001', + 'Data::Dumper' => '2.174_01', + 'DynaLoader' => '1.47_01', + 'ExtUtils::Liblist::Kid'=> '7.44_01', + 'Module::CoreList' => '5.20210123', + 'Module::CoreList::Utils'=> '5.20210123', + 'Opcode' => '1.48', + 'Safe' => '2.41_01', + 'Win32API::File::inc::ExtUtils::Myconst2perl'=> '1', + }, + removed => { + } + }, + 5.033007 => { + delta_from => 5.033006, + changed => { + 'B::Op_private' => '5.033007', + 'Config' => '5.033007', + 'Module::CoreList' => '5.20210220', + 'Module::CoreList::Utils'=> '5.20210220', }, removed => { } @@ -19079,6 +19486,34 @@ sub is_core removed => { } }, + 5.033005 => { + delta_from => 5.033004, + changed => { + }, + removed => { + } + }, + 5.033006 => { + delta_from => 5.033005, + changed => { + }, + removed => { + } + }, + 5.032001 => { + delta_from => 5.032, + changed => { + }, + removed => { + } + }, + 5.033007 => { + delta_from => 5.033006, + changed => { + }, + removed => { + } + }, ); %deprecated = _undelta(\%deprecated); @@ -19493,7 +19928,6 @@ sub is_core 'Unicode::Collate::Locale'=> 'cpan', 'Win32' => 'cpan', 'Win32API::File' => 'cpan', - 'Win32API::File::inc::ExtUtils::Myconst2perl'=> 'cpan', 'autodie' => 'cpan', 'autodie::Scope::Guard' => 'cpan', 'autodie::Scope::GuardStack'=> 'cpan', @@ -19571,7 +20005,7 @@ sub is_core 'Compress::Raw::Bzip2' => 'https://github.com/pmqs/Compress-Raw-Bzip2/issues', 'Compress::Raw::Zlib' => 'https://github.com/pmqs/Compress-Raw-Zlib/issues', 'Compress::Zlib' => 'https://github.com/pmqs/IO-Compress/issues', - 'Config::Perl::V' => undef, + 'Config::Perl::V' => 'https://github.com/Tux/Config-Perl-V/issues', 'DB_File' => 'https://github.com/pmqs/DB_File/issues', 'Digest' => 'https://github.com/Dual-Life/digest/issues', 'Digest::MD5' => 'https://github.com/Dual-Life/digest-md5/issues', @@ -19602,8 +20036,8 @@ sub is_core 'Encode::TW' => undef, 'Encode::Unicode' => undef, 'Encode::Unicode::UTF7' => undef, - 'ExtUtils::Command' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', - 'ExtUtils::Command::MM' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::Command' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::Command::MM' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', 'ExtUtils::Constant' => undef, 'ExtUtils::Constant::Base'=> undef, 'ExtUtils::Constant::ProxySubs'=> undef, @@ -19611,38 +20045,38 @@ sub is_core 'ExtUtils::Constant::XS'=> undef, 'ExtUtils::Install' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-Install', 'ExtUtils::Installed' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-Install', - 'ExtUtils::Liblist' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', - 'ExtUtils::Liblist::Kid'=> 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', - 'ExtUtils::MM' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', - 'ExtUtils::MM_AIX' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', - 'ExtUtils::MM_Any' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', - 'ExtUtils::MM_BeOS' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', - 'ExtUtils::MM_Cygwin' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', - 'ExtUtils::MM_DOS' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', - 'ExtUtils::MM_Darwin' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', - 'ExtUtils::MM_MacOS' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', - 'ExtUtils::MM_NW5' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', - 'ExtUtils::MM_OS2' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', - 'ExtUtils::MM_OS390' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', - 'ExtUtils::MM_QNX' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', - 'ExtUtils::MM_UWIN' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', - 'ExtUtils::MM_Unix' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', - 'ExtUtils::MM_VMS' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', - 'ExtUtils::MM_VOS' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', - 'ExtUtils::MM_Win32' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', - 'ExtUtils::MM_Win95' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', - 'ExtUtils::MY' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', - 'ExtUtils::MakeMaker' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', - 'ExtUtils::MakeMaker::Config'=> 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', - 'ExtUtils::MakeMaker::Locale'=> 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', - 'ExtUtils::MakeMaker::version'=> 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', - 'ExtUtils::MakeMaker::version::regex'=> 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::Liblist' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::Liblist::Kid'=> 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::MM' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::MM_AIX' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::MM_Any' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::MM_BeOS' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::MM_Cygwin' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::MM_DOS' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::MM_Darwin' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::MM_MacOS' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::MM_NW5' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::MM_OS2' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::MM_OS390' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::MM_QNX' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::MM_UWIN' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::MM_Unix' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::MM_VMS' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::MM_VOS' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::MM_Win32' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::MM_Win95' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::MY' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::MakeMaker' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::MakeMaker::Config'=> 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::MakeMaker::Locale'=> 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::MakeMaker::version'=> 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::MakeMaker::version::regex'=> 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', 'ExtUtils::Manifest' => 'http://github.com/Perl-Toolchain-Gang/ExtUtils-Manifest/issues', - 'ExtUtils::Mkbootstrap' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', - 'ExtUtils::Mksymlists' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::Mkbootstrap' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::Mksymlists' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', 'ExtUtils::PL2Bat' => 'http://rt.cpan.org/Public/Dist/Display.html?Name=ExtUtils-PL2Bat', 'ExtUtils::Packlist' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-Install', - 'ExtUtils::testlib' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', + 'ExtUtils::testlib' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', 'Fatal' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=autodie', 'File::Fetch' => undef, 'File::GlobMapper' => 'https://github.com/pmqs/IO-Compress/issues', @@ -19922,7 +20356,6 @@ sub is_core 'Unicode::Collate::Locale'=> undef, 'Win32' => 'https://github.com/perl-libwin32/win32/issues', 'Win32API::File' => undef, - 'Win32API::File::inc::ExtUtils::Myconst2perl'=> undef, 'autodie' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=autodie', 'autodie::Scope::Guard' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=autodie', 'autodie::Scope::GuardStack'=> 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=autodie', diff --git a/dist/Module-CoreList/lib/Module/CoreList/Utils.pm b/dist/Module-CoreList/lib/Module/CoreList/Utils.pm index 1406f1b5cbfd..7cc27788179e 100644 --- a/dist/Module-CoreList/lib/Module/CoreList/Utils.pm +++ b/dist/Module-CoreList/lib/Module/CoreList/Utils.pm @@ -4,7 +4,7 @@ use strict; use warnings; use Module::CoreList; -our $VERSION = '5.20201120'; +our $VERSION = '5.20210220'; our %utilities; sub utilities { @@ -1657,6 +1657,34 @@ my %delta = ( removed => { } }, + 5.033005 => { + delta_from => 5.033004, + changed => { + }, + removed => { + } + }, + 5.033006 => { + delta_from => 5.033005, + changed => { + }, + removed => { + } + }, + 5.032001 => { + delta_from => 5.032000, + changed => { + }, + removed => { + } + }, + 5.033007 => { + delta_from => 5.033006, + changed => { + }, + removed => { + } + }, ); %utilities = Module::CoreList::_undelta(\%delta); diff --git a/dist/Net-Ping/Changes b/dist/Net-Ping/Changes index 51d655078960..9e5e9e80d1b3 100644 --- a/dist/Net-Ping/Changes +++ b/dist/Net-Ping/Changes @@ -1,5 +1,28 @@ CHANGES ------- +2.74 2020-09-09 09:21:39 rurban + Features + - Add ICMPv6_NI_REPLY support. + Bugfixes + - Fix icmp payload offset to match icmpv6 (JimC Leones GH #21) + Skip the 20 byte header to reliably find the various return types. + This unifies icmpv6 with icmp better. + - Fix $SOCKET::VERSION eval (Petr Pavlu, PR #22) + META Changes + - Fix and improve the META repository as hashref, license as arrayref + (Tom Hukins, PR #19) + - add TEST_REQUIRES + - sort MANIFEST + - add windows smokers: appveyor + Test fixes + - Improve the tcp test to localhost, when there is no route to localhost + (freebsd mostly) + - TODO a flaky 450_service.t on 127.0.0.1 on port 2 on Windows (analog to freebsd, ...) + (Christian Walde, PR #20) + - Skip 501_ping_icmpv6.t when icmpv6 cannot be initialized. Mostly due to missing + icmpv6 support. (GH #15) + - add more xt tests: t/602_kwalitee.t, t/603_meta.t, t/604_manifest.t + 2.73 Thu Feb 27 14:32:25 CET 2020 (rurban) Bugfixes - Fix shadowing of hash options in constructor (Patrick Heesom, RT #131919) diff --git a/dist/Net-Ping/lib/Net/Ping.pm b/dist/Net-Ping/lib/Net/Ping.pm index 779e55daeda0..19bb51ec1acd 100644 --- a/dist/Net-Ping/lib/Net/Ping.pm +++ b/dist/Net-Ping/lib/Net/Ping.pm @@ -8,6 +8,7 @@ use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION $def_timeout $def_proto $def_factor $def_family $max_datasize $pingstring $hires $source_verify $syn_forking); use Fcntl qw( F_GETFL F_SETFL O_NONBLOCK ); +use Socket 2.007; use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW AF_INET PF_INET IPPROTO_TCP SOL_SOCKET SO_ERROR SO_BROADCAST IPPROTO_IP IP_TOS IP_TTL @@ -21,7 +22,7 @@ use Time::HiRes; @ISA = qw(Exporter); @EXPORT = qw(pingecho); @EXPORT_OK = qw(wakeonlan); -$VERSION = "2.73_01"; +$VERSION = "2.74"; # Globals @@ -46,7 +47,7 @@ my $NIx_NOSERV = eval { Socket::NIx_NOSERV() } || 2; #my $IPV6_HOPLIMIT = eval { Socket::IPV6_HOPLIMIT() }; # ping6 -h 0-255 my $qr_family = qr/^(?:(?:(:?ip)?v?(?:4|6))|${\AF_INET}|$AF_INET6)$/; my $qr_family4 = qr/^(?:(?:(:?ip)?v?4)|${\AF_INET})$/; -my $Socket_VERSION = eval { $Socket::VERSION }; +my $Socket_VERSION = eval $Socket::VERSION; if ($^O =~ /Win32/i) { # Hack to avoid this Win32 spewage: @@ -644,10 +645,11 @@ sub ping_external { # h2ph "asm/socket.h" # require "asm/socket.ph"; use constant SO_BINDTODEVICE => 25; -use constant ICMP_ECHOREPLY => 0; # ICMP packet types +use constant ICMP_ECHOREPLY => 0; # ICMP packet types use constant ICMPv6_ECHOREPLY => 129; # ICMP packet types -use constant ICMP_UNREACHABLE => 3; # ICMP packet types +use constant ICMP_UNREACHABLE => 3; # ICMP packet types use constant ICMPv6_UNREACHABLE => 1; # ICMP packet types +use constant ICMPv6_NI_REPLY => 140; # ICMP packet types use constant ICMP_ECHO => 8; use constant ICMPv6_ECHO => 128; use constant ICMP_TIME_EXCEEDED => 11; # ICMP packet types @@ -781,31 +783,25 @@ sub ping_icmp $from_saddr = recv($self->{fh}, $recv_msg, 1500, ICMP_FLAGS); $recv_msg_len = length($recv_msg) - length($self->{data}); ($from_port, $from_ip) = _unpack_sockaddr_in($from_saddr, $ip->{family}); - ($from_type, $from_subcode) = unpack("C2", substr($recv_msg, 20, 2)); + # ICMP echo includes the header and ICMPv6 doesn't. + # IPv4 length($recv_msg) is 28 (20 header + 8 payload) + # while IPv6 length is only 8 (sans header). + my $off = ($ip->{family} == AF_INET) ? 20 : 0; # payload offset + ($from_type, $from_subcode) = unpack("C2", substr($recv_msg, $off, 2)); if ($from_type == ICMP_TIMESTAMP_REPLY) { - ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 24, 4)) - if length $recv_msg >= 28; - } elsif ($from_type == ICMP_ECHOREPLY) { + ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, $off + 4, 4)) + if length $recv_msg >= $off + 8; + } elsif ($from_type == ICMP_ECHOREPLY || $from_type == ICMPv6_ECHOREPLY) { #warn "ICMP_ECHOREPLY: ", $ip->{family}, " ",$recv_msg, ":", length($recv_msg); - ($from_pid, $from_seq) = unpack("n2", substr($recv_msg, 24, 4)) - if ($ip->{family} == AF_INET && $recv_msg_len == 28); + ($from_pid, $from_seq) = unpack("n2", substr($recv_msg, $off + 4, 4)) + if $recv_msg_len == $off + 8; + } elsif ($from_type == ICMPv6_NI_REPLY) { ($from_pid, $from_seq) = unpack("n2", substr($recv_msg, 4, 4)) - if ($ip->{family} == $AF_INET6 && $recv_msg_len == 8); - } elsif ($from_type == ICMPv6_ECHOREPLY) { - #($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 24, 4)) - # if length $recv_msg >= 28; - #($from_pid, $from_seq) = unpack("n2", substr($recv_msg, 24, 4)) - # if ($ip->{family} == AF_INET && length $recv_msg == 28); - #warn "ICMPv6_ECHOREPLY: ", $ip->{family}, " ",$recv_msg, ":", length($recv_msg); - ($from_pid, $from_seq) = unpack("n2", substr($recv_msg, 4, 4)) - if ($ip->{family} == $AF_INET6 && $recv_msg_len == 8); - #} elsif ($from_type == ICMPv6_NI_REPLY) { - # ($from_pid, $from_seq) = unpack("n2", substr($recv_msg, 4, 4)) - # if ($ip->{family} == $AF_INET6 && length $recv_msg == 8); + if ($ip->{family} == $AF_INET6 && length $recv_msg == 8); } else { #warn "ICMP: ", $from_type, " ",$ip->{family}, " ",$recv_msg, ":", length($recv_msg); - ($from_pid, $from_seq) = unpack("n2", substr($recv_msg, 52, 4)) - if length $recv_msg >= 56; + ($from_pid, $from_seq) = unpack("n2", substr($recv_msg, $off + 32, 4)) + if length $recv_msg >= $off + 36; } $self->{from_ip} = $from_ip; $self->{from_type} = $from_type; @@ -2023,6 +2019,10 @@ Net::Ping - check a remote host for reachability } $p->close(); + $p = Net::Ping->new("icmpv6"); + $ip = "[fd00:dead:beef::4e]"; + print "$ip is alive.\n" if $p->ping($ip); + $p = Net::Ping->new("tcp", 2); # Try connecting to the www port instead of the echo port $p->port_number(scalar(getservbyname("http", "tcp"))); @@ -2368,7 +2368,7 @@ X The L method used with the icmp protocol. -=item $p->ping_icmpv6([$host, $timeout, $family]) I +=item $p->ping_icmpv6([$host, $timeout, $family]) X The L method used with the icmpv6 protocol. @@ -2574,7 +2574,7 @@ L =head1 COPYRIGHT -Copyright (c) 2017-2018, Reini Urban. All rights reserved. +Copyright (c) 2017-2020, Reini Urban. All rights reserved. Copyright (c) 2016, cPanel Inc. All rights reserved. diff --git a/dist/Net-Ping/t/200_ping_tcp.t b/dist/Net-Ping/t/200_ping_tcp.t index 47168b014ad9..e2bfe18c37df 100644 --- a/dist/Net-Ping/t/200_ping_tcp.t +++ b/dist/Net-Ping/t/200_ping_tcp.t @@ -44,14 +44,28 @@ eval { }; like($@, qr/message type only supported on 'icmp' protocol/, "message_type() API only concern 'icmp' protocol"); -isnt($p->ping("localhost"), 0, 'Test on the default port'); +my $localhost = $p->ping("localhost"); +if ($localhost) { + isnt($p->ping("localhost"), 0, 'Test on the default port'); +} else { + ok(1, "SKIP localhost on the default port on $^O"); +} # Change to use the more common web port. # This will pull from /etc/services on UNIX. # (Make sure getservbyname works in scalar context.) -isnt($p->{port_num} = (getservbyname("http", "tcp") || 80), undef); +isnt($p->{port_num} = (getservbyname("http", "tcp") || 80), undef, "getservbyname http"); -isnt($p->ping("localhost"), 0, 'Test localhost on the web port'); +if ($localhost) { + isnt($p->ping("localhost"), 0, 'Test localhost on the web port'); +} else { + my $result = $p->ping("localhost"); + if ($result) { + isnt($p->ping("localhost"), 0, "localhost on the web port unexpectedly worked on $^O"); + } else { + ok(1, "SKIP localhost on the web port on $^O"); + } +} is($p->ping($fail_ip), 0, "Can't reach $fail_ip"); diff --git a/dist/PathTools/.gitignore b/dist/PathTools/.gitignore index a87d5167ef43..3c1f39c66579 100644 --- a/dist/PathTools/.gitignore +++ b/dist/PathTools/.gitignore @@ -1,2 +1,3 @@ /Cwd.c /Cwd.bs +!/Makefile.PL diff --git a/dist/PathTools/Cwd.pm b/dist/PathTools/Cwd.pm index ce0f25f72de8..6a1d2f17ee57 100644 --- a/dist/PathTools/Cwd.pm +++ b/dist/PathTools/Cwd.pm @@ -3,7 +3,7 @@ use strict; use Exporter; -our $VERSION = '3.79'; +our $VERSION = '3.80'; my $xs_version = $VERSION; $VERSION =~ tr/_//d; diff --git a/dist/PathTools/Cwd.xs b/dist/PathTools/Cwd.xs index e7ecb3c6c1b4..223e1a6b18b4 100644 --- a/dist/PathTools/Cwd.xs +++ b/dist/PathTools/Cwd.xs @@ -84,6 +84,9 @@ bsd_realpath(const char *path, char resolved[MAXPATHLEN]) unsigned symlinks; int serrno; char remaining[MAXPATHLEN], next_token[MAXPATHLEN]; +#ifdef PERL_IMPLICIT_SYS + dTHX; +#endif serrno = errno; symlinks = 0; @@ -175,8 +178,8 @@ bsd_realpath(const char *path, char resolved[MAXPATHLEN]) } #if defined(HAS_LSTAT) && defined(HAS_READLINK) && defined(HAS_SYMLINK) { - struct stat sb; - if (lstat(resolved, &sb) != 0) { + Stat_t sb; + if (PerlLIO_lstat(resolved, &sb) != 0) { if (errno == ENOENT && p == NULL) { errno = serrno; return (resolved); @@ -191,7 +194,7 @@ bsd_realpath(const char *path, char resolved[MAXPATHLEN]) errno = ELOOP; return (NULL); } - slen = readlink(resolved, symlink, sizeof(symlink) - 1); + slen = PerlLIO_readlink(resolved, symlink, sizeof(symlink) - 1); if (slen < 0) return (NULL); symlink[slen] = '\0'; diff --git a/dist/PathTools/lib/File/Spec.pm b/dist/PathTools/lib/File/Spec.pm index 732746d943a2..30d883b61b3e 100644 --- a/dist/PathTools/lib/File/Spec.pm +++ b/dist/PathTools/lib/File/Spec.pm @@ -2,7 +2,7 @@ package File::Spec; use strict; -our $VERSION = '3.79'; +our $VERSION = '3.80'; $VERSION =~ tr/_//d; my %module = ( diff --git a/dist/PathTools/lib/File/Spec/AmigaOS.pm b/dist/PathTools/lib/File/Spec/AmigaOS.pm index 0d3c9a5770ca..fd9da81cdf5a 100644 --- a/dist/PathTools/lib/File/Spec/AmigaOS.pm +++ b/dist/PathTools/lib/File/Spec/AmigaOS.pm @@ -3,7 +3,7 @@ package File::Spec::AmigaOS; use strict; require File::Spec::Unix; -our $VERSION = '3.79'; +our $VERSION = '3.80'; $VERSION =~ tr/_//d; our @ISA = qw(File::Spec::Unix); diff --git a/dist/PathTools/lib/File/Spec/Cygwin.pm b/dist/PathTools/lib/File/Spec/Cygwin.pm index 591af63f9756..953c23361a10 100644 --- a/dist/PathTools/lib/File/Spec/Cygwin.pm +++ b/dist/PathTools/lib/File/Spec/Cygwin.pm @@ -3,7 +3,7 @@ package File::Spec::Cygwin; use strict; require File::Spec::Unix; -our $VERSION = '3.79'; +our $VERSION = '3.80'; $VERSION =~ tr/_//d; our @ISA = qw(File::Spec::Unix); diff --git a/dist/PathTools/lib/File/Spec/Epoc.pm b/dist/PathTools/lib/File/Spec/Epoc.pm index 4b8a17fc17cc..fcb9e894e33c 100644 --- a/dist/PathTools/lib/File/Spec/Epoc.pm +++ b/dist/PathTools/lib/File/Spec/Epoc.pm @@ -2,7 +2,7 @@ package File::Spec::Epoc; use strict; -our $VERSION = '3.79'; +our $VERSION = '3.80'; $VERSION =~ tr/_//d; require File::Spec::Unix; diff --git a/dist/PathTools/lib/File/Spec/Functions.pm b/dist/PathTools/lib/File/Spec/Functions.pm index fda2e95c627c..e14ad2f74538 100644 --- a/dist/PathTools/lib/File/Spec/Functions.pm +++ b/dist/PathTools/lib/File/Spec/Functions.pm @@ -3,7 +3,7 @@ package File::Spec::Functions; use File::Spec; use strict; -our $VERSION = '3.79'; +our $VERSION = '3.80'; $VERSION =~ tr/_//d; require Exporter; diff --git a/dist/PathTools/lib/File/Spec/Mac.pm b/dist/PathTools/lib/File/Spec/Mac.pm index 504d0cef7440..8026edcb1261 100644 --- a/dist/PathTools/lib/File/Spec/Mac.pm +++ b/dist/PathTools/lib/File/Spec/Mac.pm @@ -4,7 +4,7 @@ use strict; use Cwd (); require File::Spec::Unix; -our $VERSION = '3.79'; +our $VERSION = '3.80'; $VERSION =~ tr/_//d; our @ISA = qw(File::Spec::Unix); diff --git a/dist/PathTools/lib/File/Spec/OS2.pm b/dist/PathTools/lib/File/Spec/OS2.pm index fd7bc7fd0483..3c35ba99b48a 100644 --- a/dist/PathTools/lib/File/Spec/OS2.pm +++ b/dist/PathTools/lib/File/Spec/OS2.pm @@ -4,7 +4,7 @@ use strict; use Cwd (); require File::Spec::Unix; -our $VERSION = '3.79'; +our $VERSION = '3.80'; $VERSION =~ tr/_//d; our @ISA = qw(File::Spec::Unix); diff --git a/dist/PathTools/lib/File/Spec/Unix.pm b/dist/PathTools/lib/File/Spec/Unix.pm index 222158711571..c06d18f46819 100644 --- a/dist/PathTools/lib/File/Spec/Unix.pm +++ b/dist/PathTools/lib/File/Spec/Unix.pm @@ -3,7 +3,7 @@ package File::Spec::Unix; use strict; use Cwd (); -our $VERSION = '3.79'; +our $VERSION = '3.80'; $VERSION =~ tr/_//d; =head1 NAME diff --git a/dist/PathTools/lib/File/Spec/VMS.pm b/dist/PathTools/lib/File/Spec/VMS.pm index 174dd22b2e4f..9b78c8b4bc6e 100644 --- a/dist/PathTools/lib/File/Spec/VMS.pm +++ b/dist/PathTools/lib/File/Spec/VMS.pm @@ -4,7 +4,7 @@ use strict; use Cwd (); require File::Spec::Unix; -our $VERSION = '3.79'; +our $VERSION = '3.80'; $VERSION =~ tr/_//d; our @ISA = qw(File::Spec::Unix); diff --git a/dist/PathTools/lib/File/Spec/Win32.pm b/dist/PathTools/lib/File/Spec/Win32.pm index a3b89c3ff607..153744202338 100644 --- a/dist/PathTools/lib/File/Spec/Win32.pm +++ b/dist/PathTools/lib/File/Spec/Win32.pm @@ -5,7 +5,7 @@ use strict; use Cwd (); require File::Spec::Unix; -our $VERSION = '3.79'; +our $VERSION = '3.80'; $VERSION =~ tr/_//d; our @ISA = qw(File::Spec::Unix); diff --git a/dist/PathTools/t/cwd.t b/dist/PathTools/t/cwd.t index c05693880e2d..d155e33255ae 100644 --- a/dist/PathTools/t/cwd.t +++ b/dist/PathTools/t/cwd.t @@ -187,6 +187,10 @@ rmtree($test_dirs[0], 0, 0); SKIP: { skip "no symlinks on this platform", 2+$EXTRA_ABSPATH_TESTS unless $Config{d_symlink} && $^O !~ m!^(qnx|nto)!; + # on Win32 GetCurrentDirectory() includes the symlink if + # you chdir() to a path including the symlink. + skip "Win32 symlinks are unusual", 2+$EXTRA_ABSPATH_TESTS if $^O eq "MSWin32"; + my $file = "linktest"; mkpath([$Test_Dir], 0, 0777); symlink $Test_Dir, $file; diff --git a/dist/Safe/.gitignore b/dist/Safe/.gitignore new file mode 100644 index 000000000000..e54624d60d99 --- /dev/null +++ b/dist/Safe/.gitignore @@ -0,0 +1 @@ +!/Makefile.PL diff --git a/dist/Search-Dict/.gitignore b/dist/Search-Dict/.gitignore new file mode 100644 index 000000000000..e54624d60d99 --- /dev/null +++ b/dist/Search-Dict/.gitignore @@ -0,0 +1 @@ +!/Makefile.PL diff --git a/dist/Storable/.gitignore b/dist/Storable/.gitignore new file mode 100644 index 000000000000..e54624d60d99 --- /dev/null +++ b/dist/Storable/.gitignore @@ -0,0 +1 @@ +!/Makefile.PL diff --git a/dist/Storable/t/canonical.t b/dist/Storable/t/canonical.t index f7791ce879fd..3b930aab1bf1 100644 --- a/dist/Storable/t/canonical.t +++ b/dist/Storable/t/canonical.t @@ -34,7 +34,7 @@ $maxarraysize = 100; eval { require Digest::MD5; }; $gotmd5 = !$@; -diag "Will use Digest::MD5" if $gotmd5; +note "Will use Digest::MD5" if $gotmd5; # Use Data::Dumper if debugging and it is available to create an ASCII dump diff --git a/dist/Time-HiRes/.gitignore b/dist/Time-HiRes/.gitignore new file mode 100644 index 000000000000..e54624d60d99 --- /dev/null +++ b/dist/Time-HiRes/.gitignore @@ -0,0 +1 @@ +!/Makefile.PL diff --git a/dist/Time-HiRes/HiRes.pm b/dist/Time-HiRes/HiRes.pm index 1183dc9dd789..9377c3479fbd 100644 --- a/dist/Time-HiRes/HiRes.pm +++ b/dist/Time-HiRes/HiRes.pm @@ -50,7 +50,7 @@ our @EXPORT_OK = qw (usleep sleep ualarm alarm gettimeofday time tv_interval stat lstat utime ); -our $VERSION = '1.9765'; +our $VERSION = '1.9767'; our $XS_VERSION = $VERSION; $VERSION = eval $VERSION; diff --git a/dist/Time-HiRes/HiRes.xs b/dist/Time-HiRes/HiRes.xs index ca81e5a4a351..1b97962b3a6e 100644 --- a/dist/Time-HiRes/HiRes.xs +++ b/dist/Time-HiRes/HiRes.xs @@ -86,13 +86,6 @@ extern "C" { # undef ITIMER_REALPROF #endif -#ifndef ENV_LOCALE_LOCK -# define ENV_LOCALE_LOCK -#endif -#ifndef ENV_LOCALE_UNLOCK -# define ENV_LOCALE_UNLOCK -#endif - #ifndef TIME_HIRES_CLOCKID_T typedef int clockid_t; #endif @@ -141,8 +134,12 @@ typedef struct { unsigned __int64 reset_time; } my_cxt_t; -/* Visual C++ 2013 and older don't have the timespec structure */ -# if defined(_MSC_VER) && _MSC_VER < 1900 +/* Visual C++ 2013 and older don't have the timespec structure. + * Neither do mingw.org compilers with MinGW runtimes older than 3.22. */ +# if((defined(_MSC_VER) && _MSC_VER < 1900) || \ + (defined(__MINGW32__) && !defined(__MINGW64_VERSION_MAJOR) && \ + defined(__MINGW32_MAJOR_VERSION) && (__MINGW32_MAJOR_VERSION < 3 || \ + (__MINGW32_MAJOR_VERSION == 3 && __MINGW32_MINOR_VERSION < 22)))) struct timespec { time_t tv_sec; long tv_nsec; diff --git a/dist/Unicode-Normalize/.gitignore b/dist/Unicode-Normalize/.gitignore index 424c745c1253..47489b4d1f9f 100644 --- a/dist/Unicode-Normalize/.gitignore +++ b/dist/Unicode-Normalize/.gitignore @@ -1 +1,2 @@ *.h +!/Makefile.PL diff --git a/dist/Unicode-Normalize/Makefile.PL b/dist/Unicode-Normalize/Makefile.PL index 5c40ff1700f6..a848b0d22c68 100644 --- a/dist/Unicode-Normalize/Makefile.PL +++ b/dist/Unicode-Normalize/Makefile.PL @@ -8,7 +8,7 @@ my $clean = {}; my $mm_ver = ExtUtils::MakeMaker->VERSION; if (-f "Normalize.xs") { - print STDERR "Making header files for XS...\n"; + print "Making header files for XS...\n"; do './mkheader' or die $@ || "mkheader: $!"; diff --git a/dist/XSLoader/.gitignore b/dist/XSLoader/.gitignore index b91c997d5033..447ed53189c0 100644 --- a/dist/XSLoader/.gitignore +++ b/dist/XSLoader/.gitignore @@ -1 +1,2 @@ /XSLoader.pm +!/Makefile.PL diff --git a/dist/XSLoader/Makefile.PL b/dist/XSLoader/Makefile.PL index c7cdbec77078..6f5aae349dea 100644 --- a/dist/XSLoader/Makefile.PL +++ b/dist/XSLoader/Makefile.PL @@ -8,6 +8,8 @@ use strict; use warnings; +use v5.6; + use ExtUtils::MakeMaker; use ExtUtils::MM_Unix; @@ -101,11 +103,7 @@ WriteMakefile( my @perls = ($orig_perl); push @perls, qw(bleadperl perl5.6.1 - perl5.6.0 - perl5.005_03 - perl5.004_05 - perl5.004_04 - perl5.004) + perl5.6.0) if $ENV{PERL_TEST_ALL}; my $out; diff --git a/dist/XSLoader/XSLoader_pm.PL b/dist/XSLoader/XSLoader_pm.PL index 66e4c2d63156..ff5ca3131bc1 100644 --- a/dist/XSLoader/XSLoader_pm.PL +++ b/dist/XSLoader/XSLoader_pm.PL @@ -1,4 +1,6 @@ use strict; +use warnings; + use Config; # We require DynaLoader to make sure that mod2fname is loaded eval { require DynaLoader }; @@ -9,37 +11,15 @@ print OUT <<'EOT'; # Generated from XSLoader_pm.PL (resolved %Config::Config value) # This file is unique for every OS -package XSLoader; +use strict; +no strict 'refs'; -$VERSION = "0.30"; # remember to update version in POD! +package XSLoader; -#use strict; +our $VERSION = "0.32"; # remember to update version in POD! package DynaLoader; -EOT - -# dlutils.c before 5.006 has this: -# -# #ifdef DEBUGGING -# dl_debug = SvIV( perl_get_sv("DynaLoader::dl_debug", 0x04) ); -# #endif -# -# where 0x04 is GV_ADDWARN, which causes a warning to be issued by the call -# into XS below, if DynaLoader.pm hasn't been loaded. -# It was changed to 0 in the commit(s) that added XSLoader to the core -# (9cf41c4d23a47c8b and its parent 9426adcd48655815) -# Hence to backport XSLoader to work silently with earlier DynaLoaders we need -# to ensure that the variable exists: - -print OUT <<'EOT' if $] < 5.006; - -# enable debug/trace messages from DynaLoader perl code -$dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug; - -EOT - -print OUT <<'EOT'; # No prizes for guessing why we don't say 'bootstrap DynaLoader;' here. # NOTE: All dl_*.xs (including dl_none.xs) define a dl_error() XSUB boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) && @@ -208,42 +188,17 @@ print OUT <<'EOT'; push(@DynaLoader::dl_shared_objects, $file); # record files loaded return &$xs(@_); } -EOT # Can't test with DynaLoader->can('bootstrap_inherit') when building in the # core, as XSLoader gets built before DynaLoader. -if ($] >= 5.006) { - print OUT <<'EOT'; - sub bootstrap_inherit { require DynaLoader; goto \&DynaLoader::bootstrap_inherit; } -EOT -} else { - print OUT <<'EOT'; - -sub bootstrap_inherit { - # Versions of DynaLoader prior to 5.6.0 don't have bootstrap_inherit. - package DynaLoader; - - my $module = $_[0]; - local *DynaLoader::isa = *{"$module\::ISA"}; - local @DynaLoader::isa = (@DynaLoader::isa, 'DynaLoader'); - # Cannot goto due to delocalization. Will report errors on a wrong line? - require DynaLoader; - DynaLoader::bootstrap(@_); -} - -EOT -} - -print OUT <<'EOT'; 1; - __END__ =head1 NAME @@ -252,7 +207,7 @@ XSLoader - Dynamically load C libraries into Perl code =head1 VERSION -Version 0.30 +Version 0.32 =head1 SYNOPSIS diff --git a/dist/XSLoader/t/XSLoader.t b/dist/XSLoader/t/XSLoader.t index d3538b849cbb..5b7ce7cb5619 100644 --- a/dist/XSLoader/t/XSLoader.t +++ b/dist/XSLoader/t/XSLoader.t @@ -1,6 +1,8 @@ #!perl -T use strict; +use warnings; + use Config; my $db_file; @@ -10,8 +12,6 @@ BEGIN { die "Test::More not available\n"; } - plan(skip_all => "these tests needs Perl 5.5+") if $] < 5.005; - use Config; foreach (qw/SDBM_File GDBM_File ODBM_File NDBM_File DB_File/) { if ($Config{extensions} =~ /\b$_\b/) { diff --git a/dist/base/.gitignore b/dist/base/.gitignore new file mode 100644 index 000000000000..e54624d60d99 --- /dev/null +++ b/dist/base/.gitignore @@ -0,0 +1 @@ +!/Makefile.PL diff --git a/dist/lib/.gitignore b/dist/lib/.gitignore index 8caf3063dc85..c5c4f7289333 100644 --- a/dist/lib/.gitignore +++ b/dist/lib/.gitignore @@ -1 +1,2 @@ /lib.pm +!/Makefile.PL diff --git a/dist/threads/t/libc.t b/dist/threads/t/libc.t index 4f6f6ed3ae19..65958949f6cf 100644 --- a/dist/threads/t/libc.t +++ b/dist/threads/t/libc.t @@ -9,6 +9,12 @@ BEGIN { skip_all(q/Perl not compiled with 'useithreads'/); } + my $time_out_factor = $ENV{PERL_TEST_TIME_OUT_FACTOR} || 1; + $time_out_factor = 1 if $time_out_factor < 1; + + # Guard against bugs that result in deadlock + watchdog(1 * 60 * $time_out_factor); + plan(11); } diff --git a/djgpp/djgpp.c b/djgpp/djgpp.c index 24d12f254b25..ddadeb7d53c2 100644 --- a/djgpp/djgpp.c +++ b/djgpp/djgpp.c @@ -107,7 +107,7 @@ convretcode (pTHX_ int rc,char *prog,int fl) { if (rc < 0 && ckWARN(WARN_EXEC)) Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't %s \"%s\": %s", - fl ? "exec" : "spawn",prog,Strerror (errno)); + fl ? "exec" : "spawn",prog,Strerror (errno)); if (rc >= 0) return rc << 8; return -1; @@ -155,13 +155,13 @@ do_spawn2 (pTHX_ char *cmd,int execf) ENTER; if ((shell=getenv("SHELL"))==NULL && (shell=getenv("COMSPEC"))==NULL) - shell="c:\\command.com" EXTRA; + shell="c:\\command.com" EXTRA; unixysh=_is_unixy_shell (shell); metachars=unixysh ? "$&*(){}[]'\";\\?>|<~`\n" EXTRA : "*?[|<>\"\\" EXTRA; while (*cmd && isSPACE(*cmd)) - cmd++; + cmd++; if (strBEGINs (cmd,"/bin/sh") && isSPACE (cmd[7])) cmd+=5; @@ -181,20 +181,20 @@ do_spawn2 (pTHX_ char *cmd,int execf) goto doshell; } for (s=cmd; *s; s++) - if (strchr (metachars,*s)) - { - if (*s=='\n' && s[1]=='\0') - { - *s='\0'; - break; - } + if (strchr (metachars,*s)) + { + if (*s=='\n' && s[1]=='\0') + { + *s='\0'; + break; + } doshell: - if (execf==EXECF_EXEC) + if (execf==EXECF_EXEC) result = convretcode (execl (shell,shell,unixysh ? "-c" : "/c",cmd,NULL),cmd,execf); - else - result = convretcode (system (cmd),cmd,execf); - goto leave; - } + else + result = convretcode (system (cmd),cmd,execf); + goto leave; + } Newx (argv,(s-cmd)/2+2,char*); SAVEFREEPV(argv); @@ -202,17 +202,17 @@ do_spawn2 (pTHX_ char *cmd,int execf) SAVEFREEPV(cmd); a=argv; for (s=cmd; *s;) { - while (*s && isSPACE (*s)) s++; - if (*s) - *(a++)=s; - while (*s && !isSPACE (*s)) s++; - if (*s) - *s++='\0'; + while (*s && isSPACE (*s)) s++; + if (*s) + *(a++)=s; + while (*s && !isSPACE (*s)) s++; + if (*s) + *s++='\0'; } *a=NULL; if (!argv[0]) { result = -1; - goto leave; + goto leave; } if (execf==EXECF_EXEC) @@ -362,7 +362,7 @@ XS(dos_GetCwd) ST(0)=sv_newmortal (); if (getcwd (tmp,PATH_MAX+1)!=NULL) sv_setpv ((SV*)ST(0),tmp); - SvTAINTED_on(ST(0)); + SvTAINTED_on(ST(0)); } XSRETURN (1); } @@ -378,14 +378,14 @@ XS(XS_Cwd_sys_cwd) { dXSARGS; if (items != 0) - Perl_croak_nocontext("Usage: Cwd::sys_cwd()"); + Perl_croak_nocontext("Usage: Cwd::sys_cwd()"); { - char p[MAXPATHLEN]; - char * RETVAL; - RETVAL = getcwd(p, MAXPATHLEN); - ST(0) = sv_newmortal(); - sv_setpv((SV*)ST(0), RETVAL); - SvTAINTED_on(ST(0)); + char p[MAXPATHLEN]; + char * RETVAL; + RETVAL = getcwd(p, MAXPATHLEN); + ST(0) = sv_newmortal(); + sv_setpv((SV*)ST(0), RETVAL); + SvTAINTED_on(ST(0)); } XSRETURN(1); } @@ -453,9 +453,9 @@ djgpp_fflush (FILE *fp) int res; if ((res = fflush(fp)) == 0 && fp) { - Stat_t s; - if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode)) - res = fsync(fileno(fp)); + Stat_t s; + if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode)) + res = fsync(fileno(fp)); } /* * If the flush succeeded but set end-of-file, we need to clear diff --git a/doio.c b/doio.c index 2bffeea07958..baca499d102a 100644 --- a/doio.c +++ b/doio.c @@ -83,7 +83,7 @@ Perl_setfd_cloexec_for_nonsysfd(pTHX_ int fd) { assert(fd >= 0); if(fd > PL_maxsysfd) - setfd_cloexec(fd); + setfd_cloexec(fd); } void @@ -91,96 +91,96 @@ Perl_setfd_inhexec_for_sysfd(pTHX_ int fd) { assert(fd >= 0); if(fd <= PL_maxsysfd) - setfd_inhexec(fd); + setfd_inhexec(fd); } void Perl_setfd_cloexec_or_inhexec_by_sysfdness(pTHX_ int fd) { assert(fd >= 0); if(fd <= PL_maxsysfd) - setfd_inhexec(fd); + setfd_inhexec(fd); else - setfd_cloexec(fd); + setfd_cloexec(fd); } #define DO_GENOPEN_THEN_CLOEXEC(GENOPEN_NORMAL, GENSETFD_CLOEXEC) \ - do { \ - int res = (GENOPEN_NORMAL); \ - if(LIKELY(res != -1)) GENSETFD_CLOEXEC; \ - return res; \ - } while(0) + do { \ + int res = (GENOPEN_NORMAL); \ + if(LIKELY(res != -1)) GENSETFD_CLOEXEC; \ + return res; \ + } while(0) #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) && \ - defined(F_GETFD) + defined(F_GETFD) enum { CLOEXEC_EXPERIMENT = 0, CLOEXEC_AT_OPEN, CLOEXEC_AFTER_OPEN }; # define DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, TESTFD, GENOPEN_CLOEXEC, \ - GENOPEN_NORMAL, GENSETFD_CLOEXEC) \ - do { \ - switch (strategy) { \ - case CLOEXEC_EXPERIMENT: default: { \ - int res = (GENOPEN_CLOEXEC), eno; \ - if (LIKELY(res != -1)) { \ - int fdflags = fcntl((TESTFD), F_GETFD); \ - if (LIKELY(fdflags != -1) && \ - LIKELY(fdflags & FD_CLOEXEC)) { \ - strategy = CLOEXEC_AT_OPEN; \ - } else { \ - strategy = CLOEXEC_AFTER_OPEN; \ - GENSETFD_CLOEXEC; \ - } \ - } else if (UNLIKELY((eno = errno) == EINVAL || \ - eno == ENOSYS)) { \ - res = (GENOPEN_NORMAL); \ - if (LIKELY(res != -1)) { \ - strategy = CLOEXEC_AFTER_OPEN; \ - GENSETFD_CLOEXEC; \ - } else if (!LIKELY((eno = errno) == EINVAL || \ - eno == ENOSYS)) { \ - strategy = CLOEXEC_AFTER_OPEN; \ - } \ - } \ - return res; \ - } \ - case CLOEXEC_AT_OPEN: \ - return (GENOPEN_CLOEXEC); \ - case CLOEXEC_AFTER_OPEN: \ - DO_GENOPEN_THEN_CLOEXEC(GENOPEN_NORMAL, GENSETFD_CLOEXEC); \ - } \ - } while(0) + GENOPEN_NORMAL, GENSETFD_CLOEXEC) \ + do { \ + switch (strategy) { \ + case CLOEXEC_EXPERIMENT: default: { \ + int res = (GENOPEN_CLOEXEC), eno; \ + if (LIKELY(res != -1)) { \ + int fdflags = fcntl((TESTFD), F_GETFD); \ + if (LIKELY(fdflags != -1) && \ + LIKELY(fdflags & FD_CLOEXEC)) { \ + strategy = CLOEXEC_AT_OPEN; \ + } else { \ + strategy = CLOEXEC_AFTER_OPEN; \ + GENSETFD_CLOEXEC; \ + } \ + } else if (UNLIKELY((eno = errno) == EINVAL || \ + eno == ENOSYS)) { \ + res = (GENOPEN_NORMAL); \ + if (LIKELY(res != -1)) { \ + strategy = CLOEXEC_AFTER_OPEN; \ + GENSETFD_CLOEXEC; \ + } else if (!LIKELY((eno = errno) == EINVAL || \ + eno == ENOSYS)) { \ + strategy = CLOEXEC_AFTER_OPEN; \ + } \ + } \ + return res; \ + } \ + case CLOEXEC_AT_OPEN: \ + return (GENOPEN_CLOEXEC); \ + case CLOEXEC_AFTER_OPEN: \ + DO_GENOPEN_THEN_CLOEXEC(GENOPEN_NORMAL, GENSETFD_CLOEXEC); \ + } \ + } while(0) #else # define DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, TESTFD, GENOPEN_CLOEXEC, \ - GENOPEN_NORMAL, GENSETFD_CLOEXEC) \ - DO_GENOPEN_THEN_CLOEXEC(GENOPEN_NORMAL, GENSETFD_CLOEXEC) + GENOPEN_NORMAL, GENSETFD_CLOEXEC) \ + DO_GENOPEN_THEN_CLOEXEC(GENOPEN_NORMAL, GENSETFD_CLOEXEC) #endif #define DO_ONEOPEN_THEN_CLOEXEC(ONEOPEN_NORMAL) \ - do { \ - int fd; \ - DO_GENOPEN_THEN_CLOEXEC(fd = (ONEOPEN_NORMAL), \ - setfd_cloexec(fd)); \ - } while(0) + do { \ + int fd; \ + DO_GENOPEN_THEN_CLOEXEC(fd = (ONEOPEN_NORMAL), \ + setfd_cloexec(fd)); \ + } while(0) #define DO_ONEOPEN_EXPERIMENTING_CLOEXEC(strategy, \ ONEOPEN_CLOEXEC, ONEOPEN_NORMAL) \ - do { \ - int fd; \ - DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, \ + do { \ + int fd; \ + DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, \ fd, \ fd = (ONEOPEN_CLOEXEC), \ - fd = (ONEOPEN_NORMAL), setfd_cloexec(fd)); \ - } while(0) + fd = (ONEOPEN_NORMAL), setfd_cloexec(fd)); \ + } while(0) #define DO_PIPESETFD_CLOEXEC(PIPEFD) \ - do { \ - setfd_cloexec((PIPEFD)[0]); \ - setfd_cloexec((PIPEFD)[1]); \ - } while(0) + do { \ + setfd_cloexec((PIPEFD)[0]); \ + setfd_cloexec((PIPEFD)[1]); \ + } while(0) #define DO_PIPEOPEN_THEN_CLOEXEC(PIPEFD, PIPEOPEN_NORMAL) \ - DO_GENOPEN_THEN_CLOEXEC(PIPEOPEN_NORMAL, DO_PIPESETFD_CLOEXEC(PIPEFD)) + DO_GENOPEN_THEN_CLOEXEC(PIPEOPEN_NORMAL, DO_PIPESETFD_CLOEXEC(PIPEFD)) #define DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(strategy, PIPEFD, PIPEOPEN_CLOEXEC, \ - PIPEOPEN_NORMAL) \ - DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, \ + PIPEOPEN_NORMAL) \ + DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, \ (PIPEFD)[0], PIPEOPEN_CLOEXEC, \ - PIPEOPEN_NORMAL, DO_PIPESETFD_CLOEXEC(PIPEFD)) + PIPEOPEN_NORMAL, DO_PIPESETFD_CLOEXEC(PIPEFD)) int Perl_PerlLIO_dup_cloexec(pTHX_ int oldfd) @@ -193,8 +193,8 @@ Perl_PerlLIO_dup_cloexec(pTHX_ int oldfd) */ DO_ONEOPEN_EXPERIMENTING_CLOEXEC( PL_strategy_dup, - fcntl(oldfd, F_DUPFD_CLOEXEC, 0), - PerlLIO_dup(oldfd)); + fcntl(oldfd, F_DUPFD_CLOEXEC, 0), + PerlLIO_dup(oldfd)); #else DO_ONEOPEN_THEN_CLOEXEC(PerlLIO_dup(oldfd)); #endif @@ -211,8 +211,8 @@ Perl_PerlLIO_dup2_cloexec(pTHX_ int oldfd, int newfd) */ DO_ONEOPEN_EXPERIMENTING_CLOEXEC( PL_strategy_dup2, - dup3(oldfd, newfd, O_CLOEXEC), - PerlLIO_dup2(oldfd, newfd)); + dup3(oldfd, newfd, O_CLOEXEC), + PerlLIO_dup2(oldfd, newfd)); #else DO_ONEOPEN_THEN_CLOEXEC(PerlLIO_dup2(oldfd, newfd)); #endif @@ -225,8 +225,8 @@ Perl_PerlLIO_open_cloexec(pTHX_ const char *file, int flag) #if defined(O_CLOEXEC) DO_ONEOPEN_EXPERIMENTING_CLOEXEC( PL_strategy_open, - PerlLIO_open(file, flag | O_CLOEXEC), - PerlLIO_open(file, flag)); + PerlLIO_open(file, flag | O_CLOEXEC), + PerlLIO_open(file, flag)); #else DO_ONEOPEN_THEN_CLOEXEC(PerlLIO_open(file, flag)); #endif @@ -239,8 +239,8 @@ Perl_PerlLIO_open3_cloexec(pTHX_ const char *file, int flag, int perm) #if defined(O_CLOEXEC) DO_ONEOPEN_EXPERIMENTING_CLOEXEC( PL_strategy_open3, - PerlLIO_open3(file, flag | O_CLOEXEC, perm), - PerlLIO_open3(file, flag, perm)); + PerlLIO_open3(file, flag | O_CLOEXEC, perm), + PerlLIO_open3(file, flag, perm)); #else DO_ONEOPEN_THEN_CLOEXEC(PerlLIO_open3(file, flag, perm)); #endif @@ -253,8 +253,8 @@ Perl_my_mkstemp_cloexec(char *templte) #if defined(O_CLOEXEC) DO_ONEOPEN_EXPERIMENTING_CLOEXEC( PL_strategy_mkstemp, - Perl_my_mkostemp(templte, O_CLOEXEC), - Perl_my_mkstemp(templte)); + Perl_my_mkostemp(templte, O_CLOEXEC), + Perl_my_mkstemp(templte)); #else DO_ONEOPEN_THEN_CLOEXEC(Perl_my_mkstemp(templte)); #endif @@ -267,8 +267,8 @@ Perl_my_mkostemp_cloexec(char *templte, int flags) #if defined(O_CLOEXEC) DO_ONEOPEN_EXPERIMENTING_CLOEXEC( PL_strategy_mkstemp, - Perl_my_mkostemp(templte, flags | O_CLOEXEC), - Perl_my_mkostemp(templte, flags)); + Perl_my_mkostemp(templte, flags | O_CLOEXEC), + Perl_my_mkostemp(templte, flags)); #else DO_ONEOPEN_THEN_CLOEXEC(Perl_my_mkostemp(templte, flags)); #endif @@ -286,8 +286,8 @@ Perl_PerlProc_pipe_cloexec(pTHX_ int *pipefd) */ # if !defined(PERL_IMPLICIT_SYS) && defined(HAS_PIPE2) && defined(O_CLOEXEC) DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(PL_strategy_pipe, pipefd, - pipe2(pipefd, O_CLOEXEC), - PerlProc_pipe(pipefd)); + pipe2(pipefd, O_CLOEXEC), + PerlProc_pipe(pipefd)); # else DO_PIPEOPEN_THEN_CLOEXEC(pipefd, PerlProc_pipe(pipefd)); # endif @@ -302,8 +302,8 @@ Perl_PerlSock_socket_cloexec(pTHX_ int domain, int type, int protocol) # if defined(SOCK_CLOEXEC) DO_ONEOPEN_EXPERIMENTING_CLOEXEC( PL_strategy_socket, - PerlSock_socket(domain, type | SOCK_CLOEXEC, protocol), - PerlSock_socket(domain, type, protocol)); + PerlSock_socket(domain, type | SOCK_CLOEXEC, protocol), + PerlSock_socket(domain, type, protocol)); # else DO_ONEOPEN_THEN_CLOEXEC(PerlSock_socket(domain, type, protocol)); # endif @@ -314,7 +314,7 @@ Perl_PerlSock_accept_cloexec(pTHX_ int listenfd, struct sockaddr *addr, Sock_size_t *addrlen) { # if !defined(PERL_IMPLICIT_SYS) && \ - defined(HAS_ACCEPT4) && defined(SOCK_CLOEXEC) + defined(HAS_ACCEPT4) && defined(SOCK_CLOEXEC) /* * struct IPerlSock doesn't cover accept4(), and there's no clear * way to extend it, so for the time being this just isn't available @@ -322,8 +322,8 @@ Perl_PerlSock_accept_cloexec(pTHX_ int listenfd, struct sockaddr *addr, */ DO_ONEOPEN_EXPERIMENTING_CLOEXEC( PL_strategy_accept, - accept4(listenfd, addr, addrlen, SOCK_CLOEXEC), - PerlSock_accept(listenfd, addr, addrlen)); + accept4(listenfd, addr, addrlen, SOCK_CLOEXEC), + PerlSock_accept(listenfd, addr, addrlen)); # else DO_ONEOPEN_THEN_CLOEXEC(PerlSock_accept(listenfd, addr, addrlen)); # endif @@ -333,7 +333,7 @@ Perl_PerlSock_accept_cloexec(pTHX_ int listenfd, struct sockaddr *addr, #if defined (HAS_SOCKETPAIR) || \ (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && \ - defined(AF_INET) && defined(PF_INET)) + defined(AF_INET) && defined(PF_INET)) int Perl_PerlSock_socketpair_cloexec(pTHX_ int domain, int type, int protocol, int *pairfd) @@ -341,11 +341,11 @@ Perl_PerlSock_socketpair_cloexec(pTHX_ int domain, int type, int protocol, PERL_ARGS_ASSERT_PERLSOCK_SOCKETPAIR_CLOEXEC; # ifdef SOCK_CLOEXEC DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(PL_strategy_socketpair, pairfd, - PerlSock_socketpair(domain, type | SOCK_CLOEXEC, protocol, pairfd), - PerlSock_socketpair(domain, type, protocol, pairfd)); + PerlSock_socketpair(domain, type | SOCK_CLOEXEC, protocol, pairfd), + PerlSock_socketpair(domain, type, protocol, pairfd)); # else DO_PIPEOPEN_THEN_CLOEXEC(pairfd, - PerlSock_socketpair(domain, type, protocol, pairfd)); + PerlSock_socketpair(domain, type, protocol, pairfd)); # endif } #endif @@ -368,10 +368,10 @@ S_openn_setup(pTHX_ GV *gv, char *mode, PerlIO **saveifp, PerlIO **saveofp, /* If currently open - close before we re-open */ if (IoIFP(io)) { - if (IoTYPE(io) == IoTYPE_STD) { - /* This is a clone of one of STD* handles */ - } - else { + if (IoTYPE(io) == IoTYPE_STD) { + /* This is a clone of one of STD* handles */ + } + else { const int old_fd = PerlIO_fileno(IoIFP(io)); if (inRANGE(old_fd, 0, PL_maxsysfd)) { @@ -407,25 +407,25 @@ S_openn_setup(pTHX_ GV *gv, char *mode, PerlIO **saveifp, PerlIO **saveofp, } } } - IoOFP(io) = IoIFP(io) = NULL; + IoOFP(io) = IoIFP(io) = NULL; } return io; } bool Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw, - int rawmode, int rawperm, PerlIO *supplied_fp, SV **svp, - I32 num_svs) + int rawmode, int rawperm, PerlIO *supplied_fp, SV **svp, + I32 num_svs) { PERL_ARGS_ASSERT_DO_OPENN; if (as_raw) { /* sysopen style args, i.e. integer mode and permissions */ - if (num_svs != 0) { - Perl_croak(aTHX_ "panic: sysopen with multiple args, num_svs=%ld", - (long) num_svs); - } + if (num_svs != 0) { + Perl_croak(aTHX_ "panic: sysopen with multiple args, num_svs=%ld", + (long) num_svs); + } return do_open_raw(gv, oname, len, rawmode, rawperm, NULL); } return do_open6(gv, oname, len, supplied_fp, svp, num_svs); @@ -449,52 +449,52 @@ Perl_do_open_raw(pTHX_ GV *gv, const char *oname, STRLEN len, /* For ease of blame back to 5.000, keep the existing indenting. */ { /* sysopen style args, i.e. integer mode and permissions */ - STRLEN ix = 0; - const int appendtrunc = - 0 + STRLEN ix = 0; + const int appendtrunc = + 0 #ifdef O_APPEND /* Not fully portable. */ - |O_APPEND + |O_APPEND #endif #ifdef O_TRUNC /* Not fully portable. */ - |O_TRUNC + |O_TRUNC #endif - ; - const int modifyingmode = O_WRONLY|O_RDWR|O_CREAT|appendtrunc; - int ismodifying; + ; + const int modifyingmode = O_WRONLY|O_RDWR|O_CREAT|appendtrunc; + int ismodifying; SV *namesv; - /* It's not always + /* It's not always - O_RDONLY 0 - O_WRONLY 1 - O_RDWR 2 + O_RDONLY 0 + O_WRONLY 1 + O_RDWR 2 - It might be (in OS/390 and Mac OS Classic it is) + It might be (in OS/390 and Mac OS Classic it is) - O_WRONLY 1 - O_RDONLY 2 - O_RDWR 3 + O_WRONLY 1 + O_RDONLY 2 + O_RDWR 3 - This means that simple & with O_RDWR would look - like O_RDONLY is present. Therefore we have to - be more careful. - */ - if ((ismodifying = (rawmode & modifyingmode))) { - if ((ismodifying & O_WRONLY) == O_WRONLY || - (ismodifying & O_RDWR) == O_RDWR || - (ismodifying & (O_CREAT|appendtrunc))) - TAINT_PROPER("sysopen"); - } - mode[ix++] = IoTYPE_NUMERIC; /* Marker to openn to use numeric "sysopen" */ + This means that simple & with O_RDWR would look + like O_RDONLY is present. Therefore we have to + be more careful. + */ + if ((ismodifying = (rawmode & modifyingmode))) { + if ((ismodifying & O_WRONLY) == O_WRONLY || + (ismodifying & O_RDWR) == O_RDWR || + (ismodifying & (O_CREAT|appendtrunc))) + TAINT_PROPER("sysopen"); + } + mode[ix++] = IoTYPE_NUMERIC; /* Marker to openn to use numeric "sysopen" */ #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE) - rawmode |= O_LARGEFILE; /* Transparently largefiley. */ + rawmode |= O_LARGEFILE; /* Transparently largefiley. */ #endif IoTYPE(io) = PerlIO_intmode2str(rawmode, &mode[ix], &writing); - namesv = newSVpvn_flags(oname, len, SVs_TEMP); - fp = PerlIO_openn(aTHX_ NULL, mode, -1, rawmode, rawperm, NULL, 1, &namesv); + namesv = newSVpvn_flags(oname, len, SVs_TEMP); + fp = PerlIO_openn(aTHX_ NULL, mode, -1, rawmode, rawperm, NULL, 1, &namesv); } return openn_cleanup(gv, io, fp, mode, oname, saveifp, saveofp, savefd, savetype, writing, 0, NULL, statbufp); @@ -519,11 +519,11 @@ Perl_do_open6(pTHX_ GV *gv, const char *oname, STRLEN len, /* For ease of blame back to 5.000, keep the existing indenting. */ { - /* Regular (non-sys) open */ - char *name; - STRLEN olen = len; - char *tend; - int dodup = 0; + /* Regular (non-sys) open */ + char *name; + STRLEN olen = len; + char *tend; + int dodup = 0; bool in_raw = 0, in_crlf = 0, out_raw = 0, out_crlf = 0; /* Collect default raw/crlf info from the op */ @@ -536,29 +536,29 @@ Perl_do_open6(pTHX_ GV *gv, const char *oname, STRLEN len, out_crlf = (flags & OPpOPEN_OUT_CRLF); } - type = savepvn(oname, len); - tend = type+len; - SAVEFREEPV(type); + type = savepvn(oname, len); + tend = type+len; + SAVEFREEPV(type); /* Lose leading and trailing white space */ - while (isSPACE(*type)) - type++; + while (isSPACE(*type)) + type++; while (tend > type && isSPACE(tend[-1])) - *--tend = '\0'; + *--tend = '\0'; - if (num_svs) { + if (num_svs) { const char *p; STRLEN nlen = 0; - /* New style explicit name, type is just mode and layer info */ + /* New style explicit name, type is just mode and layer info */ #ifdef USE_STDIO - if (SvROK(*svp) && !memchr(oname, '&', len)) { - if (ckWARN(WARN_IO)) - Perl_warner(aTHX_ packWARN(WARN_IO), - "Can't open a reference"); - SETERRNO(EINVAL, LIB_INVARG); + if (SvROK(*svp) && !memchr(oname, '&', len)) { + if (ckWARN(WARN_IO)) + Perl_warner(aTHX_ packWARN(WARN_IO), + "Can't open a reference"); + SETERRNO(EINVAL, LIB_INVARG); fp = NULL; - goto say_false; - } + goto say_false; + } #endif /* USE_STDIO */ p = (SvOK(*svp) || SvGMAGICAL(*svp)) ? SvPV(*svp, nlen) : NULL; @@ -567,331 +567,331 @@ Perl_do_open6(pTHX_ GV *gv, const char *oname, STRLEN len, goto say_false; } - name = p ? savepvn(p, nlen) : savepvs(""); + name = p ? savepvn(p, nlen) : savepvs(""); - SAVEFREEPV(name); - } - else { - name = type; - len = tend-type; - } - IoTYPE(io) = *type; - if ((*type == IoTYPE_RDWR) && /* scary */ + SAVEFREEPV(name); + } + else { + name = type; + len = tend-type; + } + IoTYPE(io) = *type; + if ((*type == IoTYPE_RDWR) && /* scary */ (*(type+1) == IoTYPE_RDONLY || *(type+1) == IoTYPE_WRONLY) && - ((!num_svs || (tend > type+1 && tend[-1] != IoTYPE_PIPE)))) { - TAINT_PROPER("open"); - mode[1] = *type++; - writing = 1; - } - - if (*type == IoTYPE_PIPE) { - if (num_svs) { - if (type[1] != IoTYPE_STD) { - unknown_open_mode: - Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname); - } - type++; - } - do { - type++; - } while (isSPACE(*type)); - if (!num_svs) { - name = type; - len = tend-type; - } - if (*name == '\0') { - /* command is missing 19990114 */ - if (ckWARN(WARN_PIPE)) - Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open"); - errno = EPIPE; + ((!num_svs || (tend > type+1 && tend[-1] != IoTYPE_PIPE)))) { + TAINT_PROPER("open"); + mode[1] = *type++; + writing = 1; + } + + if (*type == IoTYPE_PIPE) { + if (num_svs) { + if (type[1] != IoTYPE_STD) { + unknown_open_mode: + Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname); + } + type++; + } + do { + type++; + } while (isSPACE(*type)); + if (!num_svs) { + name = type; + len = tend-type; + } + if (*name == '\0') { + /* command is missing 19990114 */ + if (ckWARN(WARN_PIPE)) + Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open"); + errno = EPIPE; fp = NULL; - goto say_false; - } - if (!(*name == '-' && name[1] == '\0') || num_svs) - TAINT_ENV(); - TAINT_PROPER("piped open"); - if (!num_svs && name[len-1] == '|') { - name[--len] = '\0' ; - if (ckWARN(WARN_PIPE)) - Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't open bidirectional pipe"); - } - mode[0] = 'w'; - writing = 1; + goto say_false; + } + if (!(*name == '-' && name[1] == '\0') || num_svs) + TAINT_ENV(); + TAINT_PROPER("piped open"); + if (!num_svs && name[len-1] == '|') { + name[--len] = '\0' ; + if (ckWARN(WARN_PIPE)) + Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't open bidirectional pipe"); + } + mode[0] = 'w'; + writing = 1; if (out_raw) - mode[1] = 'b'; + mode[1] = 'b'; else if (out_crlf) - mode[1] = 't'; - if (num_svs > 1) { - fp = PerlProc_popen_list(mode, num_svs, svp); - } - else { - fp = PerlProc_popen(name,mode); - } - if (num_svs) { - if (*type) { - if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) { + mode[1] = 't'; + if (num_svs > 1) { + fp = PerlProc_popen_list(mode, num_svs, svp); + } + else { + fp = PerlProc_popen(name,mode); + } + if (num_svs) { + if (*type) { + if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) { fp = NULL; - goto say_false; - } - } - } - } /* IoTYPE_PIPE */ - else if (*type == IoTYPE_WRONLY) { - TAINT_PROPER("open"); - type++; - if (*type == IoTYPE_WRONLY) { - /* Two IoTYPE_WRONLYs in a row make for an IoTYPE_APPEND. */ - mode[0] = IoTYPE(io) = IoTYPE_APPEND; - type++; - } - else { - mode[0] = 'w'; - } - writing = 1; + goto say_false; + } + } + } + } /* IoTYPE_PIPE */ + else if (*type == IoTYPE_WRONLY) { + TAINT_PROPER("open"); + type++; + if (*type == IoTYPE_WRONLY) { + /* Two IoTYPE_WRONLYs in a row make for an IoTYPE_APPEND. */ + mode[0] = IoTYPE(io) = IoTYPE_APPEND; + type++; + } + else { + mode[0] = 'w'; + } + writing = 1; if (out_raw) - mode[1] = 'b'; + mode[1] = 'b'; else if (out_crlf) - mode[1] = 't'; - if (*type == '&') { - duplicity: - dodup = PERLIO_DUP_FD; - type++; - if (*type == '=') { - dodup = 0; - type++; - } - if (!num_svs && !*type && supplied_fp) { - /* "<+&" etc. is used by typemaps */ - fp = supplied_fp; - } - else { - PerlIO *that_fp = NULL; + mode[1] = 't'; + if (*type == '&') { + duplicity: + dodup = PERLIO_DUP_FD; + type++; + if (*type == '=') { + dodup = 0; + type++; + } + if (!num_svs && !*type && supplied_fp) { + /* "<+&" etc. is used by typemaps */ + fp = supplied_fp; + } + else { + PerlIO *that_fp = NULL; int wanted_fd; UV uv; - if (num_svs > 1) { - /* diag_listed_as: More than one argument to '%s' open */ - Perl_croak(aTHX_ "More than one argument to '%c&' open",IoTYPE(io)); - } - while (isSPACE(*type)) - type++; - if (num_svs && ( - SvIOK(*svp) - || (SvPOKp(*svp) && looks_like_number(*svp)) - )) { + if (num_svs > 1) { + /* diag_listed_as: More than one argument to '%s' open */ + Perl_croak(aTHX_ "More than one argument to '%c&' open",IoTYPE(io)); + } + while (isSPACE(*type)) + type++; + if (num_svs && ( + SvIOK(*svp) + || (SvPOKp(*svp) && looks_like_number(*svp)) + )) { wanted_fd = SvUV(*svp); - num_svs = 0; - } - else if (isDIGIT(*type) + num_svs = 0; + } + else if (isDIGIT(*type) && grok_atoUV(type, &uv, NULL) && uv <= INT_MAX ) { wanted_fd = (int)uv; - } - else { - const IO* thatio; - if (num_svs) { - thatio = sv_2io(*svp); - } - else { - GV * const thatgv = gv_fetchpvn_flags(type, tend - type, - 0, SVt_PVIO); - thatio = GvIO(thatgv); - } - if (!thatio) { + } + else { + const IO* thatio; + if (num_svs) { + thatio = sv_2io(*svp); + } + else { + GV * const thatgv = gv_fetchpvn_flags(type, tend - type, + 0, SVt_PVIO); + thatio = GvIO(thatgv); + } + if (!thatio) { #ifdef EINVAL - SETERRNO(EINVAL,SS_IVCHAN); + SETERRNO(EINVAL,SS_IVCHAN); #endif fp = NULL; - goto say_false; - } - if ((that_fp = IoIFP(thatio))) { - /* Flush stdio buffer before dup. --mjd - * Unfortunately SEEK_CURing 0 seems to - * be optimized away on most platforms; - * only Solaris and Linux seem to flush - * on that. --jhi */ - /* On the other hand, do all platforms - * take gracefully to flushing a read-only - * filehandle? Perhaps we should do - * fsetpos(src)+fgetpos(dst)? --nik */ - PerlIO_flush(that_fp); - wanted_fd = PerlIO_fileno(that_fp); - /* When dup()ing STDIN, STDOUT or STDERR - * explicitly set appropriate access mode */ - if (that_fp == PerlIO_stdout() - || that_fp == PerlIO_stderr()) - IoTYPE(io) = IoTYPE_WRONLY; - else if (that_fp == PerlIO_stdin()) + goto say_false; + } + if ((that_fp = IoIFP(thatio))) { + /* Flush stdio buffer before dup. --mjd + * Unfortunately SEEK_CURing 0 seems to + * be optimized away on most platforms; + * only Solaris and Linux seem to flush + * on that. --jhi */ + /* On the other hand, do all platforms + * take gracefully to flushing a read-only + * filehandle? Perhaps we should do + * fsetpos(src)+fgetpos(dst)? --nik */ + PerlIO_flush(that_fp); + wanted_fd = PerlIO_fileno(that_fp); + /* When dup()ing STDIN, STDOUT or STDERR + * explicitly set appropriate access mode */ + if (that_fp == PerlIO_stdout() + || that_fp == PerlIO_stderr()) + IoTYPE(io) = IoTYPE_WRONLY; + else if (that_fp == PerlIO_stdin()) IoTYPE(io) = IoTYPE_RDONLY; - /* When dup()ing a socket, say result is - * one as well */ - else if (IoTYPE(thatio) == IoTYPE_SOCKET) - IoTYPE(io) = IoTYPE_SOCKET; - } + /* When dup()ing a socket, say result is + * one as well */ + else if (IoTYPE(thatio) == IoTYPE_SOCKET) + IoTYPE(io) = IoTYPE_SOCKET; + } else { SETERRNO(EBADF, RMS_IFI); fp = NULL; goto say_false; } - } - if (!num_svs) - type = NULL; - if (that_fp) { - fp = PerlIO_fdupopen(aTHX_ that_fp, NULL, dodup); - } - else { - if (dodup) + } + if (!num_svs) + type = NULL; + if (that_fp) { + fp = PerlIO_fdupopen(aTHX_ that_fp, NULL, dodup); + } + else { + if (dodup) wanted_fd = PerlLIO_dup_cloexec(wanted_fd); - else - was_fdopen = TRUE; + else + was_fdopen = TRUE; if (!(fp = PerlIO_openn(aTHX_ type,mode,wanted_fd,0,0,NULL,num_svs,svp))) { if (dodup && wanted_fd >= 0) PerlLIO_close(wanted_fd); - } - } - } - } /* & */ - else { - while (isSPACE(*type)) - type++; - if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) { - type++; - fp = PerlIO_stdout(); - IoTYPE(io) = IoTYPE_STD; - if (num_svs > 1) { - /* diag_listed_as: More than one argument to '%s' open */ - Perl_croak(aTHX_ "More than one argument to '>%c' open",IoTYPE_STD); - } - } - else { - if (num_svs) { + } + } + } + } /* & */ + else { + while (isSPACE(*type)) + type++; + if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) { + type++; + fp = PerlIO_stdout(); + IoTYPE(io) = IoTYPE_STD; + if (num_svs > 1) { + /* diag_listed_as: More than one argument to '%s' open */ + Perl_croak(aTHX_ "More than one argument to '>%c' open",IoTYPE_STD); + } + } + else { + if (num_svs) { fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); } else { SV *namesv = newSVpvn_flags(type, tend - type, SVs_TEMP); - type = NULL; + type = NULL; fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,1,&namesv); - } - } - } /* !& */ - if (!fp && type && *type && *type != ':' && !isIDFIRST(*type)) - goto unknown_open_mode; - } /* IoTYPE_WRONLY */ - else if (*type == IoTYPE_RDONLY) { - do { - type++; - } while (isSPACE(*type)); - mode[0] = 'r'; + } + } + } /* !& */ + if (!fp && type && *type && *type != ':' && !isIDFIRST(*type)) + goto unknown_open_mode; + } /* IoTYPE_WRONLY */ + else if (*type == IoTYPE_RDONLY) { + do { + type++; + } while (isSPACE(*type)); + mode[0] = 'r'; if (in_raw) - mode[1] = 'b'; + mode[1] = 'b'; else if (in_crlf) - mode[1] = 't'; - if (*type == '&') { - goto duplicity; - } - if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) { - type++; - fp = PerlIO_stdin(); - IoTYPE(io) = IoTYPE_STD; - if (num_svs > 1) { - /* diag_listed_as: More than one argument to '%s' open */ - Perl_croak(aTHX_ "More than one argument to '<%c' open",IoTYPE_STD); - } - } - else { - if (num_svs) { + mode[1] = 't'; + if (*type == '&') { + goto duplicity; + } + if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) { + type++; + fp = PerlIO_stdin(); + IoTYPE(io) = IoTYPE_STD; + if (num_svs > 1) { + /* diag_listed_as: More than one argument to '%s' open */ + Perl_croak(aTHX_ "More than one argument to '<%c' open",IoTYPE_STD); + } + } + else { + if (num_svs) { fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); } else { SV *namesv = newSVpvn_flags(type, tend - type, SVs_TEMP); - type = NULL; + type = NULL; fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,1,&namesv); - } - } - if (!fp && type && *type && *type != ':' && !isIDFIRST(*type)) - goto unknown_open_mode; - } /* IoTYPE_RDONLY */ - else if ((num_svs && /* '-|...' or '...|' */ - type[0] == IoTYPE_STD && type[1] == IoTYPE_PIPE) || - (!num_svs && tend > type+1 && tend[-1] == IoTYPE_PIPE)) { - if (num_svs) { - type += 2; /* skip over '-|' */ - } - else { - *--tend = '\0'; - while (tend > type && isSPACE(tend[-1])) - *--tend = '\0'; - for (; isSPACE(*type); type++) - ; - name = type; - len = tend-type; - } - if (*name == '\0') { - /* command is missing 19990114 */ - if (ckWARN(WARN_PIPE)) - Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open"); - errno = EPIPE; + } + } + if (!fp && type && *type && *type != ':' && !isIDFIRST(*type)) + goto unknown_open_mode; + } /* IoTYPE_RDONLY */ + else if ((num_svs && /* '-|...' or '...|' */ + type[0] == IoTYPE_STD && type[1] == IoTYPE_PIPE) || + (!num_svs && tend > type+1 && tend[-1] == IoTYPE_PIPE)) { + if (num_svs) { + type += 2; /* skip over '-|' */ + } + else { + *--tend = '\0'; + while (tend > type && isSPACE(tend[-1])) + *--tend = '\0'; + for (; isSPACE(*type); type++) + ; + name = type; + len = tend-type; + } + if (*name == '\0') { + /* command is missing 19990114 */ + if (ckWARN(WARN_PIPE)) + Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open"); + errno = EPIPE; fp = NULL; - goto say_false; - } - if (!(*name == '-' && name[1] == '\0') || num_svs) - TAINT_ENV(); - TAINT_PROPER("piped open"); - mode[0] = 'r'; + goto say_false; + } + if (!(*name == '-' && name[1] == '\0') || num_svs) + TAINT_ENV(); + TAINT_PROPER("piped open"); + mode[0] = 'r'; if (in_raw) - mode[1] = 'b'; + mode[1] = 'b'; else if (in_crlf) - mode[1] = 't'; - - if (num_svs > 1) { - fp = PerlProc_popen_list(mode,num_svs,svp); - } - else { - fp = PerlProc_popen(name,mode); - } - IoTYPE(io) = IoTYPE_PIPE; - if (num_svs) { - while (isSPACE(*type)) - type++; - if (*type) { - if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) { + mode[1] = 't'; + + if (num_svs > 1) { + fp = PerlProc_popen_list(mode,num_svs,svp); + } + else { + fp = PerlProc_popen(name,mode); + } + IoTYPE(io) = IoTYPE_PIPE; + if (num_svs) { + while (isSPACE(*type)) + type++; + if (*type) { + if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) { fp = NULL; - goto say_false; - } - } - } - } - else { /* layer(Args) */ - if (num_svs) - goto unknown_open_mode; - name = type; - IoTYPE(io) = IoTYPE_RDONLY; - for (; isSPACE(*name); name++) - ; - mode[0] = 'r'; + goto say_false; + } + } + } + } + else { /* layer(Args) */ + if (num_svs) + goto unknown_open_mode; + name = type; + IoTYPE(io) = IoTYPE_RDONLY; + for (; isSPACE(*name); name++) + ; + mode[0] = 'r'; if (in_raw) - mode[1] = 'b'; + mode[1] = 'b'; else if (in_crlf) - mode[1] = 't'; - - if (*name == '-' && name[1] == '\0') { - fp = PerlIO_stdin(); - IoTYPE(io) = IoTYPE_STD; - } - else { - if (num_svs) { + mode[1] = 't'; + + if (*name == '-' && name[1] == '\0') { + fp = PerlIO_stdin(); + IoTYPE(io) = IoTYPE_STD; + } + else { + if (num_svs) { fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); } else { - SV *namesv = newSVpvn_flags(type, tend - type, SVs_TEMP); - type = NULL; + SV *namesv = newSVpvn_flags(type, tend - type, SVs_TEMP); + type = NULL; fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,1,&namesv); - } - } - } + } + } + } } say_false: @@ -914,33 +914,33 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname, Zero(&statbuf, 1, Stat_t); if (!fp) { - if (IoTYPE(io) == IoTYPE_RDONLY && ckWARN(WARN_NEWLINE) - && should_warn_nl(oname) - - ) + if (IoTYPE(io) == IoTYPE_RDONLY && ckWARN(WARN_NEWLINE) + && should_warn_nl(oname) + + ) { GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* PL_warn_nl is constant */ - Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open"); + Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open"); GCC_DIAG_RESTORE_STMT; } - goto say_false; + goto say_false; } if (ckWARN(WARN_IO)) { - if ((IoTYPE(io) == IoTYPE_RDONLY) && - (fp == PerlIO_stdout() || fp == PerlIO_stderr())) { - Perl_warner(aTHX_ packWARN(WARN_IO), - "Filehandle STD%s reopened as %" HEKf - " only for input", - ((fp == PerlIO_stdout()) ? "OUT" : "ERR"), - HEKfARG(GvENAME_HEK(gv))); - } - else if ((IoTYPE(io) == IoTYPE_WRONLY) && fp == PerlIO_stdin()) { - Perl_warner(aTHX_ packWARN(WARN_IO), - "Filehandle STDIN reopened as %" HEKf " only for output", - HEKfARG(GvENAME_HEK(gv)) - ); - } + if ((IoTYPE(io) == IoTYPE_RDONLY) && + (fp == PerlIO_stdout() || fp == PerlIO_stderr())) { + Perl_warner(aTHX_ packWARN(WARN_IO), + "Filehandle STD%s reopened as %" HEKf + " only for input", + ((fp == PerlIO_stdout()) ? "OUT" : "ERR"), + HEKfARG(GvENAME_HEK(gv))); + } + else if ((IoTYPE(io) == IoTYPE_WRONLY) && fp == PerlIO_stdin()) { + Perl_warner(aTHX_ packWARN(WARN_IO), + "Filehandle STDIN reopened as %" HEKf " only for output", + HEKfARG(GvENAME_HEK(gv)) + ); + } } fd = PerlIO_fileno(fp); @@ -949,27 +949,27 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname, * otherwise unless we "know" the type probe for socket-ness. */ if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD && fd >= 0) { - if (PerlLIO_fstat(fd,&statbuf) < 0) { - /* If PerlIO claims to have fd we had better be able to fstat() it. */ - (void) PerlIO_close(fp); - goto say_false; - } + if (PerlLIO_fstat(fd,&statbuf) < 0) { + /* If PerlIO claims to have fd we had better be able to fstat() it. */ + (void) PerlIO_close(fp); + goto say_false; + } #ifndef PERL_MICRO - if (S_ISSOCK(statbuf.st_mode)) - IoTYPE(io) = IoTYPE_SOCKET; /* in case a socket was passed in to us */ + if (S_ISSOCK(statbuf.st_mode)) + IoTYPE(io) = IoTYPE_SOCKET; /* in case a socket was passed in to us */ #ifdef HAS_SOCKET - else if ( - !(statbuf.st_mode & S_IFMT) - && IoTYPE(io) != IoTYPE_WRONLY /* Dups of STD* filehandles already have */ - && IoTYPE(io) != IoTYPE_RDONLY /* type so they aren't marked as sockets */ - ) { /* on OS's that return 0 on fstat()ed pipe */ - char tmpbuf[256]; - Sock_size_t buflen = sizeof tmpbuf; - if (PerlSock_getsockname(fd, (struct sockaddr *)tmpbuf, &buflen) >= 0 - || errno != ENOTSOCK) - IoTYPE(io) = IoTYPE_SOCKET; /* some OS's return 0 on fstat()ed socket */ - /* but some return 0 for streams too, sigh */ - } + else if ( + !(statbuf.st_mode & S_IFMT) + && IoTYPE(io) != IoTYPE_WRONLY /* Dups of STD* filehandles already have */ + && IoTYPE(io) != IoTYPE_RDONLY /* type so they aren't marked as sockets */ + ) { /* on OS's that return 0 on fstat()ed pipe */ + char tmpbuf[256]; + Sock_size_t buflen = sizeof tmpbuf; + if (PerlSock_getsockname(fd, (struct sockaddr *)tmpbuf, &buflen) >= 0 + || errno != ENOTSOCK) + IoTYPE(io) = IoTYPE_SOCKET; /* some OS's return 0 on fstat()ed socket */ + /* but some return 0 for streams too, sigh */ + } #endif /* HAS_SOCKET */ #endif /* !PERL_MICRO */ } @@ -983,26 +983,26 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname, /* If fd is less that PL_maxsysfd i.e. STDIN..STDERR then dup the new fileno down */ - if (saveofp) { - PerlIO_flush(saveofp); /* emulate PerlIO_close() */ - if (saveofp != saveifp) { /* was a socket? */ - PerlIO_close(saveofp); - } - } - if (savefd != fd) { - /* Still a small can-of-worms here if (say) PerlIO::scalar - is assigned to (say) STDOUT - for now let dup2() fail - and provide the error - */ - if (fd < 0) { + if (saveofp) { + PerlIO_flush(saveofp); /* emulate PerlIO_close() */ + if (saveofp != saveifp) { /* was a socket? */ + PerlIO_close(saveofp); + } + } + if (savefd != fd) { + /* Still a small can-of-worms here if (say) PerlIO::scalar + is assigned to (say) STDOUT - for now let dup2() fail + and provide the error + */ + if (fd < 0) { SETERRNO(EBADF,RMS_IFI); - goto say_false; + goto say_false; } else if (PerlLIO_dup2(fd, savefd) < 0) { - (void)PerlIO_close(fp); - goto say_false; - } + (void)PerlIO_close(fp); + goto say_false; + } #ifdef VMS - if (savefd != PerlIO_fileno(PerlIO_stdin())) { + if (savefd != PerlIO_fileno(PerlIO_stdin())) { char newname[FILENAME_MAX+1]; if (PerlIO_getname(fp, newname)) { if (fd == PerlIO_fileno(PerlIO_stdout())) @@ -1010,7 +1010,7 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname, if (fd == PerlIO_fileno(PerlIO_stderr())) vmssetuserlnm("SYS$ERROR", newname); } - } + } #endif #if !defined(WIN32) @@ -1030,7 +1030,7 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname, } #endif - if (was_fdopen) { + if (was_fdopen) { /* need to close fp without closing underlying fd */ int ofd = PerlIO_fileno(fp); int dupfd = ofd >= 0 ? PerlLIO_dup_cloexec(ofd) : -1; @@ -1043,31 +1043,31 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname, PerlLIO_dup2_cloexec(dupfd, ofd); setfd_inhexec_for_sysfd(ofd); PerlLIO_close(dupfd); - } + } else - PerlIO_close(fp); - } - fp = saveifp; - PerlIO_clearerr(fp); - fd = PerlIO_fileno(fp); + PerlIO_close(fp); + } + fp = saveifp; + PerlIO_clearerr(fp); + fd = PerlIO_fileno(fp); } IoIFP(io) = fp; IoFLAGS(io) &= ~IOf_NOLINE; if (writing) { - if (IoTYPE(io) == IoTYPE_SOCKET - || (IoTYPE(io) == IoTYPE_WRONLY && fd >= 0 && S_ISCHR(statbuf.st_mode)) ) { - char *s = mode; - if (*s == IoTYPE_IMPLICIT || *s == IoTYPE_NUMERIC) - s++; - *s = 'w'; - if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,s,fd,0,0,NULL,0,NULL))) { - PerlIO_close(fp); - goto say_false; - } - } - else - IoOFP(io) = fp; + if (IoTYPE(io) == IoTYPE_SOCKET + || (IoTYPE(io) == IoTYPE_WRONLY && fd >= 0 && S_ISCHR(statbuf.st_mode)) ) { + char *s = mode; + if (*s == IoTYPE_IMPLICIT || *s == IoTYPE_NUMERIC) + s++; + *s = 'w'; + if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,s,fd,0,0,NULL,0,NULL))) { + PerlIO_close(fp); + goto say_false; + } + } + else + IoOFP(io) = fp; } if (statbufp) *statbufp = statbuf; @@ -1291,14 +1291,14 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen) SAVEFREESV(old_out_name); if (!PL_argvoutgv) - PL_argvoutgv = gv_fetchpvs("ARGVOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO); + PL_argvoutgv = gv_fetchpvs("ARGVOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO); if (io && (IoFLAGS(io) & (IOf_ARGV|IOf_START)) == (IOf_ARGV|IOf_START)) { - IoFLAGS(io) &= ~IOf_START; - if (PL_inplace) { - assert(PL_defoutgv); - Perl_av_create_and_push(aTHX_ &PL_argvout_stack, - SvREFCNT_inc_simple_NN(PL_defoutgv)); - } + IoFLAGS(io) &= ~IOf_START; + if (PL_inplace) { + assert(PL_defoutgv); + Perl_av_create_and_push(aTHX_ &PL_argvout_stack, + SvREFCNT_inc_simple_NN(PL_defoutgv)); + } } { @@ -1311,15 +1311,15 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen) PL_lastfd = -1; PL_filemode = 0; if (!GvAV(gv)) - return NULL; + return NULL; while (av_count(GvAV(gv)) > 0) { - STRLEN oldlen; + STRLEN oldlen; SV *const sv = av_shift(GvAV(gv)); - SAVEFREESV(sv); - SvTAINTED_off(GvSVn(gv)); /* previous tainting irrelevant */ - sv_setsv(GvSVn(gv),sv); - SvSETMAGIC(GvSV(gv)); - PL_oldname = SvPVx(GvSV(gv), oldlen); + SAVEFREESV(sv); + SvTAINTED_off(GvSVn(gv)); /* previous tainting irrelevant */ + sv_setsv(GvSVn(gv),sv); + SvSETMAGIC(GvSV(gv)); + PL_oldname = SvPVx(GvSV(gv), oldlen); if (LIKELY(!PL_inplace)) { if (nomagicopen ? do_open6(gv, "<", 1, NULL, &GvSV(gv), 1) @@ -1348,77 +1348,77 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen) SV *temp_name_sv = NULL; MAGIC *mg; - TAINT_PROPER("inplace open"); - if (oldlen == 1 && *PL_oldname == '-') { - setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, - SVt_PVIO)); - return IoIFP(GvIOp(gv)); - } + TAINT_PROPER("inplace open"); + if (oldlen == 1 && *PL_oldname == '-') { + setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, + SVt_PVIO)); + return IoIFP(GvIOp(gv)); + } #ifndef FLEXFILENAMES - filedev = statbuf.st_dev; - fileino = statbuf.st_ino; -#endif - PL_filemode = statbuf.st_mode; - fileuid = statbuf.st_uid; - filegid = statbuf.st_gid; - if (!S_ISREG(PL_filemode)) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), - "Can't do inplace edit: %s is not a regular file", - PL_oldname ); - do_close(gv,FALSE); - continue; - } + filedev = statbuf.st_dev; + fileino = statbuf.st_ino; +#endif + PL_filemode = statbuf.st_mode; + fileuid = statbuf.st_uid; + filegid = statbuf.st_gid; + if (!S_ISREG(PL_filemode)) { + Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), + "Can't do inplace edit: %s is not a regular file", + PL_oldname ); + do_close(gv,FALSE); + continue; + } magic_av = newAV(); - if (*PL_inplace && strNE(PL_inplace, "*")) { - const char *star = strchr(PL_inplace, '*'); - if (star) { - const char *begin = PL_inplace; + if (*PL_inplace && strNE(PL_inplace, "*")) { + const char *star = strchr(PL_inplace, '*'); + if (star) { + const char *begin = PL_inplace; SvPVCLEAR(sv); - do { - sv_catpvn(sv, begin, star - begin); - sv_catpvn(sv, PL_oldname, oldlen); - begin = ++star; - } while ((star = strchr(begin, '*'))); - if (*begin) - sv_catpv(sv,begin); - } - else { - sv_catpv(sv,PL_inplace); - } + do { + sv_catpvn(sv, begin, star - begin); + sv_catpvn(sv, PL_oldname, oldlen); + begin = ++star; + } while ((star = strchr(begin, '*'))); + if (*begin) + sv_catpv(sv,begin); + } + else { + sv_catpv(sv,PL_inplace); + } #ifndef FLEXFILENAMES - if ((PerlLIO_stat(SvPVX_const(sv),&statbuf) >= 0 - && statbuf.st_dev == filedev - && statbuf.st_ino == fileino) + if ((PerlLIO_stat(SvPVX_const(sv),&statbuf) >= 0 + && statbuf.st_dev == filedev + && statbuf.st_ino == fileino) #ifdef DJGPP - || ((_djstat_fail_bits & _STFAIL_TRUENAME)!=0) + || ((_djstat_fail_bits & _STFAIL_TRUENAME)!=0) #endif ) - { - Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), - "Can't do inplace edit: %" + { + Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), + "Can't do inplace edit: %" SVf " would not be unique", - SVfARG(sv)); + SVfARG(sv)); goto cleanup_argv; - } + } #endif av_store(magic_av, ARGVMG_BACKUP_NAME, newSVsv(sv)); - } + } - sv_setpvn(sv,PL_oldname,oldlen); - SETERRNO(0,0); /* in case sprintf set errno */ + sv_setpvn(sv,PL_oldname,oldlen); + SETERRNO(0,0); /* in case sprintf set errno */ temp_name_sv = newSV(0); if (!S_openindirtemp(aTHX_ PL_argvoutgv, GvSV(gv), temp_name_sv)) { SvREFCNT_dec(temp_name_sv); /* diag_listed_as: Can't do inplace edit on %s: %s */ Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), "Can't do inplace edit on %s: Cannot make temp name: %s", - PL_oldname, Strerror(errno) ); + PL_oldname, Strerror(errno) ); #ifndef FLEXFILENAMES cleanup_argv: #endif do_close(gv,FALSE); SvREFCNT_dec(magic_av); continue; - } + } av_store(magic_av, ARGVMG_TEMP_NAME, temp_name_sv); av_store(magic_av, ARGVMG_ORIG_NAME, newSVsv(sv)); av_store(magic_av, ARGVMG_ORIG_MODE, newSVuv(PL_filemode)); @@ -1432,12 +1432,12 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen) newSVpvn((char *)&statbuf, sizeof(statbuf))); } #endif - setdefout(PL_argvoutgv); + setdefout(PL_argvoutgv); sv_setsv(GvSVn(PL_argvoutgv), temp_name_sv); mg = sv_magicext((SV*)GvIOp(PL_argvoutgv), (SV*)magic_av, PERL_MAGIC_uvar, &argvout_vtbl, NULL, 0); mg->mg_flags |= MGf_DUP; SvREFCNT_dec(magic_av); - PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv))); + PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv))); if (PL_lastfd >= 0) { (void)PerlLIO_fstat(PL_lastfd,&statbuf); #ifdef HAS_FCHMOD @@ -1453,10 +1453,10 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen) PERL_UNUSED_RESULT(PerlLIO_chown(PL_oldname,fileuid,filegid)); #endif } - } + } return IoIFP(GvIOp(gv)); - } - } /* successful do_open_raw(), PL_inplace non-NULL */ + } + } /* successful do_open_raw(), PL_inplace non-NULL */ if (ckWARN_d(WARN_INPLACE)) { const int eno = errno; @@ -1471,20 +1471,20 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen) Perl_warner(aTHX_ packWARN(WARN_INPLACE), "Can't open %s: %s", PL_oldname, Strerror(eno)); } - } + } } if (io && (IoFLAGS(io) & IOf_ARGV)) - IoFLAGS(io) |= IOf_START; + IoFLAGS(io) |= IOf_START; if (PL_inplace) { - if (io && (IoFLAGS(io) & IOf_ARGV) - && PL_argvout_stack && AvFILLp(PL_argvout_stack) >= 0) - { - GV * const oldout = MUTABLE_GV(av_pop(PL_argvout_stack)); - setdefout(oldout); - SvREFCNT_dec_NN(oldout); - return NULL; - } - setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO)); + if (io && (IoFLAGS(io) & IOf_ARGV) + && PL_argvout_stack && AvFILLp(PL_argvout_stack) >= 0) + { + GV * const oldout = MUTABLE_GV(av_pop(PL_argvout_stack)); + setdefout(oldout); + SvREFCNT_dec_NN(oldout); + return NULL; + } + setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO)); } return NULL; } @@ -1687,7 +1687,7 @@ S_argvout_final(pTHX_ MAGIC *mg, IO *io, bool not_implicit) { #if !defined(HAS_RENAME) link(SvPVX(*temp_psv), orig_pv) < 0 #elif defined(ARGV_USE_ATFUNCTIONS) - S_my_renameat(dfd, SvPVX(*temp_psv), dfd, orig_pv) < 0 && + S_my_renameat(dfd, SvPVX(*temp_psv), dfd, orig_pv) < 0 && !(UNLIKELY(NotSupported(errno)) && dir_unchanged(orig_pv, mg) && PerlLIO_rename(SvPVX(*temp_psv), orig_pv) == 0) @@ -1744,19 +1744,19 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit) MAGIC *mg; if (!gv) - gv = PL_argvgv; + gv = PL_argvgv; if (!gv || !isGV_with_GP(gv)) { - if (not_implicit) - SETERRNO(EBADF,SS_IVCHAN); - return FALSE; + if (not_implicit) + SETERRNO(EBADF,SS_IVCHAN); + return FALSE; } io = GvIO(gv); if (!io) { /* never opened */ - if (not_implicit) { - report_evil_fh(gv); - SETERRNO(EBADF,SS_IVCHAN); - } - return FALSE; + if (not_implicit) { + report_evil_fh(gv); + SETERRNO(EBADF,SS_IVCHAN); + } + return FALSE; } if ((mg = mg_findext((SV*)io, PERL_MAGIC_uvar, &argvout_vtbl)) && mg->mg_obj) { @@ -1767,9 +1767,9 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit) retval = io_close(io, NULL, not_implicit, FALSE); } if (not_implicit) { - IoLINES(io) = 0; - IoPAGE(io) = 0; - IoLINES_LEFT(io) = IoPAGE_LEN(io); + IoLINES(io) = 0; + IoPAGE(io) = 0; + IoLINES_LEFT(io) = IoPAGE_LEN(io); } IoTYPE(io) = IoTYPE_CLOSED; return retval; @@ -1783,7 +1783,7 @@ Perl_io_close(pTHX_ IO *io, GV *gv, bool not_implicit, bool warn_on_fail) PERL_ARGS_ASSERT_IO_CLOSE; if (IoIFP(io)) { - if (IoTYPE(io) == IoTYPE_PIPE) { + if (IoTYPE(io) == IoTYPE_PIPE) { PerlIO *fh = IoIFP(io); int status; @@ -1794,54 +1794,54 @@ Perl_io_close(pTHX_ IO *io, GV *gv, bool not_implicit, bool warn_on_fail) So NULL it early. */ IoOFP(io) = IoIFP(io) = NULL; - status = PerlProc_pclose(fh); - if (not_implicit) { - STATUS_NATIVE_CHILD_SET(status); - retval = (STATUS_UNIX == 0); - } - else { - retval = (status != -1); - } - } - else if (IoTYPE(io) == IoTYPE_STD) - retval = TRUE; - else { - if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */ - const bool prev_err = PerlIO_error(IoOFP(io)); + status = PerlProc_pclose(fh); + if (not_implicit) { + STATUS_NATIVE_CHILD_SET(status); + retval = (STATUS_UNIX == 0); + } + else { + retval = (status != -1); + } + } + else if (IoTYPE(io) == IoTYPE_STD) + retval = TRUE; + else { + if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */ + const bool prev_err = PerlIO_error(IoOFP(io)); #ifdef USE_PERLIO - if (prev_err) - PerlIO_restore_errno(IoOFP(io)); -#endif - retval = (PerlIO_close(IoOFP(io)) != EOF && !prev_err); - PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */ - } - else { - const bool prev_err = PerlIO_error(IoIFP(io)); + if (prev_err) + PerlIO_restore_errno(IoOFP(io)); +#endif + retval = (PerlIO_close(IoOFP(io)) != EOF && !prev_err); + PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */ + } + else { + const bool prev_err = PerlIO_error(IoIFP(io)); #ifdef USE_PERLIO - if (prev_err) - PerlIO_restore_errno(IoIFP(io)); -#endif - retval = (PerlIO_close(IoIFP(io)) != EOF && !prev_err); - } - } - IoOFP(io) = IoIFP(io) = NULL; - - if (warn_on_fail && !retval) { - if (gv) - Perl_ck_warner_d(aTHX_ packWARN(WARN_IO), - "Warning: unable to close filehandle %" - HEKf " properly: %" SVf, - HEKfARG(GvNAME_HEK(gv)), + if (prev_err) + PerlIO_restore_errno(IoIFP(io)); +#endif + retval = (PerlIO_close(IoIFP(io)) != EOF && !prev_err); + } + } + IoOFP(io) = IoIFP(io) = NULL; + + if (warn_on_fail && !retval) { + if (gv) + Perl_ck_warner_d(aTHX_ packWARN(WARN_IO), + "Warning: unable to close filehandle %" + HEKf " properly: %" SVf, + HEKfARG(GvNAME_HEK(gv)), + SVfARG(get_sv("!",GV_ADD))); + else + Perl_ck_warner_d(aTHX_ packWARN(WARN_IO), + "Warning: unable to close filehandle " + "properly: %" SVf, SVfARG(get_sv("!",GV_ADD))); - else - Perl_ck_warner_d(aTHX_ packWARN(WARN_IO), - "Warning: unable to close filehandle " - "properly: %" SVf, - SVfARG(get_sv("!",GV_ADD))); - } + } } else if (not_implicit) { - SETERRNO(EBADF,SS_IVCHAN); + SETERRNO(EBADF,SS_IVCHAN); } return retval; @@ -1855,38 +1855,38 @@ Perl_do_eof(pTHX_ GV *gv) PERL_ARGS_ASSERT_DO_EOF; if (!io) - return TRUE; + return TRUE; else if (IoTYPE(io) == IoTYPE_WRONLY) - report_wrongway_fh(gv, '>'); + report_wrongway_fh(gv, '>'); while (IoIFP(io)) { if (PerlIO_has_cntptr(IoIFP(io))) { /* (the code works without this) */ - if (PerlIO_get_cnt(IoIFP(io)) > 0) /* cheat a little, since */ - return FALSE; /* this is the most usual case */ - } - - { - /* getc and ungetc can stomp on errno */ - dSAVE_ERRNO; - const int ch = PerlIO_getc(IoIFP(io)); - if (ch != EOF) { - (void)PerlIO_ungetc(IoIFP(io),ch); - RESTORE_ERRNO; - return FALSE; - } - RESTORE_ERRNO; - } + if (PerlIO_get_cnt(IoIFP(io)) > 0) /* cheat a little, since */ + return FALSE; /* this is the most usual case */ + } + + { + /* getc and ungetc can stomp on errno */ + dSAVE_ERRNO; + const int ch = PerlIO_getc(IoIFP(io)); + if (ch != EOF) { + (void)PerlIO_ungetc(IoIFP(io),ch); + RESTORE_ERRNO; + return FALSE; + } + RESTORE_ERRNO; + } if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) { - if (PerlIO_get_cnt(IoIFP(io)) < -1) - PerlIO_set_cnt(IoIFP(io),-1); - } - if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */ - if (gv != PL_argvgv || !nextargv(gv, FALSE)) /* get another fp handy */ - return TRUE; - } - else - return TRUE; /* normal fp, definitely end of file */ + if (PerlIO_get_cnt(IoIFP(io)) < -1) + PerlIO_set_cnt(IoIFP(io),-1); + } + if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */ + if (gv != PL_argvgv || !nextargv(gv, FALSE)) /* get another fp handy */ + return TRUE; + } + else + return TRUE; /* normal fp, definitely end of file */ } return TRUE; } @@ -1900,7 +1900,7 @@ Perl_do_tell(pTHX_ GV *gv) PERL_ARGS_ASSERT_DO_TELL; if (io && (fp = IoIFP(io))) { - return PerlIO_tell(fp); + return PerlIO_tell(fp); } report_evil_fh(gv); SETERRNO(EBADF,RMS_IFI); @@ -1914,7 +1914,7 @@ Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence) PerlIO *fp; if (io && (fp = IoIFP(io))) { - return PerlIO_seek(fp, pos, whence) >= 0; + return PerlIO_seek(fp, pos, whence) >= 0; } report_evil_fh(gv); SETERRNO(EBADF,RMS_IFI); @@ -1949,51 +1949,51 @@ Perl_mode_from_discipline(pTHX_ const char *s, STRLEN len) int mode = O_BINARY; PERL_UNUSED_CONTEXT; if (s) { - while (*s) { - if (*s == ':') { - switch (s[1]) { - case 'r': - if (s[2] == 'a' && s[3] == 'w' - && (!s[4] || s[4] == ':' || isSPACE(s[4]))) - { - mode = O_BINARY; - s += 4; - len -= 4; - break; - } - /* FALLTHROUGH */ - case 'c': - if (s[2] == 'r' && s[3] == 'l' && s[4] == 'f' - && (!s[5] || s[5] == ':' || isSPACE(s[5]))) - { - mode = O_TEXT; - s += 5; - len -= 5; - break; - } - /* FALLTHROUGH */ - default: - goto fail_discipline; - } - } - else if (isSPACE(*s)) { - ++s; - --len; - } - else { - const char *end; + while (*s) { + if (*s == ':') { + switch (s[1]) { + case 'r': + if (s[2] == 'a' && s[3] == 'w' + && (!s[4] || s[4] == ':' || isSPACE(s[4]))) + { + mode = O_BINARY; + s += 4; + len -= 4; + break; + } + /* FALLTHROUGH */ + case 'c': + if (s[2] == 'r' && s[3] == 'l' && s[4] == 'f' + && (!s[5] || s[5] == ':' || isSPACE(s[5]))) + { + mode = O_TEXT; + s += 5; + len -= 5; + break; + } + /* FALLTHROUGH */ + default: + goto fail_discipline; + } + } + else if (isSPACE(*s)) { + ++s; + --len; + } + else { + const char *end; fail_discipline: - end = (char *) memchr(s+1, ':', len); - if (!end) - end = s+len; + end = (char *) memchr(s+1, ':', len); + if (!end) + end = s+len; #ifndef PERLIO_LAYERS - Perl_croak(aTHX_ "IO layers (like '%.*s') unavailable", end-s, s); + Perl_croak(aTHX_ "IO layers (like '%.*s') unavailable", end-s, s); #else - len -= end-s; - s = end; + len -= end-s; + s = end; #endif - } - } + } + } } return mode; } @@ -2003,44 +2003,44 @@ I32 my_chsize(int fd, Off_t length) { #ifdef F_FREESP - /* code courtesy of William Kucharski */ + /* code courtesy of William Kucharski */ #define HAS_CHSIZE Stat_t filebuf; if (PerlLIO_fstat(fd, &filebuf) < 0) - return -1; + return -1; if (filebuf.st_size < length) { - /* extend file length */ + /* extend file length */ - if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0) - return -1; + if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0) + return -1; - /* write a "0" byte */ + /* write a "0" byte */ - if ((PerlLIO_write(fd, "", 1)) != 1) - return -1; + if ((PerlLIO_write(fd, "", 1)) != 1) + return -1; } else { - /* truncate length */ - struct flock fl; - fl.l_whence = 0; - fl.l_len = 0; - fl.l_start = length; - fl.l_type = F_WRLCK; /* write lock on file space */ - - /* - * This relies on the UNDOCUMENTED F_FREESP argument to - * fcntl(2), which truncates the file so that it ends at the - * position indicated by fl.l_start. - * - * Will minor miracles never cease? - */ - - if (fcntl(fd, F_FREESP, &fl) < 0) - return -1; + /* truncate length */ + struct flock fl; + fl.l_whence = 0; + fl.l_len = 0; + fl.l_start = length; + fl.l_type = F_WRLCK; /* write lock on file space */ + + /* + * This relies on the UNDOCUMENTED F_FREESP argument to + * fcntl(2), which truncates the file so that it ends at the + * position indicated by fl.l_start. + * + * Will minor miracles never cease? + */ + + if (fcntl(fd, F_FREESP, &fl) < 0) + return -1; } return 0; @@ -2058,67 +2058,67 @@ Perl_do_print(pTHX_ SV *sv, PerlIO *fp) /* assuming fp is checked earlier */ if (!sv) - return TRUE; + return TRUE; if (SvTYPE(sv) == SVt_IV && SvIOK(sv)) { - assert(!SvGMAGICAL(sv)); - if (SvIsUV(sv)) - PerlIO_printf(fp, "%" UVuf, (UV)SvUVX(sv)); - else - PerlIO_printf(fp, "%" IVdf, (IV)SvIVX(sv)); - return !PerlIO_error(fp); + assert(!SvGMAGICAL(sv)); + if (SvIsUV(sv)) + PerlIO_printf(fp, "%" UVuf, (UV)SvUVX(sv)); + else + PerlIO_printf(fp, "%" IVdf, (IV)SvIVX(sv)); + return !PerlIO_error(fp); } else { - STRLEN len; - /* Do this first to trigger any overloading. */ - const char *tmps = SvPV_const(sv, len); - U8 *tmpbuf = NULL; - bool happy = TRUE; - - if (PerlIO_isutf8(fp)) { /* If the stream is utf8 ... */ - if (!SvUTF8(sv)) { /* Convert to utf8 if necessary */ - /* We don't modify the original scalar. */ - tmpbuf = bytes_to_utf8((const U8*) tmps, &len); - tmps = (char *) tmpbuf; - } - else if (ckWARN4_d(WARN_UTF8, WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR)) { - (void) check_utf8_print((const U8*) tmps, len); - } - } /* else stream isn't utf8 */ - else if (DO_UTF8(sv)) { /* But if is utf8 internally, attempt to - convert to bytes */ - STRLEN tmplen = len; - bool utf8 = TRUE; - U8 * const result = bytes_from_utf8((const U8*) tmps, &tmplen, &utf8); - if (!utf8) { - - /* Here, succeeded in downgrading from utf8. Set up to below - * output the converted value */ - tmpbuf = result; - tmps = (char *) tmpbuf; - len = tmplen; - } - else { /* Non-utf8 output stream, but string only representable in - utf8 */ - assert((char *)result == tmps); - Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), - "Wide character in %s", - PL_op ? OP_DESC(PL_op) : "print" - ); - /* Could also check that isn't one of the things to avoid - * in utf8 by using check_utf8_print(), but not doing so, - * since the stream isn't a UTF8 stream */ - } - } - /* To detect whether the process is about to overstep its - * filesize limit we would need getrlimit(). We could then - * also transparently raise the limit with setrlimit() -- - * but only until the system hard limit/the filesystem limit, - * at which we would get EPERM. Note that when using buffered - * io the write failure can be delayed until the flush/close. --jhi */ - if (len && (PerlIO_write(fp,tmps,len) == 0)) - happy = FALSE; - Safefree(tmpbuf); - return happy ? !PerlIO_error(fp) : FALSE; + STRLEN len; + /* Do this first to trigger any overloading. */ + const char *tmps = SvPV_const(sv, len); + U8 *tmpbuf = NULL; + bool happy = TRUE; + + if (PerlIO_isutf8(fp)) { /* If the stream is utf8 ... */ + if (!SvUTF8(sv)) { /* Convert to utf8 if necessary */ + /* We don't modify the original scalar. */ + tmpbuf = bytes_to_utf8((const U8*) tmps, &len); + tmps = (char *) tmpbuf; + } + else if (ckWARN4_d(WARN_UTF8, WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR)) { + (void) check_utf8_print((const U8*) tmps, len); + } + } /* else stream isn't utf8 */ + else if (DO_UTF8(sv)) { /* But if is utf8 internally, attempt to + convert to bytes */ + STRLEN tmplen = len; + bool utf8 = TRUE; + U8 * const result = bytes_from_utf8((const U8*) tmps, &tmplen, &utf8); + if (!utf8) { + + /* Here, succeeded in downgrading from utf8. Set up to below + * output the converted value */ + tmpbuf = result; + tmps = (char *) tmpbuf; + len = tmplen; + } + else { /* Non-utf8 output stream, but string only representable in + utf8 */ + assert((char *)result == tmps); + Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), + "Wide character in %s", + PL_op ? OP_DESC(PL_op) : "print" + ); + /* Could also check that isn't one of the things to avoid + * in utf8 by using check_utf8_print(), but not doing so, + * since the stream isn't a UTF8 stream */ + } + } + /* To detect whether the process is about to overstep its + * filesize limit we would need getrlimit(). We could then + * also transparently raise the limit with setrlimit() -- + * but only until the system hard limit/the filesystem limit, + * at which we would get EPERM. Note that when using buffered + * io the write failure can be delayed until the flush/close. --jhi */ + if (len && (PerlIO_write(fp,tmps,len) == 0)) + happy = FALSE; + Safefree(tmpbuf); + return happy ? !PerlIO_error(fp) : FALSE; } } @@ -2130,24 +2130,24 @@ Perl_my_stat_flags(pTHX_ const U32 flags) GV* gv; if (PL_op->op_flags & OPf_REF) { - gv = cGVOP_gv; + gv = cGVOP_gv; do_fstat: if (gv == PL_defgv) { - if (PL_laststatval < 0) - SETERRNO(EBADF,RMS_IFI); + if (PL_laststatval < 0) + SETERRNO(EBADF,RMS_IFI); return PL_laststatval; - } - io = GvIO(gv); + } + io = GvIO(gv); do_fstat_have_io: PL_laststype = OP_STAT; PL_statgv = gv ? gv : (GV *)io; SvPVCLEAR(PL_statname); if (io) { - if (IoIFP(io)) { + if (IoIFP(io)) { int fd = PerlIO_fileno(IoIFP(io)); if (fd < 0) { /* E.g. PerlIO::scalar has no real fd. */ - SETERRNO(EBADF,RMS_IFI); + SETERRNO(EBADF,RMS_IFI); return (PL_laststatval = -1); } else { return (PL_laststatval = PerlLIO_fstat(fd, &PL_statcache)); @@ -2156,44 +2156,44 @@ Perl_my_stat_flags(pTHX_ const U32 flags) return (PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache)); } } - PL_laststatval = -1; - report_evil_fh(gv); - SETERRNO(EBADF,RMS_IFI); - return -1; + PL_laststatval = -1; + report_evil_fh(gv); + SETERRNO(EBADF,RMS_IFI); + return -1; } else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t)) - == OPpFT_STACKED) - return PL_laststatval; + == OPpFT_STACKED) + return PL_laststatval; else { - SV* const sv = TOPs; - const char *s, *d; - STRLEN len; - if ((gv = MAYBE_DEREF_GV_flags(sv,flags))) { - goto do_fstat; - } + SV* const sv = TOPs; + const char *s, *d; + STRLEN len; + if ((gv = MAYBE_DEREF_GV_flags(sv,flags))) { + goto do_fstat; + } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { io = MUTABLE_IO(SvRV(sv)); - gv = NULL; + gv = NULL; goto do_fstat_have_io; } - s = SvPV_flags_const(sv, len, flags); - PL_statgv = NULL; - sv_setpvn(PL_statname, s, len); - d = SvPVX_const(PL_statname); /* s now NUL-terminated */ - PL_laststype = OP_STAT; + s = SvPV_flags_const(sv, len, flags); + PL_statgv = NULL; + sv_setpvn(PL_statname, s, len); + d = SvPVX_const(PL_statname); /* s now NUL-terminated */ + PL_laststype = OP_STAT; if (!IS_SAFE_PATHNAME(s, len, OP_NAME(PL_op))) { PL_laststatval = -1; } else { PL_laststatval = PerlLIO_stat(d, &PL_statcache); } - if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(s)) { + if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(s)) { GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* PL_warn_nl is constant */ - Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat"); + Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat"); GCC_DIAG_RESTORE_STMT; } - return PL_laststatval; + return PL_laststatval; } } @@ -2208,27 +2208,27 @@ Perl_my_lstat_flags(pTHX_ const U32 flags) SV* const sv = TOPs; bool isio = FALSE; if (PL_op->op_flags & OPf_REF) { - if (cGVOP_gv == PL_defgv) { - if (PL_laststype != OP_LSTAT) - Perl_croak(aTHX_ "%s", no_prev_lstat); - if (PL_laststatval < 0) - SETERRNO(EBADF,RMS_IFI); - return PL_laststatval; - } - PL_laststatval = -1; - if (ckWARN(WARN_IO)) { - /* diag_listed_as: Use of -l on filehandle%s */ - Perl_warner(aTHX_ packWARN(WARN_IO), - "Use of -l on filehandle %" HEKf, - HEKfARG(GvENAME_HEK(cGVOP_gv))); - } - SETERRNO(EBADF,RMS_IFI); - return -1; + if (cGVOP_gv == PL_defgv) { + if (PL_laststype != OP_LSTAT) + Perl_croak(aTHX_ "%s", no_prev_lstat); + if (PL_laststatval < 0) + SETERRNO(EBADF,RMS_IFI); + return PL_laststatval; + } + PL_laststatval = -1; + if (ckWARN(WARN_IO)) { + /* diag_listed_as: Use of -l on filehandle%s */ + Perl_warner(aTHX_ packWARN(WARN_IO), + "Use of -l on filehandle %" HEKf, + HEKfARG(GvENAME_HEK(cGVOP_gv))); + } + SETERRNO(EBADF,RMS_IFI); + return -1; } if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t)) - == OPpFT_STACKED) { + == OPpFT_STACKED) { if (PL_laststype != OP_LSTAT) - Perl_croak(aTHX_ "%s", no_prev_lstat); + Perl_croak(aTHX_ "%s", no_prev_lstat); return PL_laststatval; } @@ -2241,11 +2241,11 @@ Perl_my_lstat_flags(pTHX_ const U32 flags) ) && ckWARN(WARN_IO)) { if (isio) - /* diag_listed_as: Use of -l on filehandle%s */ + /* diag_listed_as: Use of -l on filehandle%s */ Perl_warner(aTHX_ packWARN(WARN_IO), "Use of -l on filehandle"); else - /* diag_listed_as: Use of -l on filehandle%s */ + /* diag_listed_as: Use of -l on filehandle%s */ Perl_warner(aTHX_ packWARN(WARN_IO), "Use of -l on filehandle %" HEKf, HEKfARG(GvENAME_HEK((const GV *) @@ -2279,13 +2279,13 @@ S_exec_failed(pTHX_ const char *cmd, int fd, int do_report) if (do_report) { /* XXX silently ignore failures */ PERL_UNUSED_RESULT(PerlLIO_write(fd, (void*)&e, sizeof(int))); - PerlLIO_close(fd); + PerlLIO_close(fd); } } bool Perl_do_aexec5(pTHX_ SV *really, SV **mark, SV **sp, - int fd, int do_report) + int fd, int do_report) { PERL_ARGS_ASSERT_DO_AEXEC5; #if defined(__LIBCATAMOUNT__) @@ -2294,37 +2294,37 @@ Perl_do_aexec5(pTHX_ SV *really, SV **mark, SV **sp, assert(sp >= mark); ENTER; { - const char **argv, **a; - const char *tmps = NULL; - Newx(argv, sp - mark + 1, const char*); - SAVEFREEPV(argv); - a = argv; - - while (++mark <= sp) { - if (*mark) { - char *arg = savepv(SvPV_nolen_const(*mark)); - SAVEFREEPV(arg); - *a++ = arg; - } else - *a++ = ""; - } - *a = NULL; - if (really) { - tmps = savepv(SvPV_nolen_const(really)); - SAVEFREEPV(tmps); - } + const char **argv, **a; + const char *tmps = NULL; + Newx(argv, sp - mark + 1, const char*); + SAVEFREEPV(argv); + a = argv; + + while (++mark <= sp) { + if (*mark) { + char *arg = savepv(SvPV_nolen_const(*mark)); + SAVEFREEPV(arg); + *a++ = arg; + } else + *a++ = ""; + } + *a = NULL; + if (really) { + tmps = savepv(SvPV_nolen_const(really)); + SAVEFREEPV(tmps); + } if ((!really && argv[0] && *argv[0] != '/') || - (really && *tmps != '/')) /* will execvp use PATH? */ - TAINT_ENV(); /* testing IFS here is overkill, probably */ - PERL_FPU_PRE_EXEC - if (really && *tmps) { + (really && *tmps != '/')) /* will execvp use PATH? */ + TAINT_ENV(); /* testing IFS here is overkill, probably */ + PERL_FPU_PRE_EXEC + if (really && *tmps) { PerlProc_execvp(tmps,EXEC_ARGV_CAST(argv)); } else if (argv[0]) { PerlProc_execvp(argv[0],EXEC_ARGV_CAST(argv)); } else { SETERRNO(ENOENT,RMS_FNF); } - PERL_FPU_POST_EXEC + PERL_FPU_POST_EXEC S_exec_failed(aTHX_ (really ? tmps : argv[0] ? argv[0] : ""), fd, do_report); } LEAVE; @@ -2353,86 +2353,86 @@ Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report) memcpy(cmd, incmd, cmdlen); while (*cmd && isSPACE(*cmd)) - cmd++; + cmd++; /* save an extra exec if possible */ #ifdef CSH { char flags[PERL_FLAGS_MAX]; - if (strnEQ(cmd,PL_cshname,PL_cshlen) && - strBEGINs(cmd+PL_cshlen," -c")) { + if (strnEQ(cmd,PL_cshname,PL_cshlen) && + strBEGINs(cmd+PL_cshlen," -c")) { my_strlcpy(flags, "-c", PERL_FLAGS_MAX); - s = cmd+PL_cshlen+3; - if (*s == 'f') { - s++; + s = cmd+PL_cshlen+3; + if (*s == 'f') { + s++; my_strlcat(flags, "f", PERL_FLAGS_MAX - 2); - } - if (*s == ' ') - s++; - if (*s++ == '\'') { - char * const ncmd = s; - - while (*s) - s++; - if (s[-1] == '\n') - *--s = '\0'; - if (s[-1] == '\'') { - *--s = '\0'; - PERL_FPU_PRE_EXEC - PerlProc_execl(PL_cshname, "csh", flags, ncmd, (char*)NULL); - PERL_FPU_POST_EXEC - *s = '\''; - S_exec_failed(aTHX_ PL_cshname, fd, do_report); - goto leave; - } - } - } + } + if (*s == ' ') + s++; + if (*s++ == '\'') { + char * const ncmd = s; + + while (*s) + s++; + if (s[-1] == '\n') + *--s = '\0'; + if (s[-1] == '\'') { + *--s = '\0'; + PERL_FPU_PRE_EXEC + PerlProc_execl(PL_cshname, "csh", flags, ncmd, (char*)NULL); + PERL_FPU_POST_EXEC + *s = '\''; + S_exec_failed(aTHX_ PL_cshname, fd, do_report); + goto leave; + } + } + } } #endif /* CSH */ /* see if there are shell metacharacters in it */ if (*cmd == '.' && isSPACE(cmd[1])) - goto doshell; + goto doshell; if (strBEGINs(cmd,"exec") && isSPACE(cmd[4])) - goto doshell; + goto doshell; s = cmd; while (isWORDCHAR(*s)) - s++; /* catch VAR=val gizmo */ + s++; /* catch VAR=val gizmo */ if (*s == '=') - goto doshell; + goto doshell; for (s = cmd; *s; s++) { - if (*s != ' ' && !isALPHA(*s) && - memCHRs("$&*(){}[]'\";\\|?<>~`\n",*s)) { - if (*s == '\n' && !s[1]) { - *s = '\0'; - break; - } - /* handle the 2>&1 construct at the end */ - if (*s == '>' && s[1] == '&' && s[2] == '1' - && s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2]) - && (!s[3] || isSPACE(s[3]))) - { + if (*s != ' ' && !isALPHA(*s) && + memCHRs("$&*(){}[]'\";\\|?<>~`\n",*s)) { + if (*s == '\n' && !s[1]) { + *s = '\0'; + break; + } + /* handle the 2>&1 construct at the end */ + if (*s == '>' && s[1] == '&' && s[2] == '1' + && s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2]) + && (!s[3] || isSPACE(s[3]))) + { const char *t = s + 3; - while (*t && isSPACE(*t)) - ++t; - if (!*t && (PerlLIO_dup2(1,2) != -1)) { - s[-2] = '\0'; - break; - } - } - doshell: - PERL_FPU_PRE_EXEC + while (*t && isSPACE(*t)) + ++t; + if (!*t && (PerlLIO_dup2(1,2) != -1)) { + s[-2] = '\0'; + break; + } + } + doshell: + PERL_FPU_PRE_EXEC PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char *)NULL); - PERL_FPU_POST_EXEC - S_exec_failed(aTHX_ PL_sh_path, fd, do_report); - goto leave; - } + PERL_FPU_POST_EXEC + S_exec_failed(aTHX_ PL_sh_path, fd, do_report); + goto leave; + } } Newx(argv, (s - cmd) / 2 + 2, const char*); @@ -2441,23 +2441,23 @@ Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report) SAVEFREEPV(cmd); a = argv; for (s = cmd; *s;) { - while (isSPACE(*s)) - s++; - if (*s) - *(a++) = s; - while (*s && !isSPACE(*s)) - s++; - if (*s) - *s++ = '\0'; + while (isSPACE(*s)) + s++; + if (*s) + *(a++) = s; + while (*s && !isSPACE(*s)) + s++; + if (*s) + *s++ = '\0'; } *a = NULL; if (argv[0]) { - PERL_FPU_PRE_EXEC + PERL_FPU_PRE_EXEC PerlProc_execvp(argv[0],EXEC_ARGV_CAST(argv)); - PERL_FPU_POST_EXEC - if (errno == ENOEXEC) /* for system V NIH syndrome */ - goto doshell; - S_exec_failed(aTHX_ argv[0], fd, do_report); + PERL_FPU_POST_EXEC + if (errno == ENOEXEC) /* for system V NIH syndrome */ + goto doshell; + S_exec_failed(aTHX_ argv[0], fd, do_report); } leave: LEAVE; @@ -2486,109 +2486,109 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp) platforms where kill was not defined. */ #ifndef HAS_KILL if (type == OP_KILL) - Perl_die(aTHX_ PL_no_func, what); + Perl_die(aTHX_ PL_no_func, what); #endif #ifndef HAS_CHOWN if (type == OP_CHOWN) - Perl_die(aTHX_ PL_no_func, what); + Perl_die(aTHX_ PL_no_func, what); #endif #define APPLY_TAINT_PROPER() \ STMT_START { \ - if (TAINT_get) { TAINT_PROPER(what); } \ + if (TAINT_get) { TAINT_PROPER(what); } \ } STMT_END /* This is a first heuristic; it doesn't catch tainting magic. */ if (TAINTING_get) { - while (++mark <= sp) { - if (SvTAINTED(*mark)) { - TAINT; - break; - } - } - mark = oldmark; + while (++mark <= sp) { + if (SvTAINTED(*mark)) { + TAINT; + break; + } + } + mark = oldmark; } switch (type) { case OP_CHMOD: - APPLY_TAINT_PROPER(); - if (++mark <= sp) { - val = SvIV(*mark); - APPLY_TAINT_PROPER(); - tot = sp - mark; - while (++mark <= sp) { + APPLY_TAINT_PROPER(); + if (++mark <= sp) { + val = SvIV(*mark); + APPLY_TAINT_PROPER(); + tot = sp - mark; + while (++mark <= sp) { GV* gv; if ((gv = MAYBE_DEREF_GV(*mark))) { - if (GvIO(gv) && IoIFP(GvIOp(gv))) { + if (GvIO(gv) && IoIFP(GvIOp(gv))) { #ifdef HAS_FCHMOD int fd = PerlIO_fileno(IoIFP(GvIOn(gv))); - APPLY_TAINT_PROPER(); + APPLY_TAINT_PROPER(); if (fd < 0) { SETERRNO(EBADF,RMS_IFI); tot--; } else if (fchmod(fd, val)) tot--; #else - Perl_die(aTHX_ PL_no_func, "fchmod"); + Perl_die(aTHX_ PL_no_func, "fchmod"); #endif - } - else { + } + else { SETERRNO(EBADF,RMS_IFI); - tot--; - } - } - else { - const char *name = SvPV_nomg_const(*mark, len); - APPLY_TAINT_PROPER(); + tot--; + } + } + else { + const char *name = SvPV_nomg_const(*mark, len); + APPLY_TAINT_PROPER(); if (!IS_SAFE_PATHNAME(name, len, "chmod") || PerlLIO_chmod(name, val)) { tot--; } - } - } - } - break; + } + } + } + break; #ifdef HAS_CHOWN case OP_CHOWN: - APPLY_TAINT_PROPER(); - if (sp - mark > 2) { + APPLY_TAINT_PROPER(); + if (sp - mark > 2) { I32 val2; - val = SvIVx(*++mark); - val2 = SvIVx(*++mark); - APPLY_TAINT_PROPER(); - tot = sp - mark; - while (++mark <= sp) { + val = SvIVx(*++mark); + val2 = SvIVx(*++mark); + APPLY_TAINT_PROPER(); + tot = sp - mark; + while (++mark <= sp) { GV* gv; - if ((gv = MAYBE_DEREF_GV(*mark))) { - if (GvIO(gv) && IoIFP(GvIOp(gv))) { + if ((gv = MAYBE_DEREF_GV(*mark))) { + if (GvIO(gv) && IoIFP(GvIOp(gv))) { #ifdef HAS_FCHOWN int fd = PerlIO_fileno(IoIFP(GvIOn(gv))); - APPLY_TAINT_PROPER(); + APPLY_TAINT_PROPER(); if (fd < 0) { SETERRNO(EBADF,RMS_IFI); - tot--; + tot--; } else if (fchown(fd, val, val2)) - tot--; + tot--; #else - Perl_die(aTHX_ PL_no_func, "fchown"); + Perl_die(aTHX_ PL_no_func, "fchown"); #endif - } - else { + } + else { SETERRNO(EBADF,RMS_IFI); - tot--; - } - } - else { - const char *name = SvPV_nomg_const(*mark, len); - APPLY_TAINT_PROPER(); + tot--; + } + } + else { + const char *name = SvPV_nomg_const(*mark, len); + APPLY_TAINT_PROPER(); if (!IS_SAFE_PATHNAME(name, len, "chown") || PerlLIO_chown(name, val, val2)) { - tot--; + tot--; } - } - } - } - break; + } + } + } + break; #endif /* XXX Should we make lchown() directly available from perl? @@ -2598,44 +2598,44 @@ nothing in the core. */ #ifdef HAS_KILL case OP_KILL: - APPLY_TAINT_PROPER(); - if (mark == sp) - break; - s = SvPVx_const(*++mark, len); - if (*s == '-' && isALPHA(s[1])) - { - s++; - len--; + APPLY_TAINT_PROPER(); + if (mark == sp) + break; + s = SvPVx_const(*++mark, len); + if (*s == '-' && isALPHA(s[1])) + { + s++; + len--; killgp = TRUE; - } - if (isALPHA(*s)) { - if (*s == 'S' && s[1] == 'I' && s[2] == 'G') { - s += 3; + } + if (isALPHA(*s)) { + if (*s == 'S' && s[1] == 'I' && s[2] == 'G') { + s += 3; len -= 3; } if ((val = whichsig_pvn(s, len)) < 0) Perl_croak(aTHX_ "Unrecognized signal name \"%" SVf "\"", SVfARG(*mark)); - } - else - { - val = SvIV(*mark); - if (val < 0) - { - killgp = TRUE; + } + else + { + val = SvIV(*mark); + if (val < 0) + { + killgp = TRUE; val = -val; - } - } - APPLY_TAINT_PROPER(); - tot = sp - mark; - - while (++mark <= sp) { - Pid_t proc; - SvGETMAGIC(*mark); - if (!(SvNIOK(*mark) || looks_like_number(*mark))) - Perl_croak(aTHX_ "Can't kill a non-numeric process ID"); - proc = SvIV_nomg(*mark); - APPLY_TAINT_PROPER(); + } + } + APPLY_TAINT_PROPER(); + tot = sp - mark; + + while (++mark <= sp) { + Pid_t proc; + SvGETMAGIC(*mark); + if (!(SvNIOK(*mark) || looks_like_number(*mark))) + Perl_croak(aTHX_ "Can't kill a non-numeric process ID"); + proc = SvIV_nomg(*mark); + APPLY_TAINT_PROPER(); #ifdef HAS_KILLPG /* use killpg in preference, as the killpg() wrapper for Win32 * understands process groups, but the kill() wrapper doesn't */ @@ -2644,28 +2644,28 @@ nothing in the core. #else if (PerlProc_kill(killgp ? -proc: proc, val)) #endif - tot--; - } - PERL_ASYNC_CHECK(); - break; + tot--; + } + PERL_ASYNC_CHECK(); + break; #endif case OP_UNLINK: - APPLY_TAINT_PROPER(); - tot = sp - mark; - while (++mark <= sp) { - s = SvPV_const(*mark, len); - APPLY_TAINT_PROPER(); - if (!IS_SAFE_PATHNAME(s, len, "unlink")) { + APPLY_TAINT_PROPER(); + tot = sp - mark; + while (++mark <= sp) { + s = SvPV_const(*mark, len); + APPLY_TAINT_PROPER(); + if (!IS_SAFE_PATHNAME(s, len, "unlink")) { tot--; } - else if (PL_unsafe) { - if (UNLINK(s)) - { - tot--; - } + else if (PL_unsafe) { + if (UNLINK(s)) + { + tot--; + } #if defined(__amigaos4__) && defined(NEWLIB) - else - { + else + { /* Under AmigaOS4 unlink only 'fails' if the * filename is invalid. It may not remove the file * if it's locked, so check if it's still around. */ @@ -2673,58 +2673,58 @@ nothing in the core. { tot--; } - } -#endif - } - else { /* don't let root wipe out directories without -U */ - Stat_t statbuf; - if (PerlLIO_lstat(s, &statbuf) < 0) - tot--; - else if (S_ISDIR(statbuf.st_mode)) { - SETERRNO(EISDIR, SS_NOPRIV); - tot--; - } - else { - if (UNLINK(s)) - { - tot--; - } + } +#endif + } + else { /* don't let root wipe out directories without -U */ + Stat_t statbuf; + if (PerlLIO_lstat(s, &statbuf) < 0) + tot--; + else if (S_ISDIR(statbuf.st_mode)) { + SETERRNO(EISDIR, SS_NOPRIV); + tot--; + } + else { + if (UNLINK(s)) + { + tot--; + } #if defined(__amigaos4__) && defined(NEWLIB) - else - { - /* Under AmigaOS4 unlink only 'fails' if the filename is invalid */ - /* It may not remove the file if it's Locked, so check if it's still */ - /* arround */ - if((access(s,F_OK) != -1)) - { - tot--; - } - } -#endif - } - } - } - break; + else + { + /* Under AmigaOS4 unlink only 'fails' if the filename is invalid */ + /* It may not remove the file if it's Locked, so check if it's still */ + /* arround */ + if((access(s,F_OK) != -1)) + { + tot--; + } + } +#endif + } + } + } + break; #if defined(HAS_UTIME) || defined(HAS_FUTIMES) case OP_UTIME: - APPLY_TAINT_PROPER(); - if (sp - mark > 2) { + APPLY_TAINT_PROPER(); + if (sp - mark > 2) { #if defined(HAS_FUTIMES) - struct timeval utbuf[2]; - void *utbufp = utbuf; + struct timeval utbuf[2]; + void *utbufp = utbuf; #elif defined(I_UTIME) || defined(VMS) - struct utimbuf utbuf; - struct utimbuf *utbufp = &utbuf; + struct utimbuf utbuf; + struct utimbuf *utbufp = &utbuf; #else - struct { - Time_t actime; - Time_t modtime; - } utbuf; - void *utbufp = &utbuf; + struct { + Time_t actime; + Time_t modtime; + } utbuf; + void *utbufp = &utbuf; #endif - SV* const accessed = *++mark; - SV* const modified = *++mark; + SV* const accessed = *++mark; + SV* const modified = *++mark; /* Be like C, and if both times are undefined, let the C * library figure out what to do. This usually means @@ -2735,10 +2735,10 @@ nothing in the core. else { Zero(&utbuf, sizeof utbuf, char); #ifdef HAS_FUTIMES - utbuf[0].tv_sec = (long)SvIV(accessed); /* time accessed */ - utbuf[0].tv_usec = 0; - utbuf[1].tv_sec = (long)SvIV(modified); /* time modified */ - utbuf[1].tv_usec = 0; + utbuf[0].tv_sec = (long)SvIV(accessed); /* time accessed */ + utbuf[0].tv_usec = 0; + utbuf[1].tv_sec = (long)SvIV(modified); /* time modified */ + utbuf[1].tv_usec = 0; #elif defined(BIG_TIME) utbuf.actime = (Time_t)SvNV(accessed); /* time accessed */ utbuf.modtime = (Time_t)SvNV(modified); /* time modified */ @@ -2747,48 +2747,48 @@ nothing in the core. utbuf.modtime = (Time_t)SvIV(modified); /* time modified */ #endif } - APPLY_TAINT_PROPER(); - tot = sp - mark; - while (++mark <= sp) { + APPLY_TAINT_PROPER(); + tot = sp - mark; + while (++mark <= sp) { GV* gv; if ((gv = MAYBE_DEREF_GV(*mark))) { - if (GvIO(gv) && IoIFP(GvIOp(gv))) { + if (GvIO(gv) && IoIFP(GvIOp(gv))) { #ifdef HAS_FUTIMES int fd = PerlIO_fileno(IoIFP(GvIOn(gv))); - APPLY_TAINT_PROPER(); + APPLY_TAINT_PROPER(); if (fd < 0) { SETERRNO(EBADF,RMS_IFI); tot--; - } else if (futimes(fd, (struct timeval *) utbufp)) - tot--; + } else if (futimes(fd, (struct timeval *) utbufp)) + tot--; #else - Perl_die(aTHX_ PL_no_func, "futimes"); -#endif - } - else { - tot--; - } - } - else { - const char * const name = SvPV_nomg_const(*mark, len); - APPLY_TAINT_PROPER(); - if (!IS_SAFE_PATHNAME(name, len, "utime")) { + Perl_die(aTHX_ PL_no_func, "futimes"); +#endif + } + else { + tot--; + } + } + else { + const char * const name = SvPV_nomg_const(*mark, len); + APPLY_TAINT_PROPER(); + if (!IS_SAFE_PATHNAME(name, len, "utime")) { tot--; } else #ifdef HAS_FUTIMES - if (utimes(name, (struct timeval *)utbufp)) + if (utimes(name, (struct timeval *)utbufp)) #else - if (PerlLIO_utime(name, utbufp)) + if (PerlLIO_utime(name, utbufp)) #endif - tot--; - } + tot--; + } - } - } - else - tot = 0; - break; + } + } + else + tot = 0; + break; #endif } return tot; @@ -2837,24 +2837,24 @@ Perl_cando(pTHX_ Mode_t mode, bool effective, const Stat_t *statbufp) # else if ((effective ? PerlProc_geteuid() : PerlProc_getuid()) == 0) { /* root is special */ # endif - if (mode == S_IXUSR) { - if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode)) - return TRUE; - } - else - return TRUE; /* root reads and writes anything */ - return FALSE; + if (mode == S_IXUSR) { + if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode)) + return TRUE; + } + else + return TRUE; /* root reads and writes anything */ + return FALSE; } if (statbufp->st_uid == (effective ? PerlProc_geteuid() : PerlProc_getuid()) ) { - if (statbufp->st_mode & mode) - return TRUE; /* ok as "user" */ + if (statbufp->st_mode & mode) + return TRUE; /* ok as "user" */ } else if (ingroup(statbufp->st_gid,effective)) { - if (statbufp->st_mode & mode >> 3) - return TRUE; /* ok as "group" */ + if (statbufp->st_mode & mode >> 3) + return TRUE; /* ok as "group" */ } else if (statbufp->st_mode & mode >> 6) - return TRUE; /* ok as "other" */ + return TRUE; /* ok as "other" */ return FALSE; #endif /* ! DOSISH */ } @@ -2868,14 +2868,14 @@ S_ingroup(pTHX_ Gid_t testgid, bool effective) PERL_UNUSED_CONTEXT; #endif if (testgid == (effective ? PerlProc_getegid() : PerlProc_getgid())) - return TRUE; + return TRUE; #ifdef HAS_GETGROUPS { - Groups_t *gary = NULL; - I32 anum; + Groups_t *gary = NULL; + I32 anum; bool rc = FALSE; - anum = getgroups(0, gary); + anum = getgroups(0, gary); if (anum > 0) { Newx(gary, anum, Groups_t); anum = getgroups(anum, gary); @@ -2911,20 +2911,20 @@ Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp) { #ifdef HAS_MSG case OP_MSGGET: - return msgget(key, flags); + return msgget(key, flags); #endif #ifdef HAS_SEM case OP_SEMGET: - return semget(key, (int) SvIV(nsv), flags); + return semget(key, (int) SvIV(nsv), flags); #endif #ifdef HAS_SHM case OP_SHMGET: - return shmget(key, (size_t) SvUV(nsv), flags); + return shmget(key, (size_t) SvUV(nsv), flags); #endif #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM) default: /* diag_listed_as: msg%s not implemented */ - Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); + Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); #endif } return -1; /* should never happen */ @@ -2951,80 +2951,94 @@ Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp) { #ifdef HAS_MSG case OP_MSGCTL: - if (cmd == IPC_STAT || cmd == IPC_SET) - infosize = sizeof(struct msqid_ds); - break; + if (cmd == IPC_STAT || cmd == IPC_SET) + infosize = sizeof(struct msqid_ds); + break; #endif #ifdef HAS_SHM case OP_SHMCTL: - if (cmd == IPC_STAT || cmd == IPC_SET) - infosize = sizeof(struct shmid_ds); - break; + if (cmd == IPC_STAT || cmd == IPC_SET) + infosize = sizeof(struct shmid_ds); + break; #endif #ifdef HAS_SEM case OP_SEMCTL: #ifdef Semctl - if (cmd == IPC_STAT || cmd == IPC_SET) - infosize = sizeof(struct semid_ds); - else if (cmd == GETALL || cmd == SETALL) - { - struct semid_ds semds; - union semun semun; + if (cmd == IPC_STAT || cmd == IPC_SET) + infosize = sizeof(struct semid_ds); + else if (cmd == GETALL || cmd == SETALL) + { + struct semid_ds semds; + union semun semun; #ifdef EXTRA_F_IN_SEMUN_BUF semun.buff = &semds; #else semun.buf = &semds; #endif - getinfo = (cmd == GETALL); - if (Semctl(id, 0, IPC_STAT, semun) == -1) - return -1; - infosize = semds.sem_nsems * sizeof(short); - /* "short" is technically wrong but much more portable - than guessing about u_?short(_t)? */ - } + getinfo = (cmd == GETALL); + if (Semctl(id, 0, IPC_STAT, semun) == -1) + return -1; + infosize = semds.sem_nsems * sizeof(short); + /* "short" is technically wrong but much more portable + than guessing about u_?short(_t)? */ + } #else /* diag_listed_as: sem%s not implemented */ - Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); + Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); #endif - break; + break; #endif #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM) default: /* diag_listed_as: shm%s not implemented */ - Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); + Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); #endif } if (infosize) { - if (getinfo) - { - SvPV_force_nolen(astr); - a = SvGROW(astr, infosize+1); - } - else - { - STRLEN len; - a = SvPV(astr, len); - if (len != infosize) - Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld", - PL_op_desc[optype], - (unsigned long)len, - (long)infosize); - } + if (getinfo) + { + /* we're not using the value here, so don't SvPVanything */ + SvUPGRADE(astr, SVt_PV); + SvGETMAGIC(astr); + if (SvTHINKFIRST(astr)) + sv_force_normal_flags(astr, 0); + a = SvGROW(astr, infosize+1); + } + else + { + STRLEN len; + a = SvPVbyte(astr, len); + if (len != infosize) + Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld", + PL_op_desc[optype], + (unsigned long)len, + (long)infosize); + } } else { - const IV i = SvIV(astr); - a = INT2PTR(char *,i); /* ouch */ + /* We historically treat this as a pointer if we don't otherwise recognize + the op, but for many ops the value is simply ignored anyway, so + don't warn on undef. + */ + SvGETMAGIC(astr); + if (SvOK(astr)) { + const IV i = SvIV_nomg(astr); + a = INT2PTR(char *,i); /* ouch */ + } + else { + a = NULL; + } } SETERRNO(0,0); switch (optype) { #ifdef HAS_MSG case OP_MSGCTL: - ret = msgctl(id, cmd, (struct msqid_ds *)a); - break; + ret = msgctl(id, cmd, (struct msqid_ds *)a); + break; #endif #ifdef HAS_SEM case OP_SEMCTL: { @@ -3041,24 +3055,25 @@ Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp) unsemds.buf = (struct semid_ds *)a; #endif } - ret = Semctl(id, n, cmd, unsemds); + ret = Semctl(id, n, cmd, unsemds); #else - /* diag_listed_as: sem%s not implemented */ - Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); + /* diag_listed_as: sem%s not implemented */ + Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); #endif } - break; + break; #endif #ifdef HAS_SHM case OP_SHMCTL: - ret = shmctl(id, cmd, (struct shmid_ds *)a); - break; + ret = shmctl(id, cmd, (struct shmid_ds *)a); + break; #endif } if (getinfo && ret >= 0) { - SvCUR_set(astr, infosize); - *SvEND(astr) = '\0'; - SvSETMAGIC(astr); + SvCUR_set(astr, infosize); + *SvEND(astr) = '\0'; + SvPOK_only(astr); + SvSETMAGIC(astr); } return ret; } @@ -3071,14 +3086,14 @@ Perl_do_msgsnd(pTHX_ SV **mark, SV **sp) const I32 id = SvIVx(*++mark); SV * const mstr = *++mark; const I32 flags = SvIVx(*++mark); - const char * const mbuf = SvPV_const(mstr, len); + const char * const mbuf = SvPVbyte(mstr, len); const I32 msize = len - sizeof(long); PERL_ARGS_ASSERT_DO_MSGSND; PERL_UNUSED_ARG(sp); if (msize < 0) - Perl_croak(aTHX_ "Arg too short for msgsnd"); + Perl_croak(aTHX_ "Arg too short for msgsnd"); SETERRNO(0,0); if (id >= 0 && flags >= 0) { return msgsnd(id, (struct msgbuf *)mbuf, msize, flags); @@ -3125,10 +3140,11 @@ Perl_do_msgrcv(pTHX_ SV **mark, SV **sp) ret = -1; } if (ret >= 0) { - SvCUR_set(mstr, sizeof(long)+ret); - *SvEND(mstr) = '\0'; - /* who knows who has been playing with this message? */ - SvTAINTED_on(mstr); + SvCUR_set(mstr, sizeof(long)+ret); + SvPOK_only(mstr); + *SvEND(mstr) = '\0'; + /* who knows who has been playing with this message? */ + SvTAINTED_on(mstr); } return ret; #else @@ -3147,15 +3163,15 @@ Perl_do_semop(pTHX_ SV **mark, SV **sp) STRLEN opsize; const I32 id = SvIVx(*++mark); SV * const opstr = *++mark; - const char * const opbuf = SvPV_const(opstr, opsize); + const char * const opbuf = SvPVbyte(opstr, opsize); PERL_ARGS_ASSERT_DO_SEMOP; PERL_UNUSED_ARG(sp); if (opsize < 3 * SHORTSIZE - || (opsize % (3 * SHORTSIZE))) { - SETERRNO(EINVAL,LIB_INVARG); - return -1; + || (opsize % (3 * SHORTSIZE))) { + SETERRNO(EINVAL,LIB_INVARG); + return -1; } SETERRNO(0,0); /* We can't assume that sizeof(struct sembuf) == 3 * sizeof(short). */ @@ -3201,11 +3217,11 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) SETERRNO(0,0); if (shmctl(id, IPC_STAT, &shmds) == -1) - return -1; + return -1; if (mpos < 0 || msize < 0 - || (size_t)mpos + msize > (size_t)shmds.shm_segsz) { - SETERRNO(EFAULT,SS_ACCVIO); /* can't do as caller requested */ - return -1; + || (size_t)mpos + msize > (size_t)shmds.shm_segsz) { + SETERRNO(EFAULT,SS_ACCVIO); /* can't do as caller requested */ + return -1; } if (id >= 0) { shm = (char *)shmat(id, NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0); @@ -3214,32 +3230,32 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) return -1; } if (shm == (char *)-1) /* I hate System V IPC, I really do */ - return -1; + return -1; if (optype == OP_SHMREAD) { - char *mbuf; - /* suppress warning when reading into undef var (tchrist 3/Mar/00) */ - SvGETMAGIC(mstr); - SvUPGRADE(mstr, SVt_PV); - if (! SvOK(mstr)) + char *mbuf; + /* suppress warning when reading into undef var (tchrist 3/Mar/00) */ + SvGETMAGIC(mstr); + SvUPGRADE(mstr, SVt_PV); + if (! SvOK(mstr)) SvPVCLEAR(mstr); - SvPOK_only(mstr); - mbuf = SvGROW(mstr, (STRLEN)msize+1); + SvPOK_only(mstr); + mbuf = SvGROW(mstr, (STRLEN)msize+1); - Copy(shm + mpos, mbuf, msize, char); - SvCUR_set(mstr, msize); - *SvEND(mstr) = '\0'; - SvSETMAGIC(mstr); - /* who knows who has been playing with this shared memory? */ - SvTAINTED_on(mstr); + Copy(shm + mpos, mbuf, msize, char); + SvCUR_set(mstr, msize); + *SvEND(mstr) = '\0'; + SvSETMAGIC(mstr); + /* who knows who has been playing with this shared memory? */ + SvTAINTED_on(mstr); } else { - STRLEN len; + STRLEN len; - const char *mbuf = SvPV_const(mstr, len); - const I32 n = ((I32)len > msize) ? msize : (I32)len; - Copy(mbuf, shm + mpos, n, char); - if (n < msize) - memzero(shm + mpos + n, msize - n); + const char *mbuf = SvPVbyte(mstr, len); + const I32 n = ((I32)len > msize) ? msize : (I32)len; + Copy(mbuf, shm + mpos, n, char); + if (n < msize) + memzero(shm + mpos + n, msize - n); } return shmdt(shm); #else diff --git a/doop.c b/doop.c index 822ad3c2aaea..fe1d44aa7a3b 100644 --- a/doop.c +++ b/doop.c @@ -53,57 +53,57 @@ S_do_trans_simple(pTHX_ SV * const sv, const OPtrans_map * const tbl) /* First, take care of non-UTF-8 input strings, because they're easy */ if (!SvUTF8(sv)) { - while (s < send) { - const short ch = tbl->map[*s]; - if (ch >= 0) { - matches++; - *s = (U8)ch; - } - s++; - } - SvSETMAGIC(sv); + while (s < send) { + const short ch = tbl->map[*s]; + if (ch >= 0) { + matches++; + *s = (U8)ch; + } + s++; + } + SvSETMAGIC(sv); } else { - const bool grows = cBOOL(PL_op->op_private & OPpTRANS_GROWS); - U8 *d; - U8 *dstart; + const bool grows = cBOOL(PL_op->op_private & OPpTRANS_GROWS); + U8 *d; + U8 *dstart; /* Allow for worst-case expansion: Each input byte can become 2. For a * given input character, this happens when it occupies a single byte * under UTF-8, but is to be translated to something that occupies two: * $_="a".chr(400); tr/a/\xFE/, FE needs encoding. */ - if (grows) - Newx(d, len*2+1, U8); - else - d = s; - dstart = d; - while (s < send) { - STRLEN ulen; - short ch; - - /* Need to check this, otherwise 128..255 won't match */ - const UV c = utf8n_to_uvchr(s, send - s, &ulen, UTF8_ALLOW_DEFAULT); - if (c < 0x100 && (ch = tbl->map[c]) >= 0) { - matches++; - d = uvchr_to_utf8(d, (UV)ch); - s += ulen; - } - else { /* No match -> copy */ - Move(s, d, ulen, U8); - d += ulen; - s += ulen; - } - } - if (grows) { - sv_setpvn(sv, (char*)dstart, d - dstart); - Safefree(dstart); - } - else { - *d = '\0'; - SvCUR_set(sv, d - dstart); - } - SvUTF8_on(sv); - SvSETMAGIC(sv); + if (grows) + Newx(d, len*2+1, U8); + else + d = s; + dstart = d; + while (s < send) { + STRLEN ulen; + short ch; + + /* Need to check this, otherwise 128..255 won't match */ + const UV c = utf8n_to_uvchr(s, send - s, &ulen, UTF8_ALLOW_DEFAULT); + if (c < 0x100 && (ch = tbl->map[c]) >= 0) { + matches++; + d = uvchr_to_utf8(d, (UV)ch); + s += ulen; + } + else { /* No match -> copy */ + Move(s, d, ulen, U8); + d += ulen; + s += ulen; + } + } + if (grows) { + sv_setpvn(sv, (char*)dstart, d - dstart); + Safefree(dstart); + } + else { + *d = '\0'; + SvCUR_set(sv, d - dstart); + } + SvUTF8_on(sv); + SvSETMAGIC(sv); } DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d: returning %zu\n", __FILE__, __LINE__, matches)); @@ -140,23 +140,23 @@ S_do_trans_count(pTHX_ SV * const sv, const OPtrans_map * const tbl) DEBUG_y(sv_dump(sv)); if (!SvUTF8(sv)) { - while (s < send) { + while (s < send) { if (tbl->map[*s++] >= 0) matches++; - } + } } else { - const bool complement = cBOOL(PL_op->op_private & OPpTRANS_COMPLEMENT); - while (s < send) { - STRLEN ulen; - const UV c = utf8n_to_uvchr(s, send - s, &ulen, UTF8_ALLOW_DEFAULT); - if (c < 0x100) { - if (tbl->map[c] >= 0) - matches++; - } else if (complement) - matches++; - s += ulen; - } + const bool complement = cBOOL(PL_op->op_private & OPpTRANS_COMPLEMENT); + while (s < send) { + STRLEN ulen; + const UV c = utf8n_to_uvchr(s, send - s, &ulen, UTF8_ALLOW_DEFAULT); + if (c < 0x100) { + if (tbl->map[c] >= 0) + matches++; + } else if (complement) + matches++; + s += ulen; + } } DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d: count returning %zu\n", @@ -190,26 +190,26 @@ S_do_trans_complex(pTHX_ SV * const sv, const OPtrans_map * const tbl) DEBUG_y(sv_dump(sv)); if (!SvUTF8(sv)) { - U8 *d = s; - U8 * const dstart = d; + U8 *d = s; + U8 * const dstart = d; - if (PL_op->op_private & OPpTRANS_SQUASH) { + if (PL_op->op_private & OPpTRANS_SQUASH) { /* What the mapping of the previous character was to. If the new * character has the same mapping, it is squashed from the output * (but still is included in the count) */ short previous_map = (short) TR_OOB; - while (s < send) { - const short this_map = tbl->map[*s]; - if (this_map >= 0) { + while (s < send) { + const short this_map = tbl->map[*s]; + if (this_map >= 0) { matches++; if (this_map != previous_map) { *d++ = (U8)this_map; previous_map = this_map; } - } - else { + } + else { if (this_map == (short) TR_UNMAPPED) { *d++ = *s; previous_map = (short) TR_OOB; @@ -220,47 +220,47 @@ S_do_trans_complex(pTHX_ SV * const sv, const OPtrans_map * const tbl) } } - s++; - } - } - else { /* Not to squash */ - while (s < send) { - const short this_map = tbl->map[*s]; - if (this_map >= 0) { - matches++; - *d++ = (U8)this_map; - } - else if (this_map == (short) TR_UNMAPPED) - *d++ = *s; - else if (this_map == (short) TR_DELETE) - matches++; - s++; - } - } - *d = '\0'; - SvCUR_set(sv, d - dstart); + s++; + } + } + else { /* Not to squash */ + while (s < send) { + const short this_map = tbl->map[*s]; + if (this_map >= 0) { + matches++; + *d++ = (U8)this_map; + } + else if (this_map == (short) TR_UNMAPPED) + *d++ = *s; + else if (this_map == (short) TR_DELETE) + matches++; + s++; + } + } + *d = '\0'; + SvCUR_set(sv, d - dstart); } else { /* is utf8 */ - const bool squash = cBOOL(PL_op->op_private & OPpTRANS_SQUASH); - const bool grows = cBOOL(PL_op->op_private & OPpTRANS_GROWS); - U8 *d; - U8 *dstart; - Size_t size = tbl->size; + const bool squash = cBOOL(PL_op->op_private & OPpTRANS_SQUASH); + const bool grows = cBOOL(PL_op->op_private & OPpTRANS_GROWS); + U8 *d; + U8 *dstart; + Size_t size = tbl->size; /* What the mapping of the previous character was to. If the new * character has the same mapping, it is squashed from the output (but * still is included in the count) */ UV pch = TR_OOB; - if (grows) + if (grows) /* Allow for worst-case expansion: Each input byte can become 2. * For a given input character, this happens when it occupies a * single byte under UTF-8, but is to be translated to something * that occupies two: */ - Newx(d, len*2+1, U8); - else - d = s; - dstart = d; + Newx(d, len*2+1, U8); + else + d = s; + dstart = d; while (s < send) { STRLEN len; @@ -302,15 +302,15 @@ S_do_trans_complex(pTHX_ SV * const sv, const OPtrans_map * const tbl) s += len; } - if (grows) { - sv_setpvn(sv, (char*)dstart, d - dstart); - Safefree(dstart); - } - else { - *d = '\0'; - SvCUR_set(sv, d - dstart); - } - SvUTF8_on(sv); + if (grows) { + sv_setpvn(sv, (char*)dstart, d - dstart); + Safefree(dstart); + } + else { + *d = '\0'; + SvCUR_set(sv, d - dstart); + } + SvUTF8_on(sv); } SvSETMAGIC(sv); DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d: returning %zu\n", @@ -459,7 +459,7 @@ S_do_trans_invmap(pTHX_ SV * const sv, AV * const invmap) * transliterations are longer than the input. If none can, we just edit * in place. */ if (inplace) { - d0 = d = s; + d0 = d = s; } else { /* Here, we can't edit in place. We have no idea how much, if any, @@ -467,8 +467,8 @@ S_do_trans_invmap(pTHX_ SV * const sv, AV * const invmap) * calculated the maximum expansion possible. Use that to allocate * based on the worst case scenario. (First +1 is to round up; 2nd is * for \0) */ - Newx(d, (STRLEN) (len * max_expansion + 1 + 1), U8); - d0 = d; + Newx(d, (STRLEN) (len * max_expansion + 1 + 1), U8); + d0 = d; } restart: @@ -514,7 +514,7 @@ S_do_trans_invmap(pTHX_ SV * const sv, AV * const invmap) previous_map = to; s += s_len; continue; - } + } /* Everything else is counted as a match */ matches++; @@ -558,12 +558,12 @@ S_do_trans_invmap(pTHX_ SV * const sv, AV * const invmap) s_len = 0; s += s_len; if (! inplace) { - sv_setpvn(sv, (char*)d0, d - d0); + sv_setpvn(sv, (char*)d0, d - d0); Safefree(d0); } else { - *d = '\0'; - SvCUR_set(sv, d - d0); + *d = '\0'; + SvCUR_set(sv, d - d0); } if (! SvUTF8(sv) && out_is_utf8) { @@ -599,11 +599,11 @@ Perl_do_trans(pTHX_ SV *sv) } (void)SvPV_const(sv, len); if (!len) - return 0; + return 0; if (! identical) { - if (!SvPOKp(sv) || SvTHINKFIRST(sv)) - (void)SvPV_force_nomg(sv, len); - (void)SvPOK_only_UTF8(sv); + if (!SvPOKp(sv) || SvTHINKFIRST(sv)) + (void)SvPV_force_nomg(sv, len); + (void)SvPOK_only_UTF8(sv); } if (use_utf8_fcns) { @@ -650,19 +650,19 @@ Perl_do_join(pTHX_ SV *sv, SV *delim, SV **mark, SV **sp) len = (items > 0 ? (delimlen * (items - 1) ) : 0); SvUPGRADE(sv, SVt_PV); if (SvLEN(sv) < len + items) { /* current length is way too short */ - while (items-- > 0) { - if (*mark && !SvGAMAGIC(*mark) && SvOK(*mark)) { - STRLEN tmplen; - SvPV_const(*mark, tmplen); - len += tmplen; - } - mark++; - } - SvGROW(sv, len + 1); /* so try to pre-extend */ - - mark = oldmark; - items = sp - mark; - ++mark; + while (items-- > 0) { + if (*mark && !SvGAMAGIC(*mark) && SvOK(*mark)) { + STRLEN tmplen; + SvPV_const(*mark, tmplen); + len += tmplen; + } + mark++; + } + SvGROW(sv, len + 1); /* so try to pre-extend */ + + mark = oldmark; + items = sp - mark; + ++mark; } SvPVCLEAR(sv); @@ -670,33 +670,33 @@ Perl_do_join(pTHX_ SV *sv, SV *delim, SV **mark, SV **sp) SvUTF8_off(sv); if (TAINTING_get && SvMAGICAL(sv)) - SvTAINTED_off(sv); + SvTAINTED_off(sv); if (items-- > 0) { - if (*mark) - sv_catsv(sv, *mark); - mark++; + if (*mark) + sv_catsv(sv, *mark); + mark++; } if (delimlen) { - const U32 delimflag = DO_UTF8(delim) ? SV_CATUTF8 : SV_CATBYTES; - for (; items > 0; items--,mark++) { - STRLEN len; - const char *s; - sv_catpvn_flags(sv,delims,delimlen,delimflag); - s = SvPV_const(*mark,len); - sv_catpvn_flags(sv,s,len, - DO_UTF8(*mark) ? SV_CATUTF8 : SV_CATBYTES); - } + const U32 delimflag = DO_UTF8(delim) ? SV_CATUTF8 : SV_CATBYTES; + for (; items > 0; items--,mark++) { + STRLEN len; + const char *s; + sv_catpvn_flags(sv,delims,delimlen,delimflag); + s = SvPV_const(*mark,len); + sv_catpvn_flags(sv,s,len, + DO_UTF8(*mark) ? SV_CATUTF8 : SV_CATBYTES); + } } else { - for (; items > 0; items--,mark++) - { - STRLEN len; - const char *s = SvPV_const(*mark,len); - sv_catpvn_flags(sv,s,len, - DO_UTF8(*mark) ? SV_CATUTF8 : SV_CATBYTES); - } + for (; items > 0; items--,mark++) + { + STRLEN len; + const char *s = SvPV_const(*mark,len); + sv_catpvn_flags(sv,s,len, + DO_UTF8(*mark) ? SV_CATUTF8 : SV_CATBYTES); + } } SvSETMAGIC(sv); } @@ -712,20 +712,20 @@ Perl_do_sprintf(pTHX_ SV *sv, SSize_t len, SV **sarg) assert(len >= 1); if (SvTAINTED(*sarg)) - TAINT_PROPER( - (PL_op && PL_op->op_type < OP_max) - ? (PL_op->op_type == OP_PRTF) - ? "printf" - : PL_op_name[PL_op->op_type] - : "(unknown)" - ); + TAINT_PROPER( + (PL_op && PL_op->op_type < OP_max) + ? (PL_op->op_type == OP_PRTF) + ? "printf" + : PL_op_name[PL_op->op_type] + : "(unknown)" + ); SvUTF8_off(sv); if (DO_UTF8(*sarg)) SvUTF8_on(sv); sv_vsetpvfn(sv, pat, patlen, NULL, sarg + 1, (Size_t)(len - 1), &do_taint); SvSETMAGIC(sv); if (do_taint) - SvTAINTED_on(sv); + SvTAINTED_on(sv); } UV @@ -745,10 +745,10 @@ Perl_do_vecget(pTHX_ SV *sv, STRLEN offset, int size) PERL_ARGS_ASSERT_DO_VECGET; if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */ - Perl_croak(aTHX_ "Illegal number of bits in vec"); + Perl_croak(aTHX_ "Illegal number of bits in vec"); if (SvUTF8(sv)) { - if (Perl_sv_utf8_downgrade_flags(aTHX_ sv, TRUE, 0)) { + if (Perl_sv_utf8_downgrade_flags(aTHX_ sv, TRUE, 0)) { /* PVX may have changed */ s = (unsigned char *) SvPV_flags(sv, srclen, svpv_flags); } @@ -759,17 +759,17 @@ Perl_do_vecget(pTHX_ SV *sv, STRLEN offset, int size) } if (size < 8) { - bitoffs = ((offset%8)*size)%8; - uoffset = offset/(8/size); + bitoffs = ((offset%8)*size)%8; + uoffset = offset/(8/size); } else if (size > 8) { - int n = size/8; + int n = size/8; if (offset > Size_t_MAX / n - 1) /* would overflow */ return 0; - uoffset = offset*n; + uoffset = offset*n; } else - uoffset = offset; + uoffset = offset; if (uoffset >= srclen) return 0; @@ -780,108 +780,108 @@ Perl_do_vecget(pTHX_ SV *sv, STRLEN offset, int size) /* Does the byte range overlap the end of the string? If so, * handle specially. */ if (avail < len) { - if (size <= 8) - retnum = 0; - else { - if (size == 16) { + if (size <= 8) + retnum = 0; + else { + if (size == 16) { assert(avail == 1); retnum = (UV) s[uoffset] << 8; - } - else if (size == 32) { + } + else if (size == 32) { assert(avail >= 1 && avail <= 3); - if (avail == 1) - retnum = - ((UV) s[uoffset ] << 24); - else if (avail == 2) - retnum = - ((UV) s[uoffset ] << 24) + - ((UV) s[uoffset + 1] << 16); - else - retnum = - ((UV) s[uoffset ] << 24) + - ((UV) s[uoffset + 1] << 16) + - ( s[uoffset + 2] << 8); - } + if (avail == 1) + retnum = + ((UV) s[uoffset ] << 24); + else if (avail == 2) + retnum = + ((UV) s[uoffset ] << 24) + + ((UV) s[uoffset + 1] << 16); + else + retnum = + ((UV) s[uoffset ] << 24) + + ((UV) s[uoffset + 1] << 16) + + ( s[uoffset + 2] << 8); + } #ifdef UV_IS_QUAD - else if (size == 64) { - Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), - "Bit vector size > 32 non-portable"); + else if (size == 64) { + Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), + "Bit vector size > 32 non-portable"); assert(avail >= 1 && avail <= 7); - if (avail == 1) - retnum = - (UV) s[uoffset ] << 56; - else if (avail == 2) - retnum = - ((UV) s[uoffset ] << 56) + - ((UV) s[uoffset + 1] << 48); - else if (avail == 3) - retnum = - ((UV) s[uoffset ] << 56) + - ((UV) s[uoffset + 1] << 48) + - ((UV) s[uoffset + 2] << 40); - else if (avail == 4) - retnum = - ((UV) s[uoffset ] << 56) + - ((UV) s[uoffset + 1] << 48) + - ((UV) s[uoffset + 2] << 40) + - ((UV) s[uoffset + 3] << 32); - else if (avail == 5) - retnum = - ((UV) s[uoffset ] << 56) + - ((UV) s[uoffset + 1] << 48) + - ((UV) s[uoffset + 2] << 40) + - ((UV) s[uoffset + 3] << 32) + - ((UV) s[uoffset + 4] << 24); - else if (avail == 6) - retnum = - ((UV) s[uoffset ] << 56) + - ((UV) s[uoffset + 1] << 48) + - ((UV) s[uoffset + 2] << 40) + - ((UV) s[uoffset + 3] << 32) + - ((UV) s[uoffset + 4] << 24) + - ((UV) s[uoffset + 5] << 16); - else - retnum = - ((UV) s[uoffset ] << 56) + - ((UV) s[uoffset + 1] << 48) + - ((UV) s[uoffset + 2] << 40) + - ((UV) s[uoffset + 3] << 32) + - ((UV) s[uoffset + 4] << 24) + - ((UV) s[uoffset + 5] << 16) + - ((UV) s[uoffset + 6] << 8); - } + if (avail == 1) + retnum = + (UV) s[uoffset ] << 56; + else if (avail == 2) + retnum = + ((UV) s[uoffset ] << 56) + + ((UV) s[uoffset + 1] << 48); + else if (avail == 3) + retnum = + ((UV) s[uoffset ] << 56) + + ((UV) s[uoffset + 1] << 48) + + ((UV) s[uoffset + 2] << 40); + else if (avail == 4) + retnum = + ((UV) s[uoffset ] << 56) + + ((UV) s[uoffset + 1] << 48) + + ((UV) s[uoffset + 2] << 40) + + ((UV) s[uoffset + 3] << 32); + else if (avail == 5) + retnum = + ((UV) s[uoffset ] << 56) + + ((UV) s[uoffset + 1] << 48) + + ((UV) s[uoffset + 2] << 40) + + ((UV) s[uoffset + 3] << 32) + + ((UV) s[uoffset + 4] << 24); + else if (avail == 6) + retnum = + ((UV) s[uoffset ] << 56) + + ((UV) s[uoffset + 1] << 48) + + ((UV) s[uoffset + 2] << 40) + + ((UV) s[uoffset + 3] << 32) + + ((UV) s[uoffset + 4] << 24) + + ((UV) s[uoffset + 5] << 16); + else + retnum = + ((UV) s[uoffset ] << 56) + + ((UV) s[uoffset + 1] << 48) + + ((UV) s[uoffset + 2] << 40) + + ((UV) s[uoffset + 3] << 32) + + ((UV) s[uoffset + 4] << 24) + + ((UV) s[uoffset + 5] << 16) + + ((UV) s[uoffset + 6] << 8); + } #endif - } + } } else if (size < 8) - retnum = (s[uoffset] >> bitoffs) & nBIT_MASK(size); + retnum = (s[uoffset] >> bitoffs) & nBIT_MASK(size); else { - if (size == 8) - retnum = s[uoffset]; - else if (size == 16) - retnum = - ((UV) s[uoffset] << 8) + - s[uoffset + 1]; - else if (size == 32) - retnum = - ((UV) s[uoffset ] << 24) + - ((UV) s[uoffset + 1] << 16) + - ( s[uoffset + 2] << 8) + - s[uoffset + 3]; + if (size == 8) + retnum = s[uoffset]; + else if (size == 16) + retnum = + ((UV) s[uoffset] << 8) + + s[uoffset + 1]; + else if (size == 32) + retnum = + ((UV) s[uoffset ] << 24) + + ((UV) s[uoffset + 1] << 16) + + ( s[uoffset + 2] << 8) + + s[uoffset + 3]; #ifdef UV_IS_QUAD - else if (size == 64) { - Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), - "Bit vector size > 32 non-portable"); - retnum = - ((UV) s[uoffset ] << 56) + - ((UV) s[uoffset + 1] << 48) + - ((UV) s[uoffset + 2] << 40) + - ((UV) s[uoffset + 3] << 32) + - ((UV) s[uoffset + 4] << 24) + - ((UV) s[uoffset + 5] << 16) + - ( s[uoffset + 6] << 8) + - s[uoffset + 7]; - } + else if (size == 64) { + Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), + "Bit vector size > 32 non-portable"); + retnum = + ((UV) s[uoffset ] << 56) + + ((UV) s[uoffset + 1] << 48) + + ((UV) s[uoffset + 2] << 40) + + ((UV) s[uoffset + 3] << 32) + + ((UV) s[uoffset + 4] << 24) + + ((UV) s[uoffset + 5] << 16) + + ( s[uoffset + 6] << 8) + + s[uoffset + 7]; + } #endif } @@ -917,15 +917,15 @@ Perl_do_vecset(pTHX_ SV *sv) } if (!targ) - return; + return; s = (unsigned char*)SvPV_force_flags(targ, targlen, SV_GMAGIC | SV_UNDEF_RETURNS_NULL); if (SvUTF8(targ)) { - /* This is handled by the SvPOK_only below... - if (!Perl_sv_utf8_downgrade_flags(aTHX_ targ, TRUE, 0)) - SvUTF8_off(targ); - */ - (void) Perl_sv_utf8_downgrade_flags(aTHX_ targ, TRUE, 0); + /* This is handled by the SvPOK_only below... + if (!Perl_sv_utf8_downgrade_flags(aTHX_ targ, TRUE, 0)) + SvUTF8_off(targ); + */ + (void) Perl_sv_utf8_downgrade_flags(aTHX_ targ, TRUE, 0); } (void)SvPOK_only(targ); @@ -934,60 +934,60 @@ Perl_do_vecset(pTHX_ SV *sv) size = LvTARGLEN(sv); if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */ - Perl_croak(aTHX_ "Illegal number of bits in vec"); + Perl_croak(aTHX_ "Illegal number of bits in vec"); if (size < 8) { - bitoffs = ((offset%8)*size)%8; - offset /= 8/size; + bitoffs = ((offset%8)*size)%8; + offset /= 8/size; } else if (size > 8) { - int n = size/8; + int n = size/8; if (offset > Size_t_MAX / n - 1) /* would overflow */ Perl_croak_nocontext("Out of memory!"); - offset *= n; + offset *= n; } len = (bitoffs + size + 7)/8; /* required number of bytes */ if (targlen < offset || targlen - offset < len) { STRLEN newlen = offset > Size_t_MAX - len - 1 ? /* avoid overflow */ Size_t_MAX : offset + len + 1; - s = (unsigned char*)SvGROW(targ, newlen); - (void)memzero((char *)(s + targlen), newlen - targlen); - SvCUR_set(targ, newlen - 1); + s = (unsigned char*)SvGROW(targ, newlen); + (void)memzero((char *)(s + targlen), newlen - targlen); + SvCUR_set(targ, newlen - 1); } if (size < 8) { - mask = nBIT_MASK(size); - lval &= mask; - s[offset] &= ~(mask << bitoffs); - s[offset] |= lval << bitoffs; + mask = nBIT_MASK(size); + lval &= mask; + s[offset] &= ~(mask << bitoffs); + s[offset] |= lval << bitoffs; } else { - if (size == 8) - s[offset ] = (U8)( lval & 0xff); - else if (size == 16) { - s[offset ] = (U8)((lval >> 8) & 0xff); - s[offset+1] = (U8)( lval & 0xff); - } - else if (size == 32) { - s[offset ] = (U8)((lval >> 24) & 0xff); - s[offset+1] = (U8)((lval >> 16) & 0xff); - s[offset+2] = (U8)((lval >> 8) & 0xff); - s[offset+3] = (U8)( lval & 0xff); - } + if (size == 8) + s[offset ] = (U8)( lval & 0xff); + else if (size == 16) { + s[offset ] = (U8)((lval >> 8) & 0xff); + s[offset+1] = (U8)( lval & 0xff); + } + else if (size == 32) { + s[offset ] = (U8)((lval >> 24) & 0xff); + s[offset+1] = (U8)((lval >> 16) & 0xff); + s[offset+2] = (U8)((lval >> 8) & 0xff); + s[offset+3] = (U8)( lval & 0xff); + } #ifdef UV_IS_QUAD - else if (size == 64) { - Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), - "Bit vector size > 32 non-portable"); - s[offset ] = (U8)((lval >> 56) & 0xff); - s[offset+1] = (U8)((lval >> 48) & 0xff); - s[offset+2] = (U8)((lval >> 40) & 0xff); - s[offset+3] = (U8)((lval >> 32) & 0xff); - s[offset+4] = (U8)((lval >> 24) & 0xff); - s[offset+5] = (U8)((lval >> 16) & 0xff); - s[offset+6] = (U8)((lval >> 8) & 0xff); - s[offset+7] = (U8)( lval & 0xff); - } + else if (size == 64) { + Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), + "Bit vector size > 32 non-portable"); + s[offset ] = (U8)((lval >> 56) & 0xff); + s[offset+1] = (U8)((lval >> 48) & 0xff); + s[offset+2] = (U8)((lval >> 40) & 0xff); + s[offset+3] = (U8)((lval >> 32) & 0xff); + s[offset+4] = (U8)((lval >> 24) & 0xff); + s[offset+5] = (U8)((lval >> 16) & 0xff); + s[offset+6] = (U8)((lval >> 8) & 0xff); + s[offset+7] = (U8)( lval & 0xff); + } #endif } SvSETMAGIC(targ); @@ -1024,11 +1024,11 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) if (sv != left || (optype != OP_BIT_AND && !SvOK(sv))) SvPVCLEAR(sv); /* avoid undef warning on |= and ^= */ if (sv == left) { - lc = SvPV_force_nomg(left, leftlen); + lc = SvPV_force_nomg(left, leftlen); } else { - lc = SvPV_nomg_const(left, leftlen); - SvPV_force_nomg_nolen(sv); + lc = SvPV_nomg_const(left, leftlen); + SvPV_force_nomg_nolen(sv); } rc = SvPV_nomg_const(right, rightlen); @@ -1089,64 +1089,64 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) (void)SvPOK_only(sv); if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) { - dc = SvPV_force_nomg_nolen(sv); - if (SvLEN(sv) < len + 1) { - dc = SvGROW(sv, len + 1); - (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1); - } + dc = SvPV_force_nomg_nolen(sv); + if (SvLEN(sv) < len + 1) { + dc = SvGROW(sv, len + 1); + (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1); + } } else { - needlen = optype == OP_BIT_AND - ? len : (leftlen > rightlen ? leftlen : rightlen); - Newxz(dc, needlen + 1, char); - sv_usepvn_flags(sv, dc, needlen, SV_HAS_TRAILING_NUL); - dc = SvPVX(sv); /* sv_usepvn() calls Renew() */ + needlen = optype == OP_BIT_AND + ? len : (leftlen > rightlen ? leftlen : rightlen); + Newxz(dc, needlen + 1, char); + sv_usepvn_flags(sv, dc, needlen, SV_HAS_TRAILING_NUL); + dc = SvPVX(sv); /* sv_usepvn() calls Renew() */ } SvCUR_set(sv, len); if (len >= sizeof(long)*4 && - !(PTR2nat(dc) % sizeof(long)) && - !(PTR2nat(lc) % sizeof(long)) && - !(PTR2nat(rc) % sizeof(long))) /* It's almost always aligned... */ + !(PTR2nat(dc) % sizeof(long)) && + !(PTR2nat(lc) % sizeof(long)) && + !(PTR2nat(rc) % sizeof(long))) /* It's almost always aligned... */ { - const STRLEN remainder = len % (sizeof(long)*4); - len /= (sizeof(long)*4); - - dl = (long*)dc; - ll = (long*)lc; - rl = (long*)rc; - - switch (optype) { - case OP_BIT_AND: - while (len--) { - *dl++ = *ll++ & *rl++; - *dl++ = *ll++ & *rl++; - *dl++ = *ll++ & *rl++; - *dl++ = *ll++ & *rl++; - } - break; - case OP_BIT_XOR: - while (len--) { - *dl++ = *ll++ ^ *rl++; - *dl++ = *ll++ ^ *rl++; - *dl++ = *ll++ ^ *rl++; - *dl++ = *ll++ ^ *rl++; - } - break; - case OP_BIT_OR: - while (len--) { - *dl++ = *ll++ | *rl++; - *dl++ = *ll++ | *rl++; - *dl++ = *ll++ | *rl++; - *dl++ = *ll++ | *rl++; - } - } - - dc = (char*)dl; - lc = (char*)ll; - rc = (char*)rl; - - len = remainder; + const STRLEN remainder = len % (sizeof(long)*4); + len /= (sizeof(long)*4); + + dl = (long*)dc; + ll = (long*)lc; + rl = (long*)rc; + + switch (optype) { + case OP_BIT_AND: + while (len--) { + *dl++ = *ll++ & *rl++; + *dl++ = *ll++ & *rl++; + *dl++ = *ll++ & *rl++; + *dl++ = *ll++ & *rl++; + } + break; + case OP_BIT_XOR: + while (len--) { + *dl++ = *ll++ ^ *rl++; + *dl++ = *ll++ ^ *rl++; + *dl++ = *ll++ ^ *rl++; + *dl++ = *ll++ ^ *rl++; + } + break; + case OP_BIT_OR: + while (len--) { + *dl++ = *ll++ | *rl++; + *dl++ = *ll++ | *rl++; + *dl++ = *ll++ | *rl++; + *dl++ = *ll++ | *rl++; + } + } + + dc = (char*)dl; + lc = (char*)ll; + rc = (char*)rl; + + len = remainder; } switch (optype) { @@ -1242,42 +1242,42 @@ Perl_do_kv(pTHX) (void)hv_iterinit(keys); /* always reset iterator regardless */ if (gimme == G_VOID) - RETURN; + RETURN; if (gimme == G_SCALAR) { - if (PL_op->op_flags & OPf_MOD || LVRET) { /* lvalue */ - SV * const ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */ - sv_magic(ret, NULL, PERL_MAGIC_nkeys, NULL, 0); - LvTYPE(ret) = 'k'; - LvTARG(ret) = SvREFCNT_inc_simple(keys); - PUSHs(ret); - } - else { - IV i; - dTARGET; + if (PL_op->op_flags & OPf_MOD || LVRET) { /* lvalue */ + SV * const ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */ + sv_magic(ret, NULL, PERL_MAGIC_nkeys, NULL, 0); + LvTYPE(ret) = 'k'; + LvTARG(ret) = SvREFCNT_inc_simple(keys); + PUSHs(ret); + } + else { + IV i; + dTARGET; /* note that in 'scalar(keys %h)' the OP_KEYS is usually * optimised away and the action is performed directly by the * padhv or rv2hv op. We now only get here via OP_AVHVSWITCH * and \&CORE::keys */ - if (! SvTIED_mg((const SV *)keys, PERL_MAGIC_tied) ) { - i = HvUSEDKEYS(keys); - } - else { - i = 0; - while (hv_iternext(keys)) i++; - } - PUSHi( i ); - } - RETURN; + if (! SvTIED_mg((const SV *)keys, PERL_MAGIC_tied) ) { + i = HvUSEDKEYS(keys); + } + else { + i = 0; + while (hv_iternext(keys)) i++; + } + PUSHi( i ); + } + RETURN; } if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) { - const I32 flags = is_lvalue_sub(); - if (flags && !(flags & OPpENTERSUB_INARGS)) - /* diag_listed_as: Can't modify %s in %s */ - Perl_croak(aTHX_ "Can't modify keys in list assignment"); + const I32 flags = is_lvalue_sub(); + if (flags && !(flags & OPpENTERSUB_INARGS)) + /* diag_listed_as: Can't modify %s in %s */ + Perl_croak(aTHX_ "Can't modify keys in list assignment"); } PUTBACK; diff --git a/dosish.h b/dosish.h index 5b2716046d74..74aa1270556e 100644 --- a/dosish.h +++ b/dosish.h @@ -17,7 +17,7 @@ # define BIT_BUCKET "nul" # define OP_BINARY O_BINARY # define PERL_SYS_INIT_BODY(c,v) \ - MALLOC_CHECK_TAINT2(*c,*v) Perl_DJGPP_init(c,v); PERLIO_INIT + MALLOC_CHECK_TAINT2(*c,*v) Perl_DJGPP_init(c,v); PERLIO_INIT # define init_os_extras Perl_init_os_extras # define HAS_UTIME # define HAS_KILL @@ -30,8 +30,8 @@ # define PERL_FS_VER_FMT "%d_%d_%d" # endif # define PERL_FS_VERSION STRINGIFY(PERL_REVISION) "_" \ - STRINGIFY(PERL_VERSION) "_" \ - STRINGIFY(PERL_SUBVERSION) + STRINGIFY(PERL_VERSION) "_" \ + STRINGIFY(PERL_SUBVERSION) #elif defined(WIN32) # define PERL_SYS_INIT_BODY(c,v) \ MALLOC_CHECK_TAINT2(*c,*v) Perl_win32_init(c,v); PERLIO_INIT @@ -70,10 +70,10 @@ * to include and to get any typedef'ed * information. */ -#if defined(WIN64) || defined(USE_LARGE_FILES) -# define Stat_t struct _stati64 +#if defined(WIN32) +# define Stat_t struct w32_stat #else -# define Stat_t struct stat +# define Stat_t struct _stati64 #endif /* USE_STAT_RDEV: diff --git a/dquote.c b/dquote.c index dcbd8c93ac03..a9fa29c9ad22 100644 --- a/dquote.c +++ b/dquote.c @@ -267,8 +267,10 @@ Perl_grok_bslash_o(pTHX_ char **s, const char * const send, UV *uv, * UV_MAX, which is normally illegal, reserved for internal use. * UTF is true iff the string *s is encoded in UTF-8. */ - char* e; + char * e; + char * rbrace; STRLEN numbers_len; + STRLEN trailing_blanks_len = 0; I32 flags = PERL_SCAN_ALLOW_UNDERSCORES | PERL_SCAN_DISALLOW_PREFIX | PERL_SCAN_SILENT_NON_PORTABLE @@ -290,18 +292,35 @@ Perl_grok_bslash_o(pTHX_ char **s, const char * const send, UV *uv, return FALSE; } - e = (char *) memchr(*s, '}', send - *s); - if (!e) { + rbrace = (char *) memchr(*s, '}', send - *s); + if (!rbrace) { (*s)++; /* Move past the '{' */ - while (isOCTAL(**s)) { /* Position beyond the legal digits */ + + /* Position beyond the legal digits and blanks */ + while (*s < send && isBLANK(**s)) { (*s)++; } + + while (*s < send && isOCTAL(**s)) { + (*s)++; + } + *message = "Missing right brace on \\o{}"; return FALSE; } - (*s)++; /* Point to expected first digit (could be first byte of utf8 - sequence if not a digit) */ + /* Point to expected first digit (could be first byte of utf8 sequence if + * not a digit) */ + (*s)++; + while (isBLANK(**s)) { + (*s)++; + } + + e = rbrace; + while (*s < e && isBLANK(*(e - 1))) { + e--; + } + numbers_len = e - *s; if (numbers_len == 0) { (*s)++; /* Move past the '}' */ @@ -314,13 +333,18 @@ Perl_grok_bslash_o(pTHX_ char **s, const char * const send, UV *uv, || (! allow_UV_MAX && *uv == UV_MAX))) { *message = form_cp_too_large_msg(8, *s, numbers_len, 0); - *s = e + 1; + *s = rbrace + 1; return FALSE; } + while (isBLANK(**s)) { + trailing_blanks_len++; + (*s)++; + } + /* Note that if has non-octal, will ignore everything starting with that up * to the '}' */ - if (numbers_len != (STRLEN) (e - *s)) { + if (numbers_len + trailing_blanks_len != (STRLEN) (e - *s)) { *s += numbers_len; if (strict) { *s += (UTF) ? UTF8_SAFE_SKIP(*s, send) : 1; @@ -342,7 +366,7 @@ Perl_grok_bslash_o(pTHX_ char **s, const char * const send, UV *uv, } /* Return past the '}' */ - *s = e + 1; + *s = rbrace + 1; return TRUE; } @@ -391,7 +415,9 @@ Perl_grok_bslash_x(pTHX_ char ** s, const char * const send, UV *uv, * UTF is true iff the string *s is encoded in UTF-8. */ char* e; + char * rbrace; STRLEN numbers_len; + STRLEN trailing_blanks_len = 0; I32 flags = PERL_SCAN_DISALLOW_PREFIX | PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_NOTIFY_ILLDIGIT @@ -452,18 +478,34 @@ Perl_grok_bslash_x(pTHX_ char ** s, const char * const send, UV *uv, return TRUE; } - e = (char *) memchr(*s, '}', send - *s); - if (!e) { + rbrace = (char *) memchr(*s, '}', send - *s); + if (!rbrace) { (*s)++; /* Move past the '{' */ - while (*s < send && isXDIGIT(**s)) { /* Position beyond legal digits */ + + /* Position beyond legal blanks and digits */ + while (*s < send && isBLANK(**s)) { (*s)++; } + + while (*s < send && isXDIGIT(**s)) { + (*s)++; + } + *message = "Missing right brace on \\x{}"; return FALSE; } (*s)++; /* Point to expected first digit (could be first byte of utf8 sequence if not a digit) */ + while (isBLANK(**s)) { + (*s)++; + } + + e = rbrace; + while (*s < e && isBLANK(*(e - 1))) { + e--; + } + numbers_len = e - *s; if (numbers_len == 0) { if (strict) { @@ -471,7 +513,7 @@ Perl_grok_bslash_x(pTHX_ char ** s, const char * const send, UV *uv, *message = "Empty \\x{}"; return FALSE; } - *s = e + 1; + *s = rbrace + 1; *uv = 0; return TRUE; } @@ -487,7 +529,12 @@ Perl_grok_bslash_x(pTHX_ char ** s, const char * const send, UV *uv, return FALSE; } - if (numbers_len != (STRLEN) (e - *s)) { + while (isBLANK(**s)) { + trailing_blanks_len++; + (*s)++; + } + + if (numbers_len + trailing_blanks_len != (STRLEN) (e - *s)) { *s += numbers_len; if (strict) { *s += (UTF) ? UTF8_SAFE_SKIP(*s, send) : 1; @@ -509,7 +556,7 @@ Perl_grok_bslash_x(pTHX_ char ** s, const char * const send, UV *uv, } /* Return past the '}' */ - *s = e + 1; + *s = rbrace + 1; return TRUE; } diff --git a/dump.c b/dump.c index 0004f4995914..bb5f53354380 100644 --- a/dump.c +++ b/dump.c @@ -75,11 +75,11 @@ struct flag_to_name { static void S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start, - const struct flag_to_name *const end) + const struct flag_to_name *const end) { do { - if (flags & start->flag) - sv_catpv(sv, start->name); + if (flags & start->flag) + sv_catpv(sv, start->name); } while (++start < end); } @@ -172,7 +172,7 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str, PERL_ARGS_ASSERT_PV_ESCAPE; if (dsv && !(flags & PERL_PV_ESCAPE_NOCLEAR)) { - /* This won't alter the UTF-8 flag */ + /* This won't alter the UTF-8 flag */ SvPVCLEAR(dsv); } @@ -184,9 +184,9 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str, const U8 c = (U8)u & 0xFF; if ( ( u > 255 ) - || (flags & PERL_PV_ESCAPE_ALL) - || (( ! isASCII(u) ) && (flags & (PERL_PV_ESCAPE_NONASCII|PERL_PV_ESCAPE_DWIM)))) - { + || (flags & PERL_PV_ESCAPE_ALL) + || (( ! isASCII(u) ) && (flags & (PERL_PV_ESCAPE_NONASCII|PERL_PV_ESCAPE_DWIM)))) + { if (flags & PERL_PV_ESCAPE_FIRSTCHAR) chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, "%" UVxf, u); @@ -200,28 +200,28 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str, chsize = 1; } else { if ( (c == dq) || (c == esc) || !isPRINT(c) ) { - chsize = 2; + 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 '\\' : /* 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] = '"'; + octbuf[1] = '"'; else chsize = 1; break; - default: + default: if ( (flags & PERL_PV_ESCAPE_DWIM) && c != '\0' ) { chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, isuni ? "%cx{%02" UVxf "}" : "%cx%02" UVxf, @@ -237,24 +237,24 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str, } else { chsize = 1; } - } - if ( max && (wrote + chsize > max) ) { - break; + } + if ( max && (wrote + chsize > max) ) { + break; } else if (chsize > 1) { if (dsv) sv_catpvn(dsv, octbuf, chsize); wrote += chsize; - } else { - /* If PERL_PV_ESCAPE_NOBACKSLASH is set then non-ASCII bytes - can be appended raw to the dsv. If dsv happens to be - UTF-8 then we need catpvf to upgrade them for us. - Or add a new API call sv_catpvc(). Think about that name, and - how to keep it clear that it's unlike the s of catpvs, which is - really an array of octets, not a string. */ + } else { + /* If PERL_PV_ESCAPE_NOBACKSLASH is set then non-ASCII bytes + can be appended raw to the dsv. If dsv happens to be + UTF-8 then we need catpvf to upgrade them for us. + Or add a new API call sv_catpvc(). Think about that name, and + how to keep it clear that it's unlike the s of catpvs, which is + really an array of octets, not a string. */ if (dsv) Perl_sv_catpvf( aTHX_ dsv, "%c", c); - wrote++; - } + wrote++; + } if ( flags & PERL_PV_ESCAPE_FIRSTCHAR ) break; } @@ -335,7 +335,7 @@ Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count, Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[1]); if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) ) - sv_catpvs(dsv, "..."); + sv_catpvs(dsv, "..."); if ((flags & PERL_PV_PRETTY_EXACTSIZE)) { while( SvCUR(dsv) - orig_cur < max ) @@ -381,80 +381,80 @@ Perl_sv_peek(pTHX_ SV *sv) SvPVCLEAR(t); retry: if (!sv) { - sv_catpvs(t, "VOID"); - goto finish; + sv_catpvs(t, "VOID"); + goto finish; } else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') { /* detect data corruption under memory poisoning */ - sv_catpvs(t, "WILD"); - goto finish; + sv_catpvs(t, "WILD"); + goto finish; } else if ( sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_zero || sv == &PL_sv_placeholder) { - if (sv == &PL_sv_undef) { - sv_catpvs(t, "SV_UNDEF"); - if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT| - SVs_GMG|SVs_SMG|SVs_RMG)) && - SvREADONLY(sv)) - goto finish; - } - else if (sv == &PL_sv_no) { - sv_catpvs(t, "SV_NO"); - if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| - SVs_GMG|SVs_SMG|SVs_RMG)) && - !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| - SVp_POK|SVp_NOK)) && - SvCUR(sv) == 0 && - SvNVX(sv) == 0.0) - goto finish; - } - else if (sv == &PL_sv_yes) { - sv_catpvs(t, "SV_YES"); - if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| - SVs_GMG|SVs_SMG|SVs_RMG)) && - !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| - SVp_POK|SVp_NOK)) && - SvCUR(sv) == 1 && - SvPVX_const(sv) && *SvPVX_const(sv) == '1' && - SvNVX(sv) == 1.0) - goto finish; - } - else if (sv == &PL_sv_zero) { - sv_catpvs(t, "SV_ZERO"); - if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| - SVs_GMG|SVs_SMG|SVs_RMG)) && - !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| - SVp_POK|SVp_NOK)) && - SvCUR(sv) == 1 && - SvPVX_const(sv) && *SvPVX_const(sv) == '0' && - SvNVX(sv) == 0.0) - goto finish; - } - else { - sv_catpvs(t, "SV_PLACEHOLDER"); - if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT| - SVs_GMG|SVs_SMG|SVs_RMG)) && - SvREADONLY(sv)) - goto finish; - } - sv_catpvs(t, ":"); + if (sv == &PL_sv_undef) { + sv_catpvs(t, "SV_UNDEF"); + if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT| + SVs_GMG|SVs_SMG|SVs_RMG)) && + SvREADONLY(sv)) + goto finish; + } + else if (sv == &PL_sv_no) { + sv_catpvs(t, "SV_NO"); + if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| + SVs_GMG|SVs_SMG|SVs_RMG)) && + !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| + SVp_POK|SVp_NOK)) && + SvCUR(sv) == 0 && + SvNVX(sv) == 0.0) + goto finish; + } + else if (sv == &PL_sv_yes) { + sv_catpvs(t, "SV_YES"); + if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| + SVs_GMG|SVs_SMG|SVs_RMG)) && + !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| + SVp_POK|SVp_NOK)) && + SvCUR(sv) == 1 && + SvPVX_const(sv) && *SvPVX_const(sv) == '1' && + SvNVX(sv) == 1.0) + goto finish; + } + else if (sv == &PL_sv_zero) { + sv_catpvs(t, "SV_ZERO"); + if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| + SVs_GMG|SVs_SMG|SVs_RMG)) && + !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| + SVp_POK|SVp_NOK)) && + SvCUR(sv) == 1 && + SvPVX_const(sv) && *SvPVX_const(sv) == '0' && + SvNVX(sv) == 0.0) + goto finish; + } + else { + sv_catpvs(t, "SV_PLACEHOLDER"); + if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT| + SVs_GMG|SVs_SMG|SVs_RMG)) && + SvREADONLY(sv)) + goto finish; + } + sv_catpvs(t, ":"); } else if (SvREFCNT(sv) == 0) { - sv_catpvs(t, "("); - unref++; + sv_catpvs(t, "("); + unref++; } else if (DEBUG_R_TEST_) { - int is_tmp = 0; - SSize_t ix; - /* is this SV on the tmps stack? */ - for (ix=PL_tmps_ix; ix>=0; ix--) { - if (PL_tmps_stack[ix] == sv) { - is_tmp = 1; - break; - } - } - if (is_tmp || SvREFCNT(sv) > 1) { + int is_tmp = 0; + SSize_t ix; + /* is this SV on the tmps stack? */ + for (ix=PL_tmps_ix; ix>=0; ix--) { + if (PL_tmps_stack[ix] == sv) { + is_tmp = 1; + break; + } + } + if (is_tmp || SvREFCNT(sv) > 1) { Perl_sv_catpvf(aTHX_ t, "<"); if (SvREFCNT(sv) > 1) Perl_sv_catpvf(aTHX_ t, "%" UVuf, (UV)SvREFCNT(sv)); @@ -465,15 +465,15 @@ Perl_sv_peek(pTHX_ SV *sv) } if (SvROK(sv)) { - sv_catpvs(t, "\\"); - if (SvCUR(t) + unref > 10) { - SvCUR_set(t, unref + 3); - *SvEND(t) = '\0'; - sv_catpvs(t, "..."); - goto finish; - } - sv = SvRV(sv); - goto retry; + sv_catpvs(t, "\\"); + if (SvCUR(t) + unref > 10) { + SvCUR_set(t, unref + 3); + *SvEND(t) = '\0'; + sv_catpvs(t, "..."); + goto finish; + } + sv = SvRV(sv); + goto retry; } type = SvTYPE(sv); if (type == SVt_PVCV) { @@ -482,56 +482,56 @@ Perl_sv_peek(pTHX_ SV *sv) Perl_sv_catpvf(aTHX_ t, "CV(%s)", gvcv ? generic_pv_escape( tmp, GvNAME(gvcv), GvNAMELEN(gvcv), GvNAMEUTF8(gvcv)) : ""); - goto finish; + goto finish; } else if (type < SVt_LAST) { - sv_catpv(t, svshorttypenames[type]); + sv_catpv(t, svshorttypenames[type]); - if (type == SVt_NULL) - goto finish; + if (type == SVt_NULL) + goto finish; } else { - sv_catpvs(t, "FREED"); - goto finish; + sv_catpvs(t, "FREED"); + goto finish; } if (SvPOKp(sv)) { - if (!SvPVX_const(sv)) - sv_catpvs(t, "(null)"); - else { - SV * const tmp = newSVpvs(""); - sv_catpvs(t, "("); - if (SvOOK(sv)) { - STRLEN delta; - SvOOK_offset(sv, delta); - Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127)); - } - Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127)); - if (SvUTF8(sv)) - Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]", - sv_uni_display(tmp, sv, 6 * SvCUR(sv), - UNI_DISPLAY_QQ)); - SvREFCNT_dec_NN(tmp); - } + if (!SvPVX_const(sv)) + sv_catpvs(t, "(null)"); + else { + SV * const tmp = newSVpvs(""); + sv_catpvs(t, "("); + if (SvOOK(sv)) { + STRLEN delta; + SvOOK_offset(sv, delta); + Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127)); + } + Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127)); + if (SvUTF8(sv)) + Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]", + sv_uni_display(tmp, sv, 6 * SvCUR(sv), + UNI_DISPLAY_QQ)); + SvREFCNT_dec_NN(tmp); + } } else if (SvNOKp(sv)) { DECLARATION_FOR_LC_NUMERIC_MANIPULATION; STORE_LC_NUMERIC_SET_STANDARD(); - Perl_sv_catpvf(aTHX_ t, "(%" NVgf ")",SvNVX(sv)); + Perl_sv_catpvf(aTHX_ t, "(%" NVgf ")",SvNVX(sv)); RESTORE_LC_NUMERIC(); } else if (SvIOKp(sv)) { - if (SvIsUV(sv)) - Perl_sv_catpvf(aTHX_ t, "(%" UVuf ")", (UV)SvUVX(sv)); - else + if (SvIsUV(sv)) + Perl_sv_catpvf(aTHX_ t, "(%" UVuf ")", (UV)SvUVX(sv)); + else Perl_sv_catpvf(aTHX_ t, "(%" IVdf ")", (IV)SvIVX(sv)); } else - sv_catpvs(t, "()"); + sv_catpvs(t, "()"); finish: while (unref--) - sv_catpvs(t, ")"); + sv_catpvs(t, ")"); if (TAINTING_get && sv && SvTAINTED(sv)) - sv_catpvs(t, " [tainted]"); + sv_catpvs(t, " [tainted]"); return SvPV_nolen(t); } @@ -609,7 +609,7 @@ S_opdump_indent(pTHX_ const OP *o, I32 level, UV bar, PerlIO *file, } else - PerlIO_printf(file, " "); + PerlIO_printf(file, " "); for (i = level-1; i >= 0; i--) PerlIO_puts(file, @@ -660,7 +660,7 @@ Perl_dump_all_perl(pTHX_ bool justperl) { PerlIO_setlinebuf(Perl_debug_log); if (PL_main_root) - op_dump(PL_main_root); + op_dump(PL_main_root); dump_packsubs_perl(PL_defstash, justperl); } @@ -687,26 +687,26 @@ Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl) PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL; if (!HvARRAY(stash)) - return; + return; for (i = 0; i <= (I32) HvMAX(stash); i++) { const HE *entry; - for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { - GV * gv = (GV *)HeVAL(entry); + for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { + GV * gv = (GV *)HeVAL(entry); if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) /* unfake a fake GV */ (void)CvGV(SvRV(gv)); - if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv)) - continue; - if (GvCVu(gv)) - dump_sub_perl(gv, justperl); - if (GvFORM(gv)) - dump_form(gv); - if (HeKEY(entry)[HeKLEN(entry)-1] == ':') { - const HV * const hv = GvHV(gv); - if (hv && (hv != PL_defstash)) - dump_packsubs_perl(hv, justperl); /* nested package */ - } - } + if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv)) + continue; + if (GvCVu(gv)) + dump_sub_perl(gv, justperl); + if (GvFORM(gv)) + dump_form(gv); + if (HeKEY(entry)[HeKLEN(entry)-1] == ':') { + const HV * const hv = GvHV(gv); + if (hv && (hv != PL_defstash)) + dump_packsubs_perl(hv, justperl); /* nested package */ + } + } } } @@ -725,30 +725,30 @@ Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl) PERL_ARGS_ASSERT_DUMP_SUB_PERL; cv = isGV_with_GP(gv) ? GvCV(gv) : - (assert(SvROK((SV*)gv)), (CV*)SvRV((SV*)gv)); + (assert(SvROK((SV*)gv)), (CV*)SvRV((SV*)gv)); if (justperl && (CvISXSUB(cv) || !CvROOT(cv))) - return; + return; if (isGV_with_GP(gv)) { - SV * const namesv = newSVpvs_flags("", SVs_TEMP); - SV *escsv = newSVpvs_flags("", SVs_TEMP); - const char *namepv; - STRLEN namelen; - gv_fullname3(namesv, gv, NULL); - namepv = SvPV_const(namesv, namelen); - Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", - generic_pv_escape(escsv, namepv, namelen, SvUTF8(namesv))); + SV * const namesv = newSVpvs_flags("", SVs_TEMP); + SV *escsv = newSVpvs_flags("", SVs_TEMP); + const char *namepv; + STRLEN namelen; + gv_fullname3(namesv, gv, NULL); + namepv = SvPV_const(namesv, namelen); + Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", + generic_pv_escape(escsv, namepv, namelen, SvUTF8(namesv))); } else { - Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB = "); + Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB = "); } if (CvISXSUB(cv)) - Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%" UVxf " %d)\n", - PTR2UV(CvXSUB(cv)), - (int)CvXSUBANY(cv).any_i32); + Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%" UVxf " %d)\n", + PTR2UV(CvXSUB(cv)), + (int)CvXSUBANY(cv).any_i32); else if (CvROOT(cv)) - op_dump(CvROOT(cv)); + op_dump(CvROOT(cv)); else - Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\n"); + Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\n"); } void @@ -761,9 +761,9 @@ Perl_dump_form(pTHX_ const GV *gv) gv_fullname3(sv, gv, NULL); Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv)); if (CvROOT(GvFORM(gv))) - op_dump(CvROOT(GvFORM(gv))); + op_dump(CvROOT(GvFORM(gv))); else - Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\n"); + Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\n"); } void @@ -815,23 +815,23 @@ S_do_pmop_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const PMOP *pm) UV kidbar; if (!pm) - return; + return; kidbar = ((bar << 1) | cBOOL(pm->op_flags & OPf_KIDS)) << 1; if (PM_GETRE(pm)) { char ch = (pm->op_pmflags & PMf_ONCE) ? '?' : '/'; - S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE %c%.*s%c\n", - ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch); + S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE %c%.*s%c\n", + ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch); } else - S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE (RUNTIME)\n"); + S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE (RUNTIME)\n"); if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) { - SV * const tmpsv = pm_description(pm); - S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMFLAGS = (%s)\n", + SV * const tmpsv = pm_description(pm); + S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : ""); - SvREFCNT_dec_NN(tmpsv); + SvREFCNT_dec_NN(tmpsv); } if (pm->op_type == OP_SPLIT) @@ -841,21 +841,21 @@ S_do_pmop_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const PMOP *pm) else { if (pm->op_pmreplrootu.op_pmreplroot) { S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_REPL =\n"); - S_do_op_dump_bar(aTHX_ level + 2, + S_do_op_dump_bar(aTHX_ level + 2, (kidbar|cBOOL(OpHAS_SIBLING(pm->op_pmreplrootu.op_pmreplroot))), file, pm->op_pmreplrootu.op_pmreplroot); } } if (pm->op_code_list) { - if (pm->op_pmflags & PMf_CODELIST_PRIVATE) { - S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "CODE_LIST =\n"); - S_do_op_dump_bar(aTHX_ level + 2, + if (pm->op_pmflags & PMf_CODELIST_PRIVATE) { + S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "CODE_LIST =\n"); + S_do_op_dump_bar(aTHX_ level + 2, (kidbar | cBOOL(OpHAS_SIBLING(pm->op_code_list))), file, pm->op_code_list); - } - else - S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, + } + else + S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "CODE_LIST = 0x%" UVxf "\n", PTR2UV(pm->op_code_list)); } } @@ -892,7 +892,7 @@ S_pm_description(pTHX_ const PMOP *pm) PERL_ARGS_ASSERT_PM_DESCRIPTION; if (pmflags & PMf_ONCE) - sv_catpvs(desc, ",ONCE"); + sv_catpvs(desc, ",ONCE"); #ifdef USE_ITHREADS if (SvREADONLY(PL_regex_pad[pm->op_pmoffset])) sv_catpvs(desc, ":USED"); @@ -937,15 +937,15 @@ S_sequence_num(pTHX_ const OP *o) const char *key; STRLEN len; if (!o) - return 0; + return 0; op = newSVuv(PTR2UV(o)); sv_2mortal(op); key = SvPV_const(op, len); if (!PL_op_sequence) - PL_op_sequence = newHV(); + PL_op_sequence = newHV(); seq = hv_fetch(PL_op_sequence, key, len, 0); if (seq) - return SvUV(*seq); + return SvUV(*seq); (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0); return PL_op_seq; } @@ -1042,7 +1042,7 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) } if (o->op_targ && optype != OP_NULL) - S_opdump_indent(aTHX_ o, level, bar, file, "TARG = %ld\n", + S_opdump_indent(aTHX_ o, level, bar, file, "TARG = %ld\n", (long)o->op_targ); if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) { @@ -1150,10 +1150,10 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)oppriv); } } - if (tmpsv && SvCUR(tmpsv)) { + if (tmpsv && SvCUR(tmpsv)) { S_opdump_indent(aTHX_ o, level, bar, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1); - } else + } else S_opdump_indent(aTHX_ o, level, bar, file, "PRIVATE = (0x%" UVxf ")\n", (UV)oppriv); } @@ -1163,36 +1163,36 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) case OP_GVSV: case OP_GV: #ifdef USE_ITHREADS - S_opdump_indent(aTHX_ o, level, bar, file, + S_opdump_indent(aTHX_ o, level, bar, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix); #else S_opdump_indent(aTHX_ o, level, bar, file, "GV = %" SVf " (0x%" UVxf ")\n", SVfARG(S_gv_display(aTHX_ cGVOPo_gv)), PTR2UV(cGVOPo_gv)); #endif - break; + break; case OP_MULTIDEREF: { UNOP_AUX_item *items = cUNOP_AUXo->op_aux; UV i, count = items[-1].uv; - S_opdump_indent(aTHX_ o, level, bar, file, "ARGS = \n"); + S_opdump_indent(aTHX_ o, level, bar, file, "ARGS = \n"); for (i=0; i < count; i++) S_opdump_indent(aTHX_ o, level+1, (bar << 1), file, "%" UVuf " => 0x%" UVxf "\n", i, items[i].uv); - break; + break; } case OP_MULTICONCAT: - S_opdump_indent(aTHX_ o, level, bar, file, "NARGS = %" IVdf "\n", + S_opdump_indent(aTHX_ o, level, bar, file, "NARGS = %" IVdf "\n", (IV)cUNOP_AUXo->op_aux[PERL_MULTICONCAT_IX_NARGS].ssize); /* XXX really ought to dump each field individually, * but that's too much like hard work */ - S_opdump_indent(aTHX_ o, level, bar, file, "CONSTS = (%" SVf ")\n", + S_opdump_indent(aTHX_ o, level, bar, file, "CONSTS = (%" SVf ")\n", SVfARG(multiconcat_stringify(o))); - break; + break; case OP_CONST: case OP_HINTSEVAL: @@ -1201,21 +1201,21 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) case OP_METHOD_REDIR: case OP_METHOD_REDIR_SUPER: #ifndef USE_ITHREADS - /* with ITHREADS, consts are stored in the pad, and the right pad - * may not be active here, so skip */ - S_opdump_indent(aTHX_ o, level, bar, file, "SV = %s\n", + /* with ITHREADS, consts are stored in the pad, and the right pad + * may not be active here, so skip */ + S_opdump_indent(aTHX_ o, level, bar, file, "SV = %s\n", SvPEEK(cMETHOPx_meth(o))); #endif - break; + break; case OP_NULL: - if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE) - break; - /* FALLTHROUGH */ + if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE) + break; + /* FALLTHROUGH */ case OP_NEXTSTATE: case OP_DBSTATE: - if (CopLINE(cCOPo)) - S_opdump_indent(aTHX_ o, level, bar, file, "LINE = %" UVuf "\n", - (UV)CopLINE(cCOPo)); + if (CopLINE(cCOPo)) + S_opdump_indent(aTHX_ o, level, bar, file, "LINE = %" UVuf "\n", + (UV)CopLINE(cCOPo)); if (CopSTASHPV(cCOPo)) { SV* tmpsv = newSVpvs_flags("", SVs_TEMP); @@ -1240,17 +1240,17 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) S_opdump_indent(aTHX_ o, level, bar, file, "SEQ = %u\n", (unsigned int)cCOPo->cop_seq); - break; + break; case OP_ENTERITER: case OP_ENTERLOOP: - S_opdump_indent(aTHX_ o, level, bar, file, "REDO"); + S_opdump_indent(aTHX_ o, level, bar, file, "REDO"); S_opdump_link(aTHX_ o, cLOOPo->op_redoop, file); - S_opdump_indent(aTHX_ o, level, bar, file, "NEXT"); + S_opdump_indent(aTHX_ o, level, bar, file, "NEXT"); S_opdump_link(aTHX_ o, cLOOPo->op_nextop, file); - S_opdump_indent(aTHX_ o, level, bar, file, "LAST"); + S_opdump_indent(aTHX_ o, level, bar, file, "LAST"); S_opdump_link(aTHX_ o, cLOOPo->op_lastop, file); - break; + break; case OP_REGCOMP: case OP_SUBSTCONT: @@ -1269,33 +1269,33 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) case OP_ENTERWHEN: case OP_ENTERTRY: case OP_ONCE: - S_opdump_indent(aTHX_ o, level, bar, file, "OTHER"); + S_opdump_indent(aTHX_ o, level, bar, file, "OTHER"); S_opdump_link(aTHX_ o, cLOGOPo->op_other, file); - break; + break; case OP_SPLIT: case OP_MATCH: case OP_QR: case OP_SUBST: - S_do_pmop_dump_bar(aTHX_ level, bar, file, cPMOPo); - break; + S_do_pmop_dump_bar(aTHX_ level, bar, file, cPMOPo); + break; case OP_LEAVE: case OP_LEAVEEVAL: case OP_LEAVESUB: case OP_LEAVESUBLV: case OP_LEAVEWRITE: case OP_SCOPE: - if (o->op_private & OPpREFCOUNTED) - S_opdump_indent(aTHX_ o, level, bar, file, + if (o->op_private & OPpREFCOUNTED) + S_opdump_indent(aTHX_ o, level, bar, file, "REFCNT = %" UVuf "\n", (UV)o->op_targ); - break; + break; case OP_DUMP: case OP_GOTO: case OP_NEXT: case OP_LAST: case OP_REDO: - if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS)) - break; + if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS)) + break; { SV * const label = newSVpvs_flags("", SVs_TEMP); generic_pv_escape(label, cPVOPo->op_pv, strlen(cPVOPo->op_pv), 0); @@ -1310,8 +1310,8 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) if (o->op_private & OPpTRANS_USE_SVOP) { /* utf8: table stored as an inversion map */ #ifndef USE_ITHREADS - /* with ITHREADS, it is stored in the pad, and the right pad - * may not be active here, so skip */ + /* with ITHREADS, it is stored in the pad, and the right pad + * may not be active here, so skip */ S_opdump_indent(aTHX_ o, level, bar, file, "INVMAP = 0x%" UVxf "\n", PTR2UV(MUTABLE_SV(cSVOPo->op_sv))); @@ -1346,14 +1346,14 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) default: - break; + break; } if (o->op_flags & OPf_KIDS) { - OP *kid; + OP *kid; level++; bar <<= 1; - for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) - S_do_op_dump_bar(aTHX_ level, + for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) + S_do_op_dump_bar(aTHX_ level, (bar | cBOOL(OpHAS_SIBLING(kid))), file, kid); } @@ -1390,8 +1390,8 @@ Perl_gv_dump(pTHX_ GV *gv) SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP); if (!gv) { - PerlIO_printf(Perl_debug_log, "{}\n"); - return; + PerlIO_printf(Perl_debug_log, "{}\n"); + return; } sv = sv_newmortal(); PerlIO_printf(Perl_debug_log, "{\n"); @@ -1400,7 +1400,7 @@ Perl_gv_dump(pTHX_ GV *gv) Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", generic_pv_escape( tmp, name, len, SvUTF8(sv) )); if (gv != GvEGV(gv)) { - gv_efullname3(sv, GvEGV(gv), NULL); + gv_efullname3(sv, GvEGV(gv), NULL); name = SvPV_const(sv, len); Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", generic_pv_escape( tmp, name, len, SvUTF8(sv) )); @@ -1416,8 +1416,8 @@ Perl_gv_dump(pTHX_ GV *gv) static const struct { const char type; const char *name; } magic_names[] = { #include "mg_names.inc" - /* this null string terminates the list */ - { 0, NULL }, + /* this null string terminates the list */ + { 0, NULL }, }; void @@ -1427,120 +1427,120 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 for (; mg; mg = mg->mg_moremagic) { Perl_dump_indent(aTHX_ level, file, - " MAGIC = 0x%" UVxf "\n", PTR2UV(mg)); + " MAGIC = 0x%" UVxf "\n", PTR2UV(mg)); if (mg->mg_virtual) { const MGVTBL * const v = mg->mg_virtual; - if (v >= PL_magic_vtables - && v < PL_magic_vtables + magic_vtable_max) { - const U32 i = v - PL_magic_vtables; - Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]); - } - else - Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%" + if (v >= PL_magic_vtables + && v < PL_magic_vtables + magic_vtable_max) { + const U32 i = v - PL_magic_vtables; + Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]); + } + else + Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%" UVxf "\n", PTR2UV(v)); } - else - Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n"); - - if (mg->mg_private) - Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private); - - { - int n; - const char *name = NULL; - for (n = 0; magic_names[n].name; n++) { - if (mg->mg_type == magic_names[n].type) { - name = magic_names[n].name; - break; - } - } - if (name) - Perl_dump_indent(aTHX_ level, file, - " MG_TYPE = PERL_MAGIC_%s\n", name); - else - Perl_dump_indent(aTHX_ level, file, - " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type); - } + else + Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n"); + + if (mg->mg_private) + Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private); + + { + int n; + const char *name = NULL; + for (n = 0; magic_names[n].name; n++) { + if (mg->mg_type == magic_names[n].type) { + name = magic_names[n].name; + break; + } + } + if (name) + Perl_dump_indent(aTHX_ level, file, + " MG_TYPE = PERL_MAGIC_%s\n", name); + else + Perl_dump_indent(aTHX_ level, file, + " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type); + } if (mg->mg_flags) { Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags); - if (mg->mg_type == PERL_MAGIC_envelem && - mg->mg_flags & MGf_TAINTEDDIR) - Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n"); - if (mg->mg_type == PERL_MAGIC_regex_global && - mg->mg_flags & MGf_MINMATCH) - Perl_dump_indent(aTHX_ level, file, " MINMATCH\n"); - if (mg->mg_flags & MGf_REFCOUNTED) - Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n"); + if (mg->mg_type == PERL_MAGIC_envelem && + mg->mg_flags & MGf_TAINTEDDIR) + Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n"); + if (mg->mg_type == PERL_MAGIC_regex_global && + mg->mg_flags & MGf_MINMATCH) + Perl_dump_indent(aTHX_ level, file, " MINMATCH\n"); + if (mg->mg_flags & MGf_REFCOUNTED) + Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n"); if (mg->mg_flags & MGf_GSKIP) - Perl_dump_indent(aTHX_ level, file, " GSKIP\n"); - if (mg->mg_flags & MGf_COPY) - Perl_dump_indent(aTHX_ level, file, " COPY\n"); - if (mg->mg_flags & MGf_DUP) - Perl_dump_indent(aTHX_ level, file, " DUP\n"); - if (mg->mg_flags & MGf_LOCAL) - Perl_dump_indent(aTHX_ level, file, " LOCAL\n"); - if (mg->mg_type == PERL_MAGIC_regex_global && - mg->mg_flags & MGf_BYTES) - Perl_dump_indent(aTHX_ level, file, " BYTES\n"); + Perl_dump_indent(aTHX_ level, file, " GSKIP\n"); + if (mg->mg_flags & MGf_COPY) + Perl_dump_indent(aTHX_ level, file, " COPY\n"); + if (mg->mg_flags & MGf_DUP) + Perl_dump_indent(aTHX_ level, file, " DUP\n"); + if (mg->mg_flags & MGf_LOCAL) + Perl_dump_indent(aTHX_ level, file, " LOCAL\n"); + if (mg->mg_type == PERL_MAGIC_regex_global && + mg->mg_flags & MGf_BYTES) + Perl_dump_indent(aTHX_ level, file, " BYTES\n"); } - if (mg->mg_obj) { - Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%" UVxf "\n", - PTR2UV(mg->mg_obj)); + if (mg->mg_obj) { + Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%" UVxf "\n", + PTR2UV(mg->mg_obj)); if (mg->mg_type == PERL_MAGIC_qr) { - REGEXP* const re = (REGEXP *)mg->mg_obj; - SV * const dsv = sv_newmortal(); + REGEXP* const re = (REGEXP *)mg->mg_obj; + SV * const dsv = sv_newmortal(); const char * const s - = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re), + = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re), 60, NULL, NULL, ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES | (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0)) ); - Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s); - Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %" IVdf "\n", - (IV)RX_REFCNT(re)); + Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s); + Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %" IVdf "\n", + (IV)RX_REFCNT(re)); } if (mg->mg_flags & MGf_REFCOUNTED) - do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */ - } + do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */ + } if (mg->mg_len) - Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len); + Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len); if (mg->mg_ptr) { - Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%" UVxf, PTR2UV(mg->mg_ptr)); - if (mg->mg_len >= 0) { - if (mg->mg_type != PERL_MAGIC_utf8) { - SV * const sv = newSVpvs(""); - PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim)); - SvREFCNT_dec_NN(sv); - } + Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%" UVxf, PTR2UV(mg->mg_ptr)); + if (mg->mg_len >= 0) { + if (mg->mg_type != PERL_MAGIC_utf8) { + SV * const sv = newSVpvs(""); + PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim)); + SvREFCNT_dec_NN(sv); + } + } + else if (mg->mg_len == HEf_SVKEY) { + PerlIO_puts(file, " => HEf_SVKEY\n"); + do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1, + maxnest, dumpops, pvlim); /* MG is already +1 */ + continue; } - else if (mg->mg_len == HEf_SVKEY) { - PerlIO_puts(file, " => HEf_SVKEY\n"); - do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1, - maxnest, dumpops, pvlim); /* MG is already +1 */ - continue; - } - else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8); - else - PerlIO_puts( - file, - " ???? - " __FILE__ - " does not know how to handle this MG_LEN" - ); + else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8); + else + PerlIO_puts( + file, + " ???? - " __FILE__ + " does not know how to handle this MG_LEN" + ); (void)PerlIO_putc(file, '\n'); } - if (mg->mg_type == PERL_MAGIC_utf8) { - const STRLEN * const cache = (STRLEN *) mg->mg_ptr; - if (cache) { - IV i; - for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++) - Perl_dump_indent(aTHX_ level, file, - " %2" IVdf ": %" UVuf " -> %" UVuf "\n", - i, - (UV)cache[i * 2], - (UV)cache[i * 2 + 1]); - } - } + if (mg->mg_type == PERL_MAGIC_utf8) { + const STRLEN * const cache = (STRLEN *) mg->mg_ptr; + if (cache) { + IV i; + for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++) + Perl_dump_indent(aTHX_ level, file, + " %2" IVdf ": %" UVuf " -> %" UVuf "\n", + i, + (UV)cache[i * 2], + (UV)cache[i * 2 + 1]); + } + } } } @@ -1560,7 +1560,7 @@ Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv) Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv)); if (sv && (hvname = HvNAME_get(sv))) { - /* we have to use pv_display and HvNAMELEN_get() so that we display the real package + /* we have to use pv_display and HvNAMELEN_get() so that we display the real package name which quite legally could contain insane things like tabs, newlines, nulls or other scary crap - this should produce sane results - except maybe for unicode package names - but we will wait for someone to file a bug on that - demerphq */ @@ -1596,11 +1596,11 @@ Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv) Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv)); if (sv && GvNAME(sv)) { SV *tmp = newSVpvs_flags("", SVs_TEMP); - const char *hvname; + const char *hvname; HV * const stash = GvSTASH(sv); - PerlIO_printf(file, "\t"); + PerlIO_printf(file, "\t"); /* TODO might have an extra \" here */ - if (stash && (hvname = HvNAME_get(stash))) { + if (stash && (hvname = HvNAME_get(stash))) { PerlIO_printf(file, "\"%s\" :: \"", generic_pv_escape(tmp, hvname, HvNAMELEN(stash), HvNAMEUTF8(stash))); @@ -1743,8 +1743,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo PERL_ARGS_ASSERT_DO_SV_DUMP; if (!sv) { - Perl_dump_indent(aTHX_ level, file, "SV = 0\n"); - return; + Perl_dump_indent(aTHX_ level, file, "SV = 0\n"); + return; } flags = SvFLAGS(sv); @@ -1753,28 +1753,28 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo /* process general SV flags */ d = Perl_newSVpvf(aTHX_ - "(0x%" UVxf ") at 0x%" UVxf "\n%*s REFCNT = %" IVdf "\n%*s FLAGS = (", - PTR2UV(SvANY(sv)), PTR2UV(sv), - (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv), - (int)(PL_dumpindent*level), ""); + "(0x%" UVxf ") at 0x%" UVxf "\n%*s REFCNT = %" IVdf "\n%*s FLAGS = (", + PTR2UV(SvANY(sv)), PTR2UV(sv), + (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv), + (int)(PL_dumpindent*level), ""); if ((flags & SVs_PADSTALE)) - sv_catpvs(d, "PADSTALE,"); + sv_catpvs(d, "PADSTALE,"); if ((flags & SVs_PADTMP)) - sv_catpvs(d, "PADTMP,"); + sv_catpvs(d, "PADTMP,"); append_flags(d, flags, first_sv_flags_names); if (flags & SVf_ROK) { sv_catpvs(d, "ROK,"); - if (SvWEAKREF(sv)) sv_catpvs(d, "WEAKREF,"); + if (SvWEAKREF(sv)) sv_catpvs(d, "WEAKREF,"); } if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,"); append_flags(d, flags, second_sv_flags_names); if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv) - && type != SVt_PVAV) { - if (SvPCS_IMPORTED(sv)) - sv_catpvs(d, "PCS_IMPORTED,"); - else - sv_catpvs(d, "SCREAM,"); + && type != SVt_PVAV) { + if (SvPCS_IMPORTED(sv)) + sv_catpvs(d, "PCS_IMPORTED,"); + else + sv_catpvs(d, "SCREAM,"); } /* process type-specific SV flags */ @@ -1782,34 +1782,34 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo switch (type) { case SVt_PVCV: case SVt_PVFM: - append_flags(d, CvFLAGS(sv), cv_flags_names); - break; + append_flags(d, CvFLAGS(sv), cv_flags_names); + break; case SVt_PVHV: - append_flags(d, flags, hv_flags_names); - break; + append_flags(d, flags, hv_flags_names); + break; case SVt_PVGV: case SVt_PVLV: - if (isGV_with_GP(sv)) { - append_flags(d, GvFLAGS(sv), gp_flags_names); - } - if (isGV_with_GP(sv) && GvIMPORTED(sv)) { - sv_catpvs(d, "IMPORT"); - if (GvIMPORTED(sv) == GVf_IMPORTED) - sv_catpvs(d, "ALL,"); - else { - sv_catpvs(d, "("); - append_flags(d, GvFLAGS(sv), gp_flags_imported_names); - sv_catpvs(d, " ),"); - } - } - /* FALLTHROUGH */ + if (isGV_with_GP(sv)) { + append_flags(d, GvFLAGS(sv), gp_flags_names); + } + if (isGV_with_GP(sv) && GvIMPORTED(sv)) { + sv_catpvs(d, "IMPORT"); + if (GvIMPORTED(sv) == GVf_IMPORTED) + sv_catpvs(d, "ALL,"); + else { + sv_catpvs(d, "("); + append_flags(d, GvFLAGS(sv), gp_flags_imported_names); + sv_catpvs(d, " ),"); + } + } + /* FALLTHROUGH */ case SVt_PVMG: default: - if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpvs(d, "IsUV,"); - break; + if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpvs(d, "IsUV,"); + break; case SVt_PVAV: - break; + break; } /* SVphv_SHAREKEYS is also 0x20000000 */ if ((type != SVt_PVHV) && SvUTF8(sv)) @@ -1817,7 +1817,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo if (*(SvEND(d) - 1) == ',') { SvCUR_set(d, SvCUR(d) - 1); - SvPVX(d)[SvCUR(d)] = '\0'; + SvPVX(d)[SvCUR(d)] = '\0'; } sv_catpvs(d, ")"); s = SvPVX_const(d); @@ -1826,13 +1826,13 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo #ifdef DEBUG_LEAKING_SCALARS Perl_dump_indent(aTHX_ level, file, - "ALLOCATED at %s:%d %s %s (parent 0x%" UVxf "); serial %" UVuf "\n", - sv->sv_debug_file ? sv->sv_debug_file : "(unknown)", - sv->sv_debug_line, - sv->sv_debug_inpad ? "for" : "by", - sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)", - PTR2UV(sv->sv_debug_parent), - sv->sv_debug_serial + "ALLOCATED at %s:%d %s %s (parent 0x%" UVxf "); serial %" UVuf "\n", + sv->sv_debug_file ? sv->sv_debug_file : "(unknown)", + sv->sv_debug_line, + sv->sv_debug_inpad ? "for" : "by", + sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)", + PTR2UV(sv->sv_debug_parent), + sv->sv_debug_serial ); #endif Perl_dump_indent(aTHX_ level, file, "SV = "); @@ -1840,77 +1840,77 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo /* Dump SV type */ if (type < SVt_LAST) { - PerlIO_printf(file, "%s%s\n", svtypenames[type], s); + PerlIO_printf(file, "%s%s\n", svtypenames[type], s); - if (type == SVt_NULL) { - SvREFCNT_dec_NN(d); - return; - } + if (type == SVt_NULL) { + SvREFCNT_dec_NN(d); + return; + } } else { - PerlIO_printf(file, "UNKNOWN(0x%" UVxf ") %s\n", (UV)type, s); - SvREFCNT_dec_NN(d); - return; + PerlIO_printf(file, "UNKNOWN(0x%" UVxf ") %s\n", (UV)type, s); + SvREFCNT_dec_NN(d); + return; } /* Dump general SV fields */ if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV - && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO - && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv)) - || (type == SVt_IV && !SvROK(sv))) { - if (SvIsUV(sv) - ) - Perl_dump_indent(aTHX_ level, file, " UV = %" UVuf, (UV)SvUVX(sv)); - else - Perl_dump_indent(aTHX_ level, file, " IV = %" IVdf, (IV)SvIVX(sv)); - (void)PerlIO_putc(file, '\n'); + && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO + && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv)) + || (type == SVt_IV && !SvROK(sv))) { + if (SvIsUV(sv) + ) + Perl_dump_indent(aTHX_ level, file, " UV = %" UVuf, (UV)SvUVX(sv)); + else + Perl_dump_indent(aTHX_ level, file, " IV = %" IVdf, (IV)SvIVX(sv)); + (void)PerlIO_putc(file, '\n'); } if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV - && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP - && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv)) - || type == SVt_NV) { + && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP + && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv)) + || type == SVt_NV) { DECLARATION_FOR_LC_NUMERIC_MANIPULATION; STORE_LC_NUMERIC_SET_STANDARD(); - Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv)); + Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv)); RESTORE_LC_NUMERIC(); } if (SvROK(sv)) { - Perl_dump_indent(aTHX_ level, file, " RV = 0x%" UVxf "\n", + Perl_dump_indent(aTHX_ level, file, " RV = 0x%" UVxf "\n", PTR2UV(SvRV(sv))); - if (nest < maxnest) - do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim); + if (nest < maxnest) + do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim); } if (type < SVt_PV) { - SvREFCNT_dec_NN(d); - return; + SvREFCNT_dec_NN(d); + return; } if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) { - const bool re = isREGEXP(sv); - const char * const ptr = - re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv); - if (ptr) { - STRLEN delta; - if (SvOOK(sv)) { - SvOOK_offset(sv, delta); - Perl_dump_indent(aTHX_ level, file," OFFSET = %" UVuf "\n", - (UV) delta); - } else { - delta = 0; - } - Perl_dump_indent(aTHX_ level, file," PV = 0x%" UVxf " ", + const bool re = isREGEXP(sv); + const char * const ptr = + re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv); + if (ptr) { + STRLEN delta; + if (SvOOK(sv)) { + SvOOK_offset(sv, delta); + Perl_dump_indent(aTHX_ level, file," OFFSET = %" UVuf "\n", + (UV) delta); + } else { + delta = 0; + } + Perl_dump_indent(aTHX_ level, file," PV = 0x%" UVxf " ", PTR2UV(ptr)); - if (SvOOK(sv)) { - PerlIO_printf(file, "( %s . ) ", - pv_display(d, ptr - delta, delta, 0, - pvlim)); - } + if (SvOOK(sv)) { + PerlIO_printf(file, "( %s . ) ", + pv_display(d, ptr - delta, delta, 0, + pvlim)); + } if (type == SVt_INVLIST) { - PerlIO_printf(file, "\n"); + PerlIO_printf(file, "\n"); /* 4 blanks indents 2 beyond the PV, etc */ _invlist_dump(file, level, " ", sv); } @@ -1924,139 +1924,139 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo UNI_DISPLAY_QQ)); PerlIO_printf(file, "\n"); } - Perl_dump_indent(aTHX_ level, file, " CUR = %" IVdf "\n", (IV)SvCUR(sv)); - if (re && type == SVt_PVLV) + Perl_dump_indent(aTHX_ level, file, " CUR = %" IVdf "\n", (IV)SvCUR(sv)); + if (re && type == SVt_PVLV) /* LV-as-REGEXP usurps len field to store pointer to * regexp struct */ - Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%" UVxf "\n", + Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%" UVxf "\n", PTR2UV(((XPV*)SvANY(sv))->xpv_len_u.xpvlenu_rx)); else - Perl_dump_indent(aTHX_ level, file, " LEN = %" IVdf "\n", - (IV)SvLEN(sv)); + Perl_dump_indent(aTHX_ level, file, " LEN = %" IVdf "\n", + (IV)SvLEN(sv)); #ifdef PERL_COPY_ON_WRITE - if (SvIsCOW(sv) && SvLEN(sv)) - Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n", - CowREFCNT(sv)); + if (SvIsCOW(sv) && SvLEN(sv)) + Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n", + CowREFCNT(sv)); #endif - } - else - Perl_dump_indent(aTHX_ level, file, " PV = 0\n"); + } + else + Perl_dump_indent(aTHX_ level, file, " PV = 0\n"); } if (type >= SVt_PVMG) { - if (SvMAGIC(sv)) - do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim); - if (SvSTASH(sv)) - do_hv_dump(level, file, " STASH", SvSTASH(sv)); + if (SvMAGIC(sv)) + do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim); + if (SvSTASH(sv)) + do_hv_dump(level, file, " STASH", SvSTASH(sv)); - if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) { - Perl_dump_indent(aTHX_ level, file, " USEFUL = %" IVdf "\n", + if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) { + Perl_dump_indent(aTHX_ level, file, " USEFUL = %" IVdf "\n", (IV)BmUSEFUL(sv)); - } + } } /* Dump type-specific SV fields */ switch (type) { case SVt_PVAV: - Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf, + Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf, PTR2UV(AvARRAY(sv))); - if (AvARRAY(sv) != AvALLOC(sv)) { - PerlIO_printf(file, " (offset=%" IVdf ")\n", + if (AvARRAY(sv) != AvALLOC(sv)) { + PerlIO_printf(file, " (offset=%" IVdf ")\n", (IV)(AvARRAY(sv) - AvALLOC(sv))); - Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%" UVxf "\n", + Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%" UVxf "\n", PTR2UV(AvALLOC(sv))); - } - else + } + else (void)PerlIO_putc(file, '\n'); - Perl_dump_indent(aTHX_ level, file, " FILL = %" IVdf "\n", + Perl_dump_indent(aTHX_ level, file, " FILL = %" IVdf "\n", (IV)AvFILLp(sv)); - Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n", + Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n", (IV)AvMAX(sv)); SvPVCLEAR(d); - if (AvREAL(sv)) sv_catpvs(d, ",REAL"); - if (AvREIFY(sv)) sv_catpvs(d, ",REIFY"); - Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n", - SvCUR(d) ? SvPVX_const(d) + 1 : ""); - if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) { - SSize_t count; + if (AvREAL(sv)) sv_catpvs(d, ",REAL"); + if (AvREIFY(sv)) sv_catpvs(d, ",REIFY"); + Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n", + SvCUR(d) ? SvPVX_const(d) + 1 : ""); + if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) { + SSize_t count; SV **svp = AvARRAY(MUTABLE_AV(sv)); - for (count = 0; + for (count = 0; count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest; count++, svp++) { - SV* const elt = *svp; - Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %" IVdf "\n", + SV* const elt = *svp; + Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %" IVdf "\n", (IV)count); do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim); - } - } - break; + } + } + break; case SVt_PVHV: { - U32 usedkeys; + U32 usedkeys; if (SvOOK(sv)) { struct xpvhv_aux *const aux = HvAUX(sv); Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %" UVuf "\n", (UV)aux->xhv_aux_flags); } - Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv))); - usedkeys = HvUSEDKEYS(MUTABLE_HV(sv)); - if (HvARRAY(sv) && usedkeys) { - /* Show distribution of HEs in the ARRAY */ - int freq[200]; + Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv))); + usedkeys = HvUSEDKEYS(MUTABLE_HV(sv)); + if (HvARRAY(sv) && usedkeys) { + /* Show distribution of HEs in the ARRAY */ + int freq[200]; #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1)) - int i; - int max = 0; - U32 pow2 = 2, keys = usedkeys; - NV theoret, sum = 0; - - PerlIO_printf(file, " ("); - Zero(freq, FREQ_MAX + 1, int); - for (i = 0; (STRLEN)i <= HvMAX(sv); i++) { - HE* h; - int count = 0; + int i; + int max = 0; + U32 pow2 = 2, keys = usedkeys; + NV theoret, sum = 0; + + PerlIO_printf(file, " ("); + Zero(freq, FREQ_MAX + 1, int); + for (i = 0; (STRLEN)i <= HvMAX(sv); i++) { + HE* h; + int count = 0; for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h)) - count++; - if (count > FREQ_MAX) - count = FREQ_MAX; - freq[count]++; - if (max < count) - max = count; - } - for (i = 0; i <= max; i++) { - if (freq[i]) { - PerlIO_printf(file, "%d%s:%d", i, - (i == FREQ_MAX) ? "+" : "", - freq[i]); - if (i != max) - PerlIO_printf(file, ", "); - } + count++; + if (count > FREQ_MAX) + count = FREQ_MAX; + freq[count]++; + if (max < count) + max = count; + } + for (i = 0; i <= max; i++) { + if (freq[i]) { + PerlIO_printf(file, "%d%s:%d", i, + (i == FREQ_MAX) ? "+" : "", + freq[i]); + if (i != max) + PerlIO_printf(file, ", "); + } } - (void)PerlIO_putc(file, ')'); - /* The "quality" of a hash is defined as the total number of - comparisons needed to access every element once, relative - to the expected number needed for a random hash. - - The total number of comparisons is equal to the sum of - the squares of the number of entries in each bucket. - For a random hash of n keys into k buckets, the expected - value is - n + n(n-1)/2k - */ - - for (i = max; i > 0; i--) { /* Precision: count down. */ - sum += freq[i] * i * i; + (void)PerlIO_putc(file, ')'); + /* The "quality" of a hash is defined as the total number of + comparisons needed to access every element once, relative + to the expected number needed for a random hash. + + The total number of comparisons is equal to the sum of + the squares of the number of entries in each bucket. + For a random hash of n keys into k buckets, the expected + value is + n + n(n-1)/2k + */ + + for (i = max; i > 0; i--) { /* Precision: count down. */ + sum += freq[i] * i * i; } - while ((keys = keys >> 1)) - pow2 = pow2 << 1; - theoret = usedkeys; - theoret += theoret * (theoret-1)/pow2; - (void)PerlIO_putc(file, '\n'); - Perl_dump_indent(aTHX_ level, file, " hash quality = %.1" + while ((keys = keys >> 1)) + pow2 = pow2 << 1; + theoret = usedkeys; + theoret += theoret * (theoret-1)/pow2; + (void)PerlIO_putc(file, '\n'); + Perl_dump_indent(aTHX_ level, file, " hash quality = %.1" NVff "%%", theoret/sum*100); - } - (void)PerlIO_putc(file, '\n'); - Perl_dump_indent(aTHX_ level, file, " KEYS = %" IVdf "\n", + } + (void)PerlIO_putc(file, '\n'); + Perl_dump_indent(aTHX_ level, file, " KEYS = %" IVdf "\n", (IV)usedkeys); { STRLEN count = 0; @@ -2075,15 +2075,15 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo Perl_dump_indent(aTHX_ level, file, " FILL = %" UVuf "\n", (UV)count); } - Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n", + Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n", (IV)HvMAX(sv)); if (SvOOK(sv)) { - Perl_dump_indent(aTHX_ level, file, " RITER = %" IVdf "\n", + Perl_dump_indent(aTHX_ level, file, " RITER = %" IVdf "\n", (IV)HvRITER_get(sv)); - Perl_dump_indent(aTHX_ level, file, " EITER = 0x%" UVxf "\n", + Perl_dump_indent(aTHX_ level, file, " EITER = 0x%" UVxf "\n", PTR2UV(HvEITER_get(sv))); #ifdef PERL_HASH_RANDOMIZE_KEYS - Perl_dump_indent(aTHX_ level, file, " RAND = 0x%" UVxf, + Perl_dump_indent(aTHX_ level, file, " RAND = 0x%" UVxf, (UV)HvRAND_get(sv)); if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) { PerlIO_printf(file, " (LAST = 0x%" UVxf ")", @@ -2092,254 +2092,254 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo #endif (void)PerlIO_putc(file, '\n'); } - { - MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab); - if (mg && mg->mg_obj) { - Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%" UVxf "\n", PTR2UV(mg->mg_obj)); - } - } - { - const char * const hvname = HvNAME_get(sv); - if (hvname) { + { + MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab); + if (mg && mg->mg_obj) { + Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%" UVxf "\n", PTR2UV(mg->mg_obj)); + } + } + { + const char * const hvname = HvNAME_get(sv); + if (hvname) { SV* tmpsv = newSVpvs_flags("", SVs_TEMP); Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", generic_pv_escape( tmpsv, hvname, HvNAMELEN(sv), HvNAMEUTF8(sv))); } - } - if (SvOOK(sv)) { - AV * const backrefs - = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv)); - struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta; - if (HvAUX(sv)->xhv_name_count) - Perl_dump_indent(aTHX_ - level, file, " NAMECOUNT = %" IVdf "\n", - (IV)HvAUX(sv)->xhv_name_count - ); - if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) { - const I32 count = HvAUX(sv)->xhv_name_count; - if (count) { - SV * const names = newSVpvs_flags("", SVs_TEMP); - /* The starting point is the first element if count is - positive and the second element if count is negative. */ - HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names - + (count < 0 ? 1 : 0); - HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names - + (count < 0 ? -count : count); - while (hekp < endp) { - if (*hekp) { + } + if (SvOOK(sv)) { + AV * const backrefs + = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv)); + struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta; + if (HvAUX(sv)->xhv_name_count) + Perl_dump_indent(aTHX_ + level, file, " NAMECOUNT = %" IVdf "\n", + (IV)HvAUX(sv)->xhv_name_count + ); + if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) { + const I32 count = HvAUX(sv)->xhv_name_count; + if (count) { + SV * const names = newSVpvs_flags("", SVs_TEMP); + /* The starting point is the first element if count is + positive and the second element if count is negative. */ + HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names + + (count < 0 ? 1 : 0); + HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names + + (count < 0 ? -count : count); + while (hekp < endp) { + if (*hekp) { SV *tmp = newSVpvs_flags("", SVs_TEMP); - Perl_sv_catpvf(aTHX_ names, ", \"%s\"", + Perl_sv_catpvf(aTHX_ names, ", \"%s\"", generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp))); - } else { - /* This should never happen. */ - sv_catpvs(names, ", (null)"); - } - ++hekp; - } - Perl_dump_indent(aTHX_ - level, file, " ENAME = %s\n", SvPV_nolen(names)+2 - ); - } - else { + } else { + /* This should never happen. */ + sv_catpvs(names, ", (null)"); + } + ++hekp; + } + Perl_dump_indent(aTHX_ + level, file, " ENAME = %s\n", SvPV_nolen(names)+2 + ); + } + else { SV * const tmp = newSVpvs_flags("", SVs_TEMP); const char *const hvename = HvENAME_get(sv); - Perl_dump_indent(aTHX_ - level, file, " ENAME = \"%s\"\n", + Perl_dump_indent(aTHX_ + level, file, " ENAME = \"%s\"\n", generic_pv_escape(tmp, hvename, HvENAMELEN_get(sv), HvENAMEUTF8(sv))); } - } - if (backrefs) { - Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%" UVxf "\n", - PTR2UV(backrefs)); - do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest, - dumpops, pvlim); - } - if (meta) { - SV* tmpsv = newSVpvs_flags("", SVs_TEMP); - Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%" + } + if (backrefs) { + Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%" UVxf "\n", + PTR2UV(backrefs)); + do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest, + dumpops, pvlim); + } + if (meta) { + SV* tmpsv = newSVpvs_flags("", SVs_TEMP); + Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%" UVxf ")\n", - generic_pv_escape( tmpsv, meta->mro_which->name, + generic_pv_escape( tmpsv, meta->mro_which->name, meta->mro_which->length, (meta->mro_which->kflags & HVhek_UTF8)), - PTR2UV(meta->mro_which)); - Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%" + PTR2UV(meta->mro_which)); + Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%" UVxf "\n", - (UV)meta->cache_gen); - Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%" UVxf "\n", - (UV)meta->pkg_gen); - if (meta->mro_linear_all) { - Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%" + (UV)meta->cache_gen); + Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%" UVxf "\n", + (UV)meta->pkg_gen); + if (meta->mro_linear_all) { + Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%" UVxf "\n", - PTR2UV(meta->mro_linear_all)); - do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest, - dumpops, pvlim); - } - if (meta->mro_linear_current) { - Perl_dump_indent(aTHX_ level, file, + PTR2UV(meta->mro_linear_all)); + do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest, + dumpops, pvlim); + } + if (meta->mro_linear_current) { + Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%" UVxf "\n", - PTR2UV(meta->mro_linear_current)); - do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest, - dumpops, pvlim); - } - if (meta->mro_nextmethod) { - Perl_dump_indent(aTHX_ level, file, + PTR2UV(meta->mro_linear_current)); + do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest, + dumpops, pvlim); + } + if (meta->mro_nextmethod) { + Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%" UVxf "\n", - PTR2UV(meta->mro_nextmethod)); - do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest, - dumpops, pvlim); - } - if (meta->isa) { - Perl_dump_indent(aTHX_ level, file, " ISA = 0x%" UVxf "\n", - PTR2UV(meta->isa)); - do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest, - dumpops, pvlim); - } - } - } - if (nest < maxnest) { - HV * const hv = MUTABLE_HV(sv); - STRLEN i; - HE *he; - - if (HvARRAY(hv)) { - int count = maxnest - nest; - for (i=0; i <= HvMAX(hv); i++) { - for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) { - U32 hash; - SV * keysv; - const char * keypv; - SV * elt; + PTR2UV(meta->mro_nextmethod)); + do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest, + dumpops, pvlim); + } + if (meta->isa) { + Perl_dump_indent(aTHX_ level, file, " ISA = 0x%" UVxf "\n", + PTR2UV(meta->isa)); + do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest, + dumpops, pvlim); + } + } + } + if (nest < maxnest) { + HV * const hv = MUTABLE_HV(sv); + STRLEN i; + HE *he; + + if (HvARRAY(hv)) { + int count = maxnest - nest; + for (i=0; i <= HvMAX(hv); i++) { + for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) { + U32 hash; + SV * keysv; + const char * keypv; + SV * elt; STRLEN len; - if (count-- <= 0) goto DONEHV; + if (count-- <= 0) goto DONEHV; - hash = HeHASH(he); - keysv = hv_iterkeysv(he); - keypv = SvPV_const(keysv, len); - elt = HeVAL(he); + hash = HeHASH(he); + keysv = hv_iterkeysv(he); + keypv = SvPV_const(keysv, len); + elt = HeVAL(he); Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim)); if (SvUTF8(keysv)) PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ)); - if (HvEITER_get(hv) == he) - PerlIO_printf(file, "[CURRENT] "); + if (HvEITER_get(hv) == he) + PerlIO_printf(file, "[CURRENT] "); PerlIO_printf(file, "HASH = 0x%" UVxf "\n", (UV) hash); do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim); } - } - DONEHV:; - } - } - break; + } + DONEHV:; + } + } + break; } /* case SVt_PVHV */ case SVt_PVCV: - if (CvAUTOLOAD(sv)) { - SV* tmpsv = newSVpvs_flags("", SVs_TEMP); + if (CvAUTOLOAD(sv)) { + SV* tmpsv = newSVpvs_flags("", SVs_TEMP); STRLEN len; - const char *const name = SvPV_const(sv, len); - Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n", - generic_pv_escape(tmpsv, name, len, SvUTF8(sv))); - } - if (SvPOK(sv)) { + const char *const name = SvPV_const(sv, len); + Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n", + generic_pv_escape(tmpsv, name, len, SvUTF8(sv))); + } + if (SvPOK(sv)) { SV* tmpsv = newSVpvs_flags("", SVs_TEMP); const char *const proto = CvPROTO(sv); - Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n", - generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv), + Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n", + generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv), SvUTF8(sv))); - } - /* FALLTHROUGH */ + } + /* FALLTHROUGH */ case SVt_PVFM: - do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv)); - if (!CvISXSUB(sv)) { - if (CvSTART(sv)) { + do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv)); + if (!CvISXSUB(sv)) { + if (CvSTART(sv)) { if (CvSLABBED(sv)) Perl_dump_indent(aTHX_ level, file, - " SLAB = 0x%" UVxf "\n", - PTR2UV(CvSTART(sv))); + " SLAB = 0x%" UVxf "\n", + PTR2UV(CvSTART(sv))); else Perl_dump_indent(aTHX_ level, file, - " START = 0x%" UVxf " ===> %" IVdf "\n", - PTR2UV(CvSTART(sv)), - (IV)sequence_num(CvSTART(sv))); - } - Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%" UVxf "\n", - PTR2UV(CvROOT(sv))); - if (CvROOT(sv) && dumpops) { - do_op_dump(level+1, file, CvROOT(sv)); - } - } else { - SV * const constant = cv_const_sv((const CV *)sv); - - Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%" UVxf "\n", PTR2UV(CvXSUB(sv))); - - if (constant) { - Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%" UVxf - " (CONST SV)\n", - PTR2UV(CvXSUBANY(sv).any_ptr)); - do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops, - pvlim); - } else { - Perl_dump_indent(aTHX_ level, file, " XSUBANY = %" IVdf "\n", - (IV)CvXSUBANY(sv).any_i32); - } - } - if (CvNAMED(sv)) - Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", - HEK_KEY(CvNAME_HEK((CV *)sv))); - else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv)); - Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv)); - Perl_dump_indent(aTHX_ level, file, " DEPTH = %" + " START = 0x%" UVxf " ===> %" IVdf "\n", + PTR2UV(CvSTART(sv)), + (IV)sequence_num(CvSTART(sv))); + } + Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%" UVxf "\n", + PTR2UV(CvROOT(sv))); + if (CvROOT(sv) && dumpops) { + do_op_dump(level+1, file, CvROOT(sv)); + } + } else { + SV * const constant = cv_const_sv((const CV *)sv); + + Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%" UVxf "\n", PTR2UV(CvXSUB(sv))); + + if (constant) { + Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%" UVxf + " (CONST SV)\n", + PTR2UV(CvXSUBANY(sv).any_ptr)); + do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops, + pvlim); + } else { + Perl_dump_indent(aTHX_ level, file, " XSUBANY = %" IVdf "\n", + (IV)CvXSUBANY(sv).any_i32); + } + } + if (CvNAMED(sv)) + Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", + HEK_KEY(CvNAME_HEK((CV *)sv))); + else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv)); + Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv)); + Perl_dump_indent(aTHX_ level, file, " DEPTH = %" IVdf "\n", (IV)CvDEPTH(sv)); - Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", + Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)CvFLAGS(sv)); - Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %" UVuf "\n", (UV)CvOUTSIDE_SEQ(sv)); - if (!CvISXSUB(sv)) { - Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%" UVxf "\n", PTR2UV(CvPADLIST(sv))); - if (nest < maxnest) { - do_dump_pad(level+1, file, CvPADLIST(sv), 0); - } - } - else - Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv)); - { - const CV * const outside = CvOUTSIDE(sv); - Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%" UVxf " (%s)\n", - PTR2UV(outside), - (!outside ? "null" - : CvANON(outside) ? "ANON" - : (outside == PL_main_cv) ? "MAIN" - : CvUNIQUE(outside) ? "UNIQUE" - : CvGV(outside) ? - generic_pv_escape( - newSVpvs_flags("", SVs_TEMP), - GvNAME(CvGV(outside)), - GvNAMELEN(CvGV(outside)), - GvNAMEUTF8(CvGV(outside))) - : "UNDEFINED")); - } - if (CvOUTSIDE(sv) - && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))) - do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim); - break; + Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %" UVuf "\n", (UV)CvOUTSIDE_SEQ(sv)); + if (!CvISXSUB(sv)) { + Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%" UVxf "\n", PTR2UV(CvPADLIST(sv))); + if (nest < maxnest) { + do_dump_pad(level+1, file, CvPADLIST(sv), 0); + } + } + else + Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv)); + { + const CV * const outside = CvOUTSIDE(sv); + Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%" UVxf " (%s)\n", + PTR2UV(outside), + (!outside ? "null" + : CvANON(outside) ? "ANON" + : (outside == PL_main_cv) ? "MAIN" + : CvUNIQUE(outside) ? "UNIQUE" + : CvGV(outside) ? + generic_pv_escape( + newSVpvs_flags("", SVs_TEMP), + GvNAME(CvGV(outside)), + GvNAMELEN(CvGV(outside)), + GvNAMEUTF8(CvGV(outside))) + : "UNDEFINED")); + } + if (CvOUTSIDE(sv) + && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))) + do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim); + break; case SVt_PVGV: case SVt_PVLV: - if (type == SVt_PVLV) { - Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv)); - Perl_dump_indent(aTHX_ level, file, " TARGOFF = %" IVdf "\n", (IV)LvTARGOFF(sv)); - Perl_dump_indent(aTHX_ level, file, " TARGLEN = %" IVdf "\n", (IV)LvTARGLEN(sv)); - Perl_dump_indent(aTHX_ level, file, " TARG = 0x%" UVxf "\n", PTR2UV(LvTARG(sv))); - Perl_dump_indent(aTHX_ level, file, " FLAGS = %" IVdf "\n", (IV)LvFLAGS(sv)); - if (isALPHA_FOLD_NE(LvTYPE(sv), 't')) - do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest, - dumpops, pvlim); - } - if (isREGEXP(sv)) goto dumpregexp; - if (!isGV_with_GP(sv)) - break; + if (type == SVt_PVLV) { + Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv)); + Perl_dump_indent(aTHX_ level, file, " TARGOFF = %" IVdf "\n", (IV)LvTARGOFF(sv)); + Perl_dump_indent(aTHX_ level, file, " TARGLEN = %" IVdf "\n", (IV)LvTARGLEN(sv)); + Perl_dump_indent(aTHX_ level, file, " TARG = 0x%" UVxf "\n", PTR2UV(LvTARG(sv))); + Perl_dump_indent(aTHX_ level, file, " FLAGS = %" IVdf "\n", (IV)LvFLAGS(sv)); + if (isALPHA_FOLD_NE(LvTYPE(sv), 't')) + do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest, + dumpops, pvlim); + } + if (isREGEXP(sv)) goto dumpregexp; + if (!isGV_with_GP(sv)) + break; { SV* tmpsv = newSVpvs_flags("", SVs_TEMP); Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", @@ -2347,78 +2347,78 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo GvNAMELEN(sv), GvNAMEUTF8(sv))); } - Perl_dump_indent(aTHX_ level, file, " NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv)); - do_hv_dump (level, file, " GvSTASH", GvSTASH(sv)); - Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv)); - Perl_dump_indent(aTHX_ level, file, " GP = 0x%" UVxf "\n", PTR2UV(GvGP(sv))); - if (!GvGP(sv)) - break; - Perl_dump_indent(aTHX_ level, file, " SV = 0x%" UVxf "\n", PTR2UV(GvSV(sv))); - Perl_dump_indent(aTHX_ level, file, " REFCNT = %" IVdf "\n", (IV)GvREFCNT(sv)); - Perl_dump_indent(aTHX_ level, file, " IO = 0x%" UVxf "\n", PTR2UV(GvIOp(sv))); - Perl_dump_indent(aTHX_ level, file, " FORM = 0x%" UVxf " \n", PTR2UV(GvFORM(sv))); - Perl_dump_indent(aTHX_ level, file, " AV = 0x%" UVxf "\n", PTR2UV(GvAV(sv))); - Perl_dump_indent(aTHX_ level, file, " HV = 0x%" UVxf "\n", PTR2UV(GvHV(sv))); - Perl_dump_indent(aTHX_ level, file, " CV = 0x%" UVxf "\n", PTR2UV(GvCV(sv))); - Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%" UVxf "\n", (UV)GvCVGEN(sv)); - Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%" UVxf - " (%s)\n", - (UV)GvGPFLAGS(sv), - ""); - Perl_dump_indent(aTHX_ level, file, " LINE = %" IVdf "\n", (IV)GvLINE(sv)); - Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv)); - do_gv_dump (level, file, " EGV", GvEGV(sv)); - break; + Perl_dump_indent(aTHX_ level, file, " NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv)); + do_hv_dump (level, file, " GvSTASH", GvSTASH(sv)); + Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv)); + Perl_dump_indent(aTHX_ level, file, " GP = 0x%" UVxf "\n", PTR2UV(GvGP(sv))); + if (!GvGP(sv)) + break; + Perl_dump_indent(aTHX_ level, file, " SV = 0x%" UVxf "\n", PTR2UV(GvSV(sv))); + Perl_dump_indent(aTHX_ level, file, " REFCNT = %" IVdf "\n", (IV)GvREFCNT(sv)); + Perl_dump_indent(aTHX_ level, file, " IO = 0x%" UVxf "\n", PTR2UV(GvIOp(sv))); + Perl_dump_indent(aTHX_ level, file, " FORM = 0x%" UVxf " \n", PTR2UV(GvFORM(sv))); + Perl_dump_indent(aTHX_ level, file, " AV = 0x%" UVxf "\n", PTR2UV(GvAV(sv))); + Perl_dump_indent(aTHX_ level, file, " HV = 0x%" UVxf "\n", PTR2UV(GvHV(sv))); + Perl_dump_indent(aTHX_ level, file, " CV = 0x%" UVxf "\n", PTR2UV(GvCV(sv))); + Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%" UVxf "\n", (UV)GvCVGEN(sv)); + Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%" UVxf + " (%s)\n", + (UV)GvGPFLAGS(sv), + ""); + Perl_dump_indent(aTHX_ level, file, " LINE = %" IVdf "\n", (IV)GvLINE(sv)); + Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv)); + do_gv_dump (level, file, " EGV", GvEGV(sv)); + break; case SVt_PVIO: - Perl_dump_indent(aTHX_ level, file, " IFP = 0x%" UVxf "\n", PTR2UV(IoIFP(sv))); - Perl_dump_indent(aTHX_ level, file, " OFP = 0x%" UVxf "\n", PTR2UV(IoOFP(sv))); - Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%" UVxf "\n", PTR2UV(IoDIRP(sv))); - Perl_dump_indent(aTHX_ level, file, " LINES = %" IVdf "\n", (IV)IoLINES(sv)); - Perl_dump_indent(aTHX_ level, file, " PAGE = %" IVdf "\n", (IV)IoPAGE(sv)); - Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %" IVdf "\n", (IV)IoPAGE_LEN(sv)); - Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %" IVdf "\n", (IV)IoLINES_LEFT(sv)); + Perl_dump_indent(aTHX_ level, file, " IFP = 0x%" UVxf "\n", PTR2UV(IoIFP(sv))); + Perl_dump_indent(aTHX_ level, file, " OFP = 0x%" UVxf "\n", PTR2UV(IoOFP(sv))); + Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%" UVxf "\n", PTR2UV(IoDIRP(sv))); + Perl_dump_indent(aTHX_ level, file, " LINES = %" IVdf "\n", (IV)IoLINES(sv)); + Perl_dump_indent(aTHX_ level, file, " PAGE = %" IVdf "\n", (IV)IoPAGE(sv)); + Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %" IVdf "\n", (IV)IoPAGE_LEN(sv)); + Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %" IVdf "\n", (IV)IoLINES_LEFT(sv)); if (IoTOP_NAME(sv)) Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv)); - if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV) - do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv)); - else { - Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%" UVxf "\n", - PTR2UV(IoTOP_GV(sv))); - do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1, - maxnest, dumpops, pvlim); - } - /* Source filters hide things that are not GVs in these three, so let's - be careful out there. */ + if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV) + do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv)); + else { + Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%" UVxf "\n", + PTR2UV(IoTOP_GV(sv))); + do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1, + maxnest, dumpops, pvlim); + } + /* Source filters hide things that are not GVs in these three, so let's + be careful out there. */ if (IoFMT_NAME(sv)) Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv)); - if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV) - do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv)); - else { - Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%" UVxf "\n", - PTR2UV(IoFMT_GV(sv))); - do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1, - maxnest, dumpops, pvlim); - } + if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV) + do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv)); + else { + Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%" UVxf "\n", + PTR2UV(IoFMT_GV(sv))); + do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1, + maxnest, dumpops, pvlim); + } if (IoBOTTOM_NAME(sv)) Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv)); - if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV) - do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv)); - else { - Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%" UVxf "\n", - PTR2UV(IoBOTTOM_GV(sv))); - do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1, - maxnest, dumpops, pvlim); - } - if (isPRINT(IoTYPE(sv))) + if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV) + do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv)); + else { + Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%" UVxf "\n", + PTR2UV(IoBOTTOM_GV(sv))); + do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1, + maxnest, dumpops, pvlim); + } + if (isPRINT(IoTYPE(sv))) Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv)); - else + else Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv)); - Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)IoFLAGS(sv)); - break; + Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)IoFLAGS(sv)); + break; case SVt_REGEXP: dumpregexp: - { - struct regexp * const r = ReANY((REGEXP*)sv); + { + struct regexp * const r = ReANY((REGEXP*)sv); #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \ sv_setpv(d,""); \ @@ -2433,7 +2433,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo (UV)(r->compflags), SvPVX_const(d)); SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names); - Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%" UVxf " (%s)\n", + Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%" UVxf " (%s)\n", (UV)(r->extflags), SvPVX_const(d)); Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%" UVxf " (%s)\n", @@ -2444,56 +2444,56 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo (UV)(r->intflags), SvPVX_const(d)); } else { Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf "\n", - (UV)(r->intflags)); + (UV)(r->intflags)); } #undef SV_SET_STRINGIFY_REGEXP_FLAGS - Perl_dump_indent(aTHX_ level, file, " NPARENS = %" UVuf "\n", - (UV)(r->nparens)); - Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %" UVuf "\n", - (UV)(r->lastparen)); - Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %" UVuf "\n", - (UV)(r->lastcloseparen)); - Perl_dump_indent(aTHX_ level, file, " MINLEN = %" IVdf "\n", - (IV)(r->minlen)); - Perl_dump_indent(aTHX_ level, file, " MINLENRET = %" IVdf "\n", - (IV)(r->minlenret)); - Perl_dump_indent(aTHX_ level, file, " GOFS = %" UVuf "\n", - (UV)(r->gofs)); - Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %" UVuf "\n", - (UV)(r->pre_prefix)); - Perl_dump_indent(aTHX_ level, file, " SUBLEN = %" IVdf "\n", - (IV)(r->sublen)); - Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %" IVdf "\n", - (IV)(r->suboffset)); - Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %" IVdf "\n", - (IV)(r->subcoffset)); - if (r->subbeg) - Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%" UVxf " %s\n", - PTR2UV(r->subbeg), - pv_display(d, r->subbeg, r->sublen, 50, pvlim)); - else - Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n"); - Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%" UVxf "\n", - PTR2UV(r->mother_re)); - if (nest < maxnest && r->mother_re) - do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1, - maxnest, dumpops, pvlim); - Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%" UVxf "\n", - PTR2UV(r->paren_names)); - Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%" UVxf "\n", - PTR2UV(r->substrs)); - Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%" UVxf "\n", - PTR2UV(r->pprivate)); - Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%" UVxf "\n", - PTR2UV(r->offs)); - Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%" UVxf "\n", - PTR2UV(r->qr_anoncv)); + Perl_dump_indent(aTHX_ level, file, " NPARENS = %" UVuf "\n", + (UV)(r->nparens)); + Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %" UVuf "\n", + (UV)(r->lastparen)); + Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %" UVuf "\n", + (UV)(r->lastcloseparen)); + Perl_dump_indent(aTHX_ level, file, " MINLEN = %" IVdf "\n", + (IV)(r->minlen)); + Perl_dump_indent(aTHX_ level, file, " MINLENRET = %" IVdf "\n", + (IV)(r->minlenret)); + Perl_dump_indent(aTHX_ level, file, " GOFS = %" UVuf "\n", + (UV)(r->gofs)); + Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %" UVuf "\n", + (UV)(r->pre_prefix)); + Perl_dump_indent(aTHX_ level, file, " SUBLEN = %" IVdf "\n", + (IV)(r->sublen)); + Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %" IVdf "\n", + (IV)(r->suboffset)); + Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %" IVdf "\n", + (IV)(r->subcoffset)); + if (r->subbeg) + Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%" UVxf " %s\n", + PTR2UV(r->subbeg), + pv_display(d, r->subbeg, r->sublen, 50, pvlim)); + else + Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n"); + Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%" UVxf "\n", + PTR2UV(r->mother_re)); + if (nest < maxnest && r->mother_re) + do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1, + maxnest, dumpops, pvlim); + Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%" UVxf "\n", + PTR2UV(r->paren_names)); + Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%" UVxf "\n", + PTR2UV(r->substrs)); + Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%" UVxf "\n", + PTR2UV(r->pprivate)); + Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%" UVxf "\n", + PTR2UV(r->offs)); + Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%" UVxf "\n", + PTR2UV(r->qr_anoncv)); #ifdef PERL_ANY_COW - Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%" UVxf "\n", - PTR2UV(r->saved_copy)); + Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%" UVxf "\n", + PTR2UV(r->saved_copy)); #endif - } - break; + } + break; } SvREFCNT_dec_NN(d); } @@ -2512,9 +2512,9 @@ void Perl_sv_dump(pTHX_ SV *sv) { if (sv && SvROK(sv)) - do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0); + do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0); else - do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0); + do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0); } int @@ -2527,8 +2527,8 @@ Perl_runops_debug(pTHX) #endif if (!PL_op) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN"); - return 0; + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN"); + return 0; } DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n")); do { @@ -2544,29 +2544,29 @@ Perl_runops_debug(pTHX) PL_stack_base + PL_curstackinfo->si_stack_hwm); PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base; #endif - if (PL_debug) { + if (PL_debug) { ENTER; SAVETMPS; - if (PL_watchaddr && (*PL_watchaddr != PL_watchok)) - PerlIO_printf(Perl_debug_log, - "WARNING: %" UVxf " changed from %" UVxf " to %" UVxf "\n", - PTR2UV(PL_watchaddr), PTR2UV(PL_watchok), - PTR2UV(*PL_watchaddr)); - if (DEBUG_s_TEST_) { - if (DEBUG_v_TEST_) { - PerlIO_printf(Perl_debug_log, "\n"); - deb_stack_all(); - } - else - debstack(); - } - - - if (DEBUG_t_TEST_) debop(PL_op); - if (DEBUG_P_TEST_) debprof(PL_op); + if (PL_watchaddr && (*PL_watchaddr != PL_watchok)) + PerlIO_printf(Perl_debug_log, + "WARNING: %" UVxf " changed from %" UVxf " to %" UVxf "\n", + PTR2UV(PL_watchaddr), PTR2UV(PL_watchok), + PTR2UV(*PL_watchaddr)); + if (DEBUG_s_TEST_) { + if (DEBUG_v_TEST_) { + PerlIO_printf(Perl_debug_log, "\n"); + deb_stack_all(); + } + else + debstack(); + } + + + if (DEBUG_t_TEST_) debop(PL_op); + if (DEBUG_P_TEST_) debprof(PL_op); FREETMPS; LEAVE; - } + } PERL_DTRACE_PROBE_OP(PL_op); } while ((PL_op = PL_op->op_ppaddr(aTHX))); @@ -2861,26 +2861,26 @@ Perl_debop(pTHX_ const OP *o) PERL_ARGS_ASSERT_DEBOP; if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_) - return 0; + return 0; Perl_deb(aTHX_ "%s", OP_NAME(o)); switch (o->op_type) { case OP_CONST: case OP_HINTSEVAL: - /* With ITHREADS, consts are stored in the pad, and the right pad - * may not be active here, so check. - * Looks like only during compiling the pads are illegal. - */ + /* With ITHREADS, consts are stored in the pad, and the right pad + * may not be active here, so check. + * Looks like only during compiling the pads are illegal. + */ #ifdef USE_ITHREADS - if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME) + if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME) #endif - PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv)); - break; + PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv)); + break; case OP_GVSV: case OP_GV: PerlIO_printf(Perl_debug_log, "(%" SVf ")", SVfARG(S_gv_display(aTHX_ cGVOPo_gv))); - break; + break; case OP_PADSV: case OP_PADAV: @@ -2905,7 +2905,7 @@ Perl_debop(pTHX_ const OP *o) break; default: - break; + break; } PerlIO_printf(Perl_debug_log, "\n"); return 0; @@ -2928,29 +2928,29 @@ Perl_op_class(pTHX_ const OP *o) bool custom = 0; if (!o) - return OPclass_NULL; + return OPclass_NULL; if (o->op_type == 0) { - if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE) - return OPclass_COP; - return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP; + if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE) + return OPclass_COP; + return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP; } if (o->op_type == OP_SASSIGN) - return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPclass_UNOP : OPclass_BINOP); + return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPclass_UNOP : OPclass_BINOP); if (o->op_type == OP_AELEMFAST) { #ifdef USE_ITHREADS - return OPclass_PADOP; + return OPclass_PADOP; #else - return OPclass_SVOP; + return OPclass_SVOP; #endif } #ifdef USE_ITHREADS if (o->op_type == OP_GV || o->op_type == OP_GVSV || - o->op_type == OP_RCATLINE) - return OPclass_PADOP; + o->op_type == OP_RCATLINE) + return OPclass_PADOP; #endif if (o->op_type == OP_CUSTOM) @@ -2958,28 +2958,28 @@ Perl_op_class(pTHX_ const OP *o) switch (OP_CLASS(o)) { case OA_BASEOP: - return OPclass_BASEOP; + return OPclass_BASEOP; case OA_UNOP: - return OPclass_UNOP; + return OPclass_UNOP; case OA_BINOP: - return OPclass_BINOP; + return OPclass_BINOP; case OA_LOGOP: - return OPclass_LOGOP; + return OPclass_LOGOP; case OA_LISTOP: - return OPclass_LISTOP; + return OPclass_LISTOP; case OA_PMOP: - return OPclass_PMOP; + return OPclass_PMOP; case OA_SVOP: - return OPclass_SVOP; + return OPclass_SVOP; case OA_PADOP: - return OPclass_PADOP; + return OPclass_PADOP; case OA_PVOP_OR_SVOP: /* @@ -2989,70 +2989,70 @@ Perl_op_class(pTHX_ const OP *o) * the OP is an SVOP (or, under threads, a PADOP), * and the SV is an AV. */ - return (!custom && - (o->op_private & OPpTRANS_USE_SVOP) - ) + return (!custom && + (o->op_private & OPpTRANS_USE_SVOP) + ) #if defined(USE_ITHREADS) - ? OPclass_PADOP : OPclass_PVOP; + ? OPclass_PADOP : OPclass_PVOP; #else - ? OPclass_SVOP : OPclass_PVOP; + ? OPclass_SVOP : OPclass_PVOP; #endif case OA_LOOP: - return OPclass_LOOP; + return OPclass_LOOP; case OA_COP: - return OPclass_COP; + return OPclass_COP; case OA_BASEOP_OR_UNOP: - /* - * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on - * whether parens were seen. perly.y uses OPf_SPECIAL to - * signal whether a BASEOP had empty parens or none. - * Some other UNOPs are created later, though, so the best - * test is OPf_KIDS, which is set in newUNOP. - */ - return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP; + /* + * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on + * whether parens were seen. perly.y uses OPf_SPECIAL to + * signal whether a BASEOP had empty parens or none. + * Some other UNOPs are created later, though, so the best + * test is OPf_KIDS, which is set in newUNOP. + */ + return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP; case OA_FILESTATOP: - /* - * The file stat OPs are created via UNI(OP_foo) in toke.c but use - * the OPf_REF flag to distinguish between OP types instead of the - * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we - * return OPclass_UNOP so that walkoptree can find our children. If - * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set - * (no argument to the operator) it's an OP; with OPf_REF set it's - * an SVOP (and op_sv is the GV for the filehandle argument). - */ - return ((o->op_flags & OPf_KIDS) ? OPclass_UNOP : + /* + * The file stat OPs are created via UNI(OP_foo) in toke.c but use + * the OPf_REF flag to distinguish between OP types instead of the + * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we + * return OPclass_UNOP so that walkoptree can find our children. If + * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set + * (no argument to the operator) it's an OP; with OPf_REF set it's + * an SVOP (and op_sv is the GV for the filehandle argument). + */ + return ((o->op_flags & OPf_KIDS) ? OPclass_UNOP : #ifdef USE_ITHREADS - (o->op_flags & OPf_REF) ? OPclass_PADOP : OPclass_BASEOP); + (o->op_flags & OPf_REF) ? OPclass_PADOP : OPclass_BASEOP); #else - (o->op_flags & OPf_REF) ? OPclass_SVOP : OPclass_BASEOP); + (o->op_flags & OPf_REF) ? OPclass_SVOP : OPclass_BASEOP); #endif case OA_LOOPEXOP: - /* - * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a - * label was omitted (in which case it's a BASEOP) or else a term was - * seen. In this last case, all except goto are definitely PVOP but - * goto is either a PVOP (with an ordinary constant label), an UNOP - * with OPf_STACKED (with a non-constant non-sub) or an UNOP for - * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to - * get set. - */ - if (o->op_flags & OPf_STACKED) - return OPclass_UNOP; - else if (o->op_flags & OPf_SPECIAL) - return OPclass_BASEOP; - else - return OPclass_PVOP; + /* + * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a + * label was omitted (in which case it's a BASEOP) or else a term was + * seen. In this last case, all except goto are definitely PVOP but + * goto is either a PVOP (with an ordinary constant label), an UNOP + * with OPf_STACKED (with a non-constant non-sub) or an UNOP for + * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to + * get set. + */ + if (o->op_flags & OPf_STACKED) + return OPclass_UNOP; + else if (o->op_flags & OPf_SPECIAL) + return OPclass_BASEOP; + else + return OPclass_PVOP; case OA_METHOP: - return OPclass_METHOP; + return OPclass_METHOP; case OA_UNOP_AUX: - return OPclass_UNOP_AUX; + return OPclass_UNOP_AUX; } Perl_warn(aTHX_ "Can't determine class of operator %s, assuming BASEOP\n", - OP_NAME(o)); + OP_NAME(o)); return OPclass_BASEOP; } @@ -3067,7 +3067,7 @@ S_deb_curcv(pTHX_ I32 ix) if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) return cx->blk_sub.cv; - else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx)) + else if (CxTYPE(cx) == CXt_EVAL && !CxEVALBLOCK(cx)) return cx->blk_eval.cv; else if (ix == 0 && si->si_type == PERLSI_MAIN) return PL_main_cv; @@ -3090,7 +3090,7 @@ Perl_watch(pTHX_ char **addr) PL_watchaddr = addr; PL_watchok = *addr; PerlIO_printf(Perl_debug_log, "WATCHING, %" UVxf " is currently %" UVxf "\n", - PTR2UV(PL_watchaddr), PTR2UV(PL_watchok)); + PTR2UV(PL_watchaddr), PTR2UV(PL_watchok)); } STATIC void @@ -3099,9 +3099,9 @@ S_debprof(pTHX_ const OP *o) PERL_ARGS_ASSERT_DEBPROF; if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash)) - return; + return; if (!PL_profiledata) - Newxz(PL_profiledata, MAXO, U32); + Newxz(PL_profiledata, MAXO, U32); ++PL_profiledata[o->op_type]; } @@ -3110,11 +3110,11 @@ Perl_debprofdump(pTHX) { unsigned i; if (!PL_profiledata) - return; + return; for (i = 0; i < MAXO; i++) { - if (PL_profiledata[i]) - PerlIO_printf(Perl_debug_log, - "%5lu %s\n", (unsigned long)PL_profiledata[i], + if (PL_profiledata[i]) + PerlIO_printf(Perl_debug_log, + "%5lu %s\n", (unsigned long)PL_profiledata[i], PL_op_name[i]); } } diff --git a/embed.fnc b/embed.fnc index fbfced5451d9..c496e415ced7 100644 --- a/embed.fnc +++ b/embed.fnc @@ -512,9 +512,11 @@ : : For example, the expansion of STR_WITH_LEN is a comma separated pair of : values, so would have this flag; or some macros take preprocessor -: tokens, so would have this flag. This flag is an indication to -: downstream tools, such as Devel::PPPort, that this requires special -: handling. +: tokens, so would have this flag. +: +: This also is used for entries that require processing for use, such as +: being compiled by xsubpp. This flag is an indication to downstream +: tools, such as Devel::PPPort, that this requires special handling. : : U autodoc.pl will not output a usage example : @@ -572,7 +574,7 @@ ATod |void |perl_free |NN PerlInterpreter *my_perl ATod |int |perl_run |NN PerlInterpreter *my_perl ATod |int |perl_parse |NN PerlInterpreter *my_perl|XSINIT_t xsinit \ |int argc|NULLOK char** argv|NULLOK char** env -ATpR |bool |doing_taint |int argc|NULLOK char** argv|NULLOK char** env +CTpR |bool |doing_taint |int argc|NULLOK char** argv|NULLOK char** env #if defined(USE_ITHREADS) ATod |PerlInterpreter*|perl_clone|NN PerlInterpreter *proto_perl|UV flags # if defined(PERL_IMPLICIT_SYS) @@ -645,8 +647,8 @@ AmdR |SSize_t|av_tindex |NN AV *av Apd |void |av_undef |NN AV *av Apdoex |SV** |av_create_and_unshift_one|NN AV **const avp|NN SV *const val Apd |void |av_unshift |NN AV *av|SSize_t num -Apo |SV** |av_arylen_p |NN AV *av -Apo |IV* |av_iter_p |NN AV *av +Cpo |SV** |av_arylen_p |NN AV *av +Cpo |IV* |av_iter_p |NN AV *av #if defined(PERL_IN_AV_C) S |MAGIC* |get_aux_mg |NN AV *av #endif @@ -729,7 +731,7 @@ Apd |SV * |cv_name |NN CV *cv|NULLOK SV *sv|U32 flags Apd |void |cv_undef |NN CV* cv p |void |cv_undef_flags |NN CV* cv|U32 flags pd |void |cv_forget_slab |NULLOK CV *cv -Ap |void |cx_dump |NN PERL_CONTEXT* cx +Cp |void |cx_dump |NN PERL_CONTEXT* cx AiMpd |GV * |CvGV |NN CV *sv AiMTp |I32 * |CvDEPTH |NN const CV * const sv Aphd |SV* |filter_add |NULLOK filter_t funcp|NULLOK SV* datasv @@ -743,7 +745,7 @@ pPR |const char* |get_no_modify pPR |U32* |get_opargs ApPR |PPADDR_t*|get_ppaddr : Used by CXINC, which appears to be in widespread use -ApR |I32 |cxinc +CpR |I32 |cxinc Afp |void |deb |NN const char* pat|... Ap |void |vdeb |NN const char* pat|NULLOK va_list* args Ap |void |debprofdump @@ -938,19 +940,19 @@ Ap |GV* |gv_add_by_type |NULLOK GV *gv|svtype type ApMb |GV* |gv_AVadd |NULLOK GV *gv ApMb |GV* |gv_HVadd |NULLOK GV *gv ApMb |GV* |gv_IOadd |NULLOK GV* gv -AmR |GV* |gv_autoload4 |NULLOK HV* stash|NN const char* name \ +AdmR |GV* |gv_autoload4 |NULLOK HV* stash|NN const char* name \ |STRLEN len|I32 method ApR |GV* |gv_autoload_sv |NULLOK HV* stash|NN SV* namesv|U32 flags ApR |GV* |gv_autoload_pv |NULLOK HV* stash|NN const char* namepv \ |U32 flags ApR |GV* |gv_autoload_pvn |NULLOK HV* stash|NN const char* name \ |STRLEN len|U32 flags -Ap |void |gv_check |NN HV* stash +Cp |void |gv_check |NN HV* stash AbpD |void |gv_efullname |NN SV* sv|NN const GV* gv ApMb |void |gv_efullname3 |NN SV* sv|NN const GV* gv|NULLOK const char* prefix Ap |void |gv_efullname4 |NN SV* sv|NN const GV* gv|NULLOK const char* prefix|bool keepmain -Ap |GV* |gv_fetchfile |NN const char* name -Ap |GV* |gv_fetchfile_flags|NN const char *const name|const STRLEN len\ +Adp |GV* |gv_fetchfile |NN const char* name +Adp |GV* |gv_fetchfile_flags|NN const char *const name|const STRLEN len\ |const U32 flags Amd |GV* |gv_fetchmeth |NULLOK HV* stash|NN const char* name \ |STRLEN len|I32 level @@ -1390,7 +1392,7 @@ S |void |move_proto_attr|NN OP **proto|NN OP **attrs \ #endif : Used in op.c and pp_sys.c p |int |mode_from_discipline|NULLOK const char* s|STRLEN len -Ap |const char* |moreswitches |NN const char* s +Cp |const char* |moreswitches |NN const char* s Apd |NV |my_atof |NN const char *s ATdpR |NV |my_strtod |NN const char * const s|NULLOK char ** e Aprd |void |my_exit |U32 status @@ -1399,7 +1401,7 @@ Ap |I32 |my_fflush_all ATp |Pid_t |my_fork ATp |void |atfork_lock ATp |void |atfork_unlock -ApMb |I32 |my_lstat +m |I32 |my_lstat pX |I32 |my_lstat_flags |NULLOK const U32 flags #if ! defined(HAS_MEMRCHR) && (defined(PERL_CORE) || defined(PERL_EXT)) EeiT |void * |my_memrchr |NN const char * s|const char c|const STRLEN len @@ -1410,7 +1412,7 @@ Ap |PerlIO*|my_popen |NN const char* cmd|NN const char* mode #endif Ap |PerlIO*|my_popen_list |NN const char* mode|int n|NN SV ** args Apd |void |my_setenv |NULLOK const char* nam|NULLOK const char* val -ApMb |I32 |my_stat +m |I32 |my_stat pX |I32 |my_stat_flags |NULLOK const U32 flags Adfp |char * |my_strftime |NN const char *fmt|int sec|int min|int hour|int mday|int mon|int year|int wday|int yday|int isdst : Used in pp_ctl.c @@ -1473,7 +1475,7 @@ ApdR |OP* |newPADOP |I32 type|I32 flags|NN SV* sv #endif ApdR |OP* |newPMOP |I32 type|I32 flags ApdR |OP* |newPVOP |I32 type|I32 flags|NULLOK char* pv -ApR |SV* |newRV |NN SV *const sv +ApdR |SV* |newRV |NN SV *const sv ApdR |SV* |newRV_noinc |NN SV *const tmpRef ApdR |SV* |newSV |const STRLEN len ApR |OP* |newSVREF |NN OP* o @@ -1494,7 +1496,7 @@ ApRd |SV* |vnewSVpvf |NN const char *const pat|NULLOK va_list *const args Apd |SV* |newSVrv |NN SV *const rv|NULLOK const char *const classname ApMbdR |SV* |newSVsv |NULLOK SV *const old AmdR |SV* |newSVsv_nomg |NULLOK SV *const old -ApR |SV* |newSVsv_flags |NULLOK SV *const old|I32 flags +AdpR |SV* |newSVsv_flags |NULLOK SV *const old|I32 flags ApdR |SV* |newSV_type |const svtype type ApdR |OP* |newUNOP |I32 type|I32 flags|NULLOK OP* first ApdR |OP* |newUNOP_AUX |I32 type|I32 flags|NULLOK OP* first \ @@ -1577,7 +1579,7 @@ ApdO |I32 |call_argv |NN const char* sub_name|I32 flags|NN char** argv ApdO |I32 |call_method |NN const char* methname|I32 flags ApdO |I32 |call_pv |NN const char* sub_name|I32 flags ApdO |I32 |call_sv |NN SV* sv|volatile I32 flags -Ap |void |despatch_signals +Cp |void |despatch_signals Ap |OP * |doref |NN OP *o|I32 type|bool set_op_ref ApdO |SV* |eval_pv |NN const char* p|I32 croak_on_error ApdO |I32 |eval_sv |NN SV* sv|I32 flags @@ -1727,7 +1729,7 @@ S |OP* |scalarseq |NULLOK OP* o p |OP* |scalarvoid |NN OP* o Apd |NV |scan_bin |NN const char* start|STRLEN len|NN STRLEN* retlen Apd |NV |scan_hex |NN const char* start|STRLEN len|NN STRLEN* retlen -Ap |char* |scan_num |NN const char* s|NN YYSTYPE *lvalp +Cp |char* |scan_num |NN const char* s|NN YYSTYPE *lvalp Apd |NV |scan_oct |NN const char* start|STRLEN len|NN STRLEN* retlen Axpd |OP* |op_scope |NULLOK OP* o : Only used by perl.c/miniperl.c, but defined in caretx.c @@ -1737,17 +1739,17 @@ Ap |HEK* |share_hek |NN const char* str|SSize_t len|U32 hash #ifdef PERL_USE_3ARG_SIGHANDLER : Used in perl.c Tp |Signal_t |sighandler |int sig|NULLOK Siginfo_t *info|NULLOK void *uap -ATp |Signal_t |csighandler |int sig|NULLOK Siginfo_t *info|NULLOK void *uap +CTp |Signal_t |csighandler |int sig|NULLOK Siginfo_t *info|NULLOK void *uap #else Tp |Signal_t |sighandler |int sig -ATp |Signal_t |csighandler |int sig +CTp |Signal_t |csighandler |int sig #endif Tp |Signal_t |sighandler1 |int sig -ATp |Signal_t |csighandler1 |int sig +CTp |Signal_t |csighandler1 |int sig Tp |Signal_t |sighandler3 |int sig|NULLOK Siginfo_t *info|NULLOK void *uap -ATp |Signal_t |csighandler3 |int sig|NULLOK Siginfo_t *info|NULLOK void *uap -ATp |Signal_t |perly_sighandler |int sig|NULLOK Siginfo_t *info|NULLOK void *uap|bool safe -Ap |SV** |stack_grow |NN SV** sp|NN SV** p|SSize_t n +CTp |Signal_t |csighandler3 |int sig|NULLOK Siginfo_t *info|NULLOK void *uap +CTp |Signal_t |perly_sighandler |int sig|NULLOK Siginfo_t *info|NULLOK void *uap|bool safe +Cp |SV** |stack_grow |NN SV** sp|NN SV** p|SSize_t n Ap |I32 |start_subparse |I32 is_format|U32 flags Xp |void |init_named_cv |NN CV *cv|NN OP *nameop : Used in pp_ctl.c @@ -1760,20 +1762,20 @@ Apd |IO* |sv_2io |NN SV *const sv #if defined(PERL_IN_SV_C) S |bool |glob_2number |NN GV* const gv #endif -ApMb |IV |sv_2iv |NN SV *sv +CpMb |IV |sv_2iv |NN SV *sv Apd |IV |sv_2iv_flags |NN SV *const sv|const I32 flags Apd |SV* |sv_2mortal |NULLOK SV *const sv Apd |NV |sv_2nv_flags |NN SV *const sv|const I32 flags : Used in pp.c, pp_hot.c, sv.c pxd |SV* |sv_2num |NN SV *const sv -ApMb |char* |sv_2pv |NN SV *sv|NULLOK STRLEN *lp -Apd |char* |sv_2pv_flags |NN SV *const sv|NULLOK STRLEN *const lp|const U32 flags +CpMb |char* |sv_2pv |NN SV *sv|NULLOK STRLEN *lp +Cpd |char* |sv_2pv_flags |NN SV *const sv|NULLOK STRLEN *const lp|const U32 flags ApdMb |char* |sv_2pvutf8 |NN SV *sv|NULLOK STRLEN *const lp Ap |char* |sv_2pvutf8_flags |NN SV *sv|NULLOK STRLEN *const lp|const U32 flags ApdMb |char* |sv_2pvbyte |NN SV *sv|NULLOK STRLEN *const lp Ap |char* |sv_2pvbyte_flags |NN SV *sv|NULLOK STRLEN *const lp|const U32 flags AbpD |char* |sv_pvn_nomg |NN SV* sv|NULLOK STRLEN* lp -ApMb |UV |sv_2uv |NN SV *sv +CpMb |UV |sv_2uv |NN SV *sv Apd |UV |sv_2uv_flags |NN SV *const sv|const I32 flags CbpdD |IV |sv_iv |NN SV* sv CbpdD |UV |sv_uv |NN SV* sv @@ -1959,7 +1961,7 @@ Cp |I32 |regexec_flags |NN REGEXP *const rx|NN char *stringarg \ |NN char *strend|NN char *strbeg \ |SSize_t minend|NN SV *sv \ |NULLOK void *data|U32 flags -ApR |regnode*|regnext |NULLOK regnode* p +CpR |regnode*|regnext |NULLOK regnode* p EXp |SV*|reg_named_buff |NN REGEXP * const rx|NULLOK SV * const key \ |NULLOK SV * const value|const U32 flags EXp |SV*|reg_named_buff_iter |NN REGEXP * const rx|NULLOK const SV * const lastkey \ @@ -1989,7 +1991,6 @@ EiRT |bool |invlist_is_iterating|NN SV* const invlist EiR |SV* |invlist_contents|NN SV* const invlist \ |const bool traditional_style EixRT |UV |invlist_lowest|NN SV* const invlist -ESRT |bool |new_regcurly |NN const char *s|NN const char *e ERS |SV* |make_exactf_invlist |NN RExC_state_t *pRExC_state \ |NN regnode *node ES |regnode_offset|reg |NN RExC_state_t *pRExC_state \ @@ -2080,6 +2081,8 @@ ES |void |dump_regex_sets_structures \ # endif ES |void|parse_lparen_question_flags|NN RExC_state_t *pRExC_state ES |regnode_offset|reg_node|NN RExC_state_t *pRExC_state|U8 op +ES |U32 |get_quantifier_value|NN RExC_state_t *pRExC_state \ + |NN const char * start|NN const char * end ES |regnode_offset|regpiece|NN RExC_state_t *pRExC_state \ |NN I32 *flagp|U32 depth ES |bool |grok_bslash_N |NN RExC_state_t *pRExC_state \ @@ -2341,7 +2344,7 @@ EXTp |UV |_to_fold_latin1|const U8 c|NN U8 *p|NN STRLEN *lenp|const unsigned int EpX |SV* |invlist_clone |NN SV* const invlist|NULLOK SV* newlist #endif #if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C) -EiRT |bool |regcurly |NN const char *s +EXpRT |bool |regcurly |NN const char *s|NN const char *e|NULLOK const char * result[5] #endif #if defined(PERL_IN_REGEXEC_C) ERS |bool |isFOO_utf8_lc |const U8 classnum|NN const U8* character|NN const U8* e @@ -2646,13 +2649,13 @@ S |int |yywarn |NN const char *const s|U32 flags Ap |void |dump_mstats |NN const char* s Ap |int |get_mstats |NN perl_mstats_t *buf|int buflen|int level #endif -ATpa |Malloc_t|safesysmalloc |MEM_SIZE nbytes -ATpa |Malloc_t|safesyscalloc |MEM_SIZE elements|MEM_SIZE size -ATpR |Malloc_t|safesysrealloc|Malloc_t where|MEM_SIZE nbytes -ATp |Free_t |safesysfree |Malloc_t where +ATdpa |Malloc_t|safesysmalloc |MEM_SIZE nbytes +ATdpa |Malloc_t|safesyscalloc |MEM_SIZE elements|MEM_SIZE size +ATdpR |Malloc_t|safesysrealloc|Malloc_t where|MEM_SIZE nbytes +AdTp |Free_t |safesysfree |Malloc_t where CrTp |void |croak_memory_wrap -Ap |int |runops_standard -Ap |int |runops_debug +Cp |int |runops_standard +Cp |int |runops_debug Afpd |void |sv_catpvf_mg |NN SV *const sv|NN const char *const pat|... Apd |void |sv_vcatpvf_mg |NN SV *const sv|NN const char *const pat \ |NULLOK va_list *const args @@ -2682,23 +2685,23 @@ Apd |char* |pv_pretty |NN SV *dsv|NN char const * const str\ |NULLOK char const * const start_color\ |NULLOK char const * const end_color\ |const U32 flags -Afp |void |dump_indent |I32 level|NN PerlIO *file|NN const char* pat|... -Ap |void |dump_vindent |I32 level|NN PerlIO *file|NN const char* pat \ +Cfp |void |dump_indent |I32 level|NN PerlIO *file|NN const char* pat|... +Cp |void |dump_vindent |I32 level|NN PerlIO *file|NN const char* pat \ |NULLOK va_list *args -Ap |void |do_gv_dump |I32 level|NN PerlIO *file|NN const char *name\ +Cp |void |do_gv_dump |I32 level|NN PerlIO *file|NN const char *name\ |NULLOK GV *sv -Ap |void |do_gvgv_dump |I32 level|NN PerlIO *file|NN const char *name\ +Cp |void |do_gvgv_dump |I32 level|NN PerlIO *file|NN const char *name\ |NULLOK GV *sv -Ap |void |do_hv_dump |I32 level|NN PerlIO *file|NN const char *name\ +Cp |void |do_hv_dump |I32 level|NN PerlIO *file|NN const char *name\ |NULLOK HV *sv -Ap |void |do_magic_dump |I32 level|NN PerlIO *file|NULLOK const MAGIC *mg|I32 nest \ +Cp |void |do_magic_dump |I32 level|NN PerlIO *file|NULLOK const MAGIC *mg|I32 nest \ |I32 maxnest|bool dumpops|STRLEN pvlim -Ap |void |do_op_dump |I32 level|NN PerlIO *file|NULLOK const OP *o -Ap |void |do_pmop_dump |I32 level|NN PerlIO *file|NULLOK const PMOP *pm -Ap |void |do_sv_dump |I32 level|NN PerlIO *file|NULLOK SV *sv|I32 nest \ +Cp |void |do_op_dump |I32 level|NN PerlIO *file|NULLOK const OP *o +Cp |void |do_pmop_dump |I32 level|NN PerlIO *file|NULLOK const PMOP *pm +Cp |void |do_sv_dump |I32 level|NN PerlIO *file|NULLOK SV *sv|I32 nest \ |I32 maxnest|bool dumpops|STRLEN pvlim Ap |void |magic_dump |NULLOK const MAGIC *mg -Ap |void |reginitcolors +Cp |void |reginitcolors CpdRMb |char* |sv_2pv_nolen |NN SV* sv CpdRMb |char* |sv_2pvutf8_nolen|NN SV* sv CpdRMb |char* |sv_2pvbyte_nolen|NN SV* sv @@ -2725,6 +2728,10 @@ AiMdp |void |SvREFCNT_dec |NULLOK SV *sv AiMdp |void |SvREFCNT_dec_NN|NN SV *sv AiTp |void |SvAMAGIC_on |NN SV *sv AiTp |void |SvAMAGIC_off |NN SV *sv +Aipd |bool |SvTRUE |NULLOK SV *sv +Aipd |bool |SvTRUE_nomg |NULLOK SV *sv +Aipd |bool |SvTRUE_NN |NN SV *sv +Cip |bool |SvTRUE_common |NN SV *sv|const bool sv_2bool_is_fallback : This is indirectly referenced by globals.c. This is somewhat annoying. p |int |magic_killbackrefs|NN SV *sv|NN MAGIC *mg Ap |OP* |newANONATTRSUB |I32 floor|NULLOK OP *proto|NULLOK OP *attrs|NULLOK OP *block @@ -2738,7 +2745,7 @@ p |CV* |newSTUB |NN GV *gv|bool fake : Used in perly.y p |OP * |my_attrs |NN OP *o|NULLOK OP *attrs #if defined(USE_ITHREADS) -ApR |PERL_CONTEXT*|cx_dup |NULLOK PERL_CONTEXT* cx|I32 ix|I32 max|NN CLONE_PARAMS* param +CpR |PERL_CONTEXT*|cx_dup |NULLOK PERL_CONTEXT* cx|I32 ix|I32 max|NN CLONE_PARAMS* param ApR |PERL_SI*|si_dup |NULLOK PERL_SI* si|NN CLONE_PARAMS* param ApR |ANY* |ss_dup |NN PerlInterpreter* proto_perl|NN CLONE_PARAMS* param ApR |void* |any_dup |NULLOK void* v|NN const PerlInterpreter* proto_perl @@ -2890,6 +2897,7 @@ S |bool |process_special_blocks |I32 floor \ S |void |clear_special_blocks |NN const char *const fullname\ |NN GV *const gv|NN CV *const cv #endif +p |void |no_bareword_filehandle|NN const char *fhname XpR |void* |Slab_Alloc |size_t sz Xp |void |Slab_Free |NN void *op #if defined(PERL_DEBUG_READONLY_OPS) @@ -3110,7 +3118,7 @@ S |void |anonymise_cv_maybe |NN GV *gv|NN CV *cv po |void * |more_bodies |const svtype sv_type|const size_t body_size \ |const size_t arena_size EXpR |SV* |get_and_check_backslash_N_name|NN const char* s \ - |NN const char* const e \ + |NN const char* e \ |const bool is_utf8 \ |NN const char** error_msg EXpR |HV* |load_charnames |NN SV * char_name \ @@ -3416,7 +3424,7 @@ Apd |CV* |cv_clone |NN CV* proto p |CV* |cv_clone_into |NN CV* proto|NN CV *target pd |void |pad_fixup_inner_anons|NN PADLIST *padlist|NN CV *old_cv|NN CV *new_cv pdX |void |pad_push |NN PADLIST *padlist|int depth -ApbdRM |HV* |pad_compname_type|const PADOFFSET po +ApbdDR |HV* |pad_compname_type|const PADOFFSET po AxpdRT |PADNAME *|padnamelist_fetch|NN PADNAMELIST *pnl|SSize_t key Xop |void |padnamelist_free|NN PADNAMELIST *pnl Axpd |PADNAME **|padnamelist_store|NN PADNAMELIST *pnl|SSize_t key \ @@ -3553,7 +3561,7 @@ XExop |void |emulate_cop_io |NN const COP *const c|NN SV *const sv : Used by SvRX and SvRXOK XExop |REGEXP *|get_re_arg|NULLOK SV *sv -Aopdh |SV* |mro_get_private_data|NN struct mro_meta *const smeta \ +Coph |SV* |mro_get_private_data|NN struct mro_meta *const smeta \ |NN const struct mro_alg *const which Aopdh |SV* |mro_set_private_data|NN struct mro_meta *const smeta \ |NN const struct mro_alg *const which \ @@ -3658,4 +3666,8 @@ XEop |void |dtrace_probe_phase|enum perl_phase phase XEop |STRLEN*|dup_warnings |NULLOK STRLEN* warnings +#ifndef USE_ITHREADS +Amd |void |CopFILEGV_set |NN COP * c|NN GV * gv +#endif + : ex: set ts=8 sts=4 sw=4 noet: diff --git a/embed.h b/embed.h index 2cc69349d0ea..3be6c42420b4 100644 --- a/embed.h +++ b/embed.h @@ -31,6 +31,10 @@ #define Gv_AMupdate(a,b) Perl_Gv_AMupdate(aTHX_ a,b) #define SvAMAGIC_off Perl_SvAMAGIC_off #define SvAMAGIC_on Perl_SvAMAGIC_on +#define SvTRUE(a) Perl_SvTRUE(aTHX_ a) +#define SvTRUE_NN(a) Perl_SvTRUE_NN(aTHX_ a) +#define SvTRUE_common(a,b) Perl_SvTRUE_common(aTHX_ a,b) +#define SvTRUE_nomg(a) Perl_SvTRUE_nomg(aTHX_ a) #define _force_out_malformed_utf8_message(a,b,c,d) Perl__force_out_malformed_utf8_message(aTHX_ a,b,c,d) #define _is_uni_FOO(a,b) Perl__is_uni_FOO(aTHX_ a,b) #define _is_uni_perl_idcont(a) Perl__is_uni_perl_idcont(aTHX_ a) @@ -421,6 +425,9 @@ #define pad_add_name_pvn(a,b,c,d,e) Perl_pad_add_name_pvn(aTHX_ a,b,c,d,e) #define pad_add_name_sv(a,b,c,d) Perl_pad_add_name_sv(aTHX_ a,b,c,d) #define pad_alloc(a,b) Perl_pad_alloc(aTHX_ a,b) +#ifndef NO_MATHOMS +#define pad_compname_type(a) Perl_pad_compname_type(aTHX_ a) +#endif #define pad_findmy_pv(a,b) Perl_pad_findmy_pv(aTHX_ a,b) #define pad_findmy_pvn(a,b,c) Perl_pad_findmy_pvn(aTHX_ a,b,c) #define pad_findmy_sv(a,b) Perl_pad_findmy_sv(aTHX_ a,b) @@ -1040,6 +1047,7 @@ #define find_first_differing_byte_pos S_find_first_differing_byte_pos #define get_ANYOFM_contents(a) S_get_ANYOFM_contents(aTHX_ a) #define get_ANYOF_cp_list_for_ssc(a,b) S_get_ANYOF_cp_list_for_ssc(aTHX_ a,b) +#define get_quantifier_value(a,b,c) S_get_quantifier_value(aTHX_ a,b,c) #define grok_bslash_N(a,b,c,d,e,f,g) S_grok_bslash_N(aTHX_ a,b,c,d,e,f,g) #define handle_named_backref(a,b,c,d) S_handle_named_backref(aTHX_ a,b,c,d) #define handle_names_wildcard(a,b,c,d) S_handle_names_wildcard(aTHX_ a,b,c,d) @@ -1053,7 +1061,6 @@ #define join_exact(a,b,c,d,e,f,g) S_join_exact(aTHX_ a,b,c,d,e,f,g) #define make_exactf_invlist(a,b) S_make_exactf_invlist(aTHX_ a,b) #define make_trie(a,b,c,d,e,f,g,h) S_make_trie(aTHX_ a,b,c,d,e,f,g,h) -#define new_regcurly S_new_regcurly #define nextchar(a) S_nextchar(aTHX_ a) #define output_posix_warnings(a,b) S_output_posix_warnings(aTHX_ a,b) #define parse_lparen_question_flags(a) S_parse_lparen_question_flags(aTHX_ a) @@ -1156,7 +1163,7 @@ #define invlist_clone(a,b) Perl_invlist_clone(aTHX_ a,b) # endif # if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C) -#define regcurly S_regcurly +#define regcurly Perl_regcurly # endif # if defined(PERL_IN_REGEXEC_C) #define advance_one_LB(a,b,c) S_advance_one_LB(aTHX_ a,b,c) @@ -1401,6 +1408,7 @@ #define newXS_deffile(a,b) Perl_newXS_deffile(aTHX_ a,b) #define newXS_len_flags(a,b,c,d,e,f,g) Perl_newXS_len_flags(aTHX_ a,b,c,d,e,f,g) #define nextargv(a,b) Perl_nextargv(aTHX_ a,b) +#define no_bareword_filehandle(a) Perl_no_bareword_filehandle(aTHX_ a) #define noperl_die Perl_noperl_die #define notify_parser_that_changed_to_utf8() Perl_notify_parser_that_changed_to_utf8(aTHX) #define oopsAV(a) Perl_oopsAV(aTHX_ a) diff --git a/embedvar.h b/embedvar.h index 4427e0750efd..67ccd6b72302 100644 --- a/embedvar.h +++ b/embedvar.h @@ -204,6 +204,7 @@ #define PL_maxsysfd (vTHX->Imaxsysfd) #define PL_mbrlen_ps (vTHX->Imbrlen_ps) #define PL_mbrtowc_ps (vTHX->Imbrtowc_ps) +#define PL_mem_log (vTHX->Imem_log) #define PL_memory_debug_header (vTHX->Imemory_debug_header) #define PL_mess_sv (vTHX->Imess_sv) #define PL_min_intro_pending (vTHX->Imin_intro_pending) diff --git a/ext/Amiga-ARexx/.gitignore b/ext/Amiga-ARexx/.gitignore new file mode 100644 index 000000000000..e54624d60d99 --- /dev/null +++ b/ext/Amiga-ARexx/.gitignore @@ -0,0 +1 @@ +!/Makefile.PL diff --git a/ext/Amiga-Exec/.gitignore b/ext/Amiga-Exec/.gitignore new file mode 100644 index 000000000000..e54624d60d99 --- /dev/null +++ b/ext/Amiga-Exec/.gitignore @@ -0,0 +1 @@ +!/Makefile.PL diff --git a/ext/B/.gitignore b/ext/B/.gitignore index f67599be1daf..7fb2000b622b 100644 --- a/ext/B/.gitignore +++ b/ext/B/.gitignore @@ -1,3 +1,4 @@ defsubs.h const-c.inc const-xs.inc +!/Makefile.PL diff --git a/ext/DynaLoader/.gitignore b/ext/DynaLoader/.gitignore index 014ac3441064..2af9bc6aea86 100644 --- a/ext/DynaLoader/.gitignore +++ b/ext/DynaLoader/.gitignore @@ -1,3 +1,4 @@ !/dlutils.c /DynaLoader.pm /DynaLoader.xs +!/Makefile.PL diff --git a/ext/DynaLoader/DynaLoader_pm.PL b/ext/DynaLoader/DynaLoader_pm.PL index 86a1128f2622..efdb5beff6e2 100644 --- a/ext/DynaLoader/DynaLoader_pm.PL +++ b/ext/DynaLoader/DynaLoader_pm.PL @@ -73,6 +73,8 @@ print OUT <<'EOT'; # Generated from DynaLoader_pm.PL, this file is unique for every OS +use strict; + package DynaLoader; # And Gandalf said: 'Many folk like to know beforehand what is to @@ -88,9 +90,12 @@ package DynaLoader; # Tim.Bunce@ig.co.uk, August 1994 BEGIN { - $VERSION = '1.48'; + our $VERSION = '1.51'; } +our (@dl_library_path, @dl_resolve_using, @dl_require_symbols, + $dl_debug, @dl_librefs, @dl_modules, @dl_shared_objects); + EOT if (!$ENV{PERL_BUILD_EXPAND_CONFIG_VARS}) { @@ -119,14 +124,14 @@ sub dl_load_flags { 0x00 } EOT if ($ENV{PERL_BUILD_EXPAND_CONFIG_VARS}) { - print OUT "(\$dl_dlext, \$dl_so, \$dlsrc) = (", + print OUT "our (\$dl_dlext, \$dl_so, \$dlsrc) = (", to_string($Config{'dlext'}), ",", to_string($Config{'so'}), ",", to_string($Config{'dlsrc'}), ")\n;" ; } else { print OUT <<'EOT'; -($dl_dlext, $dl_so, $dlsrc) = @Config::Config{qw(dlext so dlsrc)}; +our ($dl_dlext, $dl_so, $dlsrc) = @Config::Config{qw(dlext so dlsrc)}; EOT } @@ -141,7 +146,7 @@ print OUT expand_os_specific(<<'EOT'); # inefficient to define on systems that don't need it. $Is_VMS = $^O eq 'VMS'; <> -$do_expand = <<$^O-eq-VMS>>1<<|$^O-eq-VMS>>0<>; +my $do_expand = <<$^O-eq-VMS>>1<<|$^O-eq-VMS>>0<>; @dl_require_symbols = (); # names of symbols we need<<$^O-eq-freemint>> @dl_resolve_using = (); # names of files to link with<><<$^O-eq-hpux>> @@ -292,6 +297,8 @@ sub croak { require Carp; Carp::croak(@_) } sub bootstrap_inherit { my $module = $_[0]; + + no strict qw/refs vars/; local *isa = *{"$module\::ISA"}; local @isa = (@isa, 'DynaLoader'); # Cannot goto due to delocalization. Will report errors on a wrong line? @@ -300,9 +307,9 @@ sub bootstrap_inherit { sub bootstrap { # use local vars to enable $module.bs script to edit values - local(@args) = @_; - local($module) = $args[0]; - local(@dirs, $file); + local our (@args) = @_; + local our ($module) = $args[0]; + local our (@dirs, $file); unless ($module) { require Carp; @@ -494,12 +501,20 @@ sub dl_findfile { foreach $name (@names) { my($file) = "$dir$dirsep$name"; print STDERR " checking in $dir for $name\n" if $dl_debug; - $file = ($do_expand) ? dl_expandspec($file) : (-f $file && $file); - #$file = _check_file($file); - if ($file) { + if ($do_expand && ($file = dl_expandspec($file))) { + push @found, $file; + next arg; # no need to look any further + } + elsif (-f $file) { push(@found, $file); next arg; # no need to look any further } + <<$^O-eq-darwin>> + elsif (dl_load_file($file, 0)) { + push @found, $file; + next arg; # no need to look any further + } + <> } } } @@ -550,6 +565,8 @@ sub dl_find_symbol_anywhere return undef; } +1; + __END__ =head1 NAME diff --git a/ext/DynaLoader/Makefile.PL b/ext/DynaLoader/Makefile.PL index 864af3ed8e2a..5579bc612084 100644 --- a/ext/DynaLoader/Makefile.PL +++ b/ext/DynaLoader/Makefile.PL @@ -1,4 +1,6 @@ use strict; +use warnings; + use ExtUtils::MakeMaker; my $is_mswin = $^O eq 'MSWin32'; diff --git a/ext/DynaLoader/dlutils.c b/ext/DynaLoader/dlutils.c index 8584f89e6bba..a818e7ac5cc7 100644 --- a/ext/DynaLoader/dlutils.c +++ b/ext/DynaLoader/dlutils.c @@ -27,10 +27,10 @@ typedef struct { SV* x_dl_last_error; /* pointer to allocated memory for - last error message */ + last error message */ #if defined(PERL_IN_DL_HPUX_XS) || defined(PERL_IN_DL_DLOPEN_XS) int x_dl_nonlazy; /* flag for immediate rather than lazy - linking (spots unresolved symbol) */ + linking (spots unresolved symbol) */ #endif #ifdef DL_LOADONCEONLY HV * x_dl_loaded_files; /* only needed on a few systems */ @@ -62,8 +62,8 @@ START_MY_CXT #ifdef DEBUGGING #define DLDEBUG(level,code) \ STMT_START { \ - dMY_CXT; \ - if (dl_debug>=level) { code; } \ + dMY_CXT; \ + if (dl_debug>=level) { code; } \ } STMT_END #else #define DLDEBUG(level,code) NOOP @@ -109,25 +109,25 @@ dl_generic_private_init(pTHX) /* called by dl_*.xs dl_private_init() */ #endif #ifdef DEBUGGING { - SV *sv = get_sv("DynaLoader::dl_debug", 0); - dl_debug = sv ? SvIV(sv) : 0; + SV *sv = get_sv("DynaLoader::dl_debug", 0); + dl_debug = sv ? SvIV(sv) : 0; } #endif #if defined(PERL_IN_DL_HPUX_XS) || defined(PERL_IN_DL_DLOPEN_XS) - if ( (perl_dl_nonlazy = getenv("PERL_DL_NONLAZY")) != NULL - && grok_atoUV(perl_dl_nonlazy, &uv, NULL) - && uv <= INT_MAX + if ( (perl_dl_nonlazy = PerlEnv_getenv("PERL_DL_NONLAZY")) != NULL + && grok_atoUV(perl_dl_nonlazy, &uv, NULL) + && uv <= INT_MAX ) { - dl_nonlazy = (int)uv; + dl_nonlazy = (int)uv; } else - dl_nonlazy = 0; + dl_nonlazy = 0; if (dl_nonlazy) - DLDEBUG(1,PerlIO_printf(Perl_debug_log, "DynaLoader bind mode is 'non-lazy'\n")); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "DynaLoader bind mode is 'non-lazy'\n")); #endif #ifdef DL_LOADONCEONLY if (!dl_loaded_files) - dl_loaded_files = newHV(); /* provide cache for dl_*.xs if needed */ + dl_loaded_files = newHV(); /* provide cache for dl_*.xs if needed */ #endif #ifdef DL_UNLOAD_ALL_AT_EXIT call_atexit(&dl_unload_all_files, (void*)0); @@ -155,10 +155,10 @@ SaveError(pTHX_ const char* pat, ...) len++; /* include terminating null char */ { - dMY_CXT; + dMY_CXT; /* Copy message into dl_last_error (including terminating null char) */ - sv_setpvn(MY_CXT.x_dl_last_error, message, len) ; - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "DynaLoader: stored error msg '%s'\n",dl_last_error)); + sv_setpvn(MY_CXT.x_dl_last_error, message, len) ; + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "DynaLoader: stored error msg '%s'\n",dl_last_error)); } } #endif diff --git a/ext/DynaLoader/t/DynaLoader.t b/ext/DynaLoader/t/DynaLoader.t index f077088f352b..11b37b5c4e69 100644 --- a/ext/DynaLoader/t/DynaLoader.t +++ b/ext/DynaLoader/t/DynaLoader.t @@ -1,6 +1,8 @@ #!/usr/bin/perl -wT use strict; +use warnings; + use Config; push @INC, '.'; if (-f 't/test.pl') { diff --git a/ext/Errno/.gitignore b/ext/Errno/.gitignore index fb9df2003588..5b0c2efa9d25 100644 --- a/ext/Errno/.gitignore +++ b/ext/Errno/.gitignore @@ -1,2 +1,3 @@ /Errno.pm /arch.txt +!/Makefile.PL diff --git a/ext/Fcntl/.gitignore b/ext/Fcntl/.gitignore index 2a06e93b553d..6531b6b8ed84 100644 --- a/ext/Fcntl/.gitignore +++ b/ext/Fcntl/.gitignore @@ -1 +1,2 @@ *.inc +!/Makefile.PL diff --git a/ext/File-Find/lib/File/Find.pm b/ext/File-Find/lib/File/Find.pm index 4c67e882a5e0..01dbc8b82590 100644 --- a/ext/File-Find/lib/File/Find.pm +++ b/ext/File-Find/lib/File/Find.pm @@ -3,7 +3,7 @@ use 5.006; use strict; use warnings; use warnings::register; -our $VERSION = '1.37'; +our $VERSION = '1.38'; require Exporter; require Cwd; @@ -161,9 +161,8 @@ sub _find_opt { $pre_process = $wanted->{preprocess}; $post_process = $wanted->{postprocess}; $no_chdir = $wanted->{no_chdir}; - $full_check = $Is_Win32 ? 0 : $wanted->{follow}; - $follow = $Is_Win32 ? 0 : - $full_check || $wanted->{follow_fast}; + $full_check = $wanted->{follow}; + $follow = $full_check || $wanted->{follow_fast}; $follow_skip = $wanted->{follow_skip}; $untaint = $wanted->{untaint}; $untaint_pat = $wanted->{untaint_pattern}; diff --git a/ext/File-Find/t/find.t b/ext/File-Find/t/find.t index 40d14db0c687..add20c268394 100644 --- a/ext/File-Find/t/find.t +++ b/ext/File-Find/t/find.t @@ -24,13 +24,8 @@ BEGIN { } my $symlink_exists = eval { symlink("",""); 1 }; -my $test_count = 111; -$test_count += 127 if $symlink_exists; -$test_count += 26 if $^O eq 'MSWin32'; -$test_count += 2 if $^O eq 'MSWin32' and $symlink_exists; use Test::More; -plan tests => $test_count; use lib qw( ./t/lib ); use Testing qw( create_file_ok @@ -39,6 +34,7 @@ use Testing qw( dir_path file_path ); +use Errno (); my %Expect_File = (); # what we expect for $_ my %Expect_Name = (); # what we expect for $File::Find::name/fullname @@ -252,7 +248,17 @@ create_file_ok( file_path('fb', $testing_basenames[0]) ); mkdir_ok( dir_path('fb', 'fba'), 0770 ); create_file_ok( file_path('fb', 'fba', $testing_basenames[1]) ); if ($symlink_exists) { - symlink_ok('../fb','fa/fsl'); + if (symlink('../fb','fa/fsl')) { + pass("able to symlink from ../fb to fa/fsl"); + } + else { + if ($^O eq "MSWin32" && ($! == &Errno::ENOSYS || $! == &Errno::EPERM)) { + $symlink_exists = 0; + } + else { + fail("able to symlink from ../fb to fa/fsl"); + } + } } create_file_ok( file_path('fa', $testing_basenames[2]) ); @@ -885,6 +891,7 @@ if ($^O eq 'MSWin32') { dir_path('fb') => 1, dir_path('fba') => 1); + $FastFileTests_OK = 0; File::Find::find( {wanted => \&wanted_File_Dir}, topdir('fa')); is( scalar(keys %Expect_File), 0, "Got no files, as expected" ); @@ -1104,3 +1111,5 @@ if ($^O eq 'MSWin32') { like($@, qr/invalid top directory/, "find() correctly died due to undefined top directory"); } + +done_testing(); diff --git a/ext/File-Find/t/lib/Testing.pm b/ext/File-Find/t/lib/Testing.pm index c638ce06b756..056e06cc8118 100644 --- a/ext/File-Find/t/lib/Testing.pm +++ b/ext/File-Find/t/lib/Testing.pm @@ -28,7 +28,7 @@ sub mkdir_ok($$;$) { my ($dir, $mask) = @_[0..1]; my $msg = $_[2] || "able to mkdir: $dir"; ok( mkdir($dir, $mask), $msg ) - or die("Unable to mkdir: $dir"); + or die("Unable to mkdir $!: $dir"); } sub symlink_ok($$;$) { diff --git a/ext/File-Find/t/taint.t b/ext/File-Find/t/taint.t index f56d18696c91..aed431aed47c 100644 --- a/ext/File-Find/t/taint.t +++ b/ext/File-Find/t/taint.t @@ -1,5 +1,24 @@ #!./perl -T use strict; + +BEGIN { + require File::Spec; + if ($ENV{PERL_CORE}) { + # May be doing dynamic loading while @INC is all relative + @INC = map { $_ = File::Spec->rel2abs($_); /(.*)/; $1 } @INC; + } + + if ($^O eq 'MSWin32' || $^O eq 'cygwin' || $^O eq 'VMS') { + # This is a hack - at present File::Find does not produce native names + # on Win32 or VMS, so force File::Spec to use Unix names. + # must be set *before* importing File::Find + require File::Spec::Unix; + @File::Spec::ISA = 'File::Spec::Unix'; + } + require File::Find; + import File::Find; +} + use Test::More; BEGIN { plan( @@ -16,6 +35,7 @@ use Testing qw( dir_path file_path ); +use Errno (); my %Expect_File = (); # what we expect for $_ my %Expect_Name = (); # what we expect for $File::Find::name/fullname @@ -169,8 +189,21 @@ create_file_ok( file_path('fb_taint', 'fb_ord') ); mkdir_ok( dir_path('fb_taint', 'fba'), 0770 ); create_file_ok( file_path('fb_taint', 'fba', 'fba_ord') ); SKIP: { - skip "Creating symlink", 1, unless $symlink_exists; - ok( symlink('../fb_taint','fa_taint/fsl'), 'Created symbolic link' ); + skip "Creating symlink", 1, unless $symlink_exists; + if (symlink('../fb_taint','fa_taint/fsl')) { + pass('Created symbolic link' ); + } + else { + my $error = 0 + $!; + if ($^O eq "MSWin32" && + ($error == &Errno::ENOSYS || $error == &Errno::EPERM)) { + $symlink_exists = 0; + skip "symbolic links not available", 1; + } + else { + fail('Created symbolic link'); + } + } } create_file_ok( file_path('fa_taint', 'fa_ord') ); @@ -201,7 +234,8 @@ delete @Expect_Dir{ dir_path('fb_taint'), dir_path('fba') } unless $symlink_exis File::Find::find( {wanted => \&wanted_File_Dir_prune, untaint => 1, untaint_pattern => qr|^(.+)$|}, topdir('fa_taint') ); -is(scalar keys %Expect_File, 0, 'Found all expected files'); +is(scalar keys %Expect_File, 0, 'Found all expected files') + or diag "Not found " . join(" ", sort keys %Expect_File); # don't untaint at all, should die %Expect_File = (); diff --git a/ext/File-Glob/.gitignore b/ext/File-Glob/.gitignore index 2a06e93b553d..d71ca7dde516 100644 --- a/ext/File-Glob/.gitignore +++ b/ext/File-Glob/.gitignore @@ -1 +1,3 @@ *.inc +!/Makefile.PL +!/bsd_glob.c diff --git a/ext/File-Glob/bsd_glob.c b/ext/File-Glob/bsd_glob.c index b038dd117a32..7a810db93ff9 100644 --- a/ext/File-Glob/bsd_glob.c +++ b/ext/File-Glob/bsd_glob.c @@ -74,8 +74,8 @@ static char sscsid[]= "$OpenBSD: glob.c,v 1.8.10.1 2001/04/10 jason Exp $"; # include #else #if defined(HAS_PASSWD) && !defined(VMS) - struct passwd *getpwnam(char *); - struct passwd *getpwuid(Uid_t); + struct passwd *getpwnam(char *); + struct passwd *getpwuid(Uid_t); #endif #endif @@ -168,12 +168,12 @@ static int g_stat(Char *, Stat_t *, glob_t *); static int glob0(const Char *, glob_t *); static int glob1(Char *, Char *, glob_t *, size_t *); static int glob2(Char *, Char *, Char *, Char *, Char *, Char *, - glob_t *, size_t *); + glob_t *, size_t *); static int glob3(Char *, Char *, Char *, Char *, Char *, - Char *, Char *, glob_t *, size_t *); + Char *, Char *, glob_t *, size_t *); static int globextend(const Char *, glob_t *, size_t *); static const Char * - globtilde(const Char *, Char *, size_t, glob_t *); + globtilde(const Char *, Char *, size_t, glob_t *); static int globexp1(const Char *, glob_t *); static int globexp2(const Char *, const Char *, glob_t *, int *); static int match(Char *, Char *, Char *, int); @@ -216,82 +216,82 @@ my_readdir(DIR *d) int bsd_glob(const char *pattern, int flags, - int (*errfunc)(const char *, int), glob_t *pglob) + int (*errfunc)(const char *, int), glob_t *pglob) { - const U8 *patnext; - int c; - Char *bufnext, *bufend, patbuf[MAXPATHLEN]; - patnext = (U8 *) pattern; - /* TODO: GLOB_APPEND / GLOB_DOOFFS aren't supported yet */ + const U8 *patnext; + int c; + Char *bufnext, *bufend, patbuf[MAXPATHLEN]; + patnext = (U8 *) pattern; + /* TODO: GLOB_APPEND / GLOB_DOOFFS aren't supported yet */ #if 0 - if (!(flags & GLOB_APPEND)) { - pglob->gl_pathc = 0; - pglob->gl_pathv = NULL; - if (!(flags & GLOB_DOOFFS)) - pglob->gl_offs = 0; - } + if (!(flags & GLOB_APPEND)) { + pglob->gl_pathc = 0; + pglob->gl_pathv = NULL; + if (!(flags & GLOB_DOOFFS)) + pglob->gl_offs = 0; + } #else - pglob->gl_pathc = 0; - pglob->gl_pathv = NULL; - pglob->gl_offs = 0; + pglob->gl_pathc = 0; + pglob->gl_pathv = NULL; + pglob->gl_offs = 0; #endif - pglob->gl_flags = flags & ~GLOB_MAGCHAR; - pglob->gl_errfunc = errfunc; - pglob->gl_matchc = 0; + pglob->gl_flags = flags & ~GLOB_MAGCHAR; + pglob->gl_errfunc = errfunc; + pglob->gl_matchc = 0; - bufnext = patbuf; - bufend = bufnext + MAXPATHLEN - 1; + bufnext = patbuf; + bufend = bufnext + MAXPATHLEN - 1; #ifdef DOSISH - /* Nasty hack to treat patterns like "C:*" correctly. In this - * case, the * should match any file in the current directory - * on the C: drive. However, the glob code does not treat the - * colon specially, so it looks for files beginning "C:" in - * the current directory. To fix this, change the pattern to - * add an explicit "./" at the start (just after the drive - * letter and colon - ie change to "C:./"). - */ - if (isalpha(pattern[0]) && pattern[1] == ':' && - pattern[2] != BG_SEP && pattern[2] != BG_SEP2 && - bufend - bufnext > 4) { - *bufnext++ = pattern[0]; - *bufnext++ = ':'; - *bufnext++ = '.'; - *bufnext++ = BG_SEP; - patnext += 2; - } + /* Nasty hack to treat patterns like "C:*" correctly. In this + * case, the * should match any file in the current directory + * on the C: drive. However, the glob code does not treat the + * colon specially, so it looks for files beginning "C:" in + * the current directory. To fix this, change the pattern to + * add an explicit "./" at the start (just after the drive + * letter and colon - ie change to "C:./"). + */ + if (isalpha(pattern[0]) && pattern[1] == ':' && + pattern[2] != BG_SEP && pattern[2] != BG_SEP2 && + bufend - bufnext > 4) { + *bufnext++ = pattern[0]; + *bufnext++ = ':'; + *bufnext++ = '.'; + *bufnext++ = BG_SEP; + patnext += 2; + } #endif - if (flags & GLOB_QUOTE) { - /* Protect the quoted characters. */ - while (bufnext < bufend && (c = *patnext++) != BG_EOS) - if (c == BG_QUOTE) { + if (flags & GLOB_QUOTE) { + /* Protect the quoted characters. */ + while (bufnext < bufend && (c = *patnext++) != BG_EOS) + if (c == BG_QUOTE) { #ifdef DOSISH - /* To avoid backslashitis on Win32, - * we only treat \ as a quoting character - * if it precedes one of the - * metacharacters []-{}~\ - */ - if ((c = *patnext++) != '[' && c != ']' && - c != '-' && c != '{' && c != '}' && - c != '~' && c != '\\') { + /* To avoid backslashitis on Win32, + * we only treat \ as a quoting character + * if it precedes one of the + * metacharacters []-{}~\ + */ + if ((c = *patnext++) != '[' && c != ']' && + c != '-' && c != '{' && c != '}' && + c != '~' && c != '\\') { #else - if ((c = *patnext++) == BG_EOS) { + if ((c = *patnext++) == BG_EOS) { #endif - c = BG_QUOTE; - --patnext; - } - *bufnext++ = c | M_PROTECT; - } else - *bufnext++ = c; - } else - while (bufnext < bufend && (c = *patnext++) != BG_EOS) - *bufnext++ = c; - *bufnext = BG_EOS; - - if (flags & GLOB_BRACE) - return globexp1(patbuf, pglob); - else - return glob0(patbuf, pglob); + c = BG_QUOTE; + --patnext; + } + *bufnext++ = c | M_PROTECT; + } else + *bufnext++ = c; + } else + while (bufnext < bufend && (c = *patnext++) != BG_EOS) + *bufnext++ = c; + *bufnext = BG_EOS; + + if (flags & GLOB_BRACE) + return globexp1(patbuf, pglob); + else + return glob0(patbuf, pglob); } /* @@ -302,18 +302,18 @@ bsd_glob(const char *pattern, int flags, static int globexp1(const Char *pattern, glob_t *pglob) { - const Char* ptr = pattern; - int rv; + const Char* ptr = pattern; + int rv; - /* Protect a single {}, for find(1), like csh */ - if (pattern[0] == BG_LBRACE && pattern[1] == BG_RBRACE && pattern[2] == BG_EOS) - return glob0(pattern, pglob); + /* Protect a single {}, for find(1), like csh */ + if (pattern[0] == BG_LBRACE && pattern[1] == BG_RBRACE && pattern[2] == BG_EOS) + return glob0(pattern, pglob); - while ((ptr = (const Char *) g_strchr((Char *) ptr, BG_LBRACE)) != NULL) - if (!globexp2(ptr, pattern, pglob, &rv)) - return rv; + while ((ptr = (const Char *) g_strchr((Char *) ptr, BG_LBRACE)) != NULL) + if (!globexp2(ptr, pattern, pglob, &rv)) + return rv; - return glob0(pattern, pglob); + return glob0(pattern, pglob); } @@ -324,103 +324,103 @@ globexp1(const Char *pattern, glob_t *pglob) */ static int globexp2(const Char *ptr, const Char *pattern, - glob_t *pglob, int *rv) + glob_t *pglob, int *rv) { - int i; - Char *lm, *ls; - const Char *pe, *pm, *pm1, *pl; - Char patbuf[MAXPATHLEN]; - - /* copy part up to the brace */ - for (lm = patbuf, pm = pattern; pm != ptr; *lm++ = *pm++) - ; - *lm = BG_EOS; - ls = lm; - - /* Find the balanced brace */ - for (i = 0, pe = ++ptr; *pe; pe++) - if (*pe == BG_LBRACKET) { - /* Ignore everything between [] */ - for (pm = pe++; *pe != BG_RBRACKET && *pe != BG_EOS; pe++) - ; - if (*pe == BG_EOS) { - /* - * We could not find a matching BG_RBRACKET. - * Ignore and just look for BG_RBRACE - */ - pe = pm; - } - } else if (*pe == BG_LBRACE) - i++; - else if (*pe == BG_RBRACE) { - if (i == 0) - break; - i--; - } - - /* Non matching braces; just glob the pattern */ - if (i != 0 || *pe == BG_EOS) { - *rv = glob0(patbuf, pglob); - return 0; - } - - for (i = 0, pl = pm = ptr; pm <= pe; pm++) { - switch (*pm) { - case BG_LBRACKET: - /* Ignore everything between [] */ - for (pm1 = pm++; *pm != BG_RBRACKET && *pm != BG_EOS; pm++) - ; - if (*pm == BG_EOS) { - /* - * We could not find a matching BG_RBRACKET. - * Ignore and just look for BG_RBRACE - */ - pm = pm1; - } - break; - - case BG_LBRACE: - i++; - break; - - case BG_RBRACE: - if (i) { - i--; - break; - } - /* FALLTHROUGH */ - case BG_COMMA: - if (i && *pm == BG_COMMA) - break; - else { - /* Append the current string */ - for (lm = ls; (pl < pm); *lm++ = *pl++) - ; - - /* - * Append the rest of the pattern after the - * closing brace - */ - for (pl = pe + 1; (*lm++ = *pl++) != BG_EOS; ) - ; - - /* Expand the current pattern */ + int i; + Char *lm, *ls; + const Char *pe, *pm, *pm1, *pl; + Char patbuf[MAXPATHLEN]; + + /* copy part up to the brace */ + for (lm = patbuf, pm = pattern; pm != ptr; *lm++ = *pm++) + ; + *lm = BG_EOS; + ls = lm; + + /* Find the balanced brace */ + for (i = 0, pe = ++ptr; *pe; pe++) + if (*pe == BG_LBRACKET) { + /* Ignore everything between [] */ + for (pm = pe++; *pe != BG_RBRACKET && *pe != BG_EOS; pe++) + ; + if (*pe == BG_EOS) { + /* + * We could not find a matching BG_RBRACKET. + * Ignore and just look for BG_RBRACE + */ + pe = pm; + } + } else if (*pe == BG_LBRACE) + i++; + else if (*pe == BG_RBRACE) { + if (i == 0) + break; + i--; + } + + /* Non matching braces; just glob the pattern */ + if (i != 0 || *pe == BG_EOS) { + *rv = glob0(patbuf, pglob); + return 0; + } + + for (i = 0, pl = pm = ptr; pm <= pe; pm++) { + switch (*pm) { + case BG_LBRACKET: + /* Ignore everything between [] */ + for (pm1 = pm++; *pm != BG_RBRACKET && *pm != BG_EOS; pm++) + ; + if (*pm == BG_EOS) { + /* + * We could not find a matching BG_RBRACKET. + * Ignore and just look for BG_RBRACE + */ + pm = pm1; + } + break; + + case BG_LBRACE: + i++; + break; + + case BG_RBRACE: + if (i) { + i--; + break; + } + /* FALLTHROUGH */ + case BG_COMMA: + if (i && *pm == BG_COMMA) + break; + else { + /* Append the current string */ + for (lm = ls; (pl < pm); *lm++ = *pl++) + ; + + /* + * Append the rest of the pattern after the + * closing brace + */ + for (pl = pe + 1; (*lm++ = *pl++) != BG_EOS; ) + ; + + /* Expand the current pattern */ #ifdef GLOB_DEBUG - qprintf("globexp2:", patbuf); + qprintf("globexp2:", patbuf); #endif /* GLOB_DEBUG */ - *rv = globexp1(patbuf, pglob); - - /* move after the comma, to the next string */ - pl = pm + 1; - } - break; - - default: - break; - } - } - *rv = 0; - return 0; + *rv = globexp1(patbuf, pglob); + + /* move after the comma, to the next string */ + pl = pm + 1; + } + break; + + default: + break; + } + } + *rv = 0; + return 0; } @@ -431,76 +431,76 @@ globexp2(const Char *ptr, const Char *pattern, static const Char * globtilde(const Char *pattern, Char *patbuf, size_t patbuf_len, glob_t *pglob) { - char *h; - const Char *p; - Char *b, *eb; + char *h; + const Char *p; + Char *b, *eb; - if (*pattern != BG_TILDE || !(pglob->gl_flags & GLOB_TILDE)) - return pattern; + if (*pattern != BG_TILDE || !(pglob->gl_flags & GLOB_TILDE)) + return pattern; - /* Copy up to the end of the string or / */ - eb = &patbuf[patbuf_len - 1]; - for (p = pattern + 1, h = (char *) patbuf; - h < (char*)eb && *p && *p != BG_SLASH; *h++ = (char)*p++) - ; + /* Copy up to the end of the string or / */ + eb = &patbuf[patbuf_len - 1]; + for (p = pattern + 1, h = (char *) patbuf; + h < (char*)eb && *p && *p != BG_SLASH; *h++ = (char)*p++) + ; - *h = BG_EOS; + *h = BG_EOS; #if 0 - if (h == (char *)eb) - return what; + if (h == (char *)eb) + return what; #endif - if (((char *) patbuf)[0] == BG_EOS) { - /* - * handle a plain ~ or ~/ by expanding $HOME - * first and then trying the password file - * or $USERPROFILE on DOSISH systems - */ - if ((h = PerlEnv_getenv("HOME")) == NULL) { + if (((char *) patbuf)[0] == BG_EOS) { + /* + * handle a plain ~ or ~/ by expanding $HOME + * first and then trying the password file + * or $USERPROFILE on DOSISH systems + */ + if ((h = PerlEnv_getenv("HOME")) == NULL) { #ifdef HAS_PASSWD - struct passwd *pwd; - if ((pwd = getpwuid(getuid())) == NULL) - return pattern; - else - h = pwd->pw_dir; + struct passwd *pwd; + if ((pwd = getpwuid(getuid())) == NULL) + return pattern; + else + h = pwd->pw_dir; #elif DOSISH - /* - * When no passwd file, fallback to the USERPROFILE - * environment variable on DOSish systems. - */ - if ((h = PerlEnv_getenv("USERPROFILE")) == NULL) { - return pattern; - } + /* + * When no passwd file, fallback to the USERPROFILE + * environment variable on DOSish systems. + */ + if ((h = PerlEnv_getenv("USERPROFILE")) == NULL) { + return pattern; + } #else return pattern; #endif - } - } else { - /* - * Expand a ~user - */ + } + } else { + /* + * Expand a ~user + */ #ifdef HAS_PASSWD - struct passwd *pwd; - if ((pwd = getpwnam((char*) patbuf)) == NULL) - return pattern; - else - h = pwd->pw_dir; + struct passwd *pwd; + if ((pwd = getpwnam((char*) patbuf)) == NULL) + return pattern; + else + h = pwd->pw_dir; #else return pattern; #endif - } + } - /* Copy the home directory */ - for (b = patbuf; b < eb && *h; *b++ = *h++) - ; + /* Copy the home directory */ + for (b = patbuf; b < eb && *h; *b++ = *h++) + ; - /* Append the rest of the pattern */ - while (b < eb && (*b++ = *p++) != BG_EOS) - ; - *b = BG_EOS; + /* Append the rest of the pattern */ + while (b < eb && (*b++ = *p++) != BG_EOS) + ; + *b = BG_EOS; - return patbuf; + return patbuf; } @@ -514,142 +514,142 @@ globtilde(const Char *pattern, Char *patbuf, size_t patbuf_len, glob_t *pglob) static int glob0(const Char *pattern, glob_t *pglob) { - const Char *qpat, *qpatnext; - int c, err, oldflags, oldpathc; - Char *bufnext, patbuf[MAXPATHLEN]; - size_t limit = 0; - - qpat = globtilde(pattern, patbuf, MAXPATHLEN, pglob); - qpatnext = qpat; - oldflags = pglob->gl_flags; - oldpathc = pglob->gl_pathc; - bufnext = patbuf; - - /* We don't need to check for buffer overflow any more. */ - while ((c = *qpatnext++) != BG_EOS) { - switch (c) { - case BG_LBRACKET: - c = *qpatnext; - if (c == BG_NOT) - ++qpatnext; - if (*qpatnext == BG_EOS || - g_strchr((Char *) qpatnext+1, BG_RBRACKET) == NULL) { - *bufnext++ = BG_LBRACKET; - if (c == BG_NOT) - --qpatnext; - break; - } - *bufnext++ = M_SET; - if (c == BG_NOT) - *bufnext++ = M_NOT; - c = *qpatnext++; - do { - *bufnext++ = CHAR(c); - if (*qpatnext == BG_RANGE && - (c = qpatnext[1]) != BG_RBRACKET) { - *bufnext++ = M_RNG; - *bufnext++ = CHAR(c); - qpatnext += 2; - } - } while ((c = *qpatnext++) != BG_RBRACKET); - pglob->gl_flags |= GLOB_MAGCHAR; - *bufnext++ = M_END; - break; - case BG_QUESTION: - pglob->gl_flags |= GLOB_MAGCHAR; - *bufnext++ = M_ONE; - break; - case BG_STAR: - pglob->gl_flags |= GLOB_MAGCHAR; + const Char *qpat, *qpatnext; + int c, err, oldflags, oldpathc; + Char *bufnext, patbuf[MAXPATHLEN]; + size_t limit = 0; + + qpat = globtilde(pattern, patbuf, MAXPATHLEN, pglob); + qpatnext = qpat; + oldflags = pglob->gl_flags; + oldpathc = pglob->gl_pathc; + bufnext = patbuf; + + /* We don't need to check for buffer overflow any more. */ + while ((c = *qpatnext++) != BG_EOS) { + switch (c) { + case BG_LBRACKET: + c = *qpatnext; + if (c == BG_NOT) + ++qpatnext; + if (*qpatnext == BG_EOS || + g_strchr((Char *) qpatnext+1, BG_RBRACKET) == NULL) { + *bufnext++ = BG_LBRACKET; + if (c == BG_NOT) + --qpatnext; + break; + } + *bufnext++ = M_SET; + if (c == BG_NOT) + *bufnext++ = M_NOT; + c = *qpatnext++; + do { + *bufnext++ = CHAR(c); + if (*qpatnext == BG_RANGE && + (c = qpatnext[1]) != BG_RBRACKET) { + *bufnext++ = M_RNG; + *bufnext++ = CHAR(c); + qpatnext += 2; + } + } while ((c = *qpatnext++) != BG_RBRACKET); + pglob->gl_flags |= GLOB_MAGCHAR; + *bufnext++ = M_END; + break; + case BG_QUESTION: + pglob->gl_flags |= GLOB_MAGCHAR; + *bufnext++ = M_ONE; + break; + case BG_STAR: + pglob->gl_flags |= GLOB_MAGCHAR; /* Collapse adjacent stars to one. * This is required to ensure that a pattern like * "a**" matches a name like "a", as without this * check when the first star matched everything it would * cause the second star to return a match fail. * As long ** is folded here this does not happen. - */ - if (bufnext == patbuf || bufnext[-1] != M_ALL) - *bufnext++ = M_ALL; - break; - default: - *bufnext++ = CHAR(c); - break; - } - } - *bufnext = BG_EOS; + */ + if (bufnext == patbuf || bufnext[-1] != M_ALL) + *bufnext++ = M_ALL; + break; + default: + *bufnext++ = CHAR(c); + break; + } + } + *bufnext = BG_EOS; #ifdef GLOB_DEBUG - qprintf("glob0:", patbuf); + qprintf("glob0:", patbuf); #endif /* GLOB_DEBUG */ - if ((err = glob1(patbuf, patbuf+MAXPATHLEN-1, pglob, &limit)) != 0) { - pglob->gl_flags = oldflags; - return(err); - } - - /* - * If there was no match we are going to append the pattern - * if GLOB_NOCHECK was specified or if GLOB_NOMAGIC was specified - * and the pattern did not contain any magic characters - * GLOB_NOMAGIC is there just for compatibility with csh. - */ - if (pglob->gl_pathc == oldpathc && - ((pglob->gl_flags & GLOB_NOCHECK) || - ((pglob->gl_flags & GLOB_NOMAGIC) && - !(pglob->gl_flags & GLOB_MAGCHAR)))) - { + if ((err = glob1(patbuf, patbuf+MAXPATHLEN-1, pglob, &limit)) != 0) { + pglob->gl_flags = oldflags; + return(err); + } + + /* + * If there was no match we are going to append the pattern + * if GLOB_NOCHECK was specified or if GLOB_NOMAGIC was specified + * and the pattern did not contain any magic characters + * GLOB_NOMAGIC is there just for compatibility with csh. + */ + if (pglob->gl_pathc == oldpathc && + ((pglob->gl_flags & GLOB_NOCHECK) || + ((pglob->gl_flags & GLOB_NOMAGIC) && + !(pglob->gl_flags & GLOB_MAGCHAR)))) + { #ifdef GLOB_DEBUG - printf("calling globextend from glob0\n"); + printf("calling globextend from glob0\n"); #endif /* GLOB_DEBUG */ - pglob->gl_flags = oldflags; - return(globextend(qpat, pglob, &limit)); + pglob->gl_flags = oldflags; + return(globextend(qpat, pglob, &limit)); } - else if (!(pglob->gl_flags & GLOB_NOSORT)) + else if (!(pglob->gl_flags & GLOB_NOSORT)) if (pglob->gl_pathv) - qsort(pglob->gl_pathv + pglob->gl_offs + oldpathc, - pglob->gl_pathc - oldpathc, sizeof(char *), - (pglob->gl_flags & (GLOB_ALPHASORT|GLOB_NOCASE)) - ? ci_compare : compare); - pglob->gl_flags = oldflags; - return(0); + qsort(pglob->gl_pathv + pglob->gl_offs + oldpathc, + pglob->gl_pathc - oldpathc, sizeof(char *), + (pglob->gl_flags & (GLOB_ALPHASORT|GLOB_NOCASE)) + ? ci_compare : compare); + pglob->gl_flags = oldflags; + return(0); } static int ci_compare(const void *p, const void *q) { - const char *pp = *(const char **)p; - const char *qq = *(const char **)q; - int ci; - while (*pp && *qq) { - if (toFOLD(*pp) != toFOLD(*qq)) - break; - ++pp; - ++qq; - } - ci = toFOLD(*pp) - toFOLD(*qq); - if (ci == 0) - return compare(p, q); - return ci; + const char *pp = *(const char **)p; + const char *qq = *(const char **)q; + int ci; + while (*pp && *qq) { + if (toFOLD(*pp) != toFOLD(*qq)) + break; + ++pp; + ++qq; + } + ci = toFOLD(*pp) - toFOLD(*qq); + if (ci == 0) + return compare(p, q); + return ci; } static int compare(const void *p, const void *q) { - return(strcmp(*(char **)p, *(char **)q)); + return(strcmp(*(char **)p, *(char **)q)); } static int glob1(Char *pattern, Char *pattern_last, glob_t *pglob, size_t *limitp) { - Char pathbuf[MAXPATHLEN]; + Char pathbuf[MAXPATHLEN]; assert(pattern < pattern_last); - /* A null pathname is invalid -- POSIX 1003.1 sect. 2.4. */ - if (*pattern == BG_EOS) - return(0); - return(glob2(pathbuf, pathbuf+MAXPATHLEN-1, - pathbuf, pathbuf+MAXPATHLEN-1, - pattern, pattern_last, pglob, limitp)); + /* A null pathname is invalid -- POSIX 1003.1 sect. 2.4. */ + if (*pattern == BG_EOS) + return(0); + return(glob2(pathbuf, pathbuf+MAXPATHLEN-1, + pathbuf, pathbuf+MAXPATHLEN-1, + pattern, pattern_last, pglob, limitp)); } /* @@ -661,79 +661,79 @@ static int glob2(Char *pathbuf, Char *pathbuf_last, Char *pathend, Char *pathend_last, Char *pattern, Char *pattern_last, glob_t *pglob, size_t *limitp) { - Stat_t sb; - Char *p, *q; - int anymeta; + Stat_t sb; + Char *p, *q; + int anymeta; assert(pattern < pattern_last); - /* - * Loop over pattern segments until end of pattern or until - * segment with meta character found. - */ - for (anymeta = 0;;) { - if (*pattern == BG_EOS) { /* End of pattern? */ - *pathend = BG_EOS; - if (g_lstat(pathbuf, &sb, pglob)) - return(0); - - if (((pglob->gl_flags & GLOB_MARK) && - pathend[-1] != BG_SEP + /* + * Loop over pattern segments until end of pattern or until + * segment with meta character found. + */ + for (anymeta = 0;;) { + if (*pattern == BG_EOS) { /* End of pattern? */ + *pathend = BG_EOS; + if (g_lstat(pathbuf, &sb, pglob)) + return(0); + + if (((pglob->gl_flags & GLOB_MARK) && + pathend[-1] != BG_SEP #ifdef DOSISH - && pathend[-1] != BG_SEP2 + && pathend[-1] != BG_SEP2 #endif - ) && (S_ISDIR(sb.st_mode) || - (S_ISLNK(sb.st_mode) && - (g_stat(pathbuf, &sb, pglob) == 0) && - S_ISDIR(sb.st_mode)))) { - if (pathend+1 > pathend_last) - return (1); - *pathend++ = BG_SEP; - *pathend = BG_EOS; - } - ++pglob->gl_matchc; + ) && (S_ISDIR(sb.st_mode) || + (S_ISLNK(sb.st_mode) && + (g_stat(pathbuf, &sb, pglob) == 0) && + S_ISDIR(sb.st_mode)))) { + if (pathend+1 > pathend_last) + return (1); + *pathend++ = BG_SEP; + *pathend = BG_EOS; + } + ++pglob->gl_matchc; #ifdef GLOB_DEBUG printf("calling globextend from glob2\n"); #endif /* GLOB_DEBUG */ - return(globextend(pathbuf, pglob, limitp)); - } + return(globextend(pathbuf, pglob, limitp)); + } - /* Find end of next segment, copy tentatively to pathend. */ - q = pathend; - p = pattern; - while (*p != BG_EOS && *p != BG_SEP + /* Find end of next segment, copy tentatively to pathend. */ + q = pathend; + p = pattern; + while (*p != BG_EOS && *p != BG_SEP #ifdef DOSISH - && *p != BG_SEP2 + && *p != BG_SEP2 #endif - ) { + ) { assert(p < pattern_last); - if (ismeta(*p)) - anymeta = 1; - if (q+1 > pathend_last) - return (1); - *q++ = *p++; - } - - if (!anymeta) { /* No expansion, do next segment. */ - pathend = q; - pattern = p; - while (*pattern == BG_SEP + if (ismeta(*p)) + anymeta = 1; + if (q+1 > pathend_last) + return (1); + *q++ = *p++; + } + + if (!anymeta) { /* No expansion, do next segment. */ + pathend = q; + pattern = p; + while (*pattern == BG_SEP #ifdef DOSISH - || *pattern == BG_SEP2 + || *pattern == BG_SEP2 #endif - ) { + ) { assert(p < pattern_last); - if (pathend+1 > pathend_last) - return (1); - *pathend++ = *pattern++; - } - } else - /* Need expansion, recurse. */ - return(glob3(pathbuf, pathbuf_last, pathend, - pathend_last, pattern, - p, pattern_last, pglob, limitp)); - } - /* NOTREACHED */ + if (pathend+1 > pathend_last) + return (1); + *pathend++ = *pattern++; + } + } else + /* Need expansion, recurse. */ + return(glob3(pathbuf, pathbuf_last, pathend, + pathend_last, pattern, + p, pattern_last, pglob, limitp)); + } + /* NOTREACHED */ } static int @@ -741,97 +741,97 @@ glob3(Char *pathbuf, Char *pathbuf_last, Char *pathend, Char *pathend_last, Char *pattern, Char *restpattern, Char *restpattern_last, glob_t *pglob, size_t *limitp) { - Direntry_t *dp; - DIR *dirp; - int err; - int nocase; - char buf[MAXPATHLEN]; - - /* - * The readdirfunc declaration can't be prototyped, because it is - * assigned, below, to two functions which are prototyped in glob.h - * and dirent.h as taking pointers to differently typed opaque - * structures. - */ - Direntry_t *(*readdirfunc)(DIR*); + Direntry_t *dp; + DIR *dirp; + int err; + int nocase; + char buf[MAXPATHLEN]; + + /* + * The readdirfunc declaration can't be prototyped, because it is + * assigned, below, to two functions which are prototyped in glob.h + * and dirent.h as taking pointers to differently typed opaque + * structures. + */ + Direntry_t *(*readdirfunc)(DIR*); assert(pattern < restpattern_last); assert(restpattern < restpattern_last); - if (pathend > pathend_last) - return (1); - *pathend = BG_EOS; - errno = 0; + if (pathend > pathend_last) + return (1); + *pathend = BG_EOS; + errno = 0; #ifdef VMS { - Char *q = pathend; - if (q - pathbuf > 5) { - q -= 5; - if (q[0] == '.' && - tolower(q[1]) == 'd' && tolower(q[2]) == 'i' && - tolower(q[3]) == 'r' && q[4] == '/') - { - q[0] = '/'; - q[1] = BG_EOS; - pathend = q+1; - } - } + Char *q = pathend; + if (q - pathbuf > 5) { + q -= 5; + if (q[0] == '.' && + tolower(q[1]) == 'd' && tolower(q[2]) == 'i' && + tolower(q[3]) == 'r' && q[4] == '/') + { + q[0] = '/'; + q[1] = BG_EOS; + pathend = q+1; + } + } } #endif - if ((dirp = g_opendir(pathbuf, pglob)) == NULL) { - /* TODO: don't call for ENOENT or ENOTDIR? */ - if (pglob->gl_errfunc) { - if (g_Ctoc(pathbuf, buf, sizeof(buf))) - return (GLOB_ABEND); - if (pglob->gl_errfunc(buf, errno) || - (pglob->gl_flags & GLOB_ERR)) - return (GLOB_ABEND); - } - return(0); - } - - err = 0; - nocase = ((pglob->gl_flags & GLOB_NOCASE) != 0); - - /* Search directory for matching names. */ - if (pglob->gl_flags & GLOB_ALTDIRFUNC) - readdirfunc = (Direntry_t *(*)(DIR *))pglob->gl_readdir; - else - readdirfunc = (Direntry_t *(*)(DIR *))my_readdir; - while ((dp = (*readdirfunc)(dirp))) { - U8 *sc; - Char *dc; - - /* Initial BG_DOT must be matched literally. */ - if (dp->d_name[0] == BG_DOT && *pattern != BG_DOT) - continue; - dc = pathend; - sc = (U8 *) dp->d_name; - while (dc < pathend_last && (*dc++ = *sc++) != BG_EOS) - ; - if (dc >= pathend_last) { - *dc = BG_EOS; - err = 1; - break; - } - - if (!match(pathend, pattern, restpattern, nocase)) { - *pathend = BG_EOS; - continue; - } - err = glob2(pathbuf, pathbuf_last, --dc, pathend_last, - restpattern, restpattern_last, pglob, limitp); - if (err) - break; - } - - if (pglob->gl_flags & GLOB_ALTDIRFUNC) - (*pglob->gl_closedir)(dirp); - else - PerlDir_close(dirp); - return(err); + if ((dirp = g_opendir(pathbuf, pglob)) == NULL) { + /* TODO: don't call for ENOENT or ENOTDIR? */ + if (pglob->gl_errfunc) { + if (g_Ctoc(pathbuf, buf, sizeof(buf))) + return (GLOB_ABEND); + if (pglob->gl_errfunc(buf, errno) || + (pglob->gl_flags & GLOB_ERR)) + return (GLOB_ABEND); + } + return(0); + } + + err = 0; + nocase = ((pglob->gl_flags & GLOB_NOCASE) != 0); + + /* Search directory for matching names. */ + if (pglob->gl_flags & GLOB_ALTDIRFUNC) + readdirfunc = (Direntry_t *(*)(DIR *))pglob->gl_readdir; + else + readdirfunc = (Direntry_t *(*)(DIR *))my_readdir; + while ((dp = (*readdirfunc)(dirp))) { + U8 *sc; + Char *dc; + + /* Initial BG_DOT must be matched literally. */ + if (dp->d_name[0] == BG_DOT && *pattern != BG_DOT) + continue; + dc = pathend; + sc = (U8 *) dp->d_name; + while (dc < pathend_last && (*dc++ = *sc++) != BG_EOS) + ; + if (dc >= pathend_last) { + *dc = BG_EOS; + err = 1; + break; + } + + if (!match(pathend, pattern, restpattern, nocase)) { + *pathend = BG_EOS; + continue; + } + err = glob2(pathbuf, pathbuf_last, --dc, pathend_last, + restpattern, restpattern_last, pglob, limitp); + if (err) + break; + } + + if (pglob->gl_flags & GLOB_ALTDIRFUNC) + (*pglob->gl_closedir)(dirp); + else + PerlDir_close(dirp); + return(err); } @@ -852,61 +852,61 @@ glob3(Char *pathbuf, Char *pathbuf_last, Char *pathend, Char *pathend_last, static int globextend(const Char *path, glob_t *pglob, size_t *limitp) { - char **pathv; - int i; - STRLEN newsize, len; - char *copy; - const Char *p; + char **pathv; + int i; + STRLEN newsize, len; + char *copy; + const Char *p; #ifdef GLOB_DEBUG - printf("Adding "); + printf("Adding "); for (p = path; *p; p++) (void)printf("%c", CHAR(*p)); printf("\n"); #endif /* GLOB_DEBUG */ - newsize = sizeof(*pathv) * (2 + pglob->gl_pathc + pglob->gl_offs); - if (pglob->gl_pathv) - pathv = Renew(pglob->gl_pathv,newsize,char*); - else - Newx(pathv,newsize,char*); - if (pathv == NULL) { - if (pglob->gl_pathv) { - Safefree(pglob->gl_pathv); - pglob->gl_pathv = NULL; - } - return(GLOB_NOSPACE); - } - - if (pglob->gl_pathv == NULL && pglob->gl_offs > 0) { - /* first time around -- clear initial gl_offs items */ - pathv += pglob->gl_offs; - for (i = pglob->gl_offs; --i >= 0; ) - *--pathv = NULL; - } - pglob->gl_pathv = pathv; - - for (p = path; *p++;) - ; - len = (STRLEN)(p - path); - *limitp += len; - Newx(copy, p-path, char); - if (copy != NULL) { - if (g_Ctoc(path, copy, len)) { - Safefree(copy); - return(GLOB_NOSPACE); - } - pathv[pglob->gl_offs + pglob->gl_pathc++] = copy; - } - pathv[pglob->gl_offs + pglob->gl_pathc] = NULL; - - if ((pglob->gl_flags & GLOB_LIMIT) && - newsize + *limitp >= (unsigned long)ARG_MAX) { - errno = 0; - return(GLOB_NOSPACE); - } - - return(copy == NULL ? GLOB_NOSPACE : 0); + newsize = sizeof(*pathv) * (2 + pglob->gl_pathc + pglob->gl_offs); + if (pglob->gl_pathv) + pathv = Renew(pglob->gl_pathv,newsize,char*); + else + Newx(pathv,newsize,char*); + if (pathv == NULL) { + if (pglob->gl_pathv) { + Safefree(pglob->gl_pathv); + pglob->gl_pathv = NULL; + } + return(GLOB_NOSPACE); + } + + if (pglob->gl_pathv == NULL && pglob->gl_offs > 0) { + /* first time around -- clear initial gl_offs items */ + pathv += pglob->gl_offs; + for (i = pglob->gl_offs; --i >= 0; ) + *--pathv = NULL; + } + pglob->gl_pathv = pathv; + + for (p = path; *p++;) + ; + len = (STRLEN)(p - path); + *limitp += len; + Newx(copy, p-path, char); + if (copy != NULL) { + if (g_Ctoc(path, copy, len)) { + Safefree(copy); + return(GLOB_NOSPACE); + } + pathv[pglob->gl_offs + pglob->gl_pathc++] = copy; + } + pathv[pglob->gl_offs + pglob->gl_pathc] = NULL; + + if ((pglob->gl_flags & GLOB_LIMIT) && + newsize + *limitp >= (unsigned long)ARG_MAX) { + errno = 0; + return(GLOB_NOSPACE); + } + + return(copy == NULL ? GLOB_NOSPACE : 0); } @@ -930,171 +930,171 @@ globextend(const Char *path, glob_t *pglob, size_t *limitp) static int match(Char *name, Char *pat, Char *patend, int nocase) { - int ok, negate_range; - Char c, k; - Char *nextp = NULL; - Char *nextn = NULL; + int ok, negate_range; + Char c, k; + Char *nextp = NULL; + Char *nextn = NULL; redo: - while (pat < patend) { - c = *pat++; - switch (c & M_MASK) { - case M_ALL: - if (pat == patend) - return(1); - if (*name == BG_EOS) - return 0; - nextn = name + 1; - nextp = pat - 1; - break; - case M_ONE: + while (pat < patend) { + c = *pat++; + switch (c & M_MASK) { + case M_ALL: + if (pat == patend) + return(1); + if (*name == BG_EOS) + return 0; + nextn = name + 1; + nextp = pat - 1; + break; + case M_ONE: /* since * matches leftmost-shortest first * * if we encounter the EOS then backtracking * * will not help, so we can exit early here. */ - if (*name++ == BG_EOS) + if (*name++ == BG_EOS) return 0; - break; - case M_SET: - ok = 0; + break; + case M_SET: + ok = 0; /* since * matches leftmost-shortest first * * if we encounter the EOS then backtracking * * will not help, so we can exit early here. */ - if ((k = *name++) == BG_EOS) + if ((k = *name++) == BG_EOS) return 0; - if ((negate_range = ((*pat & M_MASK) == M_NOT)) != BG_EOS) - ++pat; - while (((c = *pat++) & M_MASK) != M_END) - if ((*pat & M_MASK) == M_RNG) { - if (nocase) { - if (tolower(c) <= tolower(k) && tolower(k) <= tolower(pat[1])) - ok = 1; - } else { - if (c <= k && k <= pat[1]) - ok = 1; - } - pat += 2; - } else if (nocase ? (tolower(c) == tolower(k)) : (c == k)) - ok = 1; - if (ok == negate_range) - goto fail; - break; - default: - k = *name++; - if (nocase ? (tolower(k) != tolower(c)) : (k != c)) - goto fail; - break; - } - } - if (*name == BG_EOS) - return 1; + if ((negate_range = ((*pat & M_MASK) == M_NOT)) != BG_EOS) + ++pat; + while (((c = *pat++) & M_MASK) != M_END) + if ((*pat & M_MASK) == M_RNG) { + if (nocase) { + if (tolower(c) <= tolower(k) && tolower(k) <= tolower(pat[1])) + ok = 1; + } else { + if (c <= k && k <= pat[1]) + ok = 1; + } + pat += 2; + } else if (nocase ? (tolower(c) == tolower(k)) : (c == k)) + ok = 1; + if (ok == negate_range) + goto fail; + break; + default: + k = *name++; + if (nocase ? (tolower(k) != tolower(c)) : (k != c)) + goto fail; + break; + } + } + if (*name == BG_EOS) + return 1; fail: - if (nextn) { - pat = nextp; - name = nextn; - goto redo; - } - return 0; + if (nextn) { + pat = nextp; + name = nextn; + goto redo; + } + return 0; } /* Free allocated data belonging to a glob_t structure. */ void bsd_globfree(glob_t *pglob) { - int i; - char **pp; - - if (pglob->gl_pathv != NULL) { - pp = pglob->gl_pathv + pglob->gl_offs; - for (i = pglob->gl_pathc; i--; ++pp) - if (*pp) - Safefree(*pp); - Safefree(pglob->gl_pathv); - pglob->gl_pathv = NULL; - } + int i; + char **pp; + + if (pglob->gl_pathv != NULL) { + pp = pglob->gl_pathv + pglob->gl_offs; + for (i = pglob->gl_pathc; i--; ++pp) + if (*pp) + Safefree(*pp); + Safefree(pglob->gl_pathv); + pglob->gl_pathv = NULL; + } } static DIR * g_opendir(Char *str, glob_t *pglob) { - char buf[MAXPATHLEN]; + char buf[MAXPATHLEN]; - if (!*str) { - my_strlcpy(buf, ".", sizeof(buf)); - } else { - if (g_Ctoc(str, buf, sizeof(buf))) - return(NULL); - } + if (!*str) { + my_strlcpy(buf, ".", sizeof(buf)); + } else { + if (g_Ctoc(str, buf, sizeof(buf))) + return(NULL); + } - if (pglob->gl_flags & GLOB_ALTDIRFUNC) - return((DIR*)(*pglob->gl_opendir)(buf)); + if (pglob->gl_flags & GLOB_ALTDIRFUNC) + return((DIR*)(*pglob->gl_opendir)(buf)); - return(PerlDir_open(buf)); + return(PerlDir_open(buf)); } static int g_lstat(Char *fn, Stat_t *sb, glob_t *pglob) { - char buf[MAXPATHLEN]; + char buf[MAXPATHLEN]; - if (g_Ctoc(fn, buf, sizeof(buf))) - return(-1); - if (pglob->gl_flags & GLOB_ALTDIRFUNC) - return((*pglob->gl_lstat)(buf, sb)); + if (g_Ctoc(fn, buf, sizeof(buf))) + return(-1); + if (pglob->gl_flags & GLOB_ALTDIRFUNC) + return((*pglob->gl_lstat)(buf, sb)); #ifdef HAS_LSTAT - return(PerlLIO_lstat(buf, sb)); + return(PerlLIO_lstat(buf, sb)); #else - return(PerlLIO_stat(buf, sb)); + return(PerlLIO_stat(buf, sb)); #endif /* HAS_LSTAT */ } static int g_stat(Char *fn, Stat_t *sb, glob_t *pglob) { - char buf[MAXPATHLEN]; + char buf[MAXPATHLEN]; - if (g_Ctoc(fn, buf, sizeof(buf))) - return(-1); - if (pglob->gl_flags & GLOB_ALTDIRFUNC) - return((*pglob->gl_stat)(buf, sb)); - return(PerlLIO_stat(buf, sb)); + if (g_Ctoc(fn, buf, sizeof(buf))) + return(-1); + if (pglob->gl_flags & GLOB_ALTDIRFUNC) + return((*pglob->gl_stat)(buf, sb)); + return(PerlLIO_stat(buf, sb)); } static Char * g_strchr(Char *str, int ch) { - do { - if (*str == ch) - return (str); - } while (*str++); - return (NULL); + do { + if (*str == ch) + return (str); + } while (*str++); + return (NULL); } static int g_Ctoc(const Char *str, char *buf, STRLEN len) { - while (len--) { - if ((*buf++ = (char)*str++) == BG_EOS) - return (0); - } - return (1); + while (len--) { + if ((*buf++ = (char)*str++) == BG_EOS) + return (0); + } + return (1); } #ifdef GLOB_DEBUG static void qprintf(const char *str, Char *s) { - Char *p; - - (void)printf("%s:\n", str); - for (p = s; *p; p++) - (void)printf("%c", CHAR(*p)); - (void)printf("\n"); - for (p = s; *p; p++) - (void)printf("%c", *p & M_PROTECT ? '"' : ' '); - (void)printf("\n"); - for (p = s; *p; p++) - (void)printf("%c", ismeta(*p) ? '_' : ' '); - (void)printf("\n"); + Char *p; + + (void)printf("%s:\n", str); + for (p = s; *p; p++) + (void)printf("%c", CHAR(*p)); + (void)printf("\n"); + for (p = s; *p; p++) + (void)printf("%c", *p & M_PROTECT ? '"' : ' '); + (void)printf("\n"); + for (p = s; *p; p++) + (void)printf("%c", ismeta(*p) ? '_' : ' '); + (void)printf("\n"); } #endif /* GLOB_DEBUG */ diff --git a/ext/File-Glob/bsd_glob.h b/ext/File-Glob/bsd_glob.h index c913cff9d836..424591c925dd 100644 --- a/ext/File-Glob/bsd_glob.h +++ b/ext/File-Glob/bsd_glob.h @@ -39,24 +39,24 @@ /* #include */ typedef struct { - int gl_pathc; /* Count of total paths so far. */ - int gl_matchc; /* Count of paths matching pattern. */ - int gl_offs; /* Reserved at beginning of gl_pathv. */ - int gl_flags; /* Copy of flags parameter to glob. */ - char **gl_pathv; /* List of paths matching pattern. */ - /* Copy of errfunc parameter to glob. */ - int (*gl_errfunc)(const char *, int); + int gl_pathc; /* Count of total paths so far. */ + int gl_matchc; /* Count of paths matching pattern. */ + int gl_offs; /* Reserved at beginning of gl_pathv. */ + int gl_flags; /* Copy of flags parameter to glob. */ + char **gl_pathv; /* List of paths matching pattern. */ + /* Copy of errfunc parameter to glob. */ + int (*gl_errfunc)(const char *, int); - /* - * Alternate filesystem access methods for glob; replacement - * versions of closedir(3), readdir(3), opendir(3), stat(2) - * and lstat(2). - */ - void (*gl_closedir)(void *); - Direntry_t *(*gl_readdir)(void *); - void *(*gl_opendir)(const char *); - int (*gl_lstat)(const char *, Stat_t *); - int (*gl_stat)(const char *, Stat_t *); + /* + * Alternate filesystem access methods for glob; replacement + * versions of closedir(3), readdir(3), opendir(3), stat(2) + * and lstat(2). + */ + void (*gl_closedir)(void *); + Direntry_t *(*gl_readdir)(void *); + void *(*gl_opendir)(const char *); + int (*gl_lstat)(const char *, Stat_t *); + int (*gl_stat)(const char *, Stat_t *); } glob_t; #define GLOB_APPEND 0x0001 /* Append to output from previous call. */ @@ -75,7 +75,7 @@ typedef struct { #define GLOB_NOCASE 0x1000 /* Treat filenames without regard for case. */ #define GLOB_ALPHASORT 0x2000 /* Alphabetic, not ASCII sort, like csh. */ #define GLOB_LIMIT 0x4000 /* Limit pattern match output to ARG_MAX - (usually from limits.h). */ + (usually from limits.h). */ #define GLOB_NOSPACE (-1) /* Malloc call failed. */ #define GLOB_ABEND (-2) /* Unignored error. */ diff --git a/ext/GDBM_File/.gitignore b/ext/GDBM_File/.gitignore index 7ba0a5a28994..67de96f981bc 100644 --- a/ext/GDBM_File/.gitignore +++ b/ext/GDBM_File/.gitignore @@ -1 +1,2 @@ const-*.inc +!/Makefile.PL diff --git a/ext/GDBM_File/GDBM_File.pm b/ext/GDBM_File/GDBM_File.pm index b4fc49f42e8a..d837536f804c 100644 --- a/ext/GDBM_File/GDBM_File.pm +++ b/ext/GDBM_File/GDBM_File.pm @@ -6,9 +6,47 @@ GDBM_File - Perl5 access to the gdbm library. =head1 SYNOPSIS - use GDBM_File ; - tie %hash, 'GDBM_File', $filename, &GDBM_WRCREAT, 0640; + use GDBM_File; + [$db =] tie %hash, 'GDBM_File', $filename, &GDBM_WRCREAT, 0640; # Use the %hash array. + + $e = $db->errno; + $e = $db->syserrno; + $str = $db->strerror; + $bool = $db->needs_recovery; + + $db->clear_error; + + $db->reorganize; + $db->sync; + + $n = $db->count; + + $n = $db->flags; + + $str = $db->dbname; + + $db->cache_size; + $db->cache_size($newsize); + + $n = $db->block_size; + + $bool = $db->sync_mode; + $db->sync_mode($bool); + + $bool = $db->centfree; + $db->centfree($bool); + + $bool = $db->coalesce; + $db->coalesce($bool); + + $bool = $db->mmap; + + $size = $db->mmapsize; + $db->mmapsize($newsize); + + $db->recover(%args); + untie %hash ; =head1 DESCRIPTION @@ -24,6 +62,250 @@ Unlike Perl's built-in hashes, it is not safe to C the current item from a GDBM_File tied hash while iterating over it with C. This is a limitation of the gdbm library. +=head1 STATIC METHODS + +=head2 GDBM_version + + $str = GDBM_File->GDBM_version; + @ar = GDBM_File->GDBM_version; + +Returns the version number of the underlying B library. In scalar +context, returns the library version formatted as string: + + MINOR.MAJOR[.PATCH][ (GUESS)] + +where I, I, and I are version numbers, and I is +a guess level (see below). + +In list context, returns a list: + + ( MINOR, MAJOR, PATCH [, GUESS] ) + +The I component is present only if B version is 1.8.3 or +earlier. This is because earlier releases of B did not include +information about their version and the B module has to implement +certain guesswork in order to determine it. I is a textual description +in string context, and a positive number indicating how rough the guess is +in list context. Possible values are: + +=over 4 + +=item 1 - exact guess + +The major and minor version numbers are guaranteed to be correct. The actual +patchlevel is most probably guessed right, but can be 1-2 less than indicated. + +=item 2 - approximate + +The major and minor number are guaranteed to be correct. The patchlevel is +set to the upper bound. + +=item 3 - rough guess + +The version is guaranteed to be not newer than B.I>. + +=back + +=head1 METHODS + +=head2 close + + $db->close; + +Closes the database. You are not advised to use this method directly. Please, +use B instead. + +=head2 errno + + $db->errno + +Returns the last error status associated with this database. + +=head2 syserrno + + $db->syserrno + +Returns the last system error status (C C variable), associated with +this database, + +=head2 strerror + + $db->strerror + +Returns textual description of the last error that occurred in this database. + +=head2 clear_error + + $db->clear_error + +Clear error status. + +=head2 needs_recovery + + $db->needs_recovery + +Returns true if the database needs recovery. + +=head2 reorganize + + $db->reorganize; + +Reorganizes the database. + +=head2 sync + + $db->sync; + +Synchronizes recent changes to the database with its disk copy. + +=head2 count + + $n = $db->count; + +Returns number of keys in the database. + +=head2 flags + + $db->flags; + +Returns flags passed as 4th argument to B. + +=head2 dbname + + $db->dbname; + +Returns the database name (i.e. 3rd argument to B. + +=head2 cache_size + + $db->cache_size; + $db->cache_size($newsize); + +Returns the size of the internal B cache for that database. + +Called with argument, sets the size to I<$newsize>. + +=head2 block_size + + $db->block_size; + +Returns the block size of the database. + +=head2 sync_mode + + $db->sync_mode; + $db->sync_mode($bool); + +Returns the status of the automatic synchronization mode. Called with argument, +enables or disables the sync mode, depending on whether $bool is B or +B. + +When synchronization mode is on (B), any changes to the database are +immediately written to the disk. This ensures database consistency in case +of any unforeseen errors (e.g. power failures), at the expense of considerable +slowdown of operation. + +Synchronization mode is off by default. + +=head2 centfree + + $db->centfree; + $db->centfree($bool); + +Returns status of the central free block pool (B<0> - disabled, +B<1> - enabled). + +With argument, changes its status. + +By default, central free block pool is disabled. + +=head2 coalesce + + $db->coalesce; + $db->coalesce($bool); + +=head2 mmap + + $db->mmap; + +Returns true if memory mapping is enabled. + +This method will B if the B library is complied without +memory mapping support. + +=head2 mmapsize + + $db->mmapsize; + $db->mmapsize($newsize); + +If memory mapping is enabled, returns the size of memory mapping. With +argument, sets the size to B<$newsize>. + +This method will B if the B library is complied without +memory mapping support. + +=head2 recover + + $db->recover(%args); + +Recovers data from a failed database. B<%args> is optional and can contain +following keys: + +=over 4 + +=item err => sub { ... } + +Reference to code for detailed error reporting. Upon encountering an error, +B will call this sub with a single argument - a description of the +error. + +=item backup => \$str + +Creates a backup copy of the database before recovery and returns its +filename in B<$str>. + +=item max_failed_keys => $n + +Maximum allowed number of failed keys. If the actual number becomes equal +to I<$n>, B aborts and returns error. + +=item max_failed_buckets => $n + +Maximum allowed number of failed buckets. If the actual number becomes equal +to I<$n>, B aborts and returns error. + +=item max_failures => $n + +Maximum allowed number of failures during recovery. + +=item stat => \%hash + +Return recovery statistics in I<%hash>. Upon return, the following keys will +be present: + +=over 8 + +=item recovered_keys + +Number of successfully recovered keys. + +=item recovered_buckets + +Number of successfully recovered buckets. + +=item failed_keys + +Number of keys that failed to be retrieved. + +=item failed_buckets + +Number of buckets that failed to be retrieved. + +=back + +=back + + =head1 AVAILABILITY gdbm is available from any GNU archive. The master site is @@ -43,15 +325,11 @@ can be safely used with C. A maliciously crafted file might cause perl to crash or even expose a security vulnerability. -=head1 BUGS - -The available functions and the gdbm/perl interface need to be documented. - -The GDBM error number and error message interface needs to be added. - =head1 SEE ALSO -L, L, L. +L, L, L, +L, +L. =cut @@ -67,25 +345,25 @@ require Exporter; require XSLoader; @ISA = qw(Tie::Hash Exporter); @EXPORT = qw( - GDBM_CACHESIZE - GDBM_CENTFREE - GDBM_COALESCEBLKS - GDBM_FAST - GDBM_FASTMODE - GDBM_INSERT - GDBM_NEWDB - GDBM_NOLOCK - GDBM_OPENMASK - GDBM_READER - GDBM_REPLACE - GDBM_SYNC - GDBM_SYNCMODE - GDBM_WRCREAT - GDBM_WRITER + GDBM_CACHESIZE + GDBM_CENTFREE + GDBM_COALESCEBLKS + GDBM_FAST + GDBM_FASTMODE + GDBM_INSERT + GDBM_NEWDB + GDBM_NOLOCK + GDBM_OPENMASK + GDBM_READER + GDBM_REPLACE + GDBM_SYNC + GDBM_SYNCMODE + GDBM_WRCREAT + GDBM_WRITER ); # This module isn't dual life, so no need for dev version numbers. -$VERSION = '1.18'; +$VERSION = '1.19'; XSLoader::load(); diff --git a/ext/GDBM_File/GDBM_File.xs b/ext/GDBM_File/GDBM_File.xs index 7f910491166f..cd0bb6f26ffa 100644 --- a/ext/GDBM_File/GDBM_File.xs +++ b/ext/GDBM_File/GDBM_File.xs @@ -23,23 +23,106 @@ typedef datum datum_key ; typedef datum datum_value ; typedef datum datum_key_copy; -#if defined(GDBM_VERSION_MAJOR) && defined(GDBM_VERSION_MINOR) \ - && GDBM_VERSION_MAJOR > 1 || \ - (GDBM_VERSION_MAJOR == 1 && GDBM_VERSION_MINOR >= 9) -typedef void (*FATALFUNC)(const char *); +/* Indexes for gdbm_flags aliases */ +enum { + opt_flags = 0, + opt_cache_size, + opt_sync_mode, + opt_centfree, + opt_coalesce, + opt_dbname, + opt_block_size, + opt_mmap, + opt_mmapsize +}; + +/* Names of gdbm_flags aliases, for error reporting. + Indexed by opt_ constants above. +*/ +char const *opt_names[] = { + "GDBM_File::flags", + "GDBM_File::cache_size", + "GDBM_File::sync_mode", + "GDBM_File::centfree", + "GDBM_File::coalesce", + "GDBM_File::dbname", + "GDBM_File::block_size", + "GDBM_File::mmap", + "GDBM_File::mmapsize" +}; + +#ifdef GDBM_VERSION_MAJOR +# define GDBM_VERSION_GUESS 0 #else -typedef void (*FATALFUNC)(); +/* Try educated guess + * The value of GDBM_VERSION_GUESS indicates how rough the guess is: + * 1 - Precise; based on the CVS logs and existing archives + * 2 - Moderate. The major and minor number are correct. The patchlevel + * is set to the upper bound. + * 3 - Rough; The version is guaranteed to be not newer than major.minor. + */ +# if defined(GDBM_SYNCMODE) +/* CHANGES from 1.7.3 to 1.8 + * 1. Added GDBM_CENTFREE functionality and option. + */ +# define GDBM_VERSION_MAJOR 1 +# define GDBM_VERSION_MINOR 8 +# define GDBM_VERSION_PATCH 3 +# define GDBM_VERSION_GUESS 1 +# elif defined(GDBM_FASTMODE) +/* CHANGES from 1.7.2 to 1.7.3 + * 1. Fixed a couple of last minute problems. (Namely, no autoconf.h in + * version.c, and no GDBM_FASTMODE in gdbm.h!) + */ +# define GDBM_VERSION_MAJOR 1 +# define GDBM_VERSION_MINOR 7 +# define GDBM_VERSION_PATCH 3 +# define GDBM_VERSION_GUESS 1 +# elif defined(GDBM_FAST) +/* From CVS logs: + * Mon May 17 12:32:02 1993 Phil Nelson (phil at cs.wwu.edu) + * + * * gdbm.proto: Added GDBM_FAST to the read_write flags. + */ +# define GDBM_VERSION_MAJOR 1 +# define GDBM_VERSION_MINOR 7 +# define GDBM_VERSION_PATCH 2 +# define GDBM_VERSION_GUESS 2 +# else +# define GDBM_VERSION_MAJOR 1 +# define GDBM_VERSION_MINOR 6 +# define GDBM_VERSION_GUESS 3 +# endif #endif -#ifndef GDBM_FAST -static int -not_here(char *s) -{ - croak("GDBM_File::%s not implemented on this architecture", s); - return -1; +#ifndef GDBM_VERSION_PATCH +# define GDBM_VERSION_PATCH 0 +#endif + +/* The use of fatal_func argument to gdbm_open is deprecated since 1.13 */ +#if GDBM_VERSION_MAJOR == 1 && GDBM_VERSION_MINOR >= 13 +# define FATALFUNC NULL +#elif GDBM_VERSION_MAJOR == 1 && GDBM_VERSION_MINOR >= 9 +# define FATALFUNC croak_string +# define NEED_FATALFUNC 1 +#else +# define FATALFUNC (void (*)()) croak_string +# define NEED_FATALFUNC 1 +#endif + +#ifdef NEED_FATALFUNC +static void +croak_string(const char *message) { + Perl_croak_nocontext("%s", message); } #endif +#define not_here(s) (croak("GDBM_File::%s not implemented", #s),-1) + +#if ! (GDBM_VERSION_MAJOR == 1 && GDBM_VERSION_MINOR >= 11) +typedef unsigned gdbm_count_t; +#endif + /* GDBM allocates the datum with system malloc() and expects the user * to free() it. So we either have to free() it immediately, or have * perl free() it when it deallocates the SV, depending on whether @@ -62,17 +145,113 @@ output_datum(pTHX_ SV *arg, char *str, int size) #define gdbm_setopt(db,optflag,optval,optlen) not_here("gdbm_setopt") #endif +#ifndef GDBM_ITEM_NOT_FOUND +# define GDBM_ITEM_NOT_FOUND GDBM_NO_ERROR +#endif + +/* Prior to 1.13, gdbm_fetch family functions set gdbm_errno to GDBM_NO_ERROR + if the requested key did not exist */ +#define ITEM_NOT_FOUND() \ + (gdbm_errno == GDBM_ITEM_NOT_FOUND || gdbm_errno == GDBM_NO_ERROR) + +#define CHECKDB(db) do { \ + if (!db->dbp) { \ + croak("database was closed"); \ + } \ + } while (0) + static void -croak_string(const char *message) { - Perl_croak_nocontext("%s", message); +dbcroak(GDBM_File db, char const *func) +{ +#if GDBM_VERSION_MAJOR == 1 && GDBM_VERSION_MINOR >= 13 + croak("%s: %s", func, gdbm_db_strerror(db->dbp)); +#else + (void)db; + croak("%s: %s", func, gdbm_strerror(gdbm_errno)); +#endif } +#if GDBM_VERSION_MAJOR == 1 && (GDBM_VERSION_MINOR > 16 || GDBM_VERSION_PATCH >= 90) +# define gdbm_close(db) gdbm_close(db->dbp) +#else +# define gdbm_close(db) (gdbm_close(db->dbp),0) +#endif +static int +gdbm_file_close(GDBM_File db) +{ + int rc = 0; + if (db->dbp) { + rc = gdbm_close(db); + db->dbp = NULL; + } + return rc; +} + +#if GDBM_VERSION_MAJOR == 1 && GDBM_VERSION_MINOR >= 13 +/* Error-reporting wrapper for gdbm_recover */ +static void +rcvr_errfun(void *cv, char const *fmt, ...) +{ + dTHX; + dSP; + va_list ap; + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + va_start(ap, fmt); + XPUSHs(sv_2mortal(vnewSVpvf(fmt, &ap))); + va_end(ap); + PUTBACK; + + call_sv((SV*)cv, G_DISCARD); + + FREETMPS; + LEAVE; +} +#endif + #include "const-c.inc" MODULE = GDBM_File PACKAGE = GDBM_File PREFIX = gdbm_ INCLUDE: const-xs.inc +void +gdbm_GDBM_version(package) + PPCODE: + I32 gimme = GIMME_V; + if (gimme == G_VOID) { + /* nothing */; + } else if (gimme == G_SCALAR) { + static char const *guess[] = { + "", + " (exact guess)", + " (approximate)", + " (rough guess)" + }; + if (GDBM_VERSION_PATCH > 0) { + XPUSHs(sv_2mortal(newSVpvf("%d.%d.%d%s", + GDBM_VERSION_MAJOR, + GDBM_VERSION_MINOR, + GDBM_VERSION_PATCH, + guess[GDBM_VERSION_GUESS]))); + } else { + XPUSHs(sv_2mortal(newSVpvf("%d.%d%s", + GDBM_VERSION_MAJOR, + GDBM_VERSION_MINOR, + guess[GDBM_VERSION_GUESS]))); + } + } else { + XPUSHs(sv_2mortal(newSVuv(GDBM_VERSION_MAJOR))); + XPUSHs(sv_2mortal(newSVuv(GDBM_VERSION_MINOR))); + XPUSHs(sv_2mortal(newSVuv(GDBM_VERSION_PATCH))); + if (GDBM_VERSION_GUESS > 0) { + XPUSHs(sv_2mortal(newSVuv(GDBM_VERSION_GUESS))); + } + } + GDBM_File gdbm_TIEHASH(dbtype, name, read_write, mode) char * dbtype @@ -82,7 +261,7 @@ gdbm_TIEHASH(dbtype, name, read_write, mode) PREINIT: GDBM_FILE dbp; CODE: - dbp = gdbm_open(name, 0, read_write, mode, (FATALFUNC)croak_string); + dbp = gdbm_open(name, 0, read_write, mode, FATALFUNC); if (!dbp && gdbm_errno == GDBM_BLOCK_SIZE_ERROR) { /* * By specifying a block size of 0 above, we asked gdbm to @@ -93,8 +272,7 @@ gdbm_TIEHASH(dbtype, name, read_write, mode) * defaulting to fail. In that case, force an acceptable * block size. */ - dbp = gdbm_open(name, 4096, read_write, mode, - (FATALFUNC)croak_string); + dbp = gdbm_open(name, 4096, read_write, mode, FATALFUNC); } if (dbp) { RETVAL = (GDBM_File)safecalloc(1, sizeof(GDBM_File_type)); @@ -105,31 +283,46 @@ gdbm_TIEHASH(dbtype, name, read_write, mode) OUTPUT: RETVAL - -#define gdbm_close(db) gdbm_close(db->dbp) -void -gdbm_close(db) - GDBM_File db - CLEANUP: - void gdbm_DESTROY(db) GDBM_File db PREINIT: int i = store_value; - CODE: - gdbm_close(db); + CODE: + if (gdbm_file_close(db)) { + croak("gdbm_close: %s; %s", gdbm_strerror(gdbm_errno), + strerror(errno)); + } do { if (db->filter[i]) SvREFCNT_dec(db->filter[i]); } while (i-- > 0); safefree(db); +void +gdbm_UNTIE(db, count) + GDBM_File db + unsigned count + CODE: + if (count == 0) { + if (gdbm_file_close(db)) + croak("gdbm_close: %s; %s", + gdbm_strerror(gdbm_errno), + strerror(errno)); + } + + #define gdbm_FETCH(db,key) gdbm_fetch(db->dbp,key) datum_value gdbm_FETCH(db, key) GDBM_File db datum_key_copy key + INIT: + CHECKDB(db); + CLEANUP: + if (RETVAL.dptr == NULL && !ITEM_NOT_FOUND()) { + dbcroak(db, "gdbm_fetch"); + } #define gdbm_STORE(db,key,value,flags) gdbm_store(db->dbp,key,value,flags) int @@ -138,12 +331,11 @@ gdbm_STORE(db, key, value, flags = GDBM_REPLACE) datum_key key datum_value value int flags + INIT: + CHECKDB(db); CLEANUP: if (RETVAL) { - if (RETVAL < 0 && errno == EPERM) - croak("No write permission to gdbm file"); - croak("gdbm store returned %d, errno %d, key \"%.*s\"", - RETVAL,errno,key.dsize,key.dptr); + dbcroak(db, "gdbm_store"); } #define gdbm_DELETE(db,key) gdbm_delete(db->dbp,key) @@ -151,35 +343,468 @@ int gdbm_DELETE(db, key) GDBM_File db datum_key key + INIT: + CHECKDB(db); + CLEANUP: + if (RETVAL && !ITEM_NOT_FOUND()) { + dbcroak(db, "gdbm_delete"); + } #define gdbm_FIRSTKEY(db) gdbm_firstkey(db->dbp) datum_key gdbm_FIRSTKEY(db) GDBM_File db + INIT: + CHECKDB(db); + CLEANUP: + if (RETVAL.dptr == NULL && !ITEM_NOT_FOUND()) { + dbcroak(db, "gdbm_firstkey"); + } #define gdbm_NEXTKEY(db,key) gdbm_nextkey(db->dbp,key) datum_key gdbm_NEXTKEY(db, key) GDBM_File db datum_key key + INIT: + CHECKDB(db); + CLEANUP: + if (RETVAL.dptr == NULL && !ITEM_NOT_FOUND()) { + dbcroak(db, "gdbm_nextkey"); + } + +#define gdbm_EXISTS(db,key) gdbm_exists(db->dbp,key) +int +gdbm_EXISTS(db, key) + GDBM_File db + datum_key key + INIT: + CHECKDB(db); +## + +int +gdbm_close(db) + GDBM_File db + INIT: + CHECKDB(db); + CODE: + RETVAL = gdbm_file_close(db); + OUTPUT: + RETVAL + +int +gdbm_errno(db) + GDBM_File db + INIT: + CHECKDB(db); + CODE: +#if GDBM_VERSION_MAJOR == 1 && GDBM_VERSION_MINOR >= 13 + RETVAL = gdbm_last_errno(db->dbp); +#else + RETVAL = gdbm_errno; +#endif + OUTPUT: + RETVAL + +int +gdbm_syserrno(db) + GDBM_File db + INIT: + CHECKDB(db); + CODE: +#if GDBM_VERSION_MAJOR == 1 && GDBM_VERSION_MINOR >= 13 + { + int ec = gdbm_last_errno(db->dbp); + if (gdbm_check_syserr(ec)) { + RETVAL = gdbm_last_syserr(db->dbp); + } else { + RETVAL = 0; + } + } +#else + not_here("syserrno"); +#endif + OUTPUT: + RETVAL + +SV * +gdbm_strerror(db) + GDBM_File db + PREINIT: + char const *errstr; + INIT: + CHECKDB(db); + CODE: +#if GDBM_VERSION_MAJOR == 1 && GDBM_VERSION_MINOR >= 13 + errstr = gdbm_db_strerror(db->dbp); +#else + errstr = gdbm_strerror(gdbm_errno); +#endif + RETVAL = newSVpv(errstr, 0); + OUTPUT: + RETVAL + +#if GDBM_VERSION_MAJOR == 1 && GDBM_VERSION_MINOR >= 13 +# define gdbm_clear_error(db) gdbm_clear_error(db->dbp) +#else +# define gdbm_clear_error(db) (gdbm_errno = 0) +#endif +void +gdbm_clear_error(db) + GDBM_File db + INIT: + CHECKDB(db); + +#if GDBM_VERSION_MAJOR == 1 && GDBM_VERSION_MINOR >= 13 +# define gdbm_needs_recovery(db) gdbm_needs_recovery(db->dbp) +#else +# define gdbm_needs_recovery(db) not_here("gdbm_needs_recovery") +#endif +int +gdbm_needs_recovery(db) + GDBM_File db + INIT: + CHECKDB(db); + #define gdbm_reorganize(db) gdbm_reorganize(db->dbp) int gdbm_reorganize(db) GDBM_File db + INIT: + CHECKDB(db); + +# Arguments: +# err => sub { ... } +# max_failed_keys => $n +# max_failed_buckets => $n +# max_failures => $n +# backup => \$str +# stat => \%hash + +#if GDBM_VERSION_MAJOR == 1 && GDBM_VERSION_MINOR >= 13 -#define gdbm_sync(db) gdbm_sync(db->dbp) void -gdbm_sync(db) +gdbm_recover(db, ...) GDBM_File db + PREINIT: + int flags = GDBM_RCVR_FORCE; + SV *backup_ref = &PL_sv_undef; + SV *stat_ref = &PL_sv_undef; + gdbm_recovery rcvr; + INIT: + CHECKDB(db); + CODE: + if (items > 1) { + int i; + if ((items % 2) == 0) { + croak("bad number of arguments"); + } + for (i = 1; i < items; i += 2) { + char *kw; + SV *sv = ST(i); + SV *val = ST(i+1); -#define gdbm_EXISTS(db,key) gdbm_exists(db->dbp,key) + if (!SvPOK(sv)) + croak("bad arguments near #%d", i); + kw = SvPV_nolen(sv); + if (strcmp(kw, "err") == 0) { + if (SvROK(val) && SvTYPE(SvRV(val)) == SVt_PVCV) { + rcvr.data = SvRV(val); + } else { + croak("%s must be a code ref", kw); + } + rcvr.errfun = rcvr_errfun; + flags |= GDBM_RCVR_ERRFUN; + } else if (strcmp(kw, "max_failed_keys") == 0) { + if (SvIOK(val)) { + rcvr.max_failed_keys = SvUV(val); + } else { + croak("max_failed_keys must be numeric"); + } + flags |= GDBM_RCVR_MAX_FAILED_KEYS; + } else if (strcmp(kw, "max_failed_buckets") == 0) { + if (SvIOK(val)) { + rcvr.max_failed_buckets = SvUV(val); + } else { + croak("max_failed_buckets must be numeric"); + } + flags |= GDBM_RCVR_MAX_FAILED_BUCKETS; + } else if (strcmp(kw, "max_failures") == 0) { + if (SvIOK(val)) { + rcvr.max_failures = SvUV(val); + } else { + croak("max_failures must be numeric"); + } + flags |= GDBM_RCVR_MAX_FAILURES; + } else if (strcmp(kw, "backup") == 0) { + if (SvROK(val) && SvTYPE(SvRV(val)) < SVt_PVAV) { + backup_ref = val; + } else { + croak("backup must be a scalar reference"); + } + flags |= GDBM_RCVR_BACKUP; + } else if (strcmp(kw, "stat") == 0) { + if (SvROK(val) && SvTYPE(SvRV(val)) == SVt_PVHV) { + stat_ref = val; + } else { + croak("backup must be a scalar reference"); + } + } else { + croak("%s: unrecognized argument", kw); + } + } + } + if (gdbm_recover(db->dbp, &rcvr, flags)) { + dbcroak(db, "gdbm_recover"); + } + if (stat_ref != &PL_sv_undef) { + HV *hv = (HV*)SvRV(stat_ref); +#define STAT_RECOVERED_KEYS_STR "recovered_keys" +#define STAT_RECOVERED_KEYS_LEN (sizeof(STAT_RECOVERED_KEYS_STR)-1) +#define STAT_RECOVERED_BUCKETS_STR "recovered_buckets" +#define STAT_RECOVERED_BUCKETS_LEN (sizeof(STAT_RECOVERED_BUCKETS_STR)-1) +#define STAT_FAILED_KEYS_STR "failed_keys" +#define STAT_FAILED_KEYS_LEN (sizeof(STAT_FAILED_KEYS_STR)-1) +#define STAT_FAILED_BUCKETS_STR "failed_buckets" +#define STAT_FAILED_BUCKETS_LEN (sizeof(STAT_FAILED_BUCKETS_STR)-1) + hv_store(hv, STAT_RECOVERED_KEYS_STR, STAT_RECOVERED_KEYS_LEN, + newSVuv(rcvr.recovered_keys), 0); + hv_store(hv, + STAT_RECOVERED_BUCKETS_STR, + STAT_RECOVERED_BUCKETS_LEN, + newSVuv(rcvr.recovered_buckets), 0); + hv_store(hv, + STAT_FAILED_KEYS_STR, + STAT_FAILED_KEYS_LEN, + newSVuv(rcvr.failed_keys), 0); + hv_store(hv, + STAT_FAILED_BUCKETS_STR, + STAT_FAILED_BUCKETS_LEN, + newSVuv(rcvr.failed_buckets), 0); + } + if (backup_ref != &PL_sv_undef) { + SV *sv = SvRV(backup_ref); + sv_setpv(sv, rcvr.backup_name); + free(rcvr.backup_name); + } + +#endif + +#if GDBM_VERSION_MAJOR == 1 && (GDBM_VERSION_MINOR > 16 || GDBM_VERSION_PATCH >= 90) +# define gdbm_sync(db) gdbm_sync(db->dbp) +#else +# define gdbm_sync(db) (gdbm_sync(db->dbp),0) +#endif int -gdbm_EXISTS(db, key) +gdbm_sync(db) GDBM_File db - datum_key key + INIT: + CHECKDB(db); + CLEANUP: + if (RETVAL) { + dbcroak(db, "gdbm_sync"); + } + +#if GDBM_VERSION_MAJOR == 1 && GDBM_VERSION_MINOR >= 11 + +gdbm_count_t +gdbm_count(db) + GDBM_File db + PREINIT: + gdbm_count_t c; + INIT: + CHECKDB(db); + CODE: + if (gdbm_count(db->dbp, &c)) { + dbcroak(db, "gdbm_count"); + } + RETVAL = c; + OUTPUT: + RETVAL + +#endif + +#define OPTNAME(a,b) a ## b +#define INTOPTSETUP(opt) \ + do { \ + if (items == 1) { \ + opcode = OPTNAME(GDBM_GET, opt); \ + } else { \ + opcode = OPTNAME(GDBM_SET, opt); \ + sv = ST(1); \ + if (!SvIOK(sv)) { \ + croak("%s: bad argument type", opt_names[ix]); \ + } \ + c_iv = SvIV(sv); \ + } \ + } while (0) +#if GDBM_VERSION_MAJOR == 1 && GDBM_VERSION_MINOR >= 9 +# define OPTVALPTR void * +#else +# define OPTVALPTR int * +#endif + +# GDBM_GET defines appeared in version 1.9 (2011-08-12). +# +# Provide definitions for earlier versions. These will cause gdbm_setopt +# to fail with GDBM_OPT_ILLEGAL + +#ifndef GDBM_GETFLAGS +# define GDBM_GETFLAGS -1 +#endif +#ifndef GDBM_GETMMAP +# define GDBM_GETMMAP -1 +#endif +#ifndef GDBM_GETCACHESIZE +# define GDBM_GETCACHESIZE -1 +#endif +#ifndef GDBM_GETSYNCMODE +# define GDBM_GETSYNCMODE -1 +#endif +#ifndef GDBM_GETCENTFREE +# define GDBM_GETCENTFREE -1 +#endif +#ifndef GDBM_GETCOALESCEBLKS +# define GDBM_GETCOALESCEBLKS -1 +#endif +#ifndef GDBM_GETMAXMAPSIZE +# define GDBM_GETMAXMAPSIZE -1 +#endif +#ifndef GDBM_GETDBNAME +# define GDBM_GETDBNAME -1 +#endif +#ifndef GDBM_GETBLOCKSIZE +# define GDBM_GETBLOCKSIZE -1 +#endif + +# These two appeared in version 1.10: + +#ifndef GDBM_SETMAXMAPSIZE +# define GDBM_SETMAXMAPSIZE -1 +#endif +#ifndef GDBM_SETMMAP +# define GDBM_SETMMAP -1 +#endif + +# These GDBM_SET defines appeared in 1.10, replacing obsolete opcodes. +# Provide definitions for older versions + +#ifndef GDBM_SETCACHESIZE +# define GDBM_SETCACHESIZE GDBM_CACHESIZE +#endif +#ifndef GDBM_SETSYNCMODE +# define GDBM_SETSYNCMODE GDBM_SYNCMODE +#endif +#ifndef GDBM_SETCENTFREE +# define GDBM_SETCENTFREE GDBM_CENTFREE +#endif +#ifndef GDBM_SETCOALESCEBLKS +# define GDBM_SETCOALESCEBLKS GDBM_COALESCEBLKS +#endif + +SV * +gdbm_flags(db, ...) + GDBM_File db + SV * RETVAL = &PL_sv_undef; + ALIAS: + GDBM_File::cache_size = opt_cache_size + GDBM_File::sync_mode = opt_sync_mode + GDBM_File::centfree = opt_centfree + GDBM_File::coalesce = opt_coalesce + GDBM_File::dbname = opt_dbname + GDBM_File::block_size = opt_block_size + GDBM_File::mmap = opt_mmap + GDBM_File::mmapsize = opt_mmapsize + PREINIT: + int opcode = -1; + int c_iv; + unsigned c_uv; + char *c_cv; + OPTVALPTR vptr = (OPTVALPTR) &c_iv; + size_t vsiz = sizeof(c_iv); + SV *sv; + INIT: + CHECKDB(db); + CODE: + if (items > 2) { + croak("%s: too many arguments", opt_names[ix]); + } + + switch (ix) { + case opt_flags: + if (items > 1) { + croak("%s: too many arguments", opt_names[ix]); + } + opcode = GDBM_GETFLAGS; + break; + case opt_cache_size: + INTOPTSETUP(CACHESIZE); + break; + case opt_sync_mode: + INTOPTSETUP(SYNCMODE); + break; + case opt_centfree: + INTOPTSETUP(CENTFREE); + break; + case opt_coalesce: + INTOPTSETUP(COALESCEBLKS); + break; + case opt_dbname: + if (items > 1) { + croak("%s: too many arguments", opt_names[ix]); + } + opcode = GDBM_GETDBNAME; + vptr = (OPTVALPTR) &c_cv; + vsiz = sizeof(c_cv); + break; + case opt_block_size: + if (items > 1) { + croak("%s: too many arguments", opt_names[ix]); + } + opcode = GDBM_GETBLOCKSIZE; + break; + case opt_mmap: + if (items > 1) { + croak("%s: too many arguments", opt_names[ix]); + } + opcode = GDBM_GETMMAP; + break; + case opt_mmapsize: + vptr = (OPTVALPTR) &c_uv; + vsiz = sizeof(c_uv); + if (items == 1) { + opcode = GDBM_GETMAXMAPSIZE; + } else { + opcode = GDBM_SETMAXMAPSIZE; + sv = ST(1); + if (!SvUOK(sv)) { + croak("%s: bad argument type", opt_names[ix]); + } + c_uv = SvUV(sv); + } + break; + } + + if (gdbm_setopt(db->dbp, opcode, vptr, vsiz)) { + if (gdbm_errno == GDBM_OPT_ILLEGAL) + croak("%s not implemented", opt_names[ix]); + dbcroak(db, "gdbm_setopt"); + } + + if (vptr == (OPTVALPTR) &c_iv) { + RETVAL = newSViv(c_iv); + } else if (vptr == (OPTVALPTR) &c_uv) { + RETVAL = newSVuv(c_uv); + } else { + RETVAL = newSVpv(c_cv, 0); + free(c_cv); + } + OUTPUT: + RETVAL + #define gdbm_setopt(db,optflag, optval, optlen) gdbm_setopt(db->dbp,optflag, optval, optlen) int gdbm_setopt (db, optflag, optval, optlen) @@ -187,17 +812,23 @@ gdbm_setopt (db, optflag, optval, optlen) int optflag int &optval int optlen - + INIT: + CHECKDB(db); + CLEANUP: + if (RETVAL) { + dbcroak(db, "gdbm_setopt"); + } SV * filter_fetch_key(db, code) GDBM_File db SV * code SV * RETVAL = &PL_sv_undef ; - ALIAS: + ALIAS: GDBM_File::filter_fetch_key = fetch_key GDBM_File::filter_store_key = store_key GDBM_File::filter_fetch_value = fetch_value GDBM_File::filter_store_value = store_value - CODE: - DBM_setFilter(db->filter[ix], code); + CODE: + DBM_setFilter(db->filter[ix], code); + diff --git a/ext/GDBM_File/t/count.t b/ext/GDBM_File/t/count.t new file mode 100644 index 000000000000..110624724629 --- /dev/null +++ b/ext/GDBM_File/t/count.t @@ -0,0 +1,37 @@ +#!./perl -w +use strict; + +use Test::More; +use Config; +use File::Temp 'tempdir'; +use File::Spec; + +BEGIN { + plan(skip_all => "GDBM_File was not built") + unless $Config{extensions} =~ /\bGDBM_File\b/; + + # https://rt.perl.org/Public/Bug/Display.html?id=117967 + plan(skip_all => "GDBM_File is flaky in $^O") + if $^O =~ /darwin/; + + plan(tests => 3); + use_ok('GDBM_File'); + } + +my $wd = tempdir(CLEANUP => 1); + +my %h; +my $db = tie(%h, 'GDBM_File', File::Spec->catfile($wd, 'Op_dbmx'), + GDBM_WRCREAT, 0640); + +isa_ok($db, 'GDBM_File'); +SKIP: { + skip 'GDBM_File::count not available', 1 + unless $db->can('count'); + + $h{one} = '1'; + $h{two} = '2'; + $h{three} = '3'; + is($db->count, 3, 'count'); +} + diff --git a/ext/GDBM_File/t/fatal.t b/ext/GDBM_File/t/fatal.t index 1cbfdc60181a..170508232b06 100644 --- a/ext/GDBM_File/t/fatal.t +++ b/ext/GDBM_File/t/fatal.t @@ -11,6 +11,8 @@ use strict; use Test::More; use Config; +use File::Temp 'tempdir'; +use File::Spec; BEGIN { plan(skip_all => "GDBM_File was not built") @@ -24,8 +26,6 @@ BEGIN { use_ok('GDBM_File'); } -unlink ; - open my $fh, '<', $^X or die "Can't open $^X: $!"; my $fileno = fileno $fh; isnt($fileno, undef, "Can find next available file descriptor"); @@ -35,8 +35,10 @@ is((open $fh, "<&=$fileno"), undef, "Check that we cannot open fileno $fileno. \$! is $!"); umask(0); +my $wd = tempdir(CLEANUP => 1); my %h; -isa_ok(tie(%h, 'GDBM_File', 'fatal_dbmx', GDBM_WRCREAT, 0640), 'GDBM_File'); +isa_ok(tie(%h, 'GDBM_File', File::Spec->catfile($wd, 'fatal_dbmx'), + GDBM_WRCREAT, 0640), 'GDBM_File'); isnt((open $fh, "<&=$fileno"), undef, "dup fileno $fileno") or diag("\$! = $!"); @@ -63,4 +65,3 @@ SKIP: { 'expected error message from GDBM_File'); } -unlink ; diff --git a/ext/GDBM_File/t/opt.t b/ext/GDBM_File/t/opt.t new file mode 100644 index 000000000000..72390ac32e88 --- /dev/null +++ b/ext/GDBM_File/t/opt.t @@ -0,0 +1,37 @@ +#!./perl -w +use strict; + +use Test::More; +use Config; +use File::Temp 'tempdir'; +use File::Spec; + +BEGIN { + plan(skip_all => "GDBM_File was not built") + unless $Config{extensions} =~ /\bGDBM_File\b/; + + # https://rt.perl.org/Public/Bug/Display.html?id=117967 + plan(skip_all => "GDBM_File is flaky in $^O") + if $^O =~ /darwin/; + + plan(tests => 8); + use_ok('GDBM_File'); +} + +my $wd = tempdir(CLEANUP => 1); +my $dbname = File::Spec->catfile($wd, 'Op_dbmx'); +my %h; +my $db = tie(%h, 'GDBM_File', $dbname, GDBM_WRCREAT, 0640); +isa_ok($db, 'GDBM_File'); +SKIP: { + my $name = eval { $db->dbname } or do { + skip "gdbm_setopt GET calls not implemented", 6 + if $@ =~ /GDBM_File::dbname not implemented/; + }; + is($db->dbname, $dbname, 'get dbname'); + is(eval { $db->dbname("a"); }, undef, 'dbname - bad usage'); + is($db->flags, GDBM_WRCREAT, 'get flags'); + is($db->sync_mode, 0, 'get sync_mode'); + is($db->sync_mode(1), 1, 'set sync_mode'); + is($db->sync_mode, 1, 'get sync_mode'); +} diff --git a/ext/GDBM_File/typemap b/ext/GDBM_File/typemap index 8d6edeed3552..7bc475daf63b 100644 --- a/ext/GDBM_File/typemap +++ b/ext/GDBM_File/typemap @@ -11,6 +11,7 @@ SDBM_File T_PTROBJ ODBM_File T_PTROBJ DB_File T_PTROBJ DBZ_File T_PTROBJ +gdbm_count_t T_UV INPUT T_DATUM_K diff --git a/ext/Hash-Util/.gitignore b/ext/Hash-Util/.gitignore new file mode 100644 index 000000000000..e54624d60d99 --- /dev/null +++ b/ext/Hash-Util/.gitignore @@ -0,0 +1 @@ +!/Makefile.PL diff --git a/ext/I18N-Langinfo/.gitignore b/ext/I18N-Langinfo/.gitignore index 2a06e93b553d..6531b6b8ed84 100644 --- a/ext/I18N-Langinfo/.gitignore +++ b/ext/I18N-Langinfo/.gitignore @@ -1 +1,2 @@ *.inc +!/Makefile.PL diff --git a/ext/NDBM_File/.gitignore b/ext/NDBM_File/.gitignore new file mode 100644 index 000000000000..e54624d60d99 --- /dev/null +++ b/ext/NDBM_File/.gitignore @@ -0,0 +1 @@ +!/Makefile.PL diff --git a/ext/ODBM_File/.gitignore b/ext/ODBM_File/.gitignore new file mode 100644 index 000000000000..e54624d60d99 --- /dev/null +++ b/ext/ODBM_File/.gitignore @@ -0,0 +1 @@ +!/Makefile.PL diff --git a/ext/ODBM_File/ODBM_File.pm b/ext/ODBM_File/ODBM_File.pm index 7bdbecc73ccd..1b49440f3a0a 100644 --- a/ext/ODBM_File/ODBM_File.pm +++ b/ext/ODBM_File/ODBM_File.pm @@ -7,7 +7,7 @@ require Tie::Hash; require XSLoader; our @ISA = qw(Tie::Hash); -our $VERSION = "1.16"; +our $VERSION = "1.17"; XSLoader::load(); diff --git a/ext/ODBM_File/ODBM_File.xs b/ext/ODBM_File/ODBM_File.xs index 9b708119aeee..38e6dbf446a7 100644 --- a/ext/ODBM_File/ODBM_File.xs +++ b/ext/ODBM_File/ODBM_File.xs @@ -181,6 +181,14 @@ int odbm_DELETE(db, key) ODBM_File db datum_key key + CODE: + /* don't warn about 'delete' being a C++ keyword */ + GCC_DIAG_IGNORE_STMT(-Wc++-compat); + RETVAL = odbm_DELETE(db, key); + GCC_DIAG_RESTORE_STMT; + OUTPUT: + RETVAL + datum_key odbm_FIRSTKEY(db) diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm index 9351c3ba2074..f1b2247b0705 100644 --- a/ext/Opcode/Opcode.pm +++ b/ext/Opcode/Opcode.pm @@ -6,7 +6,7 @@ use strict; our($VERSION, @ISA, @EXPORT_OK); -$VERSION = "1.48"; +$VERSION = "1.50"; use Carp; use Exporter (); @@ -344,7 +344,7 @@ invert_opset function. cond_expr flip flop andassign orassign dorassign and or dor xor - warn die lineseq nextstate scope enter leave + warn die lineseq nextstate scope enter leave catch rv2cv anoncode prototype coreargs avhvswitch anonconst diff --git a/ext/Opcode/Opcode.xs b/ext/Opcode/Opcode.xs index 121b14f8e373..3fb1116f9ce2 100644 --- a/ext/Opcode/Opcode.xs +++ b/ext/Opcode/Opcode.xs @@ -237,7 +237,8 @@ opmask_addlocal(pTHX_ SV *opset, char *op_mask_buf) /* Localise PL_op_mask then * is disallowed by Borland */ if (opcode_debug >= 2) - SAVEDESTRUCTOR((void(*)(void*))Perl_warn,"PL_op_mask restored"); + SAVEDESTRUCTOR((void(*)(void*))Perl_warn_nocontext, + "PL_op_mask restored"); PL_op_mask = &op_mask_buf[0]; if (orig_op_mask) Copy(orig_op_mask, PL_op_mask, PL_maxo, char); diff --git a/ext/POSIX/.gitignore b/ext/POSIX/.gitignore index 2a06e93b553d..6531b6b8ed84 100644 --- a/ext/POSIX/.gitignore +++ b/ext/POSIX/.gitignore @@ -1 +1,2 @@ *.inc +!/Makefile.PL diff --git a/ext/POSIX/Makefile.PL b/ext/POSIX/Makefile.PL index 5d5c009c3c96..a124003f23a2 100644 --- a/ext/POSIX/Makefile.PL +++ b/ext/POSIX/Makefile.PL @@ -116,15 +116,18 @@ push @names, {name=>$_, type=>"NV", not_constant=>1} foreach (qw(DBL_MAX FLT_MAX LDBL_MAX LDBL_MIN LDBL_EPSILON DBL_EPSILON DBL_MIN FLT_EPSILON FLT_MIN)); -push @names, {name=>$_, type=>"NV"} +push @names, {name=>$_, type=>"IV"} foreach (qw(DBL_DIG DBL_MANT_DIG DBL_MAX_10_EXP DBL_MAX_EXP DBL_MIN_10_EXP DBL_MIN_EXP FLT_DIG FLT_MANT_DIG FLT_MAX_10_EXP FLT_MAX_EXP FLT_MIN_10_EXP FLT_MIN_EXP FLT_RADIX LDBL_DIG LDBL_MANT_DIG LDBL_MAX_10_EXP LDBL_MAX_EXP LDBL_MIN_10_EXP LDBL_MIN_EXP)); -push @names, {name=>$_, type=>"NV"} +push @names, {name=>$_, type=>"IV"} foreach (qw(FP_ILOGB0 FP_ILOGBNAN FP_INFINITE FP_NAN FP_NORMAL - FP_SUBNORMAL FP_ZERO M_1_PI M_2_PI M_2_SQRTPI M_E M_LN10 M_LN2 + FP_SUBNORMAL FP_ZERO)); + +push @names, {name=>$_, type=>"NV"} + foreach (qw(M_1_PI M_2_PI M_2_SQRTPI M_E M_LN10 M_LN2 M_LOG10E M_LOG2E M_PI M_PI_2 M_PI_4 M_SQRT1_2 M_SQRT2)); push @names, {name=>$_, type=>"IV"} diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index ad5ca6c26a79..0fab00952593 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -280,7 +280,7 @@ static int not_here(const char *s); # define c99_rint rintq # define c99_round roundq # define c99_scalbn scalbnq -# define c99_signbit signbitq +/* We already define Perl_signbit to signbitq in perl.h. */ # define c99_tgamma tgammaq # define c99_trunc truncq # define bessel_j0 j0q @@ -331,9 +331,7 @@ static int not_here(const char *s); # define c99_rint rintl # define c99_round roundl # define c99_scalbn scalbnl -# ifdef HAS_SIGNBIT /* possibly bad assumption */ -# define c99_signbit signbitl -# endif +/* We already define Perl_signbit in perl.h. */ # define c99_tgamma tgammal # define c99_trunc truncl #else @@ -376,9 +374,6 @@ static int not_here(const char *s); # define c99_round round # define c99_scalbn scalbn /* We already define Perl_signbit in perl.h. */ -# ifdef HAS_SIGNBIT -# define c99_signbit signbit -# endif # define c99_tgamma tgamma # define c99_trunc trunc #endif @@ -578,9 +573,6 @@ static int not_here(const char *s); #ifndef HAS_SCALBN # undef c99_scalbn #endif -#ifndef HAS_SIGNBIT -# undef c99_signbit -#endif #ifndef HAS_TGAMMA # undef c99_tgamma #endif @@ -1333,7 +1325,7 @@ static NV_PAYLOAD_TYPE S_getpayload(NV nv) #ifdef NV_PAYLOAD_DEBUG Perl_warn(aTHX_ "a[%d] = %" UVxf "\n", i, a[i]); #endif - payload *= UV_MAX; + payload *= (NV) UV_MAX; payload += a[i]; } #ifdef NV_PAYLOAD_DEBUG @@ -1424,9 +1416,9 @@ char *tzname[] = { "" , "" }; # define setuid(a) not_here("setuid") # define setgid(a) not_here("setgid") #endif /* NETWARE */ -#ifndef USE_LONG_DOUBLE +#if !defined(USE_LONG_DOUBLE) && !defined(USE_QUADMATH) # define strtold(s1,s2) not_here("strtold") -#endif /* USE_LONG_DOUBLE */ +#endif /* !(USE_LONG_DOUBLE) && !(USE_QUADMATH) */ #else # ifndef HAS_MKFIFO @@ -1559,13 +1551,13 @@ END_EXTERN_C #endif #if ! defined(HAS_MBLEN) && ! defined(HAS_MBRLEN) -#define mblen(a,b) not_here("mblen") +# define mblen(a,b) not_here("mblen") #endif #if ! defined(HAS_MBTOWC) && ! defined(HAS_MBRTOWC) -#define mbtowc(pwc, s, n) not_here("mbtowc") +# define mbtowc(pwc, s, n) not_here("mbtowc") #endif -#ifndef HAS_WCTOMB -#define wctomb(s, wchar) not_here("wctomb") +#if ! defined(HAS_WCTOMB) && ! defined(HAS_WCRTOMB) +# define wctomb(s, wchar) not_here("wctomb") #endif #if !defined(HAS_MBLEN) && !defined(HAS_MBSTOWCS) && !defined(HAS_MBTOWC) && !defined(HAS_WCSTOMBS) && !defined(HAS_WCTOMB) /* If we don't have these functions, then we wouldn't have gotten a typedef @@ -1578,7 +1570,7 @@ END_EXTERN_C #endif #endif -#ifndef HAS_LOCALECONV +#if ! defined(HAS_LOCALECONV) && ! defined(HAS_LOCALECONV_L) # define localeconv() not_here("localeconv") #else struct lconv_offset { @@ -1804,6 +1796,7 @@ fix_win32_tzenv(void) char* newenv; const char* perl_tz_env = win32_getenv("TZ"); const char* crt_tz_env = getenv("TZ"); + if (perl_tz_env == NULL) perl_tz_env = ""; if (crt_tz_env == NULL) @@ -2174,8 +2167,7 @@ localeconv() sv_2mortal((SV*)RETVAL); # if defined(USE_ITHREADS) \ && defined(HAS_POSIX_2008_LOCALE) \ - && defined(HAS_LOCALECONV_L) \ - && defined(HAS_DUPLOCALE) + && defined(HAS_LOCALECONV_L) cur = uselocale((locale_t) 0); if (cur == LC_GLOBAL_LOCALE) { @@ -2185,8 +2177,8 @@ localeconv() lcbuf = localeconv_l(cur); # else - LOCALE_LOCK_V; /* Prevent interference with other threads using - localeconv() */ + LOCALECONV_LOCK; /* Prevent interference with other threads using + localeconv() */ # ifdef TS_W32_BROKEN_LOCALECONV /* This is a workaround for a Windows bug prior to VS 15, in which * localeconv only looks at the global locale. We toggle to the global @@ -2271,7 +2263,7 @@ localeconv() Safefree(save_global); Safefree(save_thread); # endif - LOCALE_UNLOCK_V; + LOCALECONV_UNLOCK; # endif RESTORE_LC_NUMERIC(); #endif /* HAS_LOCALECONV */ @@ -2626,16 +2618,7 @@ fpclassify(x) break; case 8: default: -#ifdef Perl_signbit RETVAL = Perl_signbit(x); -#else - RETVAL = (x < 0); -#ifdef DOUBLE_IS_IEEE_FORMAT - if (x == -0.0) { - RETVAL = TRUE; - } -#endif -#endif break; } OUTPUT: @@ -3376,9 +3359,9 @@ mblen(s, n = ~0) memzero(&PL_mbrlen_ps, sizeof(PL_mbrlen_ps)); RETVAL = 0; #else - LOCALE_LOCK; + MBLEN_LOCK; RETVAL = mblen(NULL, 0); - LOCALE_UNLOCK; + MBLEN_UNLOCK; #endif } else { /* Not resetting state */ @@ -3398,9 +3381,9 @@ mblen(s, n = ~0) #else /* Locking prevents races, but locales can be switched out * without locking, so this isn't a cure all */ - LOCALE_LOCK; + MBLEN_LOCK; RETVAL = mblen(string, len); - LOCALE_UNLOCK; + MBLEN_UNLOCK; #endif } } @@ -3427,9 +3410,9 @@ mbtowc(pwc, s, n = ~0) memzero(&PL_mbrtowc_ps, sizeof(PL_mbrtowc_ps)); RETVAL = 0; #else - LOCALE_LOCK; + MBTOWC_LOCK; RETVAL = mbtowc(NULL, NULL, 0); - LOCALE_UNLOCK; + MBTOWC_UNLOCK; #endif } else { /* Not resetting state */ @@ -3448,9 +3431,9 @@ mbtowc(pwc, s, n = ~0) #else /* Locking prevents races, but locales can be switched out * without locking, so this isn't a cure all */ - LOCALE_LOCK; + MBTOWC_LOCK; RETVAL = mbtowc(&wc, string, len); - LOCALE_UNLOCK; + MBTOWC_UNLOCK; #endif if (RETVAL >= 0) { sv_setiv_mg(pwc, wc); @@ -3482,9 +3465,9 @@ wctomb(s, wchar) * But probably memzero would too */ RETVAL = wcrtomb(NULL, L'\0', &PL_wcrtomb_ps); #else - LOCALE_LOCK; + WCTOMB_LOCK; RETVAL = wctomb(NULL, L'\0'); - LOCALE_UNLOCK; + WCTOMB_UNLOCK; #endif } else { /* Not resetting state */ @@ -3494,9 +3477,9 @@ wctomb(s, wchar) #else /* Locking prevents races, but locales can be switched out without * locking, so this isn't a cure all */ - LOCALE_LOCK; + WCTOMB_LOCK; RETVAL = wctomb(buffer, wchar); - LOCALE_UNLOCK; + WCTOMB_UNLOCK; #endif if (RETVAL >= 0) { sv_setpvn_mg(s, buffer, RETVAL); diff --git a/ext/POSIX/lib/POSIX.pm b/ext/POSIX/lib/POSIX.pm index 51a51a213e60..08986d26577d 100644 --- a/ext/POSIX/lib/POSIX.pm +++ b/ext/POSIX/lib/POSIX.pm @@ -4,7 +4,7 @@ use warnings; our ($AUTOLOAD, %SIGRT); -our $VERSION = '1.95'; +our $VERSION = '1.97'; require XSLoader; diff --git a/ext/POSIX/lib/POSIX.pod b/ext/POSIX/lib/POSIX.pod index e756a51963f7..6265a4505056 100644 --- a/ext/POSIX/lib/POSIX.pod +++ b/ext/POSIX/lib/POSIX.pod @@ -32,6 +32,11 @@ and other miscellaneous objects. The remaining sections list various constants and macros in an organization which roughly follows IEEE Std 1003.1b-1993. +The notation C<[C99]> indicates functions that were added in the ISO/IEC +9899:1999 version of the C language standard. Some may not be available +on your system if it adheres to an earlier standard. Attempts to use +any missing one will result in a fatal runtime error message. + =head1 CAVEATS I (with a handful of exceptions). @@ -139,6 +144,10 @@ The C<$mon> is zero-based: January equals C<0>. The C<$year> is 1900-based: 2001 equals C<101>. C<$wday> and C<$yday> default to zero (and are usually ignored anyway), and C<$isdst> defaults to -1. +Note the result is always in English. Use C> instead to +get a result suitable for the current locale. That function's C<%c> +format yields the locale's preferred representation. + =item C This is identical to the C function C, returning diff --git a/ext/POSIX/t/iv_const.t b/ext/POSIX/t/iv_const.t new file mode 100644 index 000000000000..38d1b366fb22 --- /dev/null +++ b/ext/POSIX/t/iv_const.t @@ -0,0 +1,69 @@ +#! perl -w + +# Test integer constants (DBL_DIG, DBL_MAX_EXP, FP_*, ...) are IV, not NV. + +use strict; +use Test::More; +use Devel::Peek; +use POSIX; +use Config; + +# Capture output from Devel::Peek::Dump() into Perl string +sub capture_dump +{ + open my $olderr, '>&', *STDERR + or die "Can't save STDERR: $!"; + my $str; + my $result = eval { + local $SIG{__DIE__}; + close STDERR; + open STDERR, '>', \$str + or die "Can't redirect STDERR: $!"; + Dump($_[0]); + 1; + }; + my $reason = $@; + open STDERR, '>&', $olderr + or die "Can't restore STDERR: $!"; + $result or die $reason; + $str; +} + +# Avoid die() in a test harness. +sub capture_dump_in_test +{ + my $str; + eval { $str = capture_dump($_[0]); 1 } or BAIL_OUT $@; + $str; +} + +sub is_iv ($$) +{ + # We would write "ok(SvIOK($_[0]), ...)", + # but unfortunately SvIOK is not available in Perl. + + my $dump = capture_dump_in_test($_[0]); + #note($dump); + ok($dump =~ /^\h*FLAGS = .*\bIOK\b/m && $dump =~ /^\h*IV =/m, $_[1]); +} + +my @tests = qw(EXIT_SUCCESS); + +push @tests, qw(FLT_RADIX FP_NORMAL FP_ZERO FP_SUBNORMAL FP_INFINITE FP_NAN); + +if ($Config{uselongdouble} ? $Config{d_ilogbl} : $Config{d_ilogb}) { + push @tests, qw(FP_ILOGB0); + push @tests, qw(FP_ILOGBNAN) if $Config{d_double_has_nan}; +} + +foreach my $flt ('FLT', 'DBL', ($Config{d_longdbl} ? ('LDBL') : ())) { + push @tests, "${flt}_$_" + foreach qw(DIG MANT_DIG MAX_10_EXP MAX_EXP MIN_10_EXP MIN_EXP); +} + +push @tests, qw(FE_TONEAREST FE_TOWARDZERO FE_UPWARD FE_DOWNWARD) + if $Config{d_fegetround}; + +is_iv(eval "POSIX::$_", "$_ is an integer") foreach @tests; + +done_testing(); diff --git a/ext/POSIX/t/posix.t b/ext/POSIX/t/posix.t index 502493737191..60ef36d15eee 100644 --- a/ext/POSIX/t/posix.t +++ b/ext/POSIX/t/posix.t @@ -351,7 +351,12 @@ is ($result, undef, "fgets should fail"); like ($@, qr/^Unimplemented: POSIX::fgets\(\): Use method IO::Handle::gets\(\) instead/, "check its redef message"); -eval { use strict; POSIX->import("S_ISBLK"); my $x = S_ISBLK }; +eval { + use strict; + no warnings 'uninitialized'; # S_ISBLK normally has an arg + POSIX->import("S_ISBLK"); + my $x = S_ISBLK +}; unlike( $@, qr/Can't use string .* as a symbol ref/, "Can import autoloaded constants" ); SKIP: { diff --git a/ext/POSIX/t/time.t b/ext/POSIX/t/time.t index b19ed70ad3cf..5e71d27f66b9 100644 --- a/ext/POSIX/t/time.t +++ b/ext/POSIX/t/time.t @@ -86,7 +86,7 @@ if (locales_enabled('LC_TIME')) { setlocale(LC_TIME, $orig_time_loc) || die "Cannot setlocale(LC_TIME) back to orig: $!"; } if (locales_enabled('LC_CTYPE')) { - setlocale(LC_TIME, $orig_ctype_loc) || die "Cannot setlocale(LC_CTYPE) back to orig: $!"; + setlocale(LC_CTYPE, $orig_ctype_loc) || die "Cannot setlocale(LC_CTYPE) back to orig: $!"; } # clock() seems to have different definitions of what it does between POSIX diff --git a/ext/POSIX/t/waitpid.t b/ext/POSIX/t/waitpid.t index 7e821fd8257b..d47382bf5771 100644 --- a/ext/POSIX/t/waitpid.t +++ b/ext/POSIX/t/waitpid.t @@ -61,7 +61,7 @@ if ($child_pid) { $state = NEG1_REQUIRED; is(WIFEXITED(${^CHILD_ERROR_NATIVE}), 1, 'child exited cleanly'); is(WEXITSTATUS(${^CHILD_ERROR_NATIVE}), 0, - 'child exited with 0 (the retun value of its sleep(3) call)'); + 'child exited with 0 (the return value of its sleep(3) call)'); } } diff --git a/ext/PerlIO-encoding/encoding.pm b/ext/PerlIO-encoding/encoding.pm index daf44571880e..c80a96e7a754 100644 --- a/ext/PerlIO-encoding/encoding.pm +++ b/ext/PerlIO-encoding/encoding.pm @@ -1,7 +1,7 @@ package PerlIO::encoding; use strict; -our $VERSION = '0.28'; +our $VERSION = '0.29'; our $DEBUG = 0; $DEBUG and warn __PACKAGE__, " called by ", join(", ", caller), "\n"; @@ -13,8 +13,7 @@ $DEBUG and warn __PACKAGE__, " called by ", join(", ", caller), "\n"; require XSLoader; XSLoader::load(); -our $fallback = - Encode::PERLQQ()|Encode::WARN_ON_ERR()|Encode::ONLY_PRAGMA_WARNINGS()|Encode::STOP_AT_PARTIAL(); +our $fallback = Encode::PERLQQ()|Encode::WARN_ON_ERR()|Encode::ONLY_PRAGMA_WARNINGS(); 1; __END__ diff --git a/ext/PerlIO-encoding/encoding.xs b/ext/PerlIO-encoding/encoding.xs index 9d98d878db22..9deb20bf2670 100644 --- a/ext/PerlIO-encoding/encoding.xs +++ b/ext/PerlIO-encoding/encoding.xs @@ -5,6 +5,12 @@ #define U8 U8 #define OUR_DEFAULT_FB "Encode::PERLQQ" +#define OUR_STOP_AT_PARTIAL "Encode::STOP_AT_PARTIAL" +#define OUR_LEAVE_SRC "Encode::LEAVE_SRC" + +/* This will be set during BOOT */ +static unsigned int encode_stop_at_partial = 0; +static unsigned int encode_leave_src = 0; #if defined(USE_PERLIO) @@ -164,6 +170,9 @@ PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg, PerlIO_funcs * } e->chk = newSVsv(get_sv("PerlIO::encoding::fallback", 0)); + if (SvROK(e->chk)) + Perl_croak(aTHX_ "PerlIO::encoding::fallback must be an integer"); + SvUV_set(e->chk, SvUV(e->chk) & ~encode_leave_src | encode_stop_at_partial); e->inEncodeCall = 0; FREETMPS; @@ -645,23 +654,30 @@ BOOT: * is invoked without prior "use Encode". -- dankogai */ PUSHSTACKi(PERLSI_MAGIC); - if (!get_cvs(OUR_DEFAULT_FB, 0)) { -#if 0 - /* This would just be an irritant now loading works */ - Perl_warner(aTHX_ packWARN(WARN_IO), ":encoding without 'use Encode'"); -#endif + if (!get_cvs(OUR_STOP_AT_PARTIAL, 0)) { /* The SV is magically freed by load_module */ load_module(PERL_LOADMOD_NOIMPORT, newSVpvs("Encode"), Nullsv, Nullsv); assert(sp == PL_stack_sp); } + + PUSHMARK(sp); + PUTBACK; + if (call_pv(OUR_STOP_AT_PARTIAL, G_SCALAR) != 1) { + /* should never happen */ + Perl_die(aTHX_ "%s did not return a value", OUR_STOP_AT_PARTIAL); + } + SPAGAIN; + encode_stop_at_partial = POPu; + PUSHMARK(sp); PUTBACK; - if (call_pv(OUR_DEFAULT_FB, G_SCALAR) != 1) { + if (call_pv(OUR_LEAVE_SRC, G_SCALAR) != 1) { /* should never happen */ - Perl_die(aTHX_ "%s did not return a value",OUR_DEFAULT_FB); + Perl_die(aTHX_ "%s did not return a value", OUR_LEAVE_SRC); } SPAGAIN; - sv_setsv(chk, POPs); + encode_leave_src = POPu; + PUTBACK; #ifdef PERLIO_LAYERS PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_encode)); diff --git a/ext/Pod-Functions/.gitignore b/ext/Pod-Functions/.gitignore index 2ba87d73c541..d7514361b88f 100644 --- a/ext/Pod-Functions/.gitignore +++ b/ext/Pod-Functions/.gitignore @@ -1 +1,2 @@ /Functions.pm +!/Makefile.PL diff --git a/ext/SDBM_File/.gitignore b/ext/SDBM_File/.gitignore index acccbd016a73..18641ce7c37f 100644 --- a/ext/SDBM_File/.gitignore +++ b/ext/SDBM_File/.gitignore @@ -1,2 +1,3 @@ !*.c SDBM_File.c +!/Makefile.PL diff --git a/ext/SDBM_File/dba.c b/ext/SDBM_File/dba.c index b27c3e66a47b..84622137245e 100644 --- a/ext/SDBM_File/dba.c +++ b/ext/SDBM_File/dba.c @@ -13,75 +13,75 @@ extern void oops(); int main(int argc, char **argv) { - int n; - char *p; - char *name; - int pagf; + int n; + char *p; + char *name; + int pagf; - progname = argv[0]; + progname = argv[0]; - if (p = argv[1]) { - name = (char *) malloc((n = strlen(p)) + 5); - if (!name) - oops("cannot get memory"); + if (p = argv[1]) { + name = (char *) malloc((n = strlen(p)) + 5); + if (!name) + oops("cannot get memory"); - strcpy(name, p); - strcpy(name + n, ".pag"); + strcpy(name, p); + strcpy(name + n, ".pag"); - if ((pagf = open(name, O_RDONLY)) < 0) - oops("cannot open %s.", name); + if ((pagf = open(name, O_RDONLY)) < 0) + oops("cannot open %s.", name); - sdump(pagf); - } - else - oops("usage: %s dbname", progname); + sdump(pagf); + } + else + oops("usage: %s dbname", progname); - return 0; + return 0; } void sdump(int pagf) { - int b; - int n = 0; - int t = 0; - int o = 0; - int e; - char pag[PBLKSIZ]; + int b; + int n = 0; + int t = 0; + int o = 0; + int e; + char pag[PBLKSIZ]; - while ((b = read(pagf, pag, PBLKSIZ)) > 0) { - printf("#%d: ", n); - if (!okpage(pag)) - printf("bad\n"); - else { - printf("ok. "); - if (!(e = pagestat(pag))) - o++; - else - t += e; - } - n++; - } + while ((b = read(pagf, pag, PBLKSIZ)) > 0) { + printf("#%d: ", n); + if (!okpage(pag)) + printf("bad\n"); + else { + printf("ok. "); + if (!(e = pagestat(pag))) + o++; + else + t += e; + } + n++; + } - if (b == 0) - printf("%d pages (%d holes): %d entries\n", n, o, t); - else - oops("read failed: block %d", n); + if (b == 0) + printf("%d pages (%d holes): %d entries\n", n, o, t); + else + oops("read failed: block %d", n); } int pagestat(char *pag) { - int n; - int free; - short *ino = (short *) pag; + int n; + int free; + short *ino = (short *) pag; - if (!(n = ino[0])) - printf("no entries.\n"); - else { - free = ino[n] - (n + 1) * sizeof(short); - printf("%3d entries %2d%% used free %d.\n", - n / 2, ((PBLKSIZ - free) * 100) / PBLKSIZ, free); - } - return n / 2; + if (!(n = ino[0])) + printf("no entries.\n"); + else { + free = ino[n] - (n + 1) * sizeof(short); + printf("%3d entries %2d%% used free %d.\n", + n / 2, ((PBLKSIZ - free) * 100) / PBLKSIZ, free); + } + return n / 2; } diff --git a/ext/SDBM_File/dbd.c b/ext/SDBM_File/dbd.c index df27d174a800..bd64d90a18a8 100644 --- a/ext/SDBM_File/dbd.c +++ b/ext/SDBM_File/dbd.c @@ -16,53 +16,53 @@ extern void oops(); int main(int argc, char **argv) { - int n; - char *p; - char *name; - int pagf; + int n; + char *p; + char *name; + int pagf; - progname = argv[0]; + progname = argv[0]; - if (p = argv[1]) { - name = (char *) malloc((n = strlen(p)) + 5); - if (!name) - oops("cannot get memory"); + if (p = argv[1]) { + name = (char *) malloc((n = strlen(p)) + 5); + if (!name) + oops("cannot get memory"); - strcpy(name, p); - strcpy(name + n, ".pag"); + strcpy(name, p); + strcpy(name + n, ".pag"); - if ((pagf = open(name, O_RDONLY)) < 0) - oops("cannot open %s.", name); + if ((pagf = open(name, O_RDONLY)) < 0) + oops("cannot open %s.", name); - sdump(pagf); - } - else - oops("usage: %s dbname", progname); - return 0; + sdump(pagf); + } + else + oops("usage: %s dbname", progname); + return 0; } void sdump(int pagf) { - int r; - int n = 0; - int o = 0; - char pag[PBLKSIZ]; - - while ((r = read(pagf, pag, PBLKSIZ)) > 0) { - if (!okpage(pag)) - fprintf(stderr, "%d: bad page.\n", n); - else if (empty(pag)) - o++; - else - dispage(pag); - n++; - } - - if (r == 0) - fprintf(stderr, "%d pages (%d holes).\n", n, o); - else - oops("read failed: block %d", n); + int r; + int n = 0; + int o = 0; + char pag[PBLKSIZ]; + + while ((r = read(pagf, pag, PBLKSIZ)) > 0) { + if (!okpage(pag)) + fprintf(stderr, "%d: bad page.\n", n); + else if (empty(pag)) + o++; + else + dispage(pag); + n++; + } + + if (r == 0) + fprintf(stderr, "%d pages (%d holes).\n", n, o); + else + oops("read failed: block %d", n); } @@ -70,44 +70,44 @@ sdump(int pagf) int dispage(char *pag) { - int i, n; - int off; - int short *ino = (short *) pag; - - off = PBLKSIZ; - for (i = 1; i < ino[0]; i += 2) { - printf("\t[%d]: ", ino[i]); - for (n = ino[i]; n < off; n++) - putchar(pag[n]); - putchar(' '); - off = ino[i]; - printf("[%d]: ", ino[i + 1]); - for (n = ino[i + 1]; n < off; n++) - putchar(pag[n]); - off = ino[i + 1]; - putchar('\n'); - } + int i, n; + int off; + int short *ino = (short *) pag; + + off = PBLKSIZ; + for (i = 1; i < ino[0]; i += 2) { + printf("\t[%d]: ", ino[i]); + for (n = ino[i]; n < off; n++) + putchar(pag[n]); + putchar(' '); + off = ino[i]; + printf("[%d]: ", ino[i + 1]); + for (n = ino[i + 1]; n < off; n++) + putchar(pag[n]); + off = ino[i + 1]; + putchar('\n'); + } } #else void dispage(char *pag) { - int i, n; - int off; - short *ino = (short *) pag; - - off = PBLKSIZ; - for (i = 1; i < ino[0]; i += 2) { - for (n = ino[i]; n < off; n++) - if (pag[n] != 0) - putchar(pag[n]); - putchar('\t'); - off = ino[i]; - for (n = ino[i + 1]; n < off; n++) - if (pag[n] != 0) - putchar(pag[n]); - putchar('\n'); - off = ino[i + 1]; - } + int i, n; + int off; + short *ino = (short *) pag; + + off = PBLKSIZ; + for (i = 1; i < ino[0]; i += 2) { + for (n = ino[i]; n < off; n++) + if (pag[n] != 0) + putchar(pag[n]); + putchar('\t'); + off = ino[i]; + for (n = ino[i + 1]; n < off; n++) + if (pag[n] != 0) + putchar(pag[n]); + putchar('\n'); + off = ino[i + 1]; + } } #endif diff --git a/ext/SDBM_File/dbe.c b/ext/SDBM_File/dbe.c index d1e3bd5e77c9..a53346b67e90 100644 --- a/ext/SDBM_File/dbe.c +++ b/ext/SDBM_File/dbe.c @@ -51,381 +51,381 @@ char *optarg; /* Global argument pointer. */ char getopt(int argc, char **argv, char *optstring) { - int c; - char *place; - static int optind = 0; - static char *scan = NULL; - - optarg = NULL; - - if (scan == NULL || *scan == '\0') { - - if (optind == 0) - optind++; - if (optind >= argc) - return ':'; - - optarg = place = argv[optind++]; - if (place[0] != '-' || place[1] == '\0') - return '?'; - if (place[1] == '-' && place[2] == '\0') - return '?'; - scan = place + 1; - } - - c = *scan++; - place = strchr(optstring, c); - if (place == NULL || c == ':' || c == ';') { - - (void) fprintf(stderr, "%s: unknown option %c\n", argv[0], c); - scan = NULL; - return '!'; - } - if (*++place == ':') { - - if (*scan != '\0') { - - optarg = scan; - scan = NULL; - - } - else { - - if (optind >= argc) { - - (void) fprintf(stderr, "%s: %c requires an argument\n", - argv[0], c); - return '!'; - } - optarg = argv[optind]; - optind++; - } - } - else if (*place == ';') { - - if (*scan != '\0') { - - optarg = scan; - scan = NULL; - - } - else { - - if (optind >= argc || *argv[optind] == '-') - optarg = NULL; - else { - optarg = argv[optind]; - optind++; - } - } - } - return c; + int c; + char *place; + static int optind = 0; + static char *scan = NULL; + + optarg = NULL; + + if (scan == NULL || *scan == '\0') { + + if (optind == 0) + optind++; + if (optind >= argc) + return ':'; + + optarg = place = argv[optind++]; + if (place[0] != '-' || place[1] == '\0') + return '?'; + if (place[1] == '-' && place[2] == '\0') + return '?'; + scan = place + 1; + } + + c = *scan++; + place = strchr(optstring, c); + if (place == NULL || c == ':' || c == ';') { + + (void) fprintf(stderr, "%s: unknown option %c\n", argv[0], c); + scan = NULL; + return '!'; + } + if (*++place == ':') { + + if (*scan != '\0') { + + optarg = scan; + scan = NULL; + + } + else { + + if (optind >= argc) { + + (void) fprintf(stderr, "%s: %c requires an argument\n", + argv[0], c); + return '!'; + } + optarg = argv[optind]; + optind++; + } + } + else if (*place == ';') { + + if (*scan != '\0') { + + optarg = scan; + scan = NULL; + + } + else { + + if (optind >= argc || *argv[optind] == '-') + optarg = NULL; + else { + optarg = argv[optind]; + optind++; + } + } + } + return c; } void print_datum(datum db) { - int i; - - putchar('"'); - for (i = 0; i < db.dsize; i++) { - if (isprint((unsigned char)db.dptr[i])) - putchar(db.dptr[i]); - else { - putchar('\\'); - putchar('0' + ((db.dptr[i] >> 6) & 0x07)); - putchar('0' + ((db.dptr[i] >> 3) & 0x07)); - putchar('0' + (db.dptr[i] & 0x07)); - } - } - putchar('"'); + int i; + + putchar('"'); + for (i = 0; i < db.dsize; i++) { + if (isprint((unsigned char)db.dptr[i])) + putchar(db.dptr[i]); + else { + putchar('\\'); + putchar('0' + ((db.dptr[i] >> 6) & 0x07)); + putchar('0' + ((db.dptr[i] >> 3) & 0x07)); + putchar('0' + (db.dptr[i] & 0x07)); + } + } + putchar('"'); } datum read_datum(char *s) { - datum db; - char *p; - int i; - - db.dsize = 0; - db.dptr = (char *) malloc(strlen(s) * sizeof(char)); - if (!db.dptr) - oops("cannot get memory"); - - for (p = db.dptr; *s != '\0'; p++, db.dsize++, s++) { - if (*s == '\\') { - if (*++s == 'n') - *p = '\n'; - else if (*s == 'r') - *p = '\r'; - else if (*s == 'f') - *p = '\f'; - else if (*s == 't') - *p = '\t'; - else if (isdigit((unsigned char)*s) - && isdigit((unsigned char)*(s + 1)) - && isdigit((unsigned char)*(s + 2))) - { - i = (*s++ - '0') << 6; - i |= (*s++ - '0') << 3; - i |= *s - '0'; - *p = i; - } - else if (*s == '0') - *p = '\0'; - else - *p = *s; - } - else - *p = *s; - } - - return db; + datum db; + char *p; + int i; + + db.dsize = 0; + db.dptr = (char *) malloc(strlen(s) * sizeof(char)); + if (!db.dptr) + oops("cannot get memory"); + + for (p = db.dptr; *s != '\0'; p++, db.dsize++, s++) { + if (*s == '\\') { + if (*++s == 'n') + *p = '\n'; + else if (*s == 'r') + *p = '\r'; + else if (*s == 'f') + *p = '\f'; + else if (*s == 't') + *p = '\t'; + else if (isdigit((unsigned char)*s) + && isdigit((unsigned char)*(s + 1)) + && isdigit((unsigned char)*(s + 2))) + { + i = (*s++ - '0') << 6; + i |= (*s++ - '0') << 3; + i |= *s - '0'; + *p = i; + } + else if (*s == '0') + *p = '\0'; + else + *p = *s; + } + else + *p = *s; + } + + return db; } char * key2s(datum db) { - char *buf; - char *p1, *p2; - - buf = (char *) malloc((db.dsize + 1) * sizeof(char)); - if (!buf) - oops("cannot get memory"); - for (p1 = buf, p2 = db.dptr; *p2 != '\0'; *p1++ = *p2++); - *p1 = '\0'; - return buf; + char *buf; + char *p1, *p2; + + buf = (char *) malloc((db.dsize + 1) * sizeof(char)); + if (!buf) + oops("cannot get memory"); + for (p1 = buf, p2 = db.dptr; *p2 != '\0'; *p1++ = *p2++); + *p1 = '\0'; + return buf; } int main(int argc, char **argv) { - typedef enum { - YOW, FETCH, STORE, DELETE, SCAN, REGEXP - } commands; - char opt; - int flags; - int giveusage = 0; - int verbose = 0; - commands what = YOW; - char *comarg[3]; - int st_flag = DBM_INSERT; - int argn; - DBM *db; - datum key; - datum content; - - flags = O_RDWR; - argn = 0; - - while ((opt = getopt(argc, argv, "acdfFm:rstvx")) != ':') { - switch (opt) { - case 'a': - what = SCAN; - break; - case 'c': - flags |= O_CREAT; - break; - case 'd': - what = DELETE; - break; - case 'f': - what = FETCH; - break; - case 'F': - what = REGEXP; - break; - case 'm': - flags &= ~(000007); - if (strcmp(optarg, "r") == 0) - flags |= O_RDONLY; - else if (strcmp(optarg, "w") == 0) - flags |= O_WRONLY; - else if (strcmp(optarg, "rw") == 0) - flags |= O_RDWR; - else { - fprintf(stderr, "Invalid mode: \"%s\"\n", optarg); - giveusage = 1; - } - break; - case 'r': - st_flag = DBM_REPLACE; - break; - case 's': - what = STORE; - break; - case 't': - flags |= O_TRUNC; - break; - case 'v': - verbose = 1; - break; - case 'x': - flags |= O_EXCL; - break; - case '!': - giveusage = 1; - break; - case '?': - if (argn < 3) - comarg[argn++] = optarg; - else { - fprintf(stderr, "Too many arguments.\n"); - giveusage = 1; - } - break; - } - } - - if (giveusage || what == YOW || argn < 1) { - fprintf(stderr, "Usage: %s database [-m r|w|rw] [-crtx] -a|-d|-f|-F|-s [key [content]]\n", argv[0]); - exit(-1); - } - - if ((db = dbm_open(comarg[0], flags, 0777)) == NULL) { - fprintf(stderr, "Error opening database \"%s\"\n", comarg[0]); - exit(-1); - } - - if (argn > 1) - key = read_datum(comarg[1]); - if (argn > 2) - content = read_datum(comarg[2]); - - switch (what) { - - case SCAN: - key = dbm_firstkey(db); - if (dbm_error(db)) { - fprintf(stderr, "Error when fetching first key\n"); - goto db_exit; - } - while (key.dptr != NULL) { - content = dbm_fetch(db, key); - if (dbm_error(db)) { - fprintf(stderr, "Error when fetching "); - print_datum(key); - printf("\n"); - goto db_exit; - } - print_datum(key); - printf(": "); - print_datum(content); - printf("\n"); - if (dbm_error(db)) { - fprintf(stderr, "Error when fetching next key\n"); - goto db_exit; - } - key = dbm_nextkey(db); - } - break; - - case REGEXP: - if (argn < 2) { - fprintf(stderr, "Missing regular expression.\n"); - goto db_exit; - } - if (re_comp(comarg[1])) { - fprintf(stderr, "Invalid regular expression\n"); - goto db_exit; - } - key = dbm_firstkey(db); - if (dbm_error(db)) { - fprintf(stderr, "Error when fetching first key\n"); - goto db_exit; - } - while (key.dptr != NULL) { - if (re_exec(key2s(key))) { - content = dbm_fetch(db, key); - if (dbm_error(db)) { - fprintf(stderr, "Error when fetching "); - print_datum(key); - printf("\n"); - goto db_exit; - } - print_datum(key); - printf(": "); - print_datum(content); - printf("\n"); - if (dbm_error(db)) { - fprintf(stderr, "Error when fetching next key\n"); - goto db_exit; - } - } - key = dbm_nextkey(db); - } - break; - - case FETCH: - if (argn < 2) { - fprintf(stderr, "Missing fetch key.\n"); - goto db_exit; - } - content = dbm_fetch(db, key); - if (dbm_error(db)) { - fprintf(stderr, "Error when fetching "); - print_datum(key); - printf("\n"); - goto db_exit; - } - if (content.dptr == NULL) { - fprintf(stderr, "Cannot find "); - print_datum(key); - printf("\n"); - goto db_exit; - } - print_datum(key); - printf(": "); - print_datum(content); - printf("\n"); - break; - - case DELETE: - if (argn < 2) { - fprintf(stderr, "Missing delete key.\n"); - goto db_exit; - } - if (dbm_delete(db, key) || dbm_error(db)) { - fprintf(stderr, "Error when deleting "); - print_datum(key); - printf("\n"); - goto db_exit; - } - if (verbose) { - print_datum(key); - printf(": DELETED\n"); - } - break; - - case STORE: - if (argn < 3) { - fprintf(stderr, "Missing key and/or content.\n"); - goto db_exit; - } - if (dbm_store(db, key, content, st_flag) || dbm_error(db)) { - fprintf(stderr, "Error when storing "); - print_datum(key); - printf("\n"); - goto db_exit; - } - if (verbose) { - print_datum(key); - printf(": "); - print_datum(content); - printf(" STORED\n"); - } - break; - } + typedef enum { + YOW, FETCH, STORE, DELETE, SCAN, REGEXP + } commands; + char opt; + int flags; + int giveusage = 0; + int verbose = 0; + commands what = YOW; + char *comarg[3]; + int st_flag = DBM_INSERT; + int argn; + DBM *db; + datum key; + datum content; + + flags = O_RDWR; + argn = 0; + + while ((opt = getopt(argc, argv, "acdfFm:rstvx")) != ':') { + switch (opt) { + case 'a': + what = SCAN; + break; + case 'c': + flags |= O_CREAT; + break; + case 'd': + what = DELETE; + break; + case 'f': + what = FETCH; + break; + case 'F': + what = REGEXP; + break; + case 'm': + flags &= ~(000007); + if (strcmp(optarg, "r") == 0) + flags |= O_RDONLY; + else if (strcmp(optarg, "w") == 0) + flags |= O_WRONLY; + else if (strcmp(optarg, "rw") == 0) + flags |= O_RDWR; + else { + fprintf(stderr, "Invalid mode: \"%s\"\n", optarg); + giveusage = 1; + } + break; + case 'r': + st_flag = DBM_REPLACE; + break; + case 's': + what = STORE; + break; + case 't': + flags |= O_TRUNC; + break; + case 'v': + verbose = 1; + break; + case 'x': + flags |= O_EXCL; + break; + case '!': + giveusage = 1; + break; + case '?': + if (argn < 3) + comarg[argn++] = optarg; + else { + fprintf(stderr, "Too many arguments.\n"); + giveusage = 1; + } + break; + } + } + + if (giveusage || what == YOW || argn < 1) { + fprintf(stderr, "Usage: %s database [-m r|w|rw] [-crtx] -a|-d|-f|-F|-s [key [content]]\n", argv[0]); + exit(-1); + } + + if ((db = dbm_open(comarg[0], flags, 0777)) == NULL) { + fprintf(stderr, "Error opening database \"%s\"\n", comarg[0]); + exit(-1); + } + + if (argn > 1) + key = read_datum(comarg[1]); + if (argn > 2) + content = read_datum(comarg[2]); + + switch (what) { + + case SCAN: + key = dbm_firstkey(db); + if (dbm_error(db)) { + fprintf(stderr, "Error when fetching first key\n"); + goto db_exit; + } + while (key.dptr != NULL) { + content = dbm_fetch(db, key); + if (dbm_error(db)) { + fprintf(stderr, "Error when fetching "); + print_datum(key); + printf("\n"); + goto db_exit; + } + print_datum(key); + printf(": "); + print_datum(content); + printf("\n"); + if (dbm_error(db)) { + fprintf(stderr, "Error when fetching next key\n"); + goto db_exit; + } + key = dbm_nextkey(db); + } + break; + + case REGEXP: + if (argn < 2) { + fprintf(stderr, "Missing regular expression.\n"); + goto db_exit; + } + if (re_comp(comarg[1])) { + fprintf(stderr, "Invalid regular expression\n"); + goto db_exit; + } + key = dbm_firstkey(db); + if (dbm_error(db)) { + fprintf(stderr, "Error when fetching first key\n"); + goto db_exit; + } + while (key.dptr != NULL) { + if (re_exec(key2s(key))) { + content = dbm_fetch(db, key); + if (dbm_error(db)) { + fprintf(stderr, "Error when fetching "); + print_datum(key); + printf("\n"); + goto db_exit; + } + print_datum(key); + printf(": "); + print_datum(content); + printf("\n"); + if (dbm_error(db)) { + fprintf(stderr, "Error when fetching next key\n"); + goto db_exit; + } + } + key = dbm_nextkey(db); + } + break; + + case FETCH: + if (argn < 2) { + fprintf(stderr, "Missing fetch key.\n"); + goto db_exit; + } + content = dbm_fetch(db, key); + if (dbm_error(db)) { + fprintf(stderr, "Error when fetching "); + print_datum(key); + printf("\n"); + goto db_exit; + } + if (content.dptr == NULL) { + fprintf(stderr, "Cannot find "); + print_datum(key); + printf("\n"); + goto db_exit; + } + print_datum(key); + printf(": "); + print_datum(content); + printf("\n"); + break; + + case DELETE: + if (argn < 2) { + fprintf(stderr, "Missing delete key.\n"); + goto db_exit; + } + if (dbm_delete(db, key) || dbm_error(db)) { + fprintf(stderr, "Error when deleting "); + print_datum(key); + printf("\n"); + goto db_exit; + } + if (verbose) { + print_datum(key); + printf(": DELETED\n"); + } + break; + + case STORE: + if (argn < 3) { + fprintf(stderr, "Missing key and/or content.\n"); + goto db_exit; + } + if (dbm_store(db, key, content, st_flag) || dbm_error(db)) { + fprintf(stderr, "Error when storing "); + print_datum(key); + printf("\n"); + goto db_exit; + } + if (verbose) { + print_datum(key); + printf(": "); + print_datum(content); + printf(" STORED\n"); + } + break; + } db_exit: - dbm_clearerr(db); - dbm_close(db); - if (dbm_error(db)) { - fprintf(stderr, "Error closing database \"%s\"\n", comarg[0]); - exit(-1); - } + dbm_clearerr(db); + dbm_close(db); + if (dbm_error(db)) { + fprintf(stderr, "Error closing database \"%s\"\n", comarg[0]); + exit(-1); + } } diff --git a/ext/SDBM_File/dbu.c b/ext/SDBM_File/dbu.c index ef1963d3501f..9cf48fa39777 100644 --- a/ext/SDBM_File/dbu.c +++ b/ext/SDBM_File/dbu.c @@ -28,30 +28,30 @@ static char *usage = "%s [-R] cat | look |... dbmname"; #define LINEMAX 8192 typedef struct { - char *sname; - int scode; - int flags; + char *sname; + int scode; + int flags; } cmd; static cmd cmds[] = { - "fetch", DLOOK, O_RDONLY, - "get", DLOOK, O_RDONLY, - "look", DLOOK, O_RDONLY, - "add", DINSERT, O_RDWR, - "insert", DINSERT, O_RDWR, - "store", DINSERT, O_RDWR, - "delete", DDELETE, O_RDWR, - "remove", DDELETE, O_RDWR, - "dump", DCAT, O_RDONLY, - "list", DCAT, O_RDONLY, - "cat", DCAT, O_RDONLY, - "creat", DCREAT, O_RDWR | O_CREAT | O_TRUNC, - "new", DCREAT, O_RDWR | O_CREAT | O_TRUNC, - "build", DBUILD, O_RDWR | O_CREAT, - "squash", DPRESS, O_RDWR, - "compact", DPRESS, O_RDWR, - "compress", DPRESS, O_RDWR + "fetch", DLOOK, O_RDONLY, + "get", DLOOK, O_RDONLY, + "look", DLOOK, O_RDONLY, + "add", DINSERT, O_RDWR, + "insert", DINSERT, O_RDWR, + "store", DINSERT, O_RDWR, + "delete", DDELETE, O_RDWR, + "remove", DDELETE, O_RDWR, + "dump", DCAT, O_RDONLY, + "list", DCAT, O_RDONLY, + "cat", DCAT, O_RDONLY, + "creat", DCREAT, O_RDWR | O_CREAT | O_TRUNC, + "new", DCREAT, O_RDWR | O_CREAT | O_TRUNC, + "build", DBUILD, O_RDWR | O_CREAT, + "squash", DPRESS, O_RDWR, + "compact", DPRESS, O_RDWR, + "compress", DPRESS, O_RDWR }; #define CTABSIZ (sizeof (cmds)/sizeof (cmd)) @@ -62,173 +62,173 @@ static void badk(), doit(), prdatum(); int main(int argc, char **argv) { - int c; - cmd *act; - extern int optind; - extern char *optarg; - - progname = argv[0]; - - while ((c = getopt(argc, argv, "R")) != EOF) - switch (c) { - case 'R': /* raw processing */ - rflag++; - break; - - default: - oops("usage: %s", usage); - break; - } - - if ((argc -= optind) < 2) - oops("usage: %s", usage); - - if ((act = parse(argv[optind])) == NULL) - badk(argv[optind]); - optind++; - doit(act, argv[optind]); - return 0; + int c; + cmd *act; + extern int optind; + extern char *optarg; + + progname = argv[0]; + + while ((c = getopt(argc, argv, "R")) != EOF) + switch (c) { + case 'R': /* raw processing */ + rflag++; + break; + + default: + oops("usage: %s", usage); + break; + } + + if ((argc -= optind) < 2) + oops("usage: %s", usage); + + if ((act = parse(argv[optind])) == NULL) + badk(argv[optind]); + optind++; + doit(act, argv[optind]); + return 0; } static void doit(cmd *act, char *file) { - datum key; - datum val; - DBM *db; - char *op; - int n; - char *line; + datum key; + datum val; + DBM *db; + char *op; + int n; + char *line; #ifdef TIME - long start; - extern long time(); + long start; + extern long time(); #endif - if ((db = dbm_open(file, act->flags, 0644)) == NULL) - oops("cannot open: %s", file); - - if ((line = (char *) malloc(LINEMAX)) == NULL) - oops("%s: cannot get memory", "line alloc"); - - switch (act->scode) { - - case DLOOK: - while (fgets(line, LINEMAX, stdin) != NULL) { - n = strlen(line) - 1; - line[n] = 0; - key.dptr = line; - key.dsize = n; - val = dbm_fetch(db, key); - if (val.dptr != NULL) { - prdatum(stdout, val); - putchar('\n'); - continue; - } - prdatum(stderr, key); - fprintf(stderr, ": not found.\n"); - } - break; - case DINSERT: - break; - case DDELETE: - while (fgets(line, LINEMAX, stdin) != NULL) { - n = strlen(line) - 1; - line[n] = 0; - key.dptr = line; - key.dsize = n; - if (dbm_delete(db, key) == -1) { - prdatum(stderr, key); - fprintf(stderr, ": not found.\n"); - } - } - break; - case DCAT: - for (key = dbm_firstkey(db); key.dptr != 0; - key = dbm_nextkey(db)) { - prdatum(stdout, key); - putchar('\t'); - prdatum(stdout, dbm_fetch(db, key)); - putchar('\n'); - } - break; - case DBUILD: + if ((db = dbm_open(file, act->flags, 0644)) == NULL) + oops("cannot open: %s", file); + + if ((line = (char *) malloc(LINEMAX)) == NULL) + oops("%s: cannot get memory", "line alloc"); + + switch (act->scode) { + + case DLOOK: + while (fgets(line, LINEMAX, stdin) != NULL) { + n = strlen(line) - 1; + line[n] = 0; + key.dptr = line; + key.dsize = n; + val = dbm_fetch(db, key); + if (val.dptr != NULL) { + prdatum(stdout, val); + putchar('\n'); + continue; + } + prdatum(stderr, key); + fprintf(stderr, ": not found.\n"); + } + break; + case DINSERT: + break; + case DDELETE: + while (fgets(line, LINEMAX, stdin) != NULL) { + n = strlen(line) - 1; + line[n] = 0; + key.dptr = line; + key.dsize = n; + if (dbm_delete(db, key) == -1) { + prdatum(stderr, key); + fprintf(stderr, ": not found.\n"); + } + } + break; + case DCAT: + for (key = dbm_firstkey(db); key.dptr != 0; + key = dbm_nextkey(db)) { + prdatum(stdout, key); + putchar('\t'); + prdatum(stdout, dbm_fetch(db, key)); + putchar('\n'); + } + break; + case DBUILD: #ifdef TIME - start = time(0); + start = time(0); #endif - while (fgets(line, LINEMAX, stdin) != NULL) { - n = strlen(line) - 1; - line[n] = 0; - key.dptr = line; - if ((op = strchr(line, '\t')) != 0) { - key.dsize = op - line; - *op++ = 0; - val.dptr = op; - val.dsize = line + n - op; - } - else - oops("bad input; %s", line); - - if (dbm_store(db, key, val, DBM_REPLACE) < 0) { - prdatum(stderr, key); - fprintf(stderr, ": "); - oops("store: %s", "failed"); - } - } + while (fgets(line, LINEMAX, stdin) != NULL) { + n = strlen(line) - 1; + line[n] = 0; + key.dptr = line; + if ((op = strchr(line, '\t')) != 0) { + key.dsize = op - line; + *op++ = 0; + val.dptr = op; + val.dsize = line + n - op; + } + else + oops("bad input; %s", line); + + if (dbm_store(db, key, val, DBM_REPLACE) < 0) { + prdatum(stderr, key); + fprintf(stderr, ": "); + oops("store: %s", "failed"); + } + } #ifdef TIME - printf("done: %d seconds.\n", time(0) - start); + printf("done: %d seconds.\n", time(0) - start); #endif - break; - case DPRESS: - break; - case DCREAT: - break; - } - - dbm_close(db); + break; + case DPRESS: + break; + case DCREAT: + break; + } + + dbm_close(db); } static void badk(char *word) { - int i; - - if (progname) - fprintf(stderr, "%s: ", progname); - fprintf(stderr, "bad keywd %s. use one of\n", word); - for (i = 0; i < (int)CTABSIZ; i++) - fprintf(stderr, "%-8s%c", cmds[i].sname, - ((i + 1) % 6 == 0) ? '\n' : ' '); - fprintf(stderr, "\n"); - exit(1); - /*NOTREACHED*/ + int i; + + if (progname) + fprintf(stderr, "%s: ", progname); + fprintf(stderr, "bad keywd %s. use one of\n", word); + for (i = 0; i < (int)CTABSIZ; i++) + fprintf(stderr, "%-8s%c", cmds[i].sname, + ((i + 1) % 6 == 0) ? '\n' : ' '); + fprintf(stderr, "\n"); + exit(1); + /*NOTREACHED*/ } static cmd * parse(char *str) { - int i = CTABSIZ; - cmd *p; - - for (p = cmds; i--; p++) - if (strcmp(p->sname, str) == 0) - return p; - return NULL; + int i = CTABSIZ; + cmd *p; + + for (p = cmds; i--; p++) + if (strcmp(p->sname, str) == 0) + return p; + return NULL; } static void prdatum(FILE *stream, datum d) { - int c; - U8 *p = (U8 *) d.dptr; - int n = d.dsize; + int c; + U8 *p = (U8 *) d.dptr; + int n = d.dsize; - while (n--) { - c = *p++; + while (n--) { + c = *p++; #ifndef EBCDIC /* Meta notation doesn't make sense on EBCDIC systems*/ - if (c & 0200) { + if (c & 0200) { fprintf(stream, "M-"); c &= 0177; - } + } #endif /* \c notation applies for \0 . \x1f, plus \c? */ if (c <= 0x1F || c == QUESTION_MARK_CTRL) { @@ -237,12 +237,12 @@ prdatum(FILE *stream, datum d) #ifdef EBCDIC /* Instead of meta, use \x{} for non-printables */ else if (! isPRINT_A(c)) { fprintf(stream, "\\x{%02x}", c); - } + } #endif - else { /* must be an ASCII printable */ + else { /* must be an ASCII printable */ putc(c, stream); } - } + } } diff --git a/ext/SDBM_File/sdbm.c b/ext/SDBM_File/sdbm.c index d7839aa8c201..b81d1e30c1ac 100644 --- a/ext/SDBM_File/sdbm.c +++ b/ext/SDBM_File/sdbm.c @@ -29,7 +29,7 @@ */ #include /* See notes in perl.h about avoiding - extern int errno; */ + extern int errno; */ #ifdef __cplusplus extern "C" { #endif @@ -63,58 +63,58 @@ static int makroom(DBM *, long, int); #define OFF_DIR(off) (long) (off) * DBLKSIZ static const long masks[] = { - 000000000000, 000000000001, 000000000003, 000000000007, - 000000000017, 000000000037, 000000000077, 000000000177, - 000000000377, 000000000777, 000000001777, 000000003777, - 000000007777, 000000017777, 000000037777, 000000077777, - 000000177777, 000000377777, 000000777777, 000001777777, - 000003777777, 000007777777, 000017777777, 000037777777, - 000077777777, 000177777777, 000377777777, 000777777777, - 001777777777, 003777777777, 007777777777, 017777777777 + 000000000000, 000000000001, 000000000003, 000000000007, + 000000000017, 000000000037, 000000000077, 000000000177, + 000000000377, 000000000777, 000000001777, 000000003777, + 000000007777, 000000017777, 000000037777, 000000077777, + 000000177777, 000000377777, 000000777777, 000001777777, + 000003777777, 000007777777, 000017777777, 000037777777, + 000077777777, 000177777777, 000377777777, 000777777777, + 001777777777, 003777777777, 007777777777, 017777777777 }; DBM * sdbm_open(char *file, int flags, int mode) { - DBM *db; - char *dirname; - char *pagname; - size_t filelen; - const size_t dirfext_size = sizeof(DIRFEXT ""); - const size_t pagfext_size = sizeof(PAGFEXT ""); - - if (file == NULL || !*file) - return errno = EINVAL, (DBM *) NULL; + DBM *db; + char *dirname; + char *pagname; + size_t filelen; + const size_t dirfext_size = sizeof(DIRFEXT ""); + const size_t pagfext_size = sizeof(PAGFEXT ""); + + if (file == NULL || !*file) + return errno = EINVAL, (DBM *) NULL; /* * need space for two separate filenames */ - filelen = strlen(file); + filelen = strlen(file); - if ((dirname = (char *) malloc(filelen + dirfext_size - + filelen + pagfext_size)) == NULL) - return errno = ENOMEM, (DBM *) NULL; + if ((dirname = (char *) malloc(filelen + dirfext_size + + filelen + pagfext_size)) == NULL) + return errno = ENOMEM, (DBM *) NULL; /* * build the file names */ - memcpy(dirname, file, filelen); - memcpy(dirname + filelen, DIRFEXT, dirfext_size); - pagname = dirname + filelen + dirfext_size; - memcpy(pagname, file, filelen); - memcpy(pagname + filelen, PAGFEXT, pagfext_size); - - db = sdbm_prep(dirname, pagname, flags, mode); - free((char *) dirname); - return db; + memcpy(dirname, file, filelen); + memcpy(dirname + filelen, DIRFEXT, dirfext_size); + pagname = dirname + filelen + dirfext_size; + memcpy(pagname, file, filelen); + memcpy(pagname + filelen, PAGFEXT, pagfext_size); + + db = sdbm_prep(dirname, pagname, flags, mode); + free((char *) dirname); + return db; } DBM * sdbm_prep(char *dirname, char *pagname, int flags, int mode) { - DBM *db; - struct stat dstat; + DBM *db; + struct stat dstat; - if ((db = (DBM *) malloc(sizeof(DBM))) == NULL) - return errno = ENOMEM, (DBM *) NULL; + if ((db = (DBM *) malloc(sizeof(DBM))) == NULL) + return errno = ENOMEM, (DBM *) NULL; db->flags = 0; db->hmask = 0; @@ -125,158 +125,158 @@ sdbm_prep(char *dirname, char *pagname, int flags, int mode) * as required by this package. Also set our internal * flag for RDONLY if needed. */ - if (flags & O_WRONLY) - flags = (flags & ~O_WRONLY) | O_RDWR; + if (flags & O_WRONLY) + flags = (flags & ~O_WRONLY) | O_RDWR; - else if ((flags & 03) == O_RDONLY) - db->flags = DBM_RDONLY; + else if ((flags & 03) == O_RDONLY) + db->flags = DBM_RDONLY; /* * open the files in sequence, and stat the dirfile. * If we fail anywhere, undo everything, return NULL. */ #if defined(OS2) || defined(MSDOS) || defined(WIN32) || defined(__CYGWIN__) - flags |= O_BINARY; + flags |= O_BINARY; # endif - if ((db->pagf = open(pagname, flags, mode)) > -1) { - if ((db->dirf = open(dirname, flags, mode)) > -1) { + if ((db->pagf = open(pagname, flags, mode)) > -1) { + if ((db->dirf = open(dirname, flags, mode)) > -1) { /* * need the dirfile size to establish max bit number. */ - if (fstat(db->dirf, &dstat) == 0) { + if (fstat(db->dirf, &dstat) == 0) { /* * zero size: either a fresh database, or one with a single, * unsplit data page: dirpage is all zeros. */ - db->dirbno = (!dstat.st_size) ? 0 : -1; - db->pagbno = -1; - db->maxbno = dstat.st_size * BYTESIZ; - - (void) memset(db->pagbuf, 0, PBLKSIZ); - (void) memset(db->dirbuf, 0, DBLKSIZ); - /* - * success - */ - return db; - } - (void) close(db->dirf); - } - (void) close(db->pagf); - } - free((char *) db); - return (DBM *) NULL; + db->dirbno = (!dstat.st_size) ? 0 : -1; + db->pagbno = -1; + db->maxbno = dstat.st_size * BYTESIZ; + + (void) memset(db->pagbuf, 0, PBLKSIZ); + (void) memset(db->dirbuf, 0, DBLKSIZ); + /* + * success + */ + return db; + } + (void) close(db->dirf); + } + (void) close(db->pagf); + } + free((char *) db); + return (DBM *) NULL; } void sdbm_close(DBM *db) { - if (db == NULL) - errno = EINVAL; - else { - (void) close(db->dirf); - (void) close(db->pagf); - free((char *) db); - } + if (db == NULL) + errno = EINVAL; + else { + (void) close(db->dirf); + (void) close(db->pagf); + free((char *) db); + } } datum sdbm_fetch(DBM *db, datum key) { - if (db == NULL || bad(key)) - return errno = EINVAL, nullitem; + if (db == NULL || bad(key)) + return errno = EINVAL, nullitem; - if (getpage(db, exhash(key))) - return getpair(db->pagbuf, key); + if (getpage(db, exhash(key))) + return getpair(db->pagbuf, key); - return ioerr(db), nullitem; + return ioerr(db), nullitem; } int sdbm_exists(DBM *db, datum key) { - if (db == NULL || bad(key)) - return errno = EINVAL, -1; + if (db == NULL || bad(key)) + return errno = EINVAL, -1; - if (getpage(db, exhash(key))) - return exipair(db->pagbuf, key); + if (getpage(db, exhash(key))) + return exipair(db->pagbuf, key); - return ioerr(db), -1; + return ioerr(db), -1; } int sdbm_delete(DBM *db, datum key) { - if (db == NULL || bad(key)) - return errno = EINVAL, -1; - if (sdbm_rdonly(db)) - return errno = EPERM, -1; - - if (getpage(db, exhash(key))) { - if (!delpair(db->pagbuf, key)) - return -1; + if (db == NULL || bad(key)) + return errno = EINVAL, -1; + if (sdbm_rdonly(db)) + return errno = EPERM, -1; + + if (getpage(db, exhash(key))) { + if (!delpair(db->pagbuf, key)) + return -1; /* * update the page file */ - if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 - || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) - return ioerr(db), -1; + if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 + || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) + return ioerr(db), -1; - return 0; - } + return 0; + } - return ioerr(db), -1; + return ioerr(db), -1; } int sdbm_store(DBM *db, datum key, datum val, int flags) { - int need; - long hash; + int need; + long hash; - if (db == NULL || bad(key)) - return errno = EINVAL, -1; - if (sdbm_rdonly(db)) - return errno = EPERM, -1; + if (db == NULL || bad(key)) + return errno = EINVAL, -1; + if (sdbm_rdonly(db)) + return errno = EPERM, -1; - need = key.dsize + val.dsize; + need = key.dsize + val.dsize; /* * is the pair too big (or too small) for this database ?? */ - if (need < 0 || need > PAIRMAX) - return errno = EINVAL, -1; + if (need < 0 || need > PAIRMAX) + return errno = EINVAL, -1; - if (getpage(db, (hash = exhash(key)))) { + if (getpage(db, (hash = exhash(key)))) { /* * if we need to replace, delete the key/data pair * first. If it is not there, ignore. */ - if (flags == DBM_REPLACE) - (void) delpair(db->pagbuf, key); + if (flags == DBM_REPLACE) + (void) delpair(db->pagbuf, key); #ifdef SEEDUPS - else if (duppair(db->pagbuf, key)) - return 1; + else if (duppair(db->pagbuf, key)) + return 1; #endif /* * if we do not have enough room, we have to split. */ - if (!fitpair(db->pagbuf, need)) - if (!makroom(db, hash, need)) - return ioerr(db), -1; + if (!fitpair(db->pagbuf, need)) + if (!makroom(db, hash, need)) + return ioerr(db), -1; /* * we have enough room or split is successful. insert the key, * and update the page file. */ - (void) putpair(db->pagbuf, key, val); - - if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 - || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) - return ioerr(db), -1; - /* - * success - */ - return 0; - } - - return ioerr(db), -1; + (void) putpair(db->pagbuf, key, val); + + if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 + || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) + return ioerr(db), -1; + /* + * success + */ + return 0; + } + + return ioerr(db), -1; } /* @@ -287,28 +287,28 @@ sdbm_store(DBM *db, datum key, datum val, int flags) static int makroom(DBM *db, long int hash, int need) { - long newp; - char twin[PBLKSIZ]; + long newp; + char twin[PBLKSIZ]; #if defined(DOSISH) || defined(WIN32) - char zer[PBLKSIZ]; - long oldtail; + char zer[PBLKSIZ]; + long oldtail; #endif - char *pag = db->pagbuf; - char *New = twin; - int smax = SPLTMAX; + char *pag = db->pagbuf; + char *New = twin; + int smax = SPLTMAX; #ifdef BADMESS - int rc; + int rc; #endif - do { + do { /* * split the current page */ - (void) splpage(pag, New, db->hmask + 1); + (void) splpage(pag, New, db->hmask + 1); /* * address of the new page */ - newp = (hash & db->hmask) | (db->hmask + 1); + newp = (hash & db->hmask) | (db->hmask + 1); /* * write delay, read avoidance/cache shuffle: @@ -320,65 +320,65 @@ makroom(DBM *db, long int hash, int need) */ #if defined(DOSISH) || defined(WIN32) - /* - * Fill hole with 0 if made it. - * (hole is NOT read as 0) - */ - oldtail = lseek(db->pagf, 0L, SEEK_END); - memset(zer, 0, PBLKSIZ); - while (OFF_PAG(newp) > oldtail) { - if (lseek(db->pagf, 0L, SEEK_END) < 0 || - write(db->pagf, zer, PBLKSIZ) < 0) { - - return 0; - } - oldtail += PBLKSIZ; - } + /* + * Fill hole with 0 if made it. + * (hole is NOT read as 0) + */ + oldtail = lseek(db->pagf, 0L, SEEK_END); + memset(zer, 0, PBLKSIZ); + while (OFF_PAG(newp) > oldtail) { + if (lseek(db->pagf, 0L, SEEK_END) < 0 || + write(db->pagf, zer, PBLKSIZ) < 0) { + + return 0; + } + oldtail += PBLKSIZ; + } #endif - if (hash & (db->hmask + 1)) { - if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 - || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) - return 0; - db->pagbno = newp; - (void) memcpy(pag, New, PBLKSIZ); - } - else if (lseek(db->pagf, OFF_PAG(newp), SEEK_SET) < 0 - || write(db->pagf, New, PBLKSIZ) < 0) - return 0; - - if (!setdbit(db, db->curbit)) - return 0; + if (hash & (db->hmask + 1)) { + if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 + || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) + return 0; + db->pagbno = newp; + (void) memcpy(pag, New, PBLKSIZ); + } + else if (lseek(db->pagf, OFF_PAG(newp), SEEK_SET) < 0 + || write(db->pagf, New, PBLKSIZ) < 0) + return 0; + + if (!setdbit(db, db->curbit)) + return 0; /* * see if we have enough room now */ - if (fitpair(pag, need)) - return 1; + if (fitpair(pag, need)) + return 1; /* * try again... update curbit and hmask as getpage would have * done. because of our update of the current page, we do not * need to read in anything. BUT we have to write the current * [deferred] page out, as the window of failure is too great. */ - db->curbit = 2 * db->curbit + - ((hash & (db->hmask + 1)) ? 2 : 1); - db->hmask |= db->hmask + 1; + db->curbit = 2 * db->curbit + + ((hash & (db->hmask + 1)) ? 2 : 1); + db->hmask |= db->hmask + 1; - if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 - || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) - return 0; + if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 + || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) + return 0; - } while (--smax); + } while (--smax); /* * if we are here, this is real bad news. After SPLTMAX splits, * we still cannot fit the key. say goodnight. */ #ifdef BADMESS - rc = write(2, "sdbm: cannot insert after SPLTMAX attempts.\n", 44); - /* PERL_UNUSED_VAR() or PERL_UNUSED_RESULT() would be - * useful here but that would mean pulling in perl.h */ - (void)rc; + rc = write(2, "sdbm: cannot insert after SPLTMAX attempts.\n", 44); + /* PERL_UNUSED_VAR() or PERL_UNUSED_RESULT() would be + * useful here but that would mean pulling in perl.h */ + (void)rc; #endif - return 0; + return 0; } @@ -389,33 +389,33 @@ makroom(DBM *db, long int hash, int need) datum sdbm_firstkey(DBM *db) { - if (db == NULL) - return errno = EINVAL, nullitem; + if (db == NULL) + return errno = EINVAL, nullitem; /* * start at page 0 */ - if (lseek(db->pagf, OFF_PAG(0), SEEK_SET) < 0 - || read(db->pagf, db->pagbuf, PBLKSIZ) < 0) - return ioerr(db), nullitem; + if (lseek(db->pagf, OFF_PAG(0), SEEK_SET) < 0 + || read(db->pagf, db->pagbuf, PBLKSIZ) < 0) + return ioerr(db), nullitem; if (!chkpage(db->pagbuf)) { errno = EINVAL; ioerr(db); db->pagbno = -1; return nullitem; } - db->pagbno = 0; - db->blkptr = 0; - db->keyptr = 0; + db->pagbno = 0; + db->blkptr = 0; + db->keyptr = 0; - return getnext(db); + return getnext(db); } datum sdbm_nextkey(DBM *db) { - if (db == NULL) - return errno = EINVAL, nullitem; - return getnext(db); + if (db == NULL) + return errno = EINVAL, nullitem; + return getnext(db); } /* @@ -424,106 +424,106 @@ sdbm_nextkey(DBM *db) static int getpage(DBM *db, long int hash) { - int hbit; - long dbit; - long pagb; + int hbit; + long dbit; + long pagb; - dbit = 0; - hbit = 0; - while (dbit < db->maxbno && getdbit(db, dbit)) - dbit = 2 * dbit + ((hash & (1 << hbit++)) ? 2 : 1); + dbit = 0; + hbit = 0; + while (dbit < db->maxbno && getdbit(db, dbit)) + dbit = 2 * dbit + ((hash & (1 << hbit++)) ? 2 : 1); - debug(("dbit: %d...", dbit)); + debug(("dbit: %d...", dbit)); - db->curbit = dbit; - db->hmask = masks[hbit]; + db->curbit = dbit; + db->hmask = masks[hbit]; - pagb = hash & db->hmask; + pagb = hash & db->hmask; /* * see if the block we need is already in memory. * note: this lookaside cache has about 10% hit rate. */ - if (pagb != db->pagbno) { + if (pagb != db->pagbno) { /* * note: here, we assume a "hole" is read as 0s. * if not, must zero pagbuf first. */ - if (lseek(db->pagf, OFF_PAG(pagb), SEEK_SET) < 0 - || read(db->pagf, db->pagbuf, PBLKSIZ) < 0) - return 0; - if (!chkpage(db->pagbuf)) { + if (lseek(db->pagf, OFF_PAG(pagb), SEEK_SET) < 0 + || read(db->pagf, db->pagbuf, PBLKSIZ) < 0) + return 0; + if (!chkpage(db->pagbuf)) { errno = EINVAL; db->pagbno = -1; ioerr(db); return 0; } - db->pagbno = pagb; + db->pagbno = pagb; - debug(("pag read: %d\n", pagb)); - } - return 1; + debug(("pag read: %d\n", pagb)); + } + return 1; } static int getdbit(DBM *db, long int dbit) { - long c; - long dirb; - - c = dbit / BYTESIZ; - dirb = c / DBLKSIZ; - - if (dirb != db->dirbno) { - int got; - if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 - || (got=read(db->dirf, db->dirbuf, DBLKSIZ)) < 0) - return 0; - if (got==0) - memset(db->dirbuf,0,DBLKSIZ); - db->dirbno = dirb; - - debug(("dir read: %d\n", dirb)); - } + long c; + long dirb; + + c = dbit / BYTESIZ; + dirb = c / DBLKSIZ; + + if (dirb != db->dirbno) { + int got; + if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 + || (got=read(db->dirf, db->dirbuf, DBLKSIZ)) < 0) + return 0; + if (got==0) + memset(db->dirbuf,0,DBLKSIZ); + db->dirbno = dirb; + + debug(("dir read: %d\n", dirb)); + } - return db->dirbuf[c % DBLKSIZ] & (1 << dbit % BYTESIZ); + return db->dirbuf[c % DBLKSIZ] & (1 << dbit % BYTESIZ); } static int setdbit(DBM *db, long int dbit) { - long c; - long dirb; - - c = dbit / BYTESIZ; - dirb = c / DBLKSIZ; - - if (dirb != db->dirbno) { - int got; - if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 - || (got=read(db->dirf, db->dirbuf, DBLKSIZ)) < 0) - return 0; - if (got==0) - memset(db->dirbuf,0,DBLKSIZ); - db->dirbno = dirb; - - debug(("dir read: %d\n", dirb)); - } + long c; + long dirb; + + c = dbit / BYTESIZ; + dirb = c / DBLKSIZ; + + if (dirb != db->dirbno) { + int got; + if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 + || (got=read(db->dirf, db->dirbuf, DBLKSIZ)) < 0) + return 0; + if (got==0) + memset(db->dirbuf,0,DBLKSIZ); + db->dirbno = dirb; + + debug(("dir read: %d\n", dirb)); + } - db->dirbuf[c % DBLKSIZ] |= (1 << dbit % BYTESIZ); + db->dirbuf[c % DBLKSIZ] |= (1 << dbit % BYTESIZ); #if 0 - if (dbit >= db->maxbno) - db->maxbno += DBLKSIZ * BYTESIZ; + if (dbit >= db->maxbno) + db->maxbno += DBLKSIZ * BYTESIZ; #else - if (OFF_DIR((dirb+1))*BYTESIZ > db->maxbno) - db->maxbno=OFF_DIR((dirb+1))*BYTESIZ; + if (OFF_DIR((dirb+1))*BYTESIZ > db->maxbno) + db->maxbno=OFF_DIR((dirb+1))*BYTESIZ; #endif - if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 - || write(db->dirf, db->dirbuf, DBLKSIZ) < 0) - return 0; + if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 + || write(db->dirf, db->dirbuf, DBLKSIZ) < 0) + return 0; - return 1; + return 1; } /* @@ -533,33 +533,33 @@ setdbit(DBM *db, long int dbit) static datum getnext(DBM *db) { - datum key; + datum key; - for (;;) { - db->keyptr++; - key = getnkey(db->pagbuf, db->keyptr); - if (key.dptr != NULL) - return key; + for (;;) { + db->keyptr++; + key = getnkey(db->pagbuf, db->keyptr); + if (key.dptr != NULL) + return key; /* * we either run out, or there is nothing on this page.. * try the next one... If we lost our position on the * file, we will have to seek. */ - db->keyptr = 0; - if (db->pagbno != db->blkptr++) - if (lseek(db->pagf, OFF_PAG(db->blkptr), SEEK_SET) < 0) - break; - db->pagbno = db->blkptr; - if (read(db->pagf, db->pagbuf, PBLKSIZ) <= 0) - break; - if (!chkpage(db->pagbuf)) { + db->keyptr = 0; + if (db->pagbno != db->blkptr++) + if (lseek(db->pagf, OFF_PAG(db->blkptr), SEEK_SET) < 0) + break; + db->pagbno = db->blkptr; + if (read(db->pagf, db->pagbuf, PBLKSIZ) <= 0) + break; + if (!chkpage(db->pagbuf)) { errno = EINVAL; db->pagbno = -1; ioerr(db); break; } - } + } - return ioerr(db), nullitem; + return ioerr(db), nullitem; } diff --git a/ext/SDBM_File/sdbm.h b/ext/SDBM_File/sdbm.h index 428303d30721..199a2eec0c22 100644 --- a/ext/SDBM_File/sdbm.h +++ b/ext/SDBM_File/sdbm.h @@ -11,7 +11,7 @@ #define PBLKSIZ 1024 #define PAIRMAX 1008 /* arbitrary on PBLKSIZ-N */ #define SPLTMAX 10 /* maximum allowed splits */ - /* for a single insertion */ + /* for a single insertion */ #ifdef VMS #define DIRFEXT ".sdbm_dir" #else @@ -20,19 +20,19 @@ #define PAGFEXT ".pag" typedef struct { - int dirf; /* directory file descriptor */ - int pagf; /* page file descriptor */ - int flags; /* status/error flags, see below */ - long maxbno; /* size of dirfile in bits */ - long curbit; /* current bit number */ - long hmask; /* current hash mask */ - long blkptr; /* current block for nextkey */ - int keyptr; /* current key for nextkey */ - long blkno; /* current page to read/write */ - long pagbno; /* current page in pagbuf */ - char pagbuf[PBLKSIZ]; /* page file block buffer */ - long dirbno; /* current block in dirbuf */ - char dirbuf[DBLKSIZ]; /* directory file block buffer */ + int dirf; /* directory file descriptor */ + int pagf; /* page file descriptor */ + int flags; /* status/error flags, see below */ + long maxbno; /* size of dirfile in bits */ + long curbit; /* current bit number */ + long hmask; /* current hash mask */ + long blkptr; /* current block for nextkey */ + int keyptr; /* current key for nextkey */ + long blkno; /* current page to read/write */ + long pagbno; /* current page in pagbuf */ + char pagbuf[PBLKSIZ]; /* page file block buffer */ + long dirbno; /* current block in dirbuf */ + char dirbuf[DBLKSIZ]; /* directory file block buffer */ } DBM; #define DBM_RDONLY 0x1 /* data base open read-only */ @@ -50,8 +50,8 @@ typedef struct { #define sdbm_pagfno(db) ((db)->pagf) typedef struct { - const char *dptr; - int dsize; + const char *dptr; + int dsize; } datum; extern const datum nullitem; diff --git a/ext/SDBM_File/tune.h b/ext/SDBM_File/tune.h index b95c8c8634ae..c4b36a058040 100644 --- a/ext/SDBM_File/tune.h +++ b/ext/SDBM_File/tune.h @@ -12,7 +12,7 @@ #define SEEDUPS /* always detect duplicates */ #define BADMESS /* generate a message for worst case: - cannot make room after SPLTMAX splits */ + cannot make room after SPLTMAX splits */ /* * misc */ diff --git a/ext/SDBM_File/util.c b/ext/SDBM_File/util.c index a58085d559ae..0fa93ef34134 100644 --- a/ext/SDBM_File/util.c +++ b/ext/SDBM_File/util.c @@ -8,40 +8,40 @@ void oops(char *s1, char *s2) { - extern int errno, sys_nerr; - extern char *sys_errlist[]; - extern char *progname; + extern int errno, sys_nerr; + extern char *sys_errlist[]; + extern char *progname; - if (progname) - fprintf(stderr, "%s: ", progname); - fprintf(stderr, s1, s2); - if (errno > 0 && errno < sys_nerr) - fprintf(stderr, " (%s)", sys_errlist[errno]); - fprintf(stderr, "\n"); - exit(1); + if (progname) + fprintf(stderr, "%s: ", progname); + fprintf(stderr, s1, s2); + if (errno > 0 && errno < sys_nerr) + fprintf(stderr, " (%s)", sys_errlist[errno]); + fprintf(stderr, "\n"); + exit(1); } int okpage(char *pag) { - unsigned n; - int off; - short *ino = (short *) pag; + unsigned n; + int off; + short *ino = (short *) pag; - if ((n = ino[0]) > PBLKSIZ / sizeof(short)) - return 0; + if ((n = ino[0]) > PBLKSIZ / sizeof(short)) + return 0; - if (!n) - return 1; + if (!n) + return 1; - off = PBLKSIZ; - for (ino++; n; ino += 2) { - if (ino[0] > off || ino[1] > off || - ino[1] > ino[0]) - return 0; - off = ino[1]; - n -= 2; - } + off = PBLKSIZ; + for (ino++; n; ino += 2) { + if (ino[0] > off || ino[1] > off || + ino[1] > ino[0]) + return 0; + off = ino[1]; + n -= 2; + } - return 1; + return 1; } diff --git a/ext/VMS-DCLsym/.gitignore b/ext/VMS-DCLsym/.gitignore new file mode 100644 index 000000000000..e54624d60d99 --- /dev/null +++ b/ext/VMS-DCLsym/.gitignore @@ -0,0 +1 @@ +!/Makefile.PL diff --git a/ext/VMS-Stdio/.gitignore b/ext/VMS-Stdio/.gitignore new file mode 100644 index 000000000000..e54624d60d99 --- /dev/null +++ b/ext/VMS-Stdio/.gitignore @@ -0,0 +1 @@ +!/Makefile.PL diff --git a/ext/Win32CORE/.gitignore b/ext/Win32CORE/.gitignore index cbe3f3d56d21..7148fe97b5d9 100644 --- a/ext/Win32CORE/.gitignore +++ b/ext/Win32CORE/.gitignore @@ -1 +1,2 @@ !/Win32CORE.c +!/Makefile.PL diff --git a/ext/Win32CORE/Win32CORE.c b/ext/Win32CORE/Win32CORE.c index 6e5e1cec013d..6784e460feeb 100644 --- a/ext/Win32CORE/Win32CORE.c +++ b/ext/Win32CORE/Win32CORE.c @@ -64,78 +64,78 @@ init_Win32CORE(pTHX) */ static const struct { - char Win32__GetCwd [sizeof("Win32::GetCwd")]; - char Win32__SetCwd [sizeof("Win32::SetCwd")]; - char Win32__GetNextAvailDrive [sizeof("Win32::GetNextAvailDrive")]; - char Win32__GetLastError [sizeof("Win32::GetLastError")]; - char Win32__SetLastError [sizeof("Win32::SetLastError")]; - char Win32__LoginName [sizeof("Win32::LoginName")]; - char Win32__NodeName [sizeof("Win32::NodeName")]; - char Win32__DomainName [sizeof("Win32::DomainName")]; - char Win32__FsType [sizeof("Win32::FsType")]; - char Win32__GetOSVersion [sizeof("Win32::GetOSVersion")]; - char Win32__IsWinNT [sizeof("Win32::IsWinNT")]; - char Win32__IsWin95 [sizeof("Win32::IsWin95")]; - char Win32__FormatMessage [sizeof("Win32::FormatMessage")]; - char Win32__Spawn [sizeof("Win32::Spawn")]; - char Win32__GetTickCount [sizeof("Win32::GetTickCount")]; - char Win32__GetShortPathName [sizeof("Win32::GetShortPathName")]; - char Win32__GetFullPathName [sizeof("Win32::GetFullPathName")]; - char Win32__GetLongPathName [sizeof("Win32::GetLongPathName")]; - char Win32__CopyFile [sizeof("Win32::CopyFile")]; - char Win32__Sleep [sizeof("Win32::Sleep")]; + char Win32__GetCwd [sizeof("Win32::GetCwd")]; + char Win32__SetCwd [sizeof("Win32::SetCwd")]; + char Win32__GetNextAvailDrive [sizeof("Win32::GetNextAvailDrive")]; + char Win32__GetLastError [sizeof("Win32::GetLastError")]; + char Win32__SetLastError [sizeof("Win32::SetLastError")]; + char Win32__LoginName [sizeof("Win32::LoginName")]; + char Win32__NodeName [sizeof("Win32::NodeName")]; + char Win32__DomainName [sizeof("Win32::DomainName")]; + char Win32__FsType [sizeof("Win32::FsType")]; + char Win32__GetOSVersion [sizeof("Win32::GetOSVersion")]; + char Win32__IsWinNT [sizeof("Win32::IsWinNT")]; + char Win32__IsWin95 [sizeof("Win32::IsWin95")]; + char Win32__FormatMessage [sizeof("Win32::FormatMessage")]; + char Win32__Spawn [sizeof("Win32::Spawn")]; + char Win32__GetTickCount [sizeof("Win32::GetTickCount")]; + char Win32__GetShortPathName [sizeof("Win32::GetShortPathName")]; + char Win32__GetFullPathName [sizeof("Win32::GetFullPathName")]; + char Win32__GetLongPathName [sizeof("Win32::GetLongPathName")]; + char Win32__CopyFile [sizeof("Win32::CopyFile")]; + char Win32__Sleep [sizeof("Win32::Sleep")]; } fnname_table = { - "Win32::GetCwd", - "Win32::SetCwd", - "Win32::GetNextAvailDrive", - "Win32::GetLastError", - "Win32::SetLastError", - "Win32::LoginName", - "Win32::NodeName", - "Win32::DomainName", - "Win32::FsType", - "Win32::GetOSVersion", - "Win32::IsWinNT", - "Win32::IsWin95", - "Win32::FormatMessage", - "Win32::Spawn", - "Win32::GetTickCount", - "Win32::GetShortPathName", - "Win32::GetFullPathName", - "Win32::GetLongPathName", - "Win32::CopyFile", - "Win32::Sleep" + "Win32::GetCwd", + "Win32::SetCwd", + "Win32::GetNextAvailDrive", + "Win32::GetLastError", + "Win32::SetLastError", + "Win32::LoginName", + "Win32::NodeName", + "Win32::DomainName", + "Win32::FsType", + "Win32::GetOSVersion", + "Win32::IsWinNT", + "Win32::IsWin95", + "Win32::FormatMessage", + "Win32::Spawn", + "Win32::GetTickCount", + "Win32::GetShortPathName", + "Win32::GetFullPathName", + "Win32::GetLongPathName", + "Win32::CopyFile", + "Win32::Sleep" }; static const unsigned char fnname_lens [] = { - sizeof("Win32::GetCwd"), - sizeof("Win32::SetCwd"), - sizeof("Win32::GetNextAvailDrive"), - sizeof("Win32::GetLastError"), - sizeof("Win32::SetLastError"), - sizeof("Win32::LoginName"), - sizeof("Win32::NodeName"), - sizeof("Win32::DomainName"), - sizeof("Win32::FsType"), - sizeof("Win32::GetOSVersion"), - sizeof("Win32::IsWinNT"), - sizeof("Win32::IsWin95"), - sizeof("Win32::FormatMessage"), - sizeof("Win32::Spawn"), - sizeof("Win32::GetTickCount"), - sizeof("Win32::GetShortPathName"), - sizeof("Win32::GetFullPathName"), - sizeof("Win32::GetLongPathName"), - sizeof("Win32::CopyFile"), - sizeof("Win32::Sleep") + sizeof("Win32::GetCwd"), + sizeof("Win32::SetCwd"), + sizeof("Win32::GetNextAvailDrive"), + sizeof("Win32::GetLastError"), + sizeof("Win32::SetLastError"), + sizeof("Win32::LoginName"), + sizeof("Win32::NodeName"), + sizeof("Win32::DomainName"), + sizeof("Win32::FsType"), + sizeof("Win32::GetOSVersion"), + sizeof("Win32::IsWinNT"), + sizeof("Win32::IsWin95"), + sizeof("Win32::FormatMessage"), + sizeof("Win32::Spawn"), + sizeof("Win32::GetTickCount"), + sizeof("Win32::GetShortPathName"), + sizeof("Win32::GetFullPathName"), + sizeof("Win32::GetLongPathName"), + sizeof("Win32::CopyFile"), + sizeof("Win32::Sleep") }; const unsigned char * len = (const unsigned char *)&fnname_lens; const char * function = (char *)&fnname_table; while (function < (char *)&fnname_table + sizeof(fnname_table)) { - const char * const file = __FILE__; - CV * const cv = newXS(function, w32_CORE_all, file); - XSANY.any_ptr = (void *)function; - function += *len++; + const char * const file = __FILE__; + CV * const cv = newXS(function, w32_CORE_all, file); + XSANY.any_ptr = (void *)function; + function += *len++; } diff --git a/ext/XS-APItest/.gitignore b/ext/XS-APItest/.gitignore index 7ba0a5a28994..9bc400b68cc1 100644 --- a/ext/XS-APItest/.gitignore +++ b/ext/XS-APItest/.gitignore @@ -1 +1,6 @@ const-*.inc +/APItest.bso +!/Makefile.PL +!/core.c +!/exception.c +!/notcore.c diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm index fc4745044597..9ee0f7125853 100644 --- a/ext/XS-APItest/APItest.pm +++ b/ext/XS-APItest/APItest.pm @@ -5,7 +5,7 @@ use strict; use warnings; use Carp; -our $VERSION = '1.13'; +our $VERSION = '1.15'; require XSLoader; diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 549bf54afd08..c4f7d4462593 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -6853,10 +6853,21 @@ test_Gconvert(SV * number, SV * num_digits) PREINIT: char buffer[100]; int len; + int extras; CODE: len = (int) SvIV(num_digits); - if (len > 99) croak("Too long a number for test_Gconvert"); - if (len < 0) croak("Too short a number for test_Gconvert"); + /* To silence a -Wformat-overflow compiler warning we * + * make allowance for the following characters that may * + * appear, in addition to the digits of the significand: * + * a leading "-", a single byte radix point, "e-", the * + * terminating NULL, and a 3 or 4 digit exponent. * + * Ie, allow 8 bytes if nvtype is "double", otherwise 9 * + * bytes (as the exponent could then contain 4 digits ). */ + extras = sizeof(NV) == 8 ? 8 : 9; + if(len > 100 - extras) + croak("Too long a number for test_Gconvert"); + if (len < 0) + croak("Too short a number for test_Gconvert"); PERL_UNUSED_RESULT(Gconvert(SvNV(number), len, 0, /* No trailing zeroes */ buffer)); @@ -6936,6 +6947,31 @@ Comctl32Version() #endif +MODULE = XS::APItest PACKAGE = XS::APItest::RWMacro + +#if defined(USE_ITHREADS) + +void +compile_macros() + PREINIT: + perl_RnW1_mutex_t m; + perl_RnW1_mutex_t *pm = &m; + CODE: + PERL_RW_MUTEX_INIT(&m); + PERL_WRITE_LOCK(&m); + PERL_WRITE_UNLOCK(&m); + PERL_READ_LOCK(&m); + PERL_READ_UNLOCK(&m); + PERL_RW_MUTEX_DESTROY(&m); + PERL_RW_MUTEX_INIT(pm); + PERL_WRITE_LOCK(pm); + PERL_WRITE_UNLOCK(pm); + PERL_READ_LOCK(pm); + PERL_READ_UNLOCK(pm); + PERL_RW_MUTEX_DESTROY(pm); + +#endif + MODULE = XS::APItest PACKAGE = XS::APItest::HvMacro diff --git a/ext/XS-Typemap/.gitignore b/ext/XS-Typemap/.gitignore new file mode 100644 index 000000000000..3fb2f0ee2d7d --- /dev/null +++ b/ext/XS-Typemap/.gitignore @@ -0,0 +1,2 @@ +!/Makefile.PL +!/stdio.c diff --git a/ext/re/.gitignore b/ext/re/.gitignore new file mode 100644 index 000000000000..f63246b01f75 --- /dev/null +++ b/ext/re/.gitignore @@ -0,0 +1,2 @@ +!/Makefile.PL +/invlist_inline.h diff --git a/feature.h b/feature.h index 20f799696ae6..501bc3a3b180 100644 --- a/feature.h +++ b/feature.h @@ -12,22 +12,24 @@ #define HINT_FEATURE_SHIFT 26 -#define FEATURE_BITWISE_BIT 0x0001 -#define FEATURE___SUB___BIT 0x0002 -#define FEATURE_MYREF_BIT 0x0004 -#define FEATURE_EVALBYTES_BIT 0x0008 -#define FEATURE_FC_BIT 0x0010 -#define FEATURE_INDIRECT_BIT 0x0020 -#define FEATURE_ISA_BIT 0x0040 -#define FEATURE_MULTIDIMENSIONAL_BIT 0x0080 -#define FEATURE_POSTDEREF_QQ_BIT 0x0100 -#define FEATURE_REFALIASING_BIT 0x0200 -#define FEATURE_SAY_BIT 0x0400 -#define FEATURE_SIGNATURES_BIT 0x0800 -#define FEATURE_STATE_BIT 0x1000 -#define FEATURE_SWITCH_BIT 0x2000 -#define FEATURE_UNIEVAL_BIT 0x4000 -#define FEATURE_UNICODE_BIT 0x8000 +#define FEATURE_BAREWORD_FILEHANDLES_BIT 0x0001 +#define FEATURE_BITWISE_BIT 0x0002 +#define FEATURE___SUB___BIT 0x0004 +#define FEATURE_MYREF_BIT 0x0008 +#define FEATURE_EVALBYTES_BIT 0x0010 +#define FEATURE_FC_BIT 0x0020 +#define FEATURE_INDIRECT_BIT 0x0040 +#define FEATURE_ISA_BIT 0x0080 +#define FEATURE_MULTIDIMENSIONAL_BIT 0x0100 +#define FEATURE_POSTDEREF_QQ_BIT 0x0200 +#define FEATURE_REFALIASING_BIT 0x0400 +#define FEATURE_SAY_BIT 0x0800 +#define FEATURE_SIGNATURES_BIT 0x1000 +#define FEATURE_STATE_BIT 0x2000 +#define FEATURE_SWITCH_BIT 0x4000 +#define FEATURE_TRY_BIT 0x8000 +#define FEATURE_UNIEVAL_BIT 0x10000 +#define FEATURE_UNICODE_BIT 0x20000 #define FEATURE_BUNDLE_DEFAULT 0 #define FEATURE_BUNDLE_510 1 @@ -47,7 +49,7 @@ ? (PL_curcop->cop_features & (mask)) : FALSE) /* The longest string we pass in. */ -#define MAX_FEATURE_LEN (sizeof("multidimensional")-1) +#define MAX_FEATURE_LEN (sizeof("bareword_filehandles")-1) #define FEATURE_FC_IS_ENABLED \ ( \ @@ -71,6 +73,12 @@ FEATURE_IS_ENABLED_MASK(FEATURE_SAY_BIT)) \ ) +#define FEATURE_TRY_IS_ENABLED \ + ( \ + CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \ + FEATURE_IS_ENABLED_MASK(FEATURE_TRY_BIT) \ + ) + #define FEATURE_STATE_IS_ENABLED \ ( \ (CURRENT_FEATURE_BUNDLE >= FEATURE_BUNDLE_510 && \ @@ -166,6 +174,13 @@ FEATURE_IS_ENABLED_MASK(FEATURE_MULTIDIMENSIONAL_BIT)) \ ) +#define FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED \ + ( \ + CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_527 \ + || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \ + FEATURE_IS_ENABLED_MASK(FEATURE_BAREWORD_FILEHANDLES_BIT)) \ + ) + #define SAVEFEATUREBITS() SAVEI32(PL_compiling.cop_features) @@ -236,7 +251,12 @@ S_magic_sethint_feature(pTHX_ SV *keysv, const char *keypv, STRLEN keylen, return; case 'b': - if (keylen == sizeof("feature_bitwise")-1 + if (keylen == sizeof("feature_bareword_filehandles")-1 + && memcmp(subf+1, "areword_filehandles", keylen - sizeof("feature_")) == 0) { + mask = FEATURE_BAREWORD_FILEHANDLES_BIT; + break; + } + else if (keylen == sizeof("feature_bitwise")-1 && memcmp(subf+1, "itwise", keylen - sizeof("feature_")) == 0) { mask = FEATURE_BITWISE_BIT; break; @@ -324,6 +344,14 @@ S_magic_sethint_feature(pTHX_ SV *keysv, const char *keypv, STRLEN keylen, } return; + case 't': + if (keylen == sizeof("feature_try")-1 + && memcmp(subf+1, "ry", keylen - sizeof("feature_")) == 0) { + mask = FEATURE_TRY_BIT; + break; + } + return; + case 'u': if (keylen == sizeof("feature_unicode")-1 && memcmp(subf+1, "nicode", keylen - sizeof("feature_")) == 0) { diff --git a/generate_uudmap.c b/generate_uudmap.c index 5ab7d8197f16..b5f84a76959f 100644 --- a/generate_uudmap.c +++ b/generate_uudmap.c @@ -71,13 +71,13 @@ format_mg_data(FILE *out, const void *thing, size_t count) { while (1) { if (p->value) { - fprintf(out, " %s\n %s", p->comment, p->value); + fprintf(out, " %s\n %s", p->comment, p->value); } else { - fputs(" 0", out); + fputs(" 0", out); } ++p; if (!--count) - break; + break; fputs(",\n", out); } fputc('\n', out); @@ -94,7 +94,7 @@ format_char_block(FILE *out, const void *thing, size_t count) { if (count) { fputs(", ", out); if (!(count & 15)) { - fputs("\n ", out); + fputs("\n ", out); } } } @@ -103,15 +103,15 @@ format_char_block(FILE *out, const void *thing, size_t count) { static void output_to_file(const char *progname, const char *filename, - void (format_function)(FILE *out, const void *thing, size_t count), - const void *thing, size_t count, + void (format_function)(FILE *out, const void *thing, size_t count), + const void *thing, size_t count, const char *header ) { FILE *const out = fopen(filename, "w"); if (!out) { fprintf(stderr, "%s: Could not open '%s': %s\n", progname, filename, - strerror(errno)); + strerror(errno)); exit(1); } @@ -124,7 +124,7 @@ output_to_file(const char *progname, const char *filename, if (fclose(out)) { fprintf(stderr, "%s: Could not close '%s': %s\n", progname, filename, - strerror(errno)); + strerror(errno)); exit(1); } } @@ -159,7 +159,7 @@ int main(int argc, char **argv) { PL_uudmap[(U8)' '] = 0; output_to_file(argv[0], argv[1], &format_char_block, - (const void *)PL_uudmap, sizeof(PL_uudmap), + (const void *)PL_uudmap, sizeof(PL_uudmap), " * These values will populate PL_uumap[], as used by unpack('u')" ); @@ -175,7 +175,7 @@ int main(int argc, char **argv) { } output_to_file(argv[0], argv[2], &format_char_block, - (const void *)PL_bitcount, sizeof(PL_bitcount), + (const void *)PL_bitcount, sizeof(PL_bitcount), " * These values will populate PL_bitcount[]:\n" " * this is a count of bits for each U8 value 0..255" ); @@ -187,7 +187,7 @@ int main(int argc, char **argv) { } output_to_file(argv[0], argv[3], &format_mg_data, - (const void *)mg_data, sizeof(mg_data)/sizeof(mg_data[0]), + (const void *)mg_data, sizeof(mg_data)/sizeof(mg_data[0]), " * These values will populate PL_magic_data[]: this is an array of\n" " * per-magic U8 values containing an index into PL_magic_vtables[]\n" " * plus two flags:\n" diff --git a/globals.c b/globals.c index 5439ba241a4b..045c71ca3fb9 100644 --- a/globals.c +++ b/globals.c @@ -15,7 +15,7 @@ */ /* This file exists to #include "perl.h" _ONCE_ with - * PERL_IN_GLOBALS_C defined. That causes various global varaiables + * PERL_IN_GLOBALS_C defined. That causes various global variables * in perl.h and other files it includes to be _defined_ (and initialized) * rather than just declared. */ diff --git a/gv.c b/gv.c index e849d0fe474c..0795b7966ded 100644 --- a/gv.c +++ b/gv.c @@ -55,43 +55,64 @@ Perl_gv_add_by_type(pTHX_ GV *gv, svtype type) && SvTYPE((const SV *)gv) != SVt_PVLV ) ) { - const char *what; - if (type == SVt_PVIO) { - /* - * if it walks like a dirhandle, then let's assume that - * this is a dirhandle. - */ - what = OP_IS_DIRHOP(PL_op->op_type) ? - "dirhandle" : "filehandle"; - } else if (type == SVt_PVHV) { - what = "hash"; - } else { - what = type == SVt_PVAV ? "array" : "scalar"; - } - /* diag_listed_as: Bad symbol for filehandle */ - Perl_croak(aTHX_ "Bad symbol for %s", what); + const char *what; + if (type == SVt_PVIO) { + /* + * if it walks like a dirhandle, then let's assume that + * this is a dirhandle. + */ + what = OP_IS_DIRHOP(PL_op->op_type) ? + "dirhandle" : "filehandle"; + } else if (type == SVt_PVHV) { + what = "hash"; + } else { + what = type == SVt_PVAV ? "array" : "scalar"; + } + /* diag_listed_as: Bad symbol for filehandle */ + Perl_croak(aTHX_ "Bad symbol for %s", what); } if (type == SVt_PVHV) { - where = (SV **)&GvHV(gv); + where = (SV **)&GvHV(gv); } else if (type == SVt_PVAV) { - where = (SV **)&GvAV(gv); + where = (SV **)&GvAV(gv); } else if (type == SVt_PVIO) { - where = (SV **)&GvIOp(gv); + where = (SV **)&GvIOp(gv); } else { - where = &GvSV(gv); + where = &GvSV(gv); } if (!*where) { - *where = newSV_type(type); - if (type == SVt_PVAV - && memEQs(GvNAME(gv), GvNAMELEN(gv), "ISA")) - sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0); + *where = newSV_type(type); + if (type == SVt_PVAV + && memEQs(GvNAME(gv), GvNAMELEN(gv), "ISA")) + sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0); } return gv; } +/* +=for apidoc gv_fetchfile +=for apidoc_item gv_fetchfile_flags + +These return the debugger glob for the file (compiled by Perl) whose name is +given by the C parameter. + +There are currently exactly two differences between these functions. + +The C parameter to C is a C string, meaning it is +C-terminated; whereas the C parameter to C is a +Perl string, whose length (in bytes) is passed in via the C parameter +This means the name may contain embedded C characters. +C doesn't exist in plain C). + +The other difference is that C has an extra C +parameter, which is currently completely ignored, but allows for possible +future extensions. + +=cut +*/ GV * Perl_gv_fetchfile(pTHX_ const char *name) { @@ -101,7 +122,7 @@ Perl_gv_fetchfile(pTHX_ const char *name) GV * Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen, - const U32 flags) + const U32 flags) { char smallbuf[128]; char *tmpbuf; @@ -112,29 +133,29 @@ Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen, PERL_UNUSED_ARG(flags); if (!PL_defstash) - return NULL; + return NULL; if (tmplen <= sizeof smallbuf) - tmpbuf = smallbuf; + tmpbuf = smallbuf; else - Newx(tmpbuf, tmplen, char); + Newx(tmpbuf, tmplen, char); /* This is where the debugger's %{"::_<$filename"} hash is created */ tmpbuf[0] = '_'; tmpbuf[1] = '<'; memcpy(tmpbuf + 2, name, namelen); gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE); if (!isGV(gv)) { - gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE); + gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE); #ifdef PERL_DONT_CREATE_GVSV - GvSV(gv) = newSVpvn(name, namelen); + GvSV(gv) = newSVpvn(name, namelen); #else - sv_setpvn(GvSV(gv), name, namelen); + sv_setpvn(GvSV(gv), name, namelen); #endif } if (PERLDB_LINE_OR_SAVESRC && !GvAV(gv)) - hv_magic(GvHVn(gv), GvAVn(gv), PERL_MAGIC_dbfile); + hv_magic(GvHVn(gv), GvAVn(gv), PERL_MAGIC_dbfile); if (tmpbuf != smallbuf) - Safefree(tmpbuf); + Safefree(tmpbuf); return gv; } @@ -156,7 +177,7 @@ Perl_gv_const_sv(pTHX_ GV *gv) PERL_UNUSED_CONTEXT; if (SvTYPE(gv) == SVt_PVGV) - return cv_const_sv(GvCVu(gv)); + return cv_const_sv(GvCVu(gv)); return SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVAV && SvTYPE(SvRV(gv)) != SVt_PVCV ? SvRV(gv) : NULL; } @@ -179,29 +200,29 @@ Perl_newGP(pTHX_ GV *const gv) #endif /* PL_curcop may be null here. E.g., - INIT { bless {} and exit } + INIT { bless {} and exit } frees INIT before looking up DESTROY (and creating *DESTROY) */ if (PL_curcop) { - gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */ + gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */ #ifdef USE_ITHREADS - if (CopFILE(PL_curcop)) { - file = CopFILE(PL_curcop); - len = strlen(file); - } + if (CopFILE(PL_curcop)) { + file = CopFILE(PL_curcop); + len = strlen(file); + } #else - filegv = CopFILEGV(PL_curcop); - if (filegv) { - file = GvNAME(filegv)+2; - len = GvNAMELEN(filegv)-2; - } + filegv = CopFILEGV(PL_curcop); + if (filegv) { + file = GvNAME(filegv)+2; + len = GvNAMELEN(filegv)-2; + } #endif - else goto no_file; + else goto no_file; } else { - no_file: - file = ""; - len = 0; + no_file: + file = ""; + len = 0; } PERL_HASH(hash, file, len); @@ -222,20 +243,20 @@ Perl_cvgv_set(pTHX_ CV* cv, GV* gv) PERL_ARGS_ASSERT_CVGV_SET; if (oldgv == gv) - return; + return; if (oldgv) { - if (CvCVGV_RC(cv)) { - SvREFCNT_dec_NN(oldgv); - CvCVGV_RC_off(cv); - } - else { - sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv)); - } + if (CvCVGV_RC(cv)) { + SvREFCNT_dec_NN(oldgv); + CvCVGV_RC_off(cv); + } + else { + sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv)); + } } else if ((hek = CvNAME_HEK(cv))) { - unshare_hek(hek); - CvLEXICAL_off(cv); + unshare_hek(hek); + CvLEXICAL_off(cv); } CvNAMED_off(cv); @@ -243,13 +264,13 @@ Perl_cvgv_set(pTHX_ CV* cv, GV* gv) assert(!CvCVGV_RC(cv)); if (!gv) - return; + return; if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv)) - Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv)); + Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv)); else { - CvCVGV_RC_on(cv); - SvREFCNT_inc_simple_void_NN(gv); + CvCVGV_RC_on(cv); + SvREFCNT_inc_simple_void_NN(gv); } } @@ -269,12 +290,12 @@ Perl_cvgv_from_hek(pTHX_ CV *cv) svp = hv_fetchhek(CvSTASH(cv), CvNAME_HEK(cv), 0); gv = MUTABLE_GV(svp && *svp ? *svp : newSV(0)); if (!isGV(gv)) - gv_init_pvn(gv, CvSTASH(cv), HEK_KEY(CvNAME_HEK(cv)), - HEK_LEN(CvNAME_HEK(cv)), - SVf_UTF8 * !!HEK_UTF8(CvNAME_HEK(cv))); + gv_init_pvn(gv, CvSTASH(cv), HEK_KEY(CvNAME_HEK(cv)), + HEK_LEN(CvNAME_HEK(cv)), + SVf_UTF8 * !!HEK_UTF8(CvNAME_HEK(cv))); if (!CvNAMED(cv)) { /* gv_init took care of it */ - assert (SvANY(cv)->xcv_gv_u.xcv_gv == gv); - return gv; + assert (SvANY(cv)->xcv_gv_u.xcv_gv == gv); + return gv; } unshare_hek(CvNAME_HEK(cv)); CvNAMED_off(cv); @@ -292,12 +313,12 @@ Perl_cvstash_set(pTHX_ CV *cv, HV *st) HV *oldst = CvSTASH(cv); PERL_ARGS_ASSERT_CVSTASH_SET; if (oldst == st) - return; + return; if (oldst) - sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv)); + sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv)); SvANY(cv)->xcv_stash = st; if (st) - Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv)); + Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv)); } /* @@ -370,102 +391,102 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag const U32 old_type = SvTYPE(gv); const bool doproto = old_type > SVt_NULL; char * const proto = (doproto && SvPOK(gv)) - ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv)) - : NULL; + ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv)) + : NULL; const STRLEN protolen = proto ? SvCUR(gv) : 0; const U32 proto_utf8 = proto ? SvUTF8(gv) : 0; SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL; const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0; const bool really_sub = - has_constant && SvTYPE(has_constant) == SVt_PVCV; + has_constant && SvTYPE(has_constant) == SVt_PVCV; COP * const old = PL_curcop; PERL_ARGS_ASSERT_GV_INIT_PVN; assert (!(proto && has_constant)); if (has_constant) { - /* The constant has to be a scalar, array or subroutine. */ - switch (SvTYPE(has_constant)) { - case SVt_PVHV: - case SVt_PVFM: - case SVt_PVIO: + /* The constant has to be a scalar, array or subroutine. */ + switch (SvTYPE(has_constant)) { + case SVt_PVHV: + case SVt_PVFM: + case SVt_PVIO: Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob", - sv_reftype(has_constant, 0)); + sv_reftype(has_constant, 0)); NOT_REACHED; /* NOTREACHED */ break; - default: NOOP; - } - SvRV_set(gv, NULL); - SvROK_off(gv); + default: NOOP; + } + SvRV_set(gv, NULL); + SvROK_off(gv); } if (old_type < SVt_PVGV) { - if (old_type >= SVt_PV) - SvCUR_set(gv, 0); - sv_upgrade(MUTABLE_SV(gv), SVt_PVGV); + if (old_type >= SVt_PV) + SvCUR_set(gv, 0); + sv_upgrade(MUTABLE_SV(gv), SVt_PVGV); } if (SvLEN(gv)) { - if (proto) { - SvPV_set(gv, NULL); - SvLEN_set(gv, 0); - SvPOK_off(gv); - } else - Safefree(SvPVX_mutable(gv)); + if (proto) { + SvPV_set(gv, NULL); + SvLEN_set(gv, 0); + SvPOK_off(gv); + } else + Safefree(SvPVX_mutable(gv)); } SvIOK_off(gv); isGV_with_GP_on(gv); if (really_sub && !CvISXSUB(has_constant) && CvSTART(has_constant) && ( CvSTART(has_constant)->op_type == OP_NEXTSTATE - || CvSTART(has_constant)->op_type == OP_DBSTATE)) - PL_curcop = (COP *)CvSTART(has_constant); + || CvSTART(has_constant)->op_type == OP_DBSTATE)) + PL_curcop = (COP *)CvSTART(has_constant); GvGP_set(gv, Perl_newGP(aTHX_ gv)); PL_curcop = old; GvSTASH(gv) = stash; if (stash) - Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv)); + Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv)); gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 )); if (flags & GV_ADDMULTI || doproto) /* doproto means it */ - GvMULTI_on(gv); /* _was_ mentioned */ + GvMULTI_on(gv); /* _was_ mentioned */ if (really_sub) { - /* Not actually a constant. Just a regular sub. */ - CV * const cv = (CV *)has_constant; - GvCV_set(gv,cv); - if (CvNAMED(cv) && CvSTASH(cv) == stash && ( - CvNAME_HEK(cv) == GvNAME_HEK(gv) - || ( HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv)) - && HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv)) - && HEK_UTF8(CvNAME_HEK(cv)) == HEK_UTF8(GvNAME_HEK(gv)) - && memEQ(HEK_KEY(CvNAME_HEK(cv)), GvNAME(gv), GvNAMELEN(gv)) - ) - )) - CvGV_set(cv,gv); + /* Not actually a constant. Just a regular sub. */ + CV * const cv = (CV *)has_constant; + GvCV_set(gv,cv); + if (CvNAMED(cv) && CvSTASH(cv) == stash && ( + CvNAME_HEK(cv) == GvNAME_HEK(gv) + || ( HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv)) + && HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv)) + && HEK_UTF8(CvNAME_HEK(cv)) == HEK_UTF8(GvNAME_HEK(gv)) + && memEQ(HEK_KEY(CvNAME_HEK(cv)), GvNAME(gv), GvNAMELEN(gv)) + ) + )) + CvGV_set(cv,gv); } else if (doproto) { - CV *cv; - if (has_constant) { - /* newCONSTSUB takes ownership of the reference from us. */ - cv = newCONSTSUB_flags(stash, name, len, flags, has_constant); - /* In case op.c:S_process_special_blocks stole it: */ - if (!GvCV(gv)) - GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv)); - assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */ - /* If this reference was a copy of another, then the subroutine - must have been "imported", by a Perl space assignment to a GV - from a reference to CV. */ - if (exported_constant) - GvIMPORTED_CV_on(gv); - CvSTASH_set(cv, PL_curstash); /* XXX Why is this needed? */ - } else { - cv = newSTUB(gv,1); - } - if (proto) { - sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen, - SV_HAS_TRAILING_NUL); + CV *cv; + if (has_constant) { + /* newCONSTSUB takes ownership of the reference from us. */ + cv = newCONSTSUB_flags(stash, name, len, flags, has_constant); + /* In case op.c:S_process_special_blocks stole it: */ + if (!GvCV(gv)) + GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv)); + assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */ + /* If this reference was a copy of another, then the subroutine + must have been "imported", by a Perl space assignment to a GV + from a reference to CV. */ + if (exported_constant) + GvIMPORTED_CV_on(gv); + CvSTASH_set(cv, PL_curstash); /* XXX Why is this needed? */ + } else { + cv = newSTUB(gv,1); + } + if (proto) { + sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen, + SV_HAS_TRAILING_NUL); if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv)); - } + } } } @@ -476,26 +497,26 @@ S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type) switch (sv_type) { case SVt_PVIO: - (void)GvIOn(gv); - break; + (void)GvIOn(gv); + break; case SVt_PVAV: - (void)GvAVn(gv); - break; + (void)GvAVn(gv); + break; case SVt_PVHV: - (void)GvHVn(gv); - break; + (void)GvHVn(gv); + break; #ifdef PERL_DONT_CREATE_GVSV case SVt_NULL: case SVt_PVCV: case SVt_PVFM: case SVt_PVGV: - break; + break; default: - if(GvSVn(gv)) { - /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13 - If we just cast GvSVn(gv) to void, it ignores evaluating it for - its side effect */ - } + if(GvSVn(gv)) { + /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13 + If we just cast GvSVn(gv) to void, it ignores evaluating it for + its side effect */ + } #endif } } @@ -523,7 +544,7 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, /* no support for \&CORE::infix; no support for funcs that do not parse like funcs */ case KEY___DATA__: case KEY___END__: case KEY_and: case KEY_AUTOLOAD: - case KEY_BEGIN : case KEY_CHECK : case KEY_cmp: + case KEY_BEGIN : case KEY_CHECK : case KEY_catch : case KEY_cmp: case KEY_default : case KEY_DESTROY: case KEY_do : case KEY_dump : case KEY_else : case KEY_elsif : case KEY_END : case KEY_eq : case KEY_eval : @@ -538,10 +559,10 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, case KEY_qx : case KEY_redo : case KEY_require: case KEY_return: case KEY_s : case KEY_say : case KEY_sort : case KEY_state: case KEY_sub : - case KEY_tr : case KEY_UNITCHECK: case KEY_unless: + case KEY_tr : case KEY_try : case KEY_UNITCHECK: case KEY_unless: case KEY_until: case KEY_use : case KEY_when : case KEY_while : case KEY_x : case KEY_xor : case KEY_y : - return NULL; + return NULL; case KEY_chdir: case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete: case KEY_eof : case KEY_exec: case KEY_exists : @@ -550,33 +571,33 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, case KEY_stat: case KEY_system: case KEY_truncate: case KEY_unlink: - ampable = FALSE; + ampable = FALSE; } if (!gv) { - gv = (GV *)newSV(0); - gv_init(gv, stash, name, len, TRUE); + gv = (GV *)newSV(0); + gv_init(gv, stash, name, len, TRUE); } GvMULTI_on(gv); if (ampable) { - ENTER; - oldcurcop = PL_curcop; - oldparser = PL_parser; - lex_start(NULL, NULL, 0); - oldcompcv = PL_compcv; - PL_compcv = NULL; /* Prevent start_subparse from setting - CvOUTSIDE. */ - oldsavestack_ix = start_subparse(FALSE,0); - cv = PL_compcv; + ENTER; + oldcurcop = PL_curcop; + oldparser = PL_parser; + lex_start(NULL, NULL, 0); + oldcompcv = PL_compcv; + PL_compcv = NULL; /* Prevent start_subparse from setting + CvOUTSIDE. */ + oldsavestack_ix = start_subparse(FALSE,0); + cv = PL_compcv; } else { - /* Avoid calling newXS, as it calls us, and things start to - get hairy. */ - cv = MUTABLE_CV(newSV_type(SVt_PVCV)); - GvCV_set(gv,cv); - GvCVGEN(gv) = 0; - CvISXSUB_on(cv); - CvXSUB(cv) = core_xsub; - PoisonPADLIST(cv); + /* Avoid calling newXS, as it calls us, and things start to + get hairy. */ + cv = MUTABLE_CV(newSV_type(SVt_PVCV)); + GvCV_set(gv,cv); + GvCVGEN(gv) = 0; + CvISXSUB_on(cv); + CvXSUB(cv) = core_xsub; + PoisonPADLIST(cv); } CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE from PL_curcop. */ @@ -590,42 +611,42 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, new ATTRSUB. */ (void)core_prototype((SV *)cv, name, code, &opnum); if (stash) - (void)hv_store(stash,name,len,(SV *)gv,0); + (void)hv_store(stash,name,len,(SV *)gv,0); if (ampable) { #ifdef DEBUGGING CV *orig_cv = cv; #endif - CvLVALUE_on(cv); + CvLVALUE_on(cv); /* newATTRSUB will free the CV and return NULL if we're still compiling after a syntax error */ - if ((cv = newATTRSUB_x( - oldsavestack_ix, (OP *)gv, - NULL,NULL, - coresub_op( - opnum - ? newSVuv((UV)opnum) - : newSVpvn(name,len), - code, opnum - ), - TRUE + if ((cv = newATTRSUB_x( + oldsavestack_ix, (OP *)gv, + NULL,NULL, + coresub_op( + opnum + ? newSVuv((UV)opnum) + : newSVpvn(name,len), + code, opnum + ), + TRUE )) != NULL) { assert(GvCV(gv) == orig_cv); if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS && opnum != OP_UNDEF && opnum != OP_KEYS) CvLVALUE_off(cv); /* Now *that* was a neat trick. */ } - LEAVE; - PL_parser = oldparser; - PL_curcop = oldcurcop; - PL_compcv = oldcompcv; + LEAVE; + PL_parser = oldparser; + PL_curcop = oldcurcop; + PL_compcv = oldcompcv; } if (cv) { - SV *opnumsv = newSViv( - (opnum == OP_ENTEREVAL && len == 9 && memEQ(name, "evalbytes", 9)) ? - (OP_ENTEREVAL | (1<<16)) - : opnum ? opnum : (((I32)name[2]) << 16)); + SV *opnumsv = newSViv( + (opnum == OP_ENTEREVAL && len == 9 && memEQ(name, "evalbytes", 9)) ? + (OP_ENTEREVAL | (1<<16)) + : opnum ? opnum : (((I32)name[2]) << 16)); cv_set_call_checker_flags(cv, Perl_ck_entersub_args_core, opnumsv, 0); - SvREFCNT_dec_NN(opnumsv); + SvREFCNT_dec_NN(opnumsv); } return gv; @@ -725,9 +746,9 @@ S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, /* UNIVERSAL methods should be callable without a stash */ if (!stash) { - create = 0; /* probably appropriate */ - if(!(stash = gv_stashpvs("UNIVERSAL", 0))) - return 0; + create = 0; /* probably appropriate */ + if(!(stash = gv_stashpvs("UNIVERSAL", 0))) + return 0; } assert(stash); @@ -741,15 +762,15 @@ S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, assert(name || meth); DEBUG_o( Perl_deb(aTHX_ "Looking for %smethod %s in package %s\n", - flags & GV_SUPER ? "SUPER " : "", - name ? name : SvPV_nolen(meth), hvname) ); + flags & GV_SUPER ? "SUPER " : "", + name ? name : SvPV_nolen(meth), hvname) ); topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation; if (flags & GV_SUPER) { - if (!HvAUX(stash)->xhv_mro_meta->super) - HvAUX(stash)->xhv_mro_meta->super = newHV(); - cachestash = HvAUX(stash)->xhv_mro_meta->super; + if (!HvAUX(stash)->xhv_mro_meta->super) + HvAUX(stash)->xhv_mro_meta->super = newHV(); + cachestash = HvAUX(stash)->xhv_mro_meta->super; } else cachestash = stash; @@ -777,21 +798,21 @@ S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, } else { /* stale cache entry, junk it and move on */ - SvREFCNT_dec_NN(cand_cv); - GvCV_set(topgv, NULL); - cand_cv = NULL; - GvCVGEN(topgv) = 0; + SvREFCNT_dec_NN(cand_cv); + GvCV_set(topgv, NULL); + cand_cv = NULL; + GvCVGEN(topgv) = 0; } } else if (GvCVGEN(topgv) == topgen_cmp) { /* cache indicates no such method definitively */ return 0; } - else if (stash == cachestash - && len > 1 /* shortest is uc */ + else if (stash == cachestash + && len > 1 /* shortest is uc */ && memEQs(hvname, HvNAMELEN_get(stash), "CORE") && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len)) - goto have_gv; + goto have_gv; } linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */ @@ -864,7 +885,7 @@ S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, GvCV_set(topgv, cand_cv); GvCVGEN(topgv) = topgen_cmp; } - return candidate; + return candidate; } } @@ -965,26 +986,26 @@ Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I3 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD; if (!gv) { - CV *cv; - GV **gvp; - - if (!stash) - return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */ - if (len == S_autolen && memEQ(name, S_autoload, S_autolen)) - return NULL; - if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags))) - return NULL; - cv = GvCV(gv); - if (!(CvROOT(cv) || CvXSUB(cv))) - return NULL; - /* Have an autoload */ - if (level < 0) /* Cannot do without a stub */ - gv_fetchmeth_pvn(stash, name, len, 0, flags); - gvp = (GV**)hv_fetch(stash, name, + CV *cv; + GV **gvp; + + if (!stash) + return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */ + if (len == S_autolen && memEQ(name, S_autoload, S_autolen)) + return NULL; + if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags))) + return NULL; + cv = GvCV(gv); + if (!(CvROOT(cv) || CvXSUB(cv))) + return NULL; + /* Have an autoload */ + if (level < 0) /* Cannot do without a stub */ + gv_fetchmeth_pvn(stash, name, len, 0, flags); + gvp = (GV**)hv_fetch(stash, name, (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0)); - if (!gvp) - return NULL; - return *gvp; + if (!gvp) + return NULL; + return *gvp; } return gv; } @@ -1060,11 +1081,11 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS; if (SvTYPE(stash) < SVt_PVHV) - stash = NULL; + stash = NULL; else { - /* The only way stash can become NULL later on is if last_separator is set, - which in turn means that there is no need for a SVt_PVHV case - the error reporting code. */ + /* The only way stash can become NULL later on is if last_separator is set, + which in turn means that there is no need for a SVt_PVHV case + the error reporting code. */ } { @@ -1097,100 +1118,100 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le if (last_separator) { STRLEN sep_len= last_separator - origname; if ( memEQs(origname, sep_len, "SUPER")) { - /* ->SUPER::method should really be looked up in original stash */ - stash = CopSTASH(PL_curcop); - flags |= GV_SUPER; - DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", - origname, HvENAME_get(stash), name) ); - } + /* ->SUPER::method should really be looked up in original stash */ + stash = CopSTASH(PL_curcop); + flags |= GV_SUPER; + DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", + origname, HvENAME_get(stash), name) ); + } else if ( sep_len >= 7 && - strBEGINs(last_separator - 7, "::SUPER")) { + strBEGINs(last_separator - 7, "::SUPER")) { /* don't autovifify if ->NoSuchStash::SUPER::method */ stash = gv_stashpvn(origname, sep_len - 7, is_utf8); - if (stash) flags |= GV_SUPER; - } - else { + if (stash) flags |= GV_SUPER; + } + else { /* don't autovifify if ->NoSuchStash::method */ stash = gv_stashpvn(origname, sep_len, is_utf8); - } - ostash = stash; + } + ostash = stash; } gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags); if (!gv) { - /* This is the special case that exempts Foo->import and - Foo->unimport from being an error even if there's no - import/unimport subroutine */ - if (strEQ(name,"import") || strEQ(name,"unimport")) { - gv = (GV*)sv_2mortal((SV*)newCONSTSUB_flags(NULL, - NULL, 0, 0, NULL)); - } else if (autoload) - gv = gv_autoload_pvn( - ostash, name, name_end - name, GV_AUTOLOAD_ISMETHOD|flags - ); - if (!gv && do_croak) { - /* Right now this is exclusively for the benefit of S_method_common - in pp_hot.c */ - if (stash) { - /* If we can't find an IO::File method, it might be a call on - * a filehandle. If IO:File has not been loaded, try to - * require it first instead of croaking */ - const char *stash_name = HvNAME_get(stash); - if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File") - && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL, - STR_WITH_LEN("IO/File.pm"), 0, - HV_FETCH_ISEXISTS, NULL, 0) - ) { - require_pv("IO/File.pm"); - gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags); - if (gv) - return gv; - } - Perl_croak(aTHX_ - "Can't locate object method \"%" UTF8f - "\" via package \"%" HEKf "\"", - UTF8fARG(is_utf8, name_end - name, name), + /* This is the special case that exempts Foo->import and + Foo->unimport from being an error even if there's no + import/unimport subroutine */ + if (strEQ(name,"import") || strEQ(name,"unimport")) { + gv = (GV*)sv_2mortal((SV*)newCONSTSUB_flags(NULL, + NULL, 0, 0, NULL)); + } else if (autoload) + gv = gv_autoload_pvn( + ostash, name, name_end - name, GV_AUTOLOAD_ISMETHOD|flags + ); + if (!gv && do_croak) { + /* Right now this is exclusively for the benefit of S_method_common + in pp_hot.c */ + if (stash) { + /* If we can't find an IO::File method, it might be a call on + * a filehandle. If IO:File has not been loaded, try to + * require it first instead of croaking */ + const char *stash_name = HvNAME_get(stash); + if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File") + && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL, + STR_WITH_LEN("IO/File.pm"), 0, + HV_FETCH_ISEXISTS, NULL, 0) + ) { + require_pv("IO/File.pm"); + gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags); + if (gv) + return gv; + } + Perl_croak(aTHX_ + "Can't locate object method \"%" UTF8f + "\" via package \"%" HEKf "\"", + UTF8fARG(is_utf8, name_end - name, name), HEKfARG(HvNAME_HEK(stash))); - } - else { + } + else { SV* packnamesv; - if (last_separator) { - packnamesv = newSVpvn_flags(origname, last_separator - origname, + if (last_separator) { + packnamesv = newSVpvn_flags(origname, last_separator - origname, SVs_TEMP | is_utf8); - } else { - packnamesv = error_report; - } - - Perl_croak(aTHX_ - "Can't locate object method \"%" UTF8f - "\" via package \"%" SVf "\"" - " (perhaps you forgot to load \"%" SVf "\"?)", - UTF8fARG(is_utf8, name_end - name, name), + } else { + packnamesv = error_report; + } + + Perl_croak(aTHX_ + "Can't locate object method \"%" UTF8f + "\" via package \"%" SVf "\"" + " (perhaps you forgot to load \"%" SVf "\"?)", + UTF8fARG(is_utf8, name_end - name, name), SVfARG(packnamesv), SVfARG(packnamesv)); - } - } + } + } } else if (autoload) { - CV* const cv = GvCV(gv); - if (!CvROOT(cv) && !CvXSUB(cv)) { - GV* stubgv; - GV* autogv; - - if (CvANON(cv) || CvLEXICAL(cv)) - stubgv = gv; - else { - stubgv = CvGV(cv); - if (GvCV(stubgv) != cv) /* orphaned import */ - stubgv = gv; - } + CV* const cv = GvCV(gv); + if (!CvROOT(cv) && !CvXSUB(cv)) { + GV* stubgv; + GV* autogv; + + if (CvANON(cv) || CvLEXICAL(cv)) + stubgv = gv; + else { + stubgv = CvGV(cv); + if (GvCV(stubgv) != cv) /* orphaned import */ + stubgv = gv; + } autogv = gv_autoload_pvn(GvSTASH(stubgv), GvNAME(stubgv), GvNAMELEN(stubgv), GV_AUTOLOAD_ISMETHOD | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0)); - if (autogv) - gv = autogv; - } + if (autogv) + gv = autogv; + } } return gv; @@ -1229,26 +1250,26 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN; if (len == S_autolen && memEQ(name, S_autoload, S_autolen)) - return NULL; + return NULL; if (stash) { - if (SvTYPE(stash) < SVt_PVHV) { + if (SvTYPE(stash) < SVt_PVHV) { STRLEN packname_len = 0; const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len); packname = newSVpvn_flags(packname_ptr, packname_len, SVs_TEMP | SvUTF8(stash)); - stash = NULL; - } - else - packname = sv_2mortal(newSVhek(HvNAME_HEK(stash))); - if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER"); + stash = NULL; + } + else + packname = sv_2mortal(newSVhek(HvNAME_HEK(stash))); + if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER"); } if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, - is_utf8 | (flags & GV_SUPER)))) - return NULL; + is_utf8 | (flags & GV_SUPER)))) + return NULL; cv = GvCV(gv); if (!(CvROOT(cv) || CvXSUB(cv))) - return NULL; + return NULL; /* * Inheriting AUTOLOAD for non-methods no longer works @@ -1259,7 +1280,7 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) ) Perl_croak(aTHX_ "Use of inherited AUTOLOAD for non-method %" SVf "::%" UTF8f "() is no longer allowed", - SVfARG(packname), + SVfARG(packname), UTF8fARG(is_utf8, len, name)); if (CvISXSUB(cv)) { @@ -1285,34 +1306,34 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) * We use SvUTF8 for both prototypes and sub names, so if one is * UTF8, the other must be upgraded. */ - CvSTASH_set(cv, stash); - if (SvPOK(cv)) { /* Ouch! */ - SV * const tmpsv = newSVpvn_flags(name, len, is_utf8); - STRLEN ulen; - const char *proto = CvPROTO(cv); - assert(proto); - if (SvUTF8(cv)) - sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2); - ulen = SvCUR(tmpsv); - SvCUR_set(tmpsv, SvCUR(tmpsv) + 1); /* include null in string */ - sv_catpvn_flags( - tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv) - ); - SvTEMP_on(tmpsv); /* Allow theft */ - sv_setsv_nomg((SV *)cv, tmpsv); - SvTEMP_off(tmpsv); - SvREFCNT_dec_NN(tmpsv); - SvLEN_set(cv, SvCUR(cv) + 1); - SvCUR_set(cv, ulen); - } - else { - sv_setpvn((SV *)cv, name, len); - SvPOK_off(cv); - if (is_utf8) + CvSTASH_set(cv, stash); + if (SvPOK(cv)) { /* Ouch! */ + SV * const tmpsv = newSVpvn_flags(name, len, is_utf8); + STRLEN ulen; + const char *proto = CvPROTO(cv); + assert(proto); + if (SvUTF8(cv)) + sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2); + ulen = SvCUR(tmpsv); + SvCUR_set(tmpsv, SvCUR(tmpsv) + 1); /* include null in string */ + sv_catpvn_flags( + tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv) + ); + SvTEMP_on(tmpsv); /* Allow theft */ + sv_setsv_nomg((SV *)cv, tmpsv); + SvTEMP_off(tmpsv); + SvREFCNT_dec_NN(tmpsv); + SvLEN_set(cv, SvCUR(cv) + 1); + SvCUR_set(cv, ulen); + } + else { + sv_setpvn((SV *)cv, name, len); + SvPOK_off(cv); + if (is_utf8) SvUTF8_on(cv); - else SvUTF8_off(cv); - } - CvAUTOLOAD_on(cv); + else SvUTF8_off(cv); + } + CvAUTOLOAD_on(cv); } /* @@ -1326,9 +1347,9 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) ENTER; if (!isGV(vargv)) { - gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0); + gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0); #ifdef PERL_DONT_CREATE_GVSV - GvSV(vargv) = newSV(0); + GvSV(vargv) = newSV(0); #endif } LEAVE; @@ -1340,8 +1361,8 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */ sv_catpvn_flags( - varsv, name, len, - SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES) + varsv, name, len, + SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES) ); if (is_utf8) SvUTF8_on(varsv); @@ -1392,19 +1413,19 @@ S_require_tie_mod(pTHX_ GV *gv, const char varname, const char * name, if (!(stash = gv_stashpvn(name, len, 0)) || ! GET_HV_FETCH_TIE_FUNC) { - SV * const module = newSVpvn(name, len); - const char type = varname == '[' ? '$' : '%'; - if ( flags & 1 ) - save_scalar(gv); - Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL); - assert(sp == PL_stack_sp); - stash = gv_stashpvn(name, len, 0); - if (!stash) - Perl_croak(aTHX_ "panic: Can't use %c%c because %s is not available", - type, varname, name); - else if (! GET_HV_FETCH_TIE_FUNC) - Perl_croak(aTHX_ "panic: Can't use %c%c because %s does not define _tie_it", - type, varname, name); + SV * const module = newSVpvn(name, len); + const char type = varname == '[' ? '$' : '%'; + if ( flags & 1 ) + save_scalar(gv); + Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL); + assert(sp == PL_stack_sp); + stash = gv_stashpvn(name, len, 0); + if (!stash) + Perl_croak(aTHX_ "panic: Can't use %c%c because %s is not available", + type, varname, name); + else if (! GET_HV_FETCH_TIE_FUNC) + Perl_croak(aTHX_ "panic: Can't use %c%c because %s does not define _tie_it", + type, varname, name); } /* Now call the tie function. It should be in *gvp. */ assert(gvp); assert(*gvp); @@ -1452,12 +1473,13 @@ is returned. Flags may be one of: - GV_ADD - SVf_UTF8 - GV_NOADD_NOINIT - GV_NOINIT - GV_NOEXPAND - GV_ADDMG + GV_ADD Create and initialize the package if doesn't + already exist + GV_NOADD_NOINIT Don't create the package, + GV_ADDMG GV_ADD iff the GV is magical + GV_NOINIT GV_ADD, but don't initialize + GV_NOEXPAND Don't expand SvOK() entries to PVGV + SVf_UTF8 The name is in UTF-8 The most important of which are probably C and C. @@ -1494,28 +1516,28 @@ S_gv_stashpvn_internal(pTHX_ const char *name, U32 namelen, I32 flags) PERL_ARGS_ASSERT_GV_STASHPVN_INTERNAL; if (tmplen <= sizeof smallbuf) - tmpbuf = smallbuf; + tmpbuf = smallbuf; else - Newx(tmpbuf, tmplen, char); + Newx(tmpbuf, tmplen, char); Copy(name, tmpbuf, namelen, char); tmpbuf[namelen] = ':'; tmpbuf[namelen+1] = ':'; tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV); if (tmpbuf != smallbuf) - Safefree(tmpbuf); + Safefree(tmpbuf); if (!tmpgv || !isGV_with_GP(tmpgv)) - return NULL; + return NULL; stash = GvHV(tmpgv); if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL; assert(stash); if (!HvNAME_get(stash)) { - hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 ); - - /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */ - /* If the containing stash has multiple effective - names, see that this one gets them, too. */ - if (HvAUX(GvSTASH(tmpgv))->xhv_name_count) - mro_package_moved(stash, NULL, tmpgv, 1); + hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 ); + + /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */ + /* If the containing stash has multiple effective + names, see that this one gets them, too. */ + if (HvAUX(GvSTASH(tmpgv))->xhv_name_count) + mro_package_moved(stash, NULL, tmpgv, 1); } return stash; } @@ -1631,7 +1653,7 @@ S_gv_magicalize_isa(pTHX_ GV *gv) av = GvAVn(gv); GvMULTI_on(gv); sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa, - NULL, 0); + NULL, 0); } /* This function grabs name and tries to split a stash and glob @@ -1731,14 +1753,14 @@ S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name, *name = name_cursor+1; if (*name == name_end) { if (!*gv) { - *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE)); - if (SvTYPE(*gv) != SVt_PVGV) { - gv_init_pvn(*gv, PL_defstash, "main::", 6, - GV_ADDMULTI); - GvHV(*gv) = - MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash)); - } - } + *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE)); + if (SvTYPE(*gv) != SVt_PVGV) { + gv_init_pvn(*gv, PL_defstash, "main::", 6, + GV_ADDMULTI); + GvHV(*gv) = + MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash)); + } + } goto ok; } } @@ -1932,12 +1954,12 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, PERL_ARGS_ASSERT_GV_MAGICALIZE; if (stash != PL_defstash) { /* not the main stash */ - /* We only have to check for a few names here: a, b, EXPORT, ISA - and VERSION. All the others apply only to the main stash or to - CORE (which is checked right after this). */ - if (len) { - switch (*name) { - case 'E': + /* We only have to check for a few names here: a, b, EXPORT, ISA + and VERSION. All the others apply only to the main stash or to + CORE (which is checked right after this). */ + if (len) { + switch (*name) { + case 'E': if ( len >= 6 && name[1] == 'X' && (memEQs(name, len, "EXPORT") @@ -1945,46 +1967,46 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, ||memEQs(name, len, "EXPORT_FAIL") ||memEQs(name, len, "EXPORT_TAGS")) ) - GvMULTI_on(gv); - break; - case 'I': + GvMULTI_on(gv); + break; + case 'I': if (memEQs(name, len, "ISA")) - gv_magicalize_isa(gv); - break; - case 'V': + gv_magicalize_isa(gv); + break; + case 'V': if (memEQs(name, len, "VERSION")) - GvMULTI_on(gv); - break; - case 'a': + GvMULTI_on(gv); + break; + case 'a': if (stash == PL_debstash && memEQs(name, len, "args")) { - GvMULTI_on(gv_AVadd(gv)); - break; + GvMULTI_on(gv_AVadd(gv)); + break; } /* FALLTHROUGH */ - case 'b': - if (len == 1 && sv_type == SVt_PV) - GvMULTI_on(gv); - /* FALLTHROUGH */ - default: - goto try_core; - } - goto ret; - } + case 'b': + if (len == 1 && sv_type == SVt_PV) + GvMULTI_on(gv); + /* FALLTHROUGH */ + default: + goto try_core; + } + goto ret; + } try_core: - if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) { - /* Avoid null warning: */ - const char * const stashname = HvNAME(stash); assert(stashname); - if (strBEGINs(stashname, "CORE")) - S_maybe_add_coresub(aTHX_ 0, gv, name, len); - } + if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) { + /* Avoid null warning: */ + const char * const stashname = HvNAME(stash); assert(stashname); + if (strBEGINs(stashname, "CORE")) + S_maybe_add_coresub(aTHX_ 0, gv, name, len); + } } else if (len > 1) { #ifndef EBCDIC - if (*name > 'V' ) { - NOOP; - /* Nothing else to do. - The compiler will probably turn the switch statement into a - branch table. Make sure we avoid even that small overhead for + if (*name > 'V' ) { + NOOP; + /* Nothing else to do. + The compiler will probably turn the switch statement into a + branch table. Make sure we avoid even that small overhead for the common case of lower case variable names. (On EBCDIC platforms, we can't just do: if (NATIVE_TO_ASCII(*name) > NATIVE_TO_ASCII('V') ) { @@ -1992,19 +2014,19 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, C1 (non-ASCII) controls on those platforms, so the remapping would make them larger than 'V') */ - } else + } else #endif - { - switch (*name) { - case 'A': + { + switch (*name) { + case 'A': if (memEQs(name, len, "ARGV")) { - IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START; - } + IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START; + } else if (memEQs(name, len, "ARGVOUT")) { - GvMULTI_on(gv); - } - break; - case 'E': + GvMULTI_on(gv); + } + break; + case 'E': if ( len >= 6 && name[1] == 'X' && (memEQs(name, len, "EXPORT") @@ -2012,51 +2034,51 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, ||memEQs(name, len, "EXPORT_FAIL") ||memEQs(name, len, "EXPORT_TAGS")) ) - GvMULTI_on(gv); - break; - case 'I': + GvMULTI_on(gv); + break; + case 'I': if (memEQs(name, len, "ISA")) { - gv_magicalize_isa(gv); - } - break; - case 'S': + gv_magicalize_isa(gv); + } + break; + case 'S': if (memEQs(name, len, "SIG")) { - HV *hv; - I32 i; - if (!PL_psig_name) { - Newxz(PL_psig_name, 2 * SIG_SIZE, SV*); - Newxz(PL_psig_pend, SIG_SIZE, int); - PL_psig_ptr = PL_psig_name + SIG_SIZE; - } else { - /* I think that the only way to get here is to re-use an - embedded perl interpreter, where the previous - use didn't clean up fully because - PL_perl_destruct_level was 0. I'm not sure that we - "support" that, in that I suspect in that scenario - there are sufficient other garbage values left in the - interpreter structure that something else will crash - before we get here. I suspect that this is one of - those "doctor, it hurts when I do this" bugs. */ - Zero(PL_psig_name, 2 * SIG_SIZE, SV*); - Zero(PL_psig_pend, SIG_SIZE, int); - } - GvMULTI_on(gv); - hv = GvHVn(gv); - hv_magic(hv, NULL, PERL_MAGIC_sig); - for (i = 1; i < SIG_SIZE; i++) { - SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1); - if (init) - sv_setsv(*init, &PL_sv_undef); - } - } - break; - case 'V': + HV *hv; + I32 i; + if (!PL_psig_name) { + Newxz(PL_psig_name, 2 * SIG_SIZE, SV*); + Newxz(PL_psig_pend, SIG_SIZE, int); + PL_psig_ptr = PL_psig_name + SIG_SIZE; + } else { + /* I think that the only way to get here is to re-use an + embedded perl interpreter, where the previous + use didn't clean up fully because + PL_perl_destruct_level was 0. I'm not sure that we + "support" that, in that I suspect in that scenario + there are sufficient other garbage values left in the + interpreter structure that something else will crash + before we get here. I suspect that this is one of + those "doctor, it hurts when I do this" bugs. */ + Zero(PL_psig_name, 2 * SIG_SIZE, SV*); + Zero(PL_psig_pend, SIG_SIZE, int); + } + GvMULTI_on(gv); + hv = GvHVn(gv); + hv_magic(hv, NULL, PERL_MAGIC_sig); + for (i = 1; i < SIG_SIZE; i++) { + SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1); + if (init) + sv_setsv(*init, &PL_sv_undef); + } + } + break; + case 'V': if (memEQs(name, len, "VERSION")) - GvMULTI_on(gv); - break; + GvMULTI_on(gv); + break; case '\003': /* $^CHILD_ERROR_NATIVE */ if (memEQs(name, len, "\003HILD_ERROR_NATIVE")) - goto magicalize; + goto magicalize; /* @{^CAPTURE} %{^CAPTURE} */ if (memEQs(name, len, "\003APTURE")) { AV* const av = GvAVn(gv); @@ -2071,30 +2093,30 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, if (memEQs(name, len, "\003APTURE_ALL")) { require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0); } - break; - case '\005': /* $^ENCODING */ + break; + case '\005': /* $^ENCODING */ if (memEQs(name, len, "\005NCODING")) - goto magicalize; - break; - case '\007': /* $^GLOBAL_PHASE */ + goto magicalize; + break; + case '\007': /* $^GLOBAL_PHASE */ if (memEQs(name, len, "\007LOBAL_PHASE")) - goto ro_magicalize; - break; - case '\014': /* $^LAST_FH */ + goto ro_magicalize; + break; + case '\014': /* $^LAST_FH */ if (memEQs(name, len, "\014AST_FH")) - goto ro_magicalize; - break; + goto ro_magicalize; + break; case '\015': /* $^MATCH */ if (memEQs(name, len, "\015ATCH")) { paren = RX_BUFF_IDX_CARET_FULLMATCH; goto storeparen; } break; - case '\017': /* $^OPEN */ + case '\017': /* $^OPEN */ if (memEQs(name, len, "\017PEN")) - goto magicalize; - break; - case '\020': /* $^PREMATCH $^POSTMATCH */ + goto magicalize; + break; + case '\020': /* $^PREMATCH $^POSTMATCH */ if (memEQs(name, len, "\020REMATCH")) { paren = RX_BUFF_IDX_CARET_PREMATCH; goto storeparen; @@ -2103,73 +2125,73 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, paren = RX_BUFF_IDX_CARET_POSTMATCH; goto storeparen; } - break; + break; case '\023': if (memEQs(name, len, "\023AFE_LOCALES")) - goto ro_magicalize; - break; - case '\024': /* ${^TAINT} */ + goto ro_magicalize; + break; + case '\024': /* ${^TAINT} */ if (memEQs(name, len, "\024AINT")) - goto ro_magicalize; - break; - case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */ + goto ro_magicalize; + break; + case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */ if (memEQs(name, len, "\025NICODE")) - goto ro_magicalize; + goto ro_magicalize; if (memEQs(name, len, "\025TF8LOCALE")) - goto ro_magicalize; + goto ro_magicalize; if (memEQs(name, len, "\025TF8CACHE")) - goto magicalize; - break; - case '\027': /* $^WARNING_BITS */ + goto magicalize; + break; + case '\027': /* $^WARNING_BITS */ if (memEQs(name, len, "\027ARNING_BITS")) - goto magicalize; + goto magicalize; #ifdef WIN32 else if (memEQs(name, len, "\027IN32_SLOPPY_STAT")) - goto magicalize; + goto magicalize; #endif - break; - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - case '8': - case '9': - { - /* Ensures that we have an all-digit variable, ${"1foo"} fails - this test */ + break; + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + { + /* Ensures that we have an all-digit variable, ${"1foo"} fails + this test */ UV uv; if (!grok_atoUV(name, &uv, NULL) || uv > I32_MAX) goto ret; /* XXX why are we using a SSize_t? */ paren = (SSize_t)(I32)uv; goto storeparen; - } - } - } + } + } + } } else { - /* Names of length 1. (Or 0. But name is NUL terminated, so that will - be case '\0' in this switch statement (ie a default case) */ - switch (*name) { - case '&': /* $& */ + /* Names of length 1. (Or 0. But name is NUL terminated, so that will + be case '\0' in this switch statement (ie a default case) */ + switch (*name) { + case '&': /* $& */ paren = RX_BUFF_IDX_FULLMATCH; goto sawampersand; - case '`': /* $` */ + case '`': /* $` */ paren = RX_BUFF_IDX_PREMATCH; goto sawampersand; - case '\'': /* $' */ + case '\'': /* $' */ paren = RX_BUFF_IDX_POSTMATCH; sawampersand: #ifdef PERL_SAWAMPERSAND - if (!( - sv_type == SVt_PVAV || - sv_type == SVt_PVHV || - sv_type == SVt_PVCV || - sv_type == SVt_PVFM || - sv_type == SVt_PVIO - )) { PL_sawampersand |= + if (!( + sv_type == SVt_PVAV || + sv_type == SVt_PVHV || + sv_type == SVt_PVCV || + sv_type == SVt_PVFM || + sv_type == SVt_PVIO + )) { PL_sawampersand |= (*name == '`') ? SAWAMPERSAND_LEFT : (*name == '&') @@ -2195,29 +2217,29 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, NULL, paren); break; - case ':': /* $: */ - sv_setpv(GvSVn(gv),PL_chopset); - goto magicalize; + case ':': /* $: */ + sv_setpv(GvSVn(gv),PL_chopset); + goto magicalize; - case '?': /* $? */ + case '?': /* $? */ #ifdef COMPLEX_STATUS - SvUPGRADE(GvSVn(gv), SVt_PVLV); + SvUPGRADE(GvSVn(gv), SVt_PVLV); #endif - goto magicalize; + goto magicalize; - case '!': /* $! */ - GvMULTI_on(gv); - /* If %! has been used, automatically load Errno.pm. */ + case '!': /* $! */ + GvMULTI_on(gv); + /* If %! has been used, automatically load Errno.pm. */ - sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); + sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); /* magicalization must be done before require_tie_mod_s is called */ - if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) + if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) require_tie_mod_s(gv, '!', "Errno", 1); - break; - case '-': /* $-, %-, @- */ - case '+': /* $+, %+, @+ */ + break; + case '-': /* $-, %-, @- */ + case '+': /* $+, %+, @+ */ GvMULTI_on(gv); /* no used once warnings here */ { /* $- $+ */ sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); @@ -2236,81 +2258,81 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, SvREADONLY_on(av); } break; - case '*': /* $* */ - case '#': /* $# */ + case '*': /* $* */ + case '#': /* $# */ if (sv_type == SVt_PV) /* diag_listed_as: $* is no longer supported as of Perl 5.30 */ Perl_croak(aTHX_ "$%c is no longer supported as of Perl 5.30", *name); break; - case '\010': /* $^H */ - { - HV *const hv = GvHVn(gv); - hv_magic(hv, NULL, PERL_MAGIC_hints); - } - goto magicalize; - case '\023': /* $^S */ - ro_magicalize: - SvREADONLY_on(GvSVn(gv)); - /* FALLTHROUGH */ - case '0': /* $0 */ - case '^': /* $^ */ - case '~': /* $~ */ - case '=': /* $= */ - case '%': /* $% */ - case '.': /* $. */ - case '(': /* $( */ - case ')': /* $) */ - case '<': /* $< */ - case '>': /* $> */ - case '\\': /* $\ */ - case '/': /* $/ */ - case '|': /* $| */ - case '$': /* $$ */ - case '[': /* $[ */ - case '\001': /* $^A */ - case '\003': /* $^C */ - case '\004': /* $^D */ - case '\005': /* $^E */ - case '\006': /* $^F */ - case '\011': /* $^I, NOT \t in EBCDIC */ - case '\016': /* $^N */ - case '\017': /* $^O */ - case '\020': /* $^P */ - case '\024': /* $^T */ - case '\027': /* $^W */ - magicalize: - sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); - break; - - case '\014': /* $^L */ - sv_setpvs(GvSVn(gv),"\f"); - break; - case ';': /* $; */ - sv_setpvs(GvSVn(gv),"\034"); - break; - case ']': /* $] */ - { - SV * const sv = GvSV(gv); - if (!sv_derived_from(PL_patchlevel, "version")) - upg_version(PL_patchlevel, TRUE); - GvSV(gv) = vnumify(PL_patchlevel); - SvREADONLY_on(GvSV(gv)); - SvREFCNT_dec(sv); - } - break; - case '\026': /* $^V */ - { - SV * const sv = GvSV(gv); - GvSV(gv) = new_version(PL_patchlevel); - SvREADONLY_on(GvSV(gv)); - SvREFCNT_dec(sv); - } - break; - case 'a': - case 'b': - if (sv_type == SVt_PV) - GvMULTI_on(gv); - } + case '\010': /* $^H */ + { + HV *const hv = GvHVn(gv); + hv_magic(hv, NULL, PERL_MAGIC_hints); + } + goto magicalize; + case '\023': /* $^S */ + ro_magicalize: + SvREADONLY_on(GvSVn(gv)); + /* FALLTHROUGH */ + case '0': /* $0 */ + case '^': /* $^ */ + case '~': /* $~ */ + case '=': /* $= */ + case '%': /* $% */ + case '.': /* $. */ + case '(': /* $( */ + case ')': /* $) */ + case '<': /* $< */ + case '>': /* $> */ + case '\\': /* $\ */ + case '/': /* $/ */ + case '|': /* $| */ + case '$': /* $$ */ + case '[': /* $[ */ + case '\001': /* $^A */ + case '\003': /* $^C */ + case '\004': /* $^D */ + case '\005': /* $^E */ + case '\006': /* $^F */ + case '\011': /* $^I, NOT \t in EBCDIC */ + case '\016': /* $^N */ + case '\017': /* $^O */ + case '\020': /* $^P */ + case '\024': /* $^T */ + case '\027': /* $^W */ + magicalize: + sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); + break; + + case '\014': /* $^L */ + sv_setpvs(GvSVn(gv),"\f"); + break; + case ';': /* $; */ + sv_setpvs(GvSVn(gv),"\034"); + break; + case ']': /* $] */ + { + SV * const sv = GvSV(gv); + if (!sv_derived_from(PL_patchlevel, "version")) + upg_version(PL_patchlevel, TRUE); + GvSV(gv) = vnumify(PL_patchlevel); + SvREADONLY_on(GvSV(gv)); + SvREFCNT_dec(sv); + } + break; + case '\026': /* $^V */ + { + SV * const sv = GvSV(gv); + GvSV(gv) = new_version(PL_patchlevel); + SvREADONLY_on(GvSV(gv)); + SvREFCNT_dec(sv); + } + break; + case 'a': + case 'b': + if (sv_type == SVt_PV) + GvMULTI_on(gv); + } } ret: @@ -2439,7 +2461,7 @@ to C makes it behave identically to C. GV * Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, - const svtype sv_type) + const svtype sv_type) { const char *name = nambeg; GV *gv = NULL; @@ -2478,8 +2500,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, /* By this point we should have a stash and a name */ gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -(I32)len : (I32)len,add); if (!gvp || *gvp == (const GV *)&PL_sv_undef) { - if (addmg) gv = (GV *)newSV(0); /* tentatively */ - else return NULL; + if (addmg) gv = (GV *)newSV(0); /* tentatively */ + else return NULL; } else gv = *gvp, addmg = 0; /* From this point on, addmg means gv has not been inserted in the @@ -2489,7 +2511,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, /* The GV already exists, so return it, but check if we need to do * anything else with it before that. */ - if (add) { + if (add) { /* This is the heuristic that handles if a variable triggers the * 'used only once' warning. If there's already a GV in the stash * with this name, then we assume that the variable has been used @@ -2498,24 +2520,24 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, * BEGIN { $a = 1; $::{foo} = *a }; () = $foo * not warning about $main::foo being used just once */ - GvMULTI_on(gv); - gv_init_svtype(gv, sv_type); + GvMULTI_on(gv); + gv_init_svtype(gv, sv_type); /* You reach this path once the typeglob has already been created, either by the same or a different sigil. If this path didn't exist, then (say) referencing $! first, and %! second would mean that %! was not handled correctly. */ - if (len == 1 && stash == PL_defstash) { + if (len == 1 && stash == PL_defstash) { maybe_multimagic_gv(gv, name, sv_type); - } + } else if (sv_type == SVt_PVAV - && memEQs(name, len, "ISA") - && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv)))) - gv_magicalize_isa(gv); - } - return gv; + && memEQs(name, len, "ISA") + && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv)))) + gv_magicalize_isa(gv); + } + return gv; } else if (no_init) { - assert(!addmg); - return gv; + assert(!addmg); + return gv; } /* If GV_NOEXPAND is true and what we got off the stash is a ref, * don't expand it to a glob. This is an optimization so that things @@ -2524,8 +2546,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, * stashes. */ else if (no_expand && SvROK(gv)) { - assert(!addmg); - return gv; + assert(!addmg); + return gv; } /* Adding a new symbol. @@ -2538,9 +2560,9 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, faking_it = SvOK(gv); if (add & GV_ADDWARN) - Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), - "Had to create %" UTF8f " unexpectedly", - UTF8fARG(is_utf8, name_end-nambeg, nambeg)); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "Had to create %" UTF8f " unexpectedly", + UTF8fARG(is_utf8, name_end-nambeg, nambeg)); gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8); if ( full_len != 0 @@ -2585,8 +2607,8 @@ Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) if (hv && (name = HvNAME(hv))) { const STRLEN len = HvNAMELEN(hv); if (keepmain || ! memBEGINs(name, len, "main")) { - sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES); - sv_catpvs(sv,"::"); + sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES); + sv_catpvs(sv,"::"); } } else sv_catpvs(sv,"__ANON__::"); @@ -2616,7 +2638,7 @@ Perl_gv_check(pTHX_ HV *stash) PERL_ARGS_ASSERT_GV_CHECK; if (!SvOOK(stash)) - return; + return; assert(HvARRAY(stash)); @@ -2624,21 +2646,21 @@ Perl_gv_check(pTHX_ HV *stash) const HE *entry; /* mark stash is being scanned, to avoid recursing */ HvAUX(stash)->xhv_aux_flags |= HvAUXf_SCAN_STASH; - for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { + for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { GV *gv; HV *hv; - STRLEN keylen = HeKLEN(entry); + STRLEN keylen = HeKLEN(entry); const char * const key = HeKEY(entry); - if (keylen >= 2 && key[keylen-2] == ':' && key[keylen-1] == ':' && - (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv))) - { - if (hv != PL_defstash && hv != stash + if (keylen >= 2 && key[keylen-2] == ':' && key[keylen-1] == ':' && + (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv))) + { + if (hv != PL_defstash && hv != stash && !(SvOOK(hv) && (HvAUX(hv)->xhv_aux_flags & HvAUXf_SCAN_STASH)) ) - gv_check(hv); /* nested package */ - } + gv_check(hv); /* nested package */ + } else if ( HeKLEN(entry) != 0 && *HeKEY(entry) != '_' && isIDFIRST_lazy_if_safe(HeKEY(entry), @@ -2646,24 +2668,24 @@ Perl_gv_check(pTHX_ HV *stash) HeUTF8(entry)) ) { const char *file; - gv = MUTABLE_GV(HeVAL(entry)); - if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv)) - continue; - file = GvFILE(gv); - CopLINE_set(PL_curcop, GvLINE(gv)); + gv = MUTABLE_GV(HeVAL(entry)); + if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv)) + continue; + file = GvFILE(gv); + CopLINE_set(PL_curcop, GvLINE(gv)); #ifdef USE_ITHREADS - CopFILE(PL_curcop) = (char *)file; /* set for warning */ + CopFILE(PL_curcop) = (char *)file; /* set for warning */ #else - CopFILEGV(PL_curcop) - = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0); + CopFILEGV(PL_curcop) + = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0); #endif - Perl_warner(aTHX_ packWARN(WARN_ONCE), - "Name \"%" HEKf "::%" HEKf - "\" used only once: possible typo", + Perl_warner(aTHX_ packWARN(WARN_ONCE), + "Name \"%" HEKf "::%" HEKf + "\" used only once: possible typo", HEKfARG(HvNAME_HEK(stash)), HEKfARG(GvNAME_HEK(gv))); - } - } + } + } HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_SCAN_STASH; } } @@ -2686,17 +2708,17 @@ GP* Perl_gp_ref(pTHX_ GP *gp) { if (!gp) - return NULL; + return NULL; gp->gp_refcnt++; if (gp->gp_cv) { - if (gp->gp_cvgen) { - /* If the GP they asked for a reference to contains + if (gp->gp_cvgen) { + /* If the GP they asked for a reference to contains a method cache entry, clear it first, so that we don't infect them with our cached entry */ - SvREFCNT_dec_NN(gp->gp_cv); - gp->gp_cv = NULL; - gp->gp_cvgen = 0; - } + SvREFCNT_dec_NN(gp->gp_cv); + gp->gp_cv = NULL; + gp->gp_cvgen = 0; + } } return gp; } @@ -2708,19 +2730,19 @@ Perl_gp_free(pTHX_ GV *gv) int attempts = 100; if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv))) - return; + return; if (gp->gp_refcnt == 0) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), - "Attempt to free unreferenced glob pointers" - pTHX__FORMAT pTHX__VALUE); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "Attempt to free unreferenced glob pointers" + pTHX__FORMAT pTHX__VALUE); return; } if (gp->gp_refcnt > 1) { borrowed: - if (gp->gp_egv == gv) - gp->gp_egv = 0; - gp->gp_refcnt--; - GvGP_set(gv, NULL); + if (gp->gp_egv == gv) + gp->gp_egv = 0; + gp->gp_refcnt--; + GvGP_set(gv, NULL); return; } @@ -2744,7 +2766,7 @@ Perl_gp_free(pTHX_ GV *gv) gp->gp_form = NULL; if (file_hek) - unshare_hek(file_hek); + unshare_hek(file_hek); SvREFCNT_dec(sv); SvREFCNT_dec(av); @@ -2758,18 +2780,18 @@ Perl_gp_free(pTHX_ GV *gv) HEKfARG(hvname_hek))); (void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD); } - SvREFCNT_dec(hv); + SvREFCNT_dec(hv); } if (io && SvREFCNT(io) == 1 && IoIFP(io) - && (IoTYPE(io) == IoTYPE_WRONLY || - IoTYPE(io) == IoTYPE_RDWR || - IoTYPE(io) == IoTYPE_APPEND) - && ckWARN_d(WARN_IO) - && IoIFP(io) != PerlIO_stdin() - && IoIFP(io) != PerlIO_stdout() - && IoIFP(io) != PerlIO_stderr() - && !(IoFLAGS(io) & IOf_FAKE_DIRP)) - io_close(io, gv, FALSE, TRUE); + && (IoTYPE(io) == IoTYPE_WRONLY || + IoTYPE(io) == IoTYPE_RDWR || + IoTYPE(io) == IoTYPE_APPEND) + && ckWARN_d(WARN_IO) + && IoIFP(io) != PerlIO_stdin() + && IoIFP(io) != PerlIO_stdout() + && IoIFP(io) != PerlIO_stderr() + && !(IoFLAGS(io) & IOf_FAKE_DIRP)) + io_close(io, gv, FALSE, TRUE); SvREFCNT_dec(io); SvREFCNT_dec(cv); SvREFCNT_dec(form); @@ -2786,10 +2808,10 @@ Perl_gp_free(pTHX_ GV *gv) && !gp->gp_form) break; if (--attempts == 0) { - Perl_die(aTHX_ - "panic: gp_free failed to free glob pointer - " - "something is repeatedly re-creating entries" - ); + Perl_die(aTHX_ + "panic: gp_free failed to free glob pointer - " + "something is repeatedly re-creating entries" + ); } } @@ -2808,14 +2830,14 @@ Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_FREEOVRLD; if (amtp && AMT_AMAGIC(amtp)) { - int i; - for (i = 1; i < NofAMmeth; i++) { - CV * const cv = amtp->table[i]; - if (cv) { - SvREFCNT_dec_NN(MUTABLE_SV(cv)); - amtp->table[i] = NULL; - } - } + int i; + for (i = 1; i < NofAMmeth; i++) { + CV * const cv = amtp->table[i]; + if (cv) { + SvREFCNT_dec_NN(MUTABLE_SV(cv)); + amtp->table[i] = NULL; + } + } } return 0; } @@ -2841,7 +2863,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) if (mg) { const AMT * const amtp = (AMT*)mg->mg_ptr; if (amtp->was_ok_sub == newgen) { - return AMT_AMAGIC(amtp) ? 1 : 0; + return AMT_AMAGIC(amtp) ? 1 : 0; } sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table); } @@ -2869,19 +2891,19 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) if (!gv) { if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0)) - goto no_table; + goto no_table; } #ifdef PERL_DONT_CREATE_GVSV else if (!sv) { - NOOP; /* Equivalent to !SvTRUE and !SvOK */ + NOOP; /* Equivalent to !SvTRUE and !SvOK */ } #endif else if (SvTRUE(sv)) /* don't need to set overloading here because fallback => 1 * is the default setting for classes without overloading */ - amt.fallback=AMGfallYES; + amt.fallback=AMGfallYES; else if (SvOK(sv)) { - amt.fallback=AMGfallNEVER; + amt.fallback=AMGfallNEVER; filled = 1; } else { @@ -2893,21 +2915,21 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF; for (i = 1; i < NofAMmeth; i++) { - const char * const cooky = PL_AMG_names[i]; - /* Human-readable form, for debugging: */ - const char * const cp = AMG_id2name(i); - const STRLEN l = PL_AMG_namelens[i]; - - DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n", - cp, HvNAME_get(stash)) ); - /* don't fill the cache while looking up! - Creation of inheritance stubs in intermediate packages may - conflict with the logic of runtime method substitution. - Indeed, for inheritance A -> B -> C, if C overloads "+0", - then we could have created stubs for "(+0" in A and C too. - But if B overloads "bool", we may want to use it for - numifying instead of C's "+0". */ - gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0); + const char * const cooky = PL_AMG_names[i]; + /* Human-readable form, for debugging: */ + const char * const cp = AMG_id2name(i); + const STRLEN l = PL_AMG_namelens[i]; + + DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n", + cp, HvNAME_get(stash)) ); + /* don't fill the cache while looking up! + Creation of inheritance stubs in intermediate packages may + conflict with the logic of runtime method substitution. + Indeed, for inheritance A -> B -> C, if C overloads "+0", + then we could have created stubs for "(+0" in A and C too. + But if B overloads "bool", we may want to use it for + numifying instead of C's "+0". */ + gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0); cv = 0; if (gv && (cv = GvCV(gv)) && CvHASGV(cv)) { const HEK * const gvhek = CvGvNAME_HEK(cv); @@ -2916,49 +2938,49 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) if (memEQs(HEK_KEY(gvhek), HEK_LEN(gvhek), "nil") && stashek && memEQs(HEK_KEY(stashek), HEK_LEN(stashek), "overload")) { - /* This is a hack to support autoloading..., while - knowing *which* methods were declared as overloaded. */ - /* GvSV contains the name of the method. */ - GV *ngv = NULL; - SV *gvsv = GvSV(gv); - - DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%" SVf256\ - "\" for overloaded \"%s\" in package \"%.256s\"\n", - (void*)GvSV(gv), cp, HvNAME(stash)) ); - if (!gvsv || !SvPOK(gvsv) - || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0))) - { - /* Can be an import stub (created by "can"). */ - if (destructing) { - return -1; - } - else { - const SV * const name = (gvsv && SvPOK(gvsv)) + /* This is a hack to support autoloading..., while + knowing *which* methods were declared as overloaded. */ + /* GvSV contains the name of the method. */ + GV *ngv = NULL; + SV *gvsv = GvSV(gv); + + DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%" SVf256\ + "\" for overloaded \"%s\" in package \"%.256s\"\n", + (void*)GvSV(gv), cp, HvNAME(stash)) ); + if (!gvsv || !SvPOK(gvsv) + || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0))) + { + /* Can be an import stub (created by "can"). */ + if (destructing) { + return -1; + } + else { + const SV * const name = (gvsv && SvPOK(gvsv)) ? gvsv : newSVpvs_flags("???", SVs_TEMP); - /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */ - Perl_croak(aTHX_ "%s method \"%" SVf256 - "\" overloading \"%s\" "\ - "in package \"%" HEKf256 "\"", - (GvCVGEN(gv) ? "Stub found while resolving" - : "Can't resolve"), - SVfARG(name), cp, + /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */ + Perl_croak(aTHX_ "%s method \"%" SVf256 + "\" overloading \"%s\" "\ + "in package \"%" HEKf256 "\"", + (GvCVGEN(gv) ? "Stub found while resolving" + : "Can't resolve"), + SVfARG(name), cp, HEKfARG( - HvNAME_HEK(stash) - )); - } - } - cv = GvCV(gv = ngv); - } - DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n", - cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))), - GvNAME(CvGV(cv))) ); - filled = 1; - } else if (gv) { /* Autoloaded... */ - cv = MUTABLE_CV(gv); - filled = 1; - } - amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv)); + HvNAME_HEK(stash) + )); + } + } + cv = GvCV(gv = ngv); + } + DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n", + cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))), + GvNAME(CvGV(cv))) ); + filled = 1; + } else if (gv) { /* Autoloaded... */ + cv = MUTABLE_CV(gv); + filled = 1; + } + amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv)); if (gv) { switch (i) { @@ -2982,7 +3004,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) if (filled) { AMT_AMAGIC_on(&amt); sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, - (char*)&amt, sizeof(AMT)); + (char*)&amt, sizeof(AMT)); return TRUE; } } @@ -2990,7 +3012,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) no_table: AMT_AMAGIC_off(&amt); sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, - (char*)&amt, sizeof(AMTS)); + (char*)&amt, sizeof(AMTS)); return 0; } @@ -3012,27 +3034,27 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); if (!mg) { do_update: - if (Gv_AMupdate(stash, 0) == -1) - return NULL; - mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); + if (Gv_AMupdate(stash, 0) == -1) + return NULL; + mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); } assert(mg); amtp = (AMT*)mg->mg_ptr; if ( amtp->was_ok_sub != newgen ) - goto do_update; + goto do_update; if (AMT_AMAGIC(amtp)) { - CV * const ret = amtp->table[id]; - if (ret && isGV(ret)) { /* Autoloading stab */ - /* Passing it through may have resulted in a warning - "Inherited AUTOLOAD for a non-method deprecated", since - our caller is going through a function call, not a method call. - So return the CV for AUTOLOAD, setting $AUTOLOAD. */ - GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]); - - if (gv && GvCV(gv)) - return GvCV(gv); - } - return ret; + CV * const ret = amtp->table[id]; + if (ret && isGV(ret)) { /* Autoloading stab */ + /* Passing it through may have resulted in a warning + "Inherited AUTOLOAD for a non-method deprecated", since + our caller is going through a function call, not a method call. + So return the CV for AUTOLOAD, setting $AUTOLOAD. */ + GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]); + + if (gv && GvCV(gv)) + return GvCV(gv); + } + return ret; } return NULL; @@ -3042,7 +3064,7 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) /* Implement tryAMAGICun_MG macro. Do get magic, then see if the stack arg is overloaded and if so call it. Flags: - AMGf_numeric apply sv_2num to the stack arg. + AMGf_numeric apply sv_2num to the stack arg. */ bool @@ -3054,8 +3076,8 @@ Perl_try_amagic_un(pTHX_ int method, int flags) { SvGETMAGIC(arg); if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method, - AMGf_noright | AMGf_unary - | (flags & AMGf_numarg)))) + AMGf_noright | AMGf_unary + | (flags & AMGf_numarg)))) { /* where the op is of the form: * $lex = $x op $y (where the assign is optimised away) @@ -3072,12 +3094,12 @@ Perl_try_amagic_un(pTHX_ int method, int flags) { else SETs(tmpsv); - PUTBACK; - return TRUE; + PUTBACK; + return TRUE; } if ((flags & AMGf_numeric) && SvROK(arg)) - *sp = sv_2num(arg); + *sp = sv_2num(arg); return FALSE; } @@ -3086,8 +3108,8 @@ Perl_try_amagic_un(pTHX_ int method, int flags) { Do get magic, then see if the two stack args are overloaded and if so call it. Flags: - AMGf_assign op may be called as mutator (eg +=) - AMGf_numeric apply sv_2num to the stack arg. + AMGf_assign op may be called as mutator (eg +=) + AMGf_numeric apply sv_2num to the stack arg. */ bool @@ -3098,17 +3120,17 @@ Perl_try_amagic_bin(pTHX_ int method, int flags) { SvGETMAGIC(left); if (left != right) - SvGETMAGIC(right); + SvGETMAGIC(right); if (SvAMAGIC(left) || SvAMAGIC(right)) { - SV * tmpsv; + SV * tmpsv; /* STACKED implies mutator variant, e.g. $x += 1 */ bool mutator = (flags & AMGf_assign) && (PL_op->op_flags & OPf_STACKED); - tmpsv = amagic_call(left, right, method, - (mutator ? AMGf_assign: 0) - | (flags & AMGf_numarg)); - if (tmpsv) { + tmpsv = amagic_call(left, right, method, + (mutator ? AMGf_assign: 0) + | (flags & AMGf_numarg)); + if (tmpsv) { (void)POPs; /* where the op is one of the two forms: * $x op= $y @@ -3128,28 +3150,28 @@ Perl_try_amagic_bin(pTHX_ int method, int flags) { else SETs(tmpsv); - PUTBACK; - return TRUE; - } + PUTBACK; + return TRUE; + } } if(left==right && SvGMAGICAL(left)) { - SV * const left = sv_newmortal(); - *(sp-1) = left; - /* Print the uninitialized warning now, so it includes the vari- - able name. */ - if (!SvOK(right)) { - if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right); - sv_setsv_flags(left, &PL_sv_no, 0); - } - else sv_setsv_flags(left, right, 0); - SvGETMAGIC(right); + SV * const left = sv_newmortal(); + *(sp-1) = left; + /* Print the uninitialized warning now, so it includes the vari- + able name. */ + if (!SvOK(right)) { + if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right); + sv_setsv_flags(left, &PL_sv_no, 0); + } + else sv_setsv_flags(left, right, 0); + SvGETMAGIC(right); } if (flags & AMGf_numeric) { - if (SvROK(TOPm1s)) - *(sp-1) = sv_2num(TOPm1s); - if (SvROK(right)) - *sp = sv_2num(right); + if (SvROK(TOPm1s)) + *(sp-1) = sv_2num(TOPm1s); + if (SvROK(right)) + *sp = sv_2num(right); } return FALSE; } @@ -3170,14 +3192,14 @@ Perl_amagic_deref_call(pTHX_ SV *ref, int method) { return ref; while ((tmpsv = amagic_call(ref, &PL_sv_undef, method, - AMGf_noright | AMGf_unary))) { - if (!SvROK(tmpsv)) - Perl_croak(aTHX_ "Overloaded dereference did not return a reference"); - if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) { - /* Bail out if it returns us the same reference. */ - return tmpsv; - } - ref = tmpsv; + AMGf_noright | AMGf_unary))) { + if (!SvROK(tmpsv)) + Perl_croak(aTHX_ "Overloaded dereference did not return a reference"); + if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) { + /* Bail out if it returns us the same reference. */ + return tmpsv; + } + ref = tmpsv; if (!SvAMAGIC(ref)) break; } @@ -3192,19 +3214,19 @@ Perl_amagic_is_enabled(pTHX_ int method) assert(PL_curcop->cop_hints & HINT_NO_AMAGIC); if ( !lex_mask || !SvOK(lex_mask) ) - /* overloading lexically disabled */ - return FALSE; + /* overloading lexically disabled */ + return FALSE; else if ( lex_mask && SvPOK(lex_mask) ) { - /* we have an entry in the hints hash, check if method has been - * masked by overloading.pm */ - STRLEN len; - const int offset = method / 8; - const int bit = method % 8; - char *pv = SvPV(lex_mask, len); - - /* Bit set, so this overloading operator is disabled */ - if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) ) - return FALSE; + /* we have an entry in the hints hash, check if method has been + * masked by overloading.pm */ + STRLEN len; + const int offset = method / 8; + const int bit = method % 8; + char *pv = SvPV(lex_mask, len); + + /* Bit set, so this overloading operator is disabled */ + if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) ) + return FALSE; } return TRUE; } @@ -3237,16 +3259,16 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash) && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table)) && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) - ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table - : NULL)) + ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table + : NULL)) && ((cv = cvp[off=method+assignshift]) - || (assign && amtp->fallback > AMGfallNEVER && /* fallback to - * usual method */ - ( + || (assign && amtp->fallback > AMGfallNEVER && /* fallback to + * usual method */ + ( #ifdef DEBUGGING - fl = 1, + fl = 1, #endif - cv = cvp[off=method])))) { + cv = cvp[off=method])))) { lr = -1; /* Call method for left argument */ } else { if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) { @@ -3254,30 +3276,30 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) /* look for substituted methods */ /* In all the covered cases we should be called with assign==0. */ - switch (method) { - case inc_amg: - force_cpy = 1; - if ((cv = cvp[off=add_ass_amg]) - || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) { - right = &PL_sv_yes; lr = -1; assign = 1; - } - break; - case dec_amg: - force_cpy = 1; - if ((cv = cvp[off = subtr_ass_amg]) - || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) { - right = &PL_sv_yes; lr = -1; assign = 1; - } - break; - case bool__amg: - (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg])); - break; - case numer_amg: - (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg])); - break; - case string_amg: - (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg])); - break; + switch (method) { + case inc_amg: + force_cpy = 1; + if ((cv = cvp[off=add_ass_amg]) + || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) { + right = &PL_sv_yes; lr = -1; assign = 1; + } + break; + case dec_amg: + force_cpy = 1; + if ((cv = cvp[off = subtr_ass_amg]) + || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) { + right = &PL_sv_yes; lr = -1; assign = 1; + } + break; + case bool__amg: + (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg])); + break; + case numer_amg: + (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg])); + break; + case string_amg: + (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg])); + break; case not_amg: (void)((cv = cvp[off=bool__amg]) || (cv = cvp[off=numer_amg]) @@ -3285,115 +3307,115 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) if (cv) postpr = 1; break; - case copy_amg: - { - /* - * SV* ref causes confusion with the interpreter variable of - * the same name - */ - SV* const tmpRef=SvRV(left); - if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) { - /* - * Just to be extra cautious. Maybe in some - * additional cases sv_setsv is safe, too. - */ - SV* const newref = newSVsv(tmpRef); - SvOBJECT_on(newref); - /* No need to do SvAMAGIC_on here, as SvAMAGIC macros - delegate to the stash. */ - SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef)))); - return newref; - } - } - break; - case abs_amg: - if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg]) - && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) { - SV* const nullsv=&PL_sv_zero; - if (off1==lt_amg) { - SV* const lessp = amagic_call(left,nullsv, - lt_amg,AMGf_noright); - logic = SvTRUE_NN(lessp); - } else { - SV* const lessp = amagic_call(left,nullsv, - ncmp_amg,AMGf_noright); - logic = (SvNV(lessp) < 0); - } - if (logic) { - if (off==subtr_amg) { - right = left; - left = nullsv; - lr = 1; - } - } else { - return left; - } - } - break; - case neg_amg: - if ((cv = cvp[off=subtr_amg])) { - right = left; - left = &PL_sv_zero; - lr = 1; - } - break; - case int_amg: - case iter_amg: /* XXXX Eventually should do to_gv. */ - case ftest_amg: /* XXXX Eventually should do to_gv. */ - case regexp_amg: - /* FAIL safe */ - return NULL; /* Delegate operation to standard mechanisms. */ - - case to_sv_amg: - case to_av_amg: - case to_hv_amg: - case to_gv_amg: - case to_cv_amg: - /* FAIL safe */ - return left; /* Delegate operation to standard mechanisms. */ - - default: - goto not_found; - } - if (!cv) goto not_found; + case copy_amg: + { + /* + * SV* ref causes confusion with the interpreter variable of + * the same name + */ + SV* const tmpRef=SvRV(left); + if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) { + /* + * Just to be extra cautious. Maybe in some + * additional cases sv_setsv is safe, too. + */ + SV* const newref = newSVsv(tmpRef); + SvOBJECT_on(newref); + /* No need to do SvAMAGIC_on here, as SvAMAGIC macros + delegate to the stash. */ + SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef)))); + return newref; + } + } + break; + case abs_amg: + if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg]) + && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) { + SV* const nullsv=&PL_sv_zero; + if (off1==lt_amg) { + SV* const lessp = amagic_call(left,nullsv, + lt_amg,AMGf_noright); + logic = SvTRUE_NN(lessp); + } else { + SV* const lessp = amagic_call(left,nullsv, + ncmp_amg,AMGf_noright); + logic = (SvNV(lessp) < 0); + } + if (logic) { + if (off==subtr_amg) { + right = left; + left = nullsv; + lr = 1; + } + } else { + return left; + } + } + break; + case neg_amg: + if ((cv = cvp[off=subtr_amg])) { + right = left; + left = &PL_sv_zero; + lr = 1; + } + break; + case int_amg: + case iter_amg: /* XXXX Eventually should do to_gv. */ + case ftest_amg: /* XXXX Eventually should do to_gv. */ + case regexp_amg: + /* FAIL safe */ + return NULL; /* Delegate operation to standard mechanisms. */ + + case to_sv_amg: + case to_av_amg: + case to_hv_amg: + case to_gv_amg: + case to_cv_amg: + /* FAIL safe */ + return left; /* Delegate operation to standard mechanisms. */ + + default: + goto not_found; + } + if (!cv) goto not_found; } else if (!(AMGf_noright & flags) && SvAMAGIC(right) - && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash) - && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table)) - && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) - ? (amtp = (AMT*)mg->mg_ptr)->table - : NULL)) - && (cv = cvp[off=method])) { /* Method for right - * argument found */ + && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash) + && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table)) + && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) + ? (amtp = (AMT*)mg->mg_ptr)->table + : NULL)) + && (cv = cvp[off=method])) { /* Method for right + * argument found */ lr=1; } else if (((cvp && amtp->fallback > AMGfallNEVER) || (ocvp && oamtp->fallback > AMGfallNEVER)) - && !(flags & AMGf_unary)) { - /* We look for substitution for - * comparison operations and - * concatenation */ + && !(flags & AMGf_unary)) { + /* We look for substitution for + * comparison operations and + * concatenation */ if (method==concat_amg || method==concat_ass_amg - || method==repeat_amg || method==repeat_ass_amg) { - return NULL; /* Delegate operation to string conversion */ + || method==repeat_amg || method==repeat_ass_amg) { + return NULL; /* Delegate operation to string conversion */ } off = -1; switch (method) { - case lt_amg: - case le_amg: - case gt_amg: - case ge_amg: - case eq_amg: - case ne_amg: + case lt_amg: + case le_amg: + case gt_amg: + case ge_amg: + case eq_amg: + case ne_amg: off = ncmp_amg; break; - case slt_amg: - case sle_amg: - case sgt_amg: - case sge_amg: - case seq_amg: - case sne_amg: + case slt_amg: + case sle_amg: + case sgt_amg: + case sge_amg: + case seq_amg: + case sne_amg: off = scmp_amg; break; - } + } if (off != -1) { if (ocvp && (oamtp->fallback > AMGfallNEVER)) { cv = ocvp[off]; @@ -3411,51 +3433,51 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) } else { not_found: /* No method found, either report or croak */ switch (method) { - case to_sv_amg: - case to_av_amg: - case to_hv_amg: - case to_gv_amg: - case to_cv_amg: - /* FAIL safe */ - return left; /* Delegate operation to standard mechanisms. */ + case to_sv_amg: + case to_av_amg: + case to_hv_amg: + case to_gv_amg: + case to_cv_amg: + /* FAIL safe */ + return left; /* Delegate operation to standard mechanisms. */ } if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */ - notfound = 1; lr = -1; + notfound = 1; lr = -1; } else if (cvp && (cv=cvp[nomethod_amg])) { - notfound = 1; lr = 1; + notfound = 1; lr = 1; } else if ((use_default_op = (!ocvp || oamtp->fallback >= AMGfallYES) && (!cvp || amtp->fallback >= AMGfallYES)) && !DEBUG_o_TEST) { - /* Skip generating the "no method found" message. */ - return NULL; + /* Skip generating the "no method found" message. */ + return NULL; } else { - SV *msg; - if (off==-1) off=method; - msg = sv_2mortal(Perl_newSVpvf(aTHX_ - "Operation \"%s\": no method found,%sargument %s%" SVf "%s%" SVf, - AMG_id2name(method + assignshift), - (flags & AMGf_unary ? " " : "\n\tleft "), - SvAMAGIC(left)? - "in overloaded package ": - "has no overloaded magic", - SvAMAGIC(left)? - SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))): - SVfARG(&PL_sv_no), - SvAMAGIC(right)? - ",\n\tright argument in overloaded package ": - (flags & AMGf_unary - ? "" - : ",\n\tright argument has no overloaded magic"), - SvAMAGIC(right)? - SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))): - SVfARG(&PL_sv_no))); + SV *msg; + if (off==-1) off=method; + msg = sv_2mortal(Perl_newSVpvf(aTHX_ + "Operation \"%s\": no method found,%sargument %s%" SVf "%s%" SVf, + AMG_id2name(method + assignshift), + (flags & AMGf_unary ? " " : "\n\tleft "), + SvAMAGIC(left)? + "in overloaded package ": + "has no overloaded magic", + SvAMAGIC(left)? + SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))): + SVfARG(&PL_sv_no), + SvAMAGIC(right)? + ",\n\tright argument in overloaded package ": + (flags & AMGf_unary + ? "" + : ",\n\tright argument has no overloaded magic"), + SvAMAGIC(right)? + SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))): + SVfARG(&PL_sv_no))); if (use_default_op) { - DEBUG_o( Perl_deb(aTHX_ "%" SVf, SVfARG(msg)) ); - } else { - Perl_croak(aTHX_ "%" SVf, SVfARG(msg)); - } - return NULL; + DEBUG_o( Perl_deb(aTHX_ "%" SVf, SVfARG(msg)) ); + } else { + Perl_croak(aTHX_ "%" SVf, SVfARG(msg)); + } + return NULL; } force_cpy = force_cpy || assign; } @@ -3524,18 +3546,18 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) #ifdef DEBUGGING if (!notfound) { DEBUG_o(Perl_deb(aTHX_ - "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %" SVf "%s\n", - AMG_id2name(off), - method+assignshift==off? "" : - " (initially \"", - method+assignshift==off? "" : - AMG_id2name(method+assignshift), - method+assignshift==off? "" : "\")", - flags & AMGf_unary? "" : - lr==1 ? " for right argument": " for left argument", - flags & AMGf_unary? " for argument" : "", - stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)), - fl? ",\n\tassignment variant used": "") ); + "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %" SVf "%s\n", + AMG_id2name(off), + method+assignshift==off? "" : + " (initially \"", + method+assignshift==off? "" : + AMG_id2name(method+assignshift), + method+assignshift==off? "" : "\")", + flags & AMGf_unary? "" : + lr==1 ? " for right argument": " for left argument", + flags & AMGf_unary? " for argument" : "", + stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)), + fl? ",\n\tassignment variant used": "") ); } #endif /* Since we use shallow copy during assignment, we need @@ -3561,7 +3583,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) * In the latter case assignshift==0, so only notfound case is important. */ if ( (lr == -1) && ( ( (method + assignshift == off) - && (assign || (method == inc_amg) || (method == dec_amg))) + && (assign || (method == inc_amg) || (method == dec_amg))) || force_cpy) ) { /* newSVsv does not behave as advertised, so we copy missing @@ -3569,9 +3591,9 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) SV *tmpRef = SvRV(left); SV *rv_copy; if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) { - SvRV_set(left, rv_copy); - SvSETMAGIC(left); - SvREFCNT_dec_NN(tmpRef); + SvRV_set(left, rv_copy); + SvSETMAGIC(left); + SvREFCNT_dec_NN(tmpRef); } } @@ -3614,7 +3636,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) SAVEOP(); PL_op = (OP *) &myop; if (PERLDB_SUB && PL_curstash != PL_debstash) - PL_op->op_private |= OPpENTERSUB_DB; + PL_op->op_private |= OPpENTERSUB_DB; Perl_pp_pushmark(aTHX); EXTEND(SP, notfound + 5); @@ -3623,7 +3645,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no )); if (notfound) { PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift), - AMG_id2namelen(method + assignshift), SVs_TEMP)); + AMG_id2namelen(method + assignshift), SVs_TEMP)); } else if (flags & AMGf_numarg) PUSHs(&PL_sv_undef); @@ -3670,34 +3692,34 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) switch (method) { case le_amg: case sle_amg: - ans=SvIV(res)<=0; break; + ans=SvIV(res)<=0; break; case lt_amg: case slt_amg: - ans=SvIV(res)<0; break; + ans=SvIV(res)<0; break; case ge_amg: case sge_amg: - ans=SvIV(res)>=0; break; + ans=SvIV(res)>=0; break; case gt_amg: case sgt_amg: - ans=SvIV(res)>0; break; + ans=SvIV(res)>0; break; case eq_amg: case seq_amg: - ans=SvIV(res)==0; break; + ans=SvIV(res)==0; break; case ne_amg: case sne_amg: - ans=SvIV(res)!=0; break; + ans=SvIV(res)!=0; break; case inc_amg: case dec_amg: - SvSetSV(left,res); return left; + SvSetSV(left,res); return left; case not_amg: - ans=!SvTRUE_NN(res); break; + ans=!SvTRUE_NN(res); break; default: ans=0; break; } return boolSV(ans); } else if (method==copy_amg) { if (!SvROK(res)) { - Perl_croak(aTHX_ "Copy method did not return a reference"); + Perl_croak(aTHX_ "Copy method did not return a reference"); } return SvREFCNT_inc(SvRV(res)); } else { @@ -3714,10 +3736,10 @@ Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags) PERL_ARGS_ASSERT_GV_NAME_SET; if (len > I32_MAX) - Perl_croak(aTHX_ "panic: gv name too long (%" UVuf ")", (UV) len); + Perl_croak(aTHX_ "panic: gv name too long (%" UVuf ")", (UV) len); if (!(flags & GV_ADD) && GvNAME_HEK(gv)) { - unshare_hek(GvNAME_HEK(gv)); + unshare_hek(GvNAME_HEK(gv)); } PERL_HASH(hash, name, len); @@ -3758,47 +3780,47 @@ Perl_gv_try_downgrade(pTHX_ GV *gv) if (PL_phase == PERL_PHASE_DESTRUCT) return; if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) && - !SvOBJECT(gv) && !SvREADONLY(gv) && - isGV_with_GP(gv) && GvGP(gv) && - !GvINTRO(gv) && GvREFCNT(gv) == 1 && - !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) && - GvEGVx(gv) == gv && (stash = GvSTASH(gv)))) - return; + !SvOBJECT(gv) && !SvREADONLY(gv) && + isGV_with_GP(gv) && GvGP(gv) && + !GvINTRO(gv) && GvREFCNT(gv) == 1 && + !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) && + GvEGVx(gv) == gv && (stash = GvSTASH(gv)))) + return; if (gv == PL_statgv || gv == PL_last_in_gv || gv == PL_stderrgv) - return; + return; if (SvMAGICAL(gv)) { MAGIC *mg; - /* only backref magic is allowed */ - if (SvGMAGICAL(gv) || SvSMAGICAL(gv)) - return; + /* only backref magic is allowed */ + if (SvGMAGICAL(gv) || SvSMAGICAL(gv)) + return; for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) { if (mg->mg_type != PERL_MAGIC_backref) return; - } + } } cv = GvCV(gv); if (!cv) { - HEK *gvnhek = GvNAME_HEK(gv); - (void)hv_deletehek(stash, gvnhek, G_DISCARD); + HEK *gvnhek = GvNAME_HEK(gv); + (void)hv_deletehek(stash, gvnhek, G_DISCARD); } else if (GvMULTI(gv) && cv && SvREFCNT(cv) == 1 && - !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) && - CvSTASH(cv) == stash && !CvNAMED(cv) && CvGV(cv) == gv && - CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) && - !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) && - (namehek = GvNAME_HEK(gv)) && - (gvp = hv_fetchhek(stash, namehek, 0)) && - *gvp == (SV*)gv) { - SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr); - const bool imported = !!GvIMPORTED_CV(gv); - SvREFCNT(gv) = 0; - sv_clear((SV*)gv); - SvREFCNT(gv) = 1; - SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported; + !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) && + CvSTASH(cv) == stash && !CvNAMED(cv) && CvGV(cv) == gv && + CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) && + !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) && + (namehek = GvNAME_HEK(gv)) && + (gvp = hv_fetchhek(stash, namehek, 0)) && + *gvp == (SV*)gv) { + SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr); + const bool imported = !!GvIMPORTED_CV(gv); + SvREFCNT(gv) = 0; + sv_clear((SV*)gv); + SvREFCNT(gv) = 1; + SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported; /* See also: 'SET_SVANY_FOR_BODYLESS_IV' in sv.c */ - SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) - - STRUCT_OFFSET(XPVIV, xiv_iv)); - SvRV_set(gv, value); + SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) - + STRUCT_OFFSET(XPVIV, xiv_iv)); + SvRV_set(gv, value); } } @@ -3812,9 +3834,9 @@ Perl_gv_override(pTHX_ const char * const name, const STRLEN len) gvp = (GV**)hv_fetch(PL_globalstash, name, len, FALSE); gv = gvp ? *gvp : NULL; if (gv && !isGV(gv)) { - if (!SvPCS_IMPORTED(gv)) return NULL; - gv_init(gv, PL_globalstash, name, len, 0); - return gv; + if (!SvPCS_IMPORTED(gv)) return NULL; + gv_init(gv, PL_globalstash, name, len, 0); + return gv; } return gv && GvCVu(gv) && GvIMPORTED_CV(gv) ? gv : NULL; } diff --git a/gv.h b/gv.h index 6ac99814f6c2..514bac18713e 100644 --- a/gv.h +++ b/gv.h @@ -28,32 +28,32 @@ struct gp { #if defined (DEBUGGING) && defined(PERL_USE_GCC_BRACE_GROUPS) && !defined(__INTEL_COMPILER) # define GvGP(gv) \ - (0+(*({GV *const _gvgp = (GV *) (gv); \ - assert(SvTYPE(_gvgp) == SVt_PVGV || SvTYPE(_gvgp) == SVt_PVLV); \ - assert(isGV_with_GP(_gvgp)); \ - &((_gvgp)->sv_u.svu_gp);}))) + (0+(*({GV *const _gvgp = (GV *) (gv); \ + assert(SvTYPE(_gvgp) == SVt_PVGV || SvTYPE(_gvgp) == SVt_PVLV); \ + assert(isGV_with_GP(_gvgp)); \ + &((_gvgp)->sv_u.svu_gp);}))) # define GvGP_set(gv,gp) \ - {GV *const _gvgp = (GV *) (gv); \ - assert(SvTYPE(_gvgp) == SVt_PVGV || SvTYPE(_gvgp) == SVt_PVLV); \ - assert(isGV_with_GP(_gvgp)); \ - (_gvgp)->sv_u.svu_gp = (gp); } + {GV *const _gvgp = (GV *) (gv); \ + assert(SvTYPE(_gvgp) == SVt_PVGV || SvTYPE(_gvgp) == SVt_PVLV); \ + assert(isGV_with_GP(_gvgp)); \ + (_gvgp)->sv_u.svu_gp = (gp); } # define GvFLAGS(gv) \ - (*({GV *const _gvflags = (GV *) (gv); \ - assert(SvTYPE(_gvflags) == SVt_PVGV || SvTYPE(_gvflags) == SVt_PVLV); \ - assert(isGV_with_GP(_gvflags)); \ - &(GvXPVGV(_gvflags)->xpv_cur);})) + (*({GV *const _gvflags = (GV *) (gv); \ + assert(SvTYPE(_gvflags) == SVt_PVGV || SvTYPE(_gvflags) == SVt_PVLV); \ + assert(isGV_with_GP(_gvflags)); \ + &(GvXPVGV(_gvflags)->xpv_cur);})) # define GvSTASH(gv) \ - (*({ GV * const _gvstash = (GV *) (gv); \ - assert(isGV_with_GP(_gvstash)); \ - assert(SvTYPE(_gvstash) == SVt_PVGV || SvTYPE(_gvstash) >= SVt_PVLV); \ - &(GvXPVGV(_gvstash)->xnv_u.xgv_stash); \ - })) + (*({ GV * const _gvstash = (GV *) (gv); \ + assert(isGV_with_GP(_gvstash)); \ + assert(SvTYPE(_gvstash) == SVt_PVGV || SvTYPE(_gvstash) >= SVt_PVLV); \ + &(GvXPVGV(_gvstash)->xnv_u.xgv_stash); \ + })) # define GvNAME_HEK(gv) \ (*({ GV * const _gvname_hek = (GV *) (gv); \ - assert(isGV_with_GP(_gvname_hek)); \ - assert(SvTYPE(_gvname_hek) == SVt_PVGV || SvTYPE(_gvname_hek) >= SVt_PVLV); \ - &(GvXPVGV(_gvname_hek)->xiv_u.xivu_namehek); \ - })) + assert(isGV_with_GP(_gvname_hek)); \ + assert(SvTYPE(_gvname_hek) == SVt_PVGV || SvTYPE(_gvname_hek) >= SVt_PVLV); \ + &(GvXPVGV(_gvname_hek)->xiv_u.xivu_namehek); \ + })) # define GvNAME_get(gv) ({ assert(GvNAME_HEK(gv)); (char *)HEK_KEY(GvNAME_HEK(gv)); }) # define GvNAMELEN_get(gv) ({ assert(GvNAME_HEK(gv)); HEK_LEN(GvNAME_HEK(gv)); }) # define GvNAMEUTF8(gv) ({ assert(GvNAME_HEK(gv)); HEK_UTF8(GvNAME_HEK(gv)); }) @@ -101,8 +101,8 @@ Return the CV from the GV. #define GvSV(gv) (GvGP(gv)->gp_sv) #ifdef PERL_DONT_CREATE_GVSV #define GvSVn(gv) (*(GvGP(gv)->gp_sv ? \ - &(GvGP(gv)->gp_sv) : \ - &(GvGP(gv_SVadd(gv))->gp_sv))) + &(GvGP(gv)->gp_sv) : \ + &(GvGP(gv_SVadd(gv))->gp_sv))) #else #define GvSVn(gv) GvSV(gv) #endif @@ -126,13 +126,13 @@ Return the CV from the GV. #define GvAV(gv) (GvGP(gv)->gp_av) #define GvAVn(gv) (GvGP(gv)->gp_av ? \ - GvGP(gv)->gp_av : \ - GvGP(gv_AVadd(gv))->gp_av) + GvGP(gv)->gp_av : \ + GvGP(gv_AVadd(gv))->gp_av) #define GvHV(gv) ((GvGP(gv))->gp_hv) #define GvHVn(gv) (GvGP(gv)->gp_hv ? \ - GvGP(gv)->gp_hv : \ - GvGP(gv_HVadd(gv))->gp_hv) + GvGP(gv)->gp_hv : \ + GvGP(gv_HVadd(gv))->gp_hv) #define GvCV(gv) (0+GvGP(gv)->gp_cv) #define GvCV_set(gv,cv) (GvGP(gv)->gp_cv = (cv)) @@ -221,27 +221,27 @@ Return the CV from the GV. * symbol creation flags, for use in gv_fetchpv() and get_*v() */ #define GV_ADD 0x01 /* add, if symbol not already there - For gv_name_set, adding a HEK for the first - time, so don't try to free what's there. */ + For gv_name_set, adding a HEK for the first + time, so don't try to free what's there. */ #define GV_ADDMULTI 0x02 /* add, pretending it has been added - already; used also by gv_init_* */ + already; used also by gv_init_* */ #define GV_ADDWARN 0x04 /* add, but warn if symbol wasn't already there */ - /* 0x08 UNUSED */ + /* 0x08 UNUSED */ #define GV_NOINIT 0x10 /* add, but don't init symbol, if type != PVGV */ /* This is used by toke.c to avoid turing placeholder constants in the symbol table into full PVGVs with attached constant subroutines. */ #define GV_NOADD_NOINIT 0x20 /* Don't add the symbol if it's not there. - Don't init it if it is there but ! PVGV */ + Don't init it if it is there but ! PVGV */ #define GV_NOEXPAND 0x40 /* Don't expand SvOK() entries to PVGV */ #define GV_NOTQUAL 0x80 /* A plain symbol name, not qualified with a - package (so skip checks for :: and ') */ + package (so skip checks for :: and ') */ #define GV_AUTOLOAD 0x100 /* gv_fetchmethod_flags() should AUTOLOAD */ #define GV_CROAK 0x200 /* gv_fetchmethod_flags() should croak */ #define GV_ADDMG 0x400 /* add if magical */ #define GV_NO_SVGMAGIC 0x800 /* Skip get-magic on an SV argument; - used only by gv_fetchsv(_nomg) */ + used only by gv_fetchsv(_nomg) */ #define GV_CACHE_ONLY 0x1000 /* return stash only if found in cache; - used only in flags parameter to gv_stash* family */ + used only in flags parameter to gv_stash* family */ /* Flags for gv_fetchmeth_pvn and gv_autoload_pvn*/ #define GV_SUPER 0x1000 /* SUPER::method */ @@ -250,8 +250,8 @@ Return the CV from the GV. #define GV_AUTOLOAD_ISMETHOD 1 /* autoloading a method? */ /* SVf_UTF8 (more accurately the return value from SvUTF8) is also valid - as a flag to various gv_* functions, so ensure it lies - outside this range. + as a flag to various gv_* functions, so ensure it lies + outside this range. */ #define GV_NOADD_MASK \ @@ -265,19 +265,26 @@ Return the CV from the GV. #define gv_fetchmethod(stash, name) gv_fetchmethod_autoload(stash, name, TRUE) #define gv_fetchsv_nomg(n,f,t) gv_fetchsv(n,(f)|GV_NO_SVGMAGIC,t) #define gv_init(gv,stash,name,len,multi) \ - gv_init_pvn(gv,stash,name,len,GV_ADDMULTI*!!(multi)) + gv_init_pvn(gv,stash,name,len,GV_ADDMULTI*!!(multi)) #define gv_fetchmeth(stash,name,len,level) gv_fetchmeth_pvn(stash, name, len, level, 0) #define gv_fetchmeth_autoload(stash,name,len,level) gv_fetchmeth_pvn_autoload(stash, name, len, level, 0) #define gv_fetchmethod_flags(stash,name,flags) gv_fetchmethod_pv_flags(stash, name, flags) + +/* +=for apidoc gv_autoload4 +Equivalent to C>. + +=cut +*/ #define gv_autoload4(stash, name, len, autoload) \ - gv_autoload_pvn(stash, name, len, !!(autoload)) + gv_autoload_pvn(stash, name, len, !!(autoload)) #define newGVgen(pack) newGVgen_flags(pack, 0) #define gv_method_changed(gv) \ ( \ - assert_(isGV_with_GP(gv)) \ - GvREFCNT(gv) > 1 \ - ? (void)++PL_sub_generation \ - : mro_method_changed_in(GvSTASH(gv)) \ + assert_(isGV_with_GP(gv)) \ + GvREFCNT(gv) > 1 \ + ? (void)++PL_sub_generation \ + : mro_method_changed_in(GvSTASH(gv)) \ ) #define gv_AVadd(gv) gv_add_by_type((gv), SVt_PVAV) diff --git a/handy.h b/handy.h index 01e4b9678bcd..ff47c9bcdf4b 100644 --- a/handy.h +++ b/handy.h @@ -183,13 +183,13 @@ C<(bool)!!(cbool)> in a ternary triggers a bug in xlc on AIX For dealing with issues that may arise from various 32/64-bit systems, we will ask Configure to check out - SHORTSIZE == sizeof(short) - INTSIZE == sizeof(int) - LONGSIZE == sizeof(long) - LONGLONGSIZE == sizeof(long long) (if HAS_LONG_LONG) - PTRSIZE == sizeof(void *) - DOUBLESIZE == sizeof(double) - LONG_DOUBLESIZE == sizeof(long double) (if HAS_LONG_DOUBLE). + SHORTSIZE == sizeof(short) + INTSIZE == sizeof(int) + LONGSIZE == sizeof(long) + LONGLONGSIZE == sizeof(long long) (if HAS_LONG_LONG) + PTRSIZE == sizeof(void *) + DOUBLESIZE == sizeof(double) + LONG_DOUBLESIZE == sizeof(long double) (if HAS_LONG_DOUBLE). */ @@ -284,13 +284,19 @@ typedef U64TYPE U64; # define U32_MIN PERL_ULONG_MIN #endif -/* These C99 typedefs are useful sometimes for, say, loop variables whose - * maximum values are small, but for which speed trumps size. If we have a C99 - * compiler, use that. Otherwise, a plain 'int' should be good enough. - * - * Restrict these to core for now until we are more certain this is a good - * idea. */ -#if defined(PERL_CORE) || defined(PERL_EXT) +/* +=for apidoc_section $integer +=for apidoc Ay|| PERL_INT_FAST8_T +=for apidoc_item PERL_INT_FAST16_T +=for apidoc_item PERL_UINT_FAST8_T +=for apidoc_item PERL_UINT_FAST16_T + +These are equivalent to the correspondingly-named C99 typedefs on platforms +that have those; they evaluate to C and C on platforms that +don't, so that you can portably take advantage of this C99 feature. + +=cut +*/ # ifdef I_STDINT typedef int_fast8_t PERL_INT_FAST8_T; typedef uint_fast8_t PERL_UINT_FAST8_T; @@ -302,7 +308,6 @@ typedef U64TYPE U64; typedef int PERL_INT_FAST16_T; typedef unsigned int PERL_UINT_FAST16_T; # endif -#endif /* log(2) (i.e., log base 10 of 2) is pretty close to 0.30103, just in case * anyone is grepping for it. So BIT_DIGITS gives the number of decimal digits @@ -350,7 +355,7 @@ assert(), we would get a comma with nothing before it when not DEBUGGING. =cut -We also use empty definition under Coverity since the __ASSERT__ +We also use empty definition under Coverity since the __ASSERT_ checks often check for things that Really Cannot Happen, and Coverity detects that and gets all excited. */ @@ -489,7 +494,7 @@ Perl_xxx(aTHX_ ...) form for any API calls where it's used. #define lex_stuff_pvs(pv,flags) Perl_lex_stuff_pvn(aTHX_ STR_WITH_LEN(pv), flags) #define get_cvs(str, flags) \ - Perl_get_cvn_flags(aTHX_ STR_WITH_LEN(str), (flags)) + Perl_get_cvn_flags(aTHX_ STR_WITH_LEN(str), (flags)) /* internal helpers */ /* Transitional */ @@ -626,22 +631,24 @@ wrapper for C). =for apidoc Am|bool|memEQ|char* s1|char* s2|STRLEN len Test two buffers (which may contain embedded C characters, to see if they are equal. The C parameter indicates the number of bytes to compare. -Returns zero if equal, or non-zero if non-equal. +Returns true or false. It is undefined behavior if either of the buffers +doesn't contain at least C bytes. =for apidoc Am|bool|memEQs|char* s1|STRLEN l1|"s2" Like L, but the second string is a literal enclosed in double quotes, C gives the number of bytes in C. -Returns zero if equal, or non-zero if non-equal. +Returns true or false. =for apidoc Am|bool|memNE|char* s1|char* s2|STRLEN len Test two buffers (which may contain embedded C characters, to see if they are not equal. The C parameter indicates the number of bytes to compare. -Returns zero if non-equal, or non-zero if equal. +Returns true or false. It is undefined behavior if either of the buffers +doesn't contain at least C bytes. =for apidoc Am|bool|memNEs|char* s1|STRLEN l1|"s2" Like L, but the second string is a literal enclosed in double quotes, C gives the number of bytes in C. -Returns zero if non-equal, or zero if non-equal. +Returns true or false. =for apidoc Am|bool|memCHRs|"list"|char c Returns the position of the first occurence of the byte C in the literal @@ -1402,18 +1409,33 @@ or casts * needed. (The NV casts stop any warnings about comparison always being true * if called with an unsigned. The cast preserves the sign, which is all we * care about.) */ -#define withinCOUNT(c, l, n) (__ASSERT_((NV) (l) >= 0) \ - __ASSERT_((NV) (n) >= 0) \ - (((WIDEST_UTYPE) (((c)) - ((l) | 0))) <= (((WIDEST_UTYPE) ((n) | 0))))) +#define withinCOUNT(c, l, n) (__ASSERT_((NV) (l) >= 0) \ + __ASSERT_((NV) (n) >= 0) \ + withinCOUNT_KNOWN_VALID_((c), (l), (n))) + +/* For internal use only, this can be used in places where it is known that the + * parameters to withinCOUNT() are valid, to avoid the asserts. For example, + * inRANGE() below, calls this several times, but does all the necessary + * asserts itself, once. The reason that this is necessary is that the + * duplicate asserts were exceeding the internal limits of some compilers */ +#define withinCOUNT_KNOWN_VALID_(c, l, n) \ + (((WIDEST_UTYPE) (((c)) - ((l) | 0))) <= (((WIDEST_UTYPE) ((n) | 0)))) /* Returns true if c is in the range l..u, where 'l' is non-negative * Written this way so that after optimization, only one conditional test is * needed. */ -#define inRANGE(c, l, u) (__ASSERT_((u) >= (l)) \ - ( (sizeof(c) == sizeof(U8)) ? withinCOUNT(((U8) (c)), (l), ((u) - (l))) \ - : (sizeof(c) == sizeof(U32)) ? withinCOUNT(((U32) (c)), (l), ((u) - (l))) \ - : (__ASSERT_(sizeof(c) == sizeof(WIDEST_UTYPE)) \ - withinCOUNT(((WIDEST_UTYPE) (c)), (l), ((u) - (l)))))) +#define inRANGE(c, l, u) (__ASSERT_((NV) (l) >= 0) __ASSERT_((u) >= (l)) \ + ( (sizeof(c) == sizeof(U8)) ? inRANGE_helper_(U8, (c), (l), ((u))) \ + : (sizeof(c) == sizeof(U16)) ? inRANGE_helper_(U16,(c), (l), ((u))) \ + : (sizeof(c) == sizeof(U32)) ? inRANGE_helper_(U32,(c), (l), ((u))) \ + : (__ASSERT_(sizeof(c) == sizeof(WIDEST_UTYPE)) \ + inRANGE_helper_(WIDEST_UTYPE,(c), (l), ((u)))))) + +/* For internal use, this is used by machine-generated code which generates + * known valid calls, with a known sizeof(). This avoids the extra code and + * asserts that were exceeding internal limits of some compilers. */ +#define inRANGE_helper_(cast, c, l, u) \ + withinCOUNT_KNOWN_VALID_(((cast) (c)), (l), ((u) - (l))) #ifdef EBCDIC # ifndef _ALL_SOURCE @@ -1611,16 +1633,21 @@ END_EXTERN_C # endif /* Participates in a single-character fold with a character above 255 */ -# define _HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(c) ((! cBOOL(FITS_IN_8_BITS(c))) || (PL_charclass[(U8) (c)] & _CC_mask(_CC_NONLATIN1_SIMPLE_FOLD))) +# if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C) +# define HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(c) \ + (( ! cBOOL(FITS_IN_8_BITS(c))) \ + || (PL_charclass[(U8) (c)] & _CC_mask(_CC_NONLATIN1_SIMPLE_FOLD))) + +# define IS_NON_FINAL_FOLD(c) _generic_isCC(c, _CC_NON_FINAL_FOLD) +# define IS_IN_SOME_FOLD_L1(c) _generic_isCC(c, _CC_IS_IN_SOME_FOLD) +# endif /* Like the above, but also can be part of a multi-char fold */ -# define _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(c) ((! cBOOL(FITS_IN_8_BITS(c))) || (PL_charclass[(U8) (c)] & _CC_mask(_CC_NONLATIN1_FOLD))) +# define HAS_NONLATIN1_FOLD_CLOSURE(c) \ + ( (! cBOOL(FITS_IN_8_BITS(c))) \ + || (PL_charclass[(U8) (c)] & _CC_mask(_CC_NONLATIN1_FOLD))) # define _isQUOTEMETA(c) _generic_isCC(c, _CC_QUOTEMETA) -# define _IS_NON_FINAL_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c) \ - _generic_isCC(c, _CC_NON_FINAL_FOLD) -# define _IS_IN_SOME_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c) \ - _generic_isCC(c, _CC_IS_IN_SOME_FOLD) /* is c a control character for which we have a mnemonic? */ # if defined(PERL_CORE) || defined(PERL_EXT) @@ -2402,22 +2429,29 @@ END_EXTERN_C : (LATIN1_TO_NATIVE(((U8) (c)) ^ 64))))) #endif -/* Line numbers are unsigned, 32 bits. */ +/* +=for apidoc Ay||line_t +The typedef to use to declare variables that are to hold line numbers. + +=cut + + Line numbers are unsigned, 32 bits. +*/ typedef U32 line_t; #define NOLINE ((line_t) 4294967295UL) /* = FFFFFFFF */ /* Helpful alias for version prescan */ #define is_LAX_VERSION(a,b) \ - (a != Perl_prescan_version(aTHX_ a, FALSE, b, NULL, NULL, NULL, NULL)) + (a != Perl_prescan_version(aTHX_ a, FALSE, b, NULL, NULL, NULL, NULL)) #define is_STRICT_VERSION(a,b) \ - (a != Perl_prescan_version(aTHX_ a, TRUE, b, NULL, NULL, NULL, NULL)) + (a != Perl_prescan_version(aTHX_ a, TRUE, b, NULL, NULL, NULL, NULL)) #define BADVERSION(a,b,c) \ - if (b) { \ - *b = c; \ - } \ - return a; + if (b) { \ + *b = c; \ + } \ + return a; /* Converts a character KNOWN to represent a hexadecimal digit (0-9, A-F, or * a-f) to its numeric value without using any branches. The input is @@ -2605,17 +2639,17 @@ PoisonWith(0xEF) for catching access to freed memory. MEM_SIZE_MAX/sizeof(t)) > MEM_SIZE_MAX/sizeof(t)) # define MEM_WRAP_CHECK(n,t) \ - (void)(UNLIKELY(_MEM_WRAP_WILL_WRAP(n,t)) \ + (void)(UNLIKELY(_MEM_WRAP_WILL_WRAP(n,t)) \ && (croak_memory_wrap(),0)) # define MEM_WRAP_CHECK_1(n,t,a) \ - (void)(UNLIKELY(_MEM_WRAP_WILL_WRAP(n,t)) \ - && (Perl_croak_nocontext("%s",(a)),0)) + (void)(UNLIKELY(_MEM_WRAP_WILL_WRAP(n,t)) \ + && (Perl_croak_nocontext("%s",(a)),0)) /* "a" arg must be a string literal */ # define MEM_WRAP_CHECK_s(n,t,a) \ - (void)(UNLIKELY(_MEM_WRAP_WILL_WRAP(n,t)) \ - && (Perl_croak_nocontext("" a ""),0)) + (void)(UNLIKELY(_MEM_WRAP_WILL_WRAP(n,t)) \ + && (Perl_croak_nocontext("" a ""),0)) #define MEM_WRAP_CHECK_(n,t) MEM_WRAP_CHECK(n,t), @@ -2710,9 +2744,9 @@ void Perl_mem_log_del_sv(const SV *sv, const char *filename, const int linenumbe #endif #define Renew(v,n,t) \ - (v = (MEM_WRAP_CHECK_(n,t) (t*)MEM_LOG_REALLOC(n,t,v,saferealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t)))))) + (v = (MEM_WRAP_CHECK_(n,t) (t*)MEM_LOG_REALLOC(n,t,v,saferealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t)))))) #define Renewc(v,n,t,c) \ - (v = (MEM_WRAP_CHECK_(n,t) (c*)MEM_LOG_REALLOC(n,t,v,saferealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t)))))) + (v = (MEM_WRAP_CHECK_(n,t) (c*)MEM_LOG_REALLOC(n,t,v,saferealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t)))))) #ifdef PERL_POISON #define Safefree(d) \ @@ -2747,6 +2781,7 @@ void Perl_mem_log_del_sv(const SV *sv, const char *filename, const int linenumbe # define PERL_POISON_EXPR(x) #endif +/* Shallow copy */ #define StructCopy(s,d,t) (*((t*)(d)) = *((t*)(s))) /* diff --git a/hints/catamount.sh b/hints/catamount.sh index d09e448874d3..b5ad550df012 100644 --- a/hints/catamount.sh +++ b/hints/catamount.sh @@ -31,11 +31,11 @@ # mkdir -p /opt/perl-catamount # mkdir -p /opt/perl-catamount/include # mkdir -p /opt/perl-catamount/lib -# mkdir -p /opt/perl-catamount/lib/perl5/5.33.4 +# mkdir -p /opt/perl-catamount/lib/perl5/5.33.7 # mkdir -p /opt/perl-catamount/bin # cp *.h /opt/perl-catamount/include # cp libperl.a /opt/perl-catamount/lib -# cp -pr lib/* /opt/perl-catamount/lib/perl5/5.33.4 +# cp -pr lib/* /opt/perl-catamount/lib/perl5/5.33.7 # cp miniperl perl run.sh cc.sh /opt/perl-catamount/lib # # With the headers and the libperl.a you can embed Perl to your Catamount diff --git a/hints/solaris_2.sh b/hints/solaris_2.sh index c6134060f7e0..e50d9d832378 100644 --- a/hints/solaris_2.sh +++ b/hints/solaris_2.sh @@ -90,7 +90,8 @@ END ` case "$cc" in -'') for i in `ls -r /opt/*studio*/bin/cc` /opt/SUNWspro/bin/cc +'') for i in `ls -r /opt/*studio*/bin/cc` /opt/SUNWspro/bin/cc \ + `which gcc` do if test -f "$i"; then cc=$i diff --git a/hints/t001.c b/hints/t001.c index 562d7597ffee..5edb855384ad 100644 --- a/hints/t001.c +++ b/hints/t001.c @@ -21,70 +21,70 @@ void test(double *result) { - float afloat; - double adouble; - int checksum = 0; - unsigned cuv = 0; - double cdouble = 0.0; - const int bits_in_uv = 8 * sizeof(cuv); + float afloat; + double adouble; + int checksum = 0; + unsigned cuv = 0; + double cdouble = 0.0; + const int bits_in_uv = 8 * sizeof(cuv); - checksum = 53; - cdouble = -1.0; + checksum = 53; + cdouble = -1.0; - if (checksum) { - if (checksum > bits_in_uv) { - double trouble; + if (checksum) { + if (checksum > bits_in_uv) { + double trouble; - adouble = (double) (1 << (checksum & 15)); + adouble = (double) (1 << (checksum & 15)); - while (checksum >= 16) { - checksum -= 16; - adouble *= 65536.0; - } + while (checksum >= 16) { + checksum -= 16; + adouble *= 65536.0; + } - /* At -O1, GCC 2.95.2 compiles the following loop - into: + /* At -O1, GCC 2.95.2 compiles the following loop + into: - L$0014 - fcmp,dbl,>= %fr4,%fr0 - ftest - b L$0014 - fadd,dbl %fr4,%fr12,%fr4 - fsub,dbl %fr4,%fr12,%fr4 + L$0014 + fcmp,dbl,>= %fr4,%fr0 + ftest + b L$0014 + fadd,dbl %fr4,%fr12,%fr4 + fsub,dbl %fr4,%fr12,%fr4 - This code depends on the floating-add and - floating-subtract retaining all of the - precision present in the operands. There is - no such guarantee when using floating-point, - as this test case demonstrates. + This code depends on the floating-add and + floating-subtract retaining all of the + precision present in the operands. There is + no such guarantee when using floating-point, + as this test case demonstrates. - The code is okay at -O0. */ + The code is okay at -O0. */ - while (cdouble < 0.0) - cdouble += adouble; + while (cdouble < 0.0) + cdouble += adouble; - cdouble = modf (cdouble / adouble, &trouble) * adouble; - } - } + cdouble = modf (cdouble / adouble, &trouble) * adouble; + } + } - *result = cdouble; + *result = cdouble; } int main (int argc, char ** argv) { double value; - test (&value); + test (&value); - if (argc == 2 && !strcmp(argv[1],"-v")) - printf ("value = %.18e\n", value); + if (argc == 2 && !strcmp(argv[1],"-v")) + printf ("value = %.18e\n", value); - if (value != 9.007199254740991e+15) { - printf ("t001 fails!\n"); - return -1; - } - else { - printf ("t001 works.\n"); - return 0; - } + if (value != 9.007199254740991e+15) { + printf ("t001 fails!\n"); + return -1; + } + else { + printf ("t001 works.\n"); + return 0; + } } diff --git a/hv.c b/hv.c index 43b9330260d6..82657cb4e9cc 100644 --- a/hv.c +++ b/hv.c @@ -57,7 +57,7 @@ S_new_he(pTHX) void ** const root = &PL_body_roots[HE_SVSLOT]; if (!*root) - Perl_more_bodies(aTHX_ HE_SVSLOT, sizeof(HE), PERL_ARENA_SIZE); + Perl_more_bodies(aTHX_ HE_SVSLOT, sizeof(HE), PERL_ARENA_SIZE); he = (HE*) *root; assert(he); *root = HeNEXT(he); @@ -67,8 +67,8 @@ S_new_he(pTHX) #define new_HE() new_he() #define del_HE(p) \ STMT_START { \ - HeNEXT(p) = (HE*)(PL_body_roots[HE_SVSLOT]); \ - PL_body_roots[HE_SVSLOT] = p; \ + HeNEXT(p) = (HE*)(PL_body_roots[HE_SVSLOT]); \ + PL_body_roots[HE_SVSLOT] = p; \ } STMT_END @@ -93,7 +93,7 @@ S_save_hek_flags(const char *str, I32 len, U32 hash, int flags) HEK_FLAGS(hek) = (unsigned char)flags_masked | HVhek_UNSHARED; if (flags & HVhek_FREEKEY) - Safefree(str); + Safefree(str); return hek; } @@ -105,10 +105,10 @@ Perl_free_tied_hv_pool(pTHX) { HE *he = PL_hv_fetch_ent_mh; while (he) { - HE * const ohe = he; - Safefree(HeKEY_hek(he)); - he = HeNEXT(he); - del_HE(ohe); + HE * const ohe = he; + Safefree(HeKEY_hek(he)); + he = HeNEXT(he); + del_HE(ohe); } PL_hv_fetch_ent_mh = NULL; } @@ -123,18 +123,18 @@ Perl_hek_dup(pTHX_ HEK *source, CLONE_PARAMS* param) PERL_UNUSED_ARG(param); if (!source) - return NULL; + return NULL; shared = (HEK*)ptr_table_fetch(PL_ptr_table, source); if (shared) { - /* We already shared this hash key. */ - (void)share_hek_hek(shared); + /* We already shared this hash key. */ + (void)share_hek_hek(shared); } else { - shared - = share_hek_flags(HEK_KEY(source), HEK_LEN(source), - HEK_HASH(source), HEK_FLAGS(source)); - ptr_table_store(PL_ptr_table, source, shared); + shared + = share_hek_flags(HEK_KEY(source), HEK_LEN(source), + HEK_HASH(source), HEK_FLAGS(source)); + ptr_table_store(PL_ptr_table, source, shared); } return shared; } @@ -147,11 +147,11 @@ Perl_he_dup(pTHX_ const HE *e, bool shared, CLONE_PARAMS* param) PERL_ARGS_ASSERT_HE_DUP; if (!e) - return NULL; + return NULL; /* look for it in the table first */ ret = (HE*)ptr_table_fetch(PL_ptr_table, e); if (ret) - return ret; + return ret; /* create anew and remember what it is */ ret = new_HE(); @@ -159,31 +159,31 @@ Perl_he_dup(pTHX_ const HE *e, bool shared, CLONE_PARAMS* param) HeNEXT(ret) = he_dup(HeNEXT(e),shared, param); if (HeKLEN(e) == HEf_SVKEY) { - char *k; - Newx(k, HEK_BASESIZE + sizeof(const SV *), char); - HeKEY_hek(ret) = (HEK*)k; - HeKEY_sv(ret) = sv_dup_inc(HeKEY_sv(e), param); + char *k; + Newx(k, HEK_BASESIZE + sizeof(const SV *), char); + HeKEY_hek(ret) = (HEK*)k; + HeKEY_sv(ret) = sv_dup_inc(HeKEY_sv(e), param); } else if (shared) { - /* This is hek_dup inlined, which seems to be important for speed - reasons. */ - HEK * const source = HeKEY_hek(e); - HEK *shared = (HEK*)ptr_table_fetch(PL_ptr_table, source); - - if (shared) { - /* We already shared this hash key. */ - (void)share_hek_hek(shared); - } - else { - shared - = share_hek_flags(HEK_KEY(source), HEK_LEN(source), - HEK_HASH(source), HEK_FLAGS(source)); - ptr_table_store(PL_ptr_table, source, shared); - } - HeKEY_hek(ret) = shared; + /* This is hek_dup inlined, which seems to be important for speed + reasons. */ + HEK * const source = HeKEY_hek(e); + HEK *shared = (HEK*)ptr_table_fetch(PL_ptr_table, source); + + if (shared) { + /* We already shared this hash key. */ + (void)share_hek_hek(shared); + } + else { + shared + = share_hek_flags(HEK_KEY(source), HEK_LEN(source), + HEK_HASH(source), HEK_FLAGS(source)); + ptr_table_store(PL_ptr_table, source, shared); + } + HeKEY_hek(ret) = shared; } else - HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e), + HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e), HeKFLAGS(e)); HeVAL(ret) = sv_dup_inc(HeVAL(e), param); return ret; @@ -192,22 +192,22 @@ Perl_he_dup(pTHX_ const HE *e, bool shared, CLONE_PARAMS* param) static void S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen, - const char *msg) + const char *msg) { SV * const sv = sv_newmortal(); PERL_ARGS_ASSERT_HV_NOTALLOWED; if (!(flags & HVhek_FREEKEY)) { - sv_setpvn(sv, key, klen); + sv_setpvn(sv, key, klen); } else { - /* Need to free saved eventually assign to mortal SV */ - /* XXX is this line an error ???: SV *sv = sv_newmortal(); */ - sv_usepvn(sv, (char *) key, klen); + /* Need to free saved eventually assign to mortal SV */ + /* XXX is this line an error ???: SV *sv = sv_newmortal(); */ + sv_usepvn(sv, (char *) key, klen); } if (flags & HVhek_UTF8) { - SvUTF8_on(sv); + SvUTF8_on(sv); } Perl_croak(aTHX_ msg, SVfARG(sv)); } @@ -321,7 +321,7 @@ information on how to use this function on tied hashes. /* Common code for hv_delete()/hv_exists()/hv_fetch()/hv_store() */ void * Perl_hv_common_key_len(pTHX_ HV *hv, const char *key, I32 klen_i32, - const int action, SV *val, const U32 hash) + const int action, SV *val, const U32 hash) { STRLEN klen; int flags; @@ -329,18 +329,18 @@ Perl_hv_common_key_len(pTHX_ HV *hv, const char *key, I32 klen_i32, PERL_ARGS_ASSERT_HV_COMMON_KEY_LEN; if (klen_i32 < 0) { - klen = -klen_i32; - flags = HVhek_UTF8; + klen = -klen_i32; + flags = HVhek_UTF8; } else { - klen = klen_i32; - flags = 0; + klen = klen_i32; + flags = 0; } return hv_common(hv, NULL, key, klen, flags, action, val, hash); } void * Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, - int flags, int action, SV *val, U32 hash) + int flags, int action, SV *val, U32 hash) { XPVHV* xhv; HE *entry; @@ -353,276 +353,276 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, HEK *keysv_hek = NULL; if (!hv) - return NULL; + return NULL; if (SvTYPE(hv) == (svtype)SVTYPEMASK) - return NULL; + return NULL; assert(SvTYPE(hv) == SVt_PVHV); if (SvSMAGICAL(hv) && SvGMAGICAL(hv) && !(action & HV_DISABLE_UVAR_XKEY)) { - MAGIC* mg; - if ((mg = mg_find((const SV *)hv, PERL_MAGIC_uvar))) { - struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr; - if (uf->uf_set == NULL) { - SV* obj = mg->mg_obj; - - if (!keysv) { - keysv = newSVpvn_flags(key, klen, SVs_TEMP | - ((flags & HVhek_UTF8) - ? SVf_UTF8 : 0)); - } - - mg->mg_obj = keysv; /* pass key */ - uf->uf_index = action; /* pass action */ - magic_getuvar(MUTABLE_SV(hv), mg); - keysv = mg->mg_obj; /* may have changed */ - mg->mg_obj = obj; - - /* If the key may have changed, then we need to invalidate - any passed-in computed hash value. */ - hash = 0; - } - } + MAGIC* mg; + if ((mg = mg_find((const SV *)hv, PERL_MAGIC_uvar))) { + struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr; + if (uf->uf_set == NULL) { + SV* obj = mg->mg_obj; + + if (!keysv) { + keysv = newSVpvn_flags(key, klen, SVs_TEMP | + ((flags & HVhek_UTF8) + ? SVf_UTF8 : 0)); + } + + mg->mg_obj = keysv; /* pass key */ + uf->uf_index = action; /* pass action */ + magic_getuvar(MUTABLE_SV(hv), mg); + keysv = mg->mg_obj; /* may have changed */ + mg->mg_obj = obj; + + /* If the key may have changed, then we need to invalidate + any passed-in computed hash value. */ + hash = 0; + } + } } if (keysv) { - if (flags & HVhek_FREEKEY) - Safefree(key); - key = SvPV_const(keysv, klen); - is_utf8 = (SvUTF8(keysv) != 0); - if (SvIsCOW_shared_hash(keysv)) { - flags = HVhek_KEYCANONICAL | (is_utf8 ? HVhek_UTF8 : 0); - } else { - flags = 0; - } + if (flags & HVhek_FREEKEY) + Safefree(key); + key = SvPV_const(keysv, klen); + is_utf8 = (SvUTF8(keysv) != 0); + if (SvIsCOW_shared_hash(keysv)) { + flags = HVhek_KEYCANONICAL | (is_utf8 ? HVhek_UTF8 : 0); + } else { + flags = 0; + } } else { - is_utf8 = cBOOL(flags & HVhek_UTF8); + is_utf8 = cBOOL(flags & HVhek_UTF8); } if (action & HV_DELETE) { - return (void *) hv_delete_common(hv, keysv, key, klen, - flags | (is_utf8 ? HVhek_UTF8 : 0), - action, hash); + return (void *) hv_delete_common(hv, keysv, key, klen, + flags | (is_utf8 ? HVhek_UTF8 : 0), + action, hash); } xhv = (XPVHV*)SvANY(hv); if (SvMAGICAL(hv)) { - if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS))) { - if (mg_find((const SV *)hv, PERL_MAGIC_tied) - || SvGMAGICAL((const SV *)hv)) - { - /* FIXME should be able to skimp on the HE/HEK here when - HV_FETCH_JUST_SV is true. */ - if (!keysv) { - keysv = newSVpvn_utf8(key, klen, is_utf8); - } else { - keysv = newSVsv(keysv); - } + if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS))) { + if (mg_find((const SV *)hv, PERL_MAGIC_tied) + || SvGMAGICAL((const SV *)hv)) + { + /* FIXME should be able to skimp on the HE/HEK here when + HV_FETCH_JUST_SV is true. */ + if (!keysv) { + keysv = newSVpvn_utf8(key, klen, is_utf8); + } else { + keysv = newSVsv(keysv); + } sv = sv_newmortal(); mg_copy(MUTABLE_SV(hv), sv, (char *)keysv, HEf_SVKEY); - /* grab a fake HE/HEK pair from the pool or make a new one */ - entry = PL_hv_fetch_ent_mh; - if (entry) - PL_hv_fetch_ent_mh = HeNEXT(entry); - else { - char *k; - entry = new_HE(); - Newx(k, HEK_BASESIZE + sizeof(const SV *), char); - HeKEY_hek(entry) = (HEK*)k; - } - HeNEXT(entry) = NULL; - HeSVKEY_set(entry, keysv); - HeVAL(entry) = sv; - sv_upgrade(sv, SVt_PVLV); - LvTYPE(sv) = 'T'; - /* so we can free entry when freeing sv */ - LvTARG(sv) = MUTABLE_SV(entry); - - /* XXX remove at some point? */ - if (flags & HVhek_FREEKEY) - Safefree(key); - - if (return_svp) { - return entry ? (void *) &HeVAL(entry) : NULL; - } - return (void *) entry; - } + /* grab a fake HE/HEK pair from the pool or make a new one */ + entry = PL_hv_fetch_ent_mh; + if (entry) + PL_hv_fetch_ent_mh = HeNEXT(entry); + else { + char *k; + entry = new_HE(); + Newx(k, HEK_BASESIZE + sizeof(const SV *), char); + HeKEY_hek(entry) = (HEK*)k; + } + HeNEXT(entry) = NULL; + HeSVKEY_set(entry, keysv); + HeVAL(entry) = sv; + sv_upgrade(sv, SVt_PVLV); + LvTYPE(sv) = 'T'; + /* so we can free entry when freeing sv */ + LvTARG(sv) = MUTABLE_SV(entry); + + /* XXX remove at some point? */ + if (flags & HVhek_FREEKEY) + Safefree(key); + + if (return_svp) { + return entry ? (void *) &HeVAL(entry) : NULL; + } + return (void *) entry; + } #ifdef ENV_IS_CASELESS - else if (mg_find((const SV *)hv, PERL_MAGIC_env)) { - U32 i; - for (i = 0; i < klen; ++i) - if (isLOWER(key[i])) { - /* Would be nice if we had a routine to do the - copy and upercase in a single pass through. */ - const char * const nkey = strupr(savepvn(key,klen)); - /* Note that this fetch is for nkey (the uppercased - key) whereas the store is for key (the original) */ - void *result = hv_common(hv, NULL, nkey, klen, - HVhek_FREEKEY, /* free nkey */ - 0 /* non-LVAL fetch */ - | HV_DISABLE_UVAR_XKEY - | return_svp, - NULL /* no value */, - 0 /* compute hash */); - if (!result && (action & HV_FETCH_LVALUE)) { - /* This call will free key if necessary. - Do it this way to encourage compiler to tail - call optimise. */ - result = hv_common(hv, keysv, key, klen, flags, - HV_FETCH_ISSTORE - | HV_DISABLE_UVAR_XKEY - | return_svp, - newSV(0), hash); - } else { - if (flags & HVhek_FREEKEY) - Safefree(key); - } - return result; - } - } + else if (mg_find((const SV *)hv, PERL_MAGIC_env)) { + U32 i; + for (i = 0; i < klen; ++i) + if (isLOWER(key[i])) { + /* Would be nice if we had a routine to do the + copy and upercase in a single pass through. */ + const char * const nkey = strupr(savepvn(key,klen)); + /* Note that this fetch is for nkey (the uppercased + key) whereas the store is for key (the original) */ + void *result = hv_common(hv, NULL, nkey, klen, + HVhek_FREEKEY, /* free nkey */ + 0 /* non-LVAL fetch */ + | HV_DISABLE_UVAR_XKEY + | return_svp, + NULL /* no value */, + 0 /* compute hash */); + if (!result && (action & HV_FETCH_LVALUE)) { + /* This call will free key if necessary. + Do it this way to encourage compiler to tail + call optimise. */ + result = hv_common(hv, keysv, key, klen, flags, + HV_FETCH_ISSTORE + | HV_DISABLE_UVAR_XKEY + | return_svp, + newSV(0), hash); + } else { + if (flags & HVhek_FREEKEY) + Safefree(key); + } + return result; + } + } #endif - } /* ISFETCH */ - else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) { - if (mg_find((const SV *)hv, PERL_MAGIC_tied) - || SvGMAGICAL((const SV *)hv)) { - /* I don't understand why hv_exists_ent has svret and sv, - whereas hv_exists only had one. */ - SV * const svret = sv_newmortal(); - sv = sv_newmortal(); - - if (keysv || is_utf8) { - if (!keysv) { - keysv = newSVpvn_utf8(key, klen, TRUE); - } else { - keysv = newSVsv(keysv); - } - mg_copy(MUTABLE_SV(hv), sv, (char *)sv_2mortal(keysv), HEf_SVKEY); - } else { - mg_copy(MUTABLE_SV(hv), sv, key, klen); - } - if (flags & HVhek_FREEKEY) - Safefree(key); - { + } /* ISFETCH */ + else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) { + if (mg_find((const SV *)hv, PERL_MAGIC_tied) + || SvGMAGICAL((const SV *)hv)) { + /* I don't understand why hv_exists_ent has svret and sv, + whereas hv_exists only had one. */ + SV * const svret = sv_newmortal(); + sv = sv_newmortal(); + + if (keysv || is_utf8) { + if (!keysv) { + keysv = newSVpvn_utf8(key, klen, TRUE); + } else { + keysv = newSVsv(keysv); + } + mg_copy(MUTABLE_SV(hv), sv, (char *)sv_2mortal(keysv), HEf_SVKEY); + } else { + mg_copy(MUTABLE_SV(hv), sv, key, klen); + } + if (flags & HVhek_FREEKEY) + Safefree(key); + { MAGIC * const mg = mg_find(sv, PERL_MAGIC_tiedelem); if (mg) magic_existspack(svret, mg); - } - /* This cast somewhat evil, but I'm merely using NULL/ - not NULL to return the boolean exists. - And I know hv is not NULL. */ - return SvTRUE_NN(svret) ? (void *)hv : NULL; - } + } + /* This cast somewhat evil, but I'm merely using NULL/ + not NULL to return the boolean exists. + And I know hv is not NULL. */ + return SvTRUE_NN(svret) ? (void *)hv : NULL; + } #ifdef ENV_IS_CASELESS - else if (mg_find((const SV *)hv, PERL_MAGIC_env)) { - /* XXX This code isn't UTF8 clean. */ - char * const keysave = (char * const)key; - /* Will need to free this, so set FREEKEY flag. */ - key = savepvn(key,klen); - key = (const char*)strupr((char*)key); - is_utf8 = FALSE; - hash = 0; - keysv = 0; - - if (flags & HVhek_FREEKEY) { - Safefree(keysave); - } - flags |= HVhek_FREEKEY; - } + else if (mg_find((const SV *)hv, PERL_MAGIC_env)) { + /* XXX This code isn't UTF8 clean. */ + char * const keysave = (char * const)key; + /* Will need to free this, so set FREEKEY flag. */ + key = savepvn(key,klen); + key = (const char*)strupr((char*)key); + is_utf8 = FALSE; + hash = 0; + keysv = 0; + + if (flags & HVhek_FREEKEY) { + Safefree(keysave); + } + flags |= HVhek_FREEKEY; + } #endif - } /* ISEXISTS */ - else if (action & HV_FETCH_ISSTORE) { - bool needs_copy; - bool needs_store; - hv_magic_check (hv, &needs_copy, &needs_store); - if (needs_copy) { - const bool save_taint = TAINT_get; - if (keysv || is_utf8) { - if (!keysv) { - keysv = newSVpvn_utf8(key, klen, TRUE); - } - if (TAINTING_get) - TAINT_set(SvTAINTED(keysv)); - keysv = sv_2mortal(newSVsv(keysv)); - mg_copy(MUTABLE_SV(hv), val, (char*)keysv, HEf_SVKEY); - } else { - mg_copy(MUTABLE_SV(hv), val, key, klen); - } - - TAINT_IF(save_taint); + } /* ISEXISTS */ + else if (action & HV_FETCH_ISSTORE) { + bool needs_copy; + bool needs_store; + hv_magic_check (hv, &needs_copy, &needs_store); + if (needs_copy) { + const bool save_taint = TAINT_get; + if (keysv || is_utf8) { + if (!keysv) { + keysv = newSVpvn_utf8(key, klen, TRUE); + } + if (TAINTING_get) + TAINT_set(SvTAINTED(keysv)); + keysv = sv_2mortal(newSVsv(keysv)); + mg_copy(MUTABLE_SV(hv), val, (char*)keysv, HEf_SVKEY); + } else { + mg_copy(MUTABLE_SV(hv), val, key, klen); + } + + TAINT_IF(save_taint); #ifdef NO_TAINT_SUPPORT PERL_UNUSED_VAR(save_taint); #endif - if (!needs_store) { - if (flags & HVhek_FREEKEY) - Safefree(key); - return NULL; - } + if (!needs_store) { + if (flags & HVhek_FREEKEY) + Safefree(key); + return NULL; + } #ifdef ENV_IS_CASELESS - else if (mg_find((const SV *)hv, PERL_MAGIC_env)) { - /* XXX This code isn't UTF8 clean. */ - const char *keysave = key; - /* Will need to free this, so set FREEKEY flag. */ - key = savepvn(key,klen); - key = (const char*)strupr((char*)key); - is_utf8 = FALSE; - hash = 0; - keysv = 0; - - if (flags & HVhek_FREEKEY) { - Safefree(keysave); - } - flags |= HVhek_FREEKEY; - } + else if (mg_find((const SV *)hv, PERL_MAGIC_env)) { + /* XXX This code isn't UTF8 clean. */ + const char *keysave = key; + /* Will need to free this, so set FREEKEY flag. */ + key = savepvn(key,klen); + key = (const char*)strupr((char*)key); + is_utf8 = FALSE; + hash = 0; + keysv = 0; + + if (flags & HVhek_FREEKEY) { + Safefree(keysave); + } + flags |= HVhek_FREEKEY; + } #endif - } - } /* ISSTORE */ + } + } /* ISSTORE */ } /* SvMAGICAL */ if (!HvARRAY(hv)) { - if ((action & (HV_FETCH_LVALUE | HV_FETCH_ISSTORE)) + if ((action & (HV_FETCH_LVALUE | HV_FETCH_ISSTORE)) #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */ - || (SvRMAGICAL((const SV *)hv) - && mg_find((const SV *)hv, PERL_MAGIC_env)) + || (SvRMAGICAL((const SV *)hv) + && mg_find((const SV *)hv, PERL_MAGIC_env)) #endif - ) { - char *array; - Newxz(array, - PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */), - char); - HvARRAY(hv) = (HE**)array; - } + ) { + char *array; + Newxz(array, + PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */), + char); + HvARRAY(hv) = (HE**)array; + } #ifdef DYNAMIC_ENV_FETCH - else if (action & HV_FETCH_ISEXISTS) { - /* for an %ENV exists, if we do an insert it's by a recursive - store call, so avoid creating HvARRAY(hv) right now. */ - } + else if (action & HV_FETCH_ISEXISTS) { + /* for an %ENV exists, if we do an insert it's by a recursive + store call, so avoid creating HvARRAY(hv) right now. */ + } #endif - else { - /* XXX remove at some point? */ + else { + /* XXX remove at some point? */ if (flags & HVhek_FREEKEY) Safefree(key); - return NULL; - } + return NULL; + } } if (is_utf8 && !(flags & HVhek_KEYCANONICAL)) { - char * const keysave = (char *)key; - key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8); + char * const keysave = (char *)key; + key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8); if (is_utf8) - flags |= HVhek_UTF8; - else - flags &= ~HVhek_UTF8; + flags |= HVhek_UTF8; + else + flags &= ~HVhek_UTF8; if (key != keysave) { - if (flags & HVhek_FREEKEY) - Safefree(keysave); + if (flags & HVhek_FREEKEY) + Safefree(keysave); flags |= HVhek_WASUTF8 | HVhek_FREEKEY; - /* If the caller calculated a hash, it was on the sequence of - octets that are the UTF-8 form. We've now changed the sequence - of octets stored to that of the equivalent byte representation, - so the hash we need is different. */ - hash = 0; - } + /* If the caller calculated a hash, it was on the sequence of + octets that are the UTF-8 form. We've now changed the sequence + of octets stored to that of the equivalent byte representation, + so the hash we need is different. */ + hash = 0; + } } if (keysv && (SvIsCOW_shared_hash(keysv))) { @@ -640,7 +640,7 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, else #endif { - entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; + entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; } if (!entry) @@ -674,146 +674,146 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } for (; entry; entry = HeNEXT(entry)) { - if (HeHASH(entry) != hash) /* strings can't be equal */ - continue; - if (HeKLEN(entry) != (I32)klen) - continue; - if (memNE(HeKEY(entry),key,klen)) /* is this it? */ - continue; - if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8) - continue; + if (HeHASH(entry) != hash) /* strings can't be equal */ + continue; + if (HeKLEN(entry) != (I32)klen) + continue; + if (memNE(HeKEY(entry),key,klen)) /* is this it? */ + continue; + if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8) + continue; found: if (action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE)) { - if (HeKFLAGS(entry) != masked_flags) { - /* We match if HVhek_UTF8 bit in our flags and hash key's - match. But if entry was set previously with HVhek_WASUTF8 - and key now doesn't (or vice versa) then we should change - the key's flag, as this is assignment. */ - if (HvSHAREKEYS(hv)) { - /* Need to swap the key we have for a key with the flags we - need. As keys are shared we can't just write to the - flag, so we share the new one, unshare the old one. */ - HEK * const new_hek = share_hek_flags(key, klen, hash, - masked_flags); - unshare_hek (HeKEY_hek(entry)); - HeKEY_hek(entry) = new_hek; - } - else if (hv == PL_strtab) { - /* PL_strtab is usually the only hash without HvSHAREKEYS, - so putting this test here is cheap */ - if (flags & HVhek_FREEKEY) - Safefree(key); - Perl_croak(aTHX_ S_strtab_error, - action & HV_FETCH_LVALUE ? "fetch" : "store"); - } - else - HeKFLAGS(entry) = masked_flags; - if (masked_flags & HVhek_ENABLEHVKFLAGS) - HvHASKFLAGS_on(hv); - } - if (HeVAL(entry) == &PL_sv_placeholder) { - /* yes, can store into placeholder slot */ - if (action & HV_FETCH_LVALUE) { - if (SvMAGICAL(hv)) { - /* This preserves behaviour with the old hv_fetch - implementation which at this point would bail out - with a break; (at "if we find a placeholder, we - pretend we haven't found anything") - - That break mean that if a placeholder were found, it - caused a call into hv_store, which in turn would - check magic, and if there is no magic end up pretty - much back at this point (in hv_store's code). */ - break; - } - /* LVAL fetch which actually needs a store. */ - val = newSV(0); - HvPLACEHOLDERS(hv)--; - } else { - /* store */ - if (val != &PL_sv_placeholder) - HvPLACEHOLDERS(hv)--; - } - HeVAL(entry) = val; - } else if (action & HV_FETCH_ISSTORE) { - SvREFCNT_dec(HeVAL(entry)); - HeVAL(entry) = val; - } - } else if (HeVAL(entry) == &PL_sv_placeholder) { - /* if we find a placeholder, we pretend we haven't found - anything */ - break; - } - if (flags & HVhek_FREEKEY) - Safefree(key); - if (return_svp) { + if (HeKFLAGS(entry) != masked_flags) { + /* We match if HVhek_UTF8 bit in our flags and hash key's + match. But if entry was set previously with HVhek_WASUTF8 + and key now doesn't (or vice versa) then we should change + the key's flag, as this is assignment. */ + if (HvSHAREKEYS(hv)) { + /* Need to swap the key we have for a key with the flags we + need. As keys are shared we can't just write to the + flag, so we share the new one, unshare the old one. */ + HEK * const new_hek = share_hek_flags(key, klen, hash, + masked_flags); + unshare_hek (HeKEY_hek(entry)); + HeKEY_hek(entry) = new_hek; + } + else if (hv == PL_strtab) { + /* PL_strtab is usually the only hash without HvSHAREKEYS, + so putting this test here is cheap */ + if (flags & HVhek_FREEKEY) + Safefree(key); + Perl_croak(aTHX_ S_strtab_error, + action & HV_FETCH_LVALUE ? "fetch" : "store"); + } + else + HeKFLAGS(entry) = masked_flags; + if (masked_flags & HVhek_ENABLEHVKFLAGS) + HvHASKFLAGS_on(hv); + } + if (HeVAL(entry) == &PL_sv_placeholder) { + /* yes, can store into placeholder slot */ + if (action & HV_FETCH_LVALUE) { + if (SvMAGICAL(hv)) { + /* This preserves behaviour with the old hv_fetch + implementation which at this point would bail out + with a break; (at "if we find a placeholder, we + pretend we haven't found anything") + + That break mean that if a placeholder were found, it + caused a call into hv_store, which in turn would + check magic, and if there is no magic end up pretty + much back at this point (in hv_store's code). */ + break; + } + /* LVAL fetch which actually needs a store. */ + val = newSV(0); + HvPLACEHOLDERS(hv)--; + } else { + /* store */ + if (val != &PL_sv_placeholder) + HvPLACEHOLDERS(hv)--; + } + HeVAL(entry) = val; + } else if (action & HV_FETCH_ISSTORE) { + SvREFCNT_dec(HeVAL(entry)); + HeVAL(entry) = val; + } + } else if (HeVAL(entry) == &PL_sv_placeholder) { + /* if we find a placeholder, we pretend we haven't found + anything */ + break; + } + if (flags & HVhek_FREEKEY) + Safefree(key); + if (return_svp) { return (void *) &HeVAL(entry); - } - return entry; + } + return entry; } not_found: #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */ if (!(action & HV_FETCH_ISSTORE) - && SvRMAGICAL((const SV *)hv) - && mg_find((const SV *)hv, PERL_MAGIC_env)) { - unsigned long len; - const char * const env = PerlEnv_ENVgetenv_len(key,&len); - if (env) { - sv = newSVpvn(env,len); - SvTAINTED_on(sv); - return hv_common(hv, keysv, key, klen, flags, - HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp, - sv, hash); - } + && SvRMAGICAL((const SV *)hv) + && mg_find((const SV *)hv, PERL_MAGIC_env)) { + unsigned long len; + const char * const env = PerlEnv_ENVgetenv_len(key,&len); + if (env) { + sv = newSVpvn(env,len); + SvTAINTED_on(sv); + return hv_common(hv, keysv, key, klen, flags, + HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp, + sv, hash); + } } #endif if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) { - hv_notallowed(flags, key, klen, - "Attempt to access disallowed key '%" SVf "' in" - " a restricted hash"); + hv_notallowed(flags, key, klen, + "Attempt to access disallowed key '%" SVf "' in" + " a restricted hash"); } if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) { - /* Not doing some form of store, so return failure. */ - if (flags & HVhek_FREEKEY) - Safefree(key); - return NULL; + /* Not doing some form of store, so return failure. */ + if (flags & HVhek_FREEKEY) + Safefree(key); + return NULL; } if (action & HV_FETCH_LVALUE) { - val = action & HV_FETCH_EMPTY_HE ? NULL : newSV(0); - if (SvMAGICAL(hv)) { - /* At this point the old hv_fetch code would call to hv_store, - which in turn might do some tied magic. So we need to make that - magic check happen. */ - /* gonna assign to this, so it better be there */ - /* If a fetch-as-store fails on the fetch, then the action is to - recurse once into "hv_store". If we didn't do this, then that - recursive call would call the key conversion routine again. - However, as we replace the original key with the converted - key, this would result in a double conversion, which would show - up as a bug if the conversion routine is not idempotent. - Hence the use of HV_DISABLE_UVAR_XKEY. */ - return hv_common(hv, keysv, key, klen, flags, - HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp, - val, hash); - /* XXX Surely that could leak if the fetch-was-store fails? - Just like the hv_fetch. */ - } + val = action & HV_FETCH_EMPTY_HE ? NULL : newSV(0); + if (SvMAGICAL(hv)) { + /* At this point the old hv_fetch code would call to hv_store, + which in turn might do some tied magic. So we need to make that + magic check happen. */ + /* gonna assign to this, so it better be there */ + /* If a fetch-as-store fails on the fetch, then the action is to + recurse once into "hv_store". If we didn't do this, then that + recursive call would call the key conversion routine again. + However, as we replace the original key with the converted + key, this would result in a double conversion, which would show + up as a bug if the conversion routine is not idempotent. + Hence the use of HV_DISABLE_UVAR_XKEY. */ + return hv_common(hv, keysv, key, klen, flags, + HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp, + val, hash); + /* XXX Surely that could leak if the fetch-was-store fails? + Just like the hv_fetch. */ + } } /* Welcome to hv_store... */ if (!HvARRAY(hv)) { - /* Not sure if we can get here. I think the only case of oentry being - NULL is for %ENV with dynamic env fetch. But that should disappear - with magic in the previous code. */ - char *array; - Newxz(array, - PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */), - char); - HvARRAY(hv) = (HE**)array; + /* Not sure if we can get here. I think the only case of oentry being + NULL is for %ENV with dynamic env fetch. But that should disappear + with magic in the previous code. */ + char *array; + Newxz(array, + PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */), + char); + HvARRAY(hv) = (HE**)array; } oentry = &(HvARRAY(hv))[hash & (I32) xhv->xhv_max]; @@ -822,17 +822,17 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, /* share_hek_flags will do the free for us. This might be considered bad API design. */ if (HvSHAREKEYS(hv)) - HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags); + HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags); else if (hv == PL_strtab) { - /* PL_strtab is usually the only hash without HvSHAREKEYS, so putting - this test here is cheap */ - if (flags & HVhek_FREEKEY) - Safefree(key); - Perl_croak(aTHX_ S_strtab_error, - action & HV_FETCH_LVALUE ? "fetch" : "store"); + /* PL_strtab is usually the only hash without HvSHAREKEYS, so putting + this test here is cheap */ + if (flags & HVhek_FREEKEY) + Safefree(key); + Perl_croak(aTHX_ S_strtab_error, + action & HV_FETCH_LVALUE ? "fetch" : "store"); } else /* gotta do the real thing */ - HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags); + HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags); HeVAL(entry) = val; #ifdef PERL_HASH_RANDOMIZE_KEYS @@ -879,9 +879,9 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, #endif if (val == &PL_sv_placeholder) - HvPLACEHOLDERS(hv)++; + HvPLACEHOLDERS(hv)++; if (masked_flags & HVhek_ENABLEHVKFLAGS) - HvHASKFLAGS_on(hv); + HvHASKFLAGS_on(hv); xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */ if ( in_collision && DO_HSPLIT(xhv) ) { @@ -908,7 +908,7 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } if (return_svp) { - return entry ? (void *) &HeVAL(entry) : NULL; + return entry ? (void *) &HeVAL(entry) : NULL; } return (void *) entry; } @@ -923,14 +923,14 @@ S_hv_magic_check(HV *hv, bool *needs_copy, bool *needs_store) *needs_copy = FALSE; *needs_store = TRUE; while (mg) { - if (isUPPER(mg->mg_type)) { - *needs_copy = TRUE; - if (mg->mg_type == PERL_MAGIC_tied) { - *needs_store = FALSE; - return; /* We've set all there is to set. */ - } - } - mg = mg->mg_moremagic; + if (isUPPER(mg->mg_type)) { + *needs_copy = TRUE; + if (mg->mg_type == PERL_MAGIC_tied) { + *needs_store = FALSE; + return; /* We've set all there is to set. */ + } + } + mg = mg->mg_moremagic; } } @@ -957,9 +957,9 @@ Perl_hv_scalar(pTHX_ HV *hv) PERL_ARGS_ASSERT_HV_SCALAR; if (SvRMAGICAL(hv)) { - MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_tied); - if (mg) - return magic_scalarpack(hv, mg); + MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_tied); + if (mg) + return magic_scalarpack(hv, mg); } sv = sv_newmortal(); @@ -1103,7 +1103,7 @@ value, or 0 to ask for it to be computed. STATIC SV * S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, - int k_flags, I32 d_flags, U32 hash) + int k_flags, I32 d_flags, U32 hash) { XPVHV* xhv; HE *entry; @@ -1118,65 +1118,65 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, HV *stash = NULL; if (SvRMAGICAL(hv)) { - bool needs_copy; - bool needs_store; - hv_magic_check (hv, &needs_copy, &needs_store); - - if (needs_copy) { - SV *sv; - entry = (HE *) hv_common(hv, keysv, key, klen, - k_flags & ~HVhek_FREEKEY, - HV_FETCH_LVALUE|HV_DISABLE_UVAR_XKEY, - NULL, hash); - sv = entry ? HeVAL(entry) : NULL; - if (sv) { - if (SvMAGICAL(sv)) { - mg_clear(sv); - } - if (!needs_store) { - if (mg_find(sv, PERL_MAGIC_tiedelem)) { - /* No longer an element */ - sv_unmagic(sv, PERL_MAGIC_tiedelem); - return sv; - } - return NULL; /* element cannot be deleted */ - } + bool needs_copy; + bool needs_store; + hv_magic_check (hv, &needs_copy, &needs_store); + + if (needs_copy) { + SV *sv; + entry = (HE *) hv_common(hv, keysv, key, klen, + k_flags & ~HVhek_FREEKEY, + HV_FETCH_LVALUE|HV_DISABLE_UVAR_XKEY, + NULL, hash); + sv = entry ? HeVAL(entry) : NULL; + if (sv) { + if (SvMAGICAL(sv)) { + mg_clear(sv); + } + if (!needs_store) { + if (mg_find(sv, PERL_MAGIC_tiedelem)) { + /* No longer an element */ + sv_unmagic(sv, PERL_MAGIC_tiedelem); + return sv; + } + return NULL; /* element cannot be deleted */ + } #ifdef ENV_IS_CASELESS - else if (mg_find((const SV *)hv, PERL_MAGIC_env)) { - /* XXX This code isn't UTF8 clean. */ - keysv = newSVpvn_flags(key, klen, SVs_TEMP); - if (k_flags & HVhek_FREEKEY) { - Safefree(key); - } - key = strupr(SvPVX(keysv)); - is_utf8 = 0; - k_flags = 0; - hash = 0; - } + else if (mg_find((const SV *)hv, PERL_MAGIC_env)) { + /* XXX This code isn't UTF8 clean. */ + keysv = newSVpvn_flags(key, klen, SVs_TEMP); + if (k_flags & HVhek_FREEKEY) { + Safefree(key); + } + key = strupr(SvPVX(keysv)); + is_utf8 = 0; + k_flags = 0; + hash = 0; + } #endif - } - } + } + } } xhv = (XPVHV*)SvANY(hv); if (!HvARRAY(hv)) - return NULL; + return NULL; if (is_utf8 && !(k_flags & HVhek_KEYCANONICAL)) { - const char * const keysave = key; - key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8); + const char * const keysave = key; + key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8); if (is_utf8) k_flags |= HVhek_UTF8; - else + else k_flags &= ~HVhek_UTF8; if (key != keysave) { - if (k_flags & HVhek_FREEKEY) { - /* This shouldn't happen if our caller does what we expect, - but strictly the API allows it. */ - Safefree(keysave); - } - k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY; - } + if (k_flags & HVhek_FREEKEY) { + /* This shouldn't happen if our caller does what we expect, + but strictly the API allows it. */ + Safefree(keysave); + } + k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY; + } HvHASKFLAGS_on(MUTABLE_SV(hv)); } @@ -1224,66 +1224,66 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } for (; entry; oentry = &HeNEXT(entry), entry = *oentry) { - if (HeHASH(entry) != hash) /* strings can't be equal */ - continue; - if (HeKLEN(entry) != (I32)klen) - continue; - if (memNE(HeKEY(entry),key,klen)) /* is this it? */ - continue; - if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8) - continue; + if (HeHASH(entry) != hash) /* strings can't be equal */ + continue; + if (HeKLEN(entry) != (I32)klen) + continue; + if (memNE(HeKEY(entry),key,klen)) /* is this it? */ + continue; + if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8) + continue; found: - if (hv == PL_strtab) { - if (k_flags & HVhek_FREEKEY) - Safefree(key); - Perl_croak(aTHX_ S_strtab_error, "delete"); - } - - /* if placeholder is here, it's already been deleted.... */ - if (HeVAL(entry) == &PL_sv_placeholder) { - if (k_flags & HVhek_FREEKEY) - Safefree(key); - return NULL; - } - if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) { - hv_notallowed(k_flags, key, klen, - "Attempt to delete readonly key '%" SVf "' from" - " a restricted hash"); - } + if (hv == PL_strtab) { + if (k_flags & HVhek_FREEKEY) + Safefree(key); + Perl_croak(aTHX_ S_strtab_error, "delete"); + } + + /* if placeholder is here, it's already been deleted.... */ + if (HeVAL(entry) == &PL_sv_placeholder) { + if (k_flags & HVhek_FREEKEY) + Safefree(key); + return NULL; + } + if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) { + hv_notallowed(k_flags, key, klen, + "Attempt to delete readonly key '%" SVf "' from" + " a restricted hash"); + } if (k_flags & HVhek_FREEKEY) Safefree(key); - /* If this is a stash and the key ends with ::, then someone is - * deleting a package. - */ - if (HeVAL(entry) && HvENAME_get(hv)) { - gv = (GV *)HeVAL(entry); - if (keysv) key = SvPV(keysv, klen); - if (( - (klen > 1 && key[klen-2] == ':' && key[klen-1] == ':') - || - (klen == 1 && key[0] == ':') - ) - && (klen != 6 || hv!=PL_defstash || memNE(key,"main::",6)) - && SvTYPE(gv) == SVt_PVGV && (stash = GvHV((GV *)gv)) - && HvENAME_get(stash)) { - /* A previous version of this code checked that the - * GV was still in the symbol table by fetching the - * GV with its name. That is not necessary (and - * sometimes incorrect), as HvENAME cannot be set - * on hv if it is not in the symtab. */ - mro_changes = 2; - /* Hang on to it for a bit. */ - SvREFCNT_inc_simple_void_NN( - sv_2mortal((SV *)gv) - ); - } - else if (memEQs(key, klen, "ISA") && GvAV(gv)) { + /* If this is a stash and the key ends with ::, then someone is + * deleting a package. + */ + if (HeVAL(entry) && HvENAME_get(hv)) { + gv = (GV *)HeVAL(entry); + if (keysv) key = SvPV(keysv, klen); + if (( + (klen > 1 && key[klen-2] == ':' && key[klen-1] == ':') + || + (klen == 1 && key[0] == ':') + ) + && (klen != 6 || hv!=PL_defstash || memNE(key,"main::",6)) + && SvTYPE(gv) == SVt_PVGV && (stash = GvHV((GV *)gv)) + && HvENAME_get(stash)) { + /* A previous version of this code checked that the + * GV was still in the symbol table by fetching the + * GV with its name. That is not necessary (and + * sometimes incorrect), as HvENAME cannot be set + * on hv if it is not in the symtab. */ + mro_changes = 2; + /* Hang on to it for a bit. */ + SvREFCNT_inc_simple_void_NN( + sv_2mortal((SV *)gv) + ); + } + else if (memEQs(key, klen, "ISA") && GvAV(gv)) { AV *isa = GvAV(gv); MAGIC *mg = mg_find((SV*)isa, PERL_MAGIC_isa); - mro_changes = 1; + mro_changes = 1; if (mg) { if (mg->mg_obj == (SV*)gv) { /* This is the only stash this ISA was used for. @@ -1346,63 +1346,63 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } } } - } - - sv = d_flags & G_DISCARD ? HeVAL(entry) : sv_2mortal(HeVAL(entry)); - HeVAL(entry) = &PL_sv_placeholder; - if (sv) { - /* deletion of method from stash */ - if (isGV(sv) && isGV_with_GP(sv) && GvCVu(sv) - && HvENAME_get(hv)) - mro_method_changed_in(hv); - } - - /* - * If a restricted hash, rather than really deleting the entry, put - * a placeholder there. This marks the key as being "approved", so - * we can still access via not-really-existing key without raising - * an error. - */ - if (SvREADONLY(hv)) - /* We'll be saving this slot, so the number of allocated keys - * doesn't go down, but the number placeholders goes up */ - HvPLACEHOLDERS(hv)++; - else { - *oentry = HeNEXT(entry); - if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */) - HvLAZYDEL_on(hv); - else { - if (SvOOK(hv) && HvLAZYDEL(hv) && - entry == HeNEXT(HvAUX(hv)->xhv_eiter)) - HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry); - hv_free_ent(hv, entry); - } - xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */ - if (xhv->xhv_keys == 0) - HvHASKFLAGS_off(hv); - } - - if (d_flags & G_DISCARD) { - SvREFCNT_dec(sv); - sv = NULL; - } - - if (mro_changes == 1) mro_isa_changed_in(hv); - else if (mro_changes == 2) - mro_package_moved(NULL, stash, gv, 1); - - return sv; + } + + sv = d_flags & G_DISCARD ? HeVAL(entry) : sv_2mortal(HeVAL(entry)); + HeVAL(entry) = &PL_sv_placeholder; + if (sv) { + /* deletion of method from stash */ + if (isGV(sv) && isGV_with_GP(sv) && GvCVu(sv) + && HvENAME_get(hv)) + mro_method_changed_in(hv); + } + + /* + * If a restricted hash, rather than really deleting the entry, put + * a placeholder there. This marks the key as being "approved", so + * we can still access via not-really-existing key without raising + * an error. + */ + if (SvREADONLY(hv)) + /* We'll be saving this slot, so the number of allocated keys + * doesn't go down, but the number placeholders goes up */ + HvPLACEHOLDERS(hv)++; + else { + *oentry = HeNEXT(entry); + if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */) + HvLAZYDEL_on(hv); + else { + if (SvOOK(hv) && HvLAZYDEL(hv) && + entry == HeNEXT(HvAUX(hv)->xhv_eiter)) + HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry); + hv_free_ent(hv, entry); + } + xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */ + if (xhv->xhv_keys == 0) + HvHASKFLAGS_off(hv); + } + + if (d_flags & G_DISCARD) { + SvREFCNT_dec(sv); + sv = NULL; + } + + if (mro_changes == 1) mro_isa_changed_in(hv); + else if (mro_changes == 2) + mro_package_moved(NULL, stash, gv, 1); + + return sv; } not_found: if (SvREADONLY(hv)) { - hv_notallowed(k_flags, key, klen, - "Attempt to delete disallowed key '%" SVf "' from" - " a restricted hash"); + hv_notallowed(k_flags, key, klen, + "Attempt to delete disallowed key '%" SVf "' from" + " a restricted hash"); } if (k_flags & HVhek_FREEKEY) - Safefree(key); + Safefree(key); return NULL; } @@ -1483,15 +1483,15 @@ S_hsplit(pTHX_ HV *hv, STRLEN const oldsize, STRLEN newsize) newsize--; aep = (HE**)a; do { - HE **oentry = aep + i; - HE *entry = aep[i]; + HE **oentry = aep + i; + HE *entry = aep[i]; - if (!entry) /* non-existent */ - continue; - do { + if (!entry) /* non-existent */ + continue; + do { U32 j = (HeHASH(entry) & newsize); - if (j != (U32)i) { - *oentry = HeNEXT(entry); + if (j != (U32)i) { + *oentry = HeNEXT(entry); #ifdef PERL_HASH_RANDOMIZE_KEYS /* if the target cell is empty or PL_HASH_RAND_BITS_ENABLED is false * insert to top, otherwise rotate the bucket rand 1 bit, @@ -1517,12 +1517,12 @@ S_hsplit(pTHX_ HV *hv, STRLEN const oldsize, STRLEN newsize) HeNEXT(entry) = aep[j]; aep[j] = entry; } - } - else { - oentry = &HeNEXT(entry); - } - entry = *oentry; - } while (entry); + } + else { + oentry = &HeNEXT(entry); + } + entry = *oentry; + } while (entry); } while (i++ < oldsize); } @@ -1540,7 +1540,7 @@ Perl_hv_ksplit(pTHX_ HV *hv, IV newmax) wantsize = (I32) newmax; /* possible truncation here */ if (wantsize != newmax) - return; + return; wantsize= wantsize + (wantsize >> 1); /* wantsize *= 1.5 */ if (wantsize < newmax) /* overflow detection */ @@ -1592,76 +1592,76 @@ Perl_newHVhv(pTHX_ HV *ohv) STRLEN hv_max; if (!ohv || (!HvTOTALKEYS(ohv) && !SvMAGICAL((const SV *)ohv))) - return hv; + return hv; hv_max = HvMAX(ohv); if (!SvMAGICAL((const SV *)ohv)) { - /* It's an ordinary hash, so copy it fast. AMS 20010804 */ - STRLEN i; - const bool shared = !!HvSHAREKEYS(ohv); - HE **ents, ** const oents = (HE **)HvARRAY(ohv); - char *a; - Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char); - ents = (HE**)a; - - /* In each bucket... */ - for (i = 0; i <= hv_max; i++) { - HE *prev = NULL; - HE *oent = oents[i]; - - if (!oent) { - ents[i] = NULL; - continue; - } - - /* Copy the linked list of entries. */ - for (; oent; oent = HeNEXT(oent)) { - const U32 hash = HeHASH(oent); - const char * const key = HeKEY(oent); - const STRLEN len = HeKLEN(oent); - const int flags = HeKFLAGS(oent); - HE * const ent = new_HE(); - SV *const val = HeVAL(oent); - - HeVAL(ent) = SvIMMORTAL(val) ? val : newSVsv(val); - HeKEY_hek(ent) + /* It's an ordinary hash, so copy it fast. AMS 20010804 */ + STRLEN i; + const bool shared = !!HvSHAREKEYS(ohv); + HE **ents, ** const oents = (HE **)HvARRAY(ohv); + char *a; + Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char); + ents = (HE**)a; + + /* In each bucket... */ + for (i = 0; i <= hv_max; i++) { + HE *prev = NULL; + HE *oent = oents[i]; + + if (!oent) { + ents[i] = NULL; + continue; + } + + /* Copy the linked list of entries. */ + for (; oent; oent = HeNEXT(oent)) { + const U32 hash = HeHASH(oent); + const char * const key = HeKEY(oent); + const STRLEN len = HeKLEN(oent); + const int flags = HeKFLAGS(oent); + HE * const ent = new_HE(); + SV *const val = HeVAL(oent); + + HeVAL(ent) = SvIMMORTAL(val) ? val : newSVsv(val); + HeKEY_hek(ent) = shared ? share_hek_flags(key, len, hash, flags) : save_hek_flags(key, len, hash, flags); - if (prev) - HeNEXT(prev) = ent; - else - ents[i] = ent; - prev = ent; - HeNEXT(ent) = NULL; - } - } - - HvMAX(hv) = hv_max; - HvTOTALKEYS(hv) = HvTOTALKEYS(ohv); - HvARRAY(hv) = ents; + if (prev) + HeNEXT(prev) = ent; + else + ents[i] = ent; + prev = ent; + HeNEXT(ent) = NULL; + } + } + + HvMAX(hv) = hv_max; + HvTOTALKEYS(hv) = HvTOTALKEYS(ohv); + HvARRAY(hv) = ents; } /* not magical */ else { - /* Iterate over ohv, copying keys and values one at a time. */ - HE *entry; - const I32 riter = HvRITER_get(ohv); - HE * const eiter = HvEITER_get(ohv); + /* Iterate over ohv, copying keys and values one at a time. */ + HE *entry; + const I32 riter = HvRITER_get(ohv); + HE * const eiter = HvEITER_get(ohv); STRLEN hv_keys = HvTOTALKEYS(ohv); HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys); - hv_iterinit(ohv); - while ((entry = hv_iternext_flags(ohv, 0))) { - SV *val = hv_iterval(ohv,entry); - SV * const keysv = HeSVKEY(entry); - val = SvIMMORTAL(val) ? val : newSVsv(val); - if (keysv) - (void)hv_store_ent(hv, keysv, val, 0); - else - (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), val, - HeHASH(entry), HeKFLAGS(entry)); - } - HvRITER_set(ohv, riter); - HvEITER_set(ohv, eiter); + hv_iterinit(ohv); + while ((entry = hv_iternext_flags(ohv, 0))) { + SV *val = hv_iterval(ohv,entry); + SV * const keysv = HeSVKEY(entry); + val = SvIMMORTAL(val) ? val : newSVsv(val); + if (keysv) + (void)hv_store_ent(hv, keysv, val, 0); + else + (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), val, + HeHASH(entry), HeKFLAGS(entry)); + } + HvRITER_set(ohv, riter); + HvEITER_set(ohv, eiter); } return hv; @@ -1685,37 +1685,37 @@ Perl_hv_copy_hints_hv(pTHX_ HV *const ohv) HV * const hv = newHV(); if (ohv) { - STRLEN hv_max = HvMAX(ohv); + STRLEN hv_max = HvMAX(ohv); STRLEN hv_keys = HvTOTALKEYS(ohv); - HE *entry; - const I32 riter = HvRITER_get(ohv); - HE * const eiter = HvEITER_get(ohv); + HE *entry; + const I32 riter = HvRITER_get(ohv); + HE * const eiter = HvEITER_get(ohv); - ENTER; - SAVEFREESV(hv); + ENTER; + SAVEFREESV(hv); HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys); - hv_iterinit(ohv); - while ((entry = hv_iternext_flags(ohv, 0))) { - SV *const sv = newSVsv(hv_iterval(ohv,entry)); - SV *heksv = HeSVKEY(entry); - if (!heksv && sv) heksv = newSVhek(HeKEY_hek(entry)); - if (sv) sv_magic(sv, NULL, PERL_MAGIC_hintselem, - (char *)heksv, HEf_SVKEY); - if (heksv == HeSVKEY(entry)) - (void)hv_store_ent(hv, heksv, sv, 0); - else { - (void)hv_common(hv, heksv, HeKEY(entry), HeKLEN(entry), - HeKFLAGS(entry), HV_FETCH_ISSTORE|HV_FETCH_JUST_SV, sv, HeHASH(entry)); - SvREFCNT_dec_NN(heksv); - } - } - HvRITER_set(ohv, riter); - HvEITER_set(ohv, eiter); - - SvREFCNT_inc_simple_void_NN(hv); - LEAVE; + hv_iterinit(ohv); + while ((entry = hv_iternext_flags(ohv, 0))) { + SV *const sv = newSVsv(hv_iterval(ohv,entry)); + SV *heksv = HeSVKEY(entry); + if (!heksv && sv) heksv = newSVhek(HeKEY_hek(entry)); + if (sv) sv_magic(sv, NULL, PERL_MAGIC_hintselem, + (char *)heksv, HEf_SVKEY); + if (heksv == HeSVKEY(entry)) + (void)hv_store_ent(hv, heksv, sv, 0); + else { + (void)hv_common(hv, heksv, HeKEY(entry), HeKLEN(entry), + HeKFLAGS(entry), HV_FETCH_ISSTORE|HV_FETCH_JUST_SV, sv, HeHASH(entry)); + SvREFCNT_dec_NN(heksv); + } + } + HvRITER_set(ohv, riter); + HvEITER_set(ohv, eiter); + + SvREFCNT_inc_simple_void_NN(hv); + LEAVE; } hv_magic(hv, NULL, PERL_MAGIC_hints); return hv; @@ -1732,13 +1732,13 @@ S_hv_free_ent_ret(pTHX_ HV *hv, HE *entry) val = HeVAL(entry); if (HeKLEN(entry) == HEf_SVKEY) { - SvREFCNT_dec(HeKEY_sv(entry)); - Safefree(HeKEY_hek(entry)); + SvREFCNT_dec(HeKEY_sv(entry)); + Safefree(HeKEY_hek(entry)); } else if (HvSHAREKEYS(hv)) - unshare_hek(HeKEY_hek(entry)); + unshare_hek(HeKEY_hek(entry)); else - Safefree(HeKEY_hek(entry)); + Safefree(HeKEY_hek(entry)); del_HE(entry); return val; } @@ -1752,7 +1752,7 @@ Perl_hv_free_ent(pTHX_ HV *hv, HE *entry) PERL_ARGS_ASSERT_HV_FREE_ENT; if (!entry) - return; + return; val = hv_free_ent_ret(hv, entry); SvREFCNT_dec(val); } @@ -1764,11 +1764,11 @@ Perl_hv_delayfree_ent(pTHX_ HV *hv, HE *entry) PERL_ARGS_ASSERT_HV_DELAYFREE_ENT; if (!entry) - return; + return; /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent */ sv_2mortal(SvREFCNT_inc(HeVAL(entry))); /* free between statements */ if (HeKLEN(entry) == HEf_SVKEY) { - sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry))); + sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry))); } hv_free_ent(hv, entry); } @@ -1776,7 +1776,7 @@ Perl_hv_delayfree_ent(pTHX_ HV *hv, HE *entry) /* =for apidoc hv_clear -Frees the all the elements of a hash, leaving it empty. +Frees all the elements of a hash, leaving it empty. The XS equivalent of C<%hash = ()>. See also L. See L for a note about the hash possibly being invalid on @@ -1792,7 +1792,7 @@ Perl_hv_clear(pTHX_ HV *hv) XPVHV* xhv; if (!hv) - return; + return; DEBUG_A(Perl_hv_assert(aTHX_ hv)); @@ -1803,41 +1803,41 @@ Perl_hv_clear(pTHX_ HV *hv) PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(hv); orig_ix = PL_tmps_ix; if (SvREADONLY(hv) && HvARRAY(hv) != NULL) { - /* restricted hash: convert all keys to placeholders */ - STRLEN i; - for (i = 0; i <= xhv->xhv_max; i++) { - HE *entry = (HvARRAY(hv))[i]; - for (; entry; entry = HeNEXT(entry)) { - /* not already placeholder */ - if (HeVAL(entry) != &PL_sv_placeholder) { - if (HeVAL(entry)) { - if (SvREADONLY(HeVAL(entry))) { - SV* const keysv = hv_iterkeysv(entry); - Perl_croak_nocontext( - "Attempt to delete readonly key '%" SVf "' from a restricted hash", - (void*)keysv); - } - SvREFCNT_dec_NN(HeVAL(entry)); - } - HeVAL(entry) = &PL_sv_placeholder; - HvPLACEHOLDERS(hv)++; - } - } - } + /* restricted hash: convert all keys to placeholders */ + STRLEN i; + for (i = 0; i <= xhv->xhv_max; i++) { + HE *entry = (HvARRAY(hv))[i]; + for (; entry; entry = HeNEXT(entry)) { + /* not already placeholder */ + if (HeVAL(entry) != &PL_sv_placeholder) { + if (HeVAL(entry)) { + if (SvREADONLY(HeVAL(entry))) { + SV* const keysv = hv_iterkeysv(entry); + Perl_croak_nocontext( + "Attempt to delete readonly key '%" SVf "' from a restricted hash", + (void*)keysv); + } + SvREFCNT_dec_NN(HeVAL(entry)); + } + HeVAL(entry) = &PL_sv_placeholder; + HvPLACEHOLDERS(hv)++; + } + } + } } else { - hv_free_entries(hv); - HvPLACEHOLDERS_set(hv, 0); + hv_free_entries(hv); + HvPLACEHOLDERS_set(hv, 0); - if (SvRMAGICAL(hv)) - mg_clear(MUTABLE_SV(hv)); + if (SvRMAGICAL(hv)) + mg_clear(MUTABLE_SV(hv)); - HvHASKFLAGS_off(hv); + HvHASKFLAGS_off(hv); } if (SvOOK(hv)) { if(HvENAME_get(hv)) mro_isa_changed_in(hv); - HvEITER_set(hv, NULL); + HvEITER_set(hv, NULL); } /* disarm hv's premature free guard */ if (LIKELY(PL_tmps_ix == orig_ix)) @@ -1870,7 +1870,7 @@ Perl_hv_clear_placeholders(pTHX_ HV *hv) PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS; if (items) - clear_placeholders(hv, items); + clear_placeholders(hv, items); } static void @@ -1881,40 +1881,40 @@ S_clear_placeholders(pTHX_ HV *hv, U32 items) PERL_ARGS_ASSERT_CLEAR_PLACEHOLDERS; if (items == 0) - return; + return; i = HvMAX(hv); do { - /* Loop down the linked list heads */ - HE **oentry = &(HvARRAY(hv))[i]; - HE *entry; - - while ((entry = *oentry)) { - if (HeVAL(entry) == &PL_sv_placeholder) { - *oentry = HeNEXT(entry); - if (entry == HvEITER_get(hv)) - HvLAZYDEL_on(hv); - else { - if (SvOOK(hv) && HvLAZYDEL(hv) && - entry == HeNEXT(HvAUX(hv)->xhv_eiter)) - HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry); - hv_free_ent(hv, entry); - } - - if (--items == 0) { - /* Finished. */ - I32 placeholders = HvPLACEHOLDERS_get(hv); - HvTOTALKEYS(hv) -= (IV)placeholders; - /* HvUSEDKEYS expanded */ - if ((HvTOTALKEYS(hv) - placeholders) == 0) - HvHASKFLAGS_off(hv); - HvPLACEHOLDERS_set(hv, 0); - return; - } - } else { - oentry = &HeNEXT(entry); - } - } + /* Loop down the linked list heads */ + HE **oentry = &(HvARRAY(hv))[i]; + HE *entry; + + while ((entry = *oentry)) { + if (HeVAL(entry) == &PL_sv_placeholder) { + *oentry = HeNEXT(entry); + if (entry == HvEITER_get(hv)) + HvLAZYDEL_on(hv); + else { + if (SvOOK(hv) && HvLAZYDEL(hv) && + entry == HeNEXT(HvAUX(hv)->xhv_eiter)) + HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry); + hv_free_ent(hv, entry); + } + + if (--items == 0) { + /* Finished. */ + I32 placeholders = HvPLACEHOLDERS_get(hv); + HvTOTALKEYS(hv) -= (IV)placeholders; + /* HvUSEDKEYS expanded */ + if ((HvTOTALKEYS(hv) - placeholders) == 0) + HvHASKFLAGS_off(hv); + HvPLACEHOLDERS_set(hv, 0); + return; + } + } else { + oentry = &HeNEXT(entry); + } + } } while (--i >= 0); /* You can't get here, hence assertion should always fail. */ assert (items == 0); @@ -1931,7 +1931,7 @@ S_hv_free_entries(pTHX_ HV *hv) PERL_ARGS_ASSERT_HV_FREE_ENTRIES; while ((sv = Perl_hfree_next_entry(aTHX_ hv, &index))||xhv->xhv_keys) { - SvREFCNT_dec(sv); + SvREFCNT_dec(sv); } } @@ -1958,7 +1958,7 @@ Perl_hfree_next_entry(pTHX_ HV *hv, STRLEN *indexp) PERL_ARGS_ASSERT_HFREE_NEXT_ENTRY; if (SvOOK(hv) && ((iter = HvAUX(hv)))) { - if ((entry = iter->xhv_eiter)) { + if ((entry = iter->xhv_eiter)) { /* the iterator may get resurrected after each * destructor call, so check each time */ if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */ @@ -1977,31 +1977,31 @@ Perl_hfree_next_entry(pTHX_ HV *hv, STRLEN *indexp) } if (!((XPVHV*)SvANY(hv))->xhv_keys) - return NULL; + return NULL; array = HvARRAY(hv); assert(array); while ( ! ((entry = array[*indexp])) ) { - if ((*indexp)++ >= HvMAX(hv)) - *indexp = 0; - assert(*indexp != orig_index); + if ((*indexp)++ >= HvMAX(hv)) + *indexp = 0; + assert(*indexp != orig_index); } array[*indexp] = HeNEXT(entry); ((XPVHV*) SvANY(hv))->xhv_keys--; if ( PL_phase != PERL_PHASE_DESTRUCT && HvENAME(hv) - && HeVAL(entry) && isGV(HeVAL(entry)) - && GvHV(HeVAL(entry)) && HvENAME(GvHV(HeVAL(entry))) + && HeVAL(entry) && isGV(HeVAL(entry)) + && GvHV(HeVAL(entry)) && HvENAME(GvHV(HeVAL(entry))) ) { - STRLEN klen; - const char * const key = HePV(entry,klen); - if ((klen > 1 && key[klen-1]==':' && key[klen-2]==':') - || (klen == 1 && key[0] == ':')) { - mro_package_moved( - NULL, GvHV(HeVAL(entry)), - (GV *)HeVAL(entry), 0 - ); - } + STRLEN klen; + const char * const key = HePV(entry,klen); + if ((klen > 1 && key[klen-1]==':' && key[klen-2]==':') + || (klen == 1 && key[0] == ':')) { + mro_package_moved( + NULL, GvHV(HeVAL(entry)), + (GV *)HeVAL(entry), 0 + ); + } } return hv_free_ent_ret(hv, entry); } @@ -2029,7 +2029,7 @@ Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags) SSize_t orig_ix = PL_tmps_ix; /* silence compiler warning about unitialized vars */ if (!hv) - return; + return; save = cBOOL(SvREFCNT(hv)); DEBUG_A(Perl_hv_assert(aTHX_ hv)); xhv = (XPVHV*)SvANY(hv); @@ -2048,9 +2048,9 @@ Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags) if (PL_stashcache) { DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for '%" HEKf "'\n", HEKfARG(HvNAME_HEK(hv)))); - (void)hv_deletehek(PL_stashcache, HvNAME_HEK(hv), G_DISCARD); + (void)hv_deletehek(PL_stashcache, HvNAME_HEK(hv), G_DISCARD); } - hv_name_set(hv, NULL, 0, 0); + hv_name_set(hv, NULL, 0, 0); } if (save) { /* avoid hv being freed when calling destructors below */ @@ -2064,12 +2064,12 @@ Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags) const char *name; if (HvENAME_get(hv)) { - if (PL_phase != PERL_PHASE_DESTRUCT) - mro_isa_changed_in(hv); + if (PL_phase != PERL_PHASE_DESTRUCT) + mro_isa_changed_in(hv); if (PL_stashcache) { DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for effective name '%" HEKf "'\n", HEKfARG(HvENAME_HEK(hv)))); - (void)hv_deletehek(PL_stashcache, HvENAME_HEK(hv), G_DISCARD); + (void)hv_deletehek(PL_stashcache, HvENAME_HEK(hv), G_DISCARD); } } @@ -2080,41 +2080,41 @@ Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags) if (name && PL_stashcache) { DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for name '%" HEKf "'\n", HEKfARG(HvNAME_HEK(hv)))); - (void)hv_deletehek(PL_stashcache, HvNAME_HEK(hv), G_DISCARD); + (void)hv_deletehek(PL_stashcache, HvNAME_HEK(hv), G_DISCARD); } - hv_name_set(hv, NULL, 0, flags); + hv_name_set(hv, NULL, 0, flags); } if((meta = HvAUX(hv)->xhv_mro_meta)) { - if (meta->mro_linear_all) { - SvREFCNT_dec_NN(meta->mro_linear_all); - /* mro_linear_current is just acting as a shortcut pointer, - hence the else. */ - } - else - /* Only the current MRO is stored, so this owns the data. - */ - SvREFCNT_dec(meta->mro_linear_current); - SvREFCNT_dec(meta->mro_nextmethod); - SvREFCNT_dec(meta->isa); - SvREFCNT_dec(meta->super); - Safefree(meta); - HvAUX(hv)->xhv_mro_meta = NULL; + if (meta->mro_linear_all) { + SvREFCNT_dec_NN(meta->mro_linear_all); + /* mro_linear_current is just acting as a shortcut pointer, + hence the else. */ + } + else + /* Only the current MRO is stored, so this owns the data. + */ + SvREFCNT_dec(meta->mro_linear_current); + SvREFCNT_dec(meta->mro_nextmethod); + SvREFCNT_dec(meta->isa); + SvREFCNT_dec(meta->super); + Safefree(meta); + HvAUX(hv)->xhv_mro_meta = NULL; } if (!HvAUX(hv)->xhv_name_u.xhvnameu_name && ! HvAUX(hv)->xhv_backreferences) - SvFLAGS(hv) &= ~SVf_OOK; + SvFLAGS(hv) &= ~SVf_OOK; } if (!SvOOK(hv)) { - Safefree(HvARRAY(hv)); + Safefree(HvARRAY(hv)); xhv->xhv_max = PERL_HASH_DEFAULT_HvMAX; /* HvMAX(hv) = 7 (it's a normal hash) */ - HvARRAY(hv) = 0; + HvARRAY(hv) = 0; } /* if we're freeing the HV, the SvMAGIC field has been reused for * other purposes, and so there can't be any placeholder magic */ if (SvREFCNT(hv)) - HvPLACEHOLDERS_set(hv, 0); + HvPLACEHOLDERS_set(hv, 0); if (SvRMAGICAL(hv)) - mg_clear(MUTABLE_SV(hv)); + mg_clear(MUTABLE_SV(hv)); if (save) { /* disarm hv's premature free guard */ @@ -2162,13 +2162,13 @@ Perl_hv_fill(pTHX_ HV *const hv) * I would have thought counting up was better. * - Yves */ - HE *const *const last = ents + HvMAX(hv); - count = last + 1 - ents; + HE *const *const last = ents + HvMAX(hv); + count = last + 1 - ents; - do { - if (!*ents) - --count; - } while (++ents <= last); + do { + if (!*ents) + --count; + } while (++ents <= last); } return count; } @@ -2279,20 +2279,20 @@ Perl_hv_iterinit(pTHX_ HV *hv) PERL_ARGS_ASSERT_HV_ITERINIT; if (SvOOK(hv)) { - struct xpvhv_aux * iter = HvAUX(hv); - HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */ - if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */ - HvLAZYDEL_off(hv); - hv_free_ent(hv, entry); - } - iter = HvAUX(hv); /* may have been reallocated */ - iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ - iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ + struct xpvhv_aux * iter = HvAUX(hv); + HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */ + if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */ + HvLAZYDEL_off(hv); + hv_free_ent(hv, entry); + } + iter = HvAUX(hv); /* may have been reallocated */ + iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ + iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ #ifdef PERL_HASH_RANDOMIZE_KEYS iter->xhv_last_rand = iter->xhv_rand; #endif } else { - hv_auxinit(hv); + hv_auxinit(hv); } /* note this includes placeholders! */ @@ -2326,12 +2326,12 @@ Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) { PERL_ARGS_ASSERT_HV_RITER_SET; if (SvOOK(hv)) { - iter = HvAUX(hv); + iter = HvAUX(hv); } else { - if (riter == -1) - return; + if (riter == -1) + return; - iter = hv_auxinit(hv); + iter = hv_auxinit(hv); } iter->xhv_riter = riter; } @@ -2361,14 +2361,14 @@ Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) { PERL_ARGS_ASSERT_HV_EITER_SET; if (SvOOK(hv)) { - iter = HvAUX(hv); + iter = HvAUX(hv); } else { - /* 0 is the default so don't go malloc()ing a new structure just to - hold 0. */ - if (!eiter) - return; + /* 0 is the default so don't go malloc()ing a new structure just to + hold 0. */ + if (!eiter) + return; - iter = hv_auxinit(hv); + iter = hv_auxinit(hv); } iter->xhv_eiter = eiter; } @@ -2383,64 +2383,64 @@ Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags) PERL_ARGS_ASSERT_HV_NAME_SET; if (len > I32_MAX) - Perl_croak(aTHX_ "panic: hv name too long (%" UVuf ")", (UV) len); + Perl_croak(aTHX_ "panic: hv name too long (%" UVuf ")", (UV) len); if (SvOOK(hv)) { - iter = HvAUX(hv); - if (iter->xhv_name_u.xhvnameu_name) { - if(iter->xhv_name_count) { - if(flags & HV_NAME_SETALL) { - HEK ** const this_name = HvAUX(hv)->xhv_name_u.xhvnameu_names; - HEK **hekp = this_name + ( - iter->xhv_name_count < 0 - ? -iter->xhv_name_count - : iter->xhv_name_count - ); - while(hekp-- > this_name+1) - unshare_hek_or_pvn(*hekp, 0, 0, 0); - /* The first elem may be null. */ - if(*this_name) unshare_hek_or_pvn(*this_name, 0, 0, 0); - Safefree(this_name); + iter = HvAUX(hv); + if (iter->xhv_name_u.xhvnameu_name) { + if(iter->xhv_name_count) { + if(flags & HV_NAME_SETALL) { + HEK ** const this_name = HvAUX(hv)->xhv_name_u.xhvnameu_names; + HEK **hekp = this_name + ( + iter->xhv_name_count < 0 + ? -iter->xhv_name_count + : iter->xhv_name_count + ); + while(hekp-- > this_name+1) + unshare_hek_or_pvn(*hekp, 0, 0, 0); + /* The first elem may be null. */ + if(*this_name) unshare_hek_or_pvn(*this_name, 0, 0, 0); + Safefree(this_name); iter = HvAUX(hv); /* may been realloced */ - spot = &iter->xhv_name_u.xhvnameu_name; - iter->xhv_name_count = 0; - } - else { - if(iter->xhv_name_count > 0) { - /* shift some things over */ - Renew( - iter->xhv_name_u.xhvnameu_names, iter->xhv_name_count + 1, HEK * - ); - spot = iter->xhv_name_u.xhvnameu_names; - spot[iter->xhv_name_count] = spot[1]; - spot[1] = spot[0]; - iter->xhv_name_count = -(iter->xhv_name_count + 1); - } - else if(*(spot = iter->xhv_name_u.xhvnameu_names)) { - unshare_hek_or_pvn(*spot, 0, 0, 0); - } - } - } - else if (flags & HV_NAME_SETALL) { - unshare_hek_or_pvn(iter->xhv_name_u.xhvnameu_name, 0, 0, 0); + spot = &iter->xhv_name_u.xhvnameu_name; + iter->xhv_name_count = 0; + } + else { + if(iter->xhv_name_count > 0) { + /* shift some things over */ + Renew( + iter->xhv_name_u.xhvnameu_names, iter->xhv_name_count + 1, HEK * + ); + spot = iter->xhv_name_u.xhvnameu_names; + spot[iter->xhv_name_count] = spot[1]; + spot[1] = spot[0]; + iter->xhv_name_count = -(iter->xhv_name_count + 1); + } + else if(*(spot = iter->xhv_name_u.xhvnameu_names)) { + unshare_hek_or_pvn(*spot, 0, 0, 0); + } + } + } + else if (flags & HV_NAME_SETALL) { + unshare_hek_or_pvn(iter->xhv_name_u.xhvnameu_name, 0, 0, 0); iter = HvAUX(hv); /* may been realloced */ - spot = &iter->xhv_name_u.xhvnameu_name; - } - else { - HEK * const existing_name = iter->xhv_name_u.xhvnameu_name; - Newx(iter->xhv_name_u.xhvnameu_names, 2, HEK *); - iter->xhv_name_count = -2; - spot = iter->xhv_name_u.xhvnameu_names; - spot[1] = existing_name; - } - } - else { spot = &iter->xhv_name_u.xhvnameu_name; iter->xhv_name_count = 0; } + spot = &iter->xhv_name_u.xhvnameu_name; + } + else { + HEK * const existing_name = iter->xhv_name_u.xhvnameu_name; + Newx(iter->xhv_name_u.xhvnameu_names, 2, HEK *); + iter->xhv_name_count = -2; + spot = iter->xhv_name_u.xhvnameu_names; + spot[1] = existing_name; + } + } + else { spot = &iter->xhv_name_u.xhvnameu_name; iter->xhv_name_count = 0; } } else { - if (name == 0) - return; + if (name == 0) + return; - iter = hv_auxinit(hv); - spot = &iter->xhv_name_u.xhvnameu_name; + iter = hv_auxinit(hv); + spot = &iter->xhv_name_u.xhvnameu_name; } PERL_HASH(hash, name, len); *spot = name ? share_hek(name, flags & SVf_UTF8 ? -(I32)len : (I32)len, hash) : NULL; @@ -2457,11 +2457,11 @@ hek_eq_pvn_flags(pTHX_ const HEK *hek, const char* pv, const I32 pvlen, const U3 if (flags & SVf_UTF8) return (bytes_cmp_utf8( (const U8*)HEK_KEY(hek), HEK_LEN(hek), - (const U8*)pv, pvlen) == 0); + (const U8*)pv, pvlen) == 0); else return (bytes_cmp_utf8( (const U8*)pv, pvlen, - (const U8*)HEK_KEY(hek), HEK_LEN(hek)) == 0); + (const U8*)HEK_KEY(hek), HEK_LEN(hek)) == 0); } else return HEK_LEN(hek) == pvlen && ((HEK_KEY(hek) == pv) @@ -2489,45 +2489,45 @@ Perl_hv_ename_add(pTHX_ HV *hv, const char *name, U32 len, U32 flags) PERL_ARGS_ASSERT_HV_ENAME_ADD; if (len > I32_MAX) - Perl_croak(aTHX_ "panic: hv name too long (%" UVuf ")", (UV) len); + Perl_croak(aTHX_ "panic: hv name too long (%" UVuf ")", (UV) len); PERL_HASH(hash, name, len); if (aux->xhv_name_count) { - I32 count = aux->xhv_name_count; - HEK ** const xhv_name = aux->xhv_name_u.xhvnameu_names + (count<0); - HEK **hekp = xhv_name + (count < 0 ? -count - 1 : count); - while (hekp-- > xhv_name) - { - assert(*hekp); - if ( + I32 count = aux->xhv_name_count; + HEK ** const xhv_name = aux->xhv_name_u.xhvnameu_names + (count<0); + HEK **hekp = xhv_name + (count < 0 ? -count - 1 : count); + while (hekp-- > xhv_name) + { + assert(*hekp); + if ( (HEK_UTF8(*hekp) || (flags & SVf_UTF8)) ? hek_eq_pvn_flags(aTHX_ *hekp, name, (I32)len, flags) - : (HEK_LEN(*hekp) == (I32)len && memEQ(HEK_KEY(*hekp), name, len)) + : (HEK_LEN(*hekp) == (I32)len && memEQ(HEK_KEY(*hekp), name, len)) ) { - if (hekp == xhv_name && count < 0) - aux->xhv_name_count = -count; - return; - } - } - if (count < 0) aux->xhv_name_count--, count = -count; - else aux->xhv_name_count++; - Renew(aux->xhv_name_u.xhvnameu_names, count + 1, HEK *); - (aux->xhv_name_u.xhvnameu_names)[count] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash); + if (hekp == xhv_name && count < 0) + aux->xhv_name_count = -count; + return; + } + } + if (count < 0) aux->xhv_name_count--, count = -count; + else aux->xhv_name_count++; + Renew(aux->xhv_name_u.xhvnameu_names, count + 1, HEK *); + (aux->xhv_name_u.xhvnameu_names)[count] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash); } else { - HEK *existing_name = aux->xhv_name_u.xhvnameu_name; - if ( - existing_name && ( + HEK *existing_name = aux->xhv_name_u.xhvnameu_name; + if ( + existing_name && ( (HEK_UTF8(existing_name) || (flags & SVf_UTF8)) ? hek_eq_pvn_flags(aTHX_ existing_name, name, (I32)len, flags) - : (HEK_LEN(existing_name) == (I32)len && memEQ(HEK_KEY(existing_name), name, len)) - ) - ) return; - Newx(aux->xhv_name_u.xhvnameu_names, 2, HEK *); - aux->xhv_name_count = existing_name ? 2 : -2; - *aux->xhv_name_u.xhvnameu_names = existing_name; - (aux->xhv_name_u.xhvnameu_names)[1] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash); + : (HEK_LEN(existing_name) == (I32)len && memEQ(HEK_KEY(existing_name), name, len)) + ) + ) return; + Newx(aux->xhv_name_u.xhvnameu_names, 2, HEK *); + aux->xhv_name_count = existing_name ? 2 : -2; + *aux->xhv_name_u.xhvnameu_names = existing_name; + (aux->xhv_name_u.xhvnameu_names)[1] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash); } } @@ -2551,7 +2551,7 @@ Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len, U32 flags) PERL_ARGS_ASSERT_HV_ENAME_DELETE; if (len > I32_MAX) - Perl_croak(aTHX_ "panic: hv name too long (%" UVuf ")", (UV) len); + Perl_croak(aTHX_ "panic: hv name too long (%" UVuf ")", (UV) len); if (!SvOOK(hv)) return; @@ -2559,53 +2559,53 @@ Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len, U32 flags) if (!aux->xhv_name_u.xhvnameu_name) return; if (aux->xhv_name_count) { - HEK ** const namep = aux->xhv_name_u.xhvnameu_names; - I32 const count = aux->xhv_name_count; - HEK **victim = namep + (count < 0 ? -count : count); - while (victim-- > namep + 1) - if ( + HEK ** const namep = aux->xhv_name_u.xhvnameu_names; + I32 const count = aux->xhv_name_count; + HEK **victim = namep + (count < 0 ? -count : count); + while (victim-- > namep + 1) + if ( (HEK_UTF8(*victim) || (flags & SVf_UTF8)) ? hek_eq_pvn_flags(aTHX_ *victim, name, (I32)len, flags) - : (HEK_LEN(*victim) == (I32)len && memEQ(HEK_KEY(*victim), name, len)) - ) { - unshare_hek_or_pvn(*victim, 0, 0, 0); + : (HEK_LEN(*victim) == (I32)len && memEQ(HEK_KEY(*victim), name, len)) + ) { + unshare_hek_or_pvn(*victim, 0, 0, 0); aux = HvAUX(hv); /* may been realloced */ - if (count < 0) ++aux->xhv_name_count; - else --aux->xhv_name_count; - if ( - (aux->xhv_name_count == 1 || aux->xhv_name_count == -1) - && !*namep - ) { /* if there are none left */ - Safefree(namep); - aux->xhv_name_u.xhvnameu_names = NULL; - aux->xhv_name_count = 0; - } - else { - /* Move the last one back to fill the empty slot. It - does not matter what order they are in. */ - *victim = *(namep + (count < 0 ? -count : count) - 1); - } - return; - } - if ( - count > 0 && ((HEK_UTF8(*namep) || (flags & SVf_UTF8)) + if (count < 0) ++aux->xhv_name_count; + else --aux->xhv_name_count; + if ( + (aux->xhv_name_count == 1 || aux->xhv_name_count == -1) + && !*namep + ) { /* if there are none left */ + Safefree(namep); + aux->xhv_name_u.xhvnameu_names = NULL; + aux->xhv_name_count = 0; + } + else { + /* Move the last one back to fill the empty slot. It + does not matter what order they are in. */ + *victim = *(namep + (count < 0 ? -count : count) - 1); + } + return; + } + if ( + count > 0 && ((HEK_UTF8(*namep) || (flags & SVf_UTF8)) ? hek_eq_pvn_flags(aTHX_ *namep, name, (I32)len, flags) - : (HEK_LEN(*namep) == (I32)len && memEQ(HEK_KEY(*namep), name, len)) + : (HEK_LEN(*namep) == (I32)len && memEQ(HEK_KEY(*namep), name, len)) ) - ) { - aux->xhv_name_count = -count; - } + ) { + aux->xhv_name_count = -count; + } } else if( (HEK_UTF8(aux->xhv_name_u.xhvnameu_name) || (flags & SVf_UTF8)) ? hek_eq_pvn_flags(aTHX_ aux->xhv_name_u.xhvnameu_name, name, (I32)len, flags) - : (HEK_LEN(aux->xhv_name_u.xhvnameu_name) == (I32)len && + : (HEK_LEN(aux->xhv_name_u.xhvnameu_name) == (I32)len && memEQ(HEK_KEY(aux->xhv_name_u.xhvnameu_name), name, len)) ) { - HEK * const namehek = aux->xhv_name_u.xhvnameu_name; - Newx(aux->xhv_name_u.xhvnameu_names, 1, HEK *); - *aux->xhv_name_u.xhvnameu_names = namehek; - aux->xhv_name_count = -1; + HEK * const namehek = aux->xhv_name_u.xhvnameu_name; + Newx(aux->xhv_name_u.xhvnameu_names, 1, HEK *); + *aux->xhv_name_u.xhvnameu_names = namehek; + aux->xhv_name_count = -1; } } @@ -2626,15 +2626,15 @@ Perl_hv_kill_backrefs(pTHX_ HV *hv) { PERL_ARGS_ASSERT_HV_KILL_BACKREFS; if (!SvOOK(hv)) - return; + return; av = HvAUX(hv)->xhv_backreferences; if (av) { - HvAUX(hv)->xhv_backreferences = 0; - Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av); - if (SvTYPE(av) == SVt_PVAV) - SvREFCNT_dec_NN(av); + HvAUX(hv)->xhv_backreferences = 0; + Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av); + if (SvTYPE(av) == SVt_PVAV) + SvREFCNT_dec_NN(av); } } @@ -2684,21 +2684,21 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) xhv = (XPVHV*)SvANY(hv); if (!SvOOK(hv)) { - /* Too many things (well, pp_each at least) merrily assume that you can - call hv_iternext without calling hv_iterinit, so we'll have to deal - with it. */ - hv_iterinit(hv); + /* Too many things (well, pp_each at least) merrily assume that you can + call hv_iternext without calling hv_iterinit, so we'll have to deal + with it. */ + hv_iterinit(hv); } iter = HvAUX(hv); oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */ if (SvMAGICAL(hv) && SvRMAGICAL(hv)) { - if ( ( mg = mg_find((const SV *)hv, PERL_MAGIC_tied) ) ) { + if ( ( mg = mg_find((const SV *)hv, PERL_MAGIC_tied) ) ) { SV * const key = sv_newmortal(); if (entry) { sv_setsv(key, HeSVKEY_force(entry)); SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */ - HeSVKEY_set(entry, NULL); + HeSVKEY_set(entry, NULL); } else { char *k; @@ -2706,7 +2706,7 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) /* one HE per MAGICAL hash */ iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */ - HvLAZYDEL_on(hv); /* make sure entry gets freed */ + HvLAZYDEL_on(hv); /* make sure entry gets freed */ Zero(entry, 1, HE); Newxz(k, HEK_BASESIZE + sizeof(const SV *), char); hek = (HEK*)k; @@ -2724,21 +2724,21 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) del_HE(entry); iter = HvAUX(hv); /* may been realloced */ iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ - HvLAZYDEL_off(hv); + HvLAZYDEL_off(hv); return NULL; } } #if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__) /* set up %ENV for iteration */ if (!entry && SvRMAGICAL((const SV *)hv) - && mg_find((const SV *)hv, PERL_MAGIC_env)) { - prime_env_iter(); + && mg_find((const SV *)hv, PERL_MAGIC_env)) { + prime_env_iter(); #ifdef VMS - /* The prime_env_iter() on VMS just loaded up new hash values - * so the iteration count needs to be reset back to the beginning - */ - hv_iterinit(hv); - iter = HvAUX(hv); - oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */ + /* The prime_env_iter() on VMS just loaded up new hash values + * so the iteration count needs to be reset back to the beginning + */ + hv_iterinit(hv); + iter = HvAUX(hv); + oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */ #endif } #endif @@ -2749,7 +2749,7 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) /* At start of hash, entry is NULL. */ if (entry) { - entry = HeNEXT(entry); + entry = HeNEXT(entry); if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) { /* * Skip past any placeholders -- don't want to include them in @@ -2758,7 +2758,7 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) while (entry && HeVAL(entry) == &PL_sv_placeholder) { entry = HeNEXT(entry); } - } + } } #ifdef PERL_HASH_RANDOMIZE_KEYS @@ -2776,31 +2776,31 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) /* Skip the entire loop if the hash is empty. */ if ((flags & HV_ITERNEXT_WANTPLACEHOLDERS) - ? HvTOTALKEYS(hv) : HvUSEDKEYS(hv)) { - while (!entry) { - /* OK. Come to the end of the current list. Grab the next one. */ - - iter->xhv_riter++; /* HvRITER(hv)++ */ - if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) { - /* There is no next one. End of the hash. */ - iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ + ? HvTOTALKEYS(hv) : HvUSEDKEYS(hv)) { + while (!entry) { + /* OK. Come to the end of the current list. Grab the next one. */ + + iter->xhv_riter++; /* HvRITER(hv)++ */ + if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) { + /* There is no next one. End of the hash. */ + iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ #ifdef PERL_HASH_RANDOMIZE_KEYS iter->xhv_last_rand = iter->xhv_rand; /* reset xhv_last_rand so we can detect inserts during traversal */ #endif - break; - } + break; + } entry = (HvARRAY(hv))[ PERL_HASH_ITER_BUCKET(iter) & xhv->xhv_max ]; - if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) { - /* If we have an entry, but it's a placeholder, don't count it. - Try the next. */ - while (entry && HeVAL(entry) == &PL_sv_placeholder) - entry = HeNEXT(entry); - } - /* Will loop again if this linked list starts NULL - (for HV_ITERNEXT_WANTPLACEHOLDERS) - or if we run through it and find only placeholders. */ - } + if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) { + /* If we have an entry, but it's a placeholder, don't count it. + Try the next. */ + while (entry && HeVAL(entry) == &PL_sv_placeholder) + entry = HeNEXT(entry); + } + /* Will loop again if this linked list starts NULL + (for HV_ITERNEXT_WANTPLACEHOLDERS) + or if we run through it and find only placeholders. */ + } } else { iter->xhv_riter = -1; @@ -2810,8 +2810,8 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) } if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */ - HvLAZYDEL_off(hv); - hv_free_ent(hv, oldentry); + HvLAZYDEL_off(hv); + hv_free_ent(hv, oldentry); } iter = HvAUX(hv); /* may been realloced */ @@ -2834,14 +2834,14 @@ Perl_hv_iterkey(pTHX_ HE *entry, I32 *retlen) PERL_ARGS_ASSERT_HV_ITERKEY; if (HeKLEN(entry) == HEf_SVKEY) { - STRLEN len; - char * const p = SvPV(HeKEY_sv(entry), len); - *retlen = len; - return p; + STRLEN len; + char * const p = SvPV(HeKEY_sv(entry), len); + *retlen = len; + return p; } else { - *retlen = HeKLEN(entry); - return HeKEY(entry); + *retlen = HeKLEN(entry); + return HeKEY(entry); } } @@ -2879,14 +2879,14 @@ Perl_hv_iterval(pTHX_ HV *hv, HE *entry) PERL_ARGS_ASSERT_HV_ITERVAL; if (SvRMAGICAL(hv)) { - if (mg_find((const SV *)hv, PERL_MAGIC_tied)) { - SV* const sv = sv_newmortal(); - if (HeKLEN(entry) == HEf_SVKEY) - mg_copy(MUTABLE_SV(hv), sv, (char*)HeKEY_sv(entry), HEf_SVKEY); - else - mg_copy(MUTABLE_SV(hv), sv, HeKEY(entry), HeKLEN(entry)); - return sv; - } + if (mg_find((const SV *)hv, PERL_MAGIC_tied)) { + SV* const sv = sv_newmortal(); + if (HeKLEN(entry) == HEf_SVKEY) + mg_copy(MUTABLE_SV(hv), sv, (char*)HeKEY_sv(entry), HEf_SVKEY); + else + mg_copy(MUTABLE_SV(hv), sv, HeKEY(entry), HeKLEN(entry)); + return sv; + } } return HeVAL(entry); } @@ -2908,7 +2908,7 @@ Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen) PERL_ARGS_ASSERT_HV_ITERNEXTSV; if (!he) - return NULL; + return NULL; *key = hv_iterkey(he, retlen); return hv_iterval(hv, he); } @@ -2957,19 +2957,19 @@ S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash) struct shared_he *he = NULL; if (hek) { - /* Find the shared he which is just before us in memory. */ - he = (struct shared_he *)(((char *)hek) - - STRUCT_OFFSET(struct shared_he, - shared_he_hek)); + /* Find the shared he which is just before us in memory. */ + he = (struct shared_he *)(((char *)hek) + - STRUCT_OFFSET(struct shared_he, + shared_he_hek)); - /* Assert that the caller passed us a genuine (or at least consistent) - shared hek */ - assert (he->shared_he_he.hent_hek == hek); + /* Assert that the caller passed us a genuine (or at least consistent) + shared hek */ + assert (he->shared_he_he.hent_hek == hek); - if (he->shared_he_he.he_valu.hent_refcount - 1) { - --he->shared_he_he.he_valu.hent_refcount; - return; - } + if (he->shared_he_he.he_valu.hent_refcount - 1) { + --he->shared_he_he.he_valu.hent_refcount; + return; + } hash = HEK_HASH(hek); } else if (len < 0) { @@ -2986,14 +2986,14 @@ S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash) /* what follows was the moral equivalent of: if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) { - if (--*Svp == NULL) - hv_delete(PL_strtab, str, len, G_DISCARD, hash); + if (--*Svp == NULL) + hv_delete(PL_strtab, str, len, G_DISCARD, hash); } */ xhv = (XPVHV*)SvANY(PL_strtab); /* assert(xhv_array != 0) */ oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)]; if (he) { - const HE *const he_he = &(he->shared_he_he); + const HE *const he_he = &(he->shared_he_he); for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) { if (entry == he_he) break; @@ -3022,13 +3022,13 @@ S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash) } if (!entry) - Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), - "Attempt to free nonexistent shared string '%s'%s" - pTHX__FORMAT, - hek ? HEK_KEY(hek) : str, - ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "Attempt to free nonexistent shared string '%s'%s" + pTHX__FORMAT, + hek ? HEK_KEY(hek) : str, + ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE); if (k_flags & HVhek_FREEKEY) - Safefree(str); + Safefree(str); } /* get a (constant) string ptr from the global string table @@ -3083,73 +3083,73 @@ S_share_hek_flags(pTHX_ const char *str, STRLEN len, U32 hash, int flags) /* what follows is the moral equivalent of: if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE))) - hv_store(PL_strtab, str, len, NULL, hash); + hv_store(PL_strtab, str, len, NULL, hash); - Can't rehash the shared string table, so not sure if it's worth - counting the number of entries in the linked list + Can't rehash the shared string table, so not sure if it's worth + counting the number of entries in the linked list */ /* assert(xhv_array != 0) */ entry = (HvARRAY(PL_strtab))[hindex]; for (;entry; entry = HeNEXT(entry)) { - if (HeHASH(entry) != hash) /* strings can't be equal */ - continue; - if (HeKLEN(entry) != (SSize_t) len) - continue; - if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */ - continue; - if (HeKFLAGS(entry) != flags_masked) - continue; - break; + if (HeHASH(entry) != hash) /* strings can't be equal */ + continue; + if (HeKLEN(entry) != (SSize_t) len) + continue; + if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */ + continue; + if (HeKFLAGS(entry) != flags_masked) + continue; + break; } if (!entry) { - /* What used to be head of the list. - If this is NULL, then we're the first entry for this slot, which - means we need to increate fill. */ - struct shared_he *new_entry; - HEK *hek; - char *k; - HE **const head = &HvARRAY(PL_strtab)[hindex]; - HE *const next = *head; - - /* We don't actually store a HE from the arena and a regular HEK. - Instead we allocate one chunk of memory big enough for both, - and put the HEK straight after the HE. This way we can find the - HE directly from the HEK. - */ - - Newx(k, STRUCT_OFFSET(struct shared_he, - shared_he_hek.hek_key[0]) + len + 2, char); - new_entry = (struct shared_he *)k; - entry = &(new_entry->shared_he_he); - hek = &(new_entry->shared_he_hek); - - Copy(str, HEK_KEY(hek), len, char); - HEK_KEY(hek)[len] = 0; - HEK_LEN(hek) = len; - HEK_HASH(hek) = hash; - HEK_FLAGS(hek) = (unsigned char)flags_masked; - - /* Still "point" to the HEK, so that other code need not know what - we're up to. */ - HeKEY_hek(entry) = hek; - entry->he_valu.hent_refcount = 0; - HeNEXT(entry) = next; - *head = entry; - - xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */ - if (!next) { /* initial entry? */ - } else if ( DO_HSPLIT(xhv) ) { + /* What used to be head of the list. + If this is NULL, then we're the first entry for this slot, which + means we need to increate fill. */ + struct shared_he *new_entry; + HEK *hek; + char *k; + HE **const head = &HvARRAY(PL_strtab)[hindex]; + HE *const next = *head; + + /* We don't actually store a HE from the arena and a regular HEK. + Instead we allocate one chunk of memory big enough for both, + and put the HEK straight after the HE. This way we can find the + HE directly from the HEK. + */ + + Newx(k, STRUCT_OFFSET(struct shared_he, + shared_he_hek.hek_key[0]) + len + 2, char); + new_entry = (struct shared_he *)k; + entry = &(new_entry->shared_he_he); + hek = &(new_entry->shared_he_hek); + + Copy(str, HEK_KEY(hek), len, char); + HEK_KEY(hek)[len] = 0; + HEK_LEN(hek) = len; + HEK_HASH(hek) = hash; + HEK_FLAGS(hek) = (unsigned char)flags_masked; + + /* Still "point" to the HEK, so that other code need not know what + we're up to. */ + HeKEY_hek(entry) = hek; + entry->he_valu.hent_refcount = 0; + HeNEXT(entry) = next; + *head = entry; + + xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */ + if (!next) { /* initial entry? */ + } else if ( DO_HSPLIT(xhv) ) { const STRLEN oldsize = xhv->xhv_max + 1; hsplit(PL_strtab, oldsize, oldsize * 2); - } + } } ++entry->he_valu.hent_refcount; if (flags & HVhek_FREEKEY) - Safefree(str); + Safefree(str); return HeKEY_hek(entry); } @@ -3162,11 +3162,11 @@ Perl_hv_placeholders_p(pTHX_ HV *hv) PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P; if (!mg) { - mg = sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, 0); + mg = sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, 0); - if (!mg) { - Perl_die(aTHX_ "panic: hv_placeholders_p"); - } + if (!mg) { + Perl_die(aTHX_ "panic: hv_placeholders_p"); + } } return &(mg->mg_len); } @@ -3191,10 +3191,10 @@ Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph) PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET; if (mg) { - mg->mg_len = ph; + mg->mg_len = ph; } else if (ph) { - if (!sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, ph)) - Perl_die(aTHX_ "panic: hv_placeholders_set"); + if (!sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, ph)) + Perl_die(aTHX_ "panic: hv_placeholders_set"); } /* else we don't need to add magic to record 0 placeholders. */ } @@ -3208,34 +3208,34 @@ S_refcounted_he_value(pTHX_ const struct refcounted_he *he) switch(he->refcounted_he_data[0] & HVrhek_typemask) { case HVrhek_undef: - value = newSV(0); - break; + value = newSV(0); + break; case HVrhek_delete: - value = &PL_sv_placeholder; - break; + value = &PL_sv_placeholder; + break; case HVrhek_IV: - value = newSViv(he->refcounted_he_val.refcounted_he_u_iv); - break; + value = newSViv(he->refcounted_he_val.refcounted_he_u_iv); + break; case HVrhek_UV: - value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv); - break; + value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv); + break; case HVrhek_PV: case HVrhek_PV_UTF8: - /* Create a string SV that directly points to the bytes in our - structure. */ - value = newSV_type(SVt_PV); - SvPV_set(value, (char *) he->refcounted_he_data + 1); - SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len); - /* This stops anything trying to free it */ - SvLEN_set(value, 0); - SvPOK_on(value); - SvREADONLY_on(value); - if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8) - SvUTF8_on(value); - break; + /* Create a string SV that directly points to the bytes in our + structure. */ + value = newSV_type(SVt_PV); + SvPV_set(value, (char *) he->refcounted_he_data + 1); + SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len); + /* This stops anything trying to free it */ + SvLEN_set(value, 0); + SvPOK_on(value); + SvREADONLY_on(value); + if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8) + SvUTF8_on(value); + break; default: - Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %" UVxf, - (UV)he->refcounted_he_data[0]); + Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %" UVxf, + (UV)he->refcounted_he_data[0]); } return value; } @@ -3256,8 +3256,8 @@ Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain, U32 flags) U32 placeholders, max; if (flags) - Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %" UVxf, - (UV)flags); + Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %" UVxf, + (UV)flags); /* We could chase the chain once to get an idea of the number of keys, and call ksplit. But for now we'll make a potentially inefficient @@ -3265,77 +3265,77 @@ Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain, U32 flags) hv = newHV(); max = HvMAX(hv); if (!HvARRAY(hv)) { - char *array; - Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char); - HvARRAY(hv) = (HE**)array; + char *array; + Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char); + HvARRAY(hv) = (HE**)array; } placeholders = 0; while (chain) { #ifdef USE_ITHREADS - U32 hash = chain->refcounted_he_hash; + U32 hash = chain->refcounted_he_hash; #else - U32 hash = HEK_HASH(chain->refcounted_he_hek); + U32 hash = HEK_HASH(chain->refcounted_he_hek); #endif - HE **oentry = &((HvARRAY(hv))[hash & max]); - HE *entry = *oentry; - SV *value; - - for (; entry; entry = HeNEXT(entry)) { - if (HeHASH(entry) == hash) { - /* We might have a duplicate key here. If so, entry is older - than the key we've already put in the hash, so if they are - the same, skip adding entry. */ + HE **oentry = &((HvARRAY(hv))[hash & max]); + HE *entry = *oentry; + SV *value; + + for (; entry; entry = HeNEXT(entry)) { + if (HeHASH(entry) == hash) { + /* We might have a duplicate key here. If so, entry is older + than the key we've already put in the hash, so if they are + the same, skip adding entry. */ #ifdef USE_ITHREADS - const STRLEN klen = HeKLEN(entry); - const char *const key = HeKEY(entry); - if (klen == chain->refcounted_he_keylen - && (!!HeKUTF8(entry) - == !!(chain->refcounted_he_data[0] & HVhek_UTF8)) - && memEQ(key, REF_HE_KEY(chain), klen)) - goto next_please; + const STRLEN klen = HeKLEN(entry); + const char *const key = HeKEY(entry); + if (klen == chain->refcounted_he_keylen + && (!!HeKUTF8(entry) + == !!(chain->refcounted_he_data[0] & HVhek_UTF8)) + && memEQ(key, REF_HE_KEY(chain), klen)) + goto next_please; #else - if (HeKEY_hek(entry) == chain->refcounted_he_hek) - goto next_please; - if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek) - && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek) - && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek), - HeKLEN(entry))) - goto next_please; + if (HeKEY_hek(entry) == chain->refcounted_he_hek) + goto next_please; + if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek) + && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek) + && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek), + HeKLEN(entry))) + goto next_please; #endif - } - } - assert (!entry); - entry = new_HE(); + } + } + assert (!entry); + entry = new_HE(); #ifdef USE_ITHREADS - HeKEY_hek(entry) - = share_hek_flags(REF_HE_KEY(chain), - chain->refcounted_he_keylen, - chain->refcounted_he_hash, - (chain->refcounted_he_data[0] - & (HVhek_UTF8|HVhek_WASUTF8))); + HeKEY_hek(entry) + = share_hek_flags(REF_HE_KEY(chain), + chain->refcounted_he_keylen, + chain->refcounted_he_hash, + (chain->refcounted_he_data[0] + & (HVhek_UTF8|HVhek_WASUTF8))); #else - HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek); + HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek); #endif - value = refcounted_he_value(chain); - if (value == &PL_sv_placeholder) - placeholders++; - HeVAL(entry) = value; + value = refcounted_he_value(chain); + if (value == &PL_sv_placeholder) + placeholders++; + HeVAL(entry) = value; - /* Link it into the chain. */ - HeNEXT(entry) = *oentry; - *oentry = entry; + /* Link it into the chain. */ + HeNEXT(entry) = *oentry; + *oentry = entry; - HvTOTALKEYS(hv)++; + HvTOTALKEYS(hv)++; next_please: - chain = chain->refcounted_he_next; + chain = chain->refcounted_he_next; } if (placeholders) { - clear_placeholders(hv, placeholders); - HvTOTALKEYS(hv) -= placeholders; + clear_placeholders(hv, placeholders); + HvTOTALKEYS(hv) -= placeholders; } /* We could check in the loop to see if we encounter any keys with key @@ -3363,38 +3363,38 @@ if there is no value associated with the key. SV * Perl_refcounted_he_fetch_pvn(pTHX_ const struct refcounted_he *chain, - const char *keypv, STRLEN keylen, U32 hash, U32 flags) + const char *keypv, STRLEN keylen, U32 hash, U32 flags) { U8 utf8_flag; PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PVN; if (flags & ~(REFCOUNTED_HE_KEY_UTF8|REFCOUNTED_HE_EXISTS)) - Perl_croak(aTHX_ "panic: refcounted_he_fetch_pvn bad flags %" UVxf, - (UV)flags); + Perl_croak(aTHX_ "panic: refcounted_he_fetch_pvn bad flags %" UVxf, + (UV)flags); if (!chain) - goto ret; + goto ret; if (flags & REFCOUNTED_HE_KEY_UTF8) { - /* For searching purposes, canonicalise to Latin-1 where possible. */ - const char *keyend = keypv + keylen, *p; - STRLEN nonascii_count = 0; - for (p = keypv; p != keyend; p++) { - if (! UTF8_IS_INVARIANT(*p)) { - if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) { - goto canonicalised_key; + /* For searching purposes, canonicalise to Latin-1 where possible. */ + const char *keyend = keypv + keylen, *p; + STRLEN nonascii_count = 0; + for (p = keypv; p != keyend; p++) { + if (! UTF8_IS_INVARIANT(*p)) { + if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) { + goto canonicalised_key; } - nonascii_count++; + nonascii_count++; p++; - } - } - if (nonascii_count) { - char *q; - const char *p = keypv, *keyend = keypv + keylen; - keylen -= nonascii_count; - Newx(q, keylen, char); - SAVEFREEPV(q); - keypv = q; - for (; p != keyend; p++, q++) { - U8 c = (U8)*p; + } + } + if (nonascii_count) { + char *q; + const char *p = keypv, *keyend = keypv + keylen; + keylen -= nonascii_count; + Newx(q, keylen, char); + SAVEFREEPV(q); + keypv = q; + for (; p != keyend; p++, q++) { + U8 c = (U8)*p; if (UTF8_IS_INVARIANT(c)) { *q = (char) c; } @@ -3402,35 +3402,35 @@ Perl_refcounted_he_fetch_pvn(pTHX_ const struct refcounted_he *chain, p++; *q = (char) EIGHT_BIT_UTF8_TO_NATIVE(c, *p); } - } - } - flags &= ~REFCOUNTED_HE_KEY_UTF8; - canonicalised_key: ; + } + } + flags &= ~REFCOUNTED_HE_KEY_UTF8; + canonicalised_key: ; } utf8_flag = (flags & REFCOUNTED_HE_KEY_UTF8) ? HVhek_UTF8 : 0; if (!hash) - PERL_HASH(hash, keypv, keylen); + PERL_HASH(hash, keypv, keylen); for (; chain; chain = chain->refcounted_he_next) { - if ( + if ( #ifdef USE_ITHREADS - hash == chain->refcounted_he_hash && - keylen == chain->refcounted_he_keylen && - memEQ(REF_HE_KEY(chain), keypv, keylen) && - utf8_flag == (chain->refcounted_he_data[0] & HVhek_UTF8) + hash == chain->refcounted_he_hash && + keylen == chain->refcounted_he_keylen && + memEQ(REF_HE_KEY(chain), keypv, keylen) && + utf8_flag == (chain->refcounted_he_data[0] & HVhek_UTF8) #else - hash == HEK_HASH(chain->refcounted_he_hek) && - keylen == (STRLEN)HEK_LEN(chain->refcounted_he_hek) && - memEQ(HEK_KEY(chain->refcounted_he_hek), keypv, keylen) && - utf8_flag == (HEK_FLAGS(chain->refcounted_he_hek) & HVhek_UTF8) + hash == HEK_HASH(chain->refcounted_he_hek) && + keylen == (STRLEN)HEK_LEN(chain->refcounted_he_hek) && + memEQ(HEK_KEY(chain->refcounted_he_hek), keypv, keylen) && + utf8_flag == (HEK_FLAGS(chain->refcounted_he_hek) & HVhek_UTF8) #endif - ) { - if (flags & REFCOUNTED_HE_EXISTS) - return (chain->refcounted_he_data[0] & HVrhek_typemask) - == HVrhek_delete - ? NULL : &PL_sv_yes; - return sv_2mortal(refcounted_he_value(chain)); - } + ) { + if (flags & REFCOUNTED_HE_EXISTS) + return (chain->refcounted_he_data[0] & HVrhek_typemask) + == HVrhek_delete + ? NULL : &PL_sv_yes; + return sv_2mortal(refcounted_he_value(chain)); + } } ret: return flags & REFCOUNTED_HE_EXISTS ? NULL : &PL_sv_placeholder; @@ -3447,7 +3447,7 @@ instead of a string/length pair. SV * Perl_refcounted_he_fetch_pv(pTHX_ const struct refcounted_he *chain, - const char *key, U32 hash, U32 flags) + const char *key, U32 hash, U32 flags) { PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PV; return refcounted_he_fetch_pvn(chain, key, strlen(key), hash, flags); @@ -3464,19 +3464,19 @@ string/length pair. SV * Perl_refcounted_he_fetch_sv(pTHX_ const struct refcounted_he *chain, - SV *key, U32 hash, U32 flags) + SV *key, U32 hash, U32 flags) { const char *keypv; STRLEN keylen; PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_SV; if (flags & REFCOUNTED_HE_KEY_UTF8) - Perl_croak(aTHX_ "panic: refcounted_he_fetch_sv bad flags %" UVxf, - (UV)flags); + Perl_croak(aTHX_ "panic: refcounted_he_fetch_sv bad flags %" UVxf, + (UV)flags); keypv = SvPV_const(key, keylen); if (SvUTF8(key)) - flags |= REFCOUNTED_HE_KEY_UTF8; + flags |= REFCOUNTED_HE_KEY_UTF8; if (!hash && SvIsCOW_shared_hash(key)) - hash = SvSHARED_HASH(key); + hash = SvSHARED_HASH(key); return refcounted_he_fetch_pvn(chain, keypv, keylen, hash, flags); } @@ -3515,7 +3515,7 @@ C. struct refcounted_he * Perl_refcounted_he_new_pvn(pTHX_ struct refcounted_he *parent, - const char *keypv, STRLEN keylen, U32 hash, SV *value, U32 flags) + const char *keypv, STRLEN keylen, U32 hash, SV *value, U32 flags) { STRLEN value_len = 0; const char *value_p = NULL; @@ -3527,49 +3527,49 @@ Perl_refcounted_he_new_pvn(pTHX_ struct refcounted_he *parent, PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PVN; if (!value || value == &PL_sv_placeholder) { - value_type = HVrhek_delete; + value_type = HVrhek_delete; } else if (SvPOK(value)) { - value_type = HVrhek_PV; + value_type = HVrhek_PV; } else if (SvIOK(value)) { - value_type = SvUOK((const SV *)value) ? HVrhek_UV : HVrhek_IV; + value_type = SvUOK((const SV *)value) ? HVrhek_UV : HVrhek_IV; } else if (!SvOK(value)) { - value_type = HVrhek_undef; + value_type = HVrhek_undef; } else { - value_type = HVrhek_PV; + value_type = HVrhek_PV; } is_pv = value_type == HVrhek_PV; if (is_pv) { - /* Do it this way so that the SvUTF8() test is after the SvPV, in case - the value is overloaded, and doesn't yet have the UTF-8flag set. */ - value_p = SvPV_const(value, value_len); - if (SvUTF8(value)) - value_type = HVrhek_PV_UTF8; - key_offset = value_len + 2; + /* Do it this way so that the SvUTF8() test is after the SvPV, in case + the value is overloaded, and doesn't yet have the UTF-8flag set. */ + value_p = SvPV_const(value, value_len); + if (SvUTF8(value)) + value_type = HVrhek_PV_UTF8; + key_offset = value_len + 2; } hekflags = value_type; if (flags & REFCOUNTED_HE_KEY_UTF8) { - /* Canonicalise to Latin-1 where possible. */ - const char *keyend = keypv + keylen, *p; - STRLEN nonascii_count = 0; - for (p = keypv; p != keyend; p++) { - if (! UTF8_IS_INVARIANT(*p)) { - if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) { - goto canonicalised_key; + /* Canonicalise to Latin-1 where possible. */ + const char *keyend = keypv + keylen, *p; + STRLEN nonascii_count = 0; + for (p = keypv; p != keyend; p++) { + if (! UTF8_IS_INVARIANT(*p)) { + if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) { + goto canonicalised_key; } - nonascii_count++; + nonascii_count++; p++; - } - } - if (nonascii_count) { - char *q; - const char *p = keypv, *keyend = keypv + keylen; - keylen -= nonascii_count; - Newx(q, keylen, char); - SAVEFREEPV(q); - keypv = q; - for (; p != keyend; p++, q++) { - U8 c = (U8)*p; + } + } + if (nonascii_count) { + char *q; + const char *p = keypv, *keyend = keypv + keylen; + keylen -= nonascii_count; + Newx(q, keylen, char); + SAVEFREEPV(q); + keypv = q; + for (; p != keyend; p++, q++) { + U8 c = (U8)*p; if (UTF8_IS_INVARIANT(c)) { *q = (char) c; } @@ -3577,36 +3577,36 @@ Perl_refcounted_he_new_pvn(pTHX_ struct refcounted_he *parent, p++; *q = (char) EIGHT_BIT_UTF8_TO_NATIVE(c, *p); } - } - } - flags &= ~REFCOUNTED_HE_KEY_UTF8; - canonicalised_key: ; + } + } + flags &= ~REFCOUNTED_HE_KEY_UTF8; + canonicalised_key: ; } if (flags & REFCOUNTED_HE_KEY_UTF8) - hekflags |= HVhek_UTF8; + hekflags |= HVhek_UTF8; if (!hash) - PERL_HASH(hash, keypv, keylen); + PERL_HASH(hash, keypv, keylen); #ifdef USE_ITHREADS he = (struct refcounted_he*) - PerlMemShared_malloc(sizeof(struct refcounted_he) - 1 - + keylen - + key_offset); + PerlMemShared_malloc(sizeof(struct refcounted_he) - 1 + + keylen + + key_offset); #else he = (struct refcounted_he*) - PerlMemShared_malloc(sizeof(struct refcounted_he) - 1 - + key_offset); + PerlMemShared_malloc(sizeof(struct refcounted_he) - 1 + + key_offset); #endif he->refcounted_he_next = parent; if (is_pv) { - Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char); - he->refcounted_he_val.refcounted_he_u_len = value_len; + Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char); + he->refcounted_he_val.refcounted_he_u_len = value_len; } else if (value_type == HVrhek_IV) { - he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value); + he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value); } else if (value_type == HVrhek_UV) { - he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value); + he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value); } #ifdef USE_ITHREADS @@ -3634,7 +3634,7 @@ of a string/length pair. struct refcounted_he * Perl_refcounted_he_new_pv(pTHX_ struct refcounted_he *parent, - const char *key, U32 hash, SV *value, U32 flags) + const char *key, U32 hash, SV *value, U32 flags) { PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PV; return refcounted_he_new_pvn(parent, key, strlen(key), hash, value, flags); @@ -3651,19 +3651,19 @@ string/length pair. struct refcounted_he * Perl_refcounted_he_new_sv(pTHX_ struct refcounted_he *parent, - SV *key, U32 hash, SV *value, U32 flags) + SV *key, U32 hash, SV *value, U32 flags) { const char *keypv; STRLEN keylen; PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_SV; if (flags & REFCOUNTED_HE_KEY_UTF8) - Perl_croak(aTHX_ "panic: refcounted_he_new_sv bad flags %" UVxf, - (UV)flags); + Perl_croak(aTHX_ "panic: refcounted_he_new_sv bad flags %" UVxf, + (UV)flags); keypv = SvPV_const(key, keylen); if (SvUTF8(key)) - flags |= REFCOUNTED_HE_KEY_UTF8; + flags |= REFCOUNTED_HE_KEY_UTF8; if (!hash && SvIsCOW_shared_hash(key)) - hash = SvSHARED_HASH(key); + hash = SvSHARED_HASH(key); return refcounted_he_new_pvn(parent, keypv, keylen, hash, value, flags); } @@ -3681,28 +3681,26 @@ no action occurs in this case. void Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) { -#ifdef USE_ITHREADS -#endif PERL_UNUSED_CONTEXT; while (he) { - struct refcounted_he *copy; - U32 new_count; - - HINTS_REFCNT_LOCK; - new_count = --he->refcounted_he_refcnt; - HINTS_REFCNT_UNLOCK; - - if (new_count) { - return; - } + struct refcounted_he *copy; + U32 new_count; + + HINTS_REFCNT_LOCK; + new_count = --he->refcounted_he_refcnt; + HINTS_REFCNT_UNLOCK; + + if (new_count) { + return; + } #ifndef USE_ITHREADS - unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0); + unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0); #endif - copy = he; - he = he->refcounted_he_next; - PerlMemShared_free(copy); + copy = he; + he = he->refcounted_he_next; + PerlMemShared_free(copy); } } @@ -3719,13 +3717,11 @@ to this function: no action occurs and a null pointer is returned. struct refcounted_he * Perl_refcounted_he_inc(pTHX_ struct refcounted_he *he) { -#ifdef USE_ITHREADS -#endif PERL_UNUSED_CONTEXT; if (he) { - HINTS_REFCNT_LOCK; - he->refcounted_he_refcnt++; - HINTS_REFCNT_UNLOCK; + HINTS_REFCNT_LOCK; + he->refcounted_he_refcnt++; + HINTS_REFCNT_UNLOCK; } return he; } @@ -3756,29 +3752,29 @@ Perl_cop_fetch_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags) { PERL_UNUSED_CONTEXT; if (!chain) - return NULL; + return NULL; #ifdef USE_ITHREADS if (chain->refcounted_he_keylen != 1) - return NULL; + return NULL; if (*REF_HE_KEY(chain) != ':') - return NULL; + return NULL; #else if ((STRLEN)HEK_LEN(chain->refcounted_he_hek) != 1) - return NULL; + return NULL; if (*HEK_KEY(chain->refcounted_he_hek) != ':') - return NULL; + return NULL; #endif /* Stop anyone trying to really mess us up by adding their own value for ':' into %^H */ if ((chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV - && (chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV_UTF8) - return NULL; + && (chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV_UTF8) + return NULL; if (len) - *len = chain->refcounted_he_val.refcounted_he_u_len; + *len = chain->refcounted_he_val.refcounted_he_u_len; if (flags) { - *flags = ((chain->refcounted_he_data[0] & HVrhek_typemask) - == HVrhek_PV_UTF8) ? SVf_UTF8 : 0; + *flags = ((chain->refcounted_he_data[0] & HVrhek_typemask) + == HVrhek_PV_UTF8) ? SVf_UTF8 : 0; } return chain->refcounted_he_data + 1; } @@ -3795,19 +3791,19 @@ for a UTF-8 label. Any other flag is ignored. void Perl_cop_store_label(pTHX_ COP *const cop, const char *label, STRLEN len, - U32 flags) + U32 flags) { SV *labelsv; PERL_ARGS_ASSERT_COP_STORE_LABEL; if (flags & ~(SVf_UTF8)) - Perl_croak(aTHX_ "panic: cop_store_label illegal flag bits 0x%" UVxf, - (UV)flags); + Perl_croak(aTHX_ "panic: cop_store_label illegal flag bits 0x%" UVxf, + (UV)flags); labelsv = newSVpvn_flags(label, len, SVs_TEMP); if (flags & SVf_UTF8) - SvUTF8_on(labelsv); + SvUTF8_on(labelsv); cop->cop_hints_hash - = refcounted_he_new_pvs(cop->cop_hints_hash, ":", labelsv, 0); + = refcounted_he_new_pvs(cop->cop_hints_hash, ":", labelsv, 0); } /* @@ -3837,47 +3833,47 @@ Perl_hv_assert(pTHX_ HV *hv) (void)hv_iterinit(hv); while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) { - /* sanity check the values */ - if (HeVAL(entry) == &PL_sv_placeholder) - placeholders++; - else - real++; - /* sanity check the keys */ - if (HeSVKEY(entry)) { - NOOP; /* Don't know what to check on SV keys. */ - } else if (HeKUTF8(entry)) { - withflags++; - if (HeKWASUTF8(entry)) { - PerlIO_printf(Perl_debug_log, - "hash key has both WASUTF8 and UTF8: '%.*s'\n", - (int) HeKLEN(entry), HeKEY(entry)); - bad = 1; - } - } else if (HeKWASUTF8(entry)) - withflags++; + /* sanity check the values */ + if (HeVAL(entry) == &PL_sv_placeholder) + placeholders++; + else + real++; + /* sanity check the keys */ + if (HeSVKEY(entry)) { + NOOP; /* Don't know what to check on SV keys. */ + } else if (HeKUTF8(entry)) { + withflags++; + if (HeKWASUTF8(entry)) { + PerlIO_printf(Perl_debug_log, + "hash key has both WASUTF8 and UTF8: '%.*s'\n", + (int) HeKLEN(entry), HeKEY(entry)); + bad = 1; + } + } else if (HeKWASUTF8(entry)) + withflags++; } if (!SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) { - static const char bad_count[] = "Count %d %s(s), but hash reports %d\n"; - const int nhashkeys = HvUSEDKEYS(hv); - const int nhashplaceholders = HvPLACEHOLDERS_get(hv); - - if (nhashkeys != real) { - PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys ); - bad = 1; - } - if (nhashplaceholders != placeholders) { - PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders ); - bad = 1; - } + static const char bad_count[] = "Count %d %s(s), but hash reports %d\n"; + const int nhashkeys = HvUSEDKEYS(hv); + const int nhashplaceholders = HvPLACEHOLDERS_get(hv); + + if (nhashkeys != real) { + PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys ); + bad = 1; + } + if (nhashplaceholders != placeholders) { + PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders ); + bad = 1; + } } if (withflags && ! HvHASKFLAGS(hv)) { - PerlIO_printf(Perl_debug_log, - "Hash has HASKFLAGS off but I count %d key(s) with flags\n", - withflags); - bad = 1; + PerlIO_printf(Perl_debug_log, + "Hash has HASKFLAGS off but I count %d key(s) with flags\n", + withflags); + bad = 1; } if (bad) { - sv_dump(MUTABLE_SV(hv)); + sv_dump(MUTABLE_SV(hv)); } HvRITER_set(hv, riter); /* Restore hash iterator state */ HvEITER_set(hv, eiter); diff --git a/hv.h b/hv.h index 505c28e6f3af..6fbccdd39624 100644 --- a/hv.h +++ b/hv.h @@ -36,8 +36,8 @@ struct he { HE *hent_next; /* next entry in chain */ HEK *hent_hek; /* hash key */ union { - SV *hent_val; /* scalar value that was hashed */ - Size_t hent_refcount; /* references for this shared hash key */ + SV *hent_val; /* scalar value that was hashed */ + Size_t hent_refcount; /* references for this shared hash key */ } he_valu; }; @@ -304,16 +304,16 @@ See L. ) /* This macro may go away without notice. */ #define HvNAME_HEK(hv) \ - (SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name ? HvNAME_HEK_NN(hv) : NULL) + (SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name ? HvNAME_HEK_NN(hv) : NULL) #define HvNAME_get(hv) \ - ((SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name && HvNAME_HEK_NN(hv)) \ - ? HEK_KEY(HvNAME_HEK_NN(hv)) : NULL) + ((SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name && HvNAME_HEK_NN(hv)) \ + ? HEK_KEY(HvNAME_HEK_NN(hv)) : NULL) #define HvNAMELEN_get(hv) \ - ((SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name && HvNAME_HEK_NN(hv)) \ - ? HEK_LEN(HvNAME_HEK_NN(hv)) : 0) + ((SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name && HvNAME_HEK_NN(hv)) \ + ? HEK_LEN(HvNAME_HEK_NN(hv)) : 0) #define HvNAMEUTF8(hv) \ - ((SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name && HvNAME_HEK_NN(hv)) \ - ? HEK_UTF8(HvNAME_HEK_NN(hv)) : 0) + ((SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name && HvNAME_HEK_NN(hv)) \ + ? HEK_UTF8(HvNAME_HEK_NN(hv)) : 0) #define HvENAME_HEK_NN(hv) \ ( \ HvAUX(hv)->xhv_name_count > 0 ? HvAUX(hv)->xhv_name_u.xhvnameu_names[0] : \ @@ -322,16 +322,16 @@ See L. HvAUX(hv)->xhv_name_u.xhvnameu_name \ ) #define HvENAME_HEK(hv) \ - (SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name ? HvENAME_HEK_NN(hv) : NULL) + (SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name ? HvENAME_HEK_NN(hv) : NULL) #define HvENAME_get(hv) \ ((SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name && HvAUX(hv)->xhv_name_count != -1) \ - ? HEK_KEY(HvENAME_HEK_NN(hv)) : NULL) + ? HEK_KEY(HvENAME_HEK_NN(hv)) : NULL) #define HvENAMELEN_get(hv) \ ((SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name && HvAUX(hv)->xhv_name_count != -1) \ - ? HEK_LEN(HvENAME_HEK_NN(hv)) : 0) + ? HEK_LEN(HvENAME_HEK_NN(hv)) : 0) #define HvENAMEUTF8(hv) \ ((SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name && HvAUX(hv)->xhv_name_count != -1) \ - ? HEK_UTF8(HvENAME_HEK_NN(hv)) : 0) + ? HEK_UTF8(HvENAME_HEK_NN(hv)) : 0) /* the number of keys (including any placeholders) - NOT PART OF THE API */ #define XHvTOTALKEYS(xhv) ((xhv)->xhv_keys) @@ -383,24 +383,24 @@ See L. #define HeVAL(he) (he)->he_valu.hent_val #define HeHASH(he) HEK_HASH(HeKEY_hek(he)) #define HePV(he,lp) ((HeKLEN(he) == HEf_SVKEY) ? \ - SvPV(HeKEY_sv(he),lp) : \ - ((lp = HeKLEN(he)), HeKEY(he))) + SvPV(HeKEY_sv(he),lp) : \ + ((lp = HeKLEN(he)), HeKEY(he))) #define HeUTF8(he) ((HeKLEN(he) == HEf_SVKEY) ? \ - SvUTF8(HeKEY_sv(he)) : \ - (U32)HeKUTF8(he)) + SvUTF8(HeKEY_sv(he)) : \ + (U32)HeKUTF8(he)) #define HeSVKEY(he) ((HeKEY(he) && \ - HeKLEN(he) == HEf_SVKEY) ? \ - HeKEY_sv(he) : NULL) + HeKLEN(he) == HEf_SVKEY) ? \ + HeKEY_sv(he) : NULL) #define HeSVKEY_force(he) (HeKEY(he) ? \ - ((HeKLEN(he) == HEf_SVKEY) ? \ - HeKEY_sv(he) : \ - newSVpvn_flags(HeKEY(he), \ + ((HeKLEN(he) == HEf_SVKEY) ? \ + HeKEY_sv(he) : \ + newSVpvn_flags(HeKEY(he), \ HeKLEN(he), \ SVs_TEMP | \ ( HeKUTF8(he) ? SVf_UTF8 : 0 ))) : \ - &PL_sv_undef) + &PL_sv_undef) #define HeSVKEY_set(he,sv) ((HeKLEN(he) = HEf_SVKEY), (HeKEY_sv(he) = sv)) #ifndef PERL_CORE @@ -420,8 +420,8 @@ See L. #define HVhek_PLACEHOLD 0x200 /* Internal flag to create placeholder. * (may change, but Storable is a core module) */ #define HVhek_KEYCANONICAL 0x400 /* Internal flag - key is in canonical form. - If the string is UTF-8, it cannot be - converted to bytes. */ + If the string is UTF-8, it cannot be + converted to bytes. */ #define HVhek_MASK 0xFF #define HVhek_ENABLEHVKFLAGS (HVhek_MASK & ~(HVhek_UNSHARED)) @@ -442,9 +442,9 @@ See L. #else # define MALLOC_OVERHEAD 16 # define PERL_HV_ARRAY_ALLOC_BYTES(size) \ - (((size) < 64) \ - ? (size) * sizeof(HE*) \ - : (size) * sizeof(HE*) * 2 - MALLOC_OVERHEAD) + (((size) < 64) \ + ? (size) * sizeof(HE*) \ + : (size) * sizeof(HE*) * 2 - MALLOC_OVERHEAD) #endif /* Flags for hv_iternext_flags. */ @@ -459,33 +459,33 @@ See L. #define share_hek_hek(hek) \ (++(((struct shared_he *)(((char *)hek) \ - - STRUCT_OFFSET(struct shared_he, \ - shared_he_hek))) \ - ->shared_he_he.he_valu.hent_refcount), \ + - STRUCT_OFFSET(struct shared_he, \ + shared_he_hek))) \ + ->shared_he_he.he_valu.hent_refcount), \ hek) #define hv_store_ent(hv, keysv, val, hash) \ ((HE *) hv_common((hv), (keysv), NULL, 0, 0, HV_FETCH_ISSTORE, \ - (val), (hash))) + (val), (hash))) #define hv_exists_ent(hv, keysv, hash) \ cBOOL(hv_common((hv), (keysv), NULL, 0, 0, HV_FETCH_ISEXISTS, 0, (hash))) #define hv_fetch_ent(hv, keysv, lval, hash) \ ((HE *) hv_common((hv), (keysv), NULL, 0, 0, \ - ((lval) ? HV_FETCH_LVALUE : 0), NULL, (hash))) + ((lval) ? HV_FETCH_LVALUE : 0), NULL, (hash))) #define hv_delete_ent(hv, key, flags, hash) \ (MUTABLE_SV(hv_common((hv), (key), NULL, 0, 0, (flags) | HV_DELETE, \ - NULL, (hash)))) + NULL, (hash)))) #define hv_store_flags(hv, key, klen, val, hash, flags) \ ((SV**) hv_common((hv), NULL, (key), (klen), (flags), \ - (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), (val), \ - (hash))) + (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), (val), \ + (hash))) #define hv_store(hv, key, klen, val, hash) \ ((SV**) hv_common_key_len((hv), (key), (klen), \ - (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), \ - (val), (hash))) + (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), \ + (val), (hash))) @@ -494,12 +494,12 @@ See L. #define hv_fetch(hv, key, klen, lval) \ ((SV**) hv_common_key_len((hv), (key), (klen), (lval) \ - ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE) \ - : HV_FETCH_JUST_SV, NULL, 0)) + ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE) \ + : HV_FETCH_JUST_SV, NULL, 0)) #define hv_delete(hv, key, klen, flags) \ (MUTABLE_SV(hv_common_key_len((hv), (key), (klen), \ - (flags) | HV_DELETE, NULL, 0))) + (flags) | HV_DELETE, NULL, 0))) /* Provide 's' suffix subs for constant strings (and avoid needing to count * chars). See STR_WITH_LEN in handy.h - because these are macros we cant use @@ -522,17 +522,17 @@ See L. #ifdef PERL_CORE # define hv_storehek(hv, hek, val) \ hv_common((hv), NULL, HEK_KEY(hek), HEK_LEN(hek), HEK_UTF8(hek), \ - HV_FETCH_ISSTORE|HV_FETCH_JUST_SV, (val), HEK_HASH(hek)) + HV_FETCH_ISSTORE|HV_FETCH_JUST_SV, (val), HEK_HASH(hek)) # define hv_fetchhek(hv, hek, lval) \ ((SV **) \ hv_common((hv), NULL, HEK_KEY(hek), HEK_LEN(hek), HEK_UTF8(hek), \ - (lval) \ - ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE) \ - : HV_FETCH_JUST_SV, \ - NULL, HEK_HASH(hek))) + (lval) \ + ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE) \ + : HV_FETCH_JUST_SV, \ + NULL, HEK_HASH(hek))) # define hv_deletehek(hv, hek, flags) \ hv_common((hv), NULL, HEK_KEY(hek), HEK_LEN(hek), HEK_UTF8(hek), \ - (flags)|HV_DELETE, NULL, HEK_HASH(hek)) + (flags)|HV_DELETE, NULL, HEK_HASH(hek)) #endif /* This refcounted he structure is used for storing the hints used for lexical @@ -561,10 +561,10 @@ struct refcounted_he { HEK *refcounted_he_hek; /* hint key */ #endif union { - IV refcounted_he_u_iv; - UV refcounted_he_u_uv; - STRLEN refcounted_he_u_len; - void *refcounted_he_u_ptr; /* Might be useful in future */ + IV refcounted_he_u_iv; + UV refcounted_he_u_uv; + STRLEN refcounted_he_u_len; + void *refcounted_he_u_ptr; /* Might be useful in future */ } refcounted_he_val; U32 refcounted_he_refcnt; /* reference count */ /* First byte is flags. Then NUL-terminated value. Then for ithreads, @@ -610,9 +610,9 @@ instead of a string/length pair, and no precomputed hash. #ifdef USE_ITHREADS /* A big expression to find the key offset */ #define REF_HE_KEY(chain) \ - ((((chain->refcounted_he_data[0] & 0x60) == 0x40) \ - ? chain->refcounted_he_val.refcounted_he_u_len + 1 : 0) \ - + 1 + chain->refcounted_he_data) + ((((chain->refcounted_he_data[0] & 0x60) == 0x40) \ + ? chain->refcounted_he_val.refcounted_he_u_len + 1 : 0) \ + + 1 + chain->refcounted_he_data) #endif # ifdef USE_ITHREADS diff --git a/inline.h b/inline.h index 96f706ed8b67..777f9f6743af 100644 --- a/inline.h +++ b/inline.h @@ -72,8 +72,8 @@ Perl_CvGV(pTHX_ CV *sv) PERL_ARGS_ASSERT_CVGV; return CvNAMED(sv) - ? Perl_cvgv_from_hek(aTHX_ sv) - : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv; + ? Perl_cvgv_from_hek(aTHX_ sv) + : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv; } PERL_STATIC_INLINE I32 * @@ -105,13 +105,13 @@ S_strip_spaces(pTHX_ const char * orig, STRLEN * const len) tmpsv = newSVpvn_flags(orig, *len, SVs_TEMP); tmps = SvPVX(tmpsv); while ((*len)--) { - if (!isSPACE(*orig)) - *tmps++ = *orig; - orig++; + if (!isSPACE(*orig)) + *tmps++ = *orig; + orig++; } *tmps = '\0'; *len = tmps - SvPVX(tmpsv); - return SvPVX(tmpsv); + return SvPVX(tmpsv); } #endif @@ -125,12 +125,12 @@ S_MgBYTEPOS(pTHX_ MAGIC *mg, SV *sv, const char *s, STRLEN len) assert(mg->mg_type == PERL_MAGIC_regex_global); assert(mg->mg_len != -1); if (mg->mg_flags & MGf_BYTES || !DO_UTF8(sv)) - return (STRLEN)mg->mg_len; + return (STRLEN)mg->mg_len; else { - const STRLEN pos = (STRLEN)mg->mg_len; - /* Without this check, we may read past the end of the buffer: */ - if (pos > sv_or_pv_len_utf8(sv, s, len)) return len+1; - return sv_or_pv_pos_u2b(sv, s, pos, NULL); + const STRLEN pos = (STRLEN)mg->mg_len; + /* Without this check, we may read past the end of the buffer: */ + if (pos > sv_or_pv_len_utf8(sv, s, len)) return len+1; + return sv_or_pv_pos_u2b(sv, s, pos, NULL); } } #endif @@ -147,27 +147,27 @@ S_PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq) * This is complicated by the fact that PL_cop_seqmax * may have wrapped around at some point */ if (COP_SEQ_RANGE_LOW(pn) == PERL_PADSEQ_INTRO) - return FALSE; /* not yet introduced */ + return FALSE; /* not yet introduced */ if (COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO) { /* in compiling scope */ - if ( - (seq > COP_SEQ_RANGE_LOW(pn)) - ? (seq - COP_SEQ_RANGE_LOW(pn) < (U32_MAX >> 1)) - : (COP_SEQ_RANGE_LOW(pn) - seq > (U32_MAX >> 1)) - ) - return TRUE; + if ( + (seq > COP_SEQ_RANGE_LOW(pn)) + ? (seq - COP_SEQ_RANGE_LOW(pn) < (U32_MAX >> 1)) + : (COP_SEQ_RANGE_LOW(pn) - seq > (U32_MAX >> 1)) + ) + return TRUE; } else if ( - (COP_SEQ_RANGE_LOW(pn) > COP_SEQ_RANGE_HIGH(pn)) - ? - ( seq > COP_SEQ_RANGE_LOW(pn) - || seq <= COP_SEQ_RANGE_HIGH(pn)) + (COP_SEQ_RANGE_LOW(pn) > COP_SEQ_RANGE_HIGH(pn)) + ? + ( seq > COP_SEQ_RANGE_LOW(pn) + || seq <= COP_SEQ_RANGE_HIGH(pn)) - : ( seq > COP_SEQ_RANGE_LOW(pn) - && seq <= COP_SEQ_RANGE_HIGH(pn)) + : ( seq > COP_SEQ_RANGE_LOW(pn) + && seq <= COP_SEQ_RANGE_HIGH(pn)) ) - return TRUE; + return TRUE; return FALSE; } #endif @@ -178,9 +178,9 @@ PERL_STATIC_INLINE I32 Perl_TOPMARK(pTHX) { DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log, - "MARK top %p %" IVdf "\n", - PL_markstack_ptr, - (IV)*PL_markstack_ptr))); + "MARK top %p %" IVdf "\n", + PL_markstack_ptr, + (IV)*PL_markstack_ptr))); return *PL_markstack_ptr; } @@ -188,9 +188,9 @@ PERL_STATIC_INLINE I32 Perl_POPMARK(pTHX) { DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log, - "MARK pop %p %" IVdf "\n", - (PL_markstack_ptr-1), - (IV)*(PL_markstack_ptr-1)))); + "MARK pop %p %" IVdf "\n", + (PL_markstack_ptr-1), + (IV)*(PL_markstack_ptr-1)))); assert((PL_markstack_ptr > PL_markstack) || !"MARK underflow"); return *PL_markstack_ptr--; } @@ -212,18 +212,67 @@ Perl_ReANY(const REGEXP * const re) /* ------------------------------- sv.h ------------------------------- */ PERL_STATIC_INLINE bool -Perl_SvTRUE(pTHX_ SV *sv) { +Perl_SvTRUE(pTHX_ SV *sv) +{ + PERL_ARGS_ASSERT_SVTRUE; + + if (UNLIKELY(sv == NULL)) + return FALSE; + SvGETMAGIC(sv); + return SvTRUE_nomg_NN(sv); +} + +PERL_STATIC_INLINE bool +Perl_SvTRUE_nomg(pTHX_ SV *sv) +{ + PERL_ARGS_ASSERT_SVTRUE_NOMG; + if (UNLIKELY(sv == NULL)) return FALSE; + return SvTRUE_nomg_NN(sv); +} + +PERL_STATIC_INLINE bool +Perl_SvTRUE_NN(pTHX_ SV *sv) +{ + PERL_ARGS_ASSERT_SVTRUE_NN; + SvGETMAGIC(sv); return SvTRUE_nomg_NN(sv); } +PERL_STATIC_INLINE bool +Perl_SvTRUE_common(pTHX_ SV * sv, const bool sv_2bool_is_fallback) +{ + PERL_ARGS_ASSERT_SVTRUE_COMMON; + + if (UNLIKELY(SvIMMORTAL_INTERP(sv))) + return SvIMMORTAL_TRUE(sv); + + if (! SvOK(sv)) + return FALSE; + + if (SvPOK(sv)) + return SvPVXtrue(sv); + + if (SvIOK(sv)) + return SvIVX(sv) != 0; /* casts to bool */ + + if (SvROK(sv) && !(SvOBJECT(SvRV(sv)) && HvAMAGIC(SvSTASH(SvRV(sv))))) + return TRUE; + + if (sv_2bool_is_fallback) + return sv_2bool_nomg(sv); + + return isGV_with_GP(sv); +} + + PERL_STATIC_INLINE SV * Perl_SvREFCNT_inc(SV *sv) { if (LIKELY(sv != NULL)) - SvREFCNT(sv)++; + SvREFCNT(sv)++; return sv; } PERL_STATIC_INLINE SV * @@ -238,17 +287,17 @@ PERL_STATIC_INLINE void Perl_SvREFCNT_inc_void(SV *sv) { if (LIKELY(sv != NULL)) - SvREFCNT(sv)++; + SvREFCNT(sv)++; } PERL_STATIC_INLINE void Perl_SvREFCNT_dec(pTHX_ SV *sv) { if (LIKELY(sv != NULL)) { - U32 rc = SvREFCNT(sv); - if (LIKELY(rc > 1)) - SvREFCNT(sv) = rc - 1; - else - Perl_sv_free2(aTHX_ sv, rc); + U32 rc = SvREFCNT(sv); + if (LIKELY(rc > 1)) + SvREFCNT(sv) = rc - 1; + else + Perl_sv_free2(aTHX_ sv, rc); } } @@ -260,9 +309,9 @@ Perl_SvREFCNT_dec_NN(pTHX_ SV *sv) PERL_ARGS_ASSERT_SVREFCNT_DEC_NN; if (LIKELY(rc > 1)) - SvREFCNT(sv) = rc - 1; + SvREFCNT(sv) = rc - 1; else - Perl_sv_free2(aTHX_ sv, rc); + Perl_sv_free2(aTHX_ sv, rc); } PERL_STATIC_INLINE void @@ -279,7 +328,7 @@ Perl_SvAMAGIC_off(SV *sv) PERL_ARGS_ASSERT_SVAMAGIC_OFF; if (SvROK(sv) && SvOBJECT(SvRV(sv))) - HvAMAGIC_off(SvSTASH(SvRV(sv))); + HvAMAGIC_off(SvSTASH(SvRV(sv))); } PERL_STATIC_INLINE U32 @@ -300,9 +349,9 @@ S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp) { PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B; if (SvGAMAGIC(sv)) { - U8 *hopped = utf8_hop((U8 *)pv, pos); - if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped); - return (STRLEN)(hopped - (U8 *)pv); + U8 *hopped = utf8_hop((U8 *)pv, pos); + if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped); + return (STRLEN)(hopped - (U8 *)pv); } return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN); } @@ -356,7 +405,7 @@ Perl_valid_utf8_to_uvchr(const U8 *s, STRLEN *retlen) /* An invariant is trivially returned */ if (expectlen == 1) { - return uv; + return uv; } /* Remove the leading bits that indicate the number of bytes, leaving just @@ -518,7 +567,7 @@ Perl_is_utf8_invariant_string_loc(const U8* const s, STRLEN len, const U8 ** ep) /* Process per-byte */ while (x < send) { - if (! UTF8_IS_INVARIANT(*x)) { + if (! UTF8_IS_INVARIANT(*x)) { if (ep) { *ep = x; } @@ -693,7 +742,7 @@ S_variant_under_utf8_count(const U8* const s, const U8* const e) /* Process per-byte */ while (x < e) { - if (! UTF8_IS_INVARIANT(*x)) { + if (! UTF8_IS_INVARIANT(*x)) { count++; } @@ -1522,15 +1571,15 @@ Perl_utf8_hop(const U8 *s, SSize_t off) * In other words: in Perl UTF-8 is not just for Unicode. */ if (off >= 0) { - while (off--) - s += UTF8SKIP(s); + while (off--) + s += UTF8SKIP(s); } else { - while (off++) { - s--; - while (UTF8_IS_CONTINUATION(*s)) - s--; - } + while (off++) { + s--; + while (UTF8_IS_CONTINUATION(*s)) + s--; + } } GCC_DIAG_IGNORE(-Wcast-qual) return (U8 *)s; @@ -1980,7 +2029,7 @@ S_lossless_NV_to_IV(const NV nv, IV *ivp) /* Written this way so that with an always-false NaN comparison we * return false */ - if (!(LIKELY(nv >= IV_MIN) && LIKELY(nv <= IV_MAX))) { + if (!(LIKELY(nv >= (NV) IV_MIN) && LIKELY(nv < IV_MAX_P1))) { return FALSE; } @@ -1994,36 +2043,6 @@ S_lossless_NV_to_IV(const NV nv, IV *ivp) #endif -/* ------------------ regcomp.c, toke.c ------------ */ - -#if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C) - -/* - - regcurly - a little FSA that accepts {\d+,?\d*} - Pulled from reg.c. - */ -PERL_STATIC_INLINE bool -S_regcurly(const char *s) -{ - PERL_ARGS_ASSERT_REGCURLY; - - if (*s++ != '{') - return FALSE; - if (!isDIGIT(*s)) - return FALSE; - while (isDIGIT(*s)) - s++; - if (*s == ',') { - s++; - while (isDIGIT(*s)) - s++; - } - - return *s == '}'; -} - -#endif - /* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */ #if defined(PERL_IN_PP_C) || defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C) || defined(PERL_IN_UNIVERSAL_C) @@ -2044,10 +2063,10 @@ S_get_regex_charset_name(const U32 flags, STRLEN* const lenp) case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS; case REGEX_LOCALE_CHARSET: return LOCALE_PAT_MODS; case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS; - case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS; - case REGEX_ASCII_MORE_RESTRICTED_CHARSET: - *lenp = 2; - return ASCII_MORE_RESTRICT_PAT_MODS; + case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS; + case REGEX_ASCII_MORE_RESTRICTED_CHARSET: + *lenp = 2; + return ASCII_MORE_RESTRICT_PAT_MODS; } /* The NOT_REACHED; hides an assert() which has a rather complex * definition in perl.h. */ @@ -2481,9 +2500,9 @@ Perl_foldEQ(const char *s1, const char *s2, I32 len) assert(len >= 0); while (len--) { - if (*a != *b && *a != PL_fold[*b]) - return 0; - a++,b++; + if (*a != *b && *a != PL_fold[*b]) + return 0; + a++,b++; } return 1; } @@ -2504,10 +2523,10 @@ Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len) assert(len >= 0); while (len--) { - if (*a != *b && *a != PL_fold_latin1[*b]) { - return 0; - } - a++, b++; + if (*a != *b && *a != PL_fold_latin1[*b]) { + return 0; + } + a++, b++; } return 1; } @@ -2533,9 +2552,9 @@ Perl_foldEQ_locale(const char *s1, const char *s2, I32 len) assert(len >= 0); while (len--) { - if (*a != *b && *a != PL_fold_locale[*b]) - return 0; - a++,b++; + if (*a != *b && *a != PL_fold_locale[*b]) + return 0; + a++,b++; } return 1; } @@ -2599,23 +2618,31 @@ Perl_mortal_getenv(const char * str) { /* This implements a (mostly) thread-safe, sequential-call-safe getenv(). * - * It's (mostly) thread-safe because it uses a mutex to prevent - * simultaneous access from other threads that use the same mutex, and - * makes a copy of the result before releasing that mutex. All of the Perl - * core uses that mutex, but, like all mutexes, everything has to cooperate - * for it to completely work. It is possible for code from, say XS, to not - * use this mutex, defeating the safety. + * It's (mostly) thread-safe because it uses a mutex to prevent other + * threads (that look at this mutex) from destroying the result before this + * routine has a chance to copy the result to a place that won't be + * destroyed before the caller gets a chance to handle it. That place is a + * mortal SV. khw chose this over SAVEFREEPV because he is under the + * impression that the SV will hang around longer under more circumstances + * + * The reason it isn't completely thread-safe is that other code could + * simply not pay attention to the mutex. All of the Perl core uses the + * mutex, but it is possible for code from, say XS, to not use this mutex, + * defeating the safety. * - * On some platforms, getenv() is not sequential-call-safe, because - * subsequent calls destroy the static storage inside the C library - * returned by an earlier call. The result must be copied or completely - * acted upon before a subsequent getenv call. Those calls could come from - * another thread. Again, making a copy while controlling the mutex - * prevents these problems.. + * getenv() returns, in some implementations, a pointer to a spot in the + * **environ array, which could be invalidated at any time by this or + * another thread changing the environment. Other implementations copy the + * **environ value to a static buffer, returning a pointer to that. That + * buffer might or might not be invalidated by a getenv() call in another + * thread. If it does get zapped, we need an exclusive lock. Otherwise, + * many getenv() calls can safely be running simultaneously, so a + * many-reader (but no simultaneous writers) lock is ok. There is a + * Configure probe to see if another thread destroys the buffer, and the + * mutex is defined accordingly. * - * To prevent leaks, the copy is made by creating a new SV containing it, - * mortalizing the SV, and returning the SV's string (the copy). Thus this - * is a drop-in replacement for getenv(). + * But in all cases, using the mutex prevents these problems, as long as + * all code uses the same mutex.. * * A complication is that this can be called during phases where the * mortalization process isn't available. These are in interpreter @@ -2635,15 +2662,152 @@ Perl_mortal_getenv(const char * str) return getenv(str); } - ENV_LOCK; +#ifdef PERL_MEM_LOG + + /* A major complication arises under PERL_MEM_LOG. When that is active, + * every memory allocation may result in logging, depending on the value of + * ENV{PERL_MEM_LOG} at the moment. That means, as we create the SV for + * saving ENV{foo}'s value (but before saving it), the logging code will + * call us recursively to find out what ENV{PERL_MEM_LOG} is. Without some + * care that could lead to: 1) infinite recursion; or 2) deadlock (trying to + * lock a boolean mutex recursively); 3) destroying the getenv() static + * buffer; or 4) destroying the temporary created by this for the copy + * causes a log entry to be made which could cause a new temporary to be + * created, which will need to be destroyed at some point, leading to an + * infinite loop. + * + * The solution adopted here (after some gnashing of teeth) is to detect + * the recursive calls and calls from the logger, and treat them specially. + * Let's say we want to do getenv("foo"). We first find + * getenv(PERL_MEM_LOG) and save it to a fixed-length per-interpreter + * variable, so no temporary is required. Then we do getenv(foo}, and in + * the process of creating a temporary to save it, this function will be + * called recursively to do a getenv(PERL_MEM_LOG). On the recursed call, + * we detect that it is such a call and return our saved value instead of + * locking and doing a new getenv(). This solves all of problems 1), 2), + * and 3). Because all the getenv()s are done while the mutex is locked, + * the state cannot have changed. To solve 4), we don't create a temporary + * when this is called from the logging code. That code disposes of the + * return value while the mutex is still locked. + * + * The value of getenv(PERL_MEM_LOG) can be anything, but only initial + * digits and 3 particular letters are significant; the rest are ignored by + * the memory logging code. Thus the per-interpreter variable only needs + * to be large enough to save the significant information, the size of + * which is known at compile time. The first byte is extra, reserved for + * flags for our use. To protect against overflowing, only the reserved + * byte, as many digits as don't overflow, and the three letters are + * stored. + * + * The reserved byte has two bits: + * 0x1 if set indicates that if we get here, it is a recursive call of + * getenv() + * 0x2 if set indicates that the call is from the logging code. + * + * If the flag indicates this is a recursive call, just return the stored + * value of PL_mem_log; An empty value gets turned into NULL. */ + if (strEQ(str, "PERL_MEM_LOG") && PL_mem_log[0] & 0x1) { + if (PL_mem_log[1] == '\0') { + return NULL; + } else { + return PL_mem_log + 1; + } + } + +#endif + + GETENV_LOCK; + +#ifdef PERL_MEM_LOG + + /* Here we are in a critical section. As explained above, we do our own + * getenv(PERL_MEM_LOG), saving the result safely. */ + ret = getenv("PERL_MEM_LOG"); + if (ret == NULL) { /* No logging active */ + /* Return that immediately if called from the logging code */ + if (PL_mem_log[0] & 0x2) { + GETENV_UNLOCK; + return NULL; + } + + PL_mem_log[1] = '\0'; + } + else { + char *mem_log_meat = PL_mem_log + 1; /* first byte reserved */ + + /* There is nothing to prevent the value of PERL_MEM_LOG from being an + * extremely long string. But we want only a few characters from it. + * PL_mem_log has been made large enough to hold just the ones we need. + * First the file descriptor. */ + if (isDIGIT(*ret)) { + const char * s = ret; + if (UNLIKELY(*s == '0')) { + + /* Reduce multiple leading zeros to a single one. This is to + * allow the caller to change what to do with leading zeros. */ + *mem_log_meat++ = '0'; + s++; + while (*s == '0') { + s++; + } + } + + /* If the input overflows, copy just enough for the result to also + * overflow, plus 1 to make sure */ + while (isDIGIT(*s) && s < ret + TYPE_DIGITS(UV) + 1) { + *mem_log_meat++ = *s++; + } + } + + /* Then each of the three significant characters */ + if (strchr(ret, 'm')) { + *mem_log_meat++ = 'm'; + } + if (strchr(ret, 's')) { + *mem_log_meat++ = 's'; + } + if (strchr(ret, 't')) { + *mem_log_meat++ = 't'; + } + *mem_log_meat = '\0'; + + assert(mem_log_meat < PL_mem_log + sizeof(PL_mem_log)); + } + + /* If we are being called from the logger, it only needs the significant + * portion of PERL_MEM_LOG, and doesn't need a safe copy */ + if (PL_mem_log[0] & 0x2) { + assert(strEQ(str, "PERL_MEM_LOG")); + GETENV_UNLOCK; + return PL_mem_log + 1; + } + + /* Here is a generic getenv(). This could be a getenv("PERL_MEM_LOG") that + * is coming from other than the logging code, so it should be treated the + * same as any other getenv(), returning the full value, not just the + * significant part, and having its value saved. Set the flag that + * indicates any call to this routine will be a recursion from here */ + PL_mem_log[0] = 0x1; + +#endif + + /* Now get the value of the real desired variable, and save a copy */ ret = getenv(str); if (ret != NULL) { ret = SvPVX(sv_2mortal(newSVpv(ret, 0))); } - ENV_UNLOCK; + GETENV_UNLOCK; + +#ifdef PERL_MEM_LOG + + /* Clear the buffer */ + Zero(PL_mem_log, sizeof(PL_mem_log), char); + +#endif + return ret; } diff --git a/intrpvar.h b/intrpvar.h index 1ea21ca47155..a9e13d718793 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -10,10 +10,6 @@ #include "handy.h" -/* -=for apidoc_section Per-Interpreter Variables -*/ - /* These variables are per-interpreter in threaded/multiplicity builds, * global otherwise. @@ -40,7 +36,7 @@ PERLVAR(I, stack_base, SV **) PERLVAR(I, stack_max, SV **) PERLVAR(I, savestack, ANY *) /* items that need to be restored when - LEAVEing scopes we've ENTERed */ + LEAVEing scopes we've ENTERed */ PERLVAR(I, savestack_ix, I32) PERLVAR(I, savestack_max, I32) @@ -54,7 +50,7 @@ PERLVARI(I, tmps_floor, SSize_t, -1) PERLVAR(I, tmps_max, SSize_t) /* first unalloced slot in tmps stack */ PERLVAR(I, markstack, I32 *) /* stack_sp locations we're - remembering */ + remembering */ PERLVAR(I, markstack_ptr, I32 *) PERLVAR(I, markstack_max, I32 *) @@ -94,12 +90,17 @@ PERLVARI(I, tainted, bool, FALSE) /* using variables controlled by $< */ PERLVAR(I, delaymagic, U16) /* ($<,$>) = ... */ /* +=for apidoc_section $warning =for apidoc mn|U8|PL_dowarn The C variable that roughly corresponds to Perl's C<$^W> warning variable. However, C<$^W> is treated as a boolean, whereas C is a collection of flag bits. +On threaded perls, each thread has an independent copy of this variable; +each initialized at creation time with the current value of the creating +thread's copy. + =cut */ @@ -118,6 +119,10 @@ PERLVARI(I, utf8cache, I8, PERL___I) /* Is the utf8 caching code enabled? */ The GV representing C<*_>. Useful for access to C<$_>. +On threaded perls, each thread has an independent copy of this variable; +each initialized at creation time with the current value of the creating +thread's copy. + =cut */ @@ -130,6 +135,10 @@ PERLVAR(I, defgv, GV *) /* the *_ glob */ The stash for the package code will be compiled into. +On threaded perls, each thread has an independent copy of this variable; +each initialized at creation time with the current value of the creating +thread's copy. + =cut */ @@ -143,6 +152,10 @@ PERLVAR(I, curstash, HV *) /* symbol table for current package */ The currently active COP (control op) roughly representing the current statement in the source. +On threaded perls, each thread has an independent copy of this variable; +each initialized at creation time with the current value of the creating +thread's copy. + =cut */ @@ -150,7 +163,7 @@ PERLVAR(I, curcop, COP *) PERLVAR(I, curstack, AV *) /* THE STACK */ PERLVAR(I, curstackinfo, PERL_SI *) /* current stack + context */ PERLVAR(I, mainstack, AV *) /* the stack when nothing funny is - happening */ + happening */ /* memory management */ PERLVAR(I, sv_count, IV) /* how many SV* are currently allocated */ @@ -171,16 +184,18 @@ PERLVAR(I, regmatch_state, regmatch_state *) PERLVAR(I, comppad, PAD *) /* storage for lexically scoped temporaries */ /* +=for apidoc_section $SV =for apidoc Amn|SV|PL_sv_undef -This is the C SV. Always refer to this as C<&PL_sv_undef>. +This is the C SV. It is readonly. Always refer to this as +C<&PL_sv_undef>. =for apidoc Amn|SV|PL_sv_no -This is the C SV. See C>. Always refer to this as -C<&PL_sv_no>. +This is the C SV. It is readonly. See C>. Always refer +to this as C<&PL_sv_no>. =for apidoc Amn|SV|PL_sv_yes -This is the C SV. See C>. Always refer to this as -C<&PL_sv_yes>. +This is the C SV. It is readonly. See C>. Always refer to +this as C<&PL_sv_yes>. =for apidoc Amn|SV|PL_sv_zero This readonly SV has a zero numeric value and a C<"0"> string value. It's @@ -234,7 +249,7 @@ C macro. */ PERLVAR(I, na, STRLEN) /* for use in SvPV when length is - Not Applicable */ + Not Applicable */ /* stat stuff */ PERLVAR(I, statcache, Stat_t) /* _ */ @@ -242,18 +257,31 @@ PERLVAR(I, statgv, GV *) PERLVARI(I, statname, SV *, NULL) /* +=for apidoc_section $io =for apidoc mn|SV*|PL_rs The input record separator - C<$/> in Perl space. +On threaded perls, each thread has an independent copy of this variable; +each initialized at creation time with the current value of the creating +thread's copy. + =for apidoc mn|GV*|PL_last_in_gv The GV which was last used for a filehandle input operation. (C<< >>) +On threaded perls, each thread has an independent copy of this variable; +each initialized at creation time with the current value of the creating +thread's copy. + =for apidoc mn|GV*|PL_ofsgv The glob containing the output field separator - C<*,> in Perl space. +On threaded perls, each thread has an independent copy of this variable; +each initialized at creation time with the current value of the creating +thread's copy. + =cut */ @@ -290,9 +318,10 @@ PERLVAR(I, efloatbuf, char *) PERLVAR(I, efloatsize, STRLEN) PERLVARI(I, dumpindent, U16, 4) /* number of blanks per dump - indentation level */ + indentation level */ /* +=for apidoc_section $embedding =for apidoc Amn|U8|PL_exit_flags Contains flags controlling perl's behaviour on exit(): @@ -325,6 +354,10 @@ Set by the L operator. =for apidoc Amnh||PERL_EXIT_DESTRUCT_END =for apidoc Amnh||PERL_EXIT_WARN +On threaded perls, each thread has an independent copy of this variable; +each initialized at creation time with the current value of the creating +thread's copy. + =cut */ @@ -346,6 +379,7 @@ PERLVARA(I, locale_utf8ness, 256, char) PERLVARA(I, colors,6, char *) /* values from PERL_RE_COLORS env var */ /* +=for apidoc_section $optree_construction =for apidoc Amn|peep_t|PL_peepp Pointer to the per-subroutine peephole optimiser. This is a function @@ -363,6 +397,10 @@ If the new code wishes to operate on ops throughout the subroutine's structure, rather than just at the top level, it is likely to be more convenient to wrap the L hook. +On threaded perls, each thread has an independent copy of this variable; +each initialized at creation time with the current value of the creating +thread's copy. + =cut */ @@ -387,6 +425,10 @@ If the new code wishes to operate only on ops at a subroutine's top level, rather than throughout the structure, it is likely to be more convenient to wrap the L hook. +On threaded perls, each thread has an independent copy of this variable; +each initialized at creation time with the current value of the creating +thread's copy. + =cut */ @@ -401,6 +443,10 @@ It is also assured to first fire for the parent OP and then for its kids. When you replace this variable, it is considered a good practice to store the possibly previously installed hook and that you recall it inside your own. +On threaded perls, each thread has an independent copy of this variable; +each initialized at creation time with the current value of the creating +thread's copy. + =cut */ @@ -446,7 +492,7 @@ PERLVAR(I, e_script, SV *) PERLVAR(I, basetime, Time_t) /* $^T */ PERLVARI(I, maxsysfd, I32, MAXSYSFD) - /* top fd to pass to subprocesses */ + /* top fd to pass to subprocesses */ PERLVAR(I, statusvalue, I32) /* $? */ #ifdef VMS PERLVAR(I, statusvalue_vms, U32) @@ -475,12 +521,17 @@ PERLVAR(I, DBgv, GV *) /* *DB::DB */ PERLVAR(I, DBline, GV *) /* *DB::line */ /* +=for apidoc_section $debugging =for apidoc mn|GV *|PL_DBsub When Perl is run in debugging mode, with the B<-d> switch, this GV contains the SV which holds the name of the sub being debugged. This is the C variable which corresponds to Perl's $DB::sub variable. See C>. +On threaded perls, each thread has an independent copy of this variable; +each initialized at creation time with the current value of the creating +thread's copy. + =for apidoc mn|SV *|PL_DBsingle When Perl is run in debugging mode, with the B<-d> switch, this SV is a boolean which indicates whether subs are being single-stepped. @@ -488,11 +539,19 @@ Single-stepping is automatically turned on after every step. This is the C variable which corresponds to Perl's $DB::single variable. See C>. +On threaded perls, each thread has an independent copy of this variable; +each initialized at creation time with the current value of the creating +thread's copy. + =for apidoc mn|SV *|PL_DBtrace Trace variable used when Perl is run in debugging mode, with the B<-d> switch. This is the C variable which corresponds to Perl's $DB::trace variable. See C>. +On threaded perls, each thread has an independent copy of this variable; +each initialized at creation time with the current value of the creating +thread's copy. + =cut */ @@ -553,14 +612,15 @@ PERLVARI(I, laststype, U16, OP_STAT) PERLVARI(I, laststatval, int, -1) PERLVAR(I, modcount, I32) /* how much op_lvalue()ification in - assignment? */ + assignment? */ /* interpreter atexit processing */ PERLVARI(I, exitlistlen, I32, 0) /* length of same */ PERLVARI(I, exitlist, PerlExitListEntry *, NULL) - /* list of exit functions */ + /* list of exit functions */ /* +=for apidoc_section $HV =for apidoc Amn|HV*|PL_modglobal C is a general purpose, interpreter global HV for use by @@ -569,6 +629,10 @@ In a pinch, it can also be used as a symbol table for extensions to share data among each other. It is a good idea to use keys prefixed by the package name of the extension that owns the data. +On threaded perls, each thread has an independent copy of this variable; +each initialized at creation time with the current value of the creating +thread's copy. + =cut */ @@ -586,7 +650,7 @@ PERLVAR(I, comppad_name_floor, PADOFFSET)/* start of vars in innermost block */ #ifdef HAVE_INTERP_INTERN PERLVAR(I, sys_intern, struct interp_intern) - /* platform internals */ + /* platform internals */ #endif /* more statics moved here */ @@ -649,7 +713,7 @@ PERLVAR(I, min_intro_pending, PADOFFSET)/* start of vars to introduce */ PERLVAR(I, max_intro_pending, PADOFFSET)/* end of vars to introduce */ PERLVAR(I, padix, PADOFFSET) /* lowest unused index - 1 - in current "register" pad */ + in current "register" pad */ PERLVAR(I, constpadix, PADOFFSET) /* lowest unused for constants */ PERLVAR(I, padix_floor, PADOFFSET) /* how low may inner block reset padix */ @@ -672,7 +736,7 @@ PERLVARI(I, strxfrm_is_behaved, bool, TRUE) /* Assume until proven otherwise that it works */ PERLVARI(I, strxfrm_max_cp, U8, 0) /* Highest collating cp in locale */ PERLVARI(I, collation_standard, bool, TRUE) - /* Assume simple collation */ + /* Assume simple collation */ #endif /* USE_LOCALE_COLLATE */ PERLVARI(I, langinfo_buf, char *, NULL) @@ -695,6 +759,7 @@ PERLVAR(I, unsafe, bool) PERLVAR(I, colorset, bool) /* PERL_RE_COLORS env var is in use */ /* +=for apidoc_section $embedding =for apidoc Amn|signed char|PL_perl_destruct_level This value may be set when embedding for full cleanup. @@ -714,6 +779,10 @@ Possible values: If C<$ENV{PERL_DESTRUCT_LEVEL}> is set to an integer greater than the value of C its value is used instead. +On threaded perls, each thread has an independent copy of this variable; +each initialized at creation time with the current value of the creating +thread's copy. + =cut */ /* mod_perl is special, and also assigns a meaning -1 */ @@ -726,11 +795,11 @@ PERLVAR(I, srand_called, bool) #ifdef USE_LOCALE_NUMERIC PERLVARI(I, numeric_underlying, bool, TRUE) - /* Assume underlying locale numerics */ + /* Assume underlying locale numerics */ PERLVARI(I, numeric_underlying_is_standard, bool, TRUE) PERLVARI(I, numeric_standard, int, TRUE) - /* Assume C locale numerics */ + /* Assume C locale numerics */ PERLVAR(I, numeric_name, char *) /* Name of current numeric locale */ PERLVAR(I, numeric_radix_sv, SV *) /* The radix separator if not '.' */ @@ -769,12 +838,12 @@ PERLVAR(I, body_arenas, void *) /* pointer to list of body-arenas */ #if defined(USE_ITHREADS) PERLVAR(I, regex_pad, SV **) /* Shortcut into the array of - regex_padav */ + regex_padav */ PERLVAR(I, regex_padav, AV *) /* All regex objects, indexed via the - values in op_pmoffset of pmop. - Entry 0 is an SV whose PV is a - "packed" list of IVs listing - the now-free slots in the array */ + values in op_pmoffset of pmop. + Entry 0 is an SV whose PV is a + "packed" list of IVs listing + the now-free slots in the array */ PERLVAR(I, stashpad, HV **) /* for CopSTASH */ PERLVARI(I, stashpadmax, PADOFFSET, 64) PERLVARI(I, stashpadix, PADOFFSET, 0) @@ -795,7 +864,7 @@ PERLVARI(I, def_layerlist, PerlIO_list_t *, NULL) PERLVARI(I, checkav_save, AV *, NULL) /* save CHECK{}s when compiling */ PERLVARI(I, unitcheckav_save, AV *, NULL) - /* save UNITCHECK{}s when compiling */ + /* save UNITCHECK{}s when compiling */ PERLVARI(I, clocktick, long, 0) /* this many times() ticks in a second */ @@ -951,6 +1020,12 @@ PERLVAR(I, mbrtowc_ps, mbstate_t) #ifdef HAS_WCRTOMB PERLVAR(I, wcrtomb_ps, mbstate_t) #endif +#ifdef PERL_MEM_LOG +/* Enough space for the reserved byte, 1 for a potential leading 0, then enough + * for the longest representable integer plus an extra, the 3 flag characters, + * and NUL */ +PERLVARA(I, mem_log, 1 + 1 + TYPE_DIGITS(UV) + 1 + 3 + 1, char); +#endif /* If you are adding a U8 or U16, check to see if there are 'Space' comments * above on where there are gaps which currently will be structure padding. */ diff --git a/invlist_inline.h b/invlist_inline.h index f6ac81953355..0f24f3d50369 100644 --- a/invlist_inline.h +++ b/invlist_inline.h @@ -145,7 +145,7 @@ S_invlist_highest(SV* const invlist) PERL_ARGS_ASSERT_INVLIST_HIGHEST; if (len == 0) { - return 0; + return 0; } array = invlist_array(invlist); @@ -218,8 +218,8 @@ S_invlist_iternext(SV* invlist, UV* start, UV* end) PERL_ARGS_ASSERT_INVLIST_ITERNEXT; if (*pos >= len) { - *pos = (STRLEN) UV_MAX; /* Force iterinit() to be required next time */ - return FALSE; + *pos = (STRLEN) UV_MAX; /* Force iterinit() to be required next time */ + return FALSE; } array = invlist_array(invlist); @@ -227,10 +227,10 @@ S_invlist_iternext(SV* invlist, UV* start, UV* end) *start = array[(*pos)++]; if (*pos >= len) { - *end = UV_MAX; + *end = UV_MAX; } else { - *end = array[(*pos)++] - 1; + *end = array[(*pos)++] - 1; } return TRUE; diff --git a/iperlsys.h b/iperlsys.h index c176ad5c559a..eaa0a9df227f 100644 --- a/iperlsys.h +++ b/iperlsys.h @@ -69,7 +69,7 @@ typedef FILE* (*LPStdin)(struct IPerlStdIO*); typedef FILE* (*LPStdout)(struct IPerlStdIO*); typedef FILE* (*LPStderr)(struct IPerlStdIO*); typedef FILE* (*LPOpen)(struct IPerlStdIO*, const char*, - const char*); + const char*); typedef int (*LPClose)(struct IPerlStdIO*, FILE*); typedef int (*LPEof)(struct IPerlStdIO*, FILE*); typedef int (*LPError)(struct IPerlStdIO*, FILE*); @@ -87,12 +87,12 @@ typedef int (*LPUngetc)(struct IPerlStdIO*, int,FILE*); typedef int (*LPFileno)(struct IPerlStdIO*, FILE*); typedef FILE* (*LPFdopen)(struct IPerlStdIO*, int, const char*); typedef FILE* (*LPReopen)(struct IPerlStdIO*, const char*, - const char*, FILE*); + const char*, FILE*); typedef SSize_t (*LPRead)(struct IPerlStdIO*, void*, Size_t, Size_t, FILE *); typedef SSize_t (*LPWrite)(struct IPerlStdIO*, const void*, Size_t, Size_t, FILE *); typedef void (*LPSetBuf)(struct IPerlStdIO*, FILE*, char*); typedef int (*LPSetVBuf)(struct IPerlStdIO*, FILE*, char*, int, - Size_t); + Size_t); typedef void (*LPSetCnt)(struct IPerlStdIO*, FILE*, int); #ifndef NETWARE @@ -103,16 +103,16 @@ typedef void (*LPSetPtr)(struct IPerlStdIO*, FILE*, STDCHAR*, int); typedef void (*LPSetlinebuf)(struct IPerlStdIO*, FILE*); typedef int (*LPPrintf)(struct IPerlStdIO*, FILE*, const char*, - ...); + ...); typedef int (*LPVprintf)(struct IPerlStdIO*, FILE*, const char*, - va_list); + va_list); typedef Off_t (*LPTell)(struct IPerlStdIO*, FILE*); typedef int (*LPSeek)(struct IPerlStdIO*, FILE*, Off_t, int); typedef void (*LPRewind)(struct IPerlStdIO*, FILE*); typedef FILE* (*LPTmpfile)(struct IPerlStdIO*); typedef int (*LPGetpos)(struct IPerlStdIO*, FILE*, Fpos_t*); typedef int (*LPSetpos)(struct IPerlStdIO*, FILE*, - const Fpos_t*); + const Fpos_t*); typedef void (*LPInit)(struct IPerlStdIO*); typedef void (*LPInitOSExtras)(struct IPerlStdIO*); typedef FILE* (*LPFdupopen)(struct IPerlStdIO*, FILE*); @@ -202,84 +202,84 @@ struct IPerlStdIOInfo /* Now take FILE * via function table */ #define PerlSIO_stdin \ - (*PL_StdIO->pStdin)(PL_StdIO) + (*PL_StdIO->pStdin)(PL_StdIO) #define PerlSIO_stdout \ - (*PL_StdIO->pStdout)(PL_StdIO) + (*PL_StdIO->pStdout)(PL_StdIO) #define PerlSIO_stderr \ - (*PL_StdIO->pStderr)(PL_StdIO) + (*PL_StdIO->pStderr)(PL_StdIO) #define PerlSIO_fopen(x,y) \ - (*PL_StdIO->pOpen)(PL_StdIO, (x),(y)) + (*PL_StdIO->pOpen)(PL_StdIO, (x),(y)) #define PerlSIO_fclose(f) \ - (*PL_StdIO->pClose)(PL_StdIO, (f)) + (*PL_StdIO->pClose)(PL_StdIO, (f)) #define PerlSIO_feof(f) \ - (*PL_StdIO->pEof)(PL_StdIO, (f)) + (*PL_StdIO->pEof)(PL_StdIO, (f)) #define PerlSIO_ferror(f) \ - (*PL_StdIO->pError)(PL_StdIO, (f)) + (*PL_StdIO->pError)(PL_StdIO, (f)) #define PerlSIO_clearerr(f) \ - (*PL_StdIO->pClearerr)(PL_StdIO, (f)) + (*PL_StdIO->pClearerr)(PL_StdIO, (f)) #define PerlSIO_fgetc(f) \ - (*PL_StdIO->pGetc)(PL_StdIO, (f)) + (*PL_StdIO->pGetc)(PL_StdIO, (f)) #define PerlSIO_get_base(f) \ - (*PL_StdIO->pGetBase)(PL_StdIO, (f)) + (*PL_StdIO->pGetBase)(PL_StdIO, (f)) #define PerlSIO_get_bufsiz(f) \ - (*PL_StdIO->pGetBufsiz)(PL_StdIO, (f)) + (*PL_StdIO->pGetBufsiz)(PL_StdIO, (f)) #define PerlSIO_get_cnt(f) \ - (*PL_StdIO->pGetCnt)(PL_StdIO, (f)) + (*PL_StdIO->pGetCnt)(PL_StdIO, (f)) #define PerlSIO_get_ptr(f) \ - (*PL_StdIO->pGetPtr)(PL_StdIO, (f)) + (*PL_StdIO->pGetPtr)(PL_StdIO, (f)) #define PerlSIO_fputc(c,f) \ - (*PL_StdIO->pPutc)(PL_StdIO, (c),(f)) + (*PL_StdIO->pPutc)(PL_StdIO, (c),(f)) #define PerlSIO_fputs(s,f) \ - (*PL_StdIO->pPuts)(PL_StdIO, (s),(f)) + (*PL_StdIO->pPuts)(PL_StdIO, (s),(f)) #define PerlSIO_fflush(f) \ - (*PL_StdIO->pFlush)(PL_StdIO, (f)) + (*PL_StdIO->pFlush)(PL_StdIO, (f)) #define PerlSIO_fgets(s, n, f) \ - (*PL_StdIO->pGets)(PL_StdIO, s, n, (f)) + (*PL_StdIO->pGets)(PL_StdIO, s, n, (f)) #define PerlSIO_ungetc(c,f) \ - (*PL_StdIO->pUngetc)(PL_StdIO, (c),(f)) + (*PL_StdIO->pUngetc)(PL_StdIO, (c),(f)) #define PerlSIO_fileno(f) \ - (*PL_StdIO->pFileno)(PL_StdIO, (f)) + (*PL_StdIO->pFileno)(PL_StdIO, (f)) #define PerlSIO_fdopen(f, s) \ - (*PL_StdIO->pFdopen)(PL_StdIO, (f),(s)) + (*PL_StdIO->pFdopen)(PL_StdIO, (f),(s)) #define PerlSIO_freopen(p, m, f) \ - (*PL_StdIO->pReopen)(PL_StdIO, (p), (m), (f)) + (*PL_StdIO->pReopen)(PL_StdIO, (p), (m), (f)) #define PerlSIO_fread(buf,sz,count,f) \ - (*PL_StdIO->pRead)(PL_StdIO, (buf), (sz), (count), (f)) + (*PL_StdIO->pRead)(PL_StdIO, (buf), (sz), (count), (f)) #define PerlSIO_fwrite(buf,sz,count,f) \ - (*PL_StdIO->pWrite)(PL_StdIO, (buf), (sz), (count), (f)) + (*PL_StdIO->pWrite)(PL_StdIO, (buf), (sz), (count), (f)) #define PerlSIO_setbuf(f,b) \ - (*PL_StdIO->pSetBuf)(PL_StdIO, (f), (b)) + (*PL_StdIO->pSetBuf)(PL_StdIO, (f), (b)) #define PerlSIO_setvbuf(f,b,t,s) \ - (*PL_StdIO->pSetVBuf)(PL_StdIO, (f),(b),(t),(s)) + (*PL_StdIO->pSetVBuf)(PL_StdIO, (f),(b),(t),(s)) #define PerlSIO_set_cnt(f,c) \ - (*PL_StdIO->pSetCnt)(PL_StdIO, (f), (c)) + (*PL_StdIO->pSetCnt)(PL_StdIO, (f), (c)) #define PerlSIO_set_ptr(f,p) \ - (*PL_StdIO->pSetPtr)(PL_StdIO, (f), (p)) + (*PL_StdIO->pSetPtr)(PL_StdIO, (f), (p)) #define PerlSIO_setlinebuf(f) \ - (*PL_StdIO->pSetlinebuf)(PL_StdIO, (f)) + (*PL_StdIO->pSetlinebuf)(PL_StdIO, (f)) #define PerlSIO_printf Perl_fprintf_nocontext #define PerlSIO_stdoutf Perl_printf_nocontext #define PerlSIO_vprintf(f,fmt,a) \ - (*PL_StdIO->pVprintf)(PL_StdIO, (f),(fmt),a) + (*PL_StdIO->pVprintf)(PL_StdIO, (f),(fmt),a) #define PerlSIO_ftell(f) \ - (*PL_StdIO->pTell)(PL_StdIO, (f)) + (*PL_StdIO->pTell)(PL_StdIO, (f)) #define PerlSIO_fseek(f,o,w) \ - (*PL_StdIO->pSeek)(PL_StdIO, (f),(o),(w)) + (*PL_StdIO->pSeek)(PL_StdIO, (f),(o),(w)) #define PerlSIO_fgetpos(f,p) \ - (*PL_StdIO->pGetpos)(PL_StdIO, (f),(p)) + (*PL_StdIO->pGetpos)(PL_StdIO, (f),(p)) #define PerlSIO_fsetpos(f,p) \ - (*PL_StdIO->pSetpos)(PL_StdIO, (f),(p)) + (*PL_StdIO->pSetpos)(PL_StdIO, (f),(p)) #define PerlSIO_rewind(f) \ - (*PL_StdIO->pRewind)(PL_StdIO, (f)) + (*PL_StdIO->pRewind)(PL_StdIO, (f)) #define PerlSIO_tmpfile() \ - (*PL_StdIO->pTmpfile)(PL_StdIO) + (*PL_StdIO->pTmpfile)(PL_StdIO) #define PerlSIO_init() \ - (*PL_StdIO->pInit)(PL_StdIO) + (*PL_StdIO->pInit)(PL_StdIO) #undef init_os_extras #define init_os_extras() \ - (*PL_StdIO->pInitOSExtras)(PL_StdIO) + (*PL_StdIO->pInitOSExtras)(PL_StdIO) #define PerlSIO_fdupopen(f) \ - (*PL_StdIO->pFdupopen)(PL_StdIO, (f)) + (*PL_StdIO->pFdupopen)(PL_StdIO, (f)) #else /* PERL_IMPLICIT_SYS */ @@ -408,28 +408,28 @@ struct IPerlDirInfo }; #define PerlDir_mkdir(name, mode) \ - (*PL_Dir->pMakedir)(PL_Dir, (name), (mode)) + (*PL_Dir->pMakedir)(PL_Dir, (name), (mode)) #define PerlDir_chdir(name) \ - (*PL_Dir->pChdir)(PL_Dir, (name)) + (*PL_Dir->pChdir)(PL_Dir, (name)) #define PerlDir_rmdir(name) \ - (*PL_Dir->pRmdir)(PL_Dir, (name)) + (*PL_Dir->pRmdir)(PL_Dir, (name)) #define PerlDir_close(dir) \ - (*PL_Dir->pClose)(PL_Dir, (dir)) + (*PL_Dir->pClose)(PL_Dir, (dir)) #define PerlDir_open(name) \ - (*PL_Dir->pOpen)(PL_Dir, (name)) + (*PL_Dir->pOpen)(PL_Dir, (name)) #define PerlDir_read(dir) \ - (*PL_Dir->pRead)(PL_Dir, (dir)) + (*PL_Dir->pRead)(PL_Dir, (dir)) #define PerlDir_rewind(dir) \ - (*PL_Dir->pRewind)(PL_Dir, (dir)) + (*PL_Dir->pRewind)(PL_Dir, (dir)) #define PerlDir_seek(dir, loc) \ - (*PL_Dir->pSeek)(PL_Dir, (dir), (loc)) + (*PL_Dir->pSeek)(PL_Dir, (dir), (loc)) #define PerlDir_tell(dir) \ - (*PL_Dir->pTell)(PL_Dir, (dir)) + (*PL_Dir->pTell)(PL_Dir, (dir)) #ifdef WIN32 #define PerlDir_mapA(dir) \ - (*PL_Dir->pMapPathA)(PL_Dir, (dir)) + (*PL_Dir->pMapPathA)(PL_Dir, (dir)) #define PerlDir_mapW(dir) \ - (*PL_Dir->pMapPathW)(PL_Dir, (dir)) + (*PL_Dir->pMapPathW)(PL_Dir, (dir)) #endif #else /* PERL_IMPLICIT_SYS */ @@ -466,7 +466,7 @@ struct IPerlEnvInfo; typedef char* (*LPEnvGetenv)(struct IPerlEnv*, const char*); typedef int (*LPEnvPutenv)(struct IPerlEnv*, const char*); typedef char* (*LPEnvGetenv_len)(struct IPerlEnv*, - const char *varname, unsigned long *len); + const char *varname, unsigned long *len); typedef int (*LPEnvUname)(struct IPerlEnv*, struct utsname *name); typedef void (*LPEnvClearenv)(struct IPerlEnv*); typedef void* (*LPEnvGetChildenv)(struct IPerlEnv*); @@ -476,16 +476,16 @@ typedef void (*LPEnvFreeChilddir)(struct IPerlEnv*, char* dir); #ifdef HAS_ENVGETENV typedef char* (*LPENVGetenv)(struct IPerlEnv*, const char *varname); typedef char* (*LPENVGetenv_len)(struct IPerlEnv*, - const char *varname, unsigned long *len); + const char *varname, unsigned long *len); #endif #ifdef WIN32 typedef unsigned long (*LPEnvOsID)(struct IPerlEnv*); typedef char* (*LPEnvLibPath)(struct IPerlEnv*, WIN32_NO_REGISTRY_M_(const char*) - STRLEN *const len); + STRLEN *const len); typedef char* (*LPEnvSiteLibPath)(struct IPerlEnv*, const char*, - STRLEN *const len); + STRLEN *const len); typedef char* (*LPEnvVendorLibPath)(struct IPerlEnv*, const char*, - STRLEN *const len); + STRLEN *const len); typedef void (*LPEnvGetChildIO)(struct IPerlEnv*, child_IO_table*); #endif @@ -520,45 +520,45 @@ struct IPerlEnvInfo }; #define PerlEnv_putenv(str) \ - (*PL_Env->pPutenv)(PL_Env,(str)) + (*PL_Env->pPutenv)(PL_Env,(str)) #define PerlEnv_getenv(str) \ - (*PL_Env->pGetenv)(PL_Env,(str)) + (*PL_Env->pGetenv)(PL_Env,(str)) #define PerlEnv_getenv_len(str,l) \ - (*PL_Env->pGetenv_len)(PL_Env,(str), (l)) + (*PL_Env->pGetenv_len)(PL_Env,(str), (l)) #define PerlEnv_clearenv() \ - (*PL_Env->pClearenv)(PL_Env) + (*PL_Env->pClearenv)(PL_Env) #define PerlEnv_get_childenv() \ - (*PL_Env->pGetChildenv)(PL_Env) + (*PL_Env->pGetChildenv)(PL_Env) #define PerlEnv_free_childenv(e) \ - (*PL_Env->pFreeChildenv)(PL_Env, (e)) + (*PL_Env->pFreeChildenv)(PL_Env, (e)) #define PerlEnv_get_childdir() \ - (*PL_Env->pGetChilddir)(PL_Env) + (*PL_Env->pGetChilddir)(PL_Env) #define PerlEnv_free_childdir(d) \ - (*PL_Env->pFreeChilddir)(PL_Env, (d)) + (*PL_Env->pFreeChilddir)(PL_Env, (d)) #ifdef HAS_ENVGETENV # define PerlEnv_ENVgetenv(str) \ - (*PL_Env->pENVGetenv)(PL_Env,(str)) + (*PL_Env->pENVGetenv)(PL_Env,(str)) # define PerlEnv_ENVgetenv_len(str,l) \ - (*PL_Env->pENVGetenv_len)(PL_Env,(str), (l)) + (*PL_Env->pENVGetenv_len)(PL_Env,(str), (l)) #else # define PerlEnv_ENVgetenv(str) \ - PerlEnv_getenv((str)) + PerlEnv_getenv((str)) # define PerlEnv_ENVgetenv_len(str,l) \ - PerlEnv_getenv_len((str),(l)) + PerlEnv_getenv_len((str),(l)) #endif #define PerlEnv_uname(name) \ - (*PL_Env->pEnvUname)(PL_Env,(name)) + (*PL_Env->pEnvUname)(PL_Env,(name)) #ifdef WIN32 #define PerlEnv_os_id() \ - (*PL_Env->pEnvOsID)(PL_Env) + (*PL_Env->pEnvOsID)(PL_Env) #define PerlEnv_lib_path(str, lenp) \ - (*PL_Env->pLibPath)(PL_Env,WIN32_NO_REGISTRY_M_(str)(lenp)) + (*PL_Env->pLibPath)(PL_Env,WIN32_NO_REGISTRY_M_(str)(lenp)) #define PerlEnv_sitelib_path(str, lenp) \ - (*PL_Env->pSiteLibPath)(PL_Env,(str),(lenp)) + (*PL_Env->pSiteLibPath)(PL_Env,(str),(lenp)) #define PerlEnv_vendorlib_path(str, lenp) \ - (*PL_Env->pVendorLibPath)(PL_Env,(str),(lenp)) + (*PL_Env->pVendorLibPath)(PL_Env,(str),(lenp)) #define PerlEnv_get_child_IO(ptr) \ - (*PL_Env->pGetChildIO)(PL_Env, ptr) + (*PL_Env->pGetChildIO)(PL_Env, ptr) #endif #else /* below is ! PERL_IMPLICIT_SYS */ @@ -620,7 +620,7 @@ struct IPerlLIOInfo; typedef int (*LPLIOAccess)(struct IPerlLIO*, const char*, int); typedef int (*LPLIOChmod)(struct IPerlLIO*, const char*, int); typedef int (*LPLIOChown)(struct IPerlLIO*, const char*, uid_t, - gid_t); + gid_t); typedef int (*LPLIOChsize)(struct IPerlLIO*, int, Off_t); typedef int (*LPLIOClose)(struct IPerlLIO*, int); typedef int (*LPLIODup)(struct IPerlLIO*, int); @@ -628,32 +628,36 @@ typedef int (*LPLIODup2)(struct IPerlLIO*, int, int); typedef int (*LPLIOFlock)(struct IPerlLIO*, int, int); typedef int (*LPLIOFileStat)(struct IPerlLIO*, int, Stat_t*); typedef int (*LPLIOIOCtl)(struct IPerlLIO*, int, unsigned int, - char*); + char*); typedef int (*LPLIOIsatty)(struct IPerlLIO*, int); typedef int (*LPLIOLink)(struct IPerlLIO*, const char*, - const char *); + const char *); typedef Off_t (*LPLIOLseek)(struct IPerlLIO*, int, Off_t, int); typedef int (*LPLIOLstat)(struct IPerlLIO*, const char*, - Stat_t*); + Stat_t*); typedef char* (*LPLIOMktemp)(struct IPerlLIO*, char*); typedef int (*LPLIOOpen)(struct IPerlLIO*, const char*, int); typedef int (*LPLIOOpen3)(struct IPerlLIO*, const char*, int, int); typedef int (*LPLIORead)(struct IPerlLIO*, int, void*, unsigned int); typedef int (*LPLIORename)(struct IPerlLIO*, const char*, - const char*); + const char*); #ifdef NETWARE typedef int (*LPLIOSetmode)(struct IPerlLIO*, FILE*, int); #else typedef int (*LPLIOSetmode)(struct IPerlLIO*, int, int); #endif /* NETWARE */ typedef int (*LPLIONameStat)(struct IPerlLIO*, const char*, - Stat_t*); + Stat_t*); typedef char* (*LPLIOTmpnam)(struct IPerlLIO*, char*); typedef int (*LPLIOUmask)(struct IPerlLIO*, int); typedef int (*LPLIOUnlink)(struct IPerlLIO*, const char*); typedef int (*LPLIOUtime)(struct IPerlLIO*, const char*, struct utimbuf*); typedef int (*LPLIOWrite)(struct IPerlLIO*, int, const void*, - unsigned int); + unsigned int); +typedef int (*LPLIOSymLink)(struct IPerlLIO*, const char*, + const char *); +typedef int (*LPLIOReadLink)(struct IPerlLIO*, const char*, + char *, size_t); struct IPerlLIO { @@ -683,6 +687,8 @@ struct IPerlLIO LPLIOUnlink pUnlink; LPLIOUtime pUtime; LPLIOWrite pWrite; + LPLIOSymLink pSymLink; + LPLIOReadLink pReadLink; }; struct IPerlLIOInfo @@ -692,57 +698,61 @@ struct IPerlLIOInfo }; #define PerlLIO_access(file, mode) \ - (*PL_LIO->pAccess)(PL_LIO, (file), (mode)) + (*PL_LIO->pAccess)(PL_LIO, (file), (mode)) #define PerlLIO_chmod(file, mode) \ - (*PL_LIO->pChmod)(PL_LIO, (file), (mode)) + (*PL_LIO->pChmod)(PL_LIO, (file), (mode)) #define PerlLIO_chown(file, owner, group) \ - (*PL_LIO->pChown)(PL_LIO, (file), (owner), (group)) + (*PL_LIO->pChown)(PL_LIO, (file), (owner), (group)) #define PerlLIO_chsize(fd, size) \ - (*PL_LIO->pChsize)(PL_LIO, (fd), (size)) + (*PL_LIO->pChsize)(PL_LIO, (fd), (size)) #define PerlLIO_close(fd) \ - (*PL_LIO->pClose)(PL_LIO, (fd)) + (*PL_LIO->pClose)(PL_LIO, (fd)) #define PerlLIO_dup(fd) \ - (*PL_LIO->pDup)(PL_LIO, (fd)) + (*PL_LIO->pDup)(PL_LIO, (fd)) #define PerlLIO_dup2(fd1, fd2) \ - (*PL_LIO->pDup2)(PL_LIO, (fd1), (fd2)) + (*PL_LIO->pDup2)(PL_LIO, (fd1), (fd2)) #define PerlLIO_flock(fd, op) \ - (*PL_LIO->pFlock)(PL_LIO, (fd), (op)) + (*PL_LIO->pFlock)(PL_LIO, (fd), (op)) #define PerlLIO_fstat(fd, buf) \ - (*PL_LIO->pFileStat)(PL_LIO, (fd), (buf)) + (*PL_LIO->pFileStat)(PL_LIO, (fd), (buf)) #define PerlLIO_ioctl(fd, u, buf) \ - (*PL_LIO->pIOCtl)(PL_LIO, (fd), (u), (buf)) + (*PL_LIO->pIOCtl)(PL_LIO, (fd), (u), (buf)) #define PerlLIO_isatty(fd) \ - (*PL_LIO->pIsatty)(PL_LIO, (fd)) + (*PL_LIO->pIsatty)(PL_LIO, (fd)) #define PerlLIO_link(oldname, newname) \ - (*PL_LIO->pLink)(PL_LIO, (oldname), (newname)) + (*PL_LIO->pLink)(PL_LIO, (oldname), (newname)) +#define PerlLIO_symlink(oldname, newname) \ + (*PL_LIO->pSymLink)(PL_LIO, (oldname), (newname)) +#define PerlLIO_readlink(path, buf, bufsiz) \ + (*PL_LIO->pReadLink)(PL_LIO, (path), (buf), (bufsiz)) #define PerlLIO_lseek(fd, offset, mode) \ - (*PL_LIO->pLseek)(PL_LIO, (fd), (offset), (mode)) + (*PL_LIO->pLseek)(PL_LIO, (fd), (offset), (mode)) #define PerlLIO_lstat(name, buf) \ - (*PL_LIO->pLstat)(PL_LIO, (name), (buf)) + (*PL_LIO->pLstat)(PL_LIO, (name), (buf)) #define PerlLIO_mktemp(file) \ - (*PL_LIO->pMktemp)(PL_LIO, (file)) + (*PL_LIO->pMktemp)(PL_LIO, (file)) #define PerlLIO_open(file, flag) \ - (*PL_LIO->pOpen)(PL_LIO, (file), (flag)) + (*PL_LIO->pOpen)(PL_LIO, (file), (flag)) #define PerlLIO_open3(file, flag, perm) \ - (*PL_LIO->pOpen3)(PL_LIO, (file), (flag), (perm)) + (*PL_LIO->pOpen3)(PL_LIO, (file), (flag), (perm)) #define PerlLIO_read(fd, buf, count) \ - (*PL_LIO->pRead)(PL_LIO, (fd), (buf), (count)) + (*PL_LIO->pRead)(PL_LIO, (fd), (buf), (count)) #define PerlLIO_rename(oname, newname) \ - (*PL_LIO->pRename)(PL_LIO, (oname), (newname)) + (*PL_LIO->pRename)(PL_LIO, (oname), (newname)) #define PerlLIO_setmode(fd, mode) \ - (*PL_LIO->pSetmode)(PL_LIO, (fd), (mode)) + (*PL_LIO->pSetmode)(PL_LIO, (fd), (mode)) #define PerlLIO_stat(name, buf) \ - (*PL_LIO->pNameStat)(PL_LIO, (name), (buf)) + (*PL_LIO->pNameStat)(PL_LIO, (name), (buf)) #define PerlLIO_tmpnam(str) \ - (*PL_LIO->pTmpnam)(PL_LIO, (str)) + (*PL_LIO->pTmpnam)(PL_LIO, (str)) #define PerlLIO_umask(mode) \ - (*PL_LIO->pUmask)(PL_LIO, (mode)) + (*PL_LIO->pUmask)(PL_LIO, (mode)) #define PerlLIO_unlink(file) \ - (*PL_LIO->pUnlink)(PL_LIO, (file)) + (*PL_LIO->pUnlink)(PL_LIO, (file)) #define PerlLIO_utime(file, time) \ - (*PL_LIO->pUtime)(PL_LIO, (file), (time)) + (*PL_LIO->pUtime)(PL_LIO, (file), (time)) #define PerlLIO_write(fd, buf, count) \ - (*PL_LIO->pWrite)(PL_LIO, (fd), (buf), (count)) + (*PL_LIO->pWrite)(PL_LIO, (fd), (buf), (count)) #else /* PERL_IMPLICIT_SYS */ @@ -764,6 +774,8 @@ struct IPerlLIOInfo #define PerlLIO_ioctl(fd, u, buf) ioctl((fd), (u), (buf)) #define PerlLIO_isatty(fd) isatty((fd)) #define PerlLIO_link(oldname, newname) link((oldname), (newname)) +#define PerlLIO_symlink(oldname, newname) symlink((oldname), (newname)) +#define PerlLIO_readlink(path, buf, bufsiz) readlink((path), (buf), (bufsiz)) #define PerlLIO_lseek(fd, offset, mode) lseek((fd), (offset), (mode)) #define PerlLIO_stat(name, buf) Stat((name), (buf)) #ifdef HAS_LSTAT @@ -821,72 +833,72 @@ struct IPerlMemInfo /* Interpreter specific memory macros */ #define PerlMem_malloc(size) \ - (*PL_Mem->pMalloc)(PL_Mem, (size)) + (*PL_Mem->pMalloc)(PL_Mem, (size)) #define PerlMem_realloc(buf, size) \ - (*PL_Mem->pRealloc)(PL_Mem, (buf), (size)) + (*PL_Mem->pRealloc)(PL_Mem, (buf), (size)) #define PerlMem_free(buf) \ - (*PL_Mem->pFree)(PL_Mem, (buf)) + (*PL_Mem->pFree)(PL_Mem, (buf)) #define PerlMem_calloc(num, size) \ - (*PL_Mem->pCalloc)(PL_Mem, (num), (size)) + (*PL_Mem->pCalloc)(PL_Mem, (num), (size)) #define PerlMem_get_lock() \ - (*PL_Mem->pGetLock)(PL_Mem) + (*PL_Mem->pGetLock)(PL_Mem) #define PerlMem_free_lock() \ - (*PL_Mem->pFreeLock)(PL_Mem) + (*PL_Mem->pFreeLock)(PL_Mem) #define PerlMem_is_locked() \ - (*PL_Mem->pIsLocked)(PL_Mem) + (*PL_Mem->pIsLocked)(PL_Mem) /* Shared memory macros */ #ifdef NETWARE #define PerlMemShared_malloc(size) \ - (*PL_Mem->pMalloc)(PL_Mem, (size)) + (*PL_Mem->pMalloc)(PL_Mem, (size)) #define PerlMemShared_realloc(buf, size) \ - (*PL_Mem->pRealloc)(PL_Mem, (buf), (size)) + (*PL_Mem->pRealloc)(PL_Mem, (buf), (size)) #define PerlMemShared_free(buf) \ - (*PL_Mem->pFree)(PL_Mem, (buf)) + (*PL_Mem->pFree)(PL_Mem, (buf)) #define PerlMemShared_calloc(num, size) \ - (*PL_Mem->pCalloc)(PL_Mem, (num), (size)) + (*PL_Mem->pCalloc)(PL_Mem, (num), (size)) #define PerlMemShared_get_lock() \ - (*PL_Mem->pGetLock)(PL_Mem) + (*PL_Mem->pGetLock)(PL_Mem) #define PerlMemShared_free_lock() \ - (*PL_Mem->pFreeLock)(PL_Mem) + (*PL_Mem->pFreeLock)(PL_Mem) #define PerlMemShared_is_locked() \ - (*PL_Mem->pIsLocked)(PL_Mem) + (*PL_Mem->pIsLocked)(PL_Mem) #else #define PerlMemShared_malloc(size) \ - (*PL_MemShared->pMalloc)(PL_MemShared, (size)) + (*PL_MemShared->pMalloc)(PL_MemShared, (size)) #define PerlMemShared_realloc(buf, size) \ - (*PL_MemShared->pRealloc)(PL_MemShared, (buf), (size)) + (*PL_MemShared->pRealloc)(PL_MemShared, (buf), (size)) #define PerlMemShared_free(buf) \ - (*PL_MemShared->pFree)(PL_MemShared, (buf)) + (*PL_MemShared->pFree)(PL_MemShared, (buf)) #define PerlMemShared_calloc(num, size) \ - (*PL_MemShared->pCalloc)(PL_MemShared, (num), (size)) + (*PL_MemShared->pCalloc)(PL_MemShared, (num), (size)) #define PerlMemShared_get_lock() \ - (*PL_MemShared->pGetLock)(PL_MemShared) + (*PL_MemShared->pGetLock)(PL_MemShared) #define PerlMemShared_free_lock() \ - (*PL_MemShared->pFreeLock)(PL_MemShared) + (*PL_MemShared->pFreeLock)(PL_MemShared) #define PerlMemShared_is_locked() \ - (*PL_MemShared->pIsLocked)(PL_MemShared) + (*PL_MemShared->pIsLocked)(PL_MemShared) #endif /* Parse tree memory macros */ #define PerlMemParse_malloc(size) \ - (*PL_MemParse->pMalloc)(PL_MemParse, (size)) + (*PL_MemParse->pMalloc)(PL_MemParse, (size)) #define PerlMemParse_realloc(buf, size) \ - (*PL_MemParse->pRealloc)(PL_MemParse, (buf), (size)) + (*PL_MemParse->pRealloc)(PL_MemParse, (buf), (size)) #define PerlMemParse_free(buf) \ - (*PL_MemParse->pFree)(PL_MemParse, (buf)) + (*PL_MemParse->pFree)(PL_MemParse, (buf)) #define PerlMemParse_calloc(num, size) \ - (*PL_MemParse->pCalloc)(PL_MemParse, (num), (size)) + (*PL_MemParse->pCalloc)(PL_MemParse, (num), (size)) #define PerlMemParse_get_lock() \ - (*PL_MemParse->pGetLock)(PL_MemParse) + (*PL_MemParse->pGetLock)(PL_MemParse) #define PerlMemParse_free_lock() \ - (*PL_MemParse->pFreeLock)(PL_MemParse) + (*PL_MemParse->pFreeLock)(PL_MemParse) #define PerlMemParse_is_locked() \ - (*PL_MemParse->pIsLocked)(PL_MemParse) + (*PL_MemParse->pIsLocked)(PL_MemParse) #else /* PERL_IMPLICIT_SYS */ @@ -936,18 +948,18 @@ struct IPerlProc; struct IPerlProcInfo; typedef void (*LPProcAbort)(struct IPerlProc*); typedef char* (*LPProcCrypt)(struct IPerlProc*, const char*, - const char*); + const char*); typedef void (*LPProcExit)(struct IPerlProc*, int) - __attribute__noreturn__; + __attribute__noreturn__; typedef void (*LPProc_Exit)(struct IPerlProc*, int) - __attribute__noreturn__; + __attribute__noreturn__; typedef int (*LPProcExecl)(struct IPerlProc*, const char*, - const char*, const char*, const char*, - const char*); + const char*, const char*, const char*, + const char*); typedef int (*LPProcExecv)(struct IPerlProc*, const char*, - const char*const*); + const char*const*); typedef int (*LPProcExecvp)(struct IPerlProc*, const char*, - const char*const*); + const char*const*); typedef Uid_t (*LPProcGetuid)(struct IPerlProc*); typedef Uid_t (*LPProcGeteuid)(struct IPerlProc*); typedef Gid_t (*LPProcGetgid)(struct IPerlProc*); @@ -957,9 +969,9 @@ typedef int (*LPProcKill)(struct IPerlProc*, int, int); typedef int (*LPProcKillpg)(struct IPerlProc*, int, int); typedef int (*LPProcPauseProc)(struct IPerlProc*); typedef PerlIO* (*LPProcPopen)(struct IPerlProc*, const char*, - const char*); + const char*); typedef PerlIO* (*LPProcPopenList)(struct IPerlProc*, const char*, - IV narg, SV **args); + IV narg, SV **args); typedef int (*LPProcPclose)(struct IPerlProc*, PerlIO*); typedef int (*LPProcPipe)(struct IPerlProc*, int*); typedef int (*LPProcSetuid)(struct IPerlProc*, uid_t); @@ -974,13 +986,13 @@ typedef int (*LPProcGetpid)(struct IPerlProc*); #ifdef WIN32 typedef void* (*LPProcDynaLoader)(struct IPerlProc*, const char*); typedef void (*LPProcGetOSError)(struct IPerlProc*, - SV* sv, DWORD dwErr); + SV* sv, DWORD dwErr); typedef int (*LPProcSpawnvp)(struct IPerlProc*, int, const char*, - const char*const*); + const char*const*); #endif typedef int (*LPProcLastHost)(struct IPerlProc*); typedef int (*LPProcGetTimeOfDay)(struct IPerlProc*, - struct timeval*, void*); + struct timeval*, void*); struct IPerlProc { @@ -1028,76 +1040,76 @@ struct IPerlProcInfo }; #define PerlProc_abort() \ - (*PL_Proc->pAbort)(PL_Proc) + (*PL_Proc->pAbort)(PL_Proc) #define PerlProc_crypt(c,s) \ - (*PL_Proc->pCrypt)(PL_Proc, (c), (s)) + (*PL_Proc->pCrypt)(PL_Proc, (c), (s)) #define PerlProc_exit(s) \ - (*PL_Proc->pExit)(PL_Proc, (s)) + (*PL_Proc->pExit)(PL_Proc, (s)) #define PerlProc__exit(s) \ - (*PL_Proc->p_Exit)(PL_Proc, (s)) + (*PL_Proc->p_Exit)(PL_Proc, (s)) #define PerlProc_execl(c, w, x, y, z) \ - (*PL_Proc->pExecl)(PL_Proc, (c), (w), (x), (y), (z)) + (*PL_Proc->pExecl)(PL_Proc, (c), (w), (x), (y), (z)) #define PerlProc_execv(c, a) \ - (*PL_Proc->pExecv)(PL_Proc, (c), (a)) + (*PL_Proc->pExecv)(PL_Proc, (c), (a)) #define PerlProc_execvp(c, a) \ - (*PL_Proc->pExecvp)(PL_Proc, (c), (a)) + (*PL_Proc->pExecvp)(PL_Proc, (c), (a)) #define PerlProc_getuid() \ - (*PL_Proc->pGetuid)(PL_Proc) + (*PL_Proc->pGetuid)(PL_Proc) #define PerlProc_geteuid() \ - (*PL_Proc->pGeteuid)(PL_Proc) + (*PL_Proc->pGeteuid)(PL_Proc) #define PerlProc_getgid() \ - (*PL_Proc->pGetgid)(PL_Proc) + (*PL_Proc->pGetgid)(PL_Proc) #define PerlProc_getegid() \ - (*PL_Proc->pGetegid)(PL_Proc) + (*PL_Proc->pGetegid)(PL_Proc) #define PerlProc_getlogin() \ - (*PL_Proc->pGetlogin)(PL_Proc) + (*PL_Proc->pGetlogin)(PL_Proc) #define PerlProc_kill(i, a) \ - (*PL_Proc->pKill)(PL_Proc, (i), (a)) + (*PL_Proc->pKill)(PL_Proc, (i), (a)) #define PerlProc_killpg(i, a) \ - (*PL_Proc->pKillpg)(PL_Proc, (i), (a)) + (*PL_Proc->pKillpg)(PL_Proc, (i), (a)) #define PerlProc_pause() \ - (*PL_Proc->pPauseProc)(PL_Proc) + (*PL_Proc->pPauseProc)(PL_Proc) #define PerlProc_popen(c, m) \ - (*PL_Proc->pPopen)(PL_Proc, (c), (m)) + (*PL_Proc->pPopen)(PL_Proc, (c), (m)) #define PerlProc_popen_list(m, n, a) \ - (*PL_Proc->pPopenList)(PL_Proc, (m), (n), (a)) + (*PL_Proc->pPopenList)(PL_Proc, (m), (n), (a)) #define PerlProc_pclose(f) \ - (*PL_Proc->pPclose)(PL_Proc, (f)) + (*PL_Proc->pPclose)(PL_Proc, (f)) #define PerlProc_pipe(fd) \ - (*PL_Proc->pPipe)(PL_Proc, (fd)) + (*PL_Proc->pPipe)(PL_Proc, (fd)) #define PerlProc_setuid(u) \ - (*PL_Proc->pSetuid)(PL_Proc, (u)) + (*PL_Proc->pSetuid)(PL_Proc, (u)) #define PerlProc_setgid(g) \ - (*PL_Proc->pSetgid)(PL_Proc, (g)) + (*PL_Proc->pSetgid)(PL_Proc, (g)) #define PerlProc_sleep(t) \ - (*PL_Proc->pSleep)(PL_Proc, (t)) + (*PL_Proc->pSleep)(PL_Proc, (t)) #define PerlProc_times(t) \ - (*PL_Proc->pTimes)(PL_Proc, (t)) + (*PL_Proc->pTimes)(PL_Proc, (t)) #define PerlProc_wait(t) \ - (*PL_Proc->pWait)(PL_Proc, (t)) + (*PL_Proc->pWait)(PL_Proc, (t)) #define PerlProc_waitpid(p,s,f) \ - (*PL_Proc->pWaitpid)(PL_Proc, (p), (s), (f)) + (*PL_Proc->pWaitpid)(PL_Proc, (p), (s), (f)) #define PerlProc_signal(n, h) \ - (*PL_Proc->pSignal)(PL_Proc, (n), (h)) + (*PL_Proc->pSignal)(PL_Proc, (n), (h)) #define PerlProc_fork() \ - (*PL_Proc->pFork)(PL_Proc) + (*PL_Proc->pFork)(PL_Proc) #define PerlProc_getpid() \ - (*PL_Proc->pGetpid)(PL_Proc) + (*PL_Proc->pGetpid)(PL_Proc) #define PerlProc_setjmp(b, n) Sigsetjmp((b), (n)) #define PerlProc_longjmp(b, n) Siglongjmp((b), (n)) #ifdef WIN32 #define PerlProc_DynaLoad(f) \ - (*PL_Proc->pDynaLoader)(PL_Proc, (f)) + (*PL_Proc->pDynaLoader)(PL_Proc, (f)) #define PerlProc_GetOSError(s,e) \ - (*PL_Proc->pGetOSError)(PL_Proc, (s), (e)) + (*PL_Proc->pGetOSError)(PL_Proc, (s), (e)) #define PerlProc_spawnvp(m, c, a) \ - (*PL_Proc->pSpawnvp)(PL_Proc, (m), (c), (a)) + (*PL_Proc->pSpawnvp)(PL_Proc, (m), (c), (a)) #endif #define PerlProc_lasthost() \ - (*PL_Proc->pLastHost)(PL_Proc) + (*PL_Proc->pLastHost)(PL_Proc) #define PerlProc_gettimeofday(t,z) \ - (*PL_Proc->pGetTimeOfDay)(PL_Proc,(t),(z)) + (*PL_Proc->pGetTimeOfDay)(PL_Proc,(t),(z)) #else /* PERL_IMPLICIT_SYS */ @@ -1106,7 +1118,7 @@ struct IPerlProcInfo #define PerlProc_exit(s) exit((s)) #define PerlProc__exit(s) _exit((s)) #define PerlProc_execl(c,w,x,y,z) \ - execl((c), (w), (x), (y), (z)) + execl((c), (w), (x), (y), (z)) #define PerlProc_execv(c, a) execv((c), (a)) #define PerlProc_execvp(c, a) execvp((c), (a)) #define PerlProc_getuid() getuid() @@ -1136,11 +1148,11 @@ struct IPerlProcInfo #ifdef WIN32 #define PerlProc_DynaLoad(f) \ - win32_dynaload((f)) + win32_dynaload((f)) #define PerlProc_GetOSError(s,e) \ - win32_str_os_error((s), (e)) + win32_str_os_error((s), (e)) #define PerlProc_spawnvp(m, c, a) \ - win32_spawnvp((m), (c), (a)) + win32_spawnvp((m), (c), (a)) #undef PerlProc_signal #define PerlProc_signal(n, h) win32_signal((n), (h)) #endif @@ -1160,20 +1172,20 @@ typedef u_short (*LPHtons)(struct IPerlSock*, u_short); typedef u_long (*LPNtohl)(struct IPerlSock*, u_long); typedef u_short (*LPNtohs)(struct IPerlSock*, u_short); typedef SOCKET (*LPAccept)(struct IPerlSock*, SOCKET, - struct sockaddr*, int*); + struct sockaddr*, int*); typedef int (*LPBind)(struct IPerlSock*, SOCKET, - const struct sockaddr*, int); + const struct sockaddr*, int); typedef int (*LPConnect)(struct IPerlSock*, SOCKET, - const struct sockaddr*, int); + const struct sockaddr*, int); typedef void (*LPEndhostent)(struct IPerlSock*); typedef void (*LPEndnetent)(struct IPerlSock*); typedef void (*LPEndprotoent)(struct IPerlSock*); typedef void (*LPEndservent)(struct IPerlSock*); typedef int (*LPGethostname)(struct IPerlSock*, char*, int); typedef int (*LPGetpeername)(struct IPerlSock*, SOCKET, - struct sockaddr*, int*); + struct sockaddr*, int*); typedef struct hostent* (*LPGethostbyaddr)(struct IPerlSock*, const char*, - int, int); + int, int); typedef struct hostent* (*LPGethostbyname)(struct IPerlSock*, const char*); typedef struct hostent* (*LPGethostent)(struct IPerlSock*); typedef struct netent* (*LPGetnetbyaddr)(struct IPerlSock*, long, int); @@ -1183,36 +1195,36 @@ typedef struct protoent*(*LPGetprotobyname)(struct IPerlSock*, const char*); typedef struct protoent*(*LPGetprotobynumber)(struct IPerlSock*, int); typedef struct protoent*(*LPGetprotoent)(struct IPerlSock*); typedef struct servent* (*LPGetservbyname)(struct IPerlSock*, const char*, - const char*); + const char*); typedef struct servent* (*LPGetservbyport)(struct IPerlSock*, int, - const char*); + const char*); typedef struct servent* (*LPGetservent)(struct IPerlSock*); typedef int (*LPGetsockname)(struct IPerlSock*, SOCKET, - struct sockaddr*, int*); + struct sockaddr*, int*); typedef int (*LPGetsockopt)(struct IPerlSock*, SOCKET, int, int, - char*, int*); + char*, int*); typedef unsigned long (*LPInetAddr)(struct IPerlSock*, const char*); typedef char* (*LPInetNtoa)(struct IPerlSock*, struct in_addr); typedef int (*LPListen)(struct IPerlSock*, SOCKET, int); typedef int (*LPRecv)(struct IPerlSock*, SOCKET, char*, int, int); typedef int (*LPRecvfrom)(struct IPerlSock*, SOCKET, char*, int, - int, struct sockaddr*, int*); + int, struct sockaddr*, int*); typedef int (*LPSelect)(struct IPerlSock*, int, char*, char*, - char*, const struct timeval*); + char*, const struct timeval*); typedef int (*LPSend)(struct IPerlSock*, SOCKET, const char*, int, - int); + int); typedef int (*LPSendto)(struct IPerlSock*, SOCKET, const char*, - int, int, const struct sockaddr*, int); + int, int, const struct sockaddr*, int); typedef void (*LPSethostent)(struct IPerlSock*, int); typedef void (*LPSetnetent)(struct IPerlSock*, int); typedef void (*LPSetprotoent)(struct IPerlSock*, int); typedef void (*LPSetservent)(struct IPerlSock*, int); typedef int (*LPSetsockopt)(struct IPerlSock*, SOCKET, int, int, - const char*, int); + const char*, int); typedef int (*LPShutdown)(struct IPerlSock*, SOCKET, int); typedef SOCKET (*LPSocket)(struct IPerlSock*, int, int, int); typedef int (*LPSocketpair)(struct IPerlSock*, int, int, int, - int*); + int*); #ifdef WIN32 typedef int (*LPClosesocket)(struct IPerlSock*, SOCKET s); #endif @@ -1274,95 +1286,95 @@ struct IPerlSockInfo }; #define PerlSock_htonl(x) \ - (*PL_Sock->pHtonl)(PL_Sock, x) + (*PL_Sock->pHtonl)(PL_Sock, x) #define PerlSock_htons(x) \ - (*PL_Sock->pHtons)(PL_Sock, x) + (*PL_Sock->pHtons)(PL_Sock, x) #define PerlSock_ntohl(x) \ - (*PL_Sock->pNtohl)(PL_Sock, x) + (*PL_Sock->pNtohl)(PL_Sock, x) #define PerlSock_ntohs(x) \ - (*PL_Sock->pNtohs)(PL_Sock, x) + (*PL_Sock->pNtohs)(PL_Sock, x) #define PerlSock_accept(s, a, l) \ - (*PL_Sock->pAccept)(PL_Sock, s, a, l) + (*PL_Sock->pAccept)(PL_Sock, s, a, l) #define PerlSock_bind(s, n, l) \ - (*PL_Sock->pBind)(PL_Sock, s, n, l) + (*PL_Sock->pBind)(PL_Sock, s, n, l) #define PerlSock_connect(s, n, l) \ - (*PL_Sock->pConnect)(PL_Sock, s, n, l) + (*PL_Sock->pConnect)(PL_Sock, s, n, l) #define PerlSock_endhostent() \ - (*PL_Sock->pEndhostent)(PL_Sock) + (*PL_Sock->pEndhostent)(PL_Sock) #define PerlSock_endnetent() \ - (*PL_Sock->pEndnetent)(PL_Sock) + (*PL_Sock->pEndnetent)(PL_Sock) #define PerlSock_endprotoent() \ - (*PL_Sock->pEndprotoent)(PL_Sock) + (*PL_Sock->pEndprotoent)(PL_Sock) #define PerlSock_endservent() \ - (*PL_Sock->pEndservent)(PL_Sock) + (*PL_Sock->pEndservent)(PL_Sock) #define PerlSock_gethostbyaddr(a, l, t) \ - (*PL_Sock->pGethostbyaddr)(PL_Sock, a, l, t) + (*PL_Sock->pGethostbyaddr)(PL_Sock, a, l, t) #define PerlSock_gethostbyname(n) \ - (*PL_Sock->pGethostbyname)(PL_Sock, n) + (*PL_Sock->pGethostbyname)(PL_Sock, n) #define PerlSock_gethostent() \ - (*PL_Sock->pGethostent)(PL_Sock) + (*PL_Sock->pGethostent)(PL_Sock) #define PerlSock_gethostname(n, l) \ - (*PL_Sock->pGethostname)(PL_Sock, n, l) + (*PL_Sock->pGethostname)(PL_Sock, n, l) #define PerlSock_getnetbyaddr(n, t) \ - (*PL_Sock->pGetnetbyaddr)(PL_Sock, n, t) + (*PL_Sock->pGetnetbyaddr)(PL_Sock, n, t) #define PerlSock_getnetbyname(c) \ - (*PL_Sock->pGetnetbyname)(PL_Sock, c) + (*PL_Sock->pGetnetbyname)(PL_Sock, c) #define PerlSock_getnetent() \ - (*PL_Sock->pGetnetent)(PL_Sock) + (*PL_Sock->pGetnetent)(PL_Sock) #define PerlSock_getpeername(s, n, l) \ - (*PL_Sock->pGetpeername)(PL_Sock, s, n, l) + (*PL_Sock->pGetpeername)(PL_Sock, s, n, l) #define PerlSock_getprotobyname(n) \ - (*PL_Sock->pGetprotobyname)(PL_Sock, n) + (*PL_Sock->pGetprotobyname)(PL_Sock, n) #define PerlSock_getprotobynumber(n) \ - (*PL_Sock->pGetprotobynumber)(PL_Sock, n) + (*PL_Sock->pGetprotobynumber)(PL_Sock, n) #define PerlSock_getprotoent() \ - (*PL_Sock->pGetprotoent)(PL_Sock) + (*PL_Sock->pGetprotoent)(PL_Sock) #define PerlSock_getservbyname(n, p) \ - (*PL_Sock->pGetservbyname)(PL_Sock, n, p) + (*PL_Sock->pGetservbyname)(PL_Sock, n, p) #define PerlSock_getservbyport(port, p) \ - (*PL_Sock->pGetservbyport)(PL_Sock, port, p) + (*PL_Sock->pGetservbyport)(PL_Sock, port, p) #define PerlSock_getservent() \ - (*PL_Sock->pGetservent)(PL_Sock) + (*PL_Sock->pGetservent)(PL_Sock) #define PerlSock_getsockname(s, n, l) \ - (*PL_Sock->pGetsockname)(PL_Sock, s, n, l) + (*PL_Sock->pGetsockname)(PL_Sock, s, n, l) #define PerlSock_getsockopt(s,l,n,v,i) \ - (*PL_Sock->pGetsockopt)(PL_Sock, s, l, n, v, i) + (*PL_Sock->pGetsockopt)(PL_Sock, s, l, n, v, i) #define PerlSock_inet_addr(c) \ - (*PL_Sock->pInetAddr)(PL_Sock, c) + (*PL_Sock->pInetAddr)(PL_Sock, c) #define PerlSock_inet_ntoa(i) \ - (*PL_Sock->pInetNtoa)(PL_Sock, i) + (*PL_Sock->pInetNtoa)(PL_Sock, i) #define PerlSock_listen(s, b) \ - (*PL_Sock->pListen)(PL_Sock, s, b) + (*PL_Sock->pListen)(PL_Sock, s, b) #define PerlSock_recv(s, b, l, f) \ - (*PL_Sock->pRecv)(PL_Sock, s, b, l, f) + (*PL_Sock->pRecv)(PL_Sock, s, b, l, f) #define PerlSock_recvfrom(s,b,l,f,from,fromlen) \ - (*PL_Sock->pRecvfrom)(PL_Sock, s, b, l, f, from, fromlen) + (*PL_Sock->pRecvfrom)(PL_Sock, s, b, l, f, from, fromlen) #define PerlSock_select(n, r, w, e, t) \ - (*PL_Sock->pSelect)(PL_Sock, n, (char*)r, (char*)w, (char*)e, t) + (*PL_Sock->pSelect)(PL_Sock, n, (char*)r, (char*)w, (char*)e, t) #define PerlSock_send(s, b, l, f) \ - (*PL_Sock->pSend)(PL_Sock, s, b, l, f) + (*PL_Sock->pSend)(PL_Sock, s, b, l, f) #define PerlSock_sendto(s, b, l, f, t, tlen) \ - (*PL_Sock->pSendto)(PL_Sock, s, b, l, f, t, tlen) + (*PL_Sock->pSendto)(PL_Sock, s, b, l, f, t, tlen) #define PerlSock_sethostent(f) \ - (*PL_Sock->pSethostent)(PL_Sock, f) + (*PL_Sock->pSethostent)(PL_Sock, f) #define PerlSock_setnetent(f) \ - (*PL_Sock->pSetnetent)(PL_Sock, f) + (*PL_Sock->pSetnetent)(PL_Sock, f) #define PerlSock_setprotoent(f) \ - (*PL_Sock->pSetprotoent)(PL_Sock, f) + (*PL_Sock->pSetprotoent)(PL_Sock, f) #define PerlSock_setservent(f) \ - (*PL_Sock->pSetservent)(PL_Sock, f) + (*PL_Sock->pSetservent)(PL_Sock, f) #define PerlSock_setsockopt(s, l, n, v, len) \ - (*PL_Sock->pSetsockopt)(PL_Sock, s, l, n, v, len) + (*PL_Sock->pSetsockopt)(PL_Sock, s, l, n, v, len) #define PerlSock_shutdown(s, h) \ - (*PL_Sock->pShutdown)(PL_Sock, s, h) + (*PL_Sock->pShutdown)(PL_Sock, s, h) #define PerlSock_socket(a, t, p) \ - (*PL_Sock->pSocket)(PL_Sock, a, t, p) + (*PL_Sock->pSocket)(PL_Sock, a, t, p) #define PerlSock_socketpair(a, t, p, f) \ - (*PL_Sock->pSocketpair)(PL_Sock, a, t, p, f) + (*PL_Sock->pSocketpair)(PL_Sock, a, t, p, f) #ifdef WIN32 #define PerlSock_closesocket(s) \ - (*PL_Sock->pClosesocket)(PL_Sock, s) + (*PL_Sock->pClosesocket)(PL_Sock, s) #endif #else /* PERL_IMPLICIT_SYS */ @@ -1404,17 +1416,17 @@ struct IPerlSockInfo #define PerlSock_listen(s, b) listen(s, b) #define PerlSock_recv(s, b, l, f) recv(s, b, l, f) #define PerlSock_recvfrom(s, b, l, f, from, fromlen) \ - recvfrom(s, b, l, f, from, fromlen) + recvfrom(s, b, l, f, from, fromlen) #define PerlSock_select(n, r, w, e, t) select(n, r, w, e, t) #define PerlSock_send(s, b, l, f) send(s, b, l, f) #define PerlSock_sendto(s, b, l, f, t, tlen) \ - sendto(s, b, l, f, t, tlen) + sendto(s, b, l, f, t, tlen) #define PerlSock_sethostent(f) sethostent(f) #define PerlSock_setnetent(f) setnetent(f) #define PerlSock_setprotoent(f) setprotoent(f) #define PerlSock_setservent(f) setservent(f) #define PerlSock_setsockopt(s, l, n, v, len) \ - setsockopt(s, l, n, v, len) + setsockopt(s, l, n, v, len) #define PerlSock_shutdown(s, h) shutdown(s, h) #define PerlSock_socket(a, t, p) socket(a, t, p) #define PerlSock_socketpair(a, t, p, f) socketpair(a, t, p, f) diff --git a/keywords.c b/keywords.c index d503bc9c2d90..624debc80a4b 100644 --- a/keywords.c +++ b/keywords.c @@ -203,7 +203,7 @@ Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords) goto unknown; } - case 3: /* 29 tokens of length 3 */ + case 3: /* 30 tokens of length 3 */ switch (name[0]) { case 'E': @@ -463,13 +463,27 @@ Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords) } case 't': - if (name[1] == 'i' && - name[2] == 'e') - { /* tie */ - return -KEY_tie; - } + switch (name[1]) + { + case 'i': + if (name[2] == 'e') + { /* tie */ + return -KEY_tie; + } - goto unknown; + goto unknown; + + case 'r': + if (name[2] == 'y') + { /* try */ + return (all_keywords || FEATURE_TRY_IS_ENABLED ? KEY_try : 0); + } + + goto unknown; + + default: + goto unknown; + } case 'u': if (name[1] == 's' && @@ -964,7 +978,7 @@ Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords) goto unknown; } - case 5: /* 39 tokens of length 5 */ + case 5: /* 40 tokens of length 5 */ switch (name[0]) { case 'B': @@ -1046,6 +1060,16 @@ Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords) case 'c': switch (name[1]) { + case 'a': + if (name[2] == 't' && + name[3] == 'c' && + name[4] == 'h') + { /* catch */ + return (all_keywords || FEATURE_TRY_IS_ENABLED ? KEY_catch : 0); + } + + goto unknown; + case 'h': switch (name[2]) { @@ -3451,5 +3475,5 @@ Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords) } /* Generated from: - * f77998a5bc995c1b42d3d080de227ef5f11638bcd329367431d8f193aef2d3cc regen/keywords.pl + * 3a4f2004642b00b871c01cbdc018f6ca5ead6b4e0b2b184120c60b0b62a229dd regen/keywords.pl * ex: set ro: */ diff --git a/keywords.h b/keywords.h index 23fa6944d898..82694905cb8e 100644 --- a/keywords.h +++ b/keywords.h @@ -37,239 +37,241 @@ #define KEY_bless 21 #define KEY_break 22 #define KEY_caller 23 -#define KEY_chdir 24 -#define KEY_chmod 25 -#define KEY_chomp 26 -#define KEY_chop 27 -#define KEY_chown 28 -#define KEY_chr 29 -#define KEY_chroot 30 -#define KEY_close 31 -#define KEY_closedir 32 -#define KEY_cmp 33 -#define KEY_connect 34 -#define KEY_continue 35 -#define KEY_cos 36 -#define KEY_crypt 37 -#define KEY_dbmclose 38 -#define KEY_dbmopen 39 -#define KEY_default 40 -#define KEY_defined 41 -#define KEY_delete 42 -#define KEY_die 43 -#define KEY_do 44 -#define KEY_dump 45 -#define KEY_each 46 -#define KEY_else 47 -#define KEY_elsif 48 -#define KEY_endgrent 49 -#define KEY_endhostent 50 -#define KEY_endnetent 51 -#define KEY_endprotoent 52 -#define KEY_endpwent 53 -#define KEY_endservent 54 -#define KEY_eof 55 -#define KEY_eq 56 -#define KEY_eval 57 -#define KEY_evalbytes 58 -#define KEY_exec 59 -#define KEY_exists 60 -#define KEY_exit 61 -#define KEY_exp 62 -#define KEY_fc 63 -#define KEY_fcntl 64 -#define KEY_fileno 65 -#define KEY_flock 66 -#define KEY_for 67 -#define KEY_foreach 68 -#define KEY_fork 69 -#define KEY_format 70 -#define KEY_formline 71 -#define KEY_ge 72 -#define KEY_getc 73 -#define KEY_getgrent 74 -#define KEY_getgrgid 75 -#define KEY_getgrnam 76 -#define KEY_gethostbyaddr 77 -#define KEY_gethostbyname 78 -#define KEY_gethostent 79 -#define KEY_getlogin 80 -#define KEY_getnetbyaddr 81 -#define KEY_getnetbyname 82 -#define KEY_getnetent 83 -#define KEY_getpeername 84 -#define KEY_getpgrp 85 -#define KEY_getppid 86 -#define KEY_getpriority 87 -#define KEY_getprotobyname 88 -#define KEY_getprotobynumber 89 -#define KEY_getprotoent 90 -#define KEY_getpwent 91 -#define KEY_getpwnam 92 -#define KEY_getpwuid 93 -#define KEY_getservbyname 94 -#define KEY_getservbyport 95 -#define KEY_getservent 96 -#define KEY_getsockname 97 -#define KEY_getsockopt 98 -#define KEY_given 99 -#define KEY_glob 100 -#define KEY_gmtime 101 -#define KEY_goto 102 -#define KEY_grep 103 -#define KEY_gt 104 -#define KEY_hex 105 -#define KEY_if 106 -#define KEY_index 107 -#define KEY_int 108 -#define KEY_ioctl 109 -#define KEY_isa 110 -#define KEY_join 111 -#define KEY_keys 112 -#define KEY_kill 113 -#define KEY_last 114 -#define KEY_lc 115 -#define KEY_lcfirst 116 -#define KEY_le 117 -#define KEY_length 118 -#define KEY_link 119 -#define KEY_listen 120 -#define KEY_local 121 -#define KEY_localtime 122 -#define KEY_lock 123 -#define KEY_log 124 -#define KEY_lstat 125 -#define KEY_lt 126 -#define KEY_m 127 -#define KEY_map 128 -#define KEY_mkdir 129 -#define KEY_msgctl 130 -#define KEY_msgget 131 -#define KEY_msgrcv 132 -#define KEY_msgsnd 133 -#define KEY_my 134 -#define KEY_ne 135 -#define KEY_next 136 -#define KEY_no 137 -#define KEY_not 138 -#define KEY_oct 139 -#define KEY_open 140 -#define KEY_opendir 141 -#define KEY_or 142 -#define KEY_ord 143 -#define KEY_our 144 -#define KEY_pack 145 -#define KEY_package 146 -#define KEY_pipe 147 -#define KEY_pop 148 -#define KEY_pos 149 -#define KEY_print 150 -#define KEY_printf 151 -#define KEY_prototype 152 -#define KEY_push 153 -#define KEY_q 154 -#define KEY_qq 155 -#define KEY_qr 156 -#define KEY_quotemeta 157 -#define KEY_qw 158 -#define KEY_qx 159 -#define KEY_rand 160 -#define KEY_read 161 -#define KEY_readdir 162 -#define KEY_readline 163 -#define KEY_readlink 164 -#define KEY_readpipe 165 -#define KEY_recv 166 -#define KEY_redo 167 -#define KEY_ref 168 -#define KEY_rename 169 -#define KEY_require 170 -#define KEY_reset 171 -#define KEY_return 172 -#define KEY_reverse 173 -#define KEY_rewinddir 174 -#define KEY_rindex 175 -#define KEY_rmdir 176 -#define KEY_s 177 -#define KEY_say 178 -#define KEY_scalar 179 -#define KEY_seek 180 -#define KEY_seekdir 181 -#define KEY_select 182 -#define KEY_semctl 183 -#define KEY_semget 184 -#define KEY_semop 185 -#define KEY_send 186 -#define KEY_setgrent 187 -#define KEY_sethostent 188 -#define KEY_setnetent 189 -#define KEY_setpgrp 190 -#define KEY_setpriority 191 -#define KEY_setprotoent 192 -#define KEY_setpwent 193 -#define KEY_setservent 194 -#define KEY_setsockopt 195 -#define KEY_shift 196 -#define KEY_shmctl 197 -#define KEY_shmget 198 -#define KEY_shmread 199 -#define KEY_shmwrite 200 -#define KEY_shutdown 201 -#define KEY_sin 202 -#define KEY_sleep 203 -#define KEY_socket 204 -#define KEY_socketpair 205 -#define KEY_sort 206 -#define KEY_splice 207 -#define KEY_split 208 -#define KEY_sprintf 209 -#define KEY_sqrt 210 -#define KEY_srand 211 -#define KEY_stat 212 -#define KEY_state 213 -#define KEY_study 214 -#define KEY_sub 215 -#define KEY_substr 216 -#define KEY_symlink 217 -#define KEY_syscall 218 -#define KEY_sysopen 219 -#define KEY_sysread 220 -#define KEY_sysseek 221 -#define KEY_system 222 -#define KEY_syswrite 223 -#define KEY_tell 224 -#define KEY_telldir 225 -#define KEY_tie 226 -#define KEY_tied 227 -#define KEY_time 228 -#define KEY_times 229 -#define KEY_tr 230 -#define KEY_truncate 231 -#define KEY_uc 232 -#define KEY_ucfirst 233 -#define KEY_umask 234 -#define KEY_undef 235 -#define KEY_unless 236 -#define KEY_unlink 237 -#define KEY_unpack 238 -#define KEY_unshift 239 -#define KEY_untie 240 -#define KEY_until 241 -#define KEY_use 242 -#define KEY_utime 243 -#define KEY_values 244 -#define KEY_vec 245 -#define KEY_wait 246 -#define KEY_waitpid 247 -#define KEY_wantarray 248 -#define KEY_warn 249 -#define KEY_when 250 -#define KEY_while 251 -#define KEY_write 252 -#define KEY_x 253 -#define KEY_xor 254 -#define KEY_y 255 +#define KEY_catch 24 +#define KEY_chdir 25 +#define KEY_chmod 26 +#define KEY_chomp 27 +#define KEY_chop 28 +#define KEY_chown 29 +#define KEY_chr 30 +#define KEY_chroot 31 +#define KEY_close 32 +#define KEY_closedir 33 +#define KEY_cmp 34 +#define KEY_connect 35 +#define KEY_continue 36 +#define KEY_cos 37 +#define KEY_crypt 38 +#define KEY_dbmclose 39 +#define KEY_dbmopen 40 +#define KEY_default 41 +#define KEY_defined 42 +#define KEY_delete 43 +#define KEY_die 44 +#define KEY_do 45 +#define KEY_dump 46 +#define KEY_each 47 +#define KEY_else 48 +#define KEY_elsif 49 +#define KEY_endgrent 50 +#define KEY_endhostent 51 +#define KEY_endnetent 52 +#define KEY_endprotoent 53 +#define KEY_endpwent 54 +#define KEY_endservent 55 +#define KEY_eof 56 +#define KEY_eq 57 +#define KEY_eval 58 +#define KEY_evalbytes 59 +#define KEY_exec 60 +#define KEY_exists 61 +#define KEY_exit 62 +#define KEY_exp 63 +#define KEY_fc 64 +#define KEY_fcntl 65 +#define KEY_fileno 66 +#define KEY_flock 67 +#define KEY_for 68 +#define KEY_foreach 69 +#define KEY_fork 70 +#define KEY_format 71 +#define KEY_formline 72 +#define KEY_ge 73 +#define KEY_getc 74 +#define KEY_getgrent 75 +#define KEY_getgrgid 76 +#define KEY_getgrnam 77 +#define KEY_gethostbyaddr 78 +#define KEY_gethostbyname 79 +#define KEY_gethostent 80 +#define KEY_getlogin 81 +#define KEY_getnetbyaddr 82 +#define KEY_getnetbyname 83 +#define KEY_getnetent 84 +#define KEY_getpeername 85 +#define KEY_getpgrp 86 +#define KEY_getppid 87 +#define KEY_getpriority 88 +#define KEY_getprotobyname 89 +#define KEY_getprotobynumber 90 +#define KEY_getprotoent 91 +#define KEY_getpwent 92 +#define KEY_getpwnam 93 +#define KEY_getpwuid 94 +#define KEY_getservbyname 95 +#define KEY_getservbyport 96 +#define KEY_getservent 97 +#define KEY_getsockname 98 +#define KEY_getsockopt 99 +#define KEY_given 100 +#define KEY_glob 101 +#define KEY_gmtime 102 +#define KEY_goto 103 +#define KEY_grep 104 +#define KEY_gt 105 +#define KEY_hex 106 +#define KEY_if 107 +#define KEY_index 108 +#define KEY_int 109 +#define KEY_ioctl 110 +#define KEY_isa 111 +#define KEY_join 112 +#define KEY_keys 113 +#define KEY_kill 114 +#define KEY_last 115 +#define KEY_lc 116 +#define KEY_lcfirst 117 +#define KEY_le 118 +#define KEY_length 119 +#define KEY_link 120 +#define KEY_listen 121 +#define KEY_local 122 +#define KEY_localtime 123 +#define KEY_lock 124 +#define KEY_log 125 +#define KEY_lstat 126 +#define KEY_lt 127 +#define KEY_m 128 +#define KEY_map 129 +#define KEY_mkdir 130 +#define KEY_msgctl 131 +#define KEY_msgget 132 +#define KEY_msgrcv 133 +#define KEY_msgsnd 134 +#define KEY_my 135 +#define KEY_ne 136 +#define KEY_next 137 +#define KEY_no 138 +#define KEY_not 139 +#define KEY_oct 140 +#define KEY_open 141 +#define KEY_opendir 142 +#define KEY_or 143 +#define KEY_ord 144 +#define KEY_our 145 +#define KEY_pack 146 +#define KEY_package 147 +#define KEY_pipe 148 +#define KEY_pop 149 +#define KEY_pos 150 +#define KEY_print 151 +#define KEY_printf 152 +#define KEY_prototype 153 +#define KEY_push 154 +#define KEY_q 155 +#define KEY_qq 156 +#define KEY_qr 157 +#define KEY_quotemeta 158 +#define KEY_qw 159 +#define KEY_qx 160 +#define KEY_rand 161 +#define KEY_read 162 +#define KEY_readdir 163 +#define KEY_readline 164 +#define KEY_readlink 165 +#define KEY_readpipe 166 +#define KEY_recv 167 +#define KEY_redo 168 +#define KEY_ref 169 +#define KEY_rename 170 +#define KEY_require 171 +#define KEY_reset 172 +#define KEY_return 173 +#define KEY_reverse 174 +#define KEY_rewinddir 175 +#define KEY_rindex 176 +#define KEY_rmdir 177 +#define KEY_s 178 +#define KEY_say 179 +#define KEY_scalar 180 +#define KEY_seek 181 +#define KEY_seekdir 182 +#define KEY_select 183 +#define KEY_semctl 184 +#define KEY_semget 185 +#define KEY_semop 186 +#define KEY_send 187 +#define KEY_setgrent 188 +#define KEY_sethostent 189 +#define KEY_setnetent 190 +#define KEY_setpgrp 191 +#define KEY_setpriority 192 +#define KEY_setprotoent 193 +#define KEY_setpwent 194 +#define KEY_setservent 195 +#define KEY_setsockopt 196 +#define KEY_shift 197 +#define KEY_shmctl 198 +#define KEY_shmget 199 +#define KEY_shmread 200 +#define KEY_shmwrite 201 +#define KEY_shutdown 202 +#define KEY_sin 203 +#define KEY_sleep 204 +#define KEY_socket 205 +#define KEY_socketpair 206 +#define KEY_sort 207 +#define KEY_splice 208 +#define KEY_split 209 +#define KEY_sprintf 210 +#define KEY_sqrt 211 +#define KEY_srand 212 +#define KEY_stat 213 +#define KEY_state 214 +#define KEY_study 215 +#define KEY_sub 216 +#define KEY_substr 217 +#define KEY_symlink 218 +#define KEY_syscall 219 +#define KEY_sysopen 220 +#define KEY_sysread 221 +#define KEY_sysseek 222 +#define KEY_system 223 +#define KEY_syswrite 224 +#define KEY_tell 225 +#define KEY_telldir 226 +#define KEY_tie 227 +#define KEY_tied 228 +#define KEY_time 229 +#define KEY_times 230 +#define KEY_tr 231 +#define KEY_try 232 +#define KEY_truncate 233 +#define KEY_uc 234 +#define KEY_ucfirst 235 +#define KEY_umask 236 +#define KEY_undef 237 +#define KEY_unless 238 +#define KEY_unlink 239 +#define KEY_unpack 240 +#define KEY_unshift 241 +#define KEY_untie 242 +#define KEY_until 243 +#define KEY_use 244 +#define KEY_utime 245 +#define KEY_values 246 +#define KEY_vec 247 +#define KEY_wait 248 +#define KEY_waitpid 249 +#define KEY_wantarray 250 +#define KEY_warn 251 +#define KEY_when 252 +#define KEY_while 253 +#define KEY_write 254 +#define KEY_x 255 +#define KEY_xor 256 +#define KEY_y 257 /* Generated from: - * f77998a5bc995c1b42d3d080de227ef5f11638bcd329367431d8f193aef2d3cc regen/keywords.pl + * 3a4f2004642b00b871c01cbdc018f6ca5ead6b4e0b2b184120c60b0b62a229dd regen/keywords.pl * ex: set ro: */ diff --git a/lib/B/Deparse-core.t b/lib/B/Deparse-core.t index 991412a1dda9..9d891a750780 100644 --- a/lib/B/Deparse-core.t +++ b/lib/B/Deparse-core.t @@ -41,13 +41,15 @@ plan tests => 3904; use feature (sprintf(":%vd", $^V)); # to avoid relying on the feature # logic to add CORE:: use B::Deparse; -my $deparse = new B::Deparse; +my $deparse = B::Deparse->new(); my %SEEN; -my %SEEN_STRENGH; +my %SEEN_STRENGTH; -# for a given keyword, create a sub of that name, then -# deparse "() = $expr", and see if it matches $expected_expr +# For a given keyword, create a sub of that name, +# then deparse 3 different assignment expressions +# using that keyword. See if the $expr we get back +# matches $expected_expr. sub testit { my ($keyword, $expr, $expected_expr, $lexsub) = @_; @@ -55,56 +57,51 @@ sub testit { $expected_expr //= $expr; $SEEN{$keyword} = 1; - # lex=0: () = foo($a,$b,$c) # lex=1: my ($a,$b); () = foo($a,$b,$c) # lex=2: () = foo(my $a,$b,$c) for my $lex (0, 1, 2) { - if ($lex) { - next if $keyword =~ /local|our|state|my/; - } - my $vars = $lex == 1 ? 'my($a, $b, $c, $d, $e);' . "\n " : ""; - - if ($lex == 2) { - my $repl = 'my $a'; - if ($expr =~ 'CORE::do') { - # do foo() is a syntax error, so B::Deparse emits - # do (foo()), but does not distinguish between foo and my, - # because it is too complicated. - $repl = '(my $a)'; - } - s/\$a/$repl/ for $expr, $expected_expr; - } - - my $desc = "$keyword: lex=$lex $expr => $expected_expr"; - $desc .= " (lex sub)" if $lexsub; + next if ($lex and $keyword =~ /local|our|state|my/); + my $vars = $lex == 1 ? 'my($a, $b, $c, $d, $e);' . "\n " : ""; + + if ($lex == 2) { + my $repl = 'my $a'; + if ($expr =~ 'CORE::do') { + # do foo() is a syntax error, so B::Deparse emits + # do (foo()), but does not distinguish between foo and my, + # because it is too complicated. + $repl = '(my $a)'; + } + s/\$a/$repl/ for $expr, $expected_expr; + } + + my $desc = "$keyword: lex=$lex $expr => $expected_expr"; + $desc .= " (lex sub)" if $lexsub; my $code; - my $code_ref; - if ($lexsub) { - package lexsubtest; - no warnings 'experimental::lexical_subs', 'experimental::isa'; - use feature 'lexical_subs'; - no strict 'vars'; + my $code_ref; + if ($lexsub) { + package lexsubtest; + no warnings 'experimental::lexical_subs', 'experimental::isa'; + use feature 'lexical_subs'; + no strict 'vars'; $code = "sub { state sub $keyword; ${vars}() = $expr }"; - $code = "use feature 'isa';\n$code" if $keyword eq "isa"; - $code_ref = eval $code - or die "$@ in $expr"; - } - else { - package test; - no warnings 'experimental::isa'; - use subs (); - import subs $keyword; - $code = "no strict 'vars'; sub { ${vars}() = $expr }"; - $code = "use feature 'isa';\n$code" if $keyword eq "isa"; - $code_ref = eval $code - or die "$@ in $expr"; - } - - my $got_text = $deparse->coderef2text($code_ref); - - unless ($got_text =~ / + $code = "use feature 'isa';\n$code" if $keyword eq "isa"; + $code_ref = eval $code or die "$@ in $expr"; + } + else { + package test; + no warnings 'experimental::isa'; + use subs (); + import subs $keyword; + $code = "no strict 'vars'; sub { ${vars}() = $expr }"; + $code = "use feature 'isa';\n$code" if $keyword eq "isa"; + $code_ref = eval $code or die "$@ in $expr"; + } + + my $got_text = $deparse->coderef2text($code_ref); + + unless ($got_text =~ / package (?:lexsub)?test; (?: BEGIN \{\$\{\^WARNING_BITS\} = "[^"]+"\} )? use strict 'refs', 'subs'; @@ -112,14 +109,14 @@ sub testit { (?: (?:CORE::)?state sub \w+; )? \Q$vars\E\(\) = (.*) \}/s) { - ::fail($desc); - ::diag("couldn't extract line from boilerplate\n"); - ::diag($got_text); - return; - } - - my $got_expr = $1; - is $got_expr, $expected_expr, $desc + ::fail($desc); + ::diag("couldn't extract line from boilerplate\n"); + ::diag($got_text); + return; + } + + my $got_expr = $1; + is $got_expr, $expected_expr, $desc or ::diag("ORIGINAL CODE:\n$code");; } } @@ -128,14 +125,13 @@ sub testit { # Deparse can't distinguish 'and' from '&&' etc my %infix_map = qw(and && or ||); - -# test a keyword that is a binary infix operator, like 'cmp'. +# Test a keyword that is a binary infix operator, like 'cmp'. # $parens - "$a op $b" is deparsed as "($a op $b)" # $strong - keyword is strong sub do_infix_keyword { my ($keyword, $parens, $strong) = @_; - $SEEN_STRENGH{$keyword} = $strong; + $SEEN_STRENGTH{$keyword} = $strong; my $expr = "(\$a $keyword \$b)"; my $nkey = $infix_map{$keyword} // $keyword; my $expr = "(\$a $keyword \$b)"; @@ -149,17 +145,17 @@ sub do_infix_keyword { testit $keyword, "(\$a CORE::$keyword \$b)", $exp, 1; testit $keyword, "(\$a $keyword \$b)", $exp, 1; if (!$strong) { - # B::Deparse fully qualifies any sub whose name is a keyword, - # imported or not, since the importedness may not be reproduced by - # the deparsed code. x is special. - my $pre = "test::" x ($keyword ne 'x'); - testit $keyword, "$keyword(\$a, \$b)", "$pre$keyword(\$a, \$b);"; + # B::Deparse fully qualifies any sub whose name is a keyword, + # imported or not, since the importedness may not be reproduced by + # the deparsed code. x is special. + my $pre = "test::" x ($keyword ne 'x'); + testit $keyword, "$keyword(\$a, \$b)", "$pre$keyword(\$a, \$b);"; } testit $keyword, "$keyword(\$a, \$b)", "$keyword(\$a, \$b);", 1; } -# test a keyword that is as tandard op/function, like 'index(...)'. -# narg - how many args to test it with +# Test a keyword that is a standard op/function, like 'index(...)'. +# $narg - how many args to test it with # $parens - "foo $a, $b" is deparsed as "foo($a, $b)" # $dollar - an extra '$_' arg will appear in the deparsed output # $strong - keyword is strong @@ -168,33 +164,38 @@ sub do_infix_keyword { sub do_std_keyword { my ($keyword, $narg, $parens, $dollar, $strong) = @_; - $SEEN_STRENGH{$keyword} = $strong; + $SEEN_STRENGTH{$keyword} = $strong; for my $core (0,1) { # if true, add CORE:: to keyword being deparsed - for my $lexsub (0,1) { # if true, define lex sub - my @code; - for my $do_exp(0, 1) { # first create expr, then expected-expr - my @args = map "\$$_", (undef,"a".."z")[1..$narg]; - push @args, '$_' - if $dollar && $do_exp && ($strong && !$lexsub or $core); - my $args = join(', ', @args); - # XXX $lex_parens is temporary, until lex subs are - # deparsed properly. - my $lex_parens = - !$core && $do_exp && $lexsub && $keyword ne 'map'; - $args = ((!$core && !$strong) || $parens || $lex_parens) - ? "($args)" - : @args ? " $args" : ""; - push @code, (($core && !($do_exp && $strong)) - ? "CORE::" - : $lexsub && $do_exp - ? "CORE::" x $core - : $do_exp && !$core && !$strong ? "test::" : "") - . "$keyword$args;"; - } - # code[0]: to run; code[1]: expected - testit $keyword, @code, $lexsub; - } + for my $lexsub (0,1) { # if true, define lex sub + my @code; + for my $do_exp(0, 1) { # first create expr, then expected-expr + my @args = map "\$$_", (undef,"a".."z")[1..$narg]; + push @args, '$_' + if $dollar && $do_exp && ($strong && !$lexsub or $core); + my $args = join(', ', @args); + # XXX $lex_parens is temporary, until lex subs are + # deparsed properly. + my $lex_parens = + !$core && $do_exp && $lexsub && $keyword ne 'map'; + $args = ((!$core && !$strong) || $parens || $lex_parens) + ? "($args)" + : @args + ? " $args" + : ""; + push @code, ( + ($core && !($do_exp && $strong)) + ? "CORE::" + : $lexsub && $do_exp + ? "CORE::" x $core + : $do_exp && !$core && !$strong + ? "test::" + : "" + ) . "$keyword$args;"; + } + # code[0]: to run; code[1]: expected + testit $keyword, @code, $lexsub; + } } } @@ -217,18 +218,18 @@ while () { die "unrecognised flag(s): '$flags'" unless $flags =~ /^-?$/; if ($args eq 'B') { # binary infix - die "$keyword: binary (B) op can't have '\$' flag\\n" if $dollar; - die "$keyword: binary (B) op can't have '1' flag\\n" if $invert1; - do_infix_keyword($keyword, $parens, $strong); + die "$keyword: binary (B) op can't have '\$' flag\\n" if $dollar; + die "$keyword: binary (B) op can't have '1' flag\\n" if $invert1; + do_infix_keyword($keyword, $parens, $strong); } else { - my @narg = split //, $args; - for my $n (0..$#narg) { - my $narg = $narg[$n]; - my $p = $parens; - $p = !$p if ($n == 0 && $invert1); - do_std_keyword($keyword, $narg, $p, (!$n && $dollar), $strong); - } + my @narg = split //, $args; + for my $n (0..$#narg) { + my $narg = $narg[$n]; + my $p = $parens; + $p = !$p if ($n == 0 && $invert1); + do_std_keyword($keyword, $narg, $p, (!$n && $dollar), $strong); + } } } @@ -361,6 +362,7 @@ my %not_tested = map { $_ => 1} qw( END INIT UNITCHECK + catch default else elsif @@ -380,6 +382,7 @@ my %not_tested = map { $_ => 1} qw( require s tr + try unless until use @@ -388,8 +391,6 @@ my %not_tested = map { $_ => 1} qw( y ); - - # Sanity check against keyword data: # make sure we haven't missed any keywords, # and that we got the strength right. @@ -413,7 +414,7 @@ SKIP: diag("keyword '$key' seen in $file, but not tested here!!"); $pass = 0; } - if (exists $SEEN_STRENGH{$key} and $SEEN_STRENGH{$key} != $strength) { + if (exists $SEEN_STRENGTH{$key} and $SEEN_STRENGTH{$key} != $strength) { diag("keyword '$key' strengh as seen in $file doen't match here!!"); $pass = 0; } @@ -431,8 +432,6 @@ SKIP: ok($pass, "sanity checks"); } - - __DATA__ # # format: diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm index 2317aa1498a9..96d569acb9c4 100644 --- a/lib/B/Deparse.pm +++ b/lib/B/Deparse.pm @@ -52,7 +52,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring MDEREF_SHIFT ); -$VERSION = '1.55'; +$VERSION = '1.56'; use strict; our $AUTOLOAD; use warnings (); @@ -2304,6 +2304,8 @@ my %feature_keywords = ( evalbytes=>'evalbytes', __SUB__ => '__SUB__', fc => 'fc', + try => 'try', + catch => 'try', ); # keywords that are strong and also have a prototype diff --git a/lib/B/Op_private.pm b/lib/B/Op_private.pm index d89e3da9fa83..480dac69a056 100644 --- a/lib/B/Op_private.pm +++ b/lib/B/Op_private.pm @@ -118,7 +118,7 @@ package B::Op_private; our %bits; -our $VERSION = "5.033004"; +our $VERSION = "5.033007"; $bits{$_}{3} = 'OPpENTERSUB_AMPER' for qw(entersub rv2cv); $bits{$_}{6} = 'OPpENTERSUB_DB' for qw(entersub rv2cv); @@ -275,6 +275,7 @@ $bits{backtick}{0} = $bf[0]; @{$bits{bit_xor}}{1,0} = ($bf[1], $bf[1]); @{$bits{bless}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); @{$bits{caller}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{catch}{0} = $bf[0]; @{$bits{chdir}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); @{$bits{chmod}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); $bits{chomp}{0} = $bf[0]; diff --git a/lib/File/Copy.pm b/lib/File/Copy.pm index 63609cc28e63..ac98cc2df02a 100644 --- a/lib/File/Copy.pm +++ b/lib/File/Copy.pm @@ -24,7 +24,7 @@ sub syscopy; sub cp; sub mv; -$VERSION = '2.34'; +$VERSION = '2.35'; require Exporter; @ISA = qw(Exporter); @@ -100,7 +100,7 @@ sub copy { } if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) && - !($^O eq 'MSWin32' || $^O eq 'os2')) { + !($^O eq 'os2')) { my @fs = stat($from); if (@fs) { my @ts = stat($to); diff --git a/lib/File/Copy.t b/lib/File/Copy.t index 57d9478a68b8..f21c871316b6 100644 --- a/lib/File/Copy.t +++ b/lib/File/Copy.t @@ -164,7 +164,10 @@ for my $cross_partition_test (0..1) { open(F, ">", "file-$$") or die $!; print F "dummy content\n"; close F; - symlink("file-$$", "symlink-$$") or die $!; + if (!symlink("file-$$", "symlink-$$")) { + unlink "file-$$"; + skip "Can't create symlink", 3; + } my $warnings = ''; local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; diff --git a/lib/feature.pm b/lib/feature.pm index 7c60f1d28ec2..e6e0442582ca 100644 --- a/lib/feature.pm +++ b/lib/feature.pm @@ -5,35 +5,37 @@ package feature; -our $VERSION = '1.61'; +our $VERSION = '1.63'; our %feature = ( - fc => 'feature_fc', - isa => 'feature_isa', - say => 'feature_say', - state => 'feature_state', - switch => 'feature_switch', - bitwise => 'feature_bitwise', - indirect => 'feature_indirect', - evalbytes => 'feature_evalbytes', - signatures => 'feature_signatures', - current_sub => 'feature___SUB__', - refaliasing => 'feature_refaliasing', - postderef_qq => 'feature_postderef_qq', - unicode_eval => 'feature_unieval', - declared_refs => 'feature_myref', - unicode_strings => 'feature_unicode', - multidimensional => 'feature_multidimensional', + fc => 'feature_fc', + isa => 'feature_isa', + say => 'feature_say', + try => 'feature_try', + state => 'feature_state', + switch => 'feature_switch', + bitwise => 'feature_bitwise', + indirect => 'feature_indirect', + evalbytes => 'feature_evalbytes', + signatures => 'feature_signatures', + current_sub => 'feature___SUB__', + refaliasing => 'feature_refaliasing', + postderef_qq => 'feature_postderef_qq', + unicode_eval => 'feature_unieval', + declared_refs => 'feature_myref', + unicode_strings => 'feature_unicode', + multidimensional => 'feature_multidimensional', + bareword_filehandles => 'feature_bareword_filehandles', ); our %feature_bundle = ( - "5.10" => [qw(indirect multidimensional say state switch)], - "5.11" => [qw(indirect multidimensional say state switch unicode_strings)], - "5.15" => [qw(current_sub evalbytes fc indirect multidimensional say state switch unicode_eval unicode_strings)], - "5.23" => [qw(current_sub evalbytes fc indirect multidimensional postderef_qq say state switch unicode_eval unicode_strings)], - "5.27" => [qw(bitwise current_sub evalbytes fc indirect multidimensional postderef_qq say state switch unicode_eval unicode_strings)], - "all" => [qw(bitwise current_sub declared_refs evalbytes fc indirect isa multidimensional postderef_qq refaliasing say signatures state switch unicode_eval unicode_strings)], - "default" => [qw(indirect multidimensional)], + "5.10" => [qw(bareword_filehandles indirect multidimensional say state switch)], + "5.11" => [qw(bareword_filehandles indirect multidimensional say state switch unicode_strings)], + "5.15" => [qw(bareword_filehandles current_sub evalbytes fc indirect multidimensional say state switch unicode_eval unicode_strings)], + "5.23" => [qw(bareword_filehandles current_sub evalbytes fc indirect multidimensional postderef_qq say state switch unicode_eval unicode_strings)], + "5.27" => [qw(bareword_filehandles bitwise current_sub evalbytes fc indirect multidimensional postderef_qq say state switch unicode_eval unicode_strings)], + "all" => [qw(bareword_filehandles bitwise current_sub declared_refs evalbytes fc indirect isa multidimensional postderef_qq refaliasing say signatures state switch try unicode_eval unicode_strings)], + "default" => [qw(bareword_filehandles indirect multidimensional)], ); $feature_bundle{"5.12"} = $feature_bundle{"5.11"}; @@ -392,6 +394,30 @@ previous versions, it was simply on all the time. You can use the L module on CPAN to disable multidimensional array emulation for older versions of Perl. +=head2 The 'bareword_filehandles' feature. + +This feature enables bareword filehandles for builtin functions +operations, a generally discouraged practice. It is enabled by +default, but can be turned off to disable bareword filehandles, except +for the exceptions listed below. + +The perl built-in filehandles C, C, C, C, +C, C and the special C<_> are always enabled. + +This feature is enabled under this name from Perl 5.34 onwards. In +previous versions it was simply on all the time. + +You can use the L module on CPAN to disable +bareword filehandles for older versions of perl. + +=head2 The 'try' feature. + +This feature enables the C and C syntax, which allows exception +handling, where exceptions throwin from the body of the block introduced with +C are caught by executing the body of the C block. + +For more information, see L. + =head1 FEATURE BUNDLES It's possible to load multiple features together, using @@ -405,54 +431,64 @@ The following feature bundles are available: bundle features included --------- ----------------- :default indirect multidimensional + bareword_filehandles - :5.10 indirect multidimensional say state switch - - :5.12 indirect multidimensional say state switch - unicode_strings - - :5.14 indirect multidimensional say state switch - unicode_strings - - :5.16 current_sub evalbytes fc indirect - multidimensional say state switch - unicode_eval unicode_strings - - :5.18 current_sub evalbytes fc indirect + :5.10 bareword_filehandles indirect multidimensional say state switch - unicode_eval unicode_strings - :5.20 current_sub evalbytes fc indirect + :5.12 bareword_filehandles indirect multidimensional say state switch - unicode_eval unicode_strings + unicode_strings - :5.22 current_sub evalbytes fc indirect + :5.14 bareword_filehandles indirect multidimensional say state switch - unicode_eval unicode_strings + unicode_strings - :5.24 current_sub evalbytes fc indirect - multidimensional postderef_qq say state + :5.16 bareword_filehandles current_sub evalbytes + fc indirect multidimensional say state switch unicode_eval unicode_strings - :5.26 current_sub evalbytes fc indirect - multidimensional postderef_qq say state + :5.18 bareword_filehandles current_sub evalbytes + fc indirect multidimensional say state switch unicode_eval unicode_strings - :5.28 bitwise current_sub evalbytes fc indirect - multidimensional postderef_qq say state + :5.20 bareword_filehandles current_sub evalbytes + fc indirect multidimensional say state switch unicode_eval unicode_strings - :5.30 bitwise current_sub evalbytes fc indirect - multidimensional postderef_qq say state + :5.22 bareword_filehandles current_sub evalbytes + fc indirect multidimensional say state switch unicode_eval unicode_strings - :5.32 bitwise current_sub evalbytes fc indirect - multidimensional postderef_qq say state - switch unicode_eval unicode_strings + :5.24 bareword_filehandles current_sub evalbytes + fc indirect multidimensional postderef_qq + say state switch unicode_eval + unicode_strings - :5.34 bitwise current_sub evalbytes fc indirect - multidimensional postderef_qq say state - switch unicode_eval unicode_strings + :5.26 bareword_filehandles current_sub evalbytes + fc indirect multidimensional postderef_qq + say state switch unicode_eval + unicode_strings + + :5.28 bareword_filehandles bitwise current_sub + evalbytes fc indirect multidimensional + postderef_qq say state switch unicode_eval + unicode_strings + + :5.30 bareword_filehandles bitwise current_sub + evalbytes fc indirect multidimensional + postderef_qq say state switch unicode_eval + unicode_strings + + :5.32 bareword_filehandles bitwise current_sub + evalbytes fc indirect multidimensional + postderef_qq say state switch unicode_eval + unicode_strings + + :5.34 bareword_filehandles bitwise current_sub + evalbytes fc indirect multidimensional + postderef_qq say state switch unicode_eval + unicode_strings The C<:default> bundle represents the feature set that is enabled before any C or C declaration. diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 69890ef4ae29..3ab6e577a2f6 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -531,7 +531,7 @@ BEGIN use vars qw($VERSION $header); # bump to X.XX in blead, only use X.XX_XX in maint -$VERSION = '1.59'; +$VERSION = '1.60'; $header = "perl5db.pl version $VERSION"; @@ -1878,7 +1878,7 @@ sub _DB__trim_command_and_return_first_component { # A single-character debugger command can be immediately followed by its # argument if they aren't both alphanumeric; otherwise require space # between commands and arguments: - my ($verb, $args) = $cmd =~ m{\A(.\b|\S*)\s*(.*)}s; + my ($verb, $args) = $cmd =~ m{\A([^\.-]\b|\S*)\s*(.*)}s; $obj->cmd_verb($verb); $obj->cmd_args($args); diff --git a/lib/perl5db.t b/lib/perl5db.t index d68eeb7f1f02..f6740f5cdcea 100644 --- a/lib/perl5db.t +++ b/lib/perl5db.t @@ -2144,7 +2144,11 @@ DebugWrap->new({ [ '= quit q', '= foobar l', + '= .hello print "hellox\n"', + '= -goodbye print "goodbyex\n"', 'foobar', + '.hello', + '-goodbye', 'quit', ], prog => '../lib/perl5db/t/test-l-statement-1', @@ -2160,7 +2164,9 @@ DebugWrap->new({ 5:\s+print\ "2\\n";\n /msx, 'Test the = (command alias) command.', - ); + ); + $wrapper->output_like(qr/hellox.*goodbyex/xs, + "check . and - can start alias name"); } # Test the m statement. diff --git a/lib/unicore/uni_keywords.pl b/lib/unicore/uni_keywords.pl index dda925bc7830..1cb6740e2533 100644 --- a/lib/unicore/uni_keywords.pl +++ b/lib/unicore/uni_keywords.pl @@ -1297,7 +1297,7 @@ # 5b7c14380d5cceeaffcfbc18db1ed936391d2af2d51f5a41f1a17b692c77e59b lib/unicore/extracted/DNumValues.txt # ee0dd174fd5b158d82dfea95d7d822ca0bfcd490182669353dca3ab39a8ee807 lib/unicore/mktables # 50b85a67451145545a65cea370dab8d3444fbfe07e9c34cef560c5b7da9d3eef lib/unicore/version -# 2680b9254eb236c5c090f11b149605043e8c8433661b96efc4a42fb4709342a5 regen/charset_translations.pl -# 6bbad21de0848e0236b02f34f5fa0edd3cdae9ba8173cc9469a5513936b9e728 regen/mk_PL_charclass.pl -# d99eae7d3b60d8ed3af56e6fdc41ab53b22288238749812aa1cd01f847fe9d5f regen/mk_invlists.pl +# 24120d5e0c9685c442c93bc1dbea9b85ef973bf8e9474baf0e55b160c288226b regen/charset_translations.pl +# 9f74e34278592ddf58fef8c32236b294e94ea5e12627f911f4563e8040a07292 regen/mk_PL_charclass.pl +# 5eb9e6c825496cc9aa705e3cd33bc6d5a9657dcca16d4c4acc4824ff30b34a26 regen/mk_invlists.pl # ex: set ro: diff --git a/lib/warnings.pm b/lib/warnings.pm index 595792cd8e7e..a92d4904c2da 100644 --- a/lib/warnings.pm +++ b/lib/warnings.pm @@ -5,7 +5,7 @@ package warnings; -our $VERSION = "1.48"; +our $VERSION = "1.51"; # Verify that we're called correctly so that warnings will work. # Can't use Carp, since Carp uses us! @@ -109,6 +109,9 @@ our %Offsets = ( # Warnings Categories added in Perl 5.031 'experimental::isa' => 146, + + # Warnings Categories added in Perl 5.033 + 'experimental::try' => 148, ); our %Bits = ( @@ -122,7 +125,7 @@ our %Bits = ( 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [31] 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7] 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3] - 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x55\x51\x15\x50\x51\x05", # [51..56,58..62,66..68,70..73] + 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x55\x51\x15\x50\x51\x15", # [51..56,58..62,66..68,70..74] 'experimental::alpha_assertions' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [67] 'experimental::bitwise' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [58] 'experimental::const_attr' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [59] @@ -137,6 +140,7 @@ our %Bits = ( 'experimental::script_run' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [68] 'experimental::signatures' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [56] 'experimental::smartmatch' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [54] + 'experimental::try' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [74] 'experimental::uniprop_wildcards' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [71] 'experimental::vlb' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [72] 'experimental::win32_perlio' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [62] @@ -199,7 +203,7 @@ our %DeadBits = ( 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [31] 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7] 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3] - 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xaa\xa2\x2a\xa0\xa2\x0a", # [51..56,58..62,66..68,70..73] + 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xaa\xa2\x2a\xa0\xa2\x2a", # [51..56,58..62,66..68,70..74] 'experimental::alpha_assertions' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [67] 'experimental::bitwise' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [58] 'experimental::const_attr' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [59] @@ -214,6 +218,7 @@ our %DeadBits = ( 'experimental::script_run' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [68] 'experimental::signatures' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [56] 'experimental::smartmatch' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [54] + 'experimental::try' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [74] 'experimental::uniprop_wildcards' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [71] 'experimental::vlb' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [72] 'experimental::win32_perlio' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [62] @@ -267,8 +272,8 @@ our %DeadBits = ( # These are used by various things, including our own tests our $NONE = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"; -our $DEFAULT = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x55\x51\x55\x50\x51\x05"; # [2,4,22,23,25,52..56,58..63,66..68,70..73] -our $LAST_BIT = 148 ; +our $DEFAULT = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x55\x51\x55\x50\x51\x15"; # [2,4,22,23,25,52..56,58..63,66..68,70..74] +our $LAST_BIT = 150 ; our $BYTES = 19 ; sub Croaker @@ -284,16 +289,16 @@ sub _expand_bits { my $want_len = ($LAST_BIT + 7) >> 3; my $len = length($bits); if ($len != $want_len) { - if ($bits eq "") { - $bits = "\x00" x $want_len; - } elsif ($len > $want_len) { - substr $bits, $want_len, $len-$want_len, ""; - } else { - my $x = vec($bits, $Offsets{all} >> 1, 2); - $x |= $x << 2; - $x |= $x << 4; - $bits .= chr($x) x ($want_len - $len); - } + if ($bits eq "") { + $bits = "\x00" x $want_len; + } elsif ($len > $want_len) { + substr $bits, $want_len, $len-$want_len, ""; + } else { + my $x = vec($bits, $Offsets{all} >> 1, 2); + $x |= $x << 2; + $x |= $x << 4; + $bits .= chr($x) x ($want_len - $len); + } } return $bits; } @@ -306,21 +311,21 @@ sub _bits { $mask = _expand_bits($mask); foreach my $word ( @_ ) { - if ($word eq 'FATAL') { - $fatal = 1; - $no_fatal = 0; - } - elsif ($word eq 'NONFATAL') { - $fatal = 0; - $no_fatal = 1; - } - elsif ($catmask = $Bits{$word}) { - $mask |= $catmask ; - $mask |= $DeadBits{$word} if $fatal ; - $mask = ~(~$mask | $DeadBits{$word}) if $no_fatal ; - } - else - { Croaker("Unknown warnings category '$word'")} + if ($word eq 'FATAL') { + $fatal = 1; + $no_fatal = 0; + } + elsif ($word eq 'NONFATAL') { + $fatal = 0; + $no_fatal = 1; + } + elsif ($catmask = $Bits{$word}) { + $mask |= $catmask ; + $mask |= $DeadBits{$word} if $fatal ; + $mask = ~(~$mask | $DeadBits{$word}) if $no_fatal ; + } + else + { Croaker("Unknown warnings category '$word'")} } return $mask ; @@ -335,16 +340,24 @@ sub bits sub import { - shift; - - my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ; + my $invocant = shift; # append 'all' when implied (empty import list or after a lone # "FATAL" or "NONFATAL") push @_, 'all' - if !@_ || (@_==1 && ($_[0] eq 'FATAL' || $_[0] eq 'NONFATAL')); - - ${^WARNING_BITS} = _bits($mask, @_); + if !@_ || (@_==1 && ($_[0] eq 'FATAL' || $_[0] eq 'NONFATAL')); + + my @fatal = (); + foreach my $warning (@_) { + if($warning =~ /^(NON)?FATAL$/) { + @fatal = ($warning); + } elsif(substr($warning, 0, 1) ne '-') { + my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ; + ${^WARNING_BITS} = _bits($mask, @fatal, $warning); + } else { + $invocant->unimport(substr($warning, 1)); + } + } } sub unimport @@ -359,14 +372,14 @@ sub unimport $mask = _expand_bits($mask); foreach my $word ( @_ ) { - if ($word eq 'FATAL') { - next; - } - elsif ($catmask = $Bits{$word}) { - $mask = ~(~$mask | $catmask | $DeadBits{$word}); - } - else - { Croaker("Unknown warnings category '$word'")} + if ($word eq 'FATAL') { + next; + } + elsif ($catmask = $Bits{$word}) { + $mask = ~(~$mask | $catmask | $DeadBits{$word}); + } + else + { Croaker("Unknown warnings category '$word'")} } ${^WARNING_BITS} = $mask ; @@ -389,71 +402,71 @@ sub __chk my $has_level = $wanted & LEVEL ; if ($has_level) { - if (@_ != ($has_message ? 3 : 2)) { - my $sub = (caller 1)[3]; - my $syntax = $has_message - ? "category, level, 'message'" - : 'category, level'; - Croaker("Usage: $sub($syntax)"); + if (@_ != ($has_message ? 3 : 2)) { + my $sub = (caller 1)[3]; + my $syntax = $has_message + ? "category, level, 'message'" + : 'category, level'; + Croaker("Usage: $sub($syntax)"); } } elsif (not @_ == 1 || @_ == ($has_message ? 2 : 0)) { - my $sub = (caller 1)[3]; - my $syntax = $has_message ? "[category,] 'message'" : '[category]'; - Croaker("Usage: $sub($syntax)"); + my $sub = (caller 1)[3]; + my $syntax = $has_message ? "[category,] 'message'" : '[category]'; + Croaker("Usage: $sub($syntax)"); } my $message = pop if $has_message; if (@_) { - # check the category supplied. - $category = shift ; - if (my $type = ref $category) { - Croaker("not an object") - if exists $builtin_type{$type}; - $category = $type; - $isobj = 1 ; - } - $offset = $Offsets{$category}; - Croaker("Unknown warnings category '$category'") - unless defined $offset; + # check the category supplied. + $category = shift ; + if (my $type = ref $category) { + Croaker("not an object") + if exists $builtin_type{$type}; + $category = $type; + $isobj = 1 ; + } + $offset = $Offsets{$category}; + Croaker("Unknown warnings category '$category'") + unless defined $offset; } else { - $category = (caller(1))[0] ; - $offset = $Offsets{$category}; - Croaker("package '$category' not registered for warnings") - unless defined $offset ; + $category = (caller(1))[0] ; + $offset = $Offsets{$category}; + Croaker("package '$category' not registered for warnings") + unless defined $offset ; } my $i; if ($isobj) { - my $pkg; - $i = 2; - while (do { { package DB; $pkg = (caller($i++))[0] } } ) { - last unless @DB::args && $DB::args[0] =~ /^$category=/ ; - } - $i -= 2 ; + my $pkg; + $i = 2; + while (do { { package DB; $pkg = (caller($i++))[0] } } ) { + last unless @DB::args && $DB::args[0] =~ /^$category=/ ; + } + $i -= 2 ; } elsif ($has_level) { - $i = 2 + shift; + $i = 2 + shift; } else { - $i = _error_loc(); # see where Carp will allocate the error + $i = _error_loc(); # see where Carp will allocate the error } # Default to 0 if caller returns nothing. Default to $DEFAULT if it # explicitly returns undef. my(@callers_bitmask) = (caller($i))[9] ; my $callers_bitmask = - @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ; + @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ; length($callers_bitmask) > ($offset >> 3) or $offset = $Offsets{all}; my @results; foreach my $type (FATAL, NORMAL) { - next unless $wanted & $type; + next unless $wanted & $type; - push @results, vec($callers_bitmask, $offset + $type - 1, 1); + push @results, vec($callers_bitmask, $offset + $type - 1, 1); } # &enabled and &fatal_enabled @@ -461,19 +474,19 @@ sub __chk # &warnif, and the category is neither enabled as warning nor as fatal return if ($wanted & (NORMAL | FATAL | MESSAGE)) - == (NORMAL | FATAL | MESSAGE) - && !($results[0] || $results[1]); + == (NORMAL | FATAL | MESSAGE) + && !($results[0] || $results[1]); # If we have an explicit level, bypass Carp. if ($has_level and @callers_bitmask) { - # logic copied from util.c:mess_sv - my $stuff = " at " . join " line ", (caller $i)[1,2]; - $stuff .= sprintf ", <%s> %s %d", - *${^LAST_FH}{NAME}, - ($/ eq "\n" ? "line" : "chunk"), $. - if $. && ${^LAST_FH}; - die "$message$stuff.\n" if $results[0]; - return warn "$message$stuff.\n"; + # logic copied from util.c:mess_sv + my $stuff = " at " . join " line ", (caller $i)[1,2]; + $stuff .= sprintf ", <%s> %s %d", + *${^LAST_FH}{NAME}, + ($/ eq "\n" ? "line" : "chunk"), $. + if $. && ${^LAST_FH}; + die "$message$stuff.\n" if $results[0]; + return warn "$message$stuff.\n"; } require Carp; @@ -497,15 +510,15 @@ sub register_categories my @names = @_; for my $name (@names) { - if (! defined $Bits{$name}) { - $Offsets{$name} = $LAST_BIT; - $Bits{$name} = _mkMask($LAST_BIT++); - $DeadBits{$name} = _mkMask($LAST_BIT++); - if (length($Bits{$name}) > length($Bits{all})) { - $Bits{all} .= "\x55"; - $DeadBits{all} .= "\xaa"; - } - } + if (! defined $Bits{$name}) { + $Offsets{$name} = $LAST_BIT; + $Bits{$name} = _mkMask($LAST_BIT++); + $DeadBits{$name} = _mkMask($LAST_BIT++); + if (length($Bits{$name}) > length($Bits{all})) { + $Bits{all} .= "\x55"; + $DeadBits{all} .= "\xaa"; + } + } } } @@ -571,7 +584,10 @@ warnings - Perl pragma to control optional warnings no warnings; use warnings "all"; - no warnings "all"; + no warnings "uninitialized"; + + # or equivalent to those last two ... + use warnings qw(all -uninitialized); use warnings::register; if (warnings::enabled()) { @@ -623,7 +639,7 @@ For example, consider the code below: my @x; { no warnings; - my $y = @x[0]; + my $y = @x[0]; } my $z = @x[0]; @@ -658,6 +674,41 @@ be reported for the C<$x> variable. Note that neither the B<-w> flag or the C<$^W> can be used to disable/enable default warnings. They are still mandatory in this case. +=head2 "Negative warnings" + +As a convenience, you can (as of Perl 5.34) pass arguments to the +C method both positively and negatively. Negative warnings +are those with a C<-> sign prepended to their names; positive warnings +are anything else. This lets you turn on some warnings and turn off +others in one command. So, assuming that you've already turned on a +bunch of warnings but want to tweak them a bit in some block, you can +do this: + + { + use warnings qw(uninitialized -redefine); + ... + } + +which is equivalent to: + + { + use warnings qw(uninitialized); + no warnings qw(redefine); + ... + } + +The argument list is processed in the order you specify. So, for example, if you +don't want to be warned about use of experimental features, except for C +that you really dislike, you can say this: + + use warnings qw(all -experimental experimental::somefeature); + +which is equivalent to: + + use warnings 'all'; + no warnings 'experimental'; + use warnings 'experimental::somefeature'; + =head2 What's wrong with B<-w> and C<$^W> Although very useful, the big problem with using B<-w> on the command @@ -673,8 +724,8 @@ a block of code. You might expect this to be enough to do the trick: { local ($^W) = 0; - my $x =+ 2; - my $y; chop $y; + my $x =+ 2; + my $y; chop $y; } When this code is run with the B<-w> flag, a warning will be produced @@ -685,8 +736,8 @@ disable compile-time warnings you need to rewrite the code like this: { BEGIN { $^W = 0 } - my $x =+ 2; - my $y; chop $y; + my $x =+ 2; + my $y; chop $y; } And note that unlike the first example, this will permanently set C<$^W> @@ -842,6 +893,8 @@ The current hierarchy is: | | | +- experimental::smartmatch | | + | +- experimental::try + | | | +- experimental::uniprop_wildcards | | | +- experimental::vlb @@ -1006,7 +1059,7 @@ The L module on CPAN offers one example of a warnings subset that the module's authors believe is relatively safe to fatalize. -B users of FATAL warnings, especially those using +B Users of FATAL warnings, especially those using C<< FATAL => 'all' >>, should be fully aware that they are risking future portability of their programs by doing so. Perl makes absolutely no commitments to not introduce new warnings or warnings categories in the @@ -1074,6 +1127,9 @@ use: use v5.20; # Perl 5.20 or greater is required for the following use warnings 'FATAL'; # short form of "use warnings FATAL => 'all';" +However, you should still heed the guidance earlier in this section against +using C 'all';>. + If you want your program to be compatible with versions of Perl before 5.20, you must use C<< use warnings FATAL => 'all'; >> instead. (In previous versions of Perl, the behavior of the statements diff --git a/locale.c b/locale.c index 4654a5beaf07..c8ee1b718d78 100644 --- a/locale.c +++ b/locale.c @@ -142,21 +142,21 @@ S_stdize_locale(pTHX_ char *locs) PERL_ARGS_ASSERT_STDIZE_LOCALE; if (s) { - const char * const t = strchr(s, '.'); - okay = FALSE; - if (t) { - const char * const u = strchr(t, '\n'); - if (u && (u[1] == 0)) { - const STRLEN len = u - s; - Move(s + 1, locs, len, char); - locs[len] = 0; - okay = TRUE; - } - } + const char * const t = strchr(s, '.'); + okay = FALSE; + if (t) { + const char * const u = strchr(t, '\n'); + if (u && (u[1] == 0)) { + const STRLEN len = u - s; + Move(s + 1, locs, len, char); + locs[len] = 0; + okay = TRUE; + } + } } if (!okay) - Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs); + Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs); return locs; } @@ -636,11 +636,12 @@ S_emulate_setlocale(const int category, /* If this assert fails, adjust the size of curlocales in intrpvar.h */ STATIC_ASSERT_STMT(C_ARRAY_LENGTH(PL_curlocales) > LC_ALL_INDEX); -# if defined(_NL_LOCALE_NAME) \ - && defined(DEBUGGING) \ +# if defined(_NL_LOCALE_NAME) \ + && defined(DEBUGGING) \ + /* On systems that accept any locale name, the real underlying \ + * locale is often returned by this internal function, so we \ + * can't use it */ \ && ! defined(SETLOCALE_ACCEPTS_ANY_LOCALE_NAME) - /* On systems that accept any locale name, the real underlying locale - * is often returned by this internal function, so we can't use it */ { /* Internal glibc for querylocale(), but doesn't handle * empty-string ("") locale properly; who knows what other @@ -1226,10 +1227,10 @@ S_emulate_setlocale(const int category, * correct locale for that thread. Any operation that was locale-sensitive * would have to be changed so that it would look like this: * - * LOCALE_LOCK; + * SETLOCALE_LOCK; * setlocale to the correct locale for this operation * do operation - * LOCALE_UNLOCK + * SETLOCALE_UNLOCK * * This leaves the global locale in the most recently used operation's, but it * was locked long enough to get the result. If that result is static, it @@ -1322,7 +1323,7 @@ S_locking_setlocale(pTHX_ /* It might be that this is called from an already-locked section of code. * We would have to detect and skip the LOCK/UNLOCK if so */ - LOCALE_LOCK; + SETLOCALE_LOCK; curlocales[index] = savepv(my_setlocale(category, new_locale)); @@ -1344,7 +1345,7 @@ S_locking_setlocale(pTHX_ #endif - LOCALE_UNLOCK; + SETLOCALE_UNLOCK; return curlocales[index]; } @@ -1439,12 +1440,12 @@ S_new_numeric(pTHX_ const char *newnum) char *save_newnum; if (! newnum) { - Safefree(PL_numeric_name); - PL_numeric_name = NULL; - PL_numeric_standard = TRUE; - PL_numeric_underlying = TRUE; - PL_numeric_underlying_is_standard = TRUE; - return; + Safefree(PL_numeric_name); + PL_numeric_name = NULL; + PL_numeric_standard = TRUE; + PL_numeric_underlying = TRUE; + PL_numeric_underlying_is_standard = TRUE; + return; } save_newnum = stdize_locale(savepv(newnum)); @@ -1467,11 +1468,11 @@ S_new_numeric(pTHX_ const char *newnum) /* Save the new name if it isn't the same as the previous one, if any */ if (! PL_numeric_name || strNE(PL_numeric_name, save_newnum)) { - Safefree(PL_numeric_name); - PL_numeric_name = save_newnum; + Safefree(PL_numeric_name); + PL_numeric_name = save_newnum; } else { - Safefree(save_newnum); + Safefree(save_newnum); } PL_numeric_underlying_is_standard = PL_numeric_standard; @@ -1924,27 +1925,27 @@ S_new_collate(pTHX_ const char *newcoll) * an unlikely bug */ if (! newcoll) { - if (PL_collation_name) { - ++PL_collation_ix; - Safefree(PL_collation_name); - PL_collation_name = NULL; - } - PL_collation_standard = TRUE; + if (PL_collation_name) { + ++PL_collation_ix; + Safefree(PL_collation_name); + PL_collation_name = NULL; + } + PL_collation_standard = TRUE; is_standard_collation: - PL_collxfrm_base = 0; - PL_collxfrm_mult = 2; + PL_collxfrm_base = 0; + PL_collxfrm_mult = 2; PL_in_utf8_COLLATE_locale = FALSE; PL_strxfrm_NUL_replacement = '\0'; PL_strxfrm_max_cp = 0; - return; + return; } /* If this is not the same locale as currently, set the new one up */ if (! PL_collation_name || strNE(PL_collation_name, newcoll)) { - ++PL_collation_ix; - Safefree(PL_collation_name); - PL_collation_name = stdize_locale(savepv(newcoll)); - PL_collation_standard = isNAME_C_OR_POSIX(newcoll); + ++PL_collation_ix; + Safefree(PL_collation_name); + PL_collation_name = stdize_locale(savepv(newcoll)); + PL_collation_standard = isNAME_C_OR_POSIX(newcoll); if (PL_collation_standard) { goto is_standard_collation; } @@ -1994,7 +1995,7 @@ S_new_collate(pTHX_ const char *newcoll) * get it right the first time to avoid wasted expensive string * transformations. */ - { + { /* We use the string below to find how long the tranformation of it * is. Almost all locales are supersets of ASCII, or at least the * ASCII letters. We use all of them, half upper half lower, @@ -2110,7 +2111,7 @@ S_new_collate(pTHX_ const char *newcoll) } # endif - } + } } #endif /* USE_LOCALE_COLLATE */ @@ -2619,8 +2620,7 @@ S_my_nl_langinfo(const int item, bool toggle) #if defined(HAS_NL_LANGINFO) /* nl_langinfo() is available. */ # if ! defined(HAS_THREAD_SAFE_NL_LANGINFO_L) \ - || ! defined(HAS_POSIX_2008_LOCALE) \ - || ! defined(DUPLOCALE) + || ! defined(HAS_POSIX_2008_LOCALE) /* Here, use plain nl_langinfo(), switching to the underlying LC_NUMERIC * for those items dependent on it. This must be copied to a buffer before @@ -2634,18 +2634,16 @@ S_my_nl_langinfo(const int item, bool toggle) STORE_LC_NUMERIC_FORCE_TO_UNDERLYING(); } - LOCALE_LOCK; /* Prevent interference from another thread executing - this code section (the only call to nl_langinfo in - the core) */ - + /* Prevent interference from another thread executing this code + * section. */ + NL_LANGINFO_LOCK; /* Copy to a per-thread buffer, which is also one that won't be * destroyed by a subsequent setlocale(), such as the * RESTORE_LC_NUMERIC may do just below. */ retval = save_to_buffer(nl_langinfo(item), &PL_langinfo_buf, &PL_langinfo_bufsize, 0); - - LOCALE_UNLOCK; + NL_LANGINFO_UNLOCK; if (toggle) { RESTORE_LC_NUMERIC(); @@ -2819,8 +2817,8 @@ S_my_nl_langinfo(const int item, bool toggle) /* We don't bother with localeconv_l() because any system that * has it is likely to also have nl_langinfo() */ - LOCALE_LOCK_V; /* Prevent interference with other threads - using localeconv() */ + LOCALECONV_LOCK; /* Prevent interference with other threads + using localeconv() */ # ifdef TS_W32_BROKEN_LOCALECONV @@ -2847,7 +2845,7 @@ S_my_nl_langinfo(const int item, bool toggle) || ! lc->currency_symbol || strEQ("", lc->currency_symbol)) { - LOCALE_UNLOCK_V; + LOCALECONV_UNLOCK; return ""; } @@ -2877,7 +2875,7 @@ S_my_nl_langinfo(const int item, bool toggle) # endif - LOCALE_UNLOCK_V; + LOCALECONV_UNLOCK; break; # ifdef TS_W32_BROKEN_LOCALECONV @@ -2950,8 +2948,8 @@ S_my_nl_langinfo(const int item, bool toggle) STORE_LC_NUMERIC_FORCE_TO_UNDERLYING(); } - LOCALE_LOCK_V; /* Prevent interference with other threads - using localeconv() */ + LOCALECONV_LOCK; /* Prevent interference with other threads + using localeconv() */ # ifdef TS_W32_BROKEN_LOCALECONV @@ -3003,7 +3001,7 @@ S_my_nl_langinfo(const int item, bool toggle) # endif - LOCALE_UNLOCK_V; + LOCALECONV_UNLOCK; if (toggle) { RESTORE_LC_NUMERIC(); @@ -3041,8 +3039,6 @@ S_my_nl_langinfo(const int item, bool toggle) case MON_5: case MON_6: case MON_7: case MON_8: case MON_9: case MON_10: case MON_11: case MON_12: - LOCALE_LOCK; - init_tm(&tm); /* Precaution against core dumps */ tm.tm_sec = 30; tm.tm_min = 30; @@ -3052,7 +3048,6 @@ S_my_nl_langinfo(const int item, bool toggle) tm.tm_mon = 0; switch (item) { default: - LOCALE_UNLOCK; Perl_croak(aTHX_ "panic: %s: %d: switch case: %d problem", __FILE__, __LINE__, item); @@ -3228,8 +3223,6 @@ S_my_nl_langinfo(const int item, bool toggle) * wday was chosen because its range is all a single digit. * Things like tm_sec have two digits as the minimum: '00' */ - LOCALE_UNLOCK; - retval = PL_langinfo_buf; /* If to return the format, not the value, overwrite the buffer @@ -3374,8 +3367,8 @@ Perl_init_i18nl10n(pTHX_ int printwarn) DEBUG_INITIALIZATION_set(cBOOL(PerlEnv_getenv("PERL_DEBUG_LOCALE_INIT"))); # define DEBUG_LOCALE_INIT(category, locale, result) \ - STMT_START { \ - if (debug_initialization) { \ + STMT_START { \ + if (debug_initialization) { \ PerlIO_printf(Perl_debug_log, \ "%s:%d: %s\n", \ __FILE__, __LINE__, \ @@ -3383,7 +3376,7 @@ Perl_init_i18nl10n(pTHX_ int printwarn) locale, \ result)); \ } \ - } STMT_END + } STMT_END /* Make sure the parallel arrays are properly set up */ # ifdef USE_LOCALE_NUMERIC @@ -3928,10 +3921,10 @@ Perl_init_i18nl10n(pTHX_ int printwarn) This is an alternative to using the -C command line switch (the -C if present will override this). */ { - const char *p = PerlEnv_getenv("PERL_UNICODE"); - PL_unicode = p ? parse_unicode_opts(&p) : 0; - if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG) - PL_utf8cache = -1; + const char *p = PerlEnv_getenv("PERL_UNICODE"); + PL_unicode = p ? parse_unicode_opts(&p) : 0; + if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG) + PL_utf8cache = -1; } # endif @@ -4294,7 +4287,7 @@ Perl__mem_collxfrm(pTHX_ const char *input_string, if (UNLIKELY(! xbuf)) { DEBUG_L(PerlIO_printf(Perl_debug_log, "_mem_collxfrm: Couldn't malloc %zu bytes\n", xAlloc)); - goto bad; + goto bad; } /* Store the collation id */ @@ -4844,12 +4837,12 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category) # else - LOCALE_LOCK; + MBTOWC_LOCK; PERL_UNUSED_RESULT(mbtowc(&wc, NULL, 0));/* Reset any shift state */ SETERRNO(0, 0); len = mbtowc(&wc, STR_WITH_LEN(REPLACEMENT_CHARACTER_UTF8)); SAVE_ERRNO; - LOCALE_UNLOCK; + MBTOWC_UNLOCK; # endif @@ -5302,8 +5295,7 @@ Perl_my_strerror(pTHX_ const int errnum) } # elif defined(USE_POSIX_2008_LOCALE) \ - && defined(HAS_STRERROR_L) \ - && defined(HAS_DUPLOCALE) + && defined(HAS_STRERROR_L) /* This function is also trivial if we don't have to worry about thread * safety and have strerror_l(), as it handles the switch of locales so we @@ -5358,13 +5350,14 @@ Perl_my_strerror(pTHX_ const int errnum) * same code at the same time. (On thread-safe perls, the LOCK is a * no-op.) Since this is the only place in core that changes LC_MESSAGES * (unless the user has called setlocale(), this works to prevent races. */ - LOCALE_LOCK; + SETLOCALE_LOCK; DEBUG_Lv(PerlIO_printf(Perl_debug_log, "my_strerror called with errnum %d\n", errnum)); if (! within_locale_scope) { save_locale = do_setlocale_c(LC_MESSAGES, NULL); if (! save_locale) { + SETLOCALE_UNLOCK; Perl_croak(aTHX_ "panic: %s: %d: Could not find current LC_MESSAGES locale," " errno=%d\n", __FILE__, __LINE__, errno); @@ -5378,7 +5371,19 @@ Perl_my_strerror(pTHX_ const int errnum) /* The setlocale() just below likely will zap 'save_locale', so * create a copy. */ save_locale = savepv(save_locale); - do_setlocale_c(LC_MESSAGES, "C"); + if (! do_setlocale_c(LC_MESSAGES, "C")) { + + /* If, for some reason, the locale change failed, we + * soldier on as best as possible under the circumstances, + * using the current locale, and clear save_locale, so we + * don't try to change back. On z/0S, all setlocale() + * calls fail after you've created a thread. This is their + * way of making sure the entire process is always a single + * locale. This means that 'use locale' is always in place + * for messages under these circumstances. */ + Safefree(save_locale); + save_locale = NULL; + } } } } /* end of ! within_locale_scope */ @@ -5394,15 +5399,16 @@ Perl_my_strerror(pTHX_ const int errnum) if (! within_locale_scope) { if (save_locale && ! locale_is_C) { if (! do_setlocale_c(LC_MESSAGES, save_locale)) { + SETLOCALE_UNLOCK; Perl_croak(aTHX_ - "panic: %s: %d: setlocale restore failed, errno=%d\n", - __FILE__, __LINE__, errno); + "panic: %s: %d: setlocale restore to '%s' failed, errno=%d\n", + __FILE__, __LINE__, save_locale, errno); } Safefree(save_locale); } } - LOCALE_UNLOCK; + SETLOCALE_UNLOCK; # endif /* End of doesn't have strerror_l */ # ifdef DEBUGGING diff --git a/make_ext.pl b/make_ext.pl index ce3debd60397..ba507c8abc33 100644 --- a/make_ext.pl +++ b/make_ext.pl @@ -36,10 +36,6 @@ # # make_ext.pl "MAKE=nmake -nologo" --dir=..\ext --target=clean # -# make_ext.pl MAKE=dmake --dir=..\ext -# -# make_ext.pl MAKE=dmake --dir=..\ext --target=clean -# # Will skip building extensions which are marked with an '!' char. # Mostly because they still not ported to specified platform. # @@ -659,6 +655,7 @@ sub just_pm_to_blib { |README |README\.patching |README\.release + |\.gitignore )\z/xi; # /i to deal with case munging systems. if ($leaf eq "$last.pm") { ++$has_top; diff --git a/makedef.pl b/makedef.pl index 9af199d9a285..94ff2f54d18a 100644 --- a/makedef.pl +++ b/makedef.pl @@ -455,9 +455,6 @@ sub readvar { if ($define{USE_THREAD_SAFE_LOCALE}) { ++$skip{PL_lc_numeric_mutex}; ++$skip{PL_lc_numeric_mutex_depth}; - if (! $define{TS_W32_BROKEN_LOCALECONV}) { - ++$skip{PL_locale_mutex}; - } } unless ($define{'USE_DTRACE'}) { @@ -489,6 +486,10 @@ sub readvar { ++$skip{PL_memory_debug_header}; } +unless ($define{'PERL_MEM_LOG'}) { + ++$skip{PL_mem_log}; +} + unless ($define{'MULTIPLICITY'}) { ++$skip{$_} foreach qw( PL_interp_size @@ -910,6 +911,9 @@ sub readvar { win32_puts win32_getchar win32_putchar + win32_symlink + win32_lstat + win32_readlink )); } elsif ($ARGS{PLATFORM} eq 'vms') { diff --git a/malloc.c b/malloc.c index 01e84bfc19c4..f24fa248261a 100644 --- a/malloc.c +++ b/malloc.c @@ -149,13 +149,13 @@ # Do not allow configuration of runtime options via $ENV{PERL_MALLOC_OPT} NO_PERL_MALLOC_ENV undef - [The variable consists of ;-separated parts of the form CODE=VALUE - with 1-character codes F, M, f, A, P, G, d, a, c for runtime - configuration of FIRST_SBRK, MIN_SBRK, MIN_SBRK_FRAC1000, - SBRK_ALLOW_FAILURES, SBRK_FAILURE_PRICE, sbrk_goodness, - filldead, fillalive, fillcheck. The last 3 are for DEBUGGING - build, and allow switching the tests for free()ed memory read, - uninit memory reads, and free()ed memory write.] + [The variable consists of ;-separated parts of the form CODE=VALUE + with 1-character codes F, M, f, A, P, G, d, a, c for runtime + configuration of FIRST_SBRK, MIN_SBRK, MIN_SBRK_FRAC1000, + SBRK_ALLOW_FAILURES, SBRK_FAILURE_PRICE, sbrk_goodness, + filldead, fillalive, fillcheck. The last 3 are for DEBUGGING + build, and allow switching the tests for free()ed memory read, + uninit memory reads, and free()ed memory write.] This implementation assumes that calling PerlIO_printf() does not result in any memory allocation calls (used during a panic). @@ -281,14 +281,14 @@ # undef DEBUG_m # define DEBUG_m(a) \ STMT_START { \ - if (PERL_MAYBE_ALIVE && PERL_GET_THX) { \ - dTHX; \ - if (DEBUG_m_TEST) { \ - PL_debug &= ~DEBUG_m_FLAG; \ - a; \ - PL_debug |= DEBUG_m_FLAG; \ - } \ - } \ + if (PERL_MAYBE_ALIVE && PERL_GET_THX) { \ + dTHX; \ + if (DEBUG_m_TEST) { \ + PL_debug &= ~DEBUG_m_FLAG; \ + a; \ + PL_debug |= DEBUG_m_FLAG; \ + } \ + } \ } STMT_END #endif @@ -389,27 +389,27 @@ * plus the range checking words, and the header word MINUS ONE. */ union overhead { - union overhead *ov_next; /* when free */ + union overhead *ov_next; /* when free */ #if MEM_ALIGNBYTES > 4 - double strut; /* alignment problems */ + double strut; /* alignment problems */ # if MEM_ALIGNBYTES > 8 - char sstrut[MEM_ALIGNBYTES]; /* for the sizing */ + char sstrut[MEM_ALIGNBYTES]; /* for the sizing */ # endif #endif - struct { + struct { /* * Keep the ovu_index and ovu_magic in this order, having a char * field first gives alignment indigestion in some systems, such as * MachTen. */ - u_char ovu_index; /* bucket # */ - u_char ovu_magic; /* magic number */ + u_char ovu_index; /* bucket # */ + u_char ovu_magic; /* magic number */ #ifdef RCHECK - /* Subtract one to fit into u_short for an extra bucket */ - u_short ovu_size; /* block size (requested + overhead - 1) */ - u_int ovu_rmagic; /* range magic number */ + /* Subtract one to fit into u_short for an extra bucket */ + u_short ovu_size; /* block size (requested + overhead - 1) */ + u_int ovu_rmagic; /* range magic number */ #endif - } ovu; + } ovu; #define ov_magic ovu.ovu_magic #define ov_index ovu.ovu_index #define ov_size ovu.ovu_size @@ -466,10 +466,10 @@ static const u_short buck_size[MAX_BUCKET_BY_TABLE + 1] = }; # define BUCKET_SIZE_NO_SURPLUS(i) ((i) % 2 ? buck_size[i] : (1 << ((i) >> BUCKET_POW2_SHIFT))) # define BUCKET_SIZE_REAL(i) ((i) <= MAX_BUCKET_BY_TABLE \ - ? ((size_t)buck_size[i]) \ - : ((((size_t)1) << ((i) >> BUCKET_POW2_SHIFT)) \ - - MEM_OVERHEAD(i) \ - + POW2_OPTIMIZE_SURPLUS(i))) + ? ((size_t)buck_size[i]) \ + : ((((size_t)1) << ((i) >> BUCKET_POW2_SHIFT)) \ + - MEM_OVERHEAD(i) \ + + POW2_OPTIMIZE_SURPLUS(i))) #else # define BUCKET_SIZE_NO_SURPLUS(i) (((size_t)1) << ((i) >> BUCKET_POW2_SHIFT)) # define BUCKET_SIZE(i) (BUCKET_SIZE_NO_SURPLUS(i) + POW2_OPTIMIZE_SURPLUS(i)) @@ -602,9 +602,9 @@ static const u_short buck_size[MAX_BUCKET_BY_TABLE + 1] = # define OV_INDEXp(block) (INT2PTR(u_char*,TWOK_MASKED(block))) # define OV_INDEX(block) (*OV_INDEXp(block)) # define OV_MAGIC(block,bucket) (*(OV_INDEXp(block) + \ - (TWOK_SHIFT(block)>> \ - (bucket>>BUCKET_POW2_SHIFT)) + \ - (bucket >= MIN_NEEDS_SHIFT ? 1 : 0))) + (TWOK_SHIFT(block)>> \ + (bucket>>BUCKET_POW2_SHIFT)) + \ + (bucket >= MIN_NEEDS_SHIFT ? 1 : 0))) /* A bucket can have a shift smaller than it size, we need to shift its magic number so it will not overwrite index: */ # ifdef BUCKETS_ROOT2 @@ -618,8 +618,8 @@ static const u_short buck_size[MAX_BUCKET_BY_TABLE + 1] = #ifdef IGNORE_SMALL_BAD_FREE #define FIRST_BUCKET_WITH_CHECK (6 * BUCKETS_PER_POW2) /* 64 */ # define N_BLKS(bucket) ( (bucket) < FIRST_BUCKET_WITH_CHECK \ - ? nBIT_MASK(LOG_OF_MIN_ARENA)/BUCKET_SIZE_NO_SURPLUS(bucket) \ - : n_blks[bucket] ) + ? nBIT_MASK(LOG_OF_MIN_ARENA)/BUCKET_SIZE_NO_SURPLUS(bucket) \ + : n_blks[bucket] ) #else # define N_BLKS(bucket) n_blks[bucket] #endif @@ -640,9 +640,9 @@ static const u_short n_blks[LOG_OF_MIN_ARENA * BUCKETS_PER_POW2] = /* Shift of the first bucket with the given ordinal inside 2K chunk. */ #ifdef IGNORE_SMALL_BAD_FREE # define BLK_SHIFT(bucket) ( (bucket) < FIRST_BUCKET_WITH_CHECK \ - ? ((1<>LOG_OF_MIN_ARENA) + 1)<= BIG_SIZE - && (!emergency_buffer_last_req || - (size < (MEM_SIZE)emergency_buffer_last_req))) { - /* Give the possibility to recover, but avoid an infinite cycle. */ - MALLOC_UNLOCK; - emergency_buffer_last_req = size; - emergency_sbrk_croak("Out of memory during \"large\" request for %" UVuf + && (!emergency_buffer_last_req || + (size < (MEM_SIZE)emergency_buffer_last_req))) { + /* Give the possibility to recover, but avoid an infinite cycle. */ + MALLOC_UNLOCK; + emergency_buffer_last_req = size; + emergency_sbrk_croak("Out of memory during \"large\" request for %" UVuf " bytes, total sbrk() is %" UVuf " bytes", (UV)size, (UV)(goodsbrk + sbrk_slack)); } if ((MEM_SIZE)emergency_buffer_size >= rsize) { - char *old = emergency_buffer; - - emergency_buffer_size -= rsize; - emergency_buffer += rsize; - return old; + char *old = emergency_buffer; + + emergency_buffer_size -= rsize; + emergency_buffer += rsize; + return old; } else { - /* First offense, give a possibility to recover by dieing. */ - /* No malloc involved here: */ - IV Size; - char *pv = GET_EMERGENCY_BUFFER(&Size); - int have = 0; - - if (emergency_buffer_size) { - add_to_chain(emergency_buffer, emergency_buffer_size, 0); - emergency_buffer_size = 0; - emergency_buffer = NULL; - have = 1; - } - - if (!pv) - pv = PERL_GET_EMERGENCY_BUFFER(&Size); - if (!pv) { - if (have) - goto do_croak; - return (char *)-1; /* Now die die die... */ - } - - /* Check alignment: */ - if (PTR2UV(pv) & (NEEDED_ALIGNMENT - 1)) { - dTHX; - - PerlIO_puts(PerlIO_stderr(),"Bad alignment of $^M!\n"); - return (char *)-1; /* die die die */ - } - - emergency_buffer = pv; - emergency_buffer_size = Size; + /* First offense, give a possibility to recover by dieing. */ + /* No malloc involved here: */ + IV Size; + char *pv = GET_EMERGENCY_BUFFER(&Size); + int have = 0; + + if (emergency_buffer_size) { + add_to_chain(emergency_buffer, emergency_buffer_size, 0); + emergency_buffer_size = 0; + emergency_buffer = NULL; + have = 1; + } + + if (!pv) + pv = PERL_GET_EMERGENCY_BUFFER(&Size); + if (!pv) { + if (have) + goto do_croak; + return (char *)-1; /* Now die die die... */ + } + + /* Check alignment: */ + if (PTR2UV(pv) & (NEEDED_ALIGNMENT - 1)) { + dTHX; + + PerlIO_puts(PerlIO_stderr(),"Bad alignment of $^M!\n"); + return (char *)-1; /* die die die */ + } + + emergency_buffer = pv; + emergency_buffer_size = Size; } do_croak: MALLOC_UNLOCK; @@ -1066,32 +1066,32 @@ botch(const char *diag, const char *s, const char *file, int line) { dTHX; if (!(PERL_MAYBE_ALIVE && PERL_GET_THX)) - goto do_write; + goto do_write; else { - if (PerlIO_printf(PerlIO_stderr(), - "assertion botched (%s?): %s %s:%d\n", - diag, s, file, line) != 0) { - do_write: /* Can be initializing interpreter */ - MYMALLOC_WRITE2STDERR("assertion botched ("); - MYMALLOC_WRITE2STDERR(diag); - MYMALLOC_WRITE2STDERR("?): "); - MYMALLOC_WRITE2STDERR(s); - MYMALLOC_WRITE2STDERR(" ("); - MYMALLOC_WRITE2STDERR(file); - MYMALLOC_WRITE2STDERR(":"); - { - char linebuf[10]; - char *s = linebuf + sizeof(linebuf) - 1; - int n = line; - *s = 0; - do { - *--s = '0' + (n % 10); - } while (n /= 10); - MYMALLOC_WRITE2STDERR(s); - } - MYMALLOC_WRITE2STDERR(")\n"); - } - PerlProc_abort(); + if (PerlIO_printf(PerlIO_stderr(), + "assertion botched (%s?): %s %s:%d\n", + diag, s, file, line) != 0) { + do_write: /* Can be initializing interpreter */ + MYMALLOC_WRITE2STDERR("assertion botched ("); + MYMALLOC_WRITE2STDERR(diag); + MYMALLOC_WRITE2STDERR("?): "); + MYMALLOC_WRITE2STDERR(s); + MYMALLOC_WRITE2STDERR(" ("); + MYMALLOC_WRITE2STDERR(file); + MYMALLOC_WRITE2STDERR(":"); + { + char linebuf[10]; + char *s = linebuf + sizeof(linebuf) - 1; + int n = line; + *s = 0; + do { + *--s = '0' + (n % 10); + } while (n /= 10); + MYMALLOC_WRITE2STDERR(s); + } + MYMALLOC_WRITE2STDERR(")\n"); + } + PerlProc_abort(); } } #else @@ -1108,19 +1108,19 @@ fill_pat_4bytes(unsigned char *s, size_t nbytes, const unsigned char *fill) const long lfill = *(long*)fill; if (PTR2UV(s) & (sizeof(long)-1)) { /* Align the pattern */ - int shift = sizeof(long) - (PTR2UV(s) & (sizeof(long)-1)); - unsigned const char *f = fill + sizeof(long) - shift; - unsigned char *e1 = s + shift; + int shift = sizeof(long) - (PTR2UV(s) & (sizeof(long)-1)); + unsigned const char *f = fill + sizeof(long) - shift; + unsigned char *e1 = s + shift; - while (s < e1) - *s++ = *f++; + while (s < e1) + *s++ = *f++; } lp = (long*)s; while ((unsigned char*)(lp + 1) <= e) - *lp++ = lfill; + *lp++ = lfill; s = (unsigned char*)lp; while (s < e) - *s++ = *fill++; + *s++ = *fill++; } /* Just malloc()ed */ static const unsigned char fill_feedadad[] = @@ -1131,9 +1131,9 @@ static const unsigned char fill_deadbeef[] = {0xDE, 0xAD, 0xBE, 0xEF, 0xDE, 0xAD, 0xBE, 0xEF, 0xDE, 0xAD, 0xBE, 0xEF, 0xDE, 0xAD, 0xBE, 0xEF}; # define FILL_DEADBEEF(s, n) \ - (void)(FILL_DEAD? (fill_pat_4bytes((s), (n), fill_deadbeef), 0) : 0) + (void)(FILL_DEAD? (fill_pat_4bytes((s), (n), fill_deadbeef), 0) : 0) # define FILL_FEEDADAD(s, n) \ - (void)(FILL_ALIVE? (fill_pat_4bytes((s), (n), fill_feedadad), 0) : 0) + (void)(FILL_ALIVE? (fill_pat_4bytes((s), (n), fill_feedadad), 0) : 0) #else # define FILL_DEADBEEF(s, n) ((void)0) # define FILL_FEEDADAD(s, n) ((void)0) @@ -1149,27 +1149,27 @@ cmp_pat_4bytes(unsigned char *s, size_t nbytes, const unsigned char *fill) const long lfill = *(long*)fill; if (PTR2UV(s) & (sizeof(long)-1)) { /* Align the pattern */ - int shift = sizeof(long) - (PTR2UV(s) & (sizeof(long)-1)); - unsigned const char *f = fill + sizeof(long) - shift; - unsigned char *e1 = s + shift; + int shift = sizeof(long) - (PTR2UV(s) & (sizeof(long)-1)); + unsigned const char *f = fill + sizeof(long) - shift; + unsigned char *e1 = s + shift; - while (s < e1) - if (*s++ != *f++) - return 1; + while (s < e1) + if (*s++ != *f++) + return 1; } lp = (long*)s; while ((unsigned char*)(lp + 1) <= e) - if (*lp++ != lfill) - return 1; + if (*lp++ != lfill) + return 1; s = (unsigned char*)lp; while (s < e) - if (*s++ != *fill++) - return 1; + if (*s++ != *fill++) + return 1; return 0; } # define FILLCHECK_DEADBEEF(s, n) \ - ASSERT(!FILL_CHECK || !cmp_pat_4bytes(s, n, fill_deadbeef), \ - "free()ed/realloc()ed-away memory was overwritten") + ASSERT(!FILL_CHECK || !cmp_pat_4bytes(s, n, fill_deadbeef), \ + "free()ed/realloc()ed-away memory was overwritten") #else # define FILLCHECK_DEADBEEF(s, n) ((void)0) #endif @@ -1177,49 +1177,49 @@ cmp_pat_4bytes(unsigned char *s, size_t nbytes, const unsigned char *fill) STATIC int S_adjust_size_and_find_bucket(size_t *nbytes_p) { - MEM_SIZE shiftr; - int bucket; - size_t nbytes; + MEM_SIZE shiftr; + int bucket; + size_t nbytes; - PERL_ARGS_ASSERT_ADJUST_SIZE_AND_FIND_BUCKET; + PERL_ARGS_ASSERT_ADJUST_SIZE_AND_FIND_BUCKET; - nbytes = *nbytes_p; + nbytes = *nbytes_p; - /* - * Convert amount of memory requested into - * closest block size stored in hash buckets - * which satisfies request. Account for - * space used per block for accounting. - */ + /* + * Convert amount of memory requested into + * closest block size stored in hash buckets + * which satisfies request. Account for + * space used per block for accounting. + */ #ifdef PACK_MALLOC # ifdef SMALL_BUCKET_VIA_TABLE - if (nbytes == 0) - bucket = MIN_BUCKET; - else if (nbytes <= SIZE_TABLE_MAX) { - bucket = bucket_of[(nbytes - 1) >> BUCKET_TABLE_SHIFT]; - } else + if (nbytes == 0) + bucket = MIN_BUCKET; + else if (nbytes <= SIZE_TABLE_MAX) { + bucket = bucket_of[(nbytes - 1) >> BUCKET_TABLE_SHIFT]; + } else # else - if (nbytes == 0) - nbytes = 1; - if (nbytes <= MAX_POW2_ALGO) goto do_shifts; - else + if (nbytes == 0) + nbytes = 1; + if (nbytes <= MAX_POW2_ALGO) goto do_shifts; + else # endif #endif - { - POW2_OPTIMIZE_ADJUST(nbytes); - nbytes += M_OVERHEAD; - nbytes = (nbytes + 3) &~ 3; + { + POW2_OPTIMIZE_ADJUST(nbytes); + nbytes += M_OVERHEAD; + nbytes = (nbytes + 3) &~ 3; #if defined(PACK_MALLOC) && !defined(SMALL_BUCKET_VIA_TABLE) - do_shifts: + do_shifts: #endif - shiftr = (nbytes - 1) >> START_SHIFT; - bucket = START_SHIFTS_BUCKET; - /* apart from this loop, this is O(1) */ - while (shiftr >>= 1) - bucket += BUCKETS_PER_POW2; - } - *nbytes_p = nbytes; - return bucket; + shiftr = (nbytes - 1) >> START_SHIFT; + bucket = START_SHIFTS_BUCKET; + /* apart from this loop, this is O(1) */ + while (shiftr >>= 1) + bucket += BUCKETS_PER_POW2; + } + *nbytes_p = nbytes; + return bucket; } /* @@ -1234,10 +1234,10 @@ These have the same interfaces as the C lib ones, so are considered documented Malloc_t Perl_malloc(size_t nbytes) { - union overhead *p; - int bucket; + union overhead *p; + int bucket; #if defined(DEBUGGING) || defined(RCHECK) - MEM_SIZE size = nbytes; + MEM_SIZE size = nbytes; #endif /* A structure that has more than PTRDIFF_MAX bytes is unfortunately @@ -1253,119 +1253,119 @@ Perl_malloc(size_t nbytes) return NULL; } - BARK_64K_LIMIT("Allocation",nbytes,nbytes); + BARK_64K_LIMIT("Allocation",nbytes,nbytes); #ifdef DEBUGGING - if ((long)nbytes < 0) - croak("%s", "panic: malloc"); + if ((long)nbytes < 0) + croak("%s", "panic: malloc"); #endif - bucket = adjust_size_and_find_bucket(&nbytes); - MALLOC_LOCK; - /* - * If nothing in hash bucket right now, - * request more memory from the system. - */ - if (nextf[bucket] == NULL) - morecore(bucket); - if ((p = nextf[bucket]) == NULL) { - MALLOC_UNLOCK; - { - dTHX; - if (!PL_nomemok) { + bucket = adjust_size_and_find_bucket(&nbytes); + MALLOC_LOCK; + /* + * If nothing in hash bucket right now, + * request more memory from the system. + */ + if (nextf[bucket] == NULL) + morecore(bucket); + if ((p = nextf[bucket]) == NULL) { + MALLOC_UNLOCK; + { + dTHX; + if (!PL_nomemok) { #if defined(PLAIN_MALLOC) && defined(NO_FANCY_MALLOC) - MYMALLOC_WRITE2STDERR("Out of memory!\n"); + MYMALLOC_WRITE2STDERR("Out of memory!\n"); #else - char buff[80]; - char *eb = buff + sizeof(buff) - 1; - char *s = eb; - size_t n = nbytes; + char buff[80]; + char *eb = buff + sizeof(buff) - 1; + char *s = eb; + size_t n = nbytes; - MYMALLOC_WRITE2STDERR("Out of memory during request for "); + MYMALLOC_WRITE2STDERR("Out of memory during request for "); #if defined(DEBUGGING) || defined(RCHECK) - n = size; + n = size; #endif - *s = 0; - do { - *--s = '0' + (n % 10); - } while (n /= 10); - MYMALLOC_WRITE2STDERR(s); - MYMALLOC_WRITE2STDERR(" bytes, total sbrk() is "); - s = eb; - n = goodsbrk + sbrk_slack; - do { - *--s = '0' + (n % 10); - } while (n /= 10); - MYMALLOC_WRITE2STDERR(s); - MYMALLOC_WRITE2STDERR(" bytes!\n"); + *s = 0; + do { + *--s = '0' + (n % 10); + } while (n /= 10); + MYMALLOC_WRITE2STDERR(s); + MYMALLOC_WRITE2STDERR(" bytes, total sbrk() is "); + s = eb; + n = goodsbrk + sbrk_slack; + do { + *--s = '0' + (n % 10); + } while (n /= 10); + MYMALLOC_WRITE2STDERR(s); + MYMALLOC_WRITE2STDERR(" bytes!\n"); #endif /* defined(PLAIN_MALLOC) && defined(NO_FANCY_MALLOC) */ - my_exit(1); - } - } - return (NULL); - } + my_exit(1); + } + } + return (NULL); + } - /* remove from linked list */ + /* remove from linked list */ #ifdef DEBUGGING - if ( (PTR2UV(p) & (MEM_ALIGNBYTES - 1)) - /* Can't get this low */ - || (p && PTR2UV(p) < (1<ov_next) & (MEM_ALIGNBYTES - 1)) - || (p->ov_next && PTR2UV(p->ov_next) < (1<ov_next), PTR2UV(p)); - } + if ( (PTR2UV(p) & (MEM_ALIGNBYTES - 1)) + /* Can't get this low */ + || (p && PTR2UV(p) < (1<ov_next) & (MEM_ALIGNBYTES - 1)) + || (p->ov_next && PTR2UV(p->ov_next) < (1<ov_next), PTR2UV(p)); + } #endif - nextf[bucket] = p->ov_next; + nextf[bucket] = p->ov_next; - MALLOC_UNLOCK; + MALLOC_UNLOCK; - DEBUG_m(PerlIO_printf(Perl_debug_log, - "%p: (%05lu) malloc %ld bytes\n", - (Malloc_t)(p + CHUNK_SHIFT), + DEBUG_m(PerlIO_printf(Perl_debug_log, + "%p: (%05lu) malloc %ld bytes\n", + (Malloc_t)(p + CHUNK_SHIFT), (unsigned long)(PL_an++), - (long)size)); + (long)size)); - FILLCHECK_DEADBEEF((unsigned char*)(p + CHUNK_SHIFT), - BUCKET_SIZE_REAL(bucket) + RMAGIC_SZ); + FILLCHECK_DEADBEEF((unsigned char*)(p + CHUNK_SHIFT), + BUCKET_SIZE_REAL(bucket) + RMAGIC_SZ); #ifdef IGNORE_SMALL_BAD_FREE - if (bucket >= FIRST_BUCKET_WITH_CHECK) + if (bucket >= FIRST_BUCKET_WITH_CHECK) #endif - OV_MAGIC(p, bucket) = MAGIC; + OV_MAGIC(p, bucket) = MAGIC; #ifndef PACK_MALLOC - OV_INDEX(p) = bucket; + OV_INDEX(p) = bucket; #endif #ifdef RCHECK - /* - * Record allocated size of block and - * bound space with magic numbers. - */ - p->ov_rmagic = RMAGIC; - if (bucket <= MAX_SHORT_BUCKET) { - int i; - - nbytes = size + M_OVERHEAD; - p->ov_size = nbytes - 1; - if ((i = nbytes & (RMAGIC_SZ-1))) { - i = RMAGIC_SZ - i; - while (i--) /* nbytes - RMAGIC_SZ is end of alloced area */ - ((caddr_t)p + nbytes - RMAGIC_SZ)[i] = RMAGIC_C; - } - /* Same at RMAGIC_SZ-aligned RMAGIC */ - nbytes = (nbytes + RMAGIC_SZ - 1) & ~(RMAGIC_SZ - 1); - ((u_int *)((caddr_t)p + nbytes))[-1] = RMAGIC; - } - FILL_FEEDADAD((unsigned char *)(p + CHUNK_SHIFT), size); + /* + * Record allocated size of block and + * bound space with magic numbers. + */ + p->ov_rmagic = RMAGIC; + if (bucket <= MAX_SHORT_BUCKET) { + int i; + + nbytes = size + M_OVERHEAD; + p->ov_size = nbytes - 1; + if ((i = nbytes & (RMAGIC_SZ-1))) { + i = RMAGIC_SZ - i; + while (i--) /* nbytes - RMAGIC_SZ is end of alloced area */ + ((caddr_t)p + nbytes - RMAGIC_SZ)[i] = RMAGIC_C; + } + /* Same at RMAGIC_SZ-aligned RMAGIC */ + nbytes = (nbytes + RMAGIC_SZ - 1) & ~(RMAGIC_SZ - 1); + ((u_int *)((caddr_t)p + nbytes))[-1] = RMAGIC; + } + FILL_FEEDADAD((unsigned char *)(p + CHUNK_SHIFT), size); #endif - return ((Malloc_t)(p + CHUNK_SHIFT)); + return ((Malloc_t)(p + CHUNK_SHIFT)); } static char *last_sbrk_top; @@ -1393,33 +1393,33 @@ get_from_chain(MEM_SIZE size) long min_remain = LONG_MAX; while (elt) { - if (elt->size >= size) { - long remains = elt->size - size; - if (remains >= 0 && remains < min_remain) { - oldgoodp = oldp; - min_remain = remains; - } - if (remains == 0) { - break; - } - } - oldp = &( elt->next ); - elt = elt->next; + if (elt->size >= size) { + long remains = elt->size - size; + if (remains >= 0 && remains < min_remain) { + oldgoodp = oldp; + min_remain = remains; + } + if (remains == 0) { + break; + } + } + oldp = &( elt->next ); + elt = elt->next; } if (!oldgoodp) return NULL; if (min_remain) { - void *ret = *oldgoodp; - struct chunk_chain_s *next = (*oldgoodp)->next; - - *oldgoodp = (struct chunk_chain_s *)((char*)ret + size); - (*oldgoodp)->size = min_remain; - (*oldgoodp)->next = next; - return ret; + void *ret = *oldgoodp; + struct chunk_chain_s *next = (*oldgoodp)->next; + + *oldgoodp = (struct chunk_chain_s *)((char*)ret + size); + (*oldgoodp)->size = min_remain; + (*oldgoodp)->next = next; + return ret; } else { - void *ret = *oldgoodp; - *oldgoodp = (*oldgoodp)->next; - n_chunks--; - return ret; + void *ret = *oldgoodp; + *oldgoodp = (*oldgoodp)->next; + n_chunks--; + return ret; } } @@ -1442,26 +1442,26 @@ get_from_bigger_buckets(int bucket, MEM_SIZE size) int price = 1; static int bucketprice[NBUCKETS]; while (bucket <= max_bucket) { - /* We postpone stealing from bigger buckets until we want it - often enough. */ - if (nextf[bucket] && bucketprice[bucket]++ >= price) { - /* Steal it! */ - void *ret = (void*)(nextf[bucket] - 1 + CHUNK_SHIFT); - bucketprice[bucket] = 0; - if (((char*)nextf[bucket]) - M_OVERHEAD == last_op) { - last_op = NULL; /* Disable optimization */ - } - nextf[bucket] = nextf[bucket]->ov_next; + /* We postpone stealing from bigger buckets until we want it + often enough. */ + if (nextf[bucket] && bucketprice[bucket]++ >= price) { + /* Steal it! */ + void *ret = (void*)(nextf[bucket] - 1 + CHUNK_SHIFT); + bucketprice[bucket] = 0; + if (((char*)nextf[bucket]) - M_OVERHEAD == last_op) { + last_op = NULL; /* Disable optimization */ + } + nextf[bucket] = nextf[bucket]->ov_next; #ifdef DEBUGGING_MSTATS - nmalloc[bucket]--; - start_slack -= M_OVERHEAD; + nmalloc[bucket]--; + start_slack -= M_OVERHEAD; #endif - add_to_chain(ret, (BUCKET_SIZE_NO_SURPLUS(bucket) + - POW2_OPTIMIZE_SURPLUS(bucket)), - size); - return ret; - } - bucket++; + add_to_chain(ret, (BUCKET_SIZE_NO_SURPLUS(bucket) + + POW2_OPTIMIZE_SURPLUS(bucket)), + size); + return ret; + } + bucket++; } return NULL; } @@ -1477,134 +1477,134 @@ getpages(MEM_SIZE needed, int *nblksp, int bucket) MEM_SIZE slack = 0; if (sbrk_goodness > 0) { - if (!last_sbrk_top && require < (MEM_SIZE)FIRST_SBRK) - require = FIRST_SBRK; - else if (require < (MEM_SIZE)MIN_SBRK) require = MIN_SBRK; + if (!last_sbrk_top && require < (MEM_SIZE)FIRST_SBRK) + require = FIRST_SBRK; + else if (require < (MEM_SIZE)MIN_SBRK) require = MIN_SBRK; - if (require < (Size_t)(goodsbrk * MIN_SBRK_FRAC1000 / 1000)) - require = goodsbrk * MIN_SBRK_FRAC1000 / 1000; - require = ((require - 1 + MIN_SBRK) / MIN_SBRK) * MIN_SBRK; + if (require < (Size_t)(goodsbrk * MIN_SBRK_FRAC1000 / 1000)) + require = goodsbrk * MIN_SBRK_FRAC1000 / 1000; + require = ((require - 1 + MIN_SBRK) / MIN_SBRK) * MIN_SBRK; } else { - require = needed; - last_sbrk_top = 0; - sbrked_remains = 0; + require = needed; + last_sbrk_top = 0; + sbrked_remains = 0; } DEBUG_m(PerlIO_printf(Perl_debug_log, - "sbrk(%ld) for %ld-byte-long arena\n", - (long)require, (long) needed)); + "sbrk(%ld) for %ld-byte-long arena\n", + (long)require, (long) needed)); cp = (char *)sbrk(require); #ifdef DEBUGGING_MSTATS sbrks++; #endif if (cp == last_sbrk_top) { - /* Common case, anything is fine. */ - sbrk_goodness++; - ovp = (union overhead *) (cp - sbrked_remains); - last_op = cp - sbrked_remains; - sbrked_remains = require - (needed - sbrked_remains); + /* Common case, anything is fine. */ + sbrk_goodness++; + ovp = (union overhead *) (cp - sbrked_remains); + last_op = cp - sbrked_remains; + sbrked_remains = require - (needed - sbrked_remains); } else if (cp == (char *)-1) { /* no more room! */ - ovp = (union overhead *)emergency_sbrk(needed); - if (ovp == (union overhead *)-1) - return 0; - if (((char*)ovp) > last_op) { /* Cannot happen with current emergency_sbrk() */ - last_op = 0; - } - return ovp; + ovp = (union overhead *)emergency_sbrk(needed); + if (ovp == (union overhead *)-1) + return 0; + if (((char*)ovp) > last_op) { /* Cannot happen with current emergency_sbrk() */ + last_op = 0; + } + return ovp; } else { /* Non-continuous or first sbrk(). */ - long add = sbrked_remains; - char *newcp; - - if (sbrked_remains) { /* Put rest into chain, we - cannot use it right now. */ - add_to_chain((void*)(last_sbrk_top - sbrked_remains), - sbrked_remains, 0); - } - - /* Second, check alignment. */ - slack = 0; - - /* WANTED_ALIGNMENT may be more than NEEDED_ALIGNMENT, but this may - improve performance of memory access. */ - if (PTR2UV(cp) & (WANTED_ALIGNMENT - 1)) { /* Not aligned. */ - slack = WANTED_ALIGNMENT - (PTR2UV(cp) & (WANTED_ALIGNMENT - 1)); - add += slack; - } - - if (add) { - DEBUG_m(PerlIO_printf(Perl_debug_log, - "sbrk(%ld) to fix non-continuous/off-page sbrk:\n\t%ld for alignment,\t%ld were assumed to come from the tail of the previous sbrk\n", - (long)add, (long) slack, - (long) sbrked_remains)); - newcp = (char *)sbrk(add); + long add = sbrked_remains; + char *newcp; + + if (sbrked_remains) { /* Put rest into chain, we + cannot use it right now. */ + add_to_chain((void*)(last_sbrk_top - sbrked_remains), + sbrked_remains, 0); + } + + /* Second, check alignment. */ + slack = 0; + + /* WANTED_ALIGNMENT may be more than NEEDED_ALIGNMENT, but this may + improve performance of memory access. */ + if (PTR2UV(cp) & (WANTED_ALIGNMENT - 1)) { /* Not aligned. */ + slack = WANTED_ALIGNMENT - (PTR2UV(cp) & (WANTED_ALIGNMENT - 1)); + add += slack; + } + + if (add) { + DEBUG_m(PerlIO_printf(Perl_debug_log, + "sbrk(%ld) to fix non-continuous/off-page sbrk:\n\t%ld for alignment,\t%ld were assumed to come from the tail of the previous sbrk\n", + (long)add, (long) slack, + (long) sbrked_remains)); + newcp = (char *)sbrk(add); #if defined(DEBUGGING_MSTATS) - sbrks++; - sbrk_slack += add; + sbrks++; + sbrk_slack += add; #endif - if (newcp != cp + require) { - /* Too bad: even rounding sbrk() is not continuous.*/ - DEBUG_m(PerlIO_printf(Perl_debug_log, - "failed to fix bad sbrk()\n")); + if (newcp != cp + require) { + /* Too bad: even rounding sbrk() is not continuous.*/ + DEBUG_m(PerlIO_printf(Perl_debug_log, + "failed to fix bad sbrk()\n")); #ifdef PACK_MALLOC - if (slack) { - MALLOC_UNLOCK; - fatalcroak("panic: Off-page sbrk\n"); - } + if (slack) { + MALLOC_UNLOCK; + fatalcroak("panic: Off-page sbrk\n"); + } #endif - if (sbrked_remains) { - /* Try again. */ + if (sbrked_remains) { + /* Try again. */ #if defined(DEBUGGING_MSTATS) - sbrk_slack += require; + sbrk_slack += require; #endif - require = needed; - DEBUG_m(PerlIO_printf(Perl_debug_log, - "straight sbrk(%ld)\n", - (long)require)); - cp = (char *)sbrk(require); + require = needed; + DEBUG_m(PerlIO_printf(Perl_debug_log, + "straight sbrk(%ld)\n", + (long)require)); + cp = (char *)sbrk(require); #ifdef DEBUGGING_MSTATS - sbrks++; + sbrks++; #endif - if (cp == (char *)-1) - return 0; - } - sbrk_goodness = -1; /* Disable optimization! - Continue with not-aligned... */ - } else { - cp += slack; - require += sbrked_remains; - } - } - - if (last_sbrk_top) { - sbrk_goodness -= SBRK_FAILURE_PRICE; - } - - ovp = (union overhead *) cp; - /* - * Round up to minimum allocation size boundary - * and deduct from block count to reflect. - */ + if (cp == (char *)-1) + return 0; + } + sbrk_goodness = -1; /* Disable optimization! + Continue with not-aligned... */ + } else { + cp += slack; + require += sbrked_remains; + } + } + + if (last_sbrk_top) { + sbrk_goodness -= SBRK_FAILURE_PRICE; + } + + ovp = (union overhead *) cp; + /* + * Round up to minimum allocation size boundary + * and deduct from block count to reflect. + */ # if NEEDED_ALIGNMENT > MEM_ALIGNBYTES - if (PTR2UV(ovp) & (NEEDED_ALIGNMENT - 1)) - fatalcroak("Misalignment of sbrk()\n"); - else + if (PTR2UV(ovp) & (NEEDED_ALIGNMENT - 1)) + fatalcroak("Misalignment of sbrk()\n"); + else # endif - if (PTR2UV(ovp) & (MEM_ALIGNBYTES - 1)) { - DEBUG_m(PerlIO_printf(Perl_debug_log, - "fixing sbrk(): %d bytes off machine alignment\n", - (int)(PTR2UV(ovp) & (MEM_ALIGNBYTES - 1)))); - ovp = INT2PTR(union overhead *,(PTR2UV(ovp) + MEM_ALIGNBYTES) & - (MEM_ALIGNBYTES - 1)); - (*nblksp)--; + if (PTR2UV(ovp) & (MEM_ALIGNBYTES - 1)) { + DEBUG_m(PerlIO_printf(Perl_debug_log, + "fixing sbrk(): %d bytes off machine alignment\n", + (int)(PTR2UV(ovp) & (MEM_ALIGNBYTES - 1)))); + ovp = INT2PTR(union overhead *,(PTR2UV(ovp) + MEM_ALIGNBYTES) & + (MEM_ALIGNBYTES - 1)); + (*nblksp)--; # if defined(DEBUGGING_MSTATS) - /* This is only approx. if TWO_POT_OPTIMIZE: */ - sbrk_slack += (1 << (bucket >> BUCKET_POW2_SHIFT)); + /* This is only approx. if TWO_POT_OPTIMIZE: */ + sbrk_slack += (1 << (bucket >> BUCKET_POW2_SHIFT)); # endif - } - ; /* Finish "else" */ - sbrked_remains = require - needed; - last_op = cp; + } + ; /* Finish "else" */ + sbrked_remains = require - needed; + last_op = cp; } #if !defined(PLAIN_MALLOC) && !defined(NO_FANCY_MALLOC) emergency_buffer_last_req = 0; @@ -1620,40 +1620,40 @@ static int getpages_adjacent(MEM_SIZE require) { if (require <= sbrked_remains) { - sbrked_remains -= require; + sbrked_remains -= require; } else { - char *cp; + char *cp; - require -= sbrked_remains; - /* We do not try to optimize sbrks here, we go for place. */ - cp = (char*) sbrk(require); + require -= sbrked_remains; + /* We do not try to optimize sbrks here, we go for place. */ + cp = (char*) sbrk(require); #ifdef DEBUGGING_MSTATS - sbrks++; - goodsbrk += require; + sbrks++; + goodsbrk += require; #endif - if (cp == last_sbrk_top) { - sbrked_remains = 0; - last_sbrk_top = cp + require; - } else { - if (cp == (char*)-1) { /* Out of memory */ + if (cp == last_sbrk_top) { + sbrked_remains = 0; + last_sbrk_top = cp + require; + } else { + if (cp == (char*)-1) { /* Out of memory */ #ifdef DEBUGGING_MSTATS - goodsbrk -= require; + goodsbrk -= require; #endif - return 0; - } - /* Report the failure: */ - if (sbrked_remains) - add_to_chain((void*)(last_sbrk_top - sbrked_remains), - sbrked_remains, 0); - add_to_chain((void*)cp, require, 0); - sbrk_goodness -= SBRK_FAILURE_PRICE; - sbrked_remains = 0; - last_sbrk_top = 0; - last_op = 0; - return 0; - } + return 0; + } + /* Report the failure: */ + if (sbrked_remains) + add_to_chain((void*)(last_sbrk_top - sbrked_remains), + sbrked_remains, 0); + add_to_chain((void*)cp, require, 0); + sbrk_goodness -= SBRK_FAILURE_PRICE; + sbrked_remains = 0; + last_sbrk_top = 0; + last_op = 0; + return 0; + } } - + return 1; } @@ -1663,227 +1663,227 @@ getpages_adjacent(MEM_SIZE require) static void morecore(int bucket) { - union overhead *ovp; - int rnu; /* 2^rnu bytes will be requested */ - int nblks; /* become nblks blocks of the desired size */ - MEM_SIZE siz, needed; - static int were_called = 0; - - if (nextf[bucket]) - return; + union overhead *ovp; + int rnu; /* 2^rnu bytes will be requested */ + int nblks; /* become nblks blocks of the desired size */ + MEM_SIZE siz, needed; + static int were_called = 0; + + if (nextf[bucket]) + return; #ifndef NO_PERL_MALLOC_ENV - if (!were_called) { - /* It's our first time. Initialize ourselves */ - were_called = 1; /* Avoid a loop */ - if (!MallocCfg[MallocCfg_skip_cfg_env]) { - char *s = getenv("PERL_MALLOC_OPT"), *t = s; + if (!were_called) { + /* It's our first time. Initialize ourselves */ + were_called = 1; /* Avoid a loop */ + if (!MallocCfg[MallocCfg_skip_cfg_env]) { + char *s = getenv("PERL_MALLOC_OPT"), *t = s; const char *off; - const char *opts = PERL_MALLOC_OPT_CHARS; - int changed = 0; - - while ( t && t[0] && t[1] == '=' - && ((off = strchr(opts, *t))) ) { - IV val = 0; - - t += 2; - while (isDIGIT(*t)) - val = 10*val + *t++ - '0'; - if (!*t || *t == ';') { - if (MallocCfg[off - opts] != val) - changed = 1; - MallocCfg[off - opts] = val; - if (*t) - t++; - } - } - if (t && *t) { - dTHX; - MYMALLOC_WRITE2STDERR("Unrecognized part of PERL_MALLOC_OPT: \""); - MYMALLOC_WRITE2STDERR(t); - MYMALLOC_WRITE2STDERR("\"\n"); - } - if (changed) - MallocCfg[MallocCfg_cfg_env_read] = 1; - } - } + const char *opts = PERL_MALLOC_OPT_CHARS; + int changed = 0; + + while ( t && t[0] && t[1] == '=' + && ((off = strchr(opts, *t))) ) { + IV val = 0; + + t += 2; + while (isDIGIT(*t)) + val = 10*val + *t++ - '0'; + if (!*t || *t == ';') { + if (MallocCfg[off - opts] != val) + changed = 1; + MallocCfg[off - opts] = val; + if (*t) + t++; + } + } + if (t && *t) { + dTHX; + MYMALLOC_WRITE2STDERR("Unrecognized part of PERL_MALLOC_OPT: \""); + MYMALLOC_WRITE2STDERR(t); + MYMALLOC_WRITE2STDERR("\"\n"); + } + if (changed) + MallocCfg[MallocCfg_cfg_env_read] = 1; + } + } #endif - if (bucket == sizeof(MEM_SIZE)*8*BUCKETS_PER_POW2) { - MALLOC_UNLOCK; - croak("%s", "Out of memory during ridiculously large request"); - } - if (bucket > max_bucket) - max_bucket = bucket; - - rnu = ( (bucket <= (LOG_OF_MIN_ARENA << BUCKET_POW2_SHIFT)) - ? LOG_OF_MIN_ARENA - : (bucket >> BUCKET_POW2_SHIFT) ); - /* This may be overwritten later: */ - nblks = 1 << (rnu - (bucket >> BUCKET_POW2_SHIFT)); /* how many blocks to get */ - needed = ((MEM_SIZE)1 << rnu) + POW2_OPTIMIZE_SURPLUS(bucket); - if (nextf[rnu << BUCKET_POW2_SHIFT]) { /* 2048b bucket. */ - ovp = nextf[rnu << BUCKET_POW2_SHIFT] - 1 + CHUNK_SHIFT; - nextf[rnu << BUCKET_POW2_SHIFT] - = nextf[rnu << BUCKET_POW2_SHIFT]->ov_next; + if (bucket == sizeof(MEM_SIZE)*8*BUCKETS_PER_POW2) { + MALLOC_UNLOCK; + croak("%s", "Out of memory during ridiculously large request"); + } + if (bucket > max_bucket) + max_bucket = bucket; + + rnu = ( (bucket <= (LOG_OF_MIN_ARENA << BUCKET_POW2_SHIFT)) + ? LOG_OF_MIN_ARENA + : (bucket >> BUCKET_POW2_SHIFT) ); + /* This may be overwritten later: */ + nblks = 1 << (rnu - (bucket >> BUCKET_POW2_SHIFT)); /* how many blocks to get */ + needed = ((MEM_SIZE)1 << rnu) + POW2_OPTIMIZE_SURPLUS(bucket); + if (nextf[rnu << BUCKET_POW2_SHIFT]) { /* 2048b bucket. */ + ovp = nextf[rnu << BUCKET_POW2_SHIFT] - 1 + CHUNK_SHIFT; + nextf[rnu << BUCKET_POW2_SHIFT] + = nextf[rnu << BUCKET_POW2_SHIFT]->ov_next; #ifdef DEBUGGING_MSTATS - nmalloc[rnu << BUCKET_POW2_SHIFT]--; - start_slack -= M_OVERHEAD; + nmalloc[rnu << BUCKET_POW2_SHIFT]--; + start_slack -= M_OVERHEAD; #endif - DEBUG_m(PerlIO_printf(Perl_debug_log, - "stealing %ld bytes from %ld arena\n", - (long) needed, (long) rnu << BUCKET_POW2_SHIFT)); - } else if (chunk_chain - && (ovp = (union overhead*) get_from_chain(needed))) { - DEBUG_m(PerlIO_printf(Perl_debug_log, - "stealing %ld bytes from chain\n", - (long) needed)); - } else if ( (ovp = (union overhead*) - get_from_bigger_buckets((rnu << BUCKET_POW2_SHIFT) + 1, - needed)) ) { - DEBUG_m(PerlIO_printf(Perl_debug_log, - "stealing %ld bytes from bigger buckets\n", - (long) needed)); - } else if (needed <= sbrked_remains) { - ovp = (union overhead *)(last_sbrk_top - sbrked_remains); - sbrked_remains -= needed; - last_op = (char*)ovp; - } else - ovp = getpages(needed, &nblks, bucket); - - if (!ovp) - return; - FILL_DEADBEEF((unsigned char*)ovp, needed); - - /* - * Add new memory allocated to that on - * free list for this hash bucket. - */ - siz = BUCKET_SIZE_NO_SURPLUS(bucket); /* No surplus if nblks > 1 */ + DEBUG_m(PerlIO_printf(Perl_debug_log, + "stealing %ld bytes from %ld arena\n", + (long) needed, (long) rnu << BUCKET_POW2_SHIFT)); + } else if (chunk_chain + && (ovp = (union overhead*) get_from_chain(needed))) { + DEBUG_m(PerlIO_printf(Perl_debug_log, + "stealing %ld bytes from chain\n", + (long) needed)); + } else if ( (ovp = (union overhead*) + get_from_bigger_buckets((rnu << BUCKET_POW2_SHIFT) + 1, + needed)) ) { + DEBUG_m(PerlIO_printf(Perl_debug_log, + "stealing %ld bytes from bigger buckets\n", + (long) needed)); + } else if (needed <= sbrked_remains) { + ovp = (union overhead *)(last_sbrk_top - sbrked_remains); + sbrked_remains -= needed; + last_op = (char*)ovp; + } else + ovp = getpages(needed, &nblks, bucket); + + if (!ovp) + return; + FILL_DEADBEEF((unsigned char*)ovp, needed); + + /* + * Add new memory allocated to that on + * free list for this hash bucket. + */ + siz = BUCKET_SIZE_NO_SURPLUS(bucket); /* No surplus if nblks > 1 */ #ifdef PACK_MALLOC - *(u_char*)ovp = bucket; /* Fill index. */ - if (bucket <= MAX_PACKED) { - ovp = (union overhead *) ((char*)ovp + BLK_SHIFT(bucket)); - nblks = N_BLKS(bucket); + *(u_char*)ovp = bucket; /* Fill index. */ + if (bucket <= MAX_PACKED) { + ovp = (union overhead *) ((char*)ovp + BLK_SHIFT(bucket)); + nblks = N_BLKS(bucket); # ifdef DEBUGGING_MSTATS - start_slack += BLK_SHIFT(bucket); + start_slack += BLK_SHIFT(bucket); # endif - } else if (bucket < LOG_OF_MIN_ARENA * BUCKETS_PER_POW2) { - ovp = (union overhead *) ((char*)ovp + BLK_SHIFT(bucket)); - siz -= sizeof(union overhead); - } else ovp++; /* One chunk per block. */ + } else if (bucket < LOG_OF_MIN_ARENA * BUCKETS_PER_POW2) { + ovp = (union overhead *) ((char*)ovp + BLK_SHIFT(bucket)); + siz -= sizeof(union overhead); + } else ovp++; /* One chunk per block. */ #endif /* PACK_MALLOC */ - nextf[bucket] = ovp; + nextf[bucket] = ovp; #ifdef DEBUGGING_MSTATS - nmalloc[bucket] += nblks; - if (bucket > MAX_PACKED) { - start_slack += M_OVERHEAD * nblks; - } + nmalloc[bucket] += nblks; + if (bucket > MAX_PACKED) { + start_slack += M_OVERHEAD * nblks; + } #endif - while (--nblks > 0) { - ovp->ov_next = (union overhead *)((caddr_t)ovp + siz); - ovp = (union overhead *)((caddr_t)ovp + siz); - } - /* Not all sbrks return zeroed memory.*/ - ovp->ov_next = (union overhead *)NULL; + while (--nblks > 0) { + ovp->ov_next = (union overhead *)((caddr_t)ovp + siz); + ovp = (union overhead *)((caddr_t)ovp + siz); + } + /* Not all sbrks return zeroed memory.*/ + ovp->ov_next = (union overhead *)NULL; #ifdef PACK_MALLOC - if (bucket == 7*BUCKETS_PER_POW2) { /* Special case, explanation is above. */ - union overhead *n_op = nextf[7*BUCKETS_PER_POW2]->ov_next; - nextf[7*BUCKETS_PER_POW2] = - (union overhead *)((caddr_t)nextf[7*BUCKETS_PER_POW2] - - sizeof(union overhead)); - nextf[7*BUCKETS_PER_POW2]->ov_next = n_op; - } + if (bucket == 7*BUCKETS_PER_POW2) { /* Special case, explanation is above. */ + union overhead *n_op = nextf[7*BUCKETS_PER_POW2]->ov_next; + nextf[7*BUCKETS_PER_POW2] = + (union overhead *)((caddr_t)nextf[7*BUCKETS_PER_POW2] + - sizeof(union overhead)); + nextf[7*BUCKETS_PER_POW2]->ov_next = n_op; + } #endif /* !PACK_MALLOC */ } Free_t Perl_mfree(Malloc_t where) { - MEM_SIZE size; - union overhead *ovp; - char *cp = (char*)where; + MEM_SIZE size; + union overhead *ovp; + char *cp = (char*)where; #ifdef PACK_MALLOC - u_char bucket; + u_char bucket; #endif - DEBUG_m(PerlIO_printf(Perl_debug_log, - "0x%" UVxf ": (%05lu) free\n", - PTR2UV(cp), (unsigned long)(PL_an++))); + DEBUG_m(PerlIO_printf(Perl_debug_log, + "0x%" UVxf ": (%05lu) free\n", + PTR2UV(cp), (unsigned long)(PL_an++))); - if (cp == NULL) - return; + if (cp == NULL) + return; #ifdef DEBUGGING - if (PTR2UV(cp) & (MEM_ALIGNBYTES - 1)) - croak("%s", "wrong alignment in free()"); + if (PTR2UV(cp) & (MEM_ALIGNBYTES - 1)) + croak("%s", "wrong alignment in free()"); #endif - ovp = (union overhead *)((caddr_t)cp - - sizeof (union overhead) * CHUNK_SHIFT); + ovp = (union overhead *)((caddr_t)cp + - sizeof (union overhead) * CHUNK_SHIFT); #ifdef PACK_MALLOC - bucket = OV_INDEX(ovp); + bucket = OV_INDEX(ovp); #endif #ifdef IGNORE_SMALL_BAD_FREE - if ((bucket >= FIRST_BUCKET_WITH_CHECK) - && (OV_MAGIC(ovp, bucket) != MAGIC)) + if ((bucket >= FIRST_BUCKET_WITH_CHECK) + && (OV_MAGIC(ovp, bucket) != MAGIC)) #else - if (OV_MAGIC(ovp, bucket) != MAGIC) + if (OV_MAGIC(ovp, bucket) != MAGIC) #endif - { - static int bad_free_warn = -1; - if (bad_free_warn == -1) { - dTHX; - char *pbf = PerlEnv_getenv("PERL_BADFREE"); - bad_free_warn = (pbf) ? strNE("0", pbf) : 1; - } - if (!bad_free_warn) - return; + { + static int bad_free_warn = -1; + if (bad_free_warn == -1) { + dTHX; + char *pbf = PerlEnv_getenv("PERL_BADFREE"); + bad_free_warn = (pbf) ? strNE("0", pbf) : 1; + } + if (!bad_free_warn) + return; #ifdef RCHECK - { - dTHX; - if (!PERL_IS_ALIVE || !PL_curcop) - Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%s free() ignored (RMAGIC, PERL_CORE)", - ovp->ov_rmagic == RMAGIC - 1 ? - "Duplicate" : "Bad"); - } + { + dTHX; + if (!PERL_IS_ALIVE || !PL_curcop) + Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%s free() ignored (RMAGIC, PERL_CORE)", + ovp->ov_rmagic == RMAGIC - 1 ? + "Duplicate" : "Bad"); + } #else - { - dTHX; - if (!PERL_IS_ALIVE || !PL_curcop) - Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%s", "Bad free() ignored (PERL_CORE)"); - } + { + dTHX; + if (!PERL_IS_ALIVE || !PL_curcop) + Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%s", "Bad free() ignored (PERL_CORE)"); + } #endif - return; /* sanity */ - } + return; /* sanity */ + } #ifdef RCHECK - ASSERT(ovp->ov_rmagic == RMAGIC, "chunk's head overwrite"); - if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) { - int i; - MEM_SIZE nbytes = ovp->ov_size + 1; - - if ((i = nbytes & (RMAGIC_SZ-1))) { - i = RMAGIC_SZ - i; - while (i--) { /* nbytes - RMAGIC_SZ is end of alloced area */ - ASSERT(((caddr_t)ovp + nbytes - RMAGIC_SZ)[i] == RMAGIC_C, - "chunk's tail overwrite"); - } - } - /* Same at RMAGIC_SZ-aligned RMAGIC */ - nbytes = (nbytes + (RMAGIC_SZ-1)) & ~(RMAGIC_SZ-1); - ASSERT(((u_int *)((caddr_t)ovp + nbytes))[-1] == RMAGIC, - "chunk's tail overwrite"); - FILLCHECK_DEADBEEF((unsigned char*)((caddr_t)ovp + nbytes), - BUCKET_SIZE(OV_INDEX(ovp)) - nbytes); - } - FILL_DEADBEEF((unsigned char*)(ovp+CHUNK_SHIFT), - BUCKET_SIZE_REAL(OV_INDEX(ovp)) + RMAGIC_SZ); - ovp->ov_rmagic = RMAGIC - 1; + ASSERT(ovp->ov_rmagic == RMAGIC, "chunk's head overwrite"); + if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) { + int i; + MEM_SIZE nbytes = ovp->ov_size + 1; + + if ((i = nbytes & (RMAGIC_SZ-1))) { + i = RMAGIC_SZ - i; + while (i--) { /* nbytes - RMAGIC_SZ is end of alloced area */ + ASSERT(((caddr_t)ovp + nbytes - RMAGIC_SZ)[i] == RMAGIC_C, + "chunk's tail overwrite"); + } + } + /* Same at RMAGIC_SZ-aligned RMAGIC */ + nbytes = (nbytes + (RMAGIC_SZ-1)) & ~(RMAGIC_SZ-1); + ASSERT(((u_int *)((caddr_t)ovp + nbytes))[-1] == RMAGIC, + "chunk's tail overwrite"); + FILLCHECK_DEADBEEF((unsigned char*)((caddr_t)ovp + nbytes), + BUCKET_SIZE(OV_INDEX(ovp)) - nbytes); + } + FILL_DEADBEEF((unsigned char*)(ovp+CHUNK_SHIFT), + BUCKET_SIZE_REAL(OV_INDEX(ovp)) + RMAGIC_SZ); + ovp->ov_rmagic = RMAGIC - 1; #endif - ASSERT(OV_INDEX(ovp) < NBUCKETS, "chunk's head overwrite"); - size = OV_INDEX(ovp); + ASSERT(OV_INDEX(ovp) < NBUCKETS, "chunk's head overwrite"); + size = OV_INDEX(ovp); - MALLOC_LOCK; - ovp->ov_next = nextf[size]; - nextf[size] = ovp; - MALLOC_UNLOCK; + MALLOC_LOCK; + ovp->ov_next = nextf[size]; + nextf[size] = ovp; + MALLOC_UNLOCK; } /* There is no need to do any locking in realloc (with an exception of @@ -1894,193 +1894,193 @@ Perl_mfree(Malloc_t where) Malloc_t Perl_realloc(void *mp, size_t nbytes) { - MEM_SIZE onb; - union overhead *ovp; - char *res; - int prev_bucket; - int bucket; - int incr; /* 1 if does not fit, -1 if "easily" fits in a - smaller bucket, otherwise 0. */ - char *cp = (char*)mp; + MEM_SIZE onb; + union overhead *ovp; + char *res; + int prev_bucket; + int bucket; + int incr; /* 1 if does not fit, -1 if "easily" fits in a + smaller bucket, otherwise 0. */ + char *cp = (char*)mp; #ifdef DEBUGGING - MEM_SIZE size = nbytes; + MEM_SIZE size = nbytes; - if ((long)nbytes < 0) - croak("%s", "panic: realloc"); + if ((long)nbytes < 0) + croak("%s", "panic: realloc"); #endif - BARK_64K_LIMIT("Reallocation",nbytes,size); - if (!cp) - return Perl_malloc(nbytes); + BARK_64K_LIMIT("Reallocation",nbytes,size); + if (!cp) + return Perl_malloc(nbytes); - ovp = (union overhead *)((caddr_t)cp - - sizeof (union overhead) * CHUNK_SHIFT); - bucket = OV_INDEX(ovp); + ovp = (union overhead *)((caddr_t)cp + - sizeof (union overhead) * CHUNK_SHIFT); + bucket = OV_INDEX(ovp); #ifdef IGNORE_SMALL_BAD_FREE - if ((bucket >= FIRST_BUCKET_WITH_CHECK) - && (OV_MAGIC(ovp, bucket) != MAGIC)) + if ((bucket >= FIRST_BUCKET_WITH_CHECK) + && (OV_MAGIC(ovp, bucket) != MAGIC)) #else - if (OV_MAGIC(ovp, bucket) != MAGIC) + if (OV_MAGIC(ovp, bucket) != MAGIC) #endif - { - static int bad_free_warn = -1; - if (bad_free_warn == -1) { - dTHX; - char *pbf = PerlEnv_getenv("PERL_BADFREE"); - bad_free_warn = (pbf) ? strNE("0", pbf) : 1; - } - if (!bad_free_warn) - return NULL; + { + static int bad_free_warn = -1; + if (bad_free_warn == -1) { + dTHX; + char *pbf = PerlEnv_getenv("PERL_BADFREE"); + bad_free_warn = (pbf) ? strNE("0", pbf) : 1; + } + if (!bad_free_warn) + return NULL; #ifdef RCHECK - { - dTHX; - if (!PERL_IS_ALIVE || !PL_curcop) - Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%srealloc() %signored", - (ovp->ov_rmagic == RMAGIC - 1 ? "" : "Bad "), - ovp->ov_rmagic == RMAGIC - 1 - ? "of freed memory " : ""); - } + { + dTHX; + if (!PERL_IS_ALIVE || !PL_curcop) + Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%srealloc() %signored", + (ovp->ov_rmagic == RMAGIC - 1 ? "" : "Bad "), + ovp->ov_rmagic == RMAGIC - 1 + ? "of freed memory " : ""); + } #else - { - dTHX; - if (!PERL_IS_ALIVE || !PL_curcop) - Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%s", - "Bad realloc() ignored"); - } + { + dTHX; + if (!PERL_IS_ALIVE || !PL_curcop) + Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%s", + "Bad realloc() ignored"); + } #endif - return NULL; /* sanity */ - } - - onb = BUCKET_SIZE_REAL(bucket); - /* - * avoid the copy if same size block. - * We are not aggressive with boundary cases. Note that it might - * (for a small number of cases) give false negative if - * both new size and old one are in the bucket for - * FIRST_BIG_POW2, but the new one is near the lower end. - * - * We do not try to go to 1.5 times smaller bucket so far. - */ - if (nbytes > onb) incr = 1; - else { + return NULL; /* sanity */ + } + + onb = BUCKET_SIZE_REAL(bucket); + /* + * avoid the copy if same size block. + * We are not aggressive with boundary cases. Note that it might + * (for a small number of cases) give false negative if + * both new size and old one are in the bucket for + * FIRST_BIG_POW2, but the new one is near the lower end. + * + * We do not try to go to 1.5 times smaller bucket so far. + */ + if (nbytes > onb) incr = 1; + else { #ifdef DO_NOT_TRY_HARDER_WHEN_SHRINKING - if ( /* This is a little bit pessimal if PACK_MALLOC: */ - nbytes > ( (onb >> 1) - M_OVERHEAD ) + if ( /* This is a little bit pessimal if PACK_MALLOC: */ + nbytes > ( (onb >> 1) - M_OVERHEAD ) # ifdef TWO_POT_OPTIMIZE - || (bucket == FIRST_BIG_POW2 && nbytes >= LAST_SMALL_BOUND ) + || (bucket == FIRST_BIG_POW2 && nbytes >= LAST_SMALL_BOUND ) # endif - ) + ) #else /* !DO_NOT_TRY_HARDER_WHEN_SHRINKING */ - prev_bucket = ( (bucket > MAX_PACKED + 1) - ? bucket - BUCKETS_PER_POW2 - : bucket - 1); - if (nbytes > BUCKET_SIZE_REAL(prev_bucket)) + prev_bucket = ( (bucket > MAX_PACKED + 1) + ? bucket - BUCKETS_PER_POW2 + : bucket - 1); + if (nbytes > BUCKET_SIZE_REAL(prev_bucket)) #endif /* !DO_NOT_TRY_HARDER_WHEN_SHRINKING */ - incr = 0; - else incr = -1; - } + incr = 0; + else incr = -1; + } #ifdef STRESS_REALLOC - goto hard_way; + goto hard_way; #endif - if (incr == 0) { - inplace_label: + if (incr == 0) { + inplace_label: #ifdef RCHECK - /* - * Record new allocated size of block and - * bound space with magic numbers. - */ - if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) { - int i, nb = ovp->ov_size + 1; - - if ((i = nb & (RMAGIC_SZ-1))) { - i = RMAGIC_SZ - i; - while (i--) { /* nb - RMAGIC_SZ is end of alloced area */ - ASSERT(((caddr_t)ovp + nb - RMAGIC_SZ)[i] == RMAGIC_C, "chunk's tail overwrite"); - } - } - /* Same at RMAGIC_SZ-aligned RMAGIC */ - nb = (nb + (RMAGIC_SZ-1)) & ~(RMAGIC_SZ-1); - ASSERT(((u_int *)((caddr_t)ovp + nb))[-1] == RMAGIC, - "chunk's tail overwrite"); - FILLCHECK_DEADBEEF((unsigned char*)((caddr_t)ovp + nb), - BUCKET_SIZE(OV_INDEX(ovp)) - nb); - if (nbytes > ovp->ov_size + 1 - M_OVERHEAD) - FILL_FEEDADAD((unsigned char*)cp + ovp->ov_size + 1 - M_OVERHEAD, - nbytes - (ovp->ov_size + 1 - M_OVERHEAD)); - else - FILL_DEADBEEF((unsigned char*)cp + nbytes, - nb - M_OVERHEAD + RMAGIC_SZ - nbytes); - /* - * Convert amount of memory requested into - * closest block size stored in hash buckets - * which satisfies request. Account for - * space used per block for accounting. - */ - nbytes += M_OVERHEAD; - ovp->ov_size = nbytes - 1; - if ((i = nbytes & (RMAGIC_SZ-1))) { - i = RMAGIC_SZ - i; - while (i--) /* nbytes - RMAGIC_SZ is end of alloced area */ - ((caddr_t)ovp + nbytes - RMAGIC_SZ)[i] - = RMAGIC_C; - } - /* Same at RMAGIC_SZ-aligned RMAGIC */ - nbytes = (nbytes + (RMAGIC_SZ-1)) & ~(RMAGIC_SZ - 1); - ((u_int *)((caddr_t)ovp + nbytes))[-1] = RMAGIC; - } + /* + * Record new allocated size of block and + * bound space with magic numbers. + */ + if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) { + int i, nb = ovp->ov_size + 1; + + if ((i = nb & (RMAGIC_SZ-1))) { + i = RMAGIC_SZ - i; + while (i--) { /* nb - RMAGIC_SZ is end of alloced area */ + ASSERT(((caddr_t)ovp + nb - RMAGIC_SZ)[i] == RMAGIC_C, "chunk's tail overwrite"); + } + } + /* Same at RMAGIC_SZ-aligned RMAGIC */ + nb = (nb + (RMAGIC_SZ-1)) & ~(RMAGIC_SZ-1); + ASSERT(((u_int *)((caddr_t)ovp + nb))[-1] == RMAGIC, + "chunk's tail overwrite"); + FILLCHECK_DEADBEEF((unsigned char*)((caddr_t)ovp + nb), + BUCKET_SIZE(OV_INDEX(ovp)) - nb); + if (nbytes > ovp->ov_size + 1 - M_OVERHEAD) + FILL_FEEDADAD((unsigned char*)cp + ovp->ov_size + 1 - M_OVERHEAD, + nbytes - (ovp->ov_size + 1 - M_OVERHEAD)); + else + FILL_DEADBEEF((unsigned char*)cp + nbytes, + nb - M_OVERHEAD + RMAGIC_SZ - nbytes); + /* + * Convert amount of memory requested into + * closest block size stored in hash buckets + * which satisfies request. Account for + * space used per block for accounting. + */ + nbytes += M_OVERHEAD; + ovp->ov_size = nbytes - 1; + if ((i = nbytes & (RMAGIC_SZ-1))) { + i = RMAGIC_SZ - i; + while (i--) /* nbytes - RMAGIC_SZ is end of alloced area */ + ((caddr_t)ovp + nbytes - RMAGIC_SZ)[i] + = RMAGIC_C; + } + /* Same at RMAGIC_SZ-aligned RMAGIC */ + nbytes = (nbytes + (RMAGIC_SZ-1)) & ~(RMAGIC_SZ - 1); + ((u_int *)((caddr_t)ovp + nbytes))[-1] = RMAGIC; + } #endif - res = cp; - DEBUG_m(PerlIO_printf(Perl_debug_log, - "0x%" UVxf ": (%05lu) realloc %ld bytes inplace\n", - PTR2UV(res),(unsigned long)(PL_an++), - (long)size)); - } else if (incr == 1 && (cp - M_OVERHEAD == last_op) - && (onb > (1 << LOG_OF_MIN_ARENA))) { - MEM_SIZE require, newarena = nbytes, pow; - int shiftr; - - POW2_OPTIMIZE_ADJUST(newarena); - newarena = newarena + M_OVERHEAD; - /* newarena = (newarena + 3) &~ 3; */ - shiftr = (newarena - 1) >> LOG_OF_MIN_ARENA; - pow = LOG_OF_MIN_ARENA + 1; - /* apart from this loop, this is O(1) */ - while (shiftr >>= 1) - pow++; - newarena = (1 << pow) + POW2_OPTIMIZE_SURPLUS(pow * BUCKETS_PER_POW2); - require = newarena - onb - M_OVERHEAD; - - MALLOC_LOCK; - if (cp - M_OVERHEAD == last_op /* We *still* are the last chunk */ - && getpages_adjacent(require)) { + res = cp; + DEBUG_m(PerlIO_printf(Perl_debug_log, + "0x%" UVxf ": (%05lu) realloc %ld bytes inplace\n", + PTR2UV(res),(unsigned long)(PL_an++), + (long)size)); + } else if (incr == 1 && (cp - M_OVERHEAD == last_op) + && (onb > (1 << LOG_OF_MIN_ARENA))) { + MEM_SIZE require, newarena = nbytes, pow; + int shiftr; + + POW2_OPTIMIZE_ADJUST(newarena); + newarena = newarena + M_OVERHEAD; + /* newarena = (newarena + 3) &~ 3; */ + shiftr = (newarena - 1) >> LOG_OF_MIN_ARENA; + pow = LOG_OF_MIN_ARENA + 1; + /* apart from this loop, this is O(1) */ + while (shiftr >>= 1) + pow++; + newarena = (1 << pow) + POW2_OPTIMIZE_SURPLUS(pow * BUCKETS_PER_POW2); + require = newarena - onb - M_OVERHEAD; + + MALLOC_LOCK; + if (cp - M_OVERHEAD == last_op /* We *still* are the last chunk */ + && getpages_adjacent(require)) { #ifdef DEBUGGING_MSTATS - nmalloc[bucket]--; - nmalloc[pow * BUCKETS_PER_POW2]++; + nmalloc[bucket]--; + nmalloc[pow * BUCKETS_PER_POW2]++; #endif - if (pow * BUCKETS_PER_POW2 > (MEM_SIZE)max_bucket) - max_bucket = pow * BUCKETS_PER_POW2; - *(cp - M_OVERHEAD) = pow * BUCKETS_PER_POW2; /* Fill index. */ - MALLOC_UNLOCK; - goto inplace_label; - } else { - MALLOC_UNLOCK; - goto hard_way; - } - } else { - hard_way: - DEBUG_m(PerlIO_printf(Perl_debug_log, - "0x%" UVxf ": (%05lu) realloc %ld bytes the hard way\n", - PTR2UV(cp),(unsigned long)(PL_an++), - (long)size)); - if ((res = (char*)Perl_malloc(nbytes)) == NULL) - return (NULL); - if (cp != res) /* common optimization */ - Copy(cp, res, (MEM_SIZE)(nbytes (MEM_SIZE)max_bucket) + max_bucket = pow * BUCKETS_PER_POW2; + *(cp - M_OVERHEAD) = pow * BUCKETS_PER_POW2; /* Fill index. */ + MALLOC_UNLOCK; + goto inplace_label; + } else { + MALLOC_UNLOCK; + goto hard_way; + } + } else { + hard_way: + DEBUG_m(PerlIO_printf(Perl_debug_log, + "0x%" UVxf ": (%05lu) realloc %ld bytes the hard way\n", + PTR2UV(cp),(unsigned long)(PL_an++), + (long)size)); + if ((res = (char*)Perl_malloc(nbytes)) == NULL) + return (NULL); + if (cp != res) /* common optimization */ + Copy(cp, res, (MEM_SIZE)(nbytesov_size = size + M_OVERHEAD - 1; - *((u_int *)((caddr_t)ovp + size + M_OVERHEAD - RMAGIC_SZ)) = RMAGIC; + const MEM_SIZE size = BUCKET_SIZE_REAL(bucket); + ovp->ov_size = size + M_OVERHEAD - 1; + *((u_int *)((caddr_t)ovp + size + M_OVERHEAD - RMAGIC_SZ)) = RMAGIC; } #endif return BUCKET_SIZE_REAL(bucket); @@ -2170,56 +2170,56 @@ int Perl_get_mstats(pTHX_ perl_mstats_t *buf, int buflen, int level) { #ifdef DEBUGGING_MSTATS - int i, j; - union overhead *p; - struct chunk_chain_s* nextchain; - - PERL_ARGS_ASSERT_GET_MSTATS; - - buf->topbucket = buf->topbucket_ev = buf->topbucket_odd - = buf->totfree = buf->total = buf->total_chain = 0; - - buf->minbucket = MIN_BUCKET; - MALLOC_LOCK; - for (i = MIN_BUCKET ; i < NBUCKETS; i++) { - for (j = 0, p = nextf[i]; p; p = p->ov_next, j++) - ; - if (i < buflen) { - buf->nfree[i] = j; - buf->ntotal[i] = nmalloc[i]; - } - buf->totfree += j * BUCKET_SIZE_REAL(i); - buf->total += nmalloc[i] * BUCKET_SIZE_REAL(i); - if (nmalloc[i]) { - i % 2 ? (buf->topbucket_odd = i) : (buf->topbucket_ev = i); - buf->topbucket = i; - } - } - nextchain = chunk_chain; - while (nextchain) { - buf->total_chain += nextchain->size; - nextchain = nextchain->next; - } - buf->total_sbrk = goodsbrk + sbrk_slack; - buf->sbrks = sbrks; - buf->sbrk_good = sbrk_goodness; - buf->sbrk_slack = sbrk_slack; - buf->start_slack = start_slack; - buf->sbrked_remains = sbrked_remains; - MALLOC_UNLOCK; - buf->nbuckets = NBUCKETS; - if (level) { - for (i = MIN_BUCKET ; i < NBUCKETS; i++) { - if (i >= buflen) - break; - buf->bucket_mem_size[i] = BUCKET_SIZE_NO_SURPLUS(i); - buf->bucket_available_size[i] = BUCKET_SIZE_REAL(i); - } - } + int i, j; + union overhead *p; + struct chunk_chain_s* nextchain; + + PERL_ARGS_ASSERT_GET_MSTATS; + + buf->topbucket = buf->topbucket_ev = buf->topbucket_odd + = buf->totfree = buf->total = buf->total_chain = 0; + + buf->minbucket = MIN_BUCKET; + MALLOC_LOCK; + for (i = MIN_BUCKET ; i < NBUCKETS; i++) { + for (j = 0, p = nextf[i]; p; p = p->ov_next, j++) + ; + if (i < buflen) { + buf->nfree[i] = j; + buf->ntotal[i] = nmalloc[i]; + } + buf->totfree += j * BUCKET_SIZE_REAL(i); + buf->total += nmalloc[i] * BUCKET_SIZE_REAL(i); + if (nmalloc[i]) { + i % 2 ? (buf->topbucket_odd = i) : (buf->topbucket_ev = i); + buf->topbucket = i; + } + } + nextchain = chunk_chain; + while (nextchain) { + buf->total_chain += nextchain->size; + nextchain = nextchain->next; + } + buf->total_sbrk = goodsbrk + sbrk_slack; + buf->sbrks = sbrks; + buf->sbrk_good = sbrk_goodness; + buf->sbrk_slack = sbrk_slack; + buf->start_slack = start_slack; + buf->sbrked_remains = sbrked_remains; + MALLOC_UNLOCK; + buf->nbuckets = NBUCKETS; + if (level) { + for (i = MIN_BUCKET ; i < NBUCKETS; i++) { + if (i >= buflen) + break; + buf->bucket_mem_size[i] = BUCKET_SIZE_NO_SURPLUS(i); + buf->bucket_available_size[i] = BUCKET_SIZE_REAL(i); + } + } #else /* defined DEBUGGING_MSTATS */ - PerlIO_printf(Perl_error_log, "perl not compiled with DEBUGGING_MSTATS\n"); + PerlIO_printf(Perl_error_log, "perl not compiled with DEBUGGING_MSTATS\n"); #endif /* defined DEBUGGING_MSTATS */ - return 0; /* XXX unused */ + return 0; /* XXX unused */ } /* * mstats - print out statistics about malloc @@ -2232,72 +2232,72 @@ void Perl_dump_mstats(pTHX_ const char *s) { #ifdef DEBUGGING_MSTATS - int i; - perl_mstats_t buffer; - UV nf[NBUCKETS]; - UV nt[NBUCKETS]; + int i; + perl_mstats_t buffer; + UV nf[NBUCKETS]; + UV nt[NBUCKETS]; - PERL_ARGS_ASSERT_DUMP_MSTATS; + PERL_ARGS_ASSERT_DUMP_MSTATS; - buffer.nfree = nf; - buffer.ntotal = nt; - get_mstats(&buffer, NBUCKETS, 0); + buffer.nfree = nf; + buffer.ntotal = nt; + get_mstats(&buffer, NBUCKETS, 0); - if (s) - PerlIO_printf(Perl_error_log, - "Memory allocation statistics %s (buckets %" IVdf + if (s) + PerlIO_printf(Perl_error_log, + "Memory allocation statistics %s (buckets %" IVdf "(%" IVdf ")..%" IVdf "(%" IVdf ")\n", - s, - (IV)BUCKET_SIZE_REAL(MIN_BUCKET), - (IV)BUCKET_SIZE_NO_SURPLUS(MIN_BUCKET), - (IV)BUCKET_SIZE_REAL(buffer.topbucket), - (IV)BUCKET_SIZE_NO_SURPLUS(buffer.topbucket)); + s, + (IV)BUCKET_SIZE_REAL(MIN_BUCKET), + (IV)BUCKET_SIZE_NO_SURPLUS(MIN_BUCKET), + (IV)BUCKET_SIZE_REAL(buffer.topbucket), + (IV)BUCKET_SIZE_NO_SURPLUS(buffer.topbucket)); PerlIO_printf(Perl_error_log, "%8" IVdf " free:", buffer.totfree); - for (i = MIN_EVEN_REPORT; i <= buffer.topbucket; i += BUCKETS_PER_POW2) { - PerlIO_printf(Perl_error_log, - ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2) - ? " %5" UVuf - : ((i < 12*BUCKETS_PER_POW2) ? " %3" UVuf + for (i = MIN_EVEN_REPORT; i <= buffer.topbucket; i += BUCKETS_PER_POW2) { + PerlIO_printf(Perl_error_log, + ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2) + ? " %5" UVuf + : ((i < 12*BUCKETS_PER_POW2) ? " %3" UVuf : " %" UVuf)), - buffer.nfree[i]); - } + buffer.nfree[i]); + } #ifdef BUCKETS_ROOT2 - PerlIO_printf(Perl_error_log, "\n\t "); - for (i = MIN_BUCKET + 1; i <= buffer.topbucket_odd; i += BUCKETS_PER_POW2) { - PerlIO_printf(Perl_error_log, - ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2) - ? " %5"UVuf - : ((i < 12*BUCKETS_PER_POW2) ? " %3"UVuf : " %"UVuf)), - buffer.nfree[i]); - } + PerlIO_printf(Perl_error_log, "\n\t "); + for (i = MIN_BUCKET + 1; i <= buffer.topbucket_odd; i += BUCKETS_PER_POW2) { + PerlIO_printf(Perl_error_log, + ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2) + ? " %5"UVuf + : ((i < 12*BUCKETS_PER_POW2) ? " %3"UVuf : " %"UVuf)), + buffer.nfree[i]); + } #endif PerlIO_printf(Perl_error_log, "\n%8" IVdf " used:", buffer.total - buffer.totfree); - for (i = MIN_EVEN_REPORT; i <= buffer.topbucket; i += BUCKETS_PER_POW2) { - PerlIO_printf(Perl_error_log, - ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2) - ? " %5" IVdf - : ((i < 12*BUCKETS_PER_POW2) ? " %3" IVdf : " %" IVdf)), - buffer.ntotal[i] - buffer.nfree[i]); - } + for (i = MIN_EVEN_REPORT; i <= buffer.topbucket; i += BUCKETS_PER_POW2) { + PerlIO_printf(Perl_error_log, + ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2) + ? " %5" IVdf + : ((i < 12*BUCKETS_PER_POW2) ? " %3" IVdf : " %" IVdf)), + buffer.ntotal[i] - buffer.nfree[i]); + } #ifdef BUCKETS_ROOT2 - PerlIO_printf(Perl_error_log, "\n\t "); - for (i = MIN_BUCKET + 1; i <= buffer.topbucket_odd; i += BUCKETS_PER_POW2) { - PerlIO_printf(Perl_error_log, - ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2) - ? " %5"IVdf - : ((i < 12*BUCKETS_PER_POW2) ? " %3"IVdf : " %"IVdf)), - buffer.ntotal[i] - buffer.nfree[i]); - } + PerlIO_printf(Perl_error_log, "\n\t "); + for (i = MIN_BUCKET + 1; i <= buffer.topbucket_odd; i += BUCKETS_PER_POW2) { + PerlIO_printf(Perl_error_log, + ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2) + ? " %5"IVdf + : ((i < 12*BUCKETS_PER_POW2) ? " %3"IVdf : " %"IVdf)), + buffer.ntotal[i] - buffer.nfree[i]); + } #endif - PerlIO_printf(Perl_error_log, "\nTotal sbrk(): %" IVdf "/%" IVdf ":%" + PerlIO_printf(Perl_error_log, "\nTotal sbrk(): %" IVdf "/%" IVdf ":%" IVdf ". Odd ends: pad+heads+chain+tail: %" IVdf "+%" IVdf "+%" IVdf "+%" IVdf ".\n", - buffer.total_sbrk, buffer.sbrks, buffer.sbrk_good, - buffer.sbrk_slack, buffer.start_slack, - buffer.total_chain, buffer.sbrked_remains); + buffer.total_sbrk, buffer.sbrks, buffer.sbrk_good, + buffer.sbrk_slack, buffer.start_slack, + buffer.total_chain, buffer.sbrked_remains); #else /* DEBUGGING_MSTATS */ - PerlIO_printf(Perl_error_log, "%s: perl not compiled with DEBUGGING_MSTATS\n",s); + PerlIO_printf(Perl_error_log, "%s: perl not compiled with DEBUGGING_MSTATS\n",s); #endif /* DEBUGGING_MSTATS */ } @@ -2341,15 +2341,15 @@ Perl_sbrk(int size) size = (size + 0x7ff) & ~0x7ff; #endif if (size <= Perl_sbrk_oldsize) { - got = Perl_sbrk_oldchunk; - Perl_sbrk_oldchunk += size; - Perl_sbrk_oldsize -= size; + got = Perl_sbrk_oldchunk; + Perl_sbrk_oldchunk += size; + Perl_sbrk_oldsize -= size; } else { if (size >= PERLSBRK_32_K) { - small = 0; + small = 0; } else { - size = PERLSBRK_64_K; - small = 1; + size = PERLSBRK_64_K; + small = 1; } # if NEEDED_ALIGNMENT > SYSTEM_ALLOC_ALIGNMENT size += NEEDED_ALIGNMENT - SYSTEM_ALLOC_ALIGNMENT; @@ -2359,9 +2359,9 @@ Perl_sbrk(int size) got = (got + NEEDED_ALIGNMENT - 1) & ~(NEEDED_ALIGNMENT - 1); # endif if (small) { - /* Chunk is small, register the rest for future allocs. */ - Perl_sbrk_oldchunk = got + reqsize; - Perl_sbrk_oldsize = size - reqsize; + /* Chunk is small, register the rest for future allocs. */ + Perl_sbrk_oldchunk = got + reqsize; + Perl_sbrk_oldsize = size - reqsize; } } diff --git a/mathoms.c b/mathoms.c index 7b85ae749abc..1144e1519e41 100644 --- a/mathoms.c +++ b/mathoms.c @@ -263,14 +263,6 @@ Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen) sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC); } -/* -=for apidoc sv_catpvn_mg - -Like C, but also handles 'set' magic. - -=cut -*/ - void Perl_sv_catpvn_mg(pTHX_ SV *dsv, const char *sstr, STRLEN len) { @@ -291,14 +283,6 @@ Perl_sv_catsv(pTHX_ SV *dsv, SV *sstr) sv_catsv_flags(dsv, sstr, SV_GMAGIC); } -/* -=for apidoc sv_catsv_mg - -Like C, but also handles 'set' magic. - -=cut -*/ - void Perl_sv_catsv_mg(pTHX_ SV *dsv, SV *sstr) { @@ -322,9 +306,9 @@ Perl_sv_iv(pTHX_ SV *sv) PERL_ARGS_ASSERT_SV_IV; if (SvIOK(sv)) { - if (SvIsUV(sv)) - return (IV)SvUVX(sv); - return SvIVX(sv); + if (SvIsUV(sv)) + return (IV)SvUVX(sv); + return SvIVX(sv); } return sv_2iv(sv); } @@ -344,9 +328,9 @@ Perl_sv_uv(pTHX_ SV *sv) PERL_ARGS_ASSERT_SV_UV; if (SvIOK(sv)) { - if (SvIsUV(sv)) - return SvUVX(sv); - return (UV)SvIVX(sv); + if (SvIsUV(sv)) + return SvUVX(sv); + return (UV)SvIVX(sv); } return sv_2uv(sv); } @@ -366,7 +350,7 @@ Perl_sv_nv(pTHX_ SV *sv) PERL_ARGS_ASSERT_SV_NV; if (SvNOK(sv)) - return SvNVX(sv); + return SvNVX(sv); return sv_2nv(sv); } @@ -389,8 +373,8 @@ Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp) PERL_ARGS_ASSERT_SV_PVN; if (SvPOK(sv)) { - *lp = SvCUR(sv); - return SvPVX(sv); + *lp = SvCUR(sv); + return SvPVX(sv); } return sv_2pv(sv, lp); } @@ -402,8 +386,8 @@ Perl_sv_pvn_nomg(pTHX_ SV *sv, STRLEN *lp) PERL_ARGS_ASSERT_SV_PVN_NOMG; if (SvPOK(sv)) { - *lp = SvCUR(sv); - return SvPVX(sv); + *lp = SvCUR(sv); + return SvPVX(sv); } return sv_2pv_flags(sv, lp, 0); } @@ -640,12 +624,12 @@ Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how) bool Perl_do_open(pTHX_ GV *gv, const char *name, I32 len, int as_raw, - int rawmode, int rawperm, PerlIO *supplied_fp) + int rawmode, int rawperm, PerlIO *supplied_fp) { PERL_ARGS_ASSERT_DO_OPEN; return do_openn(gv, name, len, as_raw, rawmode, rawperm, - supplied_fp, (SV **) NULL, 0); + supplied_fp, (SV **) NULL, 0); } bool @@ -776,14 +760,14 @@ Perl_save_list(pTHX_ SV **sarg, I32 maxsarg) PERL_ARGS_ASSERT_SAVE_LIST; for (i = 1; i <= maxsarg; i++) { - SV *sv; - SvGETMAGIC(sarg[i]); - sv = newSV(0); - sv_setsv_nomg(sv,sarg[i]); - SSCHECK(3); - SSPUSHPTR(sarg[i]); /* remember the pointer */ - SSPUSHPTR(sv); /* remember the value */ - SSPUSHUV(SAVEt_ITEM); + SV *sv; + SvGETMAGIC(sarg[i]); + sv = newSV(0); + sv_setsv_nomg(sv,sarg[i]); + SSCHECK(3); + SSPUSHPTR(sarg[i]); /* remember the pointer */ + SSPUSHPTR(sv); /* remember the value */ + SSPUSHUV(SAVEt_ITEM); } } @@ -833,8 +817,8 @@ C instead. SSize_t Perl_unpack_str(pTHX_ const char *pat, const char *patend, const char *s, - const char *strbeg, const char *strend, char **new_s, I32 ocnt, - U32 flags) + const char *strbeg, const char *strend, char **new_s, I32 ocnt, + U32 flags) { PERL_ARGS_ASSERT_UNPACK_STR; @@ -886,7 +870,7 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, U32 hash) PERL_ARGS_ASSERT_HV_FETCH_ENT; return (HE *)hv_common(hv, keysv, NULL, 0, 0, - (lval ? HV_FETCH_LVALUE : 0), NULL, hash); + (lval ? HV_FETCH_LVALUE : 0), NULL, hash); } SV * @@ -895,15 +879,15 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash) PERL_ARGS_ASSERT_HV_DELETE_ENT; return MUTABLE_SV(hv_common(hv, keysv, NULL, 0, 0, flags | HV_DELETE, NULL, - hash)); + hash)); } SV** Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash, - int flags) + int flags) { return (SV**) hv_common(hv, NULL, key, klen, flags, - (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash); + (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash); } SV** @@ -913,14 +897,14 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash) int flags; if (klen_i32 < 0) { - klen = -klen_i32; - flags = HVhek_UTF8; + klen = -klen_i32; + flags = HVhek_UTF8; } else { - klen = klen_i32; - flags = 0; + klen = klen_i32; + flags = 0; } return (SV **) hv_common(hv, NULL, key, klen, flags, - (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash); + (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash); } bool @@ -932,11 +916,11 @@ Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen_i32) PERL_ARGS_ASSERT_HV_EXISTS; if (klen_i32 < 0) { - klen = -klen_i32; - flags = HVhek_UTF8; + klen = -klen_i32; + flags = HVhek_UTF8; } else { - klen = klen_i32; - flags = 0; + klen = klen_i32; + flags = 0; } return cBOOL(hv_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0)); } @@ -950,15 +934,15 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval) PERL_ARGS_ASSERT_HV_FETCH; if (klen_i32 < 0) { - klen = -klen_i32; - flags = HVhek_UTF8; + klen = -klen_i32; + flags = HVhek_UTF8; } else { - klen = klen_i32; - flags = 0; + klen = klen_i32; + flags = 0; } return (SV **) hv_common(hv, NULL, key, klen, flags, - lval ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE) - : HV_FETCH_JUST_SV, NULL, 0); + lval ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE) + : HV_FETCH_JUST_SV, NULL, 0); } SV * @@ -970,14 +954,14 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 flags) PERL_ARGS_ASSERT_HV_DELETE; if (klen_i32 < 0) { - klen = -klen_i32; - k_flags = HVhek_UTF8; + klen = -klen_i32; + k_flags = HVhek_UTF8; } else { - klen = klen_i32; - k_flags = 0; + klen = klen_i32; + k_flags = 0; } return MUTABLE_SV(hv_common(hv, NULL, key, klen, k_flags, flags | HV_DELETE, - NULL, 0)); + NULL, 0)); } AV * @@ -1277,6 +1261,8 @@ Looks up the type of the lexical variable at position C in the currently-compiling pad. If the variable is typed, the stash of the class to which it is typed is returned. If not, C is returned. +Use L> instead. + =cut */ diff --git a/metaconfig.h b/metaconfig.h index baba5eac6879..ae0093afd420 100644 --- a/metaconfig.h +++ b/metaconfig.h @@ -14,4 +14,6 @@ * they should be removed from here. * * HAS_WCRTOMB + * GETENV_PRESERVES_OTHER_THREAD + * */ diff --git a/mg.c b/mg.c index 8b90aa4e3f34..4461b6d4594e 100644 --- a/mg.c +++ b/mg.c @@ -103,8 +103,8 @@ S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags) if (SvREFCNT(sv) > 0) { /* guard against sv getting freed midway through the mg clearing, * by holding a private reference for the duration. */ - SvREFCNT_inc_simple_void_NN(sv); - bumped = TRUE; + SvREFCNT_inc_simple_void_NN(sv); + bumped = TRUE; } SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix)); @@ -137,19 +137,19 @@ Perl_mg_magical(SV *sv) SvMAGICAL_off(sv); if ((mg = SvMAGIC(sv))) { - do { - const MGVTBL* const vtbl = mg->mg_virtual; - if (vtbl) { - if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP)) - SvGMAGICAL_on(sv); - if (vtbl->svt_set) - SvSMAGICAL_on(sv); - if (vtbl->svt_clear) - SvRMAGICAL_on(sv); - } - } while ((mg = mg->mg_moremagic)); - if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG))) - SvRMAGICAL_on(sv); + do { + const MGVTBL* const vtbl = mg->mg_virtual; + if (vtbl) { + if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP)) + SvGMAGICAL_on(sv); + if (vtbl->svt_set) + SvSMAGICAL_on(sv); + if (vtbl->svt_clear) + SvRMAGICAL_on(sv); + } + } while ((mg = mg->mg_moremagic)); + if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG))) + SvRMAGICAL_on(sv); } } @@ -181,13 +181,13 @@ Perl_mg_get(pTHX_ SV *sv) newmg = cur = head = mg = SvMAGIC(sv); while (mg) { - const MGVTBL * const vtbl = mg->mg_virtual; - MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */ + const MGVTBL * const vtbl = mg->mg_virtual; + MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */ - if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) { + if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) { - /* taint's mg get is so dumb it doesn't need flag saving */ - if (mg->mg_type != PERL_MAGIC_taint) { + /* taint's mg get is so dumb it doesn't need flag saving */ + if (mg->mg_type != PERL_MAGIC_taint) { taint_only = FALSE; if (!saved) { save_magic(mgs_ix, sv); @@ -195,23 +195,23 @@ Perl_mg_get(pTHX_ SV *sv) } } - vtbl->svt_get(aTHX_ sv, mg); - - /* guard against magic having been deleted - eg FETCH calling - * untie */ - if (!SvMAGIC(sv)) { - /* recalculate flags */ - (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG); - break; - } - - /* recalculate flags if this entry was deleted. */ - if (mg->mg_flags & MGf_GSKIP) - (SSPTR(mgs_ix, MGS *))->mgs_flags &= - ~(SVs_GMG|SVs_SMG|SVs_RMG); - } - else if (vtbl == &PL_vtbl_utf8) { - /* get-magic can reallocate the PV, unless there's only taint + vtbl->svt_get(aTHX_ sv, mg); + + /* guard against magic having been deleted - eg FETCH calling + * untie */ + if (!SvMAGIC(sv)) { + /* recalculate flags */ + (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG); + break; + } + + /* recalculate flags if this entry was deleted. */ + if (mg->mg_flags & MGf_GSKIP) + (SSPTR(mgs_ix, MGS *))->mgs_flags &= + ~(SVs_GMG|SVs_SMG|SVs_RMG); + } + else if (vtbl == &PL_vtbl_utf8) { + /* get-magic can reallocate the PV, unless there's only taint * magic */ if (taint_only) { MAGIC *mg2; @@ -228,32 +228,32 @@ Perl_mg_get(pTHX_ SV *sv) } if (!taint_only) magic_setutf8(sv, mg); - } - - mg = nextmg; - - if (have_new) { - /* Have we finished with the new entries we saw? Start again - where we left off (unless there are more new entries). */ - if (mg == head) { - have_new = 0; - mg = cur; - head = newmg; - } - } - - /* Were any new entries added? */ - if (!have_new && (newmg = SvMAGIC(sv)) != head) { - have_new = 1; - cur = mg; - mg = newmg; - /* recalculate flags */ - (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG); - } + } + + mg = nextmg; + + if (have_new) { + /* Have we finished with the new entries we saw? Start again + where we left off (unless there are more new entries). */ + if (mg == head) { + have_new = 0; + mg = cur; + head = newmg; + } + } + + /* Were any new entries added? */ + if (!have_new && (newmg = SvMAGIC(sv)) != head) { + have_new = 1; + cur = mg; + mg = newmg; + /* recalculate flags */ + (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG); + } } if (saved) - restore_magic(INT2PTR(void *, (IV)mgs_ix)); + restore_magic(INT2PTR(void *, (IV)mgs_ix)); return 0; } @@ -281,16 +281,16 @@ Perl_mg_set(pTHX_ SV *sv) for (mg = SvMAGIC(sv); mg; mg = nextmg) { const MGVTBL* vtbl = mg->mg_virtual; - nextmg = mg->mg_moremagic; /* it may delete itself */ - if (mg->mg_flags & MGf_GSKIP) { - mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */ - (SSPTR(mgs_ix, MGS*))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG); - } - if (PL_localizing == 2 - && PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type)) - continue; - if (vtbl && vtbl->svt_set) - vtbl->svt_set(aTHX_ sv, mg); + nextmg = mg->mg_moremagic; /* it may delete itself */ + if (mg->mg_flags & MGf_GSKIP) { + mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */ + (SSPTR(mgs_ix, MGS*))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG); + } + if (PL_localizing == 2 + && PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type)) + continue; + if (vtbl && vtbl->svt_set) + vtbl->svt_set(aTHX_ sv, mg); } restore_magic(INT2PTR(void*, (IV)mgs_ix)); @@ -319,14 +319,14 @@ Perl_mg_length(pTHX_ SV *sv) for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { const MGVTBL * const vtbl = mg->mg_virtual; - if (vtbl && vtbl->svt_len) { + if (vtbl && vtbl->svt_len) { const I32 mgs_ix = SSNEW(sizeof(MGS)); - save_magic(mgs_ix, sv); - /* omit MGf_GSKIP -- not changed here */ - len = vtbl->svt_len(aTHX_ sv, mg); - restore_magic(INT2PTR(void*, (IV)mgs_ix)); - return len; - } + save_magic(mgs_ix, sv); + /* omit MGf_GSKIP -- not changed here */ + len = vtbl->svt_len(aTHX_ sv, mg); + restore_magic(INT2PTR(void*, (IV)mgs_ix)); + return len; + } } (void)SvPV_const(sv, len); @@ -342,24 +342,24 @@ Perl_mg_size(pTHX_ SV *sv) for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { const MGVTBL* const vtbl = mg->mg_virtual; - if (vtbl && vtbl->svt_len) { + if (vtbl && vtbl->svt_len) { const I32 mgs_ix = SSNEW(sizeof(MGS)); I32 len; - save_magic(mgs_ix, sv); - /* omit MGf_GSKIP -- not changed here */ - len = vtbl->svt_len(aTHX_ sv, mg); - restore_magic(INT2PTR(void*, (IV)mgs_ix)); - return len; - } + save_magic(mgs_ix, sv); + /* omit MGf_GSKIP -- not changed here */ + len = vtbl->svt_len(aTHX_ sv, mg); + restore_magic(INT2PTR(void*, (IV)mgs_ix)); + return len; + } } switch(SvTYPE(sv)) { - case SVt_PVAV: - return AvFILLp((const AV *) sv); /* Fallback to non-tied array */ - case SVt_PVHV: - /* FIXME */ - default: - Perl_croak(aTHX_ "Size magic not implemented"); + case SVt_PVAV: + return AvFILLp((const AV *) sv); /* Fallback to non-tied array */ + case SVt_PVHV: + /* FIXME */ + default: + Perl_croak(aTHX_ "Size magic not implemented"); } NOT_REACHED; /* NOTREACHED */ @@ -386,12 +386,12 @@ Perl_mg_clear(pTHX_ SV *sv) for (mg = SvMAGIC(sv); mg; mg = nextmg) { const MGVTBL* const vtbl = mg->mg_virtual; - /* omit GSKIP -- never set here */ + /* omit GSKIP -- never set here */ - nextmg = mg->mg_moremagic; /* it may delete itself */ + nextmg = mg->mg_moremagic; /* it may delete itself */ - if (vtbl && vtbl->svt_clear) - vtbl->svt_clear(aTHX_ sv, mg); + if (vtbl && vtbl->svt_clear) + vtbl->svt_clear(aTHX_ sv, mg); } restore_magic(INT2PTR(void*, (IV)mgs_ix)); @@ -404,13 +404,13 @@ S_mg_findext_flags(const SV *sv, int type, const MGVTBL *vtbl, U32 flags) assert(flags <= 1); if (sv) { - MAGIC *mg; + MAGIC *mg; - for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { - if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) { - return mg; - } - } + for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { + if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) { + return mg; + } + } } return NULL; @@ -478,20 +478,20 @@ Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen) for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { const MGVTBL* const vtbl = mg->mg_virtual; - if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){ - count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen); - } - else { - const char type = mg->mg_type; - if (isUPPER(type) && type != PERL_MAGIC_uvar) { - sv_magic(nsv, - (type == PERL_MAGIC_tied) - ? SvTIED_obj(sv, mg) + if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){ + count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen); + } + else { + const char type = mg->mg_type; + if (isUPPER(type) && type != PERL_MAGIC_uvar) { + sv_magic(nsv, + (type == PERL_MAGIC_tied) + ? SvTIED_obj(sv, mg) : mg->mg_obj, - toLOWER(type), key, klen); - count++; - } - } + toLOWER(type), key, klen); + count++; + } + } } return count; } @@ -519,30 +519,30 @@ Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic) PERL_ARGS_ASSERT_MG_LOCALIZE; if (nsv == DEFSV) - return; + return; for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { - const MGVTBL* const vtbl = mg->mg_virtual; - if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type)) - continue; - - if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local) - (void)vtbl->svt_local(aTHX_ nsv, mg); - else - sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl, - mg->mg_ptr, mg->mg_len); + const MGVTBL* const vtbl = mg->mg_virtual; + if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type)) + continue; + + if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local) + (void)vtbl->svt_local(aTHX_ nsv, mg); + else + sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl, + mg->mg_ptr, mg->mg_len); - /* container types should remain read-only across localization */ - SvFLAGS(nsv) |= SvREADONLY(sv); + /* container types should remain read-only across localization */ + SvFLAGS(nsv) |= SvREADONLY(sv); } if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) { - SvFLAGS(nsv) |= SvMAGICAL(sv); - if (setmagic) { - PL_localizing = 1; - SvSETMAGIC(nsv); - PL_localizing = 0; - } + SvFLAGS(nsv) |= SvMAGICAL(sv); + if (setmagic) { + PL_localizing = 1; + SvSETMAGIC(nsv); + PL_localizing = 0; + } } } @@ -552,7 +552,7 @@ S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg) { const MGVTBL* const vtbl = mg->mg_virtual; if (vtbl && vtbl->svt_free) - vtbl->svt_free(aTHX_ sv, mg); + vtbl->svt_free(aTHX_ sv, mg); if (mg->mg_len > 0) Safefree(mg->mg_ptr); @@ -560,7 +560,7 @@ S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg) SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr)); if (mg->mg_flags & MGf_REFCOUNTED) - SvREFCNT_dec(mg->mg_obj); + SvREFCNT_dec(mg->mg_obj); Safefree(mg); } @@ -581,9 +581,9 @@ Perl_mg_free(pTHX_ SV *sv) PERL_ARGS_ASSERT_MG_FREE; for (mg = SvMAGIC(sv); mg; mg = moremagic) { - moremagic = mg->mg_moremagic; - mg_free_struct(sv, mg); - SvMAGIC_set(sv, moremagic); + moremagic = mg->mg_moremagic; + mg_free_struct(sv, mg); + SvMAGIC_set(sv, moremagic); } SvMAGIC_set(sv, NULL); SvMAGICAL_off(sv); @@ -604,21 +604,21 @@ Perl_mg_free_type(pTHX_ SV *sv, int how) MAGIC *mg, *prevmg, *moremg; PERL_ARGS_ASSERT_MG_FREE_TYPE; for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) { - moremg = mg->mg_moremagic; - if (mg->mg_type == how) { + moremg = mg->mg_moremagic; + if (mg->mg_type == how) { MAGIC *newhead; - /* temporarily move to the head of the magic chain, in case - custom free code relies on this historical aspect of mg_free */ - if (prevmg) { - prevmg->mg_moremagic = moremg; - mg->mg_moremagic = SvMAGIC(sv); - SvMAGIC_set(sv, mg); - } - newhead = mg->mg_moremagic; - mg_free_struct(sv, mg); - SvMAGIC_set(sv, newhead); - mg = prevmg; - } + /* temporarily move to the head of the magic chain, in case + custom free code relies on this historical aspect of mg_free */ + if (prevmg) { + prevmg->mg_moremagic = moremg; + mg->mg_moremagic = SvMAGIC(sv); + SvMAGIC_set(sv, mg); + } + newhead = mg->mg_moremagic; + mg_free_struct(sv, mg); + SvMAGIC_set(sv, newhead); + mg = prevmg; + } } mg_magical(sv); } @@ -640,21 +640,21 @@ Perl_mg_freeext(pTHX_ SV *sv, int how, const MGVTBL *vtbl) MAGIC *mg, *prevmg, *moremg; PERL_ARGS_ASSERT_MG_FREEEXT; for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) { - MAGIC *newhead; - moremg = mg->mg_moremagic; - if (mg->mg_type == how && (vtbl == NULL || mg->mg_virtual == vtbl)) { - /* temporarily move to the head of the magic chain, in case - custom free code relies on this historical aspect of mg_free */ - if (prevmg) { - prevmg->mg_moremagic = moremg; - mg->mg_moremagic = SvMAGIC(sv); - SvMAGIC_set(sv, mg); - } - newhead = mg->mg_moremagic; - mg_free_struct(sv, mg); - SvMAGIC_set(sv, newhead); - mg = prevmg; - } + MAGIC *newhead; + moremg = mg->mg_moremagic; + if (mg->mg_type == how && (vtbl == NULL || mg->mg_virtual == vtbl)) { + /* temporarily move to the head of the magic chain, in case + custom free code relies on this historical aspect of mg_free */ + if (prevmg) { + prevmg->mg_moremagic = moremg; + mg->mg_moremagic = SvMAGIC(sv); + SvMAGIC_set(sv, mg); + } + newhead = mg->mg_moremagic; + mg_free_struct(sv, mg); + SvMAGIC_set(sv, newhead); + mg = prevmg; + } } mg_magical(sv); } @@ -670,19 +670,19 @@ Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) if (PL_curpm) { REGEXP * const rx = PM_GETRE(PL_curpm); - if (rx) { + if (rx) { const SSize_t n = (SSize_t)mg->mg_obj; if (n == '+') { /* @+ */ - /* return the number possible */ - return RX_NPARENS(rx); + /* return the number possible */ + return RX_NPARENS(rx); } else { /* @- @^CAPTURE @{^CAPTURE} */ - I32 paren = RX_LASTPAREN(rx); + I32 paren = RX_LASTPAREN(rx); - /* return the last filled */ - while ( paren >= 0 - && (RX_OFFS(rx)[paren].start == -1 - || RX_OFFS(rx)[paren].end == -1) ) - paren--; + /* return the last filled */ + while ( paren >= 0 + && (RX_OFFS(rx)[paren].start == -1 + || RX_OFFS(rx)[paren].end == -1) ) + paren--; if (n == '-') { /* @- */ return (U32)paren; @@ -691,7 +691,7 @@ Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) return paren >= 0 ? (U32)(paren-1) : (U32)-1; } } - } + } } return (U32)-1; @@ -706,42 +706,42 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) if (PL_curpm) { REGEXP * const rx = PM_GETRE(PL_curpm); - if (rx) { + if (rx) { const SSize_t n = (SSize_t)mg->mg_obj; /* @{^CAPTURE} does not contain $&, so we need to increment by 1 */ const I32 paren = mg->mg_len + (n == '\003' ? 1 : 0); - SSize_t s; - SSize_t t; - if (paren < 0) - return 0; - if (paren <= (I32)RX_NPARENS(rx) && - (s = RX_OFFS(rx)[paren].start) != -1 && - (t = RX_OFFS(rx)[paren].end) != -1) - { - SSize_t i; + SSize_t s; + SSize_t t; + if (paren < 0) + return 0; + if (paren <= (I32)RX_NPARENS(rx) && + (s = RX_OFFS(rx)[paren].start) != -1 && + (t = RX_OFFS(rx)[paren].end) != -1) + { + SSize_t i; if (n == '+') /* @+ */ - i = t; + i = t; else if (n == '-') /* @- */ - i = s; + i = s; else { /* @^CAPTURE @{^CAPTURE} */ CALLREG_NUMBUF_FETCH(rx,paren,sv); return 0; } - if (RX_MATCH_UTF8(rx)) { - const char * const b = RX_SUBBEG(rx); - if (b) - i = RX_SUBCOFFSET(rx) + + if (RX_MATCH_UTF8(rx)) { + const char * const b = RX_SUBBEG(rx); + if (b) + i = RX_SUBCOFFSET(rx) + utf8_length((U8*)b, (U8*)(b-RX_SUBOFFSET(rx)+i)); - } + } - sv_setuv(sv, i); - return 0; - } - } + sv_setuv(sv, i); + return 0; + } + } } sv_set_undef(sv); return 0; @@ -764,10 +764,10 @@ Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg) if (SvPOK(sv)) { \ STRLEN len = SvCUR(sv); \ char * const p = SvPVX(sv); \ - while (len > 0 && isSPACE(p[len-1])) \ - --len; \ - SvCUR_set(sv, len); \ - p[len] = '\0'; \ + while (len > 0 && isSPACE(p[len-1])) \ + --len; \ + SvCUR_set(sv, len); \ + p[len] = '\0'; \ } \ } STMT_END @@ -777,21 +777,21 @@ Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv) PERL_ARGS_ASSERT_EMULATE_COP_IO; if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT))) - sv_set_undef(sv); + sv_set_undef(sv); else { SvPVCLEAR(sv); - SvUTF8_off(sv); - if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) { - SV *const value = cop_hints_fetch_pvs(c, "open<", 0); - assert(value); - sv_catsv(sv, value); - } - sv_catpvs(sv, "\0"); - if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) { - SV *const value = cop_hints_fetch_pvs(c, "open>", 0); - assert(value); - sv_catsv(sv, value); - } + SvUTF8_off(sv); + if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) { + SV *const value = cop_hints_fetch_pvs(c, "open<", 0); + assert(value); + sv_catsv(sv, value); + } + sv_catpvs(sv, "\0"); + if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) { + SV *const value = cop_hints_fetch_pvs(c, "open>", 0); + assert(value); + sv_catsv(sv, value); + } } } @@ -806,7 +806,7 @@ S_fixup_errno_string(pTHX_ SV* sv) assert(SvOK(sv)); if(strEQ(SvPVX(sv), "")) { - sv_catpv(sv, UNKNOWN_ERRNO_MSG); + sv_catpv(sv, UNKNOWN_ERRNO_MSG); } else { @@ -877,13 +877,13 @@ Perl_sv_string_from_errnum(pTHX_ int errnum, SV *tgtsv) { char const *errstr; if(!tgtsv) - tgtsv = sv_newmortal(); + tgtsv = sv_newmortal(); errstr = my_strerror(errnum); if(errstr) { - sv_setpv(tgtsv, errstr); - fixup_errno_string(tgtsv); + sv_setpv(tgtsv, errstr); + fixup_errno_string(tgtsv); } else { - SvPVCLEAR(tgtsv); + SvPVCLEAR(tgtsv); } return tgtsv; } @@ -918,26 +918,26 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) nextchar = *remaining; switch (*mg->mg_ptr) { case '\001': /* ^A */ - if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget); - else + if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget); + else sv_set_undef(sv); - if (SvTAINTED(PL_bodytarget)) - SvTAINTED_on(sv); - break; + if (SvTAINTED(PL_bodytarget)) + SvTAINTED_on(sv); + break; case '\003': /* ^C, ^CHILD_ERROR_NATIVE */ - if (nextchar == '\0') { - sv_setiv(sv, (IV)PL_minus_c); - } - else if (strEQ(remaining, "HILD_ERROR_NATIVE")) { - sv_setiv(sv, (IV)STATUS_NATIVE); + if (nextchar == '\0') { + sv_setiv(sv, (IV)PL_minus_c); } - break; + else if (strEQ(remaining, "HILD_ERROR_NATIVE")) { + sv_setiv(sv, (IV)STATUS_NATIVE); + } + break; case '\004': /* ^D */ - sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK)); - break; + sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK)); + break; case '\005': /* ^E */ - if (nextchar != '\0') { + if (nextchar != '\0') { if (strEQ(remaining, "NCODING")) sv_set_undef(sv); break; @@ -987,13 +987,13 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) # endif SvRTRIM(sv); SvNOK_on(sv); /* what a wonderful hack! */ - break; + break; #endif /* End of platforms with special handling for $^E; others just fall through to $! */ /* FALLTHROUGH */ case '!': - { + { dSAVE_ERRNO; #ifdef VMS sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno)); @@ -1017,224 +1017,219 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) SvPOK_off(sv); } RESTORE_ERRNO; - } + } - SvRTRIM(sv); - SvNOK_on(sv); /* what a wonderful hack! */ - break; + SvRTRIM(sv); + SvNOK_on(sv); /* what a wonderful hack! */ + break; case '\006': /* ^F */ if (nextchar == '\0') { sv_setiv(sv, (IV)PL_maxsysfd); } - break; + break; case '\007': /* ^GLOBAL_PHASE */ - if (strEQ(remaining, "LOBAL_PHASE")) { - sv_setpvn(sv, PL_phase_names[PL_phase], - strlen(PL_phase_names[PL_phase])); - } - break; + if (strEQ(remaining, "LOBAL_PHASE")) { + sv_setpvn(sv, PL_phase_names[PL_phase], + strlen(PL_phase_names[PL_phase])); + } + break; case '\010': /* ^H */ - sv_setuv(sv, PL_hints); - break; + sv_setuv(sv, PL_hints); + break; case '\011': /* ^I */ /* NOT \t in EBCDIC */ - sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */ - break; + sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */ + break; case '\014': /* ^LAST_FH */ - if (strEQ(remaining, "AST_FH")) { - if (PL_last_in_gv && (SV*)PL_last_in_gv != &PL_sv_undef) { - assert(isGV_with_GP(PL_last_in_gv)); - SV_CHECK_THINKFIRST_COW_DROP(sv); - prepare_SV_for_RV(sv); - SvOK_off(sv); - SvRV_set(sv, SvREFCNT_inc_simple_NN(PL_last_in_gv)); - SvROK_on(sv); - sv_rvweaken(sv); - } - else + if (strEQ(remaining, "AST_FH")) { + if (PL_last_in_gv && (SV*)PL_last_in_gv != &PL_sv_undef) { + assert(isGV_with_GP(PL_last_in_gv)); + SV_CHECK_THINKFIRST_COW_DROP(sv); + prepare_SV_for_RV(sv); + SvOK_off(sv); + SvRV_set(sv, SvREFCNT_inc_simple_NN(PL_last_in_gv)); + SvROK_on(sv); + sv_rvweaken(sv); + } + else sv_set_undef(sv); - } - break; + } + break; case '\017': /* ^O & ^OPEN */ - if (nextchar == '\0') { - sv_setpv(sv, PL_osname); - SvTAINTED_off(sv); - } - else if (strEQ(remaining, "PEN")) { - Perl_emulate_cop_io(aTHX_ &PL_compiling, sv); - } - break; + if (nextchar == '\0') { + sv_setpv(sv, PL_osname); + SvTAINTED_off(sv); + } + else if (strEQ(remaining, "PEN")) { + Perl_emulate_cop_io(aTHX_ &PL_compiling, sv); + } + break; case '\020': sv_setiv(sv, (IV)PL_perldb); - break; + break; case '\023': /* ^S */ - if (nextchar == '\0') { - if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING) - SvOK_off(sv); - else if (PL_in_eval) - sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE)); - else - sv_setiv(sv, 0); - } - else if (strEQ(remaining, "AFE_LOCALES")) { + if (nextchar == '\0') { + if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING) + SvOK_off(sv); + else if (PL_in_eval) + sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE)); + else + sv_setiv(sv, 0); + } + else if (strEQ(remaining, "AFE_LOCALES")) { #if ! defined(USE_ITHREADS) || defined(USE_THREAD_SAFE_LOCALE) - sv_setuv(sv, (UV) 1); + sv_setuv(sv, (UV) 1); #else - sv_setuv(sv, (UV) 0); + sv_setuv(sv, (UV) 0); #endif } - break; + break; case '\024': /* ^T */ - if (nextchar == '\0') { + if (nextchar == '\0') { #ifdef BIG_TIME sv_setnv(sv, PL_basetime); #else sv_setiv(sv, (IV)PL_basetime); #endif } - else if (strEQ(remaining, "AINT")) + else if (strEQ(remaining, "AINT")) sv_setiv(sv, TAINTING_get - ? (TAINT_WARN_get || PL_unsafe ? -1 : 1) - : 0); + ? (TAINT_WARN_get || PL_unsafe ? -1 : 1) + : 0); break; case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */ - if (strEQ(remaining, "NICODE")) - sv_setuv(sv, (UV) PL_unicode); - else if (strEQ(remaining, "TF8LOCALE")) - sv_setuv(sv, (UV) PL_utf8locale); - else if (strEQ(remaining, "TF8CACHE")) - sv_setiv(sv, (IV) PL_utf8cache); + if (strEQ(remaining, "NICODE")) + sv_setuv(sv, (UV) PL_unicode); + else if (strEQ(remaining, "TF8LOCALE")) + sv_setuv(sv, (UV) PL_utf8locale); + else if (strEQ(remaining, "TF8CACHE")) + sv_setiv(sv, (IV) PL_utf8cache); break; case '\027': /* ^W & $^WARNING_BITS */ - if (nextchar == '\0') - sv_setiv(sv, (IV)cBOOL(PL_dowarn & G_WARN_ON)); - else if (strEQ(remaining, "ARNING_BITS")) { - if (PL_compiling.cop_warnings == pWARN_NONE) { - sv_setpvn(sv, WARN_NONEstring, WARNsize) ; - } - else if (PL_compiling.cop_warnings == pWARN_STD) { + if (nextchar == '\0') + sv_setiv(sv, (IV)cBOOL(PL_dowarn & G_WARN_ON)); + else if (strEQ(remaining, "ARNING_BITS")) { + if (PL_compiling.cop_warnings == pWARN_NONE) { + sv_setpvn(sv, WARN_NONEstring, WARNsize) ; + } + else if (PL_compiling.cop_warnings == pWARN_STD) { goto set_undef; - } + } else if (PL_compiling.cop_warnings == pWARN_ALL) { - sv_setpvn(sv, WARN_ALLstring, WARNsize); - } + sv_setpvn(sv, WARN_ALLstring, WARNsize); + } else { - sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1), - *PL_compiling.cop_warnings); - } - } -#ifdef WIN32 - else if (strEQ(remaining, "IN32_SLOPPY_STAT")) { - sv_setiv(sv, w32_sloppystat); - } -#endif - break; + sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1), + *PL_compiling.cop_warnings); + } + } + break; case '+': - if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { - paren = RX_LASTPAREN(rx); - if (paren) + if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { + paren = RX_LASTPAREN(rx); + if (paren) goto do_numbuf_fetch; - } + } goto set_undef; case '\016': /* ^N */ - if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { - paren = RX_LASTCLOSEPAREN(rx); - if (paren) + if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { + paren = RX_LASTCLOSEPAREN(rx); + if (paren) goto do_numbuf_fetch; - } + } goto set_undef; case '.': - if (GvIO(PL_last_in_gv)) { - sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv))); - } - break; + if (GvIO(PL_last_in_gv)) { + sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv))); + } + break; case '?': - { - sv_setiv(sv, (IV)STATUS_CURRENT); + { + sv_setiv(sv, (IV)STATUS_CURRENT); #ifdef COMPLEX_STATUS - SvUPGRADE(sv, SVt_PVLV); - LvTARGOFF(sv) = PL_statusvalue; - LvTARGLEN(sv) = PL_statusvalue_vms; + SvUPGRADE(sv, SVt_PVLV); + LvTARGOFF(sv) = PL_statusvalue; + LvTARGLEN(sv) = PL_statusvalue_vms; #endif - } - break; + } + break; case '^': - if (GvIOp(PL_defoutgv)) - s = IoTOP_NAME(GvIOp(PL_defoutgv)); - if (s) - sv_setpv(sv,s); - else { - sv_setpv(sv,GvENAME(PL_defoutgv)); - sv_catpvs(sv,"_TOP"); - } - break; + if (GvIOp(PL_defoutgv)) + s = IoTOP_NAME(GvIOp(PL_defoutgv)); + if (s) + sv_setpv(sv,s); + else { + sv_setpv(sv,GvENAME(PL_defoutgv)); + sv_catpvs(sv,"_TOP"); + } + break; case '~': - if (GvIOp(PL_defoutgv)) - s = IoFMT_NAME(GvIOp(PL_defoutgv)); - if (!s) - s = GvENAME(PL_defoutgv); - sv_setpv(sv,s); - break; + if (GvIOp(PL_defoutgv)) + s = IoFMT_NAME(GvIOp(PL_defoutgv)); + if (!s) + s = GvENAME(PL_defoutgv); + sv_setpv(sv,s); + break; case '=': - if (GvIO(PL_defoutgv)) - sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv))); - break; + if (GvIO(PL_defoutgv)) + sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv))); + break; case '-': - if (GvIO(PL_defoutgv)) - sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv))); - break; + if (GvIO(PL_defoutgv)) + sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv))); + break; case '%': - if (GvIO(PL_defoutgv)) - sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv))); - break; + if (GvIO(PL_defoutgv)) + sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv))); + break; case ':': case '/': - break; + break; case '[': - sv_setiv(sv, 0); - break; + sv_setiv(sv, 0); + break; case '|': - if (GvIO(PL_defoutgv)) - sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 ); - break; + if (GvIO(PL_defoutgv)) + sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 ); + break; case '\\': - if (PL_ors_sv) - sv_copypv(sv, PL_ors_sv); - else + if (PL_ors_sv) + sv_copypv(sv, PL_ors_sv); + else goto set_undef; - break; + break; case '$': /* $$ */ - { - IV const pid = (IV)PerlProc_getpid(); - if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) { - /* never set manually, or at least not since last fork */ - sv_setiv(sv, pid); - /* never unsafe, even if reading in a tainted expression */ - SvTAINTED_off(sv); - } - /* else a value has been assigned manually, so do nothing */ - } - break; + { + IV const pid = (IV)PerlProc_getpid(); + if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) { + /* never set manually, or at least not since last fork */ + sv_setiv(sv, pid); + /* never unsafe, even if reading in a tainted expression */ + SvTAINTED_off(sv); + } + /* else a value has been assigned manually, so do nothing */ + } + break; case '<': sv_setuid(sv, PerlProc_getuid()); - break; + break; case '>': sv_setuid(sv, PerlProc_geteuid()); - break; + break; case '(': sv_setgid(sv, PerlProc_getgid()); - goto add_groups; + goto add_groups; case ')': sv_setgid(sv, PerlProc_getegid()); add_groups: #ifdef HAS_GETGROUPS - { - Groups_t *gary = NULL; + { + Groups_t *gary = NULL; I32 num_groups = getgroups(0, gary); if (num_groups > 0) { I32 i; @@ -1244,12 +1239,12 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) Perl_sv_catpvf(aTHX_ sv, " %" IVdf, (IV)gary[i]); Safefree(gary); } - } - (void)SvIOK_on(sv); /* what a wonderful hack! */ + } + (void)SvIOK_on(sv); /* what a wonderful hack! */ #endif - break; + break; case '0': - break; + break; } return 0; @@ -1266,7 +1261,7 @@ Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_GETUVAR; if (uf && uf->uf_val) - (*uf->uf_val)(aTHX_ uf->uf_index, sv); + (*uf->uf_val)(aTHX_ uf->uf_index, sv); return 0; } @@ -1298,76 +1293,76 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg) /* We just undefd an environment var. Is a replacement */ /* waiting in the wings? */ if (!len) { - SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE); - if (valp) - s = SvOK(*valp) ? SvPV_const(*valp, len) : ""; + SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE); + if (valp) + s = SvOK(*valp) ? SvPV_const(*valp, len) : ""; } #endif #if !defined(OS2) && !defined(WIN32) && !defined(MSDOS) - /* And you'll never guess what the dog had */ - /* in its mouth... */ + /* And you'll never guess what the dog had */ + /* in its mouth... */ if (TAINTING_get) { - MgTAINTEDDIR_off(mg); + MgTAINTEDDIR_off(mg); #ifdef VMS - if (s && memEQs(key, klen, "DCL$PATH")) { - char pathbuf[256], eltbuf[256], *cp, *elt; - int i = 0, j = 0; - - my_strlcpy(eltbuf, s, sizeof(eltbuf)); - elt = eltbuf; - do { /* DCL$PATH may be a search list */ - while (1) { /* as may dev portion of any element */ - if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) { - if ( *(cp+1) == '.' || *(cp+1) == '-' || - cando_by_name(S_IWUSR,0,elt) ) { - MgTAINTEDDIR_on(mg); - return 0; - } - } - if ((cp = strchr(elt, ':')) != NULL) - *cp = '\0'; - if (my_trnlnm(elt, eltbuf, j++)) - elt = eltbuf; - else - break; - } - j = 0; - } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf)); - } + if (s && memEQs(key, klen, "DCL$PATH")) { + char pathbuf[256], eltbuf[256], *cp, *elt; + int i = 0, j = 0; + + my_strlcpy(eltbuf, s, sizeof(eltbuf)); + elt = eltbuf; + do { /* DCL$PATH may be a search list */ + while (1) { /* as may dev portion of any element */ + if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) { + if ( *(cp+1) == '.' || *(cp+1) == '-' || + cando_by_name(S_IWUSR,0,elt) ) { + MgTAINTEDDIR_on(mg); + return 0; + } + } + if ((cp = strchr(elt, ':')) != NULL) + *cp = '\0'; + if (my_trnlnm(elt, eltbuf, j++)) + elt = eltbuf; + else + break; + } + j = 0; + } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf)); + } #endif /* VMS */ - if (s && memEQs(key, klen, "PATH")) { - const char * const strend = s + len; + if (s && memEQs(key, klen, "PATH")) { + const char * const strend = s + len; /* set MGf_TAINTEDDIR if any component of the new path is * relative or world-writeable */ - while (s < strend) { - char tmpbuf[256]; - Stat_t st; - I32 i; + while (s < strend) { + char tmpbuf[256]; + Stat_t st; + I32 i; #ifdef __VMS /* Hmm. How do we get $Config{path_sep} from C? */ - const char path_sep = PL_perllib_sep; + const char path_sep = PL_perllib_sep; #else - const char path_sep = ':'; + const char path_sep = ':'; #endif - s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf, - s, strend, path_sep, &i); - s++; - if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */ + s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf, + s, strend, path_sep, &i); + s++; + if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */ #ifdef __VMS - /* no colon thus no device name -- assume relative path */ - || (PL_perllib_sep != ':' && !strchr(tmpbuf, ':')) - /* Using Unix separator, e.g. under bash, so act line Unix */ - || (PL_perllib_sep == ':' && *tmpbuf != '/') + /* no colon thus no device name -- assume relative path */ + || (PL_perllib_sep != ':' && !strchr(tmpbuf, ':')) + /* Using Unix separator, e.g. under bash, so act line Unix */ + || (PL_perllib_sep == ':' && *tmpbuf != '/') #else - || *tmpbuf != '/' /* no starting slash -- assume relative path */ + || *tmpbuf != '/' /* no starting slash -- assume relative path */ #endif - || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) { - MgTAINTEDDIR_on(mg); - return 0; - } - } - } + || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) { + MgTAINTEDDIR_on(mg); + return 0; + } + } + } } #endif /* neither OS2 nor WIN32 nor MSDOS */ @@ -1392,14 +1387,14 @@ Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg) Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system"); #else if (PL_localizing) { - HE* entry; - my_clearenv(); - hv_iterinit(MUTABLE_HV(sv)); - while ((entry = hv_iternext(MUTABLE_HV(sv)))) { - I32 keylen; - my_setenv(hv_iterkey(entry, &keylen), - SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry))); - } + HE* entry; + my_clearenv(); + hv_iterinit(MUTABLE_HV(sv)); + while ((entry = hv_iternext(MUTABLE_HV(sv)))) { + I32 keylen; + my_setenv(hv_iterkey(entry, &keylen), + SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry))); + } } #endif return 0; @@ -1443,26 +1438,26 @@ Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) } if (i > 0) { - if(PL_psig_ptr[i]) - sv_setsv(sv,PL_psig_ptr[i]); - else { - Sighandler_t sigstate = rsignal_state(i); + if(PL_psig_ptr[i]) + sv_setsv(sv,PL_psig_ptr[i]); + else { + Sighandler_t sigstate = rsignal_state(i); #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS - if (PL_sig_handlers_initted && PL_sig_ignoring[i]) - sigstate = SIG_IGN; + if (PL_sig_handlers_initted && PL_sig_ignoring[i]) + sigstate = SIG_IGN; #endif #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS - if (PL_sig_handlers_initted && PL_sig_defaulting[i]) - sigstate = SIG_DFL; + if (PL_sig_handlers_initted && PL_sig_defaulting[i]) + sigstate = SIG_DFL; #endif - /* cache state so we don't fetch it again */ - if(sigstate == (Sighandler_t) SIG_IGN) - sv_setpvs(sv,"IGNORE"); - else + /* cache state so we don't fetch it again */ + if(sigstate == (Sighandler_t) SIG_IGN) + sv_setpvs(sv,"IGNORE"); + else sv_set_undef(sv); - PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv); - SvTEMP_off(sv); - } + PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv); + SvTEMP_off(sv); + } } return 0; } @@ -1536,17 +1531,17 @@ Perl_csighandler3(int sig, Siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSE #endif if ( #ifdef SIGILL - sig == SIGILL || + sig == SIGILL || #endif #ifdef SIGBUS - sig == SIGBUS || + sig == SIGBUS || #endif #ifdef SIGSEGV - sig == SIGSEGV || + sig == SIGSEGV || #endif - (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)) - /* Call the perl level handler now-- - * with risk we may be in malloc() or being destructed etc. */ + (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)) + /* Call the perl level handler now-- + * with risk we may be in malloc() or being destructed etc. */ { if (PL_sighandlerp == Perl_sighandler) /* default handler, so can call perly_sighandler() directly @@ -1562,18 +1557,18 @@ Perl_csighandler3(int sig, Siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSE #endif } else { - if (!PL_psig_pend) return; - /* Set a flag to say this signal is pending, that is awaiting delivery after - * the current Perl opcode completes */ - PL_psig_pend[sig]++; + if (!PL_psig_pend) return; + /* Set a flag to say this signal is pending, that is awaiting delivery after + * the current Perl opcode completes */ + PL_psig_pend[sig]++; #ifndef SIG_PENDING_DIE_COUNT # define SIG_PENDING_DIE_COUNT 120 #endif - /* Add one to say _a_ signal is pending */ - if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT) - Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded", - (unsigned long)SIG_PENDING_DIE_COUNT); + /* Add one to say _a_ signal is pending */ + if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT) + Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded", + (unsigned long)SIG_PENDING_DIE_COUNT); } } @@ -1613,31 +1608,31 @@ Perl_despatch_signals(pTHX) int sig; PL_sig_pending = 0; for (sig = 1; sig < SIG_SIZE; sig++) { - if (PL_psig_pend[sig]) { - dSAVE_ERRNO; + if (PL_psig_pend[sig]) { + dSAVE_ERRNO; #ifdef HAS_SIGPROCMASK - /* From sigaction(2) (FreeBSD man page): - * | Signal routines normally execute with the signal that - * | caused their invocation blocked, but other signals may - * | yet occur. - * Emulation of this behavior (from within Perl) is enabled - * using sigprocmask - */ - int was_blocked; - sigset_t newset, oldset; - - sigemptyset(&newset); - sigaddset(&newset, sig); - sigprocmask(SIG_BLOCK, &newset, &oldset); - was_blocked = sigismember(&oldset, sig); - if (!was_blocked) { - SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t)); - ENTER; - SAVEFREESV(save_sv); - SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv)); - } -#endif - PL_psig_pend[sig] = 0; + /* From sigaction(2) (FreeBSD man page): + * | Signal routines normally execute with the signal that + * | caused their invocation blocked, but other signals may + * | yet occur. + * Emulation of this behavior (from within Perl) is enabled + * using sigprocmask + */ + int was_blocked; + sigset_t newset, oldset; + + sigemptyset(&newset); + sigaddset(&newset, sig); + sigprocmask(SIG_BLOCK, &newset, &oldset); + was_blocked = sigismember(&oldset, sig); + if (!was_blocked) { + SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t)); + ENTER; + SAVEFREESV(save_sv); + SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv)); + } +#endif + PL_psig_pend[sig] = 0; if (PL_sighandlerp == Perl_sighandler) /* default handler, so can call perly_sighandler() directly * rather than via Perl_sighandler, passing the extra @@ -1652,11 +1647,11 @@ Perl_despatch_signals(pTHX) #endif #ifdef HAS_SIGPROCMASK - if (!was_blocked) - LEAVE; + if (!was_blocked) + LEAVE; #endif - RESTORE_ERRNO; - } + RESTORE_ERRNO; + } } } @@ -1682,134 +1677,134 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) if (*s == '_') { if (memEQs(s, len, "__DIE__")) - svp = &PL_diehook; - else if (memEQs(s, len, "__WARN__") - && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) { - /* Merge the existing behaviours, which are as follows: - magic_setsig, we always set svp to &PL_warnhook - (hence we always change the warnings handler) - For magic_clearsig, we don't change the warnings handler if it's - set to the &PL_warnhook. */ - svp = &PL_warnhook; + svp = &PL_diehook; + else if (memEQs(s, len, "__WARN__") + && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) { + /* Merge the existing behaviours, which are as follows: + magic_setsig, we always set svp to &PL_warnhook + (hence we always change the warnings handler) + For magic_clearsig, we don't change the warnings handler if it's + set to the &PL_warnhook. */ + svp = &PL_warnhook; } else if (sv) { SV *tmp = sv_newmortal(); Perl_croak(aTHX_ "No such hook: %s", pv_pretty(tmp, s, len, 0, NULL, NULL, 0)); } - i = 0; - if (svp && *svp) { - if (*svp != PERL_WARNHOOK_FATAL) - to_dec = *svp; - *svp = NULL; - } + i = 0; + if (svp && *svp) { + if (*svp != PERL_WARNHOOK_FATAL) + to_dec = *svp; + *svp = NULL; + } } else { - i = (I16)mg->mg_private; - if (!i) { - i = whichsig_pvn(s, len); /* ...no, a brick */ - mg->mg_private = (U16)i; - } - if (i <= 0) { - if (sv) { + i = (I16)mg->mg_private; + if (!i) { + i = whichsig_pvn(s, len); /* ...no, a brick */ + mg->mg_private = (U16)i; + } + if (i <= 0) { + if (sv) { SV *tmp = sv_newmortal(); - Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", + Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", pv_pretty(tmp, s, len, 0, NULL, NULL, 0)); } - return 0; - } + return 0; + } #ifdef HAS_SIGPROCMASK - /* Avoid having the signal arrive at a bad time, if possible. */ - sigemptyset(&set); - sigaddset(&set,i); - sigprocmask(SIG_BLOCK, &set, &save); - ENTER; - save_sv = newSVpvn((char *)(&save), sizeof(sigset_t)); - SAVEFREESV(save_sv); - SAVEDESTRUCTOR_X(restore_sigmask, save_sv); -#endif - PERL_ASYNC_CHECK(); + /* Avoid having the signal arrive at a bad time, if possible. */ + sigemptyset(&set); + sigaddset(&set,i); + sigprocmask(SIG_BLOCK, &set, &save); + ENTER; + save_sv = newSVpvn((char *)(&save), sizeof(sigset_t)); + SAVEFREESV(save_sv); + SAVEDESTRUCTOR_X(restore_sigmask, save_sv); +#endif + PERL_ASYNC_CHECK(); #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) - if (!PL_sig_handlers_initted) Perl_csighandler_init(); + if (!PL_sig_handlers_initted) Perl_csighandler_init(); #endif #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS - PL_sig_ignoring[i] = 0; + PL_sig_ignoring[i] = 0; #endif #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS - PL_sig_defaulting[i] = 0; -#endif - to_dec = PL_psig_ptr[i]; - if (sv) { - PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv); - SvTEMP_off(sv); /* Make sure it doesn't go away on us */ - - /* Signals don't change name during the program's execution, so once - they're cached in the appropriate slot of PL_psig_name, they can - stay there. - - Ideally we'd find some way of making SVs at (C) compile time, or - at least, doing most of the work. */ - if (!PL_psig_name[i]) { - const char* name = PL_sig_name[i]; - PL_psig_name[i] = newSVpvn(name, strlen(name)); - SvREADONLY_on(PL_psig_name[i]); - } - } else { - SvREFCNT_dec(PL_psig_name[i]); - PL_psig_name[i] = NULL; - PL_psig_ptr[i] = NULL; - } + PL_sig_defaulting[i] = 0; +#endif + to_dec = PL_psig_ptr[i]; + if (sv) { + PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv); + SvTEMP_off(sv); /* Make sure it doesn't go away on us */ + + /* Signals don't change name during the program's execution, so once + they're cached in the appropriate slot of PL_psig_name, they can + stay there. + + Ideally we'd find some way of making SVs at (C) compile time, or + at least, doing most of the work. */ + if (!PL_psig_name[i]) { + const char* name = PL_sig_name[i]; + PL_psig_name[i] = newSVpvn(name, strlen(name)); + SvREADONLY_on(PL_psig_name[i]); + } + } else { + SvREFCNT_dec(PL_psig_name[i]); + PL_psig_name[i] = NULL; + PL_psig_ptr[i] = NULL; + } } if (sv && (isGV_with_GP(sv) || SvROK(sv))) { - if (i) { - (void)rsignal(i, PL_csighandlerp); - } - else - *svp = SvREFCNT_inc_simple_NN(sv); + if (i) { + (void)rsignal(i, PL_csighandlerp); + } + else + *svp = SvREFCNT_inc_simple_NN(sv); } else { - if (sv && SvOK(sv)) { - s = SvPV_force(sv, len); - } else { - sv = NULL; - } - if (sv && memEQs(s, len,"IGNORE")) { - if (i) { + if (sv && SvOK(sv)) { + s = SvPV_force(sv, len); + } else { + sv = NULL; + } + if (sv && memEQs(s, len,"IGNORE")) { + if (i) { #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS - PL_sig_ignoring[i] = 1; - (void)rsignal(i, PL_csighandlerp); + PL_sig_ignoring[i] = 1; + (void)rsignal(i, PL_csighandlerp); #else - (void)rsignal(i, (Sighandler_t) SIG_IGN); + (void)rsignal(i, (Sighandler_t) SIG_IGN); #endif - } - } - else if (!sv || memEQs(s, len,"DEFAULT") || !len) { - if (i) { + } + } + else if (!sv || memEQs(s, len,"DEFAULT") || !len) { + if (i) { #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS - PL_sig_defaulting[i] = 1; - (void)rsignal(i, PL_csighandlerp); + PL_sig_defaulting[i] = 1; + (void)rsignal(i, PL_csighandlerp); #else - (void)rsignal(i, (Sighandler_t) SIG_DFL); -#endif - } - } - else { - /* - * We should warn if HINT_STRICT_REFS, but without - * access to a known hint bit in a known OP, we can't - * tell whether HINT_STRICT_REFS is in force or not. - */ - if (!memchr(s, ':', len) && !memchr(s, '\'', len)) - Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"), - SV_GMAGIC); - if (i) - (void)rsignal(i, PL_csighandlerp); - else - *svp = SvREFCNT_inc_simple_NN(sv); - } + (void)rsignal(i, (Sighandler_t) SIG_DFL); +#endif + } + } + else { + /* + * We should warn if HINT_STRICT_REFS, but without + * access to a known hint bit in a known OP, we can't + * tell whether HINT_STRICT_REFS is in force or not. + */ + if (!memchr(s, ':', len) && !memchr(s, '\'', len)) + Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"), + SV_GMAGIC); + if (i) + (void)rsignal(i, PL_csighandlerp); + else + *svp = SvREFCNT_inc_simple_NN(sv); + } } #ifdef HAS_SIGPROCMASK if(i) - LEAVE; + LEAVE; #endif SvREFCNT_dec(to_dec); return 0; @@ -1824,7 +1819,7 @@ Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg) /* Skip _isaelem because _isa will handle it shortly */ if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem) - return 0; + return 0; return magic_clearisa(NULL, mg); } @@ -1840,23 +1835,23 @@ Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg) if(PL_phase == PERL_PHASE_DESTRUCT) return 0; if (sv) - av_clear(MUTABLE_AV(sv)); + av_clear(MUTABLE_AV(sv)); if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj)) - /* This occurs with setisa_elem magic, which calls this - same function. */ - mg = mg_find(mg->mg_obj, PERL_MAGIC_isa); + /* This occurs with setisa_elem magic, which calls this + same function. */ + mg = mg_find(mg->mg_obj, PERL_MAGIC_isa); assert(mg); if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */ - SV **svp = AvARRAY((AV *)mg->mg_obj); - I32 items = AvFILLp((AV *)mg->mg_obj) + 1; - while (items--) { - stash = GvSTASH((GV *)*svp++); - if (stash && HvENAME(stash)) mro_isa_changed_in(stash); - } + SV **svp = AvARRAY((AV *)mg->mg_obj); + I32 items = AvFILLp((AV *)mg->mg_obj) + 1; + while (items--) { + stash = GvSTASH((GV *)*svp++); + if (stash && HvENAME(stash)) mro_isa_changed_in(stash); + } - return 0; + return 0; } stash = GvSTASH( @@ -1866,7 +1861,7 @@ Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg) /* The stash may have been detached from the symbol table, so check its name before doing anything. */ if (stash && HvENAME_get(stash)) - mro_isa_changed_in(stash); + mro_isa_changed_in(stash); return 0; } @@ -1883,10 +1878,10 @@ Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg) if (hv) { (void) hv_iterinit(hv); if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) - i = HvUSEDKEYS(hv); + i = HvUSEDKEYS(hv); else { - while (hv_iternext(hv)) - i++; + while (hv_iternext(hv)) + i++; } } @@ -1900,7 +1895,7 @@ Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_SETNKEYS; PERL_UNUSED_ARG(mg); if (LvTARG(sv)) { - hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv)); + hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv)); } return 0; } @@ -1934,7 +1929,7 @@ Returns the SV (if any) returned by the method, or C on failure. SV* Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags, - U32 argc, ...) + U32 argc, ...) { dSP; SV* ret = NULL; @@ -1944,11 +1939,11 @@ Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags, ENTER; if (flags & G_WRITING_TO_STDERR) { - SAVETMPS; + SAVETMPS; - save_re_context(); - SAVESPTR(PL_stderrgv); - PL_stderrgv = NULL; + save_re_context(); + SAVESPTR(PL_stderrgv); + PL_stderrgv = NULL; } PUSHSTACKi(PERLSI_MAGIC); @@ -1959,31 +1954,31 @@ Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags, EXTEND(SP, (I32)argc+1); PUSHs(SvTIED_obj(sv, mg)); if (flags & G_UNDEF_FILL) { - while (argc--) { - PUSHs(&PL_sv_undef); - } + while (argc--) { + PUSHs(&PL_sv_undef); + } } else if (argc > 0) { - va_list args; - va_start(args, argc); + va_list args; + va_start(args, argc); - do { - SV *const this_sv = va_arg(args, SV *); - PUSHs(this_sv); - } while (--argc); + do { + SV *const this_sv = va_arg(args, SV *); + PUSHs(this_sv); + } while (--argc); - va_end(args); + va_end(args); } PUTBACK; if (flags & G_DISCARD) { - call_sv(meth, G_SCALAR|G_DISCARD|G_METHOD_NAMED); + call_sv(meth, G_SCALAR|G_DISCARD|G_METHOD_NAMED); } else { - if (call_sv(meth, G_SCALAR|G_METHOD_NAMED)) - ret = *PL_stack_sp--; + if (call_sv(meth, G_SCALAR|G_METHOD_NAMED)) + ret = *PL_stack_sp--; } POPSTACK; if (flags & G_WRITING_TO_STDERR) - FREETMPS; + FREETMPS; LEAVE; return ret; } @@ -1999,18 +1994,18 @@ S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags, PERL_ARGS_ASSERT_MAGIC_METHCALL1; if (mg->mg_ptr) { - if (mg->mg_len >= 0) { - arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP); - } - else if (mg->mg_len == HEf_SVKEY) - arg1 = MUTABLE_SV(mg->mg_ptr); + if (mg->mg_len >= 0) { + arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP); + } + else if (mg->mg_len == HEf_SVKEY) + arg1 = MUTABLE_SV(mg->mg_ptr); } else if (mg->mg_type == PERL_MAGIC_tiedelem) { - arg1 = newSViv((IV)(mg->mg_len)); - sv_2mortal(arg1); + arg1 = newSViv((IV)(mg->mg_len)); + sv_2mortal(arg1); } if (!arg1) { - return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val); + return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val); } return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val); } @@ -2024,7 +2019,7 @@ S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth) ret = magic_methcall1(sv, mg, meth, 0, 1, NULL); if (ret) - sv_setsv(sv, ret); + sv_setsv(sv, ret); return 0; } @@ -2034,7 +2029,7 @@ Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_GETPACK; if (mg->mg_type == PERL_MAGIC_tiedelem) - mg->mg_flags |= MGf_GSKIP; + mg->mg_flags |= MGf_GSKIP; magic_methpack(sv,mg,SV_CONST(FETCH)); return 0; } @@ -2058,13 +2053,13 @@ Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg) * re-enabling magic on sv). */ if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint)) - && (tmg->mg_len & 1)) + && (tmg->mg_len & 1)) { - val = sv_mortalcopy(sv); - SvTAINTED_on(val); + val = sv_mortalcopy(sv); + SvTAINTED_on(val); } else - val = sv; + val = sv; magic_methcall1(sv, mg, SV_CONST(STORE), G_DISCARD, 2, val); return 0; @@ -2090,9 +2085,9 @@ Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg) retsv = magic_methcall1(sv, mg, SV_CONST(FETCHSIZE), 0, 1, NULL); if (retsv) { - retval = SvIV(retsv)-1; - if (retval < -1) - Perl_croak(aTHX_ "FETCHSIZE returned a negative value"); + retval = SvIV(retsv)-1; + if (retval < -1) + Perl_croak(aTHX_ "FETCHSIZE returned a negative value"); } return (U32) retval; } @@ -2114,9 +2109,9 @@ Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key) PERL_ARGS_ASSERT_MAGIC_NEXTPACK; ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(NEXTKEY), 0, 1, key) - : Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(FIRSTKEY), 0, 0); + : Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(FIRSTKEY), 0, 0); if (ret) - sv_setsv(key,ret); + sv_setsv(key,ret); return 0; } @@ -2152,7 +2147,7 @@ Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg) /* there is a SCALAR method that we can call */ retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, SV_CONST(SCALAR), 0, 0); if (!retval) - retval = &PL_sv_undef; + retval = &PL_sv_undef; return retval; } @@ -2172,23 +2167,23 @@ Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) /* Use sv_2iv instead of SvIV() as the former generates smaller code, and setting/clearing debugger breakpoints is not a hot path. */ svp = av_fetch(MUTABLE_AV(mg->mg_obj), - sv_2iv(MUTABLE_SV((mg)->mg_ptr)), FALSE); + sv_2iv(MUTABLE_SV((mg)->mg_ptr)), FALSE); if (svp && SvIOKp(*svp)) { - OP * const o = INT2PTR(OP*,SvIVX(*svp)); - if (o) { + OP * const o = INT2PTR(OP*,SvIVX(*svp)); + if (o) { #ifdef PERL_DEBUG_READONLY_OPS - Slab_to_rw(OpSLAB(o)); + Slab_to_rw(OpSLAB(o)); #endif - /* set or clear breakpoint in the relevant control op */ - if (SvTRUE(sv)) - o->op_flags |= OPf_SPECIAL; - else - o->op_flags &= ~OPf_SPECIAL; + /* set or clear breakpoint in the relevant control op */ + if (SvTRUE(sv)) + o->op_flags |= OPf_SPECIAL; + else + o->op_flags &= ~OPf_SPECIAL; #ifdef PERL_DEBUG_READONLY_OPS - Slab_to_ro(OpSLAB(o)); + Slab_to_ro(OpSLAB(o)); #endif - } + } } return 0; } @@ -2201,7 +2196,7 @@ Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_GETARYLEN; if (obj) { - sv_setiv(sv, AvFILL(obj)); + sv_setiv(sv, AvFILL(obj)); } else { sv_set_undef(sv); } @@ -2216,10 +2211,10 @@ Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_SETARYLEN; if (obj) { - av_fill(obj, SvIV(sv)); + av_fill(obj, SvIV(sv)); } else { - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), - "Attempt to set length of freed array"); + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), + "Attempt to set length of freed array"); } return 0; } @@ -2233,10 +2228,10 @@ Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg) /* Reset the iterator when the array is cleared */ if (sizeof(IV) == sizeof(SSize_t)) { - *((IV *) &(mg->mg_len)) = 0; + *((IV *) &(mg->mg_len)) = 0; } else { - if (mg->mg_ptr) - *((IV *) mg->mg_ptr) = 0; + if (mg->mg_ptr) + *((IV *) mg->mg_ptr) = 0; } return 0; @@ -2250,17 +2245,17 @@ Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg) /* during global destruction, mg_obj may already have been freed */ if (PL_in_clean_all) - return 0; + return 0; mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen); if (mg) { - /* arylen scalar holds a pointer back to the array, but doesn't own a - reference. Hence the we (the array) are about to go away with it - still pointing at us. Clear its pointer, else it would be pointing - at free memory. See the comment in sv_magic about reference loops, - and why it can't own a reference to us. */ - mg->mg_obj = 0; + /* arylen scalar holds a pointer back to the array, but doesn't own a + reference. Hence the we (the array) are about to go away with it + still pointing at us. Clear its pointer, else it would be pointing + at free memory. See the comment in sv_magic about reference loops, + and why it can't own a reference to us. */ + mg->mg_obj = 0; } return 0; } @@ -2275,11 +2270,11 @@ Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg) PERL_UNUSED_ARG(mg); if (found && found->mg_len != -1) { - STRLEN i = found->mg_len; - if (found->mg_flags & MGf_BYTES && DO_UTF8(lsv)) - i = sv_pos_b2u_flags(lsv, i, SV_GMAGIC|SV_CONST_RETURN); - sv_setuv(sv, i); - return 0; + STRLEN i = found->mg_len; + if (found->mg_flags & MGf_BYTES && DO_UTF8(lsv)) + i = sv_pos_b2u_flags(lsv, i, SV_GMAGIC|SV_CONST_RETURN); + sv_setuv(sv, i); + return 0; } sv_set_undef(sv); return 0; @@ -2299,13 +2294,13 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) found = mg_find_mglob(lsv); if (!found) { - if (!SvOK(sv)) - return 0; - found = sv_magicext_mglob(lsv); + if (!SvOK(sv)) + return 0; + found = sv_magicext_mglob(lsv); } else if (!SvOK(sv)) { - found->mg_len = -1; - return 0; + found->mg_len = -1; + return 0; } s = SvPV_const(lsv, len); @@ -2313,17 +2308,17 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) if (DO_UTF8(lsv)) { const STRLEN ulen = sv_or_pv_len_utf8(lsv, s, len); - if (ulen) - len = ulen; + if (ulen) + len = ulen; } if (pos < 0) { - pos += len; - if (pos < 0) - pos = 0; + pos += len; + if (pos < 0) + pos = 0; } else if (pos > (SSize_t)len) - pos = len; + pos = len; found->mg_len = pos; found->mg_flags &= ~(MGf_MINMATCH|MGf_BYTES); @@ -2346,17 +2341,17 @@ Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg) PERL_UNUSED_ARG(mg); if (!translate_substr_offsets( - SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len, - negoff ? -(IV)offs : (IV)offs, !negoff, - negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem + SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len, + negoff ? -(IV)offs : (IV)offs, !negoff, + negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem )) { - Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string"); + Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string"); sv_set_undef(sv); - return 0; + return 0; } if (SvUTF8(lsv)) - offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem); + offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem); sv_setpvn(sv, tmps + offs, rem); if (SvUTF8(lsv)) SvUTF8_on(sv); @@ -2379,36 +2374,36 @@ Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg) SvGETMAGIC(lsv); if (SvROK(lsv)) - Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), - "Attempt to use reference as lvalue in substr" - ); + Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), + "Attempt to use reference as lvalue in substr" + ); SvPV_force_nomg(lsv,lsv_len); if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv); if (!translate_substr_offsets( - lsv_len, - negoff ? -(IV)lvoff : (IV)lvoff, !negoff, - neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen + lsv_len, + negoff ? -(IV)lvoff : (IV)lvoff, !negoff, + neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen )) - Perl_croak(aTHX_ "substr outside of string"); + Perl_croak(aTHX_ "substr outside of string"); oldtarglen = lvlen; if (DO_UTF8(sv)) { - sv_utf8_upgrade_nomg(lsv); - lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN); - sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0); - newtarglen = sv_or_pv_len_utf8(sv, tmps, len); - SvUTF8_on(lsv); + sv_utf8_upgrade_nomg(lsv); + lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN); + sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0); + newtarglen = sv_or_pv_len_utf8(sv, tmps, len); + SvUTF8_on(lsv); } else if (SvUTF8(lsv)) { - const char *utf8; - lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN); - newtarglen = len; - utf8 = (char*)bytes_to_utf8((U8*)tmps, &len); - sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0); - Safefree(utf8); + const char *utf8; + lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN); + newtarglen = len; + utf8 = (char*)bytes_to_utf8((U8*)tmps, &len); + sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0); + Safefree(utf8); } else { - sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0); - newtarglen = len; + sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0); + newtarglen = len; } if (!neglen) LvTARGLEN(sv) = newtarglen; if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen; @@ -2437,9 +2432,9 @@ Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg) /* update taint status */ if (TAINT_get) - mg->mg_len |= 1; + mg->mg_len |= 1; else - mg->mg_len &= ~1; + mg->mg_len &= ~1; return 0; } @@ -2476,37 +2471,37 @@ Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg) if (!mg) mg = mg_find(sv, PERL_MAGIC_defelem); assert(mg); if (LvTARGLEN(sv)) { - if (mg->mg_obj) { - SV * const ahv = LvTARG(sv); - HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0); + if (mg->mg_obj) { + SV * const ahv = LvTARG(sv); + HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0); if (he) targ = HeVAL(he); - } - else if (LvSTARGOFF(sv) >= 0) { - AV *const av = MUTABLE_AV(LvTARG(sv)); - if (LvSTARGOFF(sv) <= AvFILL(av)) - { - if (SvRMAGICAL(av)) { - SV * const * const svp = av_fetch(av, LvSTARGOFF(sv), 0); - targ = svp ? *svp : NULL; - } - else - targ = AvARRAY(av)[LvSTARGOFF(sv)]; - } - } - if (targ && (targ != &PL_sv_undef)) { - /* somebody else defined it for us */ - SvREFCNT_dec(LvTARG(sv)); - LvTARG(sv) = SvREFCNT_inc_simple_NN(targ); - LvTARGLEN(sv) = 0; - SvREFCNT_dec(mg->mg_obj); - mg->mg_obj = NULL; - mg->mg_flags &= ~MGf_REFCOUNTED; - } - return targ; + } + else if (LvSTARGOFF(sv) >= 0) { + AV *const av = MUTABLE_AV(LvTARG(sv)); + if (LvSTARGOFF(sv) <= AvFILL(av)) + { + if (SvRMAGICAL(av)) { + SV * const * const svp = av_fetch(av, LvSTARGOFF(sv), 0); + targ = svp ? *svp : NULL; + } + else + targ = AvARRAY(av)[LvSTARGOFF(sv)]; + } + } + if (targ && (targ != &PL_sv_undef)) { + /* somebody else defined it for us */ + SvREFCNT_dec(LvTARG(sv)); + LvTARG(sv) = SvREFCNT_inc_simple_NN(targ); + LvTARGLEN(sv) = 0; + SvREFCNT_dec(mg->mg_obj); + mg->mg_obj = NULL; + mg->mg_flags &= ~MGf_REFCOUNTED; + } + return targ; } else - return LvTARG(sv); + return LvTARG(sv); } int @@ -2524,10 +2519,10 @@ Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_SETDEFELEM; PERL_UNUSED_ARG(mg); if (LvTARGLEN(sv)) - vivify_defelem(sv); + vivify_defelem(sv); if (LvTARG(sv)) { - sv_setsv(LvTARG(sv), sv); - SvSETMAGIC(LvTARG(sv)); + sv_setsv(LvTARG(sv), sv); + SvSETMAGIC(LvTARG(sv)); } return 0; } @@ -2541,26 +2536,26 @@ Perl_vivify_defelem(pTHX_ SV *sv) PERL_ARGS_ASSERT_VIVIFY_DEFELEM; if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem))) - return; + return; if (mg->mg_obj) { - SV * const ahv = LvTARG(sv); - HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0); + SV * const ahv = LvTARG(sv); + HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0); if (he) value = HeVAL(he); - if (!value || value == &PL_sv_undef) - Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj)); + if (!value || value == &PL_sv_undef) + Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj)); } else if (LvSTARGOFF(sv) < 0) - Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv)); + Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv)); else { - AV *const av = MUTABLE_AV(LvTARG(sv)); - if ((I32)LvTARGLEN(sv) < 0 && LvSTARGOFF(sv) > AvFILL(av)) - LvTARG(sv) = NULL; /* array can't be extended */ - else { - SV* const * const svp = av_fetch(av, LvSTARGOFF(sv), TRUE); - if (!svp || !(value = *svp)) - Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv)); - } + AV *const av = MUTABLE_AV(LvTARG(sv)); + if ((I32)LvTARGLEN(sv) < 0 && LvSTARGOFF(sv) > AvFILL(av)) + LvTARG(sv) = NULL; /* array can't be extended */ + else { + SV* const * const svp = av_fetch(av, LvSTARGOFF(sv), TRUE); + if (!svp || !(value = *svp)) + Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv)); + } } SvREFCNT_inc_simple_void(value); SvREFCNT_dec(LvTARG(sv)); @@ -2623,7 +2618,7 @@ Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_SETUVAR; if (uf && uf->uf_set) - (*uf->uf_set)(aTHX_ uf->uf_index, sv); + (*uf->uf_set)(aTHX_ uf->uf_index, sv); return 0; } @@ -2653,9 +2648,9 @@ Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg) PERL_UNUSED_CONTEXT; PERL_UNUSED_ARG(sv); if (mg->mg_ptr) { - Safefree(mg->mg_ptr); - mg->mg_ptr = NULL; - mg->mg_len = -1; + Safefree(mg->mg_ptr); + mg->mg_ptr = NULL; + mg->mg_len = -1; } return 0; } @@ -2716,52 +2711,52 @@ Perl_magic_setlvref(pTHX_ SV *sv, MAGIC *mg) if (!SvROK(sv)) Perl_croak(aTHX_ "Assigned value is not a reference"); switch (mg->mg_private & OPpLVREF_TYPE) { case OPpLVREF_SV: - if (SvTYPE(SvRV(sv)) > SVt_PVLV) - bad = " SCALAR"; - break; + if (SvTYPE(SvRV(sv)) > SVt_PVLV) + bad = " SCALAR"; + break; case OPpLVREF_AV: - if (SvTYPE(SvRV(sv)) != SVt_PVAV) - bad = "n ARRAY"; - break; + if (SvTYPE(SvRV(sv)) != SVt_PVAV) + bad = "n ARRAY"; + break; case OPpLVREF_HV: - if (SvTYPE(SvRV(sv)) != SVt_PVHV) - bad = " HASH"; - break; + if (SvTYPE(SvRV(sv)) != SVt_PVHV) + bad = " HASH"; + break; case OPpLVREF_CV: - if (SvTYPE(SvRV(sv)) != SVt_PVCV) - bad = " CODE"; + if (SvTYPE(SvRV(sv)) != SVt_PVCV) + bad = " CODE"; } if (bad) - /* diag_listed_as: Assigned value is not %s reference */ - Perl_croak(aTHX_ "Assigned value is not a%s reference", bad); + /* diag_listed_as: Assigned value is not %s reference */ + Perl_croak(aTHX_ "Assigned value is not a%s reference", bad); switch (mg->mg_obj ? SvTYPE(mg->mg_obj) : 0) { case 0: { - SV * const old = PAD_SV(mg->mg_len); - PAD_SETSV(mg->mg_len, SvREFCNT_inc_NN(SvRV(sv))); - SvREFCNT_dec(old); - break; + SV * const old = PAD_SV(mg->mg_len); + PAD_SETSV(mg->mg_len, SvREFCNT_inc_NN(SvRV(sv))); + SvREFCNT_dec(old); + break; } case SVt_PVGV: - gv_setref(mg->mg_obj, sv); - SvSETMAGIC(mg->mg_obj); - break; + gv_setref(mg->mg_obj, sv); + SvSETMAGIC(mg->mg_obj); + break; case SVt_PVAV: - av_store((AV *)mg->mg_obj, SvIV((SV *)mg->mg_ptr), - SvREFCNT_inc_simple_NN(SvRV(sv))); - break; + av_store((AV *)mg->mg_obj, SvIV((SV *)mg->mg_ptr), + SvREFCNT_inc_simple_NN(SvRV(sv))); + break; case SVt_PVHV: - (void)hv_store_ent((HV *)mg->mg_obj, (SV *)mg->mg_ptr, + (void)hv_store_ent((HV *)mg->mg_obj, (SV *)mg->mg_ptr, SvREFCNT_inc_simple_NN(SvRV(sv)), 0); } if (mg->mg_flags & MGf_PERSIST) - NOOP; /* This sv is in use as an iterator var and will be reused, - so we must leave the magic. */ + NOOP; /* This sv is in use as an iterator var and will be reused, + so we must leave the magic. */ else - /* This sv could be returned by the assignment op, so clear the - magic, as lvrefs are an implementation detail that must not be - leaked to the user. */ - sv_unmagic(sv, PERL_MAGIC_lvref); + /* This sv could be returned by the assignment op, so clear the + magic, as lvrefs are an implementation detail that must not be + leaked to the user. */ + sv_unmagic(sv, PERL_MAGIC_lvref); return 0; } @@ -2769,8 +2764,6 @@ static void S_set_dollarzero(pTHX_ SV *sv) PERL_TSA_REQUIRES(PL_dollarzero_mutex) { -#ifdef USE_ITHREADS -#endif const char *s; STRLEN len; #ifdef HAS_SETPROCTITLE @@ -2847,8 +2840,6 @@ S_set_dollarzero(pTHX_ SV *sv) int Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) { -#ifdef USE_ITHREADS -#endif I32 paren; const REGEXP * rx; I32 i; @@ -2859,10 +2850,10 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) if (!mg->mg_ptr) { paren = mg->mg_len; - if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { + if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { setparen_got_rx: CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv); - } else { + } else { /* Croak with a READONLY error when a numbered match var is * set without a previous pattern match. Unless it's C */ @@ -2876,28 +2867,28 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) switch (*mg->mg_ptr) { case '\001': /* ^A */ - if (SvOK(sv)) sv_copypv(PL_bodytarget, sv); - else SvOK_off(PL_bodytarget); - FmLINES(PL_bodytarget) = 0; - if (SvPOK(PL_bodytarget)) { - char *s = SvPVX(PL_bodytarget); + if (SvOK(sv)) sv_copypv(PL_bodytarget, sv); + else SvOK_off(PL_bodytarget); + FmLINES(PL_bodytarget) = 0; + if (SvPOK(PL_bodytarget)) { + char *s = SvPVX(PL_bodytarget); char *e = SvEND(PL_bodytarget); - while ( ((s = (char *) memchr(s, '\n', e - s))) ) { - FmLINES(PL_bodytarget)++; - s++; - } - } - /* mg_set() has temporarily made sv non-magical */ - if (TAINTING_get) { - if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1) - SvTAINTED_on(PL_bodytarget); - else - SvTAINTED_off(PL_bodytarget); - } - break; + while ( ((s = (char *) memchr(s, '\n', e - s))) ) { + FmLINES(PL_bodytarget)++; + s++; + } + } + /* mg_set() has temporarily made sv non-magical */ + if (TAINTING_get) { + if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1) + SvTAINTED_on(PL_bodytarget); + else + SvTAINTED_off(PL_bodytarget); + } + break; case '\003': /* ^C */ - PL_minus_c = cBOOL(SvIV(sv)); - break; + PL_minus_c = cBOOL(SvIV(sv)); + break; case '\004': /* ^D */ #ifdef DEBUGGING @@ -2908,30 +2899,30 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) dump_all_perl(!DEBUG_B_TEST); } #else - PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG; + PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG; #endif - break; + break; case '\005': /* ^E */ - if (*(mg->mg_ptr+1) == '\0') { + if (*(mg->mg_ptr+1) == '\0') { #ifdef VMS - set_vaxc_errno(SvIV(sv)); + set_vaxc_errno(SvIV(sv)); #elif defined(WIN32) - SetLastError( SvIV(sv) ); + SetLastError( SvIV(sv) ); #elif defined(OS2) - os2_setsyserrno(SvIV(sv)); + os2_setsyserrno(SvIV(sv)); #else - /* will anyone ever use this? */ - SETERRNO(SvIV(sv), 4); + /* will anyone ever use this? */ + SETERRNO(SvIV(sv), 4); #endif - } - else if (strEQ(mg->mg_ptr + 1, "NCODING") && SvOK(sv)) + } + else if (strEQ(mg->mg_ptr + 1, "NCODING") && SvOK(sv)) Perl_croak(aTHX_ "${^ENCODING} is no longer supported"); - break; + break; case '\006': /* ^F */ if (mg->mg_ptr[1] == '\0') { PL_maxsysfd = SvIV(sv); } - break; + break; case '\010': /* ^H */ { U32 save_hints = PL_hints; @@ -2942,48 +2933,48 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) notify_parser_that_changed_to_utf8(); } } - break; + break; case '\011': /* ^I */ /* NOT \t in EBCDIC */ - Safefree(PL_inplace); - PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL; - break; + Safefree(PL_inplace); + PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL; + break; case '\016': /* ^N */ - if (PL_curpm && (rx = PM_GETRE(PL_curpm)) - && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx; - goto croakparen; + if (PL_curpm && (rx = PM_GETRE(PL_curpm)) + && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx; + goto croakparen; case '\017': /* ^O */ - if (*(mg->mg_ptr+1) == '\0') { - Safefree(PL_osname); - PL_osname = NULL; - if (SvOK(sv)) { - TAINT_PROPER("assigning to $^O"); - PL_osname = savesvpv(sv); - } - } - else if (strEQ(mg->mg_ptr, "\017PEN")) { - STRLEN len; - const char *const start = SvPV(sv, len); - const char *out = (const char*)memchr(start, '\0', len); - SV *tmp; - - - PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT; - PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT; - - /* Opening for input is more common than opening for output, so - ensure that hints for input are sooner on linked list. */ - tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1, - SvUTF8(sv)) - : newSVpvs_flags("", SvUTF8(sv)); - (void)hv_stores(GvHV(PL_hintgv), "open>", tmp); - mg_set(tmp); - - tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len, - SvUTF8(sv)); - (void)hv_stores(GvHV(PL_hintgv), "open<", tmp); - mg_set(tmp); - } - break; + if (*(mg->mg_ptr+1) == '\0') { + Safefree(PL_osname); + PL_osname = NULL; + if (SvOK(sv)) { + TAINT_PROPER("assigning to $^O"); + PL_osname = savesvpv(sv); + } + } + else if (strEQ(mg->mg_ptr, "\017PEN")) { + STRLEN len; + const char *const start = SvPV(sv, len); + const char *out = (const char*)memchr(start, '\0', len); + SV *tmp; + + + PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT; + PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT; + + /* Opening for input is more common than opening for output, so + ensure that hints for input are sooner on linked list. */ + tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1, + SvUTF8(sv)) + : newSVpvs_flags("", SvUTF8(sv)); + (void)hv_stores(GvHV(PL_hintgv), "open>", tmp); + mg_set(tmp); + + tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len, + SvUTF8(sv)); + (void)hv_stores(GvHV(PL_hintgv), "open<", tmp); + mg_set(tmp); + } + break; case '\020': /* ^P */ PL_perldb = SvIV(sv); if (PL_perldb && !PL_DBsingle) @@ -2991,111 +2982,106 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) break; case '\024': /* ^T */ #ifdef BIG_TIME - PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv)); + PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv)); #else - PL_basetime = (Time_t)SvIV(sv); + PL_basetime = (Time_t)SvIV(sv); #endif - break; + break; case '\025': /* ^UTF8CACHE */ - if (strEQ(mg->mg_ptr+1, "TF8CACHE")) { - PL_utf8cache = (signed char) sv_2iv(sv); - } - break; + if (strEQ(mg->mg_ptr+1, "TF8CACHE")) { + PL_utf8cache = (signed char) sv_2iv(sv); + } + break; case '\027': /* ^W & $^WARNING_BITS */ - if (*(mg->mg_ptr+1) == '\0') { - if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { - i = SvIV(sv); - PL_dowarn = (PL_dowarn & ~G_WARN_ON) - | (i ? G_WARN_ON : G_WARN_OFF) ; - } - } - else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) { - if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { - if (!SvPOK(sv)) { + if (*(mg->mg_ptr+1) == '\0') { + if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { + i = SvIV(sv); + PL_dowarn = (PL_dowarn & ~G_WARN_ON) + | (i ? G_WARN_ON : G_WARN_OFF) ; + } + } + else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) { + if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { + if (!SvPOK(sv)) { free_and_set_cop_warnings(&PL_compiling, pWARN_STD); - break; - } - { - STRLEN len, i; - int not_none = 0, not_all = 0; - const U8 * const ptr = (const U8 *)SvPV_const(sv, len) ; - for (i = 0 ; i < len ; ++i) { - not_none |= ptr[i]; - not_all |= ptr[i] ^ 0x55; - } - if (!not_none) { + break; + } + { + STRLEN len, i; + int not_none = 0, not_all = 0; + const U8 * const ptr = (const U8 *)SvPV_const(sv, len) ; + for (i = 0 ; i < len ; ++i) { + not_none |= ptr[i]; + not_all |= ptr[i] ^ 0x55; + } + if (!not_none) { free_and_set_cop_warnings(&PL_compiling, pWARN_NONE); - } else if (len >= WARNsize && !not_all) { + } else if (len >= WARNsize && !not_all) { free_and_set_cop_warnings(&PL_compiling, pWARN_ALL); - PL_dowarn |= G_WARN_ONCE ; - } + PL_dowarn |= G_WARN_ONCE ; + } else { - STRLEN len; - const char *const p = SvPV_const(sv, len); - - PL_compiling.cop_warnings - = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings, - p, len); - - if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE)) - PL_dowarn |= G_WARN_ONCE ; - } - - } - } - } -#ifdef WIN32 - else if (strEQ(mg->mg_ptr+1, "IN32_SLOPPY_STAT")) { - w32_sloppystat = SvTRUE(sv); - } -#endif - break; + STRLEN len; + const char *const p = SvPV_const(sv, len); + + PL_compiling.cop_warnings + = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings, + p, len); + + if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE)) + PL_dowarn |= G_WARN_ONCE ; + } + + } + } + } + break; case '.': - if (PL_localizing) { - if (PL_localizing == 1) - SAVESPTR(PL_last_in_gv); - } - else if (SvOK(sv) && GvIO(PL_last_in_gv)) - IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv); - break; + if (PL_localizing) { + if (PL_localizing == 1) + SAVESPTR(PL_last_in_gv); + } + else if (SvOK(sv) && GvIO(PL_last_in_gv)) + IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv); + break; case '^': - Safefree(IoTOP_NAME(GvIOp(PL_defoutgv))); - IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); - IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO); - break; + Safefree(IoTOP_NAME(GvIOp(PL_defoutgv))); + IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); + IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO); + break; case '~': - Safefree(IoFMT_NAME(GvIOp(PL_defoutgv))); - IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); - IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO); - break; + Safefree(IoFMT_NAME(GvIOp(PL_defoutgv))); + IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); + IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO); + break; case '=': - IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv)); - break; + IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv)); + break; case '-': - IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv)); - if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L) - IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L; - break; + IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv)); + if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L) + IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L; + break; case '%': - IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv)); - break; + IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv)); + break; case '|': - { - IO * const io = GvIO(PL_defoutgv); - if(!io) - break; - if ((SvIV(sv)) == 0) - IoFLAGS(io) &= ~IOf_FLUSH; - else { - if (!(IoFLAGS(io) & IOf_FLUSH)) { - PerlIO *ofp = IoOFP(io); - if (ofp) - (void)PerlIO_flush(ofp); - IoFLAGS(io) |= IOf_FLUSH; - } - } - } - break; + { + IO * const io = GvIO(PL_defoutgv); + if(!io) + break; + if ((SvIV(sv)) == 0) + IoFLAGS(io) &= ~IOf_FLUSH; + else { + if (!(IoFLAGS(io) & IOf_FLUSH)) { + PerlIO *ofp = IoOFP(io); + if (ofp) + (void)PerlIO_flush(ofp); + IoFLAGS(io) |= IOf_FLUSH; + } + } + } + break; case '/': { if (SvROK(sv)) { @@ -3125,36 +3111,36 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) SvREFCNT_dec(PL_rs); PL_rs = newSVsv(sv); } - break; + break; case '\\': - SvREFCNT_dec(PL_ors_sv); - if (SvOK(sv)) { - PL_ors_sv = newSVsv(sv); - } - else { - PL_ors_sv = NULL; - } - break; + SvREFCNT_dec(PL_ors_sv); + if (SvOK(sv)) { + PL_ors_sv = newSVsv(sv); + } + else { + PL_ors_sv = NULL; + } + break; case '[': - if (SvIV(sv) != 0) - Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible"); - break; + if (SvIV(sv) != 0) + Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible"); + break; case '?': #ifdef COMPLEX_STATUS - if (PL_localizing == 2) { - SvUPGRADE(sv, SVt_PVLV); - PL_statusvalue = LvTARGOFF(sv); - PL_statusvalue_vms = LvTARGLEN(sv); - } - else + if (PL_localizing == 2) { + SvUPGRADE(sv, SVt_PVLV); + PL_statusvalue = LvTARGOFF(sv); + PL_statusvalue_vms = LvTARGLEN(sv); + } + else #endif #ifdef VMSISH_STATUS - if (VMSISH_STATUS) - STATUS_NATIVE_CHILD_SET((U32)SvIV(sv)); - else + if (VMSISH_STATUS) + STATUS_NATIVE_CHILD_SET((U32)SvIV(sv)); + else #endif - STATUS_UNIX_EXIT_SET(SvIV(sv)); - break; + STATUS_UNIX_EXIT_SET(SvIV(sv)); + break; case '!': { #ifdef VMS @@ -3163,93 +3149,93 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) # define PERL_VMS_BANG 0 #endif #if defined(WIN32) - SETERRNO(win32_get_errno(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0), - (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG); + SETERRNO(win32_get_errno(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0), + (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG); #else - SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0, - (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG); + SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0, + (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG); #endif - } - break; + } + break; case '<': - { + { /* XXX $< currently silently ignores failures */ - const Uid_t new_uid = SvUID(sv); - PL_delaymagic_uid = new_uid; - if (PL_delaymagic) { - PL_delaymagic |= DM_RUID; - break; /* don't do magic till later */ - } + const Uid_t new_uid = SvUID(sv); + PL_delaymagic_uid = new_uid; + if (PL_delaymagic) { + PL_delaymagic |= DM_RUID; + break; /* don't do magic till later */ + } #ifdef HAS_SETRUID - PERL_UNUSED_RESULT(setruid(new_uid)); + PERL_UNUSED_RESULT(setruid(new_uid)); #elif defined(HAS_SETREUID) PERL_UNUSED_RESULT(setreuid(new_uid, (Uid_t)-1)); #elif defined(HAS_SETRESUID) PERL_UNUSED_RESULT(setresuid(new_uid, (Uid_t)-1, (Uid_t)-1)); #else - if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */ + if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */ # ifdef PERL_DARWIN - /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */ - if (new_uid != 0 && PerlProc_getuid() == 0) + /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */ + if (new_uid != 0 && PerlProc_getuid() == 0) PERL_UNUSED_RESULT(PerlProc_setuid(0)); # endif PERL_UNUSED_RESULT(PerlProc_setuid(new_uid)); - } else { - Perl_croak(aTHX_ "setruid() not implemented"); - } + } else { + Perl_croak(aTHX_ "setruid() not implemented"); + } #endif - break; - } + break; + } case '>': - { + { /* XXX $> currently silently ignores failures */ - const Uid_t new_euid = SvUID(sv); - PL_delaymagic_euid = new_euid; - if (PL_delaymagic) { - PL_delaymagic |= DM_EUID; - break; /* don't do magic till later */ - } + const Uid_t new_euid = SvUID(sv); + PL_delaymagic_euid = new_euid; + if (PL_delaymagic) { + PL_delaymagic |= DM_EUID; + break; /* don't do magic till later */ + } #ifdef HAS_SETEUID - PERL_UNUSED_RESULT(seteuid(new_euid)); + PERL_UNUSED_RESULT(seteuid(new_euid)); #elif defined(HAS_SETREUID) - PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid)); + PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid)); #elif defined(HAS_SETRESUID) - PERL_UNUSED_RESULT(setresuid((Uid_t)-1, new_euid, (Uid_t)-1)); + PERL_UNUSED_RESULT(setresuid((Uid_t)-1, new_euid, (Uid_t)-1)); #else - if (new_euid == PerlProc_getuid()) /* special case $> = $< */ - PERL_UNUSED_RESULT(PerlProc_setuid(new_euid)); - else { - Perl_croak(aTHX_ "seteuid() not implemented"); - } -#endif - break; - } + if (new_euid == PerlProc_getuid()) /* special case $> = $< */ + PERL_UNUSED_RESULT(PerlProc_setuid(new_euid)); + else { + Perl_croak(aTHX_ "seteuid() not implemented"); + } +#endif + break; + } case '(': - { + { /* XXX $( currently silently ignores failures */ - const Gid_t new_gid = SvGID(sv); - PL_delaymagic_gid = new_gid; - if (PL_delaymagic) { - PL_delaymagic |= DM_RGID; - break; /* don't do magic till later */ - } + const Gid_t new_gid = SvGID(sv); + PL_delaymagic_gid = new_gid; + if (PL_delaymagic) { + PL_delaymagic |= DM_RGID; + break; /* don't do magic till later */ + } #ifdef HAS_SETRGID - PERL_UNUSED_RESULT(setrgid(new_gid)); + PERL_UNUSED_RESULT(setrgid(new_gid)); #elif defined(HAS_SETREGID) - PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1)); + PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1)); #elif defined(HAS_SETRESGID) PERL_UNUSED_RESULT(setresgid(new_gid, (Gid_t)-1, (Gid_t) -1)); #else - if (new_gid == PerlProc_getegid()) /* special case $( = $) */ - PERL_UNUSED_RESULT(PerlProc_setgid(new_gid)); - else { - Perl_croak(aTHX_ "setrgid() not implemented"); - } -#endif - break; - } + if (new_gid == PerlProc_getegid()) /* special case $( = $) */ + PERL_UNUSED_RESULT(PerlProc_setgid(new_gid)); + else { + Perl_croak(aTHX_ "setrgid() not implemented"); + } +#endif + break; + } case ')': - { + { /* (hv) best guess: maybe we'll need configure probes to do a better job, * but you can override it if you need to. */ @@ -3257,10 +3243,10 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) #define INVALID_GID ((Gid_t)-1) #endif /* XXX $) currently silently ignores failures */ - Gid_t new_egid; + Gid_t new_egid; #ifdef HAS_SETGROUPS - { - const char *p = SvPV_const(sv, len); + { + const char *p = SvPV_const(sv, len); Groups_t *gary = NULL; const char* p_end = p + len; const char* endptr = p_end; @@ -3304,50 +3290,50 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } if (i) PERL_UNUSED_RESULT(setgroups(i, gary)); - Safefree(gary); - } + Safefree(gary); + } #else /* HAS_SETGROUPS */ new_egid = SvGID(sv); #endif /* HAS_SETGROUPS */ - PL_delaymagic_egid = new_egid; - if (PL_delaymagic) { - PL_delaymagic |= DM_EGID; - break; /* don't do magic till later */ - } + PL_delaymagic_egid = new_egid; + if (PL_delaymagic) { + PL_delaymagic |= DM_EGID; + break; /* don't do magic till later */ + } #ifdef HAS_SETEGID - PERL_UNUSED_RESULT(setegid(new_egid)); + PERL_UNUSED_RESULT(setegid(new_egid)); #elif defined(HAS_SETREGID) - PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid)); + PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid)); #elif defined(HAS_SETRESGID) - PERL_UNUSED_RESULT(setresgid((Gid_t)-1, new_egid, (Gid_t)-1)); + PERL_UNUSED_RESULT(setresgid((Gid_t)-1, new_egid, (Gid_t)-1)); #else - if (new_egid == PerlProc_getgid()) /* special case $) = $( */ - PERL_UNUSED_RESULT(PerlProc_setgid(new_egid)); - else { - Perl_croak(aTHX_ "setegid() not implemented"); - } -#endif - break; - } + if (new_egid == PerlProc_getgid()) /* special case $) = $( */ + PERL_UNUSED_RESULT(PerlProc_setgid(new_egid)); + else { + Perl_croak(aTHX_ "setegid() not implemented"); + } +#endif + break; + } case ':': - PL_chopset = SvPV_force(sv,len); - break; + PL_chopset = SvPV_force(sv,len); + break; case '$': /* $$ */ - /* Store the pid in mg->mg_obj so we can tell when a fork has - occurred. mg->mg_obj points to *$ by default, so clear it. */ - if (isGV(mg->mg_obj)) { - if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */ - SvREFCNT_dec(mg->mg_obj); - mg->mg_flags |= MGf_REFCOUNTED; - mg->mg_obj = newSViv((IV)PerlProc_getpid()); - } - else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid()); - break; + /* Store the pid in mg->mg_obj so we can tell when a fork has + occurred. mg->mg_obj points to *$ by default, so clear it. */ + if (isGV(mg->mg_obj)) { + if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */ + SvREFCNT_dec(mg->mg_obj); + mg->mg_flags |= MGf_REFCOUNTED; + mg->mg_obj = newSViv((IV)PerlProc_getpid()); + } + else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid()); + break; case '0': - LOCK_DOLLARZERO_MUTEX; + LOCK_DOLLARZERO_MUTEX; S_set_dollarzero(aTHX_ sv); - UNLOCK_DOLLARZERO_MUTEX; - break; + UNLOCK_DOLLARZERO_MUTEX; + break; } return 0; } @@ -3403,15 +3389,15 @@ Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len) PERL_UNUSED_CONTEXT; for (sigv = (char* const*)PL_sig_name; *sigv; sigv++) - if (strlen(*sigv) == len && memEQ(sig,*sigv, len)) - return PL_sig_num[sigv - (char* const*)PL_sig_name]; + if (strlen(*sigv) == len && memEQ(sig,*sigv, len)) + return PL_sig_num[sigv - (char* const*)PL_sig_name]; #ifdef SIGCLD if (memEQs(sig, len, "CHLD")) - return SIGCLD; + return SIGCLD; #endif #ifdef SIGCHLD if (memEQs(sig, len, "CLD")) - return SIGCHLD; + return SIGCHLD; #endif return -1; } @@ -3491,54 +3477,54 @@ Perl_perly_sighandler(int sig, Siginfo_t *sip PERL_UNUSED_DECL, if (!PL_psig_ptr[sig]) { - PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n", - PL_sig_name[sig]); - exit(sig); - } + PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n", + PL_sig_name[sig]); + exit(sig); + } if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) { - /* Max number of items pushed there is 3*n or 4. We cannot fix - infinity, so we fix 4 (in fact 5): */ - if (PL_savestack_ix + 15 <= PL_savestack_max) { - flags |= 1; - PL_savestack_ix += 5; /* Protect save in progress. */ - SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL); - } + /* Max number of items pushed there is 3*n or 4. We cannot fix + infinity, so we fix 4 (in fact 5): */ + if (PL_savestack_ix + 15 <= PL_savestack_max) { + flags |= 1; + PL_savestack_ix += 5; /* Protect save in progress. */ + SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL); + } } /* sv_2cv is too complicated, try a simpler variant first: */ if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig]))) - || SvTYPE(cv) != SVt_PVCV) { - HV *st; - cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD); + || SvTYPE(cv) != SVt_PVCV) { + HV *st; + cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD); } if (!cv || !CvROOT(cv)) { - const HEK * const hek = gv - ? GvENAME_HEK(gv) - : cv && CvNAMED(cv) - ? CvNAME_HEK(cv) - : cv && CvGV(cv) ? GvENAME_HEK(CvGV(cv)) : NULL; - if (hek) - Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), - "SIG%s handler \"%" HEKf "\" not defined.\n", - PL_sig_name[sig], HEKfARG(hek)); - /* diag_listed_as: SIG%s handler "%s" not defined */ - else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), - "SIG%s handler \"__ANON__\" not defined.\n", - PL_sig_name[sig]); - goto cleanup; + const HEK * const hek = gv + ? GvENAME_HEK(gv) + : cv && CvNAMED(cv) + ? CvNAME_HEK(cv) + : cv && CvGV(cv) ? GvENAME_HEK(CvGV(cv)) : NULL; + if (hek) + Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), + "SIG%s handler \"%" HEKf "\" not defined.\n", + PL_sig_name[sig], HEKfARG(hek)); + /* diag_listed_as: SIG%s handler "%s" not defined */ + else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), + "SIG%s handler \"__ANON__\" not defined.\n", + PL_sig_name[sig]); + goto cleanup; } sv = PL_psig_name[sig] - ? SvREFCNT_inc_NN(PL_psig_name[sig]) - : newSVpv(PL_sig_name[sig],0); + ? SvREFCNT_inc_NN(PL_psig_name[sig]) + : newSVpv(PL_sig_name[sig],0); flags |= 8; SAVEFREESV(sv); if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) { - /* make sure our assumption about the size of the SAVEs are correct: - * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */ - assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix); + /* make sure our assumption about the size of the SAVEs are correct: + * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */ + assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix); } PUSHSTACKi(PERLSI_SIGNAL); @@ -3547,9 +3533,9 @@ Perl_perly_sighandler(int sig, Siginfo_t *sip PERL_UNUSED_DECL, #if defined(HAS_SIGACTION) && defined(SA_SIGINFO) { - struct sigaction oact; + struct sigaction oact; - if (sip && sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) { + if (sip && sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) { HV *sih = newHV(); SV *rv = newRV_noinc(MUTABLE_SV(sih)); /* The siginfo fields signo, code, errno, pid, uid, @@ -3582,7 +3568,7 @@ Perl_perly_sighandler(int sig, Siginfo_t *sip PERL_UNUSED_DECL, PUSHs(rv); mPUSHp((char *)sip, sizeof(*sip)); - } + } } #endif @@ -3594,9 +3580,9 @@ Perl_perly_sighandler(int sig, Siginfo_t *sip PERL_UNUSED_DECL, POPSTACK; { - SV * const errsv = ERRSV; - if (SvTRUE_NN(errsv)) { - SvREFCNT_dec(errsv_save); + SV * const errsv = ERRSV; + if (SvTRUE_NN(errsv)) { + SvREFCNT_dec(errsv_save); #ifndef PERL_MICRO /* Handler "died", for example to get out of a restart-able read(). @@ -3604,41 +3590,41 @@ Perl_perly_sighandler(int sig, Siginfo_t *sip PERL_UNUSED_DECL, * blocked by the system when we entered. */ # ifdef HAS_SIGPROCMASK - if (!safe) { + if (!safe) { /* safe signals called via dispatch_signals() set up a * savestack destructor, unblock_sigmask(), to * automatically unblock the handler at the end. If * instead we get here directly, we have to do it * ourselves */ - sigset_t set; - sigemptyset(&set); - sigaddset(&set,sig); - sigprocmask(SIG_UNBLOCK, &set, NULL); - } + sigset_t set; + sigemptyset(&set); + sigaddset(&set,sig); + sigprocmask(SIG_UNBLOCK, &set, NULL); + } # else - /* Not clear if this will work */ + /* Not clear if this will work */ /* XXX not clear if this should be protected by 'if (safe)' * too */ - (void)rsignal(sig, SIG_IGN); - (void)rsignal(sig, PL_csighandlerp); + (void)rsignal(sig, SIG_IGN); + (void)rsignal(sig, PL_csighandlerp); # endif #endif /* !PERL_MICRO */ - die_sv(errsv); - } - else { - sv_setsv(errsv, errsv_save); - SvREFCNT_dec(errsv_save); - } + die_sv(errsv); + } + else { + sv_setsv(errsv, errsv_save); + SvREFCNT_dec(errsv_save); + } } cleanup: /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */ PL_savestack_ix = old_ss_ix; if (flags & 8) - SvREFCNT_dec_NN(sv); + SvREFCNT_dec_NN(sv); PL_op = myop; /* Apparently not needed... */ PL_Sv = tSv; /* Restore global temporaries. */ @@ -3658,11 +3644,11 @@ S_restore_magic(pTHX_ const void *p) return; if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { - SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */ - if (mgs->mgs_flags) - SvFLAGS(sv) |= mgs->mgs_flags; - else - mg_magical(sv); + SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */ + if (mgs->mgs_flags) + SvFLAGS(sv) |= mgs->mgs_flags; + else + mg_magical(sv); } bumped = mgs->mgs_bumped; @@ -3677,25 +3663,25 @@ S_restore_magic(pTHX_ const void *p) */ if (PL_savestack_ix == mgs->mgs_ss_ix) { - UV popval = SSPOPUV; + UV popval = SSPOPUV; assert(popval == SAVEt_DESTRUCTOR_X); PL_savestack_ix -= 2; - popval = SSPOPUV; + popval = SSPOPUV; assert((popval & SAVE_MASK) == SAVEt_ALLOC); PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT; } if (bumped) { - if (SvREFCNT(sv) == 1) { - /* We hold the last reference to this SV, which implies that the - SV was deleted as a side effect of the routines we called. - So artificially keep it alive a bit longer. - We avoid turning on the TEMP flag, which can cause the SV's - buffer to get stolen (and maybe other stuff). */ - sv_2mortal(sv); - SvTEMP_off(sv); - } - else - SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */ + if (SvREFCNT(sv) == 1) { + /* We hold the last reference to this SV, which implies that the + SV was deleted as a side effect of the routines we called. + So artificially keep it alive a bit longer. + We avoid turning on the TEMP flag, which can cause the SV's + buffer to get stolen (and maybe other stuff). */ + sv_2mortal(sv); + SvTEMP_off(sv); + } + else + SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */ } } @@ -3727,7 +3713,7 @@ int Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg) { SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr) - : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP); + : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP); PERL_ARGS_ASSERT_MAGIC_SETHINT; @@ -3741,7 +3727,7 @@ Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg) forgetting to do it, and consequent subtle errors. */ PL_hints |= HINT_LOCALIZE_HH; CopHINTHASH_set(&PL_compiling, - cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0)); + cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0)); magic_sethint_feature(key, NULL, 0, sv, 0); return 0; } @@ -3762,11 +3748,11 @@ Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg) PL_hints |= HINT_LOCALIZE_HH; CopHINTHASH_set(&PL_compiling, - mg->mg_len == HEf_SVKEY - ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling), - MUTABLE_SV(mg->mg_ptr), 0, 0) - : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling), - mg->mg_ptr, mg->mg_len, 0, 0)); + mg->mg_len == HEf_SVKEY + ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling), + MUTABLE_SV(mg->mg_ptr), 0, 0) + : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling), + mg->mg_ptr, mg->mg_len, 0, 0)); if (mg->mg_len == HEf_SVKEY) magic_sethint_feature(MUTABLE_SV(mg->mg_ptr), NULL, 0, NULL, FALSE); else @@ -3795,7 +3781,7 @@ Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv, - const char *name, I32 namlen) + const char *name, I32 namlen) { MAGIC *nmg; diff --git a/mg.h b/mg.h index 5e3bcc0a6651..53f1a47032f2 100644 --- a/mg.h +++ b/mg.h @@ -15,7 +15,7 @@ struct mgvtbl { int (*svt_clear) (pTHX_ SV *sv, MAGIC* mg); int (*svt_free) (pTHX_ SV *sv, MAGIC* mg); int (*svt_copy) (pTHX_ SV *sv, MAGIC* mg, - SV *nsv, const char *name, I32 namlen); + SV *nsv, const char *name, I32 namlen); int (*svt_dup) (pTHX_ MAGIC *mg, CLONE_PARAMS *param); int (*svt_local)(pTHX_ SV *nsv, MAGIC *mg); }; @@ -47,14 +47,14 @@ struct magic { #define MgTAINTEDDIR_off(mg) (mg->mg_flags &= ~MGf_TAINTEDDIR) #define MgPV(mg,lp) ((((int)(lp = (mg)->mg_len)) == HEf_SVKEY) ? \ - SvPV(MUTABLE_SV((mg)->mg_ptr),lp) : \ - (mg)->mg_ptr) + SvPV(MUTABLE_SV((mg)->mg_ptr),lp) : \ + (mg)->mg_ptr) #define MgPV_const(mg,lp) ((((int)(lp = (mg)->mg_len)) == HEf_SVKEY) ? \ - SvPV_const(MUTABLE_SV((mg)->mg_ptr),lp) : \ - (const char*)(mg)->mg_ptr) + SvPV_const(MUTABLE_SV((mg)->mg_ptr),lp) : \ + (const char*)(mg)->mg_ptr) #define MgPV_nolen_const(mg) (((((int)(mg)->mg_len)) == HEf_SVKEY) ? \ - SvPV_nolen_const(MUTABLE_SV((mg)->mg_ptr)) : \ - (const char*)(mg)->mg_ptr) + SvPV_nolen_const(MUTABLE_SV((mg)->mg_ptr)) : \ + (const char*)(mg)->mg_ptr) #define SvTIED_mg(sv,how) (SvRMAGICAL(sv) ? mg_find((sv),(how)) : NULL) #define SvTIED_obj(sv,mg) \ @@ -66,11 +66,11 @@ struct magic { # define MgBYTEPOS_set(mg,sv,pv,off) ( \ assert_((mg)->mg_type == PERL_MAGIC_regex_global) \ SvPOK(sv) && (!SvGMAGICAL(sv) || sv_only_taint_gmagic(sv)) \ - ? (mg)->mg_len = (off), (mg)->mg_flags |= MGf_BYTES \ - : ((mg)->mg_len = DO_UTF8(sv) \ - ? (SSize_t)utf8_length((U8 *)(pv), (U8 *)(pv)+(off)) \ - : (SSize_t)(off), \ - (mg)->mg_flags &= ~MGf_BYTES)) + ? (mg)->mg_len = (off), (mg)->mg_flags |= MGf_BYTES \ + : ((mg)->mg_len = DO_UTF8(sv) \ + ? (SSize_t)utf8_length((U8 *)(pv), (U8 *)(pv)+(off)) \ + : (SSize_t)(off), \ + (mg)->mg_flags &= ~MGf_BYTES)) #endif #define whichsig(pv) whichsig_pv(pv) diff --git a/mro_core.c b/mro_core.c index 378c738c7a5e..25642d826f66 100644 --- a/mro_core.c +++ b/mro_core.c @@ -35,68 +35,68 @@ static const struct mro_alg dfs_alg = SV * Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta, - const struct mro_alg *const which) + const struct mro_alg *const which) { SV **data; PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA; data = (SV **)Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL, - which->name, which->length, which->kflags, - HV_FETCH_JUST_SV, NULL, which->hash); + which->name, which->length, which->kflags, + HV_FETCH_JUST_SV, NULL, which->hash); if (!data) - return NULL; + return NULL; /* If we've been asked to look up the private data for the current MRO, then cache it. */ if (smeta->mro_which == which) - smeta->mro_linear_current = *data; + smeta->mro_linear_current = *data; return *data; } SV * Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta, - const struct mro_alg *const which, SV *const data) + const struct mro_alg *const which, SV *const data) { PERL_ARGS_ASSERT_MRO_SET_PRIVATE_DATA; if (!smeta->mro_linear_all) { - if (smeta->mro_which == which) { - /* If all we need to store is the current MRO's data, then don't use - memory on a hash with 1 element - store it direct, and signal - this by leaving the would-be-hash NULL. */ - smeta->mro_linear_current = data; - return data; - } else { - HV *const hv = newHV(); - /* Start with 2 buckets. It's unlikely we'll need more. */ - HvMAX(hv) = 1; - smeta->mro_linear_all = hv; - - if (smeta->mro_linear_current) { - /* If we were storing something directly, put it in the hash - before we lose it. */ - Perl_mro_set_private_data(aTHX_ smeta, smeta->mro_which, - smeta->mro_linear_current); - } - } + if (smeta->mro_which == which) { + /* If all we need to store is the current MRO's data, then don't use + memory on a hash with 1 element - store it direct, and signal + this by leaving the would-be-hash NULL. */ + smeta->mro_linear_current = data; + return data; + } else { + HV *const hv = newHV(); + /* Start with 2 buckets. It's unlikely we'll need more. */ + HvMAX(hv) = 1; + smeta->mro_linear_all = hv; + + if (smeta->mro_linear_current) { + /* If we were storing something directly, put it in the hash + before we lose it. */ + Perl_mro_set_private_data(aTHX_ smeta, smeta->mro_which, + smeta->mro_linear_current); + } + } } /* We get here if we're storing more than one linearisation for this stash, or the linearisation we are storing is not that if its current MRO. */ if (smeta->mro_which == which) { - /* If we've been asked to store the private data for the current MRO, - then cache it. */ - smeta->mro_linear_current = data; + /* If we've been asked to store the private data for the current MRO, + then cache it. */ + smeta->mro_linear_current = data; } if (!Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL, - which->name, which->length, which->kflags, - HV_FETCH_ISSTORE, data, which->hash)) { - Perl_croak(aTHX_ "panic: hv_store() failed in set_mro_private_data() " - "for '%.*s' %d", (int) which->length, which->name, - which->kflags); + which->name, which->length, which->kflags, + HV_FETCH_ISSTORE, data, which->hash)) { + Perl_croak(aTHX_ "panic: hv_store() failed in set_mro_private_data() " + "for '%.*s' %d", (int) which->length, which->name, + which->kflags); } return data; @@ -109,9 +109,9 @@ Perl_mro_get_from_name(pTHX_ SV *name) { PERL_ARGS_ASSERT_MRO_GET_FROM_NAME; data = (SV **)Perl_hv_common(aTHX_ PL_registered_mros, name, NULL, 0, 0, - HV_FETCH_JUST_SV, NULL, 0); + HV_FETCH_JUST_SV, NULL, 0); if (!data) - return NULL; + return NULL; assert(SvTYPE(*data) == SVt_IV); assert(SvIOK(*data)); return INT2PTR(const struct mro_alg *, SvUVX(*data)); @@ -133,11 +133,11 @@ Perl_mro_register(pTHX_ const struct mro_alg *mro) { if (!Perl_hv_common(aTHX_ PL_registered_mros, NULL, - mro->name, mro->length, mro->kflags, - HV_FETCH_ISSTORE, wrapper, mro->hash)) { - SvREFCNT_dec_NN(wrapper); - Perl_croak(aTHX_ "panic: hv_store() failed in mro_register() " - "for '%.*s' %d", (int) mro->length, mro->name, mro->kflags); + mro->name, mro->length, mro->kflags, + HV_FETCH_ISSTORE, wrapper, mro->hash)) { + SvREFCNT_dec_NN(wrapper); + Perl_croak(aTHX_ "panic: hv_store() failed in mro_register() " + "for '%.*s' %d", (int) mro->length, mro->name, mro->kflags); } } @@ -173,23 +173,23 @@ Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param) Copy(smeta, newmeta, 1, struct mro_meta); if (newmeta->mro_linear_all) { - newmeta->mro_linear_all - = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_linear_all, param)); - /* This is just acting as a shortcut pointer, and will be automatically - updated on the first get. */ - newmeta->mro_linear_current = NULL; + newmeta->mro_linear_all + = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_linear_all, param)); + /* This is just acting as a shortcut pointer, and will be automatically + updated on the first get. */ + newmeta->mro_linear_current = NULL; } else if (newmeta->mro_linear_current) { - /* Only the current MRO is stored, so this owns the data. */ - newmeta->mro_linear_current - = sv_dup_inc((const SV *)newmeta->mro_linear_current, param); + /* Only the current MRO is stored, so this owns the data. */ + newmeta->mro_linear_current + = sv_dup_inc((const SV *)newmeta->mro_linear_current, param); } if (newmeta->mro_nextmethod) - newmeta->mro_nextmethod - = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_nextmethod, param)); + newmeta->mro_nextmethod + = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_nextmethod, param)); if (newmeta->isa) - newmeta->isa - = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->isa, param)); + newmeta->isa + = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->isa, param)); newmeta->super = NULL; @@ -243,8 +243,8 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level) if (level > 100) Perl_croak(aTHX_ - "Recursive inheritance detected in package '%" HEKf "'", - HEKfARG(stashhek)); + "Recursive inheritance detected in package '%" HEKf "'", + HEKfARG(stashhek)); meta = HvMROMETA(stash); @@ -280,85 +280,85 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level) while (items--) { SV* const sv = *svp ? *svp : &PL_sv_undef; HV* const basestash = gv_stashsv(sv, 0); - SV *const *subrv_p; - I32 subrv_items; - svp++; + SV *const *subrv_p; + I32 subrv_items; + svp++; if (!basestash) { /* if no stash exists for this @ISA member, simply add it to the MRO and move on */ - subrv_p = &sv; - subrv_items = 1; + subrv_p = &sv; + subrv_items = 1; } else { /* otherwise, recurse into ourselves for the MRO of this @ISA member, and append their MRO to ours. - The recursive call could throw an exception, which - has memory management implications here, hence the use of - the mortal. */ - const AV *const subrv - = mro_get_linear_isa_dfs(basestash, level + 1); - - subrv_p = AvARRAY(subrv); - subrv_items = AvFILLp(subrv) + 1; - } - if (stored) { - while(subrv_items--) { - SV *const subsv = *subrv_p++; - /* LVALUE fetch will create a new undefined SV if necessary - */ - HE *const he = hv_fetch_ent(stored, subsv, 1, 0); - assert(he); - if(HeVAL(he) != &PL_sv_undef) { - /* It was newly created. Steal it for our new SV, and - replace it in the hash with the "real" thing. */ - SV *const val = HeVAL(he); - HEK *const key = HeKEY_hek(he); - - HeVAL(he) = &PL_sv_undef; - sv_sethek(val, key); - av_push(retval, val); - } - } + The recursive call could throw an exception, which + has memory management implications here, hence the use of + the mortal. */ + const AV *const subrv + = mro_get_linear_isa_dfs(basestash, level + 1); + + subrv_p = AvARRAY(subrv); + subrv_items = AvFILLp(subrv) + 1; + } + if (stored) { + while(subrv_items--) { + SV *const subsv = *subrv_p++; + /* LVALUE fetch will create a new undefined SV if necessary + */ + HE *const he = hv_fetch_ent(stored, subsv, 1, 0); + assert(he); + if(HeVAL(he) != &PL_sv_undef) { + /* It was newly created. Steal it for our new SV, and + replace it in the hash with the "real" thing. */ + SV *const val = HeVAL(he); + HEK *const key = HeKEY_hek(he); + + HeVAL(he) = &PL_sv_undef; + sv_sethek(val, key); + av_push(retval, val); + } + } } else { - /* We are the first (or only) parent. We can short cut the - complexity above, because our @ISA is simply us prepended - to our parent's @ISA, and our ->isa cache is simply our - parent's, with our name added. */ - /* newSVsv() is slow. This code is only faster if we can avoid - it by ensuring that SVs in the arrays are shared hash key - scalar SVs, because we can "copy" them very efficiently. - Although to be fair, we can't *ensure* this, as a reference - to the internal array is returned by mro::get_linear_isa(), - so we'll have to be defensive just in case someone faffed - with it. */ - if (basestash) { - SV **svp; - stored = MUTABLE_HV(sv_2mortal((SV*)newHVhv(HvMROMETA(basestash)->isa))); - av_extend(retval, subrv_items); - AvFILLp(retval) = subrv_items; - svp = AvARRAY(retval); - while(subrv_items--) { - SV *const val = *subrv_p++; - *++svp = SvIsCOW_shared_hash(val) - ? newSVhek(SvSHARED_HEK_FROM_PV(SvPVX(val))) - : newSVsv(val); - } - } else { - /* They have no stash. So create ourselves an ->isa cache - as if we'd copied it from what theirs should be. */ - stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV()))); - (void) hv_stores(stored, "UNIVERSAL", &PL_sv_undef); - av_push(retval, - newSVhek(HeKEY_hek(hv_store_ent(stored, sv, - &PL_sv_undef, 0)))); - } - } + /* We are the first (or only) parent. We can short cut the + complexity above, because our @ISA is simply us prepended + to our parent's @ISA, and our ->isa cache is simply our + parent's, with our name added. */ + /* newSVsv() is slow. This code is only faster if we can avoid + it by ensuring that SVs in the arrays are shared hash key + scalar SVs, because we can "copy" them very efficiently. + Although to be fair, we can't *ensure* this, as a reference + to the internal array is returned by mro::get_linear_isa(), + so we'll have to be defensive just in case someone faffed + with it. */ + if (basestash) { + SV **svp; + stored = MUTABLE_HV(sv_2mortal((SV*)newHVhv(HvMROMETA(basestash)->isa))); + av_extend(retval, subrv_items); + AvFILLp(retval) = subrv_items; + svp = AvARRAY(retval); + while(subrv_items--) { + SV *const val = *subrv_p++; + *++svp = SvIsCOW_shared_hash(val) + ? newSVhek(SvSHARED_HEK_FROM_PV(SvPVX(val))) + : newSVsv(val); + } + } else { + /* They have no stash. So create ourselves an ->isa cache + as if we'd copied it from what theirs should be. */ + stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV()))); + (void) hv_stores(stored, "UNIVERSAL", &PL_sv_undef); + av_push(retval, + newSVhek(HeKEY_hek(hv_store_ent(stored, sv, + &PL_sv_undef, 0)))); + } + } } } else { - /* We have no parents. */ - stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV()))); - (void) hv_stores(stored, "UNIVERSAL", &PL_sv_undef); + /* We have no parents. */ + stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV()))); + (void) hv_stores(stored, "UNIVERSAL", &PL_sv_undef); } (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0); @@ -380,7 +380,7 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level) SvREADONLY_on(retval); return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg, - MUTABLE_SV(retval))); + MUTABLE_SV(retval))); } /* @@ -415,49 +415,49 @@ Perl_mro_get_linear_isa(pTHX_ HV *stash) isa = meta->mro_which->resolve(aTHX_ stash, 0); if (meta->mro_which != &dfs_alg) { /* skip for dfs, for speed */ - SV * const namesv = - (HvENAME(stash)||HvNAME(stash)) - ? newSVhek(HvENAME_HEK(stash) - ? HvENAME_HEK(stash) - : HvNAME_HEK(stash)) - : NULL; - - if(namesv && (AvFILLp(isa) == -1 || !sv_eq(*AvARRAY(isa), namesv))) - { - AV * const old = isa; - SV **svp; - SV **ovp = AvARRAY(old); - SV * const * const oend = ovp + AvFILLp(old) + 1; - isa = (AV *)sv_2mortal((SV *)newAV()); - av_extend(isa, AvFILLp(isa) = AvFILLp(old)+1); - *AvARRAY(isa) = namesv; - svp = AvARRAY(isa)+1; - while (ovp < oend) *svp++ = SvREFCNT_inc(*ovp++); - } - else SvREFCNT_dec(namesv); + SV * const namesv = + (HvENAME(stash)||HvNAME(stash)) + ? newSVhek(HvENAME_HEK(stash) + ? HvENAME_HEK(stash) + : HvNAME_HEK(stash)) + : NULL; + + if(namesv && (AvFILLp(isa) == -1 || !sv_eq(*AvARRAY(isa), namesv))) + { + AV * const old = isa; + SV **svp; + SV **ovp = AvARRAY(old); + SV * const * const oend = ovp + AvFILLp(old) + 1; + isa = (AV *)sv_2mortal((SV *)newAV()); + av_extend(isa, AvFILLp(isa) = AvFILLp(old)+1); + *AvARRAY(isa) = namesv; + svp = AvARRAY(isa)+1; + while (ovp < oend) *svp++ = SvREFCNT_inc(*ovp++); + } + else SvREFCNT_dec(namesv); } if (!meta->isa) { - HV *const isa_hash = newHV(); - /* Linearisation didn't build it for us, so do it here. */ - SV *const *svp = AvARRAY(isa); - SV *const *const svp_end = svp + AvFILLp(isa) + 1; - const HEK *canon_name = HvENAME_HEK(stash); - if (!canon_name) canon_name = HvNAME_HEK(stash); - - while (svp < svp_end) { - (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0); - } - - (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name), - HEK_LEN(canon_name), HEK_FLAGS(canon_name), - HV_FETCH_ISSTORE, &PL_sv_undef, - HEK_HASH(canon_name)); - (void) hv_stores(isa_hash, "UNIVERSAL", &PL_sv_undef); - - SvREADONLY_on(isa_hash); - - meta->isa = isa_hash; + HV *const isa_hash = newHV(); + /* Linearisation didn't build it for us, so do it here. */ + SV *const *svp = AvARRAY(isa); + SV *const *const svp_end = svp + AvFILLp(isa) + 1; + const HEK *canon_name = HvENAME_HEK(stash); + if (!canon_name) canon_name = HvNAME_HEK(stash); + + while (svp < svp_end) { + (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0); + } + + (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name), + HEK_LEN(canon_name), HEK_FLAGS(canon_name), + HV_FETCH_ISSTORE, &PL_sv_undef, + HEK_HASH(canon_name)); + (void) hv_stores(isa_hash, "UNIVERSAL", &PL_sv_undef); + + SvREADONLY_on(isa_hash); + + meta->isa = isa_hash; } return isa; @@ -476,14 +476,14 @@ by the C magic, should not need to invoke directly. /* Macro to avoid repeating the code five times. */ #define CLEAR_LINEAR(mEta) \ if (mEta->mro_linear_all) { \ - SvREFCNT_dec(MUTABLE_SV(mEta->mro_linear_all)); \ - mEta->mro_linear_all = NULL; \ - /* This is just acting as a shortcut pointer. */ \ - mEta->mro_linear_current = NULL; \ + SvREFCNT_dec(MUTABLE_SV(mEta->mro_linear_all)); \ + mEta->mro_linear_all = NULL; \ + /* This is just acting as a shortcut pointer. */ \ + mEta->mro_linear_current = NULL; \ } else if (mEta->mro_linear_current) { \ - /* Only the current MRO is stored, so this owns the data. */ \ - SvREFCNT_dec(mEta->mro_linear_current); \ - mEta->mro_linear_current = NULL; \ + /* Only the current MRO is stored, so this owns the data. */ \ + SvREFCNT_dec(mEta->mro_linear_current); \ + mEta->mro_linear_current = NULL; \ } void @@ -512,9 +512,9 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) meta = HvMROMETA(stash); CLEAR_LINEAR(meta); if (meta->isa) { - /* Steal it for our own purposes. */ - isa = (HV *)sv_2mortal((SV *)meta->isa); - meta->isa = NULL; + /* Steal it for our own purposes. */ + isa = (HV *)sv_2mortal((SV *)meta->isa); + meta->isa = NULL; } /* Inc the package generation, since our @ISA changed */ @@ -533,7 +533,7 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) } else { /* Wipe the local method cache otherwise */ meta->cache_gen++; - is_universal = FALSE; + is_universal = FALSE; } /* wipe next::method cache too */ @@ -573,19 +573,19 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) if(!revstash) continue; revmeta = HvMROMETA(revstash); - CLEAR_LINEAR(revmeta); + CLEAR_LINEAR(revmeta); if(!is_universal) revmeta->cache_gen++; if(revmeta->mro_nextmethod) hv_clear(revmeta->mro_nextmethod); - if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL; - - (void) - hv_store( - isa_hashes, (const char*)&revstash, sizeof(HV *), - revmeta->isa ? (SV *)revmeta->isa : &PL_sv_undef, 0 - ); - revmeta->isa = NULL; + if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL; + + (void) + hv_store( + isa_hashes, (const char*)&revstash, sizeof(HV *), + revmeta->isa ? (SV *)revmeta->isa : &PL_sv_undef, 0 + ); + revmeta->isa = NULL; } /* Second pass: Update PL_isarev. We can just use isa_hashes to @@ -661,20 +661,20 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0); - /* That fetch should not fail. But if it had to create a new SV for - us, then will need to upgrade it to an HV (which sv_upgrade() can - now do for us. */ + /* That fetch should not fail. But if it had to create a new SV for + us, then will need to upgrade it to an HV (which sv_upgrade() can + now do for us. */ mroisarev = MUTABLE_HV(HeVAL(he)); - SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV); + SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV); - /* This hash only ever contains PL_sv_yes. Storing it over itself is - almost as cheap as calling hv_exists, so on aggregate we expect to - save time by not making two calls to the common HV code for the - case where it doesn't exist. */ + /* This hash only ever contains PL_sv_yes. Storing it over itself is + almost as cheap as calling hv_exists, so on aggregate we expect to + save time by not making two calls to the common HV code for the + case where it doesn't exist. */ - (void)hv_storehek(mroisarev, stashhek, &PL_sv_yes); + (void)hv_storehek(mroisarev, stashhek, &PL_sv_yes); } /* Delete our name from our former parents' isarevs. */ @@ -771,12 +771,12 @@ Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash, * If flags & 1, the caller has asked us to skip the check. */ if(!(flags & 1)) { - SV **svp; - if( - !GvSTASH(gv) || !HvENAME(GvSTASH(gv)) || - !(svp = hv_fetchhek(GvSTASH(gv), GvNAME_HEK(gv), 0)) || - *svp != (SV *)gv - ) return; + SV **svp; + if( + !GvSTASH(gv) || !HvENAME(GvSTASH(gv)) || + !(svp = hv_fetchhek(GvSTASH(gv), GvNAME_HEK(gv), 0)) || + *svp != (SV *)gv + ) return; } assert(SvOOK(GvSTASH(gv))); assert(GvNAMELEN(gv)); @@ -784,56 +784,56 @@ Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash, assert(GvNAMELEN(gv) == 1 || GvNAME(gv)[GvNAMELEN(gv) - 2] == ':'); name_count = HvAUX(GvSTASH(gv))->xhv_name_count; if (!name_count) { - name_count = 1; - namep = &HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_name; + name_count = 1; + namep = &HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_name; } else { - namep = HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_names; - if (name_count < 0) ++namep, name_count = -name_count - 1; + namep = HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_names; + if (name_count < 0) ++namep, name_count = -name_count - 1; } if (name_count == 1) { - if (memEQs(HEK_KEY(*namep), HEK_LEN(*namep), "main")) { - namesv = GvNAMELEN(gv) == 1 - ? newSVpvs_flags(":", SVs_TEMP) - : newSVpvs_flags("", SVs_TEMP); - } - else { - namesv = sv_2mortal(newSVhek(*namep)); - if (GvNAMELEN(gv) == 1) sv_catpvs(namesv, ":"); - else sv_catpvs(namesv, "::"); - } - if (GvNAMELEN(gv) != 1) { - sv_catpvn_flags( - namesv, GvNAME(gv), GvNAMELEN(gv) - 2, - /* skip trailing :: */ - GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES - ); + if (memEQs(HEK_KEY(*namep), HEK_LEN(*namep), "main")) { + namesv = GvNAMELEN(gv) == 1 + ? newSVpvs_flags(":", SVs_TEMP) + : newSVpvs_flags("", SVs_TEMP); + } + else { + namesv = sv_2mortal(newSVhek(*namep)); + if (GvNAMELEN(gv) == 1) sv_catpvs(namesv, ":"); + else sv_catpvs(namesv, "::"); + } + if (GvNAMELEN(gv) != 1) { + sv_catpvn_flags( + namesv, GvNAME(gv), GvNAMELEN(gv) - 2, + /* skip trailing :: */ + GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES + ); } } else { - SV *aname; - namesv = sv_2mortal((SV *)newAV()); - while (name_count--) { - if(memEQs(HEK_KEY(*namep), HEK_LEN(*namep), "main")){ - aname = GvNAMELEN(gv) == 1 - ? newSVpvs(":") - : newSVpvs(""); - namep++; - } - else { - aname = newSVhek(*namep++); - if (GvNAMELEN(gv) == 1) sv_catpvs(aname, ":"); - else sv_catpvs(aname, "::"); - } - if (GvNAMELEN(gv) != 1) { - sv_catpvn_flags( - aname, GvNAME(gv), GvNAMELEN(gv) - 2, - /* skip trailing :: */ - GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES - ); + SV *aname; + namesv = sv_2mortal((SV *)newAV()); + while (name_count--) { + if(memEQs(HEK_KEY(*namep), HEK_LEN(*namep), "main")){ + aname = GvNAMELEN(gv) == 1 + ? newSVpvs(":") + : newSVpvs(""); + namep++; } - av_push((AV *)namesv, aname); - } + else { + aname = newSVhek(*namep++); + if (GvNAMELEN(gv) == 1) sv_catpvs(aname, ":"); + else sv_catpvs(aname, "::"); + } + if (GvNAMELEN(gv) != 1) { + sv_catpvn_flags( + aname, GvNAME(gv), GvNAMELEN(gv) - 2, + /* skip trailing :: */ + GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES + ); + } + av_push((AV *)namesv, aname); + } } /* Get a list of all the affected classes. */ @@ -859,25 +859,25 @@ Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash, mro_isa_changed_in on each. */ hv_iterinit(stashes); while((iter = hv_iternext(stashes))) { - HV * const this_stash = *(HV **)HEK_KEY(HeKEY_hek(iter)); - if(HvENAME(this_stash)) { - /* We have to restore the original meta->isa (that - mro_gather_and_rename set aside for us) this way, in case - one class in this list is a superclass of a another class - that we have already encountered. In such a case, meta->isa - will have been overwritten without old entries being deleted - from PL_isarev. */ - struct mro_meta * const meta = HvMROMETA(this_stash); - if(meta->isa != (HV *)HeVAL(iter)){ - SvREFCNT_dec(meta->isa); - meta->isa - = HeVAL(iter) == &PL_sv_yes - ? NULL - : (HV *)HeVAL(iter); - HeVAL(iter) = NULL; /* We donated our reference count. */ - } - mro_isa_changed_in(this_stash); - } + HV * const this_stash = *(HV **)HEK_KEY(HeKEY_hek(iter)); + if(HvENAME(this_stash)) { + /* We have to restore the original meta->isa (that + mro_gather_and_rename set aside for us) this way, in case + one class in this list is a superclass of a another class + that we have already encountered. In such a case, meta->isa + will have been overwritten without old entries being deleted + from PL_isarev. */ + struct mro_meta * const meta = HvMROMETA(this_stash); + if(meta->isa != (HV *)HeVAL(iter)){ + SvREFCNT_dec(meta->isa); + meta->isa + = HeVAL(iter) == &PL_sv_yes + ? NULL + : (HV *)HeVAL(iter); + HeVAL(iter) = NULL; /* We donated our reference count. */ + } + mro_isa_changed_in(this_stash); + } } } @@ -915,196 +915,196 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, */ if(oldstash) { - /* Add to the big list. */ - struct mro_meta * meta; - HE * const entry - = (HE *) - hv_common( - seen_stashes, NULL, (const char *)&oldstash, sizeof(HV *), 0, - HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0 - ); - if(HeVAL(entry) == &PL_sv_undef || HeVAL(entry) == &PL_sv_yes) { - oldstash = NULL; - goto check_stash; - } - HeVAL(entry) - = HeVAL(entry) == &PL_sv_no ? &PL_sv_yes : &PL_sv_undef; - meta = HvMROMETA(oldstash); - (void) - hv_store( - stashes, (const char *)&oldstash, sizeof(HV *), - meta->isa - ? SvREFCNT_inc_simple_NN((SV *)meta->isa) - : &PL_sv_yes, - 0 - ); - CLEAR_LINEAR(meta); - - /* Update the effective name. */ - if(HvENAME_get(oldstash)) { - const HEK * const enamehek = HvENAME_HEK(oldstash); - if(SvTYPE(namesv) == SVt_PVAV) { - items = AvFILLp((AV *)namesv) + 1; - svp = AvARRAY((AV *)namesv); - } - else { - items = 1; - svp = &namesv; - } - while (items--) { + /* Add to the big list. */ + struct mro_meta * meta; + HE * const entry + = (HE *) + hv_common( + seen_stashes, NULL, (const char *)&oldstash, sizeof(HV *), 0, + HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0 + ); + if(HeVAL(entry) == &PL_sv_undef || HeVAL(entry) == &PL_sv_yes) { + oldstash = NULL; + goto check_stash; + } + HeVAL(entry) + = HeVAL(entry) == &PL_sv_no ? &PL_sv_yes : &PL_sv_undef; + meta = HvMROMETA(oldstash); + (void) + hv_store( + stashes, (const char *)&oldstash, sizeof(HV *), + meta->isa + ? SvREFCNT_inc_simple_NN((SV *)meta->isa) + : &PL_sv_yes, + 0 + ); + CLEAR_LINEAR(meta); + + /* Update the effective name. */ + if(HvENAME_get(oldstash)) { + const HEK * const enamehek = HvENAME_HEK(oldstash); + if(SvTYPE(namesv) == SVt_PVAV) { + items = AvFILLp((AV *)namesv) + 1; + svp = AvARRAY((AV *)namesv); + } + else { + items = 1; + svp = &namesv; + } + while (items--) { const U32 name_utf8 = SvUTF8(*svp); - STRLEN len; - const char *name = SvPVx_const(*svp, len); - if(PL_stashcache) { + STRLEN len; + const char *name = SvPVx_const(*svp, len); + if(PL_stashcache) { DEBUG_o(Perl_deb(aTHX_ "mro_gather_and_rename clearing PL_stashcache for '%" SVf "'\n", SVfARG(*svp))); - (void)hv_delete(PL_stashcache, name, name_utf8 ? -(I32)len : (I32)len, G_DISCARD); + (void)hv_delete(PL_stashcache, name, name_utf8 ? -(I32)len : (I32)len, G_DISCARD); } ++svp; - hv_ename_delete(oldstash, name, len, name_utf8); - - if (!fetched_isarev) { - /* If the name deletion caused a name change, then we - * are not going to call mro_isa_changed_in with this - * name (and not at all if it has become anonymous) so - * we need to delete old isarev entries here, both - * those in the superclasses and this class's own list - * of subclasses. We simply delete the latter from - * PL_isarev, since we still need it. hv_delete morti- - * fies it for us, so sv_2mortal is not necessary. */ - if(HvENAME_HEK(oldstash) != enamehek) { - if(meta->isa && HvARRAY(meta->isa)) - mro_clean_isarev(meta->isa, name, len, 0, 0, - name_utf8 ? HVhek_UTF8 : 0); - isarev = (HV *)hv_delete(PL_isarev, name, + hv_ename_delete(oldstash, name, len, name_utf8); + + if (!fetched_isarev) { + /* If the name deletion caused a name change, then we + * are not going to call mro_isa_changed_in with this + * name (and not at all if it has become anonymous) so + * we need to delete old isarev entries here, both + * those in the superclasses and this class's own list + * of subclasses. We simply delete the latter from + * PL_isarev, since we still need it. hv_delete morti- + * fies it for us, so sv_2mortal is not necessary. */ + if(HvENAME_HEK(oldstash) != enamehek) { + if(meta->isa && HvARRAY(meta->isa)) + mro_clean_isarev(meta->isa, name, len, 0, 0, + name_utf8 ? HVhek_UTF8 : 0); + isarev = (HV *)hv_delete(PL_isarev, name, name_utf8 ? -(I32)len : (I32)len, 0); - fetched_isarev=TRUE; - } - } - } - } + fetched_isarev=TRUE; + } + } + } + } } check_stash: if(stash) { - if(SvTYPE(namesv) == SVt_PVAV) { - items = AvFILLp((AV *)namesv) + 1; - svp = AvARRAY((AV *)namesv); - } - else { - items = 1; - svp = &namesv; - } - while (items--) { + if(SvTYPE(namesv) == SVt_PVAV) { + items = AvFILLp((AV *)namesv) + 1; + svp = AvARRAY((AV *)namesv); + } + else { + items = 1; + svp = &namesv; + } + while (items--) { const U32 name_utf8 = SvUTF8(*svp); - STRLEN len; - const char *name = SvPVx_const(*svp++, len); - hv_ename_add(stash, name, len, name_utf8); - } + STRLEN len; + const char *name = SvPVx_const(*svp++, len); + hv_ename_add(stash, name, len, name_utf8); + } /* Add it to the big list if it needs - * mro_isa_changed_in called on it. That happens if it was - * detached from the symbol table (so it had no HvENAME) before - * being assigned to the spot named by the 'name' variable, because - * its cached isa linearisation is now stale (the effective name - * having changed), and subclasses will then use that cache when - * mro_package_moved calls mro_isa_changed_in. (See - * [perl #77358].) - * - * If it did have a name, then its previous name is still - * used in isa caches, and there is no need for - * mro_package_moved to call mro_isa_changed_in. - */ - - entry - = (HE *) - hv_common( - seen_stashes, NULL, (const char *)&stash, sizeof(HV *), 0, - HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0 - ); - if(HeVAL(entry) == &PL_sv_yes || HeVAL(entry) == &PL_sv_no) - stash = NULL; - else { - HeVAL(entry) - = HeVAL(entry) == &PL_sv_undef ? &PL_sv_yes : &PL_sv_no; - if(!stash_had_name) - { - struct mro_meta * const meta = HvMROMETA(stash); - (void) - hv_store( - stashes, (const char *)&stash, sizeof(HV *), - meta->isa - ? SvREFCNT_inc_simple_NN((SV *)meta->isa) - : &PL_sv_yes, - 0 - ); - CLEAR_LINEAR(meta); - } - } + * mro_isa_changed_in called on it. That happens if it was + * detached from the symbol table (so it had no HvENAME) before + * being assigned to the spot named by the 'name' variable, because + * its cached isa linearisation is now stale (the effective name + * having changed), and subclasses will then use that cache when + * mro_package_moved calls mro_isa_changed_in. (See + * [perl #77358].) + * + * If it did have a name, then its previous name is still + * used in isa caches, and there is no need for + * mro_package_moved to call mro_isa_changed_in. + */ + + entry + = (HE *) + hv_common( + seen_stashes, NULL, (const char *)&stash, sizeof(HV *), 0, + HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0 + ); + if(HeVAL(entry) == &PL_sv_yes || HeVAL(entry) == &PL_sv_no) + stash = NULL; + else { + HeVAL(entry) + = HeVAL(entry) == &PL_sv_undef ? &PL_sv_yes : &PL_sv_no; + if(!stash_had_name) + { + struct mro_meta * const meta = HvMROMETA(stash); + (void) + hv_store( + stashes, (const char *)&stash, sizeof(HV *), + meta->isa + ? SvREFCNT_inc_simple_NN((SV *)meta->isa) + : &PL_sv_yes, + 0 + ); + CLEAR_LINEAR(meta); + } + } } if(!stash && !oldstash) - /* Both stashes have been encountered already. */ - return; + /* Both stashes have been encountered already. */ + return; /* Add all the subclasses to the big list. */ if(!fetched_isarev) { - /* If oldstash is not null, then we can use its HvENAME to look up - the isarev hash, since all its subclasses will be listed there. - It will always have an HvENAME. It the HvENAME was removed - above, then fetch_isarev will be true, and this code will not be - reached. - - If oldstash is null, then this is an empty spot with no stash in - it, so subclasses could be listed in isarev hashes belonging to - any of the names, so we have to check all of them. - */ - assert(!oldstash || HvENAME(oldstash)); - if (oldstash) { - /* Extra variable to avoid a compiler warning */ - const HEK * const hvename = HvENAME_HEK(oldstash); - fetched_isarev = TRUE; - svp = hv_fetchhek(PL_isarev, hvename, 0); - if (svp) isarev = MUTABLE_HV(*svp); - } - else if(SvTYPE(namesv) == SVt_PVAV) { - items = AvFILLp((AV *)namesv) + 1; - svp = AvARRAY((AV *)namesv); - } - else { - items = 1; - svp = &namesv; - } + /* If oldstash is not null, then we can use its HvENAME to look up + the isarev hash, since all its subclasses will be listed there. + It will always have an HvENAME. It the HvENAME was removed + above, then fetch_isarev will be true, and this code will not be + reached. + + If oldstash is null, then this is an empty spot with no stash in + it, so subclasses could be listed in isarev hashes belonging to + any of the names, so we have to check all of them. + */ + assert(!oldstash || HvENAME(oldstash)); + if (oldstash) { + /* Extra variable to avoid a compiler warning */ + const HEK * const hvename = HvENAME_HEK(oldstash); + fetched_isarev = TRUE; + svp = hv_fetchhek(PL_isarev, hvename, 0); + if (svp) isarev = MUTABLE_HV(*svp); + } + else if(SvTYPE(namesv) == SVt_PVAV) { + items = AvFILLp((AV *)namesv) + 1; + svp = AvARRAY((AV *)namesv); + } + else { + items = 1; + svp = &namesv; + } } if( isarev || !fetched_isarev ) { while (fetched_isarev || items--) { - HE *iter; - - if (!fetched_isarev) { - HE * const he = hv_fetch_ent(PL_isarev, *svp++, 0, 0); - if (!he || !(isarev = MUTABLE_HV(HeVAL(he)))) continue; - } - - hv_iterinit(isarev); - while((iter = hv_iternext(isarev))) { - HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0); - struct mro_meta * meta; - - if(!revstash) continue; - meta = HvMROMETA(revstash); - (void) - hv_store( - stashes, (const char *)&revstash, sizeof(HV *), - meta->isa - ? SvREFCNT_inc_simple_NN((SV *)meta->isa) - : &PL_sv_yes, - 0 - ); - CLEAR_LINEAR(meta); + HE *iter; + + if (!fetched_isarev) { + HE * const he = hv_fetch_ent(PL_isarev, *svp++, 0, 0); + if (!he || !(isarev = MUTABLE_HV(HeVAL(he)))) continue; } - if (fetched_isarev) break; + hv_iterinit(isarev); + while((iter = hv_iternext(isarev))) { + HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0); + struct mro_meta * meta; + + if(!revstash) continue; + meta = HvMROMETA(revstash); + (void) + hv_store( + stashes, (const char *)&revstash, sizeof(HV *), + meta->isa + ? SvREFCNT_inc_simple_NN((SV *)meta->isa) + : &PL_sv_yes, + 0 + ); + CLEAR_LINEAR(meta); + } + + if (fetched_isarev) break; } } @@ -1113,169 +1113,169 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, /* Skip the entire loop if the hash is empty. */ if(oldstash && HvUSEDKEYS(oldstash)) { - xhv = (XPVHV*)SvANY(oldstash); - seen = (HV *) sv_2mortal((SV *)newHV()); - - /* Iterate through entries in the oldstash, adding them to the - list, meanwhile doing the equivalent of $seen{$key} = 1. - */ - - while (++riter <= (I32)xhv->xhv_max) { - entry = (HvARRAY(oldstash))[riter]; - - /* Iterate through the entries in this list */ - for(; entry; entry = HeNEXT(entry)) { - const char* key; - I32 len; - - /* If this entry is not a glob, ignore it. - Try the next. */ - if (!isGV(HeVAL(entry))) continue; - - key = hv_iterkey(entry, &len); - if ((len > 1 && key[len-2] == ':' && key[len-1] == ':') - || (len == 1 && key[0] == ':')) { - HV * const oldsubstash = GvHV(HeVAL(entry)); - SV ** const stashentry - = stash ? hv_fetch(stash, key, HeUTF8(entry) ? -(I32)len : (I32)len, 0) : NULL; - HV *substash = NULL; - - /* Avoid main::main::main::... */ - if(oldsubstash == oldstash) continue; - - if( - ( - stashentry && *stashentry && isGV(*stashentry) - && (substash = GvHV(*stashentry)) - ) - || (oldsubstash && HvENAME_get(oldsubstash)) - ) - { - /* Add :: and the key (minus the trailing ::) - to each name. */ - SV *subname; - if(SvTYPE(namesv) == SVt_PVAV) { - SV *aname; - items = AvFILLp((AV *)namesv) + 1; - svp = AvARRAY((AV *)namesv); - subname = sv_2mortal((SV *)newAV()); - while (items--) { - aname = newSVsv(*svp++); - if (len == 1) - sv_catpvs(aname, ":"); - else { - sv_catpvs(aname, "::"); - sv_catpvn_flags( - aname, key, len-2, - HeUTF8(entry) - ? SV_CATUTF8 : SV_CATBYTES - ); - } - av_push((AV *)subname, aname); - } - } - else { - subname = sv_2mortal(newSVsv(namesv)); - if (len == 1) sv_catpvs(subname, ":"); - else { - sv_catpvs(subname, "::"); - sv_catpvn_flags( - subname, key, len-2, - HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES - ); - } - } - mro_gather_and_rename( - stashes, seen_stashes, - substash, oldsubstash, subname - ); - } - - (void)hv_store(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len, &PL_sv_yes, 0); - } - } - } + xhv = (XPVHV*)SvANY(oldstash); + seen = (HV *) sv_2mortal((SV *)newHV()); + + /* Iterate through entries in the oldstash, adding them to the + list, meanwhile doing the equivalent of $seen{$key} = 1. + */ + + while (++riter <= (I32)xhv->xhv_max) { + entry = (HvARRAY(oldstash))[riter]; + + /* Iterate through the entries in this list */ + for(; entry; entry = HeNEXT(entry)) { + const char* key; + I32 len; + + /* If this entry is not a glob, ignore it. + Try the next. */ + if (!isGV(HeVAL(entry))) continue; + + key = hv_iterkey(entry, &len); + if ((len > 1 && key[len-2] == ':' && key[len-1] == ':') + || (len == 1 && key[0] == ':')) { + HV * const oldsubstash = GvHV(HeVAL(entry)); + SV ** const stashentry + = stash ? hv_fetch(stash, key, HeUTF8(entry) ? -(I32)len : (I32)len, 0) : NULL; + HV *substash = NULL; + + /* Avoid main::main::main::... */ + if(oldsubstash == oldstash) continue; + + if( + ( + stashentry && *stashentry && isGV(*stashentry) + && (substash = GvHV(*stashentry)) + ) + || (oldsubstash && HvENAME_get(oldsubstash)) + ) + { + /* Add :: and the key (minus the trailing ::) + to each name. */ + SV *subname; + if(SvTYPE(namesv) == SVt_PVAV) { + SV *aname; + items = AvFILLp((AV *)namesv) + 1; + svp = AvARRAY((AV *)namesv); + subname = sv_2mortal((SV *)newAV()); + while (items--) { + aname = newSVsv(*svp++); + if (len == 1) + sv_catpvs(aname, ":"); + else { + sv_catpvs(aname, "::"); + sv_catpvn_flags( + aname, key, len-2, + HeUTF8(entry) + ? SV_CATUTF8 : SV_CATBYTES + ); + } + av_push((AV *)subname, aname); + } + } + else { + subname = sv_2mortal(newSVsv(namesv)); + if (len == 1) sv_catpvs(subname, ":"); + else { + sv_catpvs(subname, "::"); + sv_catpvn_flags( + subname, key, len-2, + HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES + ); + } + } + mro_gather_and_rename( + stashes, seen_stashes, + substash, oldsubstash, subname + ); + } + + (void)hv_store(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len, &PL_sv_yes, 0); + } + } + } } /* Skip the entire loop if the hash is empty. */ if (stash && HvUSEDKEYS(stash)) { - xhv = (XPVHV*)SvANY(stash); - riter = -1; - - /* Iterate through the new stash, skipping $seen{$key} items, - calling mro_gather_and_rename(stashes,seen,entry,NULL, ...). */ - while (++riter <= (I32)xhv->xhv_max) { - entry = (HvARRAY(stash))[riter]; - - /* Iterate through the entries in this list */ - for(; entry; entry = HeNEXT(entry)) { - const char* key; - I32 len; - - /* If this entry is not a glob, ignore it. - Try the next. */ - if (!isGV(HeVAL(entry))) continue; - - key = hv_iterkey(entry, &len); - if ((len > 1 && key[len-2] == ':' && key[len-1] == ':') - || (len == 1 && key[0] == ':')) { - HV *substash; - - /* If this entry was seen when we iterated through the - oldstash, skip it. */ - if(seen && hv_exists(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len)) continue; - - /* We get here only if this stash has no corresponding - entry in the stash being replaced. */ - - substash = GvHV(HeVAL(entry)); - if(substash) { - SV *subname; - - /* Avoid checking main::main::main::... */ - if(substash == stash) continue; - - /* Add :: and the key (minus the trailing ::) - to each name. */ - if(SvTYPE(namesv) == SVt_PVAV) { - SV *aname; - items = AvFILLp((AV *)namesv) + 1; - svp = AvARRAY((AV *)namesv); - subname = sv_2mortal((SV *)newAV()); - while (items--) { - aname = newSVsv(*svp++); - if (len == 1) - sv_catpvs(aname, ":"); - else { - sv_catpvs(aname, "::"); - sv_catpvn_flags( - aname, key, len-2, - HeUTF8(entry) - ? SV_CATUTF8 : SV_CATBYTES - ); - } - av_push((AV *)subname, aname); - } - } - else { - subname = sv_2mortal(newSVsv(namesv)); - if (len == 1) sv_catpvs(subname, ":"); - else { - sv_catpvs(subname, "::"); - sv_catpvn_flags( - subname, key, len-2, - HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES - ); - } - } - mro_gather_and_rename( - stashes, seen_stashes, - substash, NULL, subname - ); - } - } - } - } + xhv = (XPVHV*)SvANY(stash); + riter = -1; + + /* Iterate through the new stash, skipping $seen{$key} items, + calling mro_gather_and_rename(stashes,seen,entry,NULL, ...). */ + while (++riter <= (I32)xhv->xhv_max) { + entry = (HvARRAY(stash))[riter]; + + /* Iterate through the entries in this list */ + for(; entry; entry = HeNEXT(entry)) { + const char* key; + I32 len; + + /* If this entry is not a glob, ignore it. + Try the next. */ + if (!isGV(HeVAL(entry))) continue; + + key = hv_iterkey(entry, &len); + if ((len > 1 && key[len-2] == ':' && key[len-1] == ':') + || (len == 1 && key[0] == ':')) { + HV *substash; + + /* If this entry was seen when we iterated through the + oldstash, skip it. */ + if(seen && hv_exists(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len)) continue; + + /* We get here only if this stash has no corresponding + entry in the stash being replaced. */ + + substash = GvHV(HeVAL(entry)); + if(substash) { + SV *subname; + + /* Avoid checking main::main::main::... */ + if(substash == stash) continue; + + /* Add :: and the key (minus the trailing ::) + to each name. */ + if(SvTYPE(namesv) == SVt_PVAV) { + SV *aname; + items = AvFILLp((AV *)namesv) + 1; + svp = AvARRAY((AV *)namesv); + subname = sv_2mortal((SV *)newAV()); + while (items--) { + aname = newSVsv(*svp++); + if (len == 1) + sv_catpvs(aname, ":"); + else { + sv_catpvs(aname, "::"); + sv_catpvn_flags( + aname, key, len-2, + HeUTF8(entry) + ? SV_CATUTF8 : SV_CATBYTES + ); + } + av_push((AV *)subname, aname); + } + } + else { + subname = sv_2mortal(newSVsv(namesv)); + if (len == 1) sv_catpvs(subname, ":"); + else { + sv_catpvs(subname, "::"); + sv_catpvn_flags( + subname, key, len-2, + HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES + ); + } + } + mro_gather_and_rename( + stashes, seen_stashes, + substash, NULL, subname + ); + } + } + } + } } } @@ -1340,7 +1340,7 @@ Perl_mro_method_changed_in(pTHX_ HV *stash) /* else, invalidate the method caches of all child classes, but not itself */ if(isarev) { - HE* iter; + HE* iter; hv_iterinit(isarev); while((iter = hv_iternext(isarev))) { @@ -1374,15 +1374,15 @@ Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name) Perl_croak(aTHX_ "Invalid mro name: '%" SVf "'", name); if(meta->mro_which != which) { - if (meta->mro_linear_current && !meta->mro_linear_all) { - /* If we were storing something directly, put it in the hash before - we lose it. */ - Perl_mro_set_private_data(aTHX_ meta, meta->mro_which, - MUTABLE_SV(meta->mro_linear_current)); - } - meta->mro_which = which; - /* Scrub our cached pointer to the private data. */ - meta->mro_linear_current = NULL; + if (meta->mro_linear_current && !meta->mro_linear_all) { + /* If we were storing something directly, put it in the hash before + we lose it. */ + Perl_mro_set_private_data(aTHX_ meta, meta->mro_which, + MUTABLE_SV(meta->mro_linear_current)); + } + meta->mro_which = which; + /* Scrub our cached pointer to the private data. */ + meta->mro_linear_current = NULL; /* Only affects local method cache, not even child classes */ meta->cache_gen++; @@ -1412,7 +1412,7 @@ XS(XS_mro_method_changed_in) HV* class_stash; if(items != 1) - croak_xs_usage(cv, "classname"); + croak_xs_usage(cv, "classname"); classname = ST(0); diff --git a/numeric.c b/numeric.c index 52c454711f48..72130dd9f521 100644 --- a/numeric.c +++ b/numeric.c @@ -994,7 +994,7 @@ C is non-C, but no actual assignment (or SEGV) will occur. C will be set with C if trailing decimals were seen (in which case C<*valuep> gives the true value truncated to an integer), and C if the number is negative (in which case C<*valuep> holds the -absolute value). C is not set if e notation was used or the +absolute value). C is not set if C notation was used or the number is larger than a UV. C allows only C, which allows for trailing @@ -1367,9 +1367,9 @@ S_mulexp10(NV value, I32 exponent) I32 bit; if (exponent == 0) - return value; + return value; if (value == 0) - return (NV)0; + return (NV)0; /* On OpenVMS VAX we by default use the D_FLOAT double format, * and that format does not have *easy* capabilities [1] for @@ -1393,24 +1393,24 @@ S_mulexp10(NV value, I32 exponent) #if ((defined(VMS) && !defined(_IEEE_FP)) || defined(_UNICOS) || defined(DOUBLE_IS_VAX_FLOAT)) && defined(NV_MAX_10_EXP) STMT_START { - const NV exp_v = log10(value); - if (exponent >= NV_MAX_10_EXP || exponent + exp_v >= NV_MAX_10_EXP) - return NV_MAX; - if (exponent < 0) { - if (-(exponent + exp_v) >= NV_MAX_10_EXP) - return 0.0; - while (-exponent >= NV_MAX_10_EXP) { - /* combination does not overflow, but 10^(-exponent) does */ - value /= 10; - ++exponent; - } - } + const NV exp_v = log10(value); + if (exponent >= NV_MAX_10_EXP || exponent + exp_v >= NV_MAX_10_EXP) + return NV_MAX; + if (exponent < 0) { + if (-(exponent + exp_v) >= NV_MAX_10_EXP) + return 0.0; + while (-exponent >= NV_MAX_10_EXP) { + /* combination does not overflow, but 10^(-exponent) does */ + value /= 10; + ++exponent; + } + } } STMT_END; #endif if (exponent < 0) { - negative = 1; - exponent = -exponent; + negative = 1; + exponent = -exponent; #ifdef NV_MAX_10_EXP /* for something like 1234 x 10^-309, the action of calculating * the intermediate value 10^309 then returning 1234 / (10^309) @@ -1433,9 +1433,9 @@ S_mulexp10(NV value, I32 exponent) # define FP_OVERFLOWS_TO_ZERO #endif for (bit = 1; exponent; bit <<= 1) { - if (exponent & bit) { - exponent ^= bit; - result *= power; + if (exponent & bit) { + exponent ^= bit; + result *= power; #ifdef FP_OVERFLOWS_TO_ZERO if (result == 0) # ifdef NV_INF @@ -1444,12 +1444,12 @@ S_mulexp10(NV value, I32 exponent) return value < 0 ? -FLT_MAX : FLT_MAX; # endif #endif - /* Floating point exceptions are supposed to be turned off, - * but if we're obviously done, don't risk another iteration. - */ - if (exponent == 0) break; - } - power *= power; + /* Floating point exceptions are supposed to be turned off, + * but if we're obviously done, don't risk another iteration. + */ + if (exponent == 0) break; + } + power *= power; } return negative ? value / result : value * result; } @@ -1646,15 +1646,15 @@ Perl_my_atof3(pTHX_ const char* orig, NV* value, const STRLEN len) /* leading whitespace */ while (s < send && isSPACE(*s)) - ++s; + ++s; /* sign */ switch (*s) { - case '-': - negative = 1; - /* FALLTHROUGH */ - case '+': - ++s; + case '-': + negative = 1; + /* FALLTHROUGH */ + case '+': + ++s; } #endif @@ -1744,102 +1744,102 @@ Perl_my_atof3(pTHX_ const char* orig, NV* value, const STRLEN len) * large, we add the total to NV and start again */ while (s < send) { - if (isDIGIT(*s)) { - seen_digit = 1; - old_digit = digit; - digit = *s++ - '0'; - if (seen_dp) - exp_adjust[1]++; - - /* don't start counting until we see the first significant - * digit, eg the 5 in 0.00005... */ - if (!sig_digits && digit == 0) - continue; - - if (++sig_digits > MAX_SIG_DIGITS) { - /* limits of precision reached */ - if (digit > 5) { - ++accumulator[seen_dp]; - } else if (digit == 5) { - if (old_digit % 2) { /* round to even - Allen */ - ++accumulator[seen_dp]; - } - } - if (seen_dp) { - exp_adjust[1]--; - } else { - exp_adjust[0]++; - } - /* skip remaining digits */ - while (s < send && isDIGIT(*s)) { - ++s; - if (! seen_dp) { - exp_adjust[0]++; - } - } - /* warn of loss of precision? */ - } - else { - if (accumulator[seen_dp] > MAX_ACCUMULATE) { - /* add accumulator to result and start again */ - result[seen_dp] = S_mulexp10(result[seen_dp], - exp_acc[seen_dp]) - + (NV)accumulator[seen_dp]; - accumulator[seen_dp] = 0; - exp_acc[seen_dp] = 0; - } - accumulator[seen_dp] = accumulator[seen_dp] * 10 + digit; - ++exp_acc[seen_dp]; - } - } - else if (!seen_dp && GROK_NUMERIC_RADIX(&s, send)) { - seen_dp = 1; - if (sig_digits > MAX_SIG_DIGITS) { - while (s < send && isDIGIT(*s)) { - ++s; - } - break; - } - } - else { - break; - } + if (isDIGIT(*s)) { + seen_digit = 1; + old_digit = digit; + digit = *s++ - '0'; + if (seen_dp) + exp_adjust[1]++; + + /* don't start counting until we see the first significant + * digit, eg the 5 in 0.00005... */ + if (!sig_digits && digit == 0) + continue; + + if (++sig_digits > MAX_SIG_DIGITS) { + /* limits of precision reached */ + if (digit > 5) { + ++accumulator[seen_dp]; + } else if (digit == 5) { + if (old_digit % 2) { /* round to even - Allen */ + ++accumulator[seen_dp]; + } + } + if (seen_dp) { + exp_adjust[1]--; + } else { + exp_adjust[0]++; + } + /* skip remaining digits */ + while (s < send && isDIGIT(*s)) { + ++s; + if (! seen_dp) { + exp_adjust[0]++; + } + } + /* warn of loss of precision? */ + } + else { + if (accumulator[seen_dp] > MAX_ACCUMULATE) { + /* add accumulator to result and start again */ + result[seen_dp] = S_mulexp10(result[seen_dp], + exp_acc[seen_dp]) + + (NV)accumulator[seen_dp]; + accumulator[seen_dp] = 0; + exp_acc[seen_dp] = 0; + } + accumulator[seen_dp] = accumulator[seen_dp] * 10 + digit; + ++exp_acc[seen_dp]; + } + } + else if (!seen_dp && GROK_NUMERIC_RADIX(&s, send)) { + seen_dp = 1; + if (sig_digits > MAX_SIG_DIGITS) { + while (s < send && isDIGIT(*s)) { + ++s; + } + break; + } + } + else { + break; + } } result[0] = S_mulexp10(result[0], exp_acc[0]) + (NV)accumulator[0]; if (seen_dp) { - result[1] = S_mulexp10(result[1], exp_acc[1]) + (NV)accumulator[1]; + result[1] = S_mulexp10(result[1], exp_acc[1]) + (NV)accumulator[1]; } if (s < send && seen_digit && (isALPHA_FOLD_EQ(*s, 'e'))) { - bool expnegative = 0; - - ++s; - switch (*s) { - case '-': - expnegative = 1; - /* FALLTHROUGH */ - case '+': - ++s; - } - while (s < send && isDIGIT(*s)) - exponent = exponent * 10 + (*s++ - '0'); - if (expnegative) - exponent = -exponent; + bool expnegative = 0; + + ++s; + switch (*s) { + case '-': + expnegative = 1; + /* FALLTHROUGH */ + case '+': + ++s; + } + while (s < send && isDIGIT(*s)) + exponent = exponent * 10 + (*s++ - '0'); + if (expnegative) + exponent = -exponent; } /* now apply the exponent */ if (seen_dp) { - result[2] = S_mulexp10(result[0],exponent+exp_adjust[0]) - + S_mulexp10(result[1],exponent-exp_adjust[1]); + result[2] = S_mulexp10(result[0],exponent+exp_adjust[0]) + + S_mulexp10(result[1],exponent-exp_adjust[1]); } else { - result[2] = S_mulexp10(result[0],exponent+exp_adjust[0]); + result[2] = S_mulexp10(result[0],exponent+exp_adjust[0]); } /* now apply the sign */ if (negative) - result[2] = -result[2]; + result[2] = -result[2]; *value = result[2]; return (char *)s; #else /* USE_PERL_ATOF */ diff --git a/op.c b/op.c index 421387ed107b..e507d3244619 100644 --- a/op.c +++ b/op.c @@ -724,12 +724,28 @@ S_no_bareword_allowed(pTHX_ OP *o) o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */ } +void +Perl_no_bareword_filehandle(pTHX_ const char *fhname) { + PERL_ARGS_ASSERT_NO_BAREWORD_FILEHANDLE; + + if (strNE(fhname, "STDERR") + && strNE(fhname, "STDOUT") + && strNE(fhname, "STDIN") + && strNE(fhname, "_") + && strNE(fhname, "ARGV") + && strNE(fhname, "ARGVOUT") + && strNE(fhname, "DATA")) { + qerror(Perl_mess(aTHX_ "Bareword filehandle \"%s\" not allowed under 'no feature \"bareword_filehandles\"'", fhname)); + } +} + /* "register" allocation */ PADOFFSET Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) { PADOFFSET off; + bool is_idfirst, is_default; const bool is_our = (PL_parser->in_my == KEY_our); PERL_ARGS_ASSERT_ALLOCMY; @@ -738,14 +754,15 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf, (UV)flags); + is_idfirst = flags & SVf_UTF8 + ? isIDFIRST_utf8_safe((U8*)name + 1, name + len) + : isIDFIRST_A(name[1]); + + /* $_, @_, etc. */ + is_default = len == 2 && name[1] == '_'; + /* complain about "my $" etc etc */ - if ( len - && !( is_our - || isALPHA(name[1]) - || ( (flags & SVf_UTF8) - && isIDFIRST_utf8_safe((U8 *)name+1, name + len)) - || (name[1] == '_' && len > 2))) - { + if (!is_our && (!is_idfirst || is_default)) { const char * const type = PL_parser->in_my == KEY_sigvar ? "subroutine signature" : PL_parser->in_my == KEY_state ? "\"state\"" : "\"my\""; @@ -1406,8 +1423,6 @@ void Perl_op_refcnt_lock(pTHX) PERL_TSA_ACQUIRE(PL_op_mutex) { -#ifdef USE_ITHREADS -#endif PERL_UNUSED_CONTEXT; OP_REFCNT_LOCK; } @@ -1416,8 +1431,6 @@ void Perl_op_refcnt_unlock(pTHX) PERL_TSA_RELEASE(PL_op_mutex) { -#ifdef USE_ITHREADS -#endif PERL_UNUSED_CONTEXT; OP_REFCNT_UNLOCK; } @@ -5595,7 +5608,7 @@ Perl_cmpchain_finish(pTHX_ OP *ch) cmpop->op_private = 2; cmpop = CHECKOP(cmpoptype, cmpop); if(!cmpop->op_next && cmpop->op_type == cmpoptype) - cmpop = fold_constants(op_integerize(op_std_init(cmpop))); + cmpop = op_integerize(op_std_init(cmpop)); condop = condop ? newLOGOP(OP_CMPCHAIN_AND, 0, cmpop, condop) : cmpop; if (!nextrightarg) @@ -12740,6 +12753,8 @@ Perl_ck_eval(pTHX_ OP *o) op_free(o); enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL); + if(o->op_flags & OPf_SPECIAL) + enter->op_flags |= OPf_SPECIAL; /* establish postfix order */ enter->op_next = (OP*)enter; @@ -13092,6 +13107,11 @@ Perl_ck_fun(pTHX_ OP *o) { OP * const newop = newGVOP(OP_GV, 0, gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO)); + /* a first argument is handled by toke.c, ideally we'd + just check here but several ops don't use ck_fun() */ + if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED && numargs > 1) { + no_bareword_filehandle(SvPVX(cSVOPx_sv((SVOP*)kid))); + } /* replace kid with newop in chain */ op_sibling_splice(o, prev_kid, 1, newop); op_free(kid); @@ -15161,6 +15181,9 @@ Perl_ck_trunc(pTHX_ OP *o) { o->op_flags |= OPf_SPECIAL; kid->op_private &= ~OPpCONST_STRICT; + if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) { + no_bareword_filehandle(SvPVX(cSVOPx_sv(kid))); + } } } return ck_fun(o); @@ -17880,7 +17903,7 @@ Perl_rpeep(pTHX_ OP *o) || !r /* .... = (); */ || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */ || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */ - || (lscalars < 2) /* ($x, undef) = ... */ + || (lscalars < 2) /* (undef, $x) = ... */ ) { NOOP; /* always safe */ } diff --git a/op.h b/op.h index 975071756240..6d8729680b0c 100644 --- a/op.h +++ b/op.h @@ -65,7 +65,7 @@ typedef PERL_BITFIELD16 Optype; /* for efficiency, requires OPf_WANT_VOID == G_VOID etc */ #define OP_GIMME(op,dfl) \ - (((op)->op_flags & OPf_WANT) ? ((op)->op_flags & OPf_WANT) : dfl) + (((op)->op_flags & OPf_WANT) ? ((op)->op_flags & OPf_WANT) : dfl) #define OP_GIMME_REVERSE(flags) ((flags) & G_WANT) @@ -95,9 +95,9 @@ Deprecated. Use C instead. #define OPf_WANT_LIST 3 /* Want list of any length */ #define OPf_KIDS 4 /* There is a firstborn child. */ #define OPf_PARENS 8 /* This operator was parenthesized. */ - /* (Or block needs explicit scope entry.) */ + /* (Or block needs explicit scope entry.) */ #define OPf_REF 16 /* Certified reference. */ - /* (Return container, not containee). */ + /* (Return container, not containee). */ #define OPf_MOD 32 /* Will modify (lvalue). */ #define OPf_STACKED 64 /* Some arg is arriving on the stack. */ @@ -106,47 +106,48 @@ Deprecated. Use C instead. */ #define OPf_SPECIAL 128 /* Do something weird for this op: */ - /* On local LVAL, don't init local value. */ - /* On OP_SORT, subroutine is inlined. */ - /* On OP_NOT, inversion was implicit. */ - /* On OP_LEAVE, don't restore curpm, e.g. + /* On local LVAL, don't init local value. */ + /* On OP_SORT, subroutine is inlined. */ + /* On OP_NOT, inversion was implicit. */ + /* On OP_LEAVE, don't restore curpm, e.g. * /(...)/ while ...>; */ - /* On truncate, we truncate filehandle */ - /* On control verbs, we saw no label */ - /* On flipflop, we saw ... instead of .. */ - /* On UNOPs, saw bare parens, e.g. eof(). */ - /* On OP_CHDIR, handle (or bare parens) */ - /* On OP_NULL, saw a "do". */ - /* On OP_EXISTS, treat av as av, not avhv. */ - /* On OP_(ENTER|LEAVE)EVAL, don't clear $@ */ - /* On regcomp, "use re 'eval'" was in scope */ - /* On RV2[ACGHS]V, don't create GV--in - defined()*/ - /* On OP_DBSTATE, indicates breakpoint - * (runtime property) */ - /* On OP_REQUIRE, was seen as CORE::require */ - /* On OP_(ENTER|LEAVE)WHEN, there's - no condition */ - /* On OP_SMARTMATCH, an implicit smartmatch */ - /* On OP_ANONHASH and OP_ANONLIST, create a - reference to the new anon hash or array */ - /* On OP_HELEM, OP_MULTIDEREF and OP_HSLICE, + /* On truncate, we truncate filehandle */ + /* On control verbs, we saw no label */ + /* On flipflop, we saw ... instead of .. */ + /* On UNOPs, saw bare parens, e.g. eof(). */ + /* On OP_CHDIR, handle (or bare parens) */ + /* On OP_NULL, saw a "do". */ + /* On OP_EXISTS, treat av as av, not avhv. */ + /* On OP_(ENTER|LEAVE)EVAL, don't clear $@ */ + /* On regcomp, "use re 'eval'" was in scope */ + /* On RV2[ACGHS]V, don't create GV--in + defined()*/ + /* On OP_DBSTATE, indicates breakpoint + * (runtime property) */ + /* On OP_REQUIRE, was seen as CORE::require */ + /* On OP_(ENTER|LEAVE)WHEN, there's + no condition */ + /* On OP_SMARTMATCH, an implicit smartmatch */ + /* On OP_ANONHASH and OP_ANONLIST, create a + reference to the new anon hash or array */ + /* On OP_HELEM, OP_MULTIDEREF and OP_HSLICE, localization will be followed by assignment, so do not wipe the target if it is special (e.g. a glob or a magic SV) */ - /* On OP_MATCH, OP_SUBST & OP_TRANS, the - operand of a logical or conditional - that was optimised away, so it should - not be bound via =~ */ - /* On OP_CONST, from a constant CV */ - /* On OP_GLOB, two meanings: - - Before ck_glob, called as CORE::glob - - After ck_glob, use Perl glob function - */ + /* On OP_MATCH, OP_SUBST & OP_TRANS, the + operand of a logical or conditional + that was optimised away, so it should + not be bound via =~ */ + /* On OP_CONST, from a constant CV */ + /* On OP_GLOB, two meanings: + - Before ck_glob, called as CORE::glob + - After ck_glob, use Perl glob function + */ /* On OP_PADRANGE, push @_ */ /* On OP_DUMP, has no label */ /* On OP_UNSTACK, in a C-style for loop */ /* On OP_READLINE, it's for <<>>, not <> */ + /* On OP_ENTERTRY, this is a real try {} block. */ /* There is no room in op_flags for this one, so it has its own bit- field member (op_folded) instead. The flag is only used to tell op_convert_list to set op_folded. */ @@ -158,11 +159,11 @@ Deprecated. Use C instead. #if !defined(PERL_CORE) && !defined(PERL_EXT) # define GIMME \ - (PL_op->op_flags & OPf_WANT \ - ? ((PL_op->op_flags & OPf_WANT) == OPf_WANT_LIST \ - ? G_ARRAY \ - : G_SCALAR) \ - : dowantarray()) + (PL_op->op_flags & OPf_WANT \ + ? ((PL_op->op_flags & OPf_WANT) == OPf_WANT_LIST \ + ? G_ARRAY \ + : G_SCALAR) \ + : dowantarray()) #endif @@ -259,16 +260,16 @@ struct pmop { #endif U32 op_pmflags; union { - OP * op_pmreplroot; /* For OP_SUBST */ - PADOFFSET op_pmtargetoff; /* For OP_SPLIT lex ary or thr GV */ - GV * op_pmtargetgv; /* For OP_SPLIT non-threaded GV */ + OP * op_pmreplroot; /* For OP_SUBST */ + PADOFFSET op_pmtargetoff; /* For OP_SPLIT lex ary or thr GV */ + GV * op_pmtargetgv; /* For OP_SPLIT non-threaded GV */ } op_pmreplrootu; union { - OP * op_pmreplstart; /* Only used in OP_SUBST */ + OP * op_pmreplstart; /* Only used in OP_SUBST */ #ifdef USE_ITHREADS - PADOFFSET op_pmstashoff; /* Only used in OP_MATCH, with PMf_ONCE set */ + PADOFFSET op_pmstashoff; /* Only used in OP_MATCH, with PMf_ONCE set */ #else - HV * op_pmstash; + HV * op_pmstash; #endif } op_pmstashstartu; OP * op_code_list; /* list of (?{}) code blocks */ @@ -276,7 +277,7 @@ struct pmop { #ifdef USE_ITHREADS #define PM_GETRE(o) (SvTYPE(PL_regex_pad[(o)->op_pmoffset]) == SVt_REGEXP \ - ? (REGEXP*)(PL_regex_pad[(o)->op_pmoffset]) : NULL) + ? (REGEXP*)(PL_regex_pad[(o)->op_pmoffset]) : NULL) /* The assignment is just to enforce type safety (or at least get a warning). */ /* With first class regexps not via a reference one needs to assign @@ -288,7 +289,7 @@ struct pmop { #define PM_SETRE(o,r) STMT_START { \ REGEXP *const _pm_setre = (r); \ assert(_pm_setre); \ - PL_regex_pad[(o)->op_pmoffset] = MUTABLE_SV(_pm_setre); \ + PL_regex_pad[(o)->op_pmoffset] = MUTABLE_SV(_pm_setre); \ } STMT_END #else #define PM_GETRE(o) ((o)->op_pmregexp) @@ -390,16 +391,16 @@ struct pmop { ? PL_stashpad[(o)->op_pmstashstartu.op_pmstashoff] \ : NULL) # define PmopSTASH_set(o,hv) \ - (assert_((o)->op_pmflags & PMf_ONCE) \ - (o)->op_pmstashstartu.op_pmstashoff = \ - (hv) ? alloccopstash(hv) : 0) + (assert_((o)->op_pmflags & PMf_ONCE) \ + (o)->op_pmstashstartu.op_pmstashoff = \ + (hv) ? alloccopstash(hv) : 0) #else # define PmopSTASH(o) \ (((o)->op_pmflags & PMf_ONCE) ? (o)->op_pmstashstartu.op_pmstash : NULL) # if defined (DEBUGGING) && defined(PERL_USE_GCC_BRACE_GROUPS) # define PmopSTASH_set(o,hv) ({ \ - assert((o)->op_pmflags & PMf_ONCE); \ - ((o)->op_pmstashstartu.op_pmstash = (hv)); \ + assert((o)->op_pmflags & PMf_ONCE); \ + ((o)->op_pmstashstartu.op_pmstash = (hv)); \ }) # else # define PmopSTASH_set(o,hv) ((o)->op_pmstashstartu.op_pmstash = (hv)) @@ -506,12 +507,12 @@ typedef enum { # ifndef PERL_CORE # define IS_PADGV(v) (v && isGV(v)) # define IS_PADCONST(v) \ - (v && (SvREADONLY(v) || (SvIsCOW(v) && !SvLEN(v)))) + (v && (SvREADONLY(v) || (SvIsCOW(v) && !SvLEN(v)))) # endif # define cSVOPx_sv(v) (cSVOPx(v)->op_sv \ - ? cSVOPx(v)->op_sv : PAD_SVl((v)->op_targ)) + ? cSVOPx(v)->op_sv : PAD_SVl((v)->op_targ)) # define cSVOPx_svp(v) (cSVOPx(v)->op_sv \ - ? &cSVOPx(v)->op_sv : &PAD_SVl((v)->op_targ)) + ? &cSVOPx(v)->op_sv : &PAD_SVl((v)->op_targ)) # define cMETHOPx_rclass(v) PAD_SVl(cMETHOPx(v)->op_rclass_targ) #else # define cGVOPx_gv(o) ((GV*)cSVOPx(o)->op_sv) @@ -621,9 +622,9 @@ typedef enum { #define PERL_LOADMOD_DENY 0x1 /* no Module */ #define PERL_LOADMOD_NOIMPORT 0x2 /* use Module () */ #define PERL_LOADMOD_IMPORT_OPS 0x4 /* import arguments - are passed as a sin- - gle op tree, not a - list of SVs */ + are passed as a sin- + gle op tree, not a + list of SVs */ #if defined(PERL_IN_PERLY_C) || defined(PERL_IN_OP_C) || defined(PERL_IN_TOKE_C) #define ref(o, type) doref(o, type, TRUE) @@ -668,9 +669,9 @@ least an C. #endif #define NewOp(m,var,c,type) \ - (var = (type *) Perl_Slab_Alloc(aTHX_ c*sizeof(type))) + (var = (type *) Perl_Slab_Alloc(aTHX_ c*sizeof(type))) #define NewOpSz(m,var,size) \ - (var = (OP *) Perl_Slab_Alloc(aTHX_ size)) + (var = (OP *) Perl_Slab_Alloc(aTHX_ size)) #define FreeOp(p) Perl_Slab_Free(aTHX_ p) /* @@ -719,7 +720,7 @@ struct opslab { # define OPSLOT_HEADER STRUCT_OFFSET(OPSLOT, opslot_op) # define OpSLOT(o) (assert_(o->op_slabbed) \ - (OPSLOT *)(((char *)o)-OPSLOT_HEADER)) + (OPSLOT *)(((char *)o)-OPSLOT_HEADER)) /* the slab that owns this op */ # define OpMySLAB(o) \ @@ -732,14 +733,14 @@ struct opslab { ((OPSLOT*)(((I32 **)&(slab)->opslab_slots)+(offset))) # define OpslabREFCNT_dec(slab) \ - (((slab)->opslab_refcnt == 1) \ - ? opslab_free_nopad(slab) \ - : (void)--(slab)->opslab_refcnt) + (((slab)->opslab_refcnt == 1) \ + ? opslab_free_nopad(slab) \ + : (void)--(slab)->opslab_refcnt) /* Variant that does not null out the pads */ # define OpslabREFCNT_dec_padok(slab) \ - (((slab)->opslab_refcnt == 1) \ - ? opslab_free(slab) \ - : (void)--(slab)->opslab_refcnt) + (((slab)->opslab_refcnt == 1) \ + ? opslab_free(slab) \ + : (void)--(slab)->opslab_refcnt) #endif struct block_hooks { @@ -797,39 +798,39 @@ preprocessing token; the type of C depends on C. #define BhkENABLE(hk, which) \ STMT_START { \ - BhkFLAGS(hk) |= BHKf_ ## which; \ - assert(BhkENTRY(hk, which)); \ + BhkFLAGS(hk) |= BHKf_ ## which; \ + assert(BhkENTRY(hk, which)); \ } STMT_END #define BhkDISABLE(hk, which) \ STMT_START { \ - BhkFLAGS(hk) &= ~(BHKf_ ## which); \ + BhkFLAGS(hk) &= ~(BHKf_ ## which); \ } STMT_END #define BhkENTRY_set(hk, which, ptr) \ STMT_START { \ - (hk)->which = ptr; \ - BhkENABLE(hk, which); \ + (hk)->which = ptr; \ + BhkENABLE(hk, which); \ } STMT_END #define CALL_BLOCK_HOOKS(which, arg) \ STMT_START { \ - if (PL_blockhooks) { \ - SSize_t i; \ - for (i = av_top_index(PL_blockhooks); i >= 0; i--) { \ - SV *sv = AvARRAY(PL_blockhooks)[i]; \ - BHK *hk; \ - \ - assert(SvIOK(sv)); \ - if (SvUOK(sv)) \ - hk = INT2PTR(BHK *, SvUVX(sv)); \ - else \ - hk = INT2PTR(BHK *, SvIVX(sv)); \ - \ - if (BhkENTRY(hk, which)) \ - BhkENTRY(hk, which)(aTHX_ arg); \ - } \ - } \ + if (PL_blockhooks) { \ + SSize_t i; \ + for (i = av_top_index(PL_blockhooks); i >= 0; i--) { \ + SV *sv = AvARRAY(PL_blockhooks)[i]; \ + BHK *hk; \ + \ + assert(SvIOK(sv)); \ + if (SvUOK(sv)) \ + hk = INT2PTR(BHK *, SvUVX(sv)); \ + else \ + hk = INT2PTR(BHK *, SvIVX(sv)); \ + \ + if (BhkENTRY(hk, which)) \ + BhkENTRY(hk, which)(aTHX_ arg); \ + } \ + } \ } STMT_END /* flags for rv2cv_op_cv */ @@ -924,8 +925,8 @@ typedef enum { #define XopENTRY_set(xop, which, to) \ STMT_START { \ - (xop)->which = (to); \ - (xop)->xop_flags |= XOPf_ ## which; \ + (xop)->which = (to); \ + (xop)->xop_flags |= XOPf_ ## which; \ } STMT_END #define XopENTRY(xop, which) \ @@ -937,8 +938,8 @@ typedef enum { #define XopDISABLE(xop, which) ((xop)->xop_flags &= ~XOPf_ ## which) #define XopENABLE(xop, which) \ STMT_START { \ - (xop)->xop_flags |= XOPf_ ## which; \ - assert(XopENTRY(xop, which)); \ + (xop)->xop_flags |= XOPf_ ## which; \ + assert(XopENTRY(xop, which)); \ } STMT_END #define Perl_custom_op_xop(x) \ @@ -1009,13 +1010,13 @@ C is non-null. For a higher-level interface, see C>. #define OP_NAME(o) ((o)->op_type == OP_CUSTOM \ ? XopENTRYCUSTOM(o, xop_name) \ - : PL_op_name[(o)->op_type]) + : PL_op_name[(o)->op_type]) #define OP_DESC(o) ((o)->op_type == OP_CUSTOM \ ? XopENTRYCUSTOM(o, xop_desc) \ - : PL_op_desc[(o)->op_type]) + : PL_op_desc[(o)->op_type]) #define OP_CLASS(o) ((o)->op_type == OP_CUSTOM \ - ? XopENTRYCUSTOM(o, xop_class) \ - : (PL_opargs[(o)->op_type] & OA_CLASS_MASK)) + ? XopENTRYCUSTOM(o, xop_class) \ + : (PL_opargs[(o)->op_type] & OA_CLASS_MASK)) #define OP_TYPE_IS(o, type) ((o) && (o)->op_type == (type)) #define OP_TYPE_IS_NN(o, type) ((o)->op_type == (type)) diff --git a/opcode.h b/opcode.h index c754a6401524..dc4254cb4e99 100644 --- a/opcode.h +++ b/opcode.h @@ -13,6 +13,8 @@ * Any changes made here will be lost! */ +#if defined(PERL_CORE) || defined(PERL_EXT) + #define Perl_pp_scalar Perl_pp_null #define Perl_pp_padany Perl_unimplemented_op #define Perl_pp_regcmaybe Perl_pp_null @@ -138,6 +140,9 @@ #define Perl_pp_sgrent Perl_pp_ehostent #define Perl_pp_egrent Perl_pp_ehostent #define Perl_pp_custom Perl_unimplemented_op + +#endif /* End of if defined(PERL_CORE) || defined(PERL_EXT) */ + START_EXTERN_C #ifndef DOINIT @@ -544,7 +549,8 @@ EXTCONST char* const PL_op_name[] = { "isa", "cmpchain_and", "cmpchain_dup", - "freed", + "catch", + "freed", }; #endif @@ -952,7 +958,8 @@ EXTCONST char* const PL_op_desc[] = { "derived class test", "comparison chaining", "comparand shuffling", - "freed op", + "catch {} block", + "freed op", }; #endif @@ -1363,6 +1370,7 @@ EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */ Perl_pp_isa, Perl_pp_cmpchain_and, Perl_pp_cmpchain_dup, + Perl_pp_catch, } #endif ; @@ -1770,6 +1778,7 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */ Perl_ck_isa, /* isa */ Perl_ck_null, /* cmpchain_and */ Perl_ck_null, /* cmpchain_dup */ + Perl_ck_null, /* catch */ } #endif ; @@ -2178,6 +2187,7 @@ EXTCONST U32 PL_opargs[] = { 0x00000204, /* isa */ 0x00000300, /* cmpchain_and */ 0x00000100, /* cmpchain_dup */ + 0x00000300, /* catch */ }; #endif @@ -2845,6 +2855,7 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = { 12, /* isa */ 0, /* cmpchain_and */ 0, /* cmpchain_dup */ + 0, /* catch */ }; @@ -2863,7 +2874,7 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = { */ EXTCONST U16 PL_op_private_bitdefs[] = { - 0x0003, /* scalar, prototype, refgen, srefgen, readline, regcmaybe, regcreset, regcomp, substcont, chop, schop, defined, undef, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i_postdec, negate, i_negate, not, complement, ucfirst, lcfirst, uc, lc, quotemeta, aeach, avalues, each, pop, shift, grepstart, mapstart, mapwhile, range, and, or, dor, andassign, orassign, dorassign, argcheck, argdefelem, method, method_named, method_super, method_redir, method_redir_super, entergiven, leavegiven, enterwhen, leavewhen, untie, tied, dbmclose, getsockname, getpeername, lstat, stat, readlink, readdir, telldir, rewinddir, closedir, localtime, alarm, require, dofile, entertry, ghbyname, gnbyname, gpbyname, shostent, snetent, sprotoent, sservent, gpwnam, gpwuid, ggrnam, ggrgid, lock, once, fc, anonconst, cmpchain_and, cmpchain_dup */ + 0x0003, /* scalar, prototype, refgen, srefgen, readline, regcmaybe, regcreset, regcomp, substcont, chop, schop, defined, undef, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i_postdec, negate, i_negate, not, complement, ucfirst, lcfirst, uc, lc, quotemeta, aeach, avalues, each, pop, shift, grepstart, mapstart, mapwhile, range, and, or, dor, andassign, orassign, dorassign, argcheck, argdefelem, method, method_named, method_super, method_redir, method_redir_super, entergiven, leavegiven, enterwhen, leavewhen, untie, tied, dbmclose, getsockname, getpeername, lstat, stat, readlink, readdir, telldir, rewinddir, closedir, localtime, alarm, require, dofile, entertry, ghbyname, gnbyname, gpbyname, shostent, snetent, sprotoent, sservent, gpwnam, gpwuid, ggrnam, ggrgid, lock, once, fc, anonconst, cmpchain_and, cmpchain_dup, catch */ 0x2fdc, 0x41b9, /* pushmark */ 0x00bd, /* wantarray, runcv */ 0x0438, 0x1a50, 0x426c, 0x3d28, 0x3505, /* const */ @@ -3341,6 +3352,7 @@ EXTCONST U8 PL_op_private_valid[] = { /* ISA */ (OPpARG2_MASK), /* CMPCHAIN_AND */ (OPpARG1_MASK), /* CMPCHAIN_DUP */ (OPpARG1_MASK), + /* CATCH */ (OPpARG1_MASK), }; diff --git a/opnames.h b/opnames.h index 0e325466d15d..57d29583af81 100644 --- a/opnames.h +++ b/opnames.h @@ -414,10 +414,11 @@ typedef enum opcode { OP_ISA = 397, OP_CMPCHAIN_AND = 398, OP_CMPCHAIN_DUP = 399, + OP_CATCH = 400, OP_max } opcode; -#define MAXO 400 +#define MAXO 401 #define OP_FREED MAXO /* the OP_IS_* macros are optimized to a simple range check because diff --git a/os2/dl_os2.c b/os2/dl_os2.c index f15c465f621d..ccf2e1a84cbb 100644 --- a/os2/dl_os2.c +++ b/os2/dl_os2.c @@ -31,11 +31,11 @@ unsigned long _DLL_InitTerm(unsigned long modHandle, unsigned long flag) case 0: /* INIT */ /* Save handle */ dllHandle = modHandle; - handle_found = 1; + handle_found = 1; return TRUE; case 1: /* TERM */ - handle_found = 0; + handle_found = 0; dllHandle = (unsigned long)NULLHANDLE; return TRUE; } @@ -50,25 +50,25 @@ find_myself(void) { static APIRET APIENTRY (*pDosQueryModFromEIP) (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf, - ULONG * Offset, ULONG Address); + ULONG * Offset, ULONG Address); HMODULE doscalls_h, mod; static int failed; ULONG obj, offset, rc; char buf[260]; if (failed) - return 0; + return 0; failed = 1; doscalls_h = (HMODULE)dlopen("DOSCALLS",0); if (!doscalls_h) - return 0; + return 0; /* {&doscalls_handle, NULL, 360}, */ /* DosQueryModFromEIP */ rc = DosQueryProcAddr(doscalls_h, 360, 0, (PFN*)&pDosQueryModFromEIP); if (rc) - return 0; + return 0; rc = pDosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, (ULONG)dlopen); if (rc) - return 0; + return 0; failed = 0; handle_found = 1; dllHandle = mod; @@ -78,66 +78,66 @@ find_myself(void) void * dlopen(const char *path, int mode) { - HMODULE handle; - char tmp[260]; - const char *beg, *dot; - ULONG rc; - unsigned fpflag = _control87(0,0); - - fail[0] = 0; - if (!path) { /* Our own handle. */ - if (handle_found || find_myself()) { - char dllname[260]; - - if (handle_loaded) - return (void*)dllHandle; - rc = DosQueryModuleName(dllHandle, sizeof(dllname), dllname); - if (rc) { - strcpy(fail, "can't find my DLL name by the handle"); - retcode = rc; - return 0; - } - rc = DosLoadModule(fail, sizeof fail, dllname, &handle); - if (rc) { - strcpy(fail, "can't load my own DLL"); - retcode = rc; - return 0; - } - handle_loaded = 1; - goto ret; - } - retcode = ERROR_MOD_NOT_FOUND; + HMODULE handle; + char tmp[260]; + const char *beg, *dot; + ULONG rc; + unsigned fpflag = _control87(0,0); + + fail[0] = 0; + if (!path) { /* Our own handle. */ + if (handle_found || find_myself()) { + char dllname[260]; + + if (handle_loaded) + return (void*)dllHandle; + rc = DosQueryModuleName(dllHandle, sizeof(dllname), dllname); + if (rc) { + strcpy(fail, "can't find my DLL name by the handle"); + retcode = rc; + return 0; + } + rc = DosLoadModule(fail, sizeof fail, dllname, &handle); + if (rc) { + strcpy(fail, "can't load my own DLL"); + retcode = rc; + return 0; + } + handle_loaded = 1; + goto ret; + } + retcode = ERROR_MOD_NOT_FOUND; strcpy(fail, "can't load from myself: compiled without -DDLOPEN_INITTERM"); - return 0; - } - if ((rc = DosLoadModule(fail, sizeof fail, (char*)path, &handle)) == 0) - goto ret; - - retcode = rc; - - if (strlen(path) >= sizeof(tmp)) - return NULL; - - /* Not found. Check for non-FAT name and try truncated name. */ - /* Don't know if this helps though... */ - for (beg = dot = path + strlen(path); - beg > path && !memCHRs(":/\\", *(beg-1)); - beg--) - if (*beg == '.') - dot = beg; - if (dot - beg > 8) { - int n = beg+8-path; - - memmove(tmp, path, n); - memmove(tmp+n, dot, strlen(dot)+1); - if (DosLoadModule(fail, sizeof fail, tmp, &handle) == 0) - goto ret; - } - handle = 0; + return 0; + } + if ((rc = DosLoadModule(fail, sizeof fail, (char*)path, &handle)) == 0) + goto ret; + + retcode = rc; + + if (strlen(path) >= sizeof(tmp)) + return NULL; + + /* Not found. Check for non-FAT name and try truncated name. */ + /* Don't know if this helps though... */ + for (beg = dot = path + strlen(path); + beg > path && !memCHRs(":/\\", *(beg-1)); + beg--) + if (*beg == '.') + dot = beg; + if (dot - beg > 8) { + int n = beg+8-path; + + memmove(tmp, path, n); + memmove(tmp+n, dot, strlen(dot)+1); + if (DosLoadModule(fail, sizeof fail, tmp, &handle) == 0) + goto ret; + } + handle = 0; ret: - _control87(fpflag, MCW_EM); /* Some modules reset FP flags on load */ - return (void *)handle; + _control87(fpflag, MCW_EM); /* Some modules reset FP flags on load */ + return (void *)handle; } #define ERROR_WRONG_PROCTYPE 0xffffffff @@ -145,51 +145,51 @@ dlopen(const char *path, int mode) void * dlsym(void *handle, const char *symbol) { - ULONG rc, type; - PFN addr; - - fail[0] = 0; - rc = DosQueryProcAddr((HMODULE)handle, 0, symbol, &addr); - if (rc == 0) { - rc = DosQueryProcType((HMODULE)handle, 0, symbol, &type); - if (rc == 0 && type == PT_32BIT) - return (void *)addr; - rc = ERROR_WRONG_PROCTYPE; - } - retcode = rc; - return NULL; + ULONG rc, type; + PFN addr; + + fail[0] = 0; + rc = DosQueryProcAddr((HMODULE)handle, 0, symbol, &addr); + if (rc == 0) { + rc = DosQueryProcType((HMODULE)handle, 0, symbol, &type); + if (rc == 0 && type == PT_32BIT) + return (void *)addr; + rc = ERROR_WRONG_PROCTYPE; + } + retcode = rc; + return NULL; } char * dlerror(void) { - static char buf[700]; - ULONG len; - char *err; - - if (retcode == 0) - return NULL; - if (retcode == ERROR_WRONG_PROCTYPE) - err = "Wrong procedure type"; - else - err = os2error(retcode); - len = strlen(err); - if (len > sizeof(buf) - 1) - len = sizeof(buf) - 1; - strncpy(buf, err, len+1); - if (fail[0] && len + strlen(fail) < sizeof(buf) - 100) - sprintf(buf + len, ", possible problematic module: '%s'", fail); - retcode = 0; - return buf; + static char buf[700]; + ULONG len; + char *err; + + if (retcode == 0) + return NULL; + if (retcode == ERROR_WRONG_PROCTYPE) + err = "Wrong procedure type"; + else + err = os2error(retcode); + len = strlen(err); + if (len > sizeof(buf) - 1) + len = sizeof(buf) - 1; + strncpy(buf, err, len+1); + if (fail[0] && len + strlen(fail) < sizeof(buf) - 100) + sprintf(buf + len, ", possible problematic module: '%s'", fail); + retcode = 0; + return buf; } int dlclose(void *handle) { - ULONG rc; + ULONG rc; - if ((rc = DosFreeModule((HMODULE)handle)) == 0) return 0; + if ((rc = DosFreeModule((HMODULE)handle)) == 0) return 0; - retcode = rc; - return 2; + retcode = rc; + return 2; } diff --git a/os2/os2.c b/os2/os2.c index 3e2bd1b31bb1..ebe58b058b6d 100644 --- a/os2/os2.c +++ b/os2/os2.c @@ -246,7 +246,7 @@ pthreads_state_string(enum pthreads_state state) { if (state < 0 || state >= sizeof(pthreads_states)/sizeof(*pthreads_states)) { snprintf(pthreads_state_buf, sizeof(pthreads_state_buf), - "unknown thread state %d", (int)state); + "unknown thread state %d", (int)state); return pthreads_state_buf; } return pthreads_states[state]; @@ -269,53 +269,53 @@ pthread_join(perl_os_thread tid, void **status) { MUTEX_LOCK(&start_thread_mutex); if (tid < 1 || tid >= thread_join_count) { - MUTEX_UNLOCK(&start_thread_mutex); - if (tid != pthread_not_existant) - Perl_croak_nocontext("panic: join with a thread with strange ordinal %d", (int)tid); - Perl_warn_nocontext("panic: join with a thread which could not start"); - *status = 0; - return 0; + MUTEX_UNLOCK(&start_thread_mutex); + if (tid != pthread_not_existant) + Perl_croak_nocontext("panic: join with a thread with strange ordinal %d", (int)tid); + Perl_warn_nocontext("panic: join with a thread which could not start"); + *status = 0; + return 0; } switch (thread_join_data[tid].state) { case pthreads_st_exited: - thread_join_data[tid].state = pthreads_st_exited_waited; - *status = thread_join_data[tid].status; - MUTEX_UNLOCK(&start_thread_mutex); - COND_SIGNAL(&thread_join_data[tid].cond); - break; + thread_join_data[tid].state = pthreads_st_exited_waited; + *status = thread_join_data[tid].status; + MUTEX_UNLOCK(&start_thread_mutex); + COND_SIGNAL(&thread_join_data[tid].cond); + break; case pthreads_st_waited: - MUTEX_UNLOCK(&start_thread_mutex); - Perl_croak_nocontext("join with a thread with a waiter"); - break; + MUTEX_UNLOCK(&start_thread_mutex); + Perl_croak_nocontext("join with a thread with a waiter"); + break; case pthreads_st_norun: { - int state = (int)thread_join_data[tid].status; - - thread_join_data[tid].state = pthreads_st_none; - MUTEX_UNLOCK(&start_thread_mutex); - Perl_croak_nocontext("panic: join with a thread which could not run" - " due to attempt of tid reuse (state='%s')", - pthreads_state_string(state)); - break; + int state = (int)thread_join_data[tid].status; + + thread_join_data[tid].state = pthreads_st_none; + MUTEX_UNLOCK(&start_thread_mutex); + Perl_croak_nocontext("panic: join with a thread which could not run" + " due to attempt of tid reuse (state='%s')", + pthreads_state_string(state)); + break; } case pthreads_st_run: { - perl_cond cond; - - thread_join_data[tid].state = pthreads_st_waited; - thread_join_data[tid].status = (void *)status; - COND_INIT(&thread_join_data[tid].cond); - cond = thread_join_data[tid].cond; - COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex); - COND_DESTROY(&cond); - MUTEX_UNLOCK(&start_thread_mutex); - break; + perl_cond cond; + + thread_join_data[tid].state = pthreads_st_waited; + thread_join_data[tid].status = (void *)status; + COND_INIT(&thread_join_data[tid].cond); + cond = thread_join_data[tid].cond; + COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex); + COND_DESTROY(&cond); + MUTEX_UNLOCK(&start_thread_mutex); + break; } default: - MUTEX_UNLOCK(&start_thread_mutex); - Perl_croak_nocontext("panic: join with thread in unknown thread state: '%s'", - pthreads_state_string(thread_join_data[tid].state)); - break; + MUTEX_UNLOCK(&start_thread_mutex); + Perl_croak_nocontext("panic: join with thread in unknown thread state: '%s'", + pthreads_state_string(thread_join_data[tid].state)); + break; } return 0; } @@ -327,9 +327,9 @@ typedef struct { } pthr_startit; /* The lock is used: - a) Since we temporarily usurp the caller interp, so malloc() may - use it to decide on debugging the call; - b) Since *args is on the caller's stack. + a) Since we temporarily usurp the caller interp, so malloc() may + use it to decide on debugging the call; + b) Since *args is on the caller's stack. */ void pthread_startit(void *arg1) @@ -341,40 +341,40 @@ pthread_startit(void *arg1) int state; if (tid <= 1) { - /* Can't croak, the setjmp() is not in scope... */ - char buf[80]; - - snprintf(buf, sizeof(buf), - "panic: thread with strange ordinal %d created\n\r", tid); - write(2,buf,strlen(buf)); - MUTEX_UNLOCK(&start_thread_mutex); - return; + /* Can't croak, the setjmp() is not in scope... */ + char buf[80]; + + snprintf(buf, sizeof(buf), + "panic: thread with strange ordinal %d created\n\r", tid); + write(2,buf,strlen(buf)); + MUTEX_UNLOCK(&start_thread_mutex); + return; } /* Until args.sub resets it, makes debugging Perl_malloc() work: */ PERL_SET_CONTEXT(0); if (tid >= thread_join_count) { - int oc = thread_join_count; - - thread_join_count = tid + 5 + tid/5; - if (thread_join_data) { - Renew(thread_join_data, thread_join_count, thread_join_t); - Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t); - } else { - Newxz(thread_join_data, thread_join_count, thread_join_t); - } + int oc = thread_join_count; + + thread_join_count = tid + 5 + tid/5; + if (thread_join_data) { + Renew(thread_join_data, thread_join_count, thread_join_t); + Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t); + } else { + Newxz(thread_join_data, thread_join_count, thread_join_t); + } } if (thread_join_data[tid].state != pthreads_st_none) { - /* Can't croak, the setjmp() is not in scope... */ - char buf[80]; - - snprintf(buf, sizeof(buf), - "panic: attempt to reuse thread id %d (state='%s')\n\r", - tid, pthreads_state_string(thread_join_data[tid].state)); - write(2,buf,strlen(buf)); - thread_join_data[tid].status = (void*)thread_join_data[tid].state; - thread_join_data[tid].state = pthreads_st_norun; - MUTEX_UNLOCK(&start_thread_mutex); - return; + /* Can't croak, the setjmp() is not in scope... */ + char buf[80]; + + snprintf(buf, sizeof(buf), + "panic: attempt to reuse thread id %d (state='%s')\n\r", + tid, pthreads_state_string(thread_join_data[tid].state)); + write(2,buf,strlen(buf)); + thread_join_data[tid].status = (void*)thread_join_data[tid].state; + thread_join_data[tid].state = pthreads_st_norun; + MUTEX_UNLOCK(&start_thread_mutex); + return; } thread_join_data[tid].state = pthreads_st_run; /* Now that we copied/updated the guys, we may release the caller... */ @@ -383,35 +383,35 @@ pthread_startit(void *arg1) MUTEX_LOCK(&start_thread_mutex); switch (thread_join_data[tid].state) { case pthreads_st_waited: - COND_SIGNAL(&thread_join_data[tid].cond); - thread_join_data[tid].state = pthreads_st_none; - *((void**)thread_join_data[tid].status) = rc; - break; + COND_SIGNAL(&thread_join_data[tid].cond); + thread_join_data[tid].state = pthreads_st_none; + *((void**)thread_join_data[tid].status) = rc; + break; case pthreads_st_detached: - thread_join_data[tid].state = pthreads_st_none; - break; + thread_join_data[tid].state = pthreads_st_none; + break; case pthreads_st_run: - /* Somebody can wait on us; cannot exit, since OS can reuse the tid - and our waiter will get somebody else's status. */ - thread_join_data[tid].state = pthreads_st_exited; - thread_join_data[tid].status = rc; - COND_INIT(&thread_join_data[tid].cond); - COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex); - COND_DESTROY(&thread_join_data[tid].cond); - thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */ - break; + /* Somebody can wait on us; cannot exit, since OS can reuse the tid + and our waiter will get somebody else's status. */ + thread_join_data[tid].state = pthreads_st_exited; + thread_join_data[tid].status = rc; + COND_INIT(&thread_join_data[tid].cond); + COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex); + COND_DESTROY(&thread_join_data[tid].cond); + thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */ + break; default: - state = thread_join_data[tid].state; - MUTEX_UNLOCK(&start_thread_mutex); - Perl_croak_nocontext("panic: unexpected thread state on exit: '%s'", - pthreads_state_string(state)); + state = thread_join_data[tid].state; + MUTEX_UNLOCK(&start_thread_mutex); + Perl_croak_nocontext("panic: unexpected thread state on exit: '%s'", + pthreads_state_string(state)); } MUTEX_UNLOCK(&start_thread_mutex); } int pthread_create(perl_os_thread *tidp, const pthread_attr_t *attr, - void *(*start_routine)(void*), void *arg) + void *(*start_routine)(void*), void *arg) { dTHX; pthr_startit args; @@ -424,11 +424,11 @@ pthread_create(perl_os_thread *tidp, const pthread_attr_t *attr, /* Test suite creates 31 extra threads; on machine without shared-memory-hogs this stack sizeis OK with 31: */ *tidp = _beginthread(pthread_startit, /*stack*/ NULL, - /*stacksize*/ 4*1024*1024, (void*)&args); + /*stacksize*/ 4*1024*1024, (void*)&args); if (*tidp == -1) { - *tidp = pthread_not_existant; - MUTEX_UNLOCK(&start_thread_mutex); - return EINVAL; + *tidp = pthread_not_existant; + MUTEX_UNLOCK(&start_thread_mutex); + return EINVAL; } MUTEX_LOCK(&start_thread_mutex); /* Wait for init to proceed */ MUTEX_UNLOCK(&start_thread_mutex); @@ -440,45 +440,45 @@ pthread_detach(perl_os_thread tid) { MUTEX_LOCK(&start_thread_mutex); if (tid < 1 || tid >= thread_join_count) { - MUTEX_UNLOCK(&start_thread_mutex); - if (tid != pthread_not_existant) - Perl_croak_nocontext("panic: detach of a thread with strange ordinal %d", (int)tid); - Perl_warn_nocontext("detach of a thread which could not start"); - return 0; + MUTEX_UNLOCK(&start_thread_mutex); + if (tid != pthread_not_existant) + Perl_croak_nocontext("panic: detach of a thread with strange ordinal %d", (int)tid); + Perl_warn_nocontext("detach of a thread which could not start"); + return 0; } switch (thread_join_data[tid].state) { case pthreads_st_waited: - MUTEX_UNLOCK(&start_thread_mutex); - Perl_croak_nocontext("detach on a thread with a waiter"); - break; + MUTEX_UNLOCK(&start_thread_mutex); + Perl_croak_nocontext("detach on a thread with a waiter"); + break; case pthreads_st_run: - thread_join_data[tid].state = pthreads_st_detached; - MUTEX_UNLOCK(&start_thread_mutex); - break; + thread_join_data[tid].state = pthreads_st_detached; + MUTEX_UNLOCK(&start_thread_mutex); + break; case pthreads_st_exited: - MUTEX_UNLOCK(&start_thread_mutex); - COND_SIGNAL(&thread_join_data[tid].cond); - break; + MUTEX_UNLOCK(&start_thread_mutex); + COND_SIGNAL(&thread_join_data[tid].cond); + break; case pthreads_st_detached: - MUTEX_UNLOCK(&start_thread_mutex); - Perl_warn_nocontext("detach on an already detached thread"); - break; + MUTEX_UNLOCK(&start_thread_mutex); + Perl_warn_nocontext("detach on an already detached thread"); + break; case pthreads_st_norun: { - int state = (int)thread_join_data[tid].status; - - thread_join_data[tid].state = pthreads_st_none; - MUTEX_UNLOCK(&start_thread_mutex); - Perl_croak_nocontext("panic: detaching thread which could not run" - " due to attempt of tid reuse (state='%s')", - pthreads_state_string(state)); - break; + int state = (int)thread_join_data[tid].status; + + thread_join_data[tid].state = pthreads_st_none; + MUTEX_UNLOCK(&start_thread_mutex); + Perl_croak_nocontext("panic: detaching thread which could not run" + " due to attempt of tid reuse (state='%s')", + pthreads_state_string(state)); + break; } default: - MUTEX_UNLOCK(&start_thread_mutex); - Perl_croak_nocontext("panic: detach of a thread with unknown thread state: '%s'", - pthreads_state_string(thread_join_data[tid].state)); - break; + MUTEX_UNLOCK(&start_thread_mutex); + Perl_croak_nocontext("panic: detach of a thread with unknown thread state: '%s'", + pthreads_state_string(thread_join_data[tid].state)); + break; } return 0; } @@ -490,13 +490,13 @@ os2_cond_wait(perl_cond *c, perl_mutex *m) int rc; STRLEN n_a; if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET)) - Perl_rc = CheckOSError(rc), croak_with_os2error("panic: COND_WAIT-reset"); + Perl_rc = CheckOSError(rc), croak_with_os2error("panic: COND_WAIT-reset"); if (m) MUTEX_UNLOCK(m); if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT)) - && (rc != ERROR_INTERRUPT)) - croak_with_os2error("panic: COND_WAIT"); + && (rc != ERROR_INTERRUPT)) + croak_with_os2error("panic: COND_WAIT"); if (rc == ERROR_INTERRUPT) - errno = EINTR; + errno = EINTR; if (m) MUTEX_LOCK(m); return 0; } @@ -533,8 +533,8 @@ static const struct { {&pmwin_handle, NULL, 912}, /* WinDispatchMsg */ {&pmwin_handle, NULL, 753}, /* WinGetLastError */ {&pmwin_handle, NULL, 705}, /* WinCancelShutdown */ - /* These are needed in extensions. - How to protect PMSHAPI: it comes through EMX functions? */ + /* These are needed in extensions. + How to protect PMSHAPI: it comes through EMX functions? */ {&rexx_handle, "RexxStart", 0}, {&rexx_handle, "RexxVariablePool", 0}, {&rexxapi_handle, "RexxRegisterFunctionExe", 0}, @@ -549,7 +549,7 @@ static const struct { {&pmshapi_handle, "PRF32WRITEPROFILEDATA", 0}, /* At least some of these do not work by name, since they need - WIN32 instead of WIN... */ + WIN32 instead of WIN... */ #if 0 These were generated with nm I:\emx\lib\os2.a | fgrep -f API-list | grep = > API-list-entries @@ -646,8 +646,8 @@ loadModule(const char *modname, int fail) HMODULE h = (HMODULE)dlopen(modname, 0); if (!h && fail) - Perl_croak_nocontext("Error loading module '%s': %s", - modname, dlerror()); + Perl_croak_nocontext("Error loading module '%s': %s", + modname, dlerror()); return h; } @@ -662,7 +662,7 @@ my_type() if (!(_emx_env & 0x200)) return 1; /* not OS/2. */ if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) - return -1; + return -1; return (pib->pib_ultype); } @@ -675,9 +675,9 @@ my_type_set(int type) PIB *pib; if (!(_emx_env & 0x200)) - Perl_croak_nocontext("Can't set type on DOS"); /* not OS/2. */ + Perl_croak_nocontext("Can't set type on DOS"); /* not OS/2. */ if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) - croak_with_os2error("Error getting info blocks"); + croak_with_os2error("Error getting info blocks"); pib->pib_ultype = type; } @@ -685,54 +685,54 @@ PFN loadByOrdinal(enum entries_ordinals ord, int fail) { if (sizeof(loadOrdinals)/sizeof(loadOrdinals[0]) != ORD_NENTRIES) - Perl_croak_nocontext( - "Wrong size of loadOrdinals array: expected %d, actual %d", - sizeof(loadOrdinals)/sizeof(loadOrdinals[0]), ORD_NENTRIES); + Perl_croak_nocontext( + "Wrong size of loadOrdinals array: expected %d, actual %d", + sizeof(loadOrdinals)/sizeof(loadOrdinals[0]), ORD_NENTRIES); if (ExtFCN[ord] == NULL) { - PFN fcn = (PFN)-1; - APIRET rc; - - if (!loadOrdinals[ord].dll->handle) { - if (loadOrdinals[ord].dll->requires_pm && my_type() < 2) { /* FS */ - char *s = PerlEnv_getenv("PERL_ASIF_PM"); - - if (!s || !atoi(s)) { - /* The module will not function well without PM. - The usual way to detect PM is the existence of the mutex - \SEM32\PMDRAG.SEM. */ - HMTX hMtx = 0; - - if (CheckOSError(DosOpenMutexSem("\\SEM32\\PMDRAG.SEM", - &hMtx))) - Perl_croak_nocontext("Looks like we have no PM; will not load DLL %s without $ENV{PERL_ASIF_PM}", - loadOrdinals[ord].dll->modname); - DosCloseMutexSem(hMtx); - } - } - MUTEX_LOCK(&perlos2_state_mutex); - loadOrdinals[ord].dll->handle - = loadModule(loadOrdinals[ord].dll->modname, fail); - MUTEX_UNLOCK(&perlos2_state_mutex); - } - if (!loadOrdinals[ord].dll->handle) - return 0; /* Possible with FAIL==0 only */ - if (CheckOSError(DosQueryProcAddr(loadOrdinals[ord].dll->handle, - loadOrdinals[ord].entrypoint, - loadOrdinals[ord].entryname,&fcn))) { - char buf[20], *s = (char*)loadOrdinals[ord].entryname; - - if (!fail) - return 0; - if (!s) - sprintf(s = buf, "%d", loadOrdinals[ord].entrypoint); - Perl_croak_nocontext( - "This version of OS/2 does not support %s.%s", - loadOrdinals[ord].dll->modname, s); - } - ExtFCN[ord] = fcn; + PFN fcn = (PFN)-1; + APIRET rc; + + if (!loadOrdinals[ord].dll->handle) { + if (loadOrdinals[ord].dll->requires_pm && my_type() < 2) { /* FS */ + char *s = PerlEnv_getenv("PERL_ASIF_PM"); + + if (!s || !atoi(s)) { + /* The module will not function well without PM. + The usual way to detect PM is the existence of the mutex + \SEM32\PMDRAG.SEM. */ + HMTX hMtx = 0; + + if (CheckOSError(DosOpenMutexSem("\\SEM32\\PMDRAG.SEM", + &hMtx))) + Perl_croak_nocontext("Looks like we have no PM; will not load DLL %s without $ENV{PERL_ASIF_PM}", + loadOrdinals[ord].dll->modname); + DosCloseMutexSem(hMtx); + } + } + MUTEX_LOCK(&perlos2_state_mutex); + loadOrdinals[ord].dll->handle + = loadModule(loadOrdinals[ord].dll->modname, fail); + MUTEX_UNLOCK(&perlos2_state_mutex); + } + if (!loadOrdinals[ord].dll->handle) + return 0; /* Possible with FAIL==0 only */ + if (CheckOSError(DosQueryProcAddr(loadOrdinals[ord].dll->handle, + loadOrdinals[ord].entrypoint, + loadOrdinals[ord].entryname,&fcn))) { + char buf[20], *s = (char*)loadOrdinals[ord].entryname; + + if (!fail) + return 0; + if (!s) + sprintf(s = buf, "%d", loadOrdinals[ord].entrypoint); + Perl_croak_nocontext( + "This version of OS/2 does not support %s.%s", + loadOrdinals[ord].dll->modname, s); + } + ExtFCN[ord] = fcn; } if ((long)ExtFCN[ord] == -1) - Perl_croak_nocontext("panic queryaddr"); + Perl_croak_nocontext("panic queryaddr"); return ExtFCN[ord]; } @@ -742,7 +742,7 @@ init_PMWIN_entries(void) int i; for (i = ORD_WinInitialize; i <= ORD_WinCancelShutdown; i++) - ((PFN*)&PMWIN_entries)[i - ORD_WinInitialize] = loadByOrdinal(i, 1); + ((PFN*)&PMWIN_entries)[i - ORD_WinInitialize] = loadByOrdinal(i, 1); } /*****************************************************/ @@ -765,7 +765,7 @@ DeclVoidFuncByORD(endservent, ORD_ENDSERVENT, (void), ()) /* priorities */ static const signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged, - self inverse. */ + self inverse. */ #define QSS_INI_BUFFER 1024 ULONG (*pDosVerifyPidTid) (PID pid, TID tid); @@ -778,28 +778,28 @@ get_sysinfo(ULONG pid, ULONG flags) PQTOPLEVEL psi; if (pid) { - if (!pidtid_lookup) { - pidtid_lookup = 1; - *(PFN*)&pDosVerifyPidTid = loadByOrdinal(ORD_DosVerifyPidTid, 0); - } - if (pDosVerifyPidTid) { /* Warp3 or later */ - /* Up to some fixpak QuerySysState() kills the system if a non-existent - pid is used. */ - if (CheckOSError(pDosVerifyPidTid(pid, 1))) - return 0; + if (!pidtid_lookup) { + pidtid_lookup = 1; + *(PFN*)&pDosVerifyPidTid = loadByOrdinal(ORD_DosVerifyPidTid, 0); + } + if (pDosVerifyPidTid) { /* Warp3 or later */ + /* Up to some fixpak QuerySysState() kills the system if a non-existent + pid is used. */ + if (CheckOSError(pDosVerifyPidTid(pid, 1))) + return 0; } } Newx(pbuffer, buf_len, char); /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */ rc = QuerySysState(flags, pid, pbuffer, buf_len); while (rc == ERROR_BUFFER_OVERFLOW) { - Renew(pbuffer, buf_len *= 2, char); - rc = QuerySysState(flags, pid, pbuffer, buf_len); + Renew(pbuffer, buf_len *= 2, char); + rc = QuerySysState(flags, pid, pbuffer, buf_len); } if (rc) { - FillOSError(rc); - Safefree(pbuffer); - return 0; + FillOSError(rc); + Safefree(pbuffer); + return 0; } psi = (PQTOPLEVEL)pbuffer; if (psi && pid && psi->procdata && pid != psi->procdata->pid) { @@ -836,28 +836,28 @@ setpriority(int which, int pid, int val) if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) { /* Do not change class. */ return CheckOSError(DosSetPriority((pid < 0) - ? PRTYS_PROCESSTREE : PRTYS_PROCESS, - 0, - (32 - val) % 32 - (prio & 0xFF), - abs(pid))) + ? PRTYS_PROCESSTREE : PRTYS_PROCESS, + 0, + (32 - val) % 32 - (prio & 0xFF), + abs(pid))) ? -1 : 0; } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ { /* Documentation claims one can change both class and basevalue, * but I find it wrong. */ /* Change class, but since delta == 0 denotes absolute 0, correct. */ if (CheckOSError(DosSetPriority((pid < 0) - ? PRTYS_PROCESSTREE : PRTYS_PROCESS, - priors[(32 - val) >> 5] + 1, - 0, - abs(pid)))) - return -1; + ? PRTYS_PROCESSTREE : PRTYS_PROCESS, + priors[(32 - val) >> 5] + 1, + 0, + abs(pid)))) + return -1; if ( ((32 - val) % 32) == 0 ) return 0; return CheckOSError(DosSetPriority((pid < 0) - ? PRTYS_PROCESSTREE : PRTYS_PROCESS, - 0, - (32 - val) % 32, - abs(pid))) - ? -1 : 0; + ? PRTYS_PROCESSTREE : PRTYS_PROCESS, + 0, + (32 - val) % 32, + abs(pid))) + ? -1 : 0; } } @@ -891,7 +891,7 @@ spawn_sighandler(int sig) */ if (spawn_killed) - sig = SIGKILL; /* Try harder. */ + sig = SIGKILL; /* Try harder. */ kill(spawn_pid, sig); spawn_killed = 1; } @@ -899,40 +899,40 @@ spawn_sighandler(int sig) static int result(pTHX_ int flag, int pid) { - int r, status; - Signal_t (*ihand)(); /* place to save signal during system() */ - Signal_t (*qhand)(); /* place to save signal during system() */ + int r, status; + Signal_t (*ihand)(); /* place to save signal during system() */ + Signal_t (*qhand)(); /* place to save signal during system() */ #ifndef __EMX__ - RESULTCODES res; - int rpid; + RESULTCODES res; + int rpid; #endif - if (pid < 0 || flag != 0) - return pid; + if (pid < 0 || flag != 0) + return pid; #ifdef __EMX__ - spawn_pid = pid; - spawn_killed = 0; - ihand = rsignal(SIGINT, &spawn_sighandler); - qhand = rsignal(SIGQUIT, &spawn_sighandler); - do { - r = wait4pid(pid, &status, 0); - } while (r == -1 && errno == EINTR); - rsignal(SIGINT, ihand); - rsignal(SIGQUIT, qhand); - - PL_statusvalue = (U16)status; - if (r < 0) - return -1; - return status & 0xFFFF; + spawn_pid = pid; + spawn_killed = 0; + ihand = rsignal(SIGINT, &spawn_sighandler); + qhand = rsignal(SIGQUIT, &spawn_sighandler); + do { + r = wait4pid(pid, &status, 0); + } while (r == -1 && errno == EINTR); + rsignal(SIGINT, ihand); + rsignal(SIGQUIT, qhand); + + PL_statusvalue = (U16)status; + if (r < 0) + return -1; + return status & 0xFFFF; #else - ihand = rsignal(SIGINT, SIG_IGN); - r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid); - rsignal(SIGINT, ihand); - PL_statusvalue = res.codeResult << 8 | res.codeTerminate; - if (r) - return -1; - return PL_statusvalue; + ihand = rsignal(SIGINT, SIG_IGN); + r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid); + rsignal(SIGINT, ihand); + PL_statusvalue = res.codeResult << 8 | res.codeTerminate; + if (r) + return -1; + return PL_statusvalue; #endif } @@ -952,19 +952,19 @@ file_type(char *path) ULONG apptype; if (!(_emx_env & 0x200)) - Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */ + Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */ if (CheckOSError(DosQueryAppType(path, &apptype))) { - switch (rc) { - case ERROR_FILE_NOT_FOUND: - case ERROR_PATH_NOT_FOUND: - return -1; - case ERROR_ACCESS_DENIED: /* Directory with this name found? */ - return -3; - default: /* Found, but not an - executable, or some other - read error. */ - return -2; - } + switch (rc) { + case ERROR_FILE_NOT_FOUND: + case ERROR_PATH_NOT_FOUND: + return -1; + case ERROR_ACCESS_DENIED: /* Directory with this name found? */ + return -3; + default: /* Found, but not an + executable, or some other + read error. */ + return -2; + } } return apptype; } @@ -972,374 +972,374 @@ file_type(char *path) /* Spawn/exec a program, revert to shell if needed. */ extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *, - EXCEPTIONREGISTRATIONRECORD *, + EXCEPTIONREGISTRATIONRECORD *, CONTEXTRECORD *, void *); int do_spawn_ve(pTHX_ SV *really, const char **argv, U32 flag, U32 execf, char *inicmd, U32 addflag) { - int trueflag = flag; - int rc, pass = 1; - char *real_name = NULL; /* Shut down the warning */ - char const * args[4]; - static const char * const fargs[4] - = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", }; - const char * const *argsp = fargs; - int nargs = 4; - int force_shell; - int new_stderr = -1, nostderr = 0; - int fl_stderr = 0; - STRLEN n_a; - char *buf; - PerlIO *file; - - if (flag == P_WAIT) - flag = P_NOWAIT; - if (really) { - real_name = SvPV(really, n_a); - real_name = savepv(real_name); - SAVEFREEPV(real_name); - if (!*real_name) - really = NULL; - } + int trueflag = flag; + int rc, pass = 1; + char *real_name = NULL; /* Shut down the warning */ + char const * args[4]; + static const char * const fargs[4] + = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", }; + const char * const *argsp = fargs; + int nargs = 4; + int force_shell; + int new_stderr = -1, nostderr = 0; + int fl_stderr = 0; + STRLEN n_a; + char *buf; + PerlIO *file; + + if (flag == P_WAIT) + flag = P_NOWAIT; + if (really) { + real_name = SvPV(really, n_a); + real_name = savepv(real_name); + SAVEFREEPV(real_name); + if (!*real_name) + really = NULL; + } retry: - if (strEQ(argv[0],"/bin/sh")) - argv[0] = PL_sh_path; - - /* We should check PERL_SH* and PERLLIB_* as well? */ - if (!really || pass >= 2) - real_name = argv[0]; - if (real_name[0] != '/' && real_name[0] != '\\' - && !(real_name[0] && real_name[1] == ':' - && (real_name[2] == '/' || real_name[2] != '\\')) - ) /* will spawnvp use PATH? */ - TAINT_ENV(); /* testing IFS here is overkill, probably */ + if (strEQ(argv[0],"/bin/sh")) + argv[0] = PL_sh_path; + + /* We should check PERL_SH* and PERLLIB_* as well? */ + if (!really || pass >= 2) + real_name = argv[0]; + if (real_name[0] != '/' && real_name[0] != '\\' + && !(real_name[0] && real_name[1] == ':' + && (real_name[2] == '/' || real_name[2] != '\\')) + ) /* will spawnvp use PATH? */ + TAINT_ENV(); /* testing IFS here is overkill, probably */ reread: - force_shell = 0; - if (_emx_env & 0x200) { /* OS/2. */ - int type = file_type(real_name); - type_again: - if (type == -1) { /* Not found */ - errno = ENOENT; - rc = -1; - goto do_script; - } - else if (type == -2) { /* Not an EXE */ - errno = ENOEXEC; - rc = -1; - goto do_script; - } - else if (type == -3) { /* Is a directory? */ - /* Special-case this */ - char tbuf[512]; - int l = strlen(real_name); - - if (l + 5 <= sizeof tbuf) { - strcpy(tbuf, real_name); - strcpy(tbuf + l, ".exe"); - type = file_type(tbuf); - if (type >= -3) - goto type_again; - } - - errno = ENOEXEC; - rc = -1; - goto do_script; - } - switch (type & 7) { - /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */ - case FAPPTYP_WINDOWAPI: - { /* Apparently, kids are started basing on startup type, not the morphed type */ - if (os2_mytype != 3) { /* not PM */ - if (flag == P_NOWAIT) - flag = P_PM; - else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION && ckWARN(WARN_EXEC)) - Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting PM process with flag=%d, mytype=%d", - flag, os2_mytype); - } - } - break; - case FAPPTYP_NOTWINDOWCOMPAT: - { - if (os2_mytype != 0) { /* not full screen */ - if (flag == P_NOWAIT) - flag = P_SESSION; - else if ((flag & 7) != P_SESSION && ckWARN(WARN_EXEC)) - Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting Full Screen process with flag=%d, mytype=%d", - flag, os2_mytype); - } - } - break; - case FAPPTYP_NOTSPEC: - /* Let the shell handle this... */ - force_shell = 1; - buf = ""; /* Pacify a warning */ - file = 0; /* Pacify a warning */ - goto doshell_args; - break; - } - } - - if (addflag) { - addflag = 0; - new_stderr = dup(2); /* Preserve stderr */ - if (new_stderr == -1) { - if (errno == EBADF) - nostderr = 1; - else { - rc = -1; - goto finish; - } - } else - fl_stderr = fcntl(2, F_GETFD); - rc = dup2(1,2); - if (rc == -1) - goto finish; - fcntl(new_stderr, F_SETFD, FD_CLOEXEC); - } + force_shell = 0; + if (_emx_env & 0x200) { /* OS/2. */ + int type = file_type(real_name); + type_again: + if (type == -1) { /* Not found */ + errno = ENOENT; + rc = -1; + goto do_script; + } + else if (type == -2) { /* Not an EXE */ + errno = ENOEXEC; + rc = -1; + goto do_script; + } + else if (type == -3) { /* Is a directory? */ + /* Special-case this */ + char tbuf[512]; + int l = strlen(real_name); + + if (l + 5 <= sizeof tbuf) { + strcpy(tbuf, real_name); + strcpy(tbuf + l, ".exe"); + type = file_type(tbuf); + if (type >= -3) + goto type_again; + } + + errno = ENOEXEC; + rc = -1; + goto do_script; + } + switch (type & 7) { + /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */ + case FAPPTYP_WINDOWAPI: + { /* Apparently, kids are started basing on startup type, not the morphed type */ + if (os2_mytype != 3) { /* not PM */ + if (flag == P_NOWAIT) + flag = P_PM; + else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION && ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting PM process with flag=%d, mytype=%d", + flag, os2_mytype); + } + } + break; + case FAPPTYP_NOTWINDOWCOMPAT: + { + if (os2_mytype != 0) { /* not full screen */ + if (flag == P_NOWAIT) + flag = P_SESSION; + else if ((flag & 7) != P_SESSION && ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting Full Screen process with flag=%d, mytype=%d", + flag, os2_mytype); + } + } + break; + case FAPPTYP_NOTSPEC: + /* Let the shell handle this... */ + force_shell = 1; + buf = ""; /* Pacify a warning */ + file = 0; /* Pacify a warning */ + goto doshell_args; + break; + } + } + + if (addflag) { + addflag = 0; + new_stderr = dup(2); /* Preserve stderr */ + if (new_stderr == -1) { + if (errno == EBADF) + nostderr = 1; + else { + rc = -1; + goto finish; + } + } else + fl_stderr = fcntl(2, F_GETFD); + rc = dup2(1,2); + if (rc == -1) + goto finish; + fcntl(new_stderr, F_SETFD, FD_CLOEXEC); + } #if 0 - rc = result(aTHX_ trueflag, spawnvp(flag,real_name,argv)); + rc = result(aTHX_ trueflag, spawnvp(flag,real_name,argv)); #else - if (execf == EXECF_TRUEEXEC) - rc = execvp(real_name,argv); - else if (execf == EXECF_EXEC) - rc = spawnvp(trueflag | P_OVERLAY,real_name,argv); - else if (execf == EXECF_SPAWN_NOWAIT) - rc = spawnvp(flag,real_name,argv); + if (execf == EXECF_TRUEEXEC) + rc = execvp(real_name,argv); + else if (execf == EXECF_EXEC) + rc = spawnvp(trueflag | P_OVERLAY,real_name,argv); + else if (execf == EXECF_SPAWN_NOWAIT) + rc = spawnvp(flag,real_name,argv); else if (execf == EXECF_SYNC) - rc = spawnvp(trueflag,real_name,argv); + rc = spawnvp(trueflag,real_name,argv); else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */ - rc = result(aTHX_ trueflag, - spawnvp(flag,real_name,argv)); + rc = result(aTHX_ trueflag, + spawnvp(flag,real_name,argv)); #endif - if (rc < 0 && pass == 1) { - do_script: - if (real_name == argv[0]) { - int err = errno; - - if (err == ENOENT || err == ENOEXEC) { - /* No such file, or is a script. */ - /* Try adding script extensions to the file name, and - search on PATH. */ - char *scr = find_script(argv[0], TRUE, NULL, 0); - - if (scr) { - char *s = 0, *s1; - SV *scrsv = sv_2mortal(newSVpv(scr, 0)); - SV *bufsv = sv_newmortal(); + if (rc < 0 && pass == 1) { + do_script: + if (real_name == argv[0]) { + int err = errno; + + if (err == ENOENT || err == ENOEXEC) { + /* No such file, or is a script. */ + /* Try adding script extensions to the file name, and + search on PATH. */ + char *scr = find_script(argv[0], TRUE, NULL, 0); + + if (scr) { + char *s = 0, *s1; + SV *scrsv = sv_2mortal(newSVpv(scr, 0)); + SV *bufsv = sv_newmortal(); Safefree(scr); - scr = SvPV(scrsv, n_a); /* free()ed later */ + scr = SvPV(scrsv, n_a); /* free()ed later */ - file = PerlIO_open(scr, "r"); - argv[0] = scr; - if (!file) - goto panic_file; + file = PerlIO_open(scr, "r"); + argv[0] = scr; + if (!file) + goto panic_file; - buf = sv_gets(bufsv, file, 0 /* No append */); - if (!buf) - buf = ""; /* XXX Needed? */ - if (!buf[0]) { /* Empty... */ + buf = sv_gets(bufsv, file, 0 /* No append */); + if (!buf) + buf = ""; /* XXX Needed? */ + if (!buf[0]) { /* Empty... */ struct stat statbuf; - PerlIO_close(file); - /* Special case: maybe from -Zexe build, so - there is an executable around (contrary to - documentation, DosQueryAppType sometimes (?) - does not append ".exe", so we could have - reached this place). */ - sv_catpvs(scrsv, ".exe"); - argv[0] = scr = SvPV(scrsv, n_a); /* Reload */ + PerlIO_close(file); + /* Special case: maybe from -Zexe build, so + there is an executable around (contrary to + documentation, DosQueryAppType sometimes (?) + does not append ".exe", so we could have + reached this place). */ + sv_catpvs(scrsv, ".exe"); + argv[0] = scr = SvPV(scrsv, n_a); /* Reload */ if (PerlLIO_stat(scr,&statbuf) >= 0 && !S_ISDIR(statbuf.st_mode)) { /* Found */ - real_name = scr; - pass++; - goto reread; - } else { /* Restore */ - SvCUR_set(scrsv, SvCUR(scrsv) - 4); - *SvEND(scrsv) = 0; - } - } - if (PerlIO_close(file) != 0) { /* Failure */ - panic_file: - if (ckWARN(WARN_EXEC)) - Perl_warner(aTHX_ packWARN(WARN_EXEC), "Error reading \"%s\": %s", - scr, Strerror(errno)); - buf = ""; /* Not #! */ - goto doshell_args; - } - if (buf[0] == '#') { - if (buf[1] == '!') - s = buf + 2; - } else if (buf[0] == 'e') { - if (strBEGINs(buf, "extproc") - && isSPACE(buf[7])) - s = buf + 8; - } else if (buf[0] == 'E') { - if (strBEGINs(buf, "EXTPROC") - && isSPACE(buf[7])) - s = buf + 8; - } - if (!s) { - buf = ""; /* Not #! */ - goto doshell_args; - } - - s1 = s; - nargs = 0; - argsp = args; - while (1) { - /* Do better than pdksh: allow a few args, - strip trailing whitespace. */ - while (isSPACE(*s)) - s++; - if (*s == 0) - break; - if (nargs == 4) { - nargs = -1; - break; - } - args[nargs++] = s; - while (*s && !isSPACE(*s)) - s++; - if (*s == 0) - break; - *s++ = 0; - } - if (nargs == -1) { - Perl_warner(aTHX_ packWARN(WARN_EXEC), "Too many args on %.*s line of \"%s\"", - s1 - buf, buf, scr); - nargs = 4; - argsp = fargs; - } - /* Can jump from far, buf/file invalid if force_shell: */ - doshell_args: - { - char **a = argv; - const char *exec_args[2]; - - if (force_shell - || (!buf[0] && file)) { /* File without magic */ - /* In fact we tried all what pdksh would - try. There is no point in calling - pdksh, we may just emulate its logic. */ - char *shell = PerlEnv_getenv("EXECSHELL"); - char *shell_opt = NULL; - if (!shell) { - char *s; - - shell_opt = "/c"; - shell = PerlEnv_getenv("OS2_SHELL"); - if (inicmd) { /* No spaces at start! */ - s = inicmd; - while (*s && !isSPACE(*s)) { - if (*s++ == '/') { - inicmd = NULL; /* Cannot use */ - break; - } - } - } - if (!inicmd) { - s = argv[0]; - while (*s) { - /* Dosish shells will choke on slashes - in paths, fortunately, this is - important for zeroth arg only. */ - if (*s == '/') - *s = '\\'; - s++; - } - } - } - /* If EXECSHELL is set, we do not set */ - - if (!shell) - shell = ((_emx_env & 0x200) - ? "c:/os2/cmd.exe" - : "c:/command.com"); - nargs = shell_opt ? 2 : 1; /* shell file args */ - exec_args[0] = shell; - exec_args[1] = shell_opt; - argsp = exec_args; - if (nargs == 2 && inicmd) { - /* Use the original cmd line */ - /* XXXX This is good only until we refuse - quoted arguments... */ - argv[0] = inicmd; - argv[1] = NULL; - } - } else if (!buf[0] && inicmd) { /* No file */ - /* Start with the original cmdline. */ - /* XXXX This is good only until we refuse - quoted arguments... */ - - argv[0] = inicmd; - argv[1] = NULL; - nargs = 2; /* shell -c */ - } - - while (a[1]) /* Get to the end */ - a++; - a++; /* Copy finil NULL too */ - while (a >= argv) { - *(a + nargs) = *a; /* argv was preallocated to be - long enough. */ - a--; - } - while (--nargs >= 0) /* XXXX Discard const... */ - argv[nargs] = (char*)argsp[nargs]; - /* Enable pathless exec if #! (as pdksh). */ - pass = (buf[0] == '#' ? 2 : 3); - goto retry; - } - } - /* Not found: restore errno */ - errno = err; - } - } else if (errno == ENOEXEC) { /* Cannot transfer `real_name' via shell. */ - if (rc < 0 && ckWARN(WARN_EXEC)) - Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s script `%s' with ARGV[0] being `%s'", - ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) - ? "spawn" : "exec"), - real_name, argv[0]); - goto warned; - } else if (errno == ENOENT) { /* Cannot transfer `real_name' via shell. */ - if (rc < 0 && ckWARN(WARN_EXEC)) - Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)", - ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) - ? "spawn" : "exec"), - real_name, argv[0]); - goto warned; - } - } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */ - char *no_dir = strrchr(argv[0], '/'); - - /* Do as pdksh port does: if not found with /, try without - path. */ - if (no_dir) { - argv[0] = no_dir + 1; - pass++; - goto retry; - } - } - if (rc < 0 && ckWARN(WARN_EXEC)) - Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s\n", - ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) - ? "spawn" : "exec"), - real_name, Strerror(errno)); + real_name = scr; + pass++; + goto reread; + } else { /* Restore */ + SvCUR_set(scrsv, SvCUR(scrsv) - 4); + *SvEND(scrsv) = 0; + } + } + if (PerlIO_close(file) != 0) { /* Failure */ + panic_file: + if (ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ packWARN(WARN_EXEC), "Error reading \"%s\": %s", + scr, Strerror(errno)); + buf = ""; /* Not #! */ + goto doshell_args; + } + if (buf[0] == '#') { + if (buf[1] == '!') + s = buf + 2; + } else if (buf[0] == 'e') { + if (strBEGINs(buf, "extproc") + && isSPACE(buf[7])) + s = buf + 8; + } else if (buf[0] == 'E') { + if (strBEGINs(buf, "EXTPROC") + && isSPACE(buf[7])) + s = buf + 8; + } + if (!s) { + buf = ""; /* Not #! */ + goto doshell_args; + } + + s1 = s; + nargs = 0; + argsp = args; + while (1) { + /* Do better than pdksh: allow a few args, + strip trailing whitespace. */ + while (isSPACE(*s)) + s++; + if (*s == 0) + break; + if (nargs == 4) { + nargs = -1; + break; + } + args[nargs++] = s; + while (*s && !isSPACE(*s)) + s++; + if (*s == 0) + break; + *s++ = 0; + } + if (nargs == -1) { + Perl_warner(aTHX_ packWARN(WARN_EXEC), "Too many args on %.*s line of \"%s\"", + s1 - buf, buf, scr); + nargs = 4; + argsp = fargs; + } + /* Can jump from far, buf/file invalid if force_shell: */ + doshell_args: + { + char **a = argv; + const char *exec_args[2]; + + if (force_shell + || (!buf[0] && file)) { /* File without magic */ + /* In fact we tried all what pdksh would + try. There is no point in calling + pdksh, we may just emulate its logic. */ + char *shell = PerlEnv_getenv("EXECSHELL"); + char *shell_opt = NULL; + if (!shell) { + char *s; + + shell_opt = "/c"; + shell = PerlEnv_getenv("OS2_SHELL"); + if (inicmd) { /* No spaces at start! */ + s = inicmd; + while (*s && !isSPACE(*s)) { + if (*s++ == '/') { + inicmd = NULL; /* Cannot use */ + break; + } + } + } + if (!inicmd) { + s = argv[0]; + while (*s) { + /* Dosish shells will choke on slashes + in paths, fortunately, this is + important for zeroth arg only. */ + if (*s == '/') + *s = '\\'; + s++; + } + } + } + /* If EXECSHELL is set, we do not set */ + + if (!shell) + shell = ((_emx_env & 0x200) + ? "c:/os2/cmd.exe" + : "c:/command.com"); + nargs = shell_opt ? 2 : 1; /* shell file args */ + exec_args[0] = shell; + exec_args[1] = shell_opt; + argsp = exec_args; + if (nargs == 2 && inicmd) { + /* Use the original cmd line */ + /* XXXX This is good only until we refuse + quoted arguments... */ + argv[0] = inicmd; + argv[1] = NULL; + } + } else if (!buf[0] && inicmd) { /* No file */ + /* Start with the original cmdline. */ + /* XXXX This is good only until we refuse + quoted arguments... */ + + argv[0] = inicmd; + argv[1] = NULL; + nargs = 2; /* shell -c */ + } + + while (a[1]) /* Get to the end */ + a++; + a++; /* Copy finil NULL too */ + while (a >= argv) { + *(a + nargs) = *a; /* argv was preallocated to be + long enough. */ + a--; + } + while (--nargs >= 0) /* XXXX Discard const... */ + argv[nargs] = (char*)argsp[nargs]; + /* Enable pathless exec if #! (as pdksh). */ + pass = (buf[0] == '#' ? 2 : 3); + goto retry; + } + } + /* Not found: restore errno */ + errno = err; + } + } else if (errno == ENOEXEC) { /* Cannot transfer `real_name' via shell. */ + if (rc < 0 && ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s script `%s' with ARGV[0] being `%s'", + ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) + ? "spawn" : "exec"), + real_name, argv[0]); + goto warned; + } else if (errno == ENOENT) { /* Cannot transfer `real_name' via shell. */ + if (rc < 0 && ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)", + ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) + ? "spawn" : "exec"), + real_name, argv[0]); + goto warned; + } + } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */ + char *no_dir = strrchr(argv[0], '/'); + + /* Do as pdksh port does: if not found with /, try without + path. */ + if (no_dir) { + argv[0] = no_dir + 1; + pass++; + goto retry; + } + } + if (rc < 0 && ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s\n", + ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) + ? "spawn" : "exec"), + real_name, Strerror(errno)); warned: - if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT) - && ((trueflag & 0xFF) == P_WAIT)) - rc = -1; + if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT) + && ((trueflag & 0xFF) == P_WAIT)) + rc = -1; finish: if (new_stderr != -1) { /* How can we use error codes? */ - dup2(new_stderr, 2); - close(new_stderr); - fcntl(2, F_SETFD, fl_stderr); + dup2(new_stderr, 2); + close(new_stderr); + fcntl(2, F_SETFD, fl_stderr); } else if (nostderr) close(2); return rc; @@ -1357,13 +1357,13 @@ do_spawn3(pTHX_ char *cmd, int execf, int flag) ENTER; #ifdef TRYSHELL if ((shell = PerlEnv_getenv("EMXSHELL")) != NULL) - copt = "-c"; + copt = "-c"; else if ((shell = PerlEnv_getenv("SHELL")) != NULL) - copt = "-c"; + copt = "-c"; else if ((shell = PerlEnv_getenv("COMSPEC")) != NULL) - copt = "/C"; + copt = "/C"; else - shell = "cmd.exe"; + shell = "cmd.exe"; #else /* Consensus on perl5-porters is that it is _very_ important to have a shell which will not change between computers with the @@ -1374,81 +1374,81 @@ do_spawn3(pTHX_ char *cmd, int execf, int flag) #endif while (*cmd && isSPACE(*cmd)) - cmd++; + cmd++; if (strBEGINs(cmd,"/bin/sh") && isSPACE(cmd[7])) { - STRLEN l = strlen(PL_sh_path); - - Newx(news, strlen(cmd) - 7 + l + 1, char); - strcpy(news, PL_sh_path); - strcpy(news + l, cmd + 7); - cmd = news; + STRLEN l = strlen(PL_sh_path); + + Newx(news, strlen(cmd) - 7 + l + 1, char); + strcpy(news, PL_sh_path); + strcpy(news + l, cmd + 7); + cmd = news; } /* save an extra exec if possible */ /* see if there are shell metacharacters in it */ if (*cmd == '.' && isSPACE(cmd[1])) - goto doshell; + goto doshell; if (strBEGINs(cmd,"exec") && isSPACE(cmd[4])) - goto doshell; + goto doshell; for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */ if (*s == '=') - goto doshell; + goto doshell; for (s = cmd; *s; s++) { - if (*s != ' ' && !isALPHA(*s) && memCHRs("$&*(){}[]'\";\\|?<>~`\n",*s)) { - if (*s == '\n' && s[1] == '\0') { - *s = '\0'; - break; - } else if (*s == '\\' && !seenspace) { - continue; /* Allow backslashes in names */ - } else if (*s == '>' && s >= cmd + 3 - && s[-1] == '2' && s[1] == '&' && s[2] == '1' - && isSPACE(s[-2]) ) { - char *t = s + 3; - - while (*t && isSPACE(*t)) - t++; - if (!*t) { - s[-2] = '\0'; - mergestderr = 1; - break; /* Allow 2>&1 as the last thing */ - } - } - /* We do not convert this to do_spawn_ve since shell - should be smart enough to start itself gloriously. */ - doshell: - if (execf == EXECF_TRUEEXEC) + if (*s != ' ' && !isALPHA(*s) && memCHRs("$&*(){}[]'\";\\|?<>~`\n",*s)) { + if (*s == '\n' && s[1] == '\0') { + *s = '\0'; + break; + } else if (*s == '\\' && !seenspace) { + continue; /* Allow backslashes in names */ + } else if (*s == '>' && s >= cmd + 3 + && s[-1] == '2' && s[1] == '&' && s[2] == '1' + && isSPACE(s[-2]) ) { + char *t = s + 3; + + while (*t && isSPACE(*t)) + t++; + if (!*t) { + s[-2] = '\0'; + mergestderr = 1; + break; /* Allow 2>&1 as the last thing */ + } + } + /* We do not convert this to do_spawn_ve since shell + should be smart enough to start itself gloriously. */ + doshell: + if (execf == EXECF_TRUEEXEC) rc = execl(shell,shell,copt,cmd,(char*)0); - else if (execf == EXECF_EXEC) + else if (execf == EXECF_EXEC) rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0); - else if (execf == EXECF_SPAWN_NOWAIT) + else if (execf == EXECF_SPAWN_NOWAIT) rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0); - else if (execf == EXECF_SPAWN_BYFLAG) + else if (execf == EXECF_SPAWN_BYFLAG) rc = spawnl(flag,shell,shell,copt,cmd,(char*)0); - else { - /* In the ak code internal P_NOWAIT is P_WAIT ??? */ - if (execf == EXECF_SYNC) - rc = spawnl(P_WAIT,shell,shell,copt,cmd,(char*)0); - else - rc = result(aTHX_ P_WAIT, - spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0)); - if (rc < 0 && ckWARN(WARN_EXEC)) - Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s", - (execf == EXECF_SPAWN ? "spawn" : "exec"), - shell, Strerror(errno)); - if (rc < 0) - rc = -1; - } - if (news) - Safefree(news); - goto leave; - } else if (*s == ' ' || *s == '\t') { - seenspace = 1; - } + else { + /* In the ak code internal P_NOWAIT is P_WAIT ??? */ + if (execf == EXECF_SYNC) + rc = spawnl(P_WAIT,shell,shell,copt,cmd,(char*)0); + else + rc = result(aTHX_ P_WAIT, + spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0)); + if (rc < 0 && ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s", + (execf == EXECF_SPAWN ? "spawn" : "exec"), + shell, Strerror(errno)); + if (rc < 0) + rc = -1; + } + if (news) + Safefree(news); + goto leave; + } else if (*s == ' ' || *s == '\t') { + seenspace = 1; + } } /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */ @@ -1458,20 +1458,20 @@ do_spawn3(pTHX_ char *cmd, int execf, int flag) SAVEFREEPV(cmd); a = argv; for (s = cmd; *s;) { - while (*s && isSPACE(*s)) s++; - if (*s) - *(a++) = s; - while (*s && !isSPACE(*s)) s++; - if (*s) - *s++ = '\0'; + while (*s && isSPACE(*s)) s++; + if (*s) + *(a++) = s; + while (*s && !isSPACE(*s)) s++; + if (*s) + *s++ = '\0'; } *a = NULL; if (argv[0]) - rc = do_spawn_ve(aTHX_ NULL, argv, flag, execf, cmd, mergestderr); + rc = do_spawn_ve(aTHX_ NULL, argv, flag, execf, cmd, mergestderr); else - rc = -1; + rc = -1; if (news) - Safefree(news); + Safefree(news); leave: LEAVE; return rc; @@ -1494,37 +1494,37 @@ os2_aspawn_4(pTHX_ SV *really, SV **args, I32 cnt, int execing) ENTER; if (cnt) { - Newx(argv, cnt + 3, char*); /* 3 extra to expand #! */ - SAVEFREEPV(argv); - a = argv; - - if (cnt > 1 && SvNIOKp(*argp) && !SvPOKp(*argp)) { - flag = SvIVx(*argp); - flag_set = 1; - } else - --argp; - - while (++argp < last) { - if (*argp) { - char *arg = SvPVx(*argp, n_a); - arg = savepv(arg); - SAVEFREEPV(arg); - *a++ = arg; - } else - *a++ = ""; - } - *a = NULL; - - if ( flag_set && (a == argv + 1) - && !really && execing == ASPAWN_WAIT ) { /* One arg? */ - rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag); - } else { - const int execf[3] = {EXECF_SPAWN, EXECF_EXEC, EXECF_SPAWN_NOWAIT}; - - rc = do_spawn_ve(aTHX_ really, argv, flag, execf[execing], NULL, 0); - } + Newx(argv, cnt + 3, char*); /* 3 extra to expand #! */ + SAVEFREEPV(argv); + a = argv; + + if (cnt > 1 && SvNIOKp(*argp) && !SvPOKp(*argp)) { + flag = SvIVx(*argp); + flag_set = 1; + } else + --argp; + + while (++argp < last) { + if (*argp) { + char *arg = SvPVx(*argp, n_a); + arg = savepv(arg); + SAVEFREEPV(arg); + *a++ = arg; + } else + *a++ = ""; + } + *a = NULL; + + if ( flag_set && (a == argv + 1) + && !really && execing == ASPAWN_WAIT ) { /* One arg? */ + rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag); + } else { + const int execf[3] = {EXECF_SPAWN, EXECF_EXEC, EXECF_SPAWN_NOWAIT}; + + rc = do_spawn_ve(aTHX_ really, argv, flag, execf[execing], NULL, 0); + } } else - rc = -1; + rc = -1; LEAVE; return rc; } @@ -1582,63 +1582,63 @@ my_syspopen4(pTHX_ char *cmd, char *mode, I32 cnt, SV** args) this = (*mode == 'w'); that = !this; if (TAINTING_get) { - taint_env(); - taint_proper("Insecure %s%s", "EXEC"); + taint_env(); + taint_proper("Insecure %s%s", "EXEC"); } if (pipe(p) < 0) - return NULL; + return NULL; /* Now we need to spawn the child. */ if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */ - int new = dup(p[this]); + int new = dup(p[this]); - if (new == -1) - goto closepipes; - close(p[this]); - p[this] = new; + if (new == -1) + goto closepipes; + close(p[this]); + p[this] = new; } newfd = dup(*mode == 'r'); /* Preserve std* */ if (newfd == -1) { - /* This cannot happen due to fh being bad after pipe(), since - pipe() should have created fh 0 and 1 even if they were - initially closed. But we closed p[this] before. */ - if (errno != EBADF) { - closepipes: - close(p[0]); - close(p[1]); - return NULL; - } + /* This cannot happen due to fh being bad after pipe(), since + pipe() should have created fh 0 and 1 even if they were + initially closed. But we closed p[this] before. */ + if (errno != EBADF) { + closepipes: + close(p[0]); + close(p[1]); + return NULL; + } } else - fh_fl = fcntl(*mode == 'r', F_GETFD); + fh_fl = fcntl(*mode == 'r', F_GETFD); if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */ - dup2(p[that], *mode == 'r'); - close(p[that]); + dup2(p[that], *mode == 'r'); + close(p[that]); } /* Where is `this' and newfd now? */ fcntl(p[this], F_SETFD, FD_CLOEXEC); if (newfd != -1) - fcntl(newfd, F_SETFD, FD_CLOEXEC); + fcntl(newfd, F_SETFD, FD_CLOEXEC); if (cnt) { /* Args: "Real cmd", before first arg, the last, execing */ - pid = os2_aspawn_4(aTHX_ NULL, args, cnt, ASPAWN_NOWAIT); + pid = os2_aspawn_4(aTHX_ NULL, args, cnt, ASPAWN_NOWAIT); } else - pid = do_spawn_nowait(aTHX_ cmd); + pid = do_spawn_nowait(aTHX_ cmd); if (newfd == -1) - close(*mode == 'r'); /* It was closed initially */ + close(*mode == 'r'); /* It was closed initially */ else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */ - dup2(newfd, *mode == 'r'); /* Return std* back. */ - close(newfd); - fcntl(*mode == 'r', F_SETFD, fh_fl); + dup2(newfd, *mode == 'r'); /* Return std* back. */ + close(newfd); + fcntl(*mode == 'r', F_SETFD, fh_fl); } else - fcntl(*mode == 'r', F_SETFD, fh_fl); + fcntl(*mode == 'r', F_SETFD, fh_fl); if (p[that] == (*mode == 'r')) - close(p[that]); + close(p[that]); if (pid == -1) { - close(p[this]); - return NULL; + close(p[this]); + return NULL; } if (p[that] < p[this]) { /* Make fh as small as possible */ - dup2(p[this], p[that]); - close(p[this]); - p[this] = p[that]; + dup2(p[this], p[that]); + close(p[this]); + p[this] = p[that]; } sv = *av_fetch(PL_fdpid,p[this],TRUE); (void)SvUPGRADE(sv,SVt_IV); @@ -1652,7 +1652,7 @@ my_syspopen4(pTHX_ char *cmd, char *mode, I32 cnt, SV** args) SV *sv; if (cnt) - Perl_croak(aTHX_ "List form of piped open not implemented"); + Perl_croak(aTHX_ "List form of piped open not implemented"); # ifdef TRYSHELL res = popen(cmd, mode); @@ -1726,16 +1726,16 @@ static void massage_os2_attr(struct stat *st) { if ( ((st->st_mode & S_IFMT) != S_IFREG - && (st->st_mode & S_IFMT) != S_IFDIR) + && (st->st_mode & S_IFMT) != S_IFDIR) || !(st->st_attr & (FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM))) - return; + return; if ( st->st_attr & FILE_ARCHIVED ) - st->st_mode |= (os2_stat_archived | os2_stat_force); + st->st_mode |= (os2_stat_archived | os2_stat_force); if ( st->st_attr & FILE_HIDDEN ) - st->st_mode |= (os2_stat_hidden | os2_stat_force); + st->st_mode |= (os2_stat_hidden | os2_stat_force); if ( st->st_attr & FILE_SYSTEM ) - st->st_mode |= (os2_stat_system | os2_stat_force); + st->st_mode |= (os2_stat_system | os2_stat_force); } /* First attempt used DosQueryFSAttach which crashed the system when @@ -1748,15 +1748,15 @@ os2_stat(const char *name, struct stat *st) if ( ( l < 8 || l > 9) || strnicmp(name, "/dev/", 5) != 0 || ( stricmp(name + 5, "con") != 0 - && stricmp(name + 5, "tty") != 0 - && stricmp(name + 5, "nul") != 0 - && stricmp(name + 5, "null") != 0) ) { - int s = stat(name, st); - - if (s) - return s; - massage_os2_attr(st); - return 0; + && stricmp(name + 5, "tty") != 0 + && stricmp(name + 5, "nul") != 0 + && stricmp(name + 5, "null") != 0) ) { + int s = stat(name, st); + + if (s) + return s; + massage_os2_attr(st); + return 0; } memset(st, 0, sizeof *st); @@ -1774,7 +1774,7 @@ os2_fstat(int handle, struct stat *st) int s = fstat(handle, st); if (s) - return s; + return s; massage_os2_attr(st); return 0; } @@ -1786,15 +1786,15 @@ os2_chmod (const char *name, int pmode) /* Modelled after EMX src/lib/io/chmod.c int attr, rc; if (!(pmode & os2_stat_force)) - return chmod(name, pmode); + return chmod(name, pmode); attr = __chmod (name, 0, 0); /* Get attributes */ if (attr < 0) - return -1; + return -1; if (pmode & S_IWRITE) - attr &= ~FILE_READONLY; + attr &= ~FILE_READONLY; else - attr |= FILE_READONLY; + attr |= FILE_READONLY; /* New logic */ attr &= ~(FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM); @@ -1822,9 +1822,9 @@ sys_alloc(int size) { APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE); if (rc == ERROR_NOT_ENOUGH_MEMORY) { - return (void *) -1; + return (void *) -1; } else if ( rc ) - Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc); + Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc); return got; } @@ -1846,10 +1846,10 @@ settmppath() len = strlen(p); tpath = (char *)malloc(len + strlen(TMPPATH1) + 2); if (tpath) { - strcpy(tpath, p); - tpath[len] = '/'; - strcpy(tpath + len + 1, TMPPATH1); - tmppath = tpath; + strcpy(tpath, p); + tpath[len] = '/'; + strcpy(tpath + len + 1, TMPPATH1); + tmppath = tpath; } } @@ -1859,23 +1859,23 @@ XS(XS_File__Copy_syscopy) { dXSARGS; if (items < 2 || items > 3) - Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)"); + Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)"); { - STRLEN n_a; - char * src = (char *)SvPV(ST(0),n_a); - char * dst = (char *)SvPV(ST(1),n_a); - U32 flag; - int RETVAL, rc; - dXSTARG; - - if (items < 3) - flag = 0; - else { - flag = (unsigned long)SvIV(ST(2)); - } - - RETVAL = !CheckOSError(DosCopy(src, dst, flag)); - XSprePUSH; PUSHi((IV)RETVAL); + STRLEN n_a; + char * src = (char *)SvPV(ST(0),n_a); + char * dst = (char *)SvPV(ST(1),n_a); + U32 flag; + int RETVAL, rc; + dXSTARG; + + if (items < 3) + flag = 0; + else { + flag = (unsigned long)SvIV(ST(2)); + } + + RETVAL = !CheckOSError(DosCopy(src, dst, flag)); + XSprePUSH; PUSHi((IV)RETVAL); } XSRETURN(1); } @@ -1883,21 +1883,21 @@ XS(XS_File__Copy_syscopy) /* APIRET APIENTRY DosReplaceModule (PCSZ pszOld, PCSZ pszNew, PCSZ pszBackup); */ DeclOSFuncByORD(ULONG,replaceModule,ORD_DosReplaceModule, - (char *old, char *new, char *backup), (old, new, backup)) + (char *old, char *new, char *backup), (old, new, backup)) XS(XS_OS2_replaceModule); /* prototype to pass -Wmissing-prototypes */ XS(XS_OS2_replaceModule) { dXSARGS; if (items < 1 || items > 3) - Perl_croak(aTHX_ "Usage: OS2::replaceModule(target [, source [, backup]])"); + Perl_croak(aTHX_ "Usage: OS2::replaceModule(target [, source [, backup]])"); { - char * target = (char *)SvPV_nolen(ST(0)); - char * source = (items < 2) ? NULL : (char *)SvPV_nolen(ST(1)); - char * backup = (items < 3) ? NULL : (char *)SvPV_nolen(ST(2)); + char * target = (char *)SvPV_nolen(ST(0)); + char * source = (items < 2) ? NULL : (char *)SvPV_nolen(ST(1)); + char * backup = (items < 3) ? NULL : (char *)SvPV_nolen(ST(2)); - if (!replaceModule(target, source, backup)) - croak_with_os2error("replaceModule() error"); + if (!replaceModule(target, source, backup)) + croak_with_os2error("replaceModule() error"); } XSRETURN_YES; } @@ -1906,8 +1906,8 @@ XS(XS_OS2_replaceModule) ULONG ulParm2, ULONG ulParm3); */ DeclOSFuncByORD(ULONG,perfSysCall,ORD_DosPerfSysCall, - (ULONG ulCommand, ULONG ulParm1, ULONG ulParm2, ULONG ulParm3), - (ulCommand, ulParm1, ulParm2, ulParm3)) + (ULONG ulCommand, ULONG ulParm1, ULONG ulParm2, ULONG ulParm3), + (ulCommand, ulParm1, ulParm2, ulParm3)) #ifndef CMD_KI_RDCNT # define CMD_KI_RDCNT 0x63 @@ -1925,10 +1925,10 @@ typedef unsigned long long myCPUUTIL[4]; /* time/idle/busy/intr */ NO_OUTPUT ULONG perfSysCall(ULONG ulCommand, ULONG ulParm1, ULONG ulParm2, ULONG ulParm3) PREINIT: - ULONG rc; + ULONG rc; POSTCALL: - if (!RETVAL) - croak_with_os2error("perfSysCall() error"); + if (!RETVAL) + croak_with_os2error("perfSysCall() error"); */ static int @@ -1937,7 +1937,7 @@ numprocessors(void) ULONG res; if (DosQuerySysInfo(QSV_NUMPROCESSORS, QSV_NUMPROCESSORS, (PVOID)&res, sizeof(res))) - return 1; /* Old system? */ + return 1; /* Old system? */ return res; } @@ -1946,64 +1946,64 @@ XS(XS_OS2_perfSysCall) { dXSARGS; if (items < 0 || items > 4) - Perl_croak(aTHX_ "Usage: OS2::perfSysCall(ulCommand = CMD_KI_RDCNT, ulParm1= 0, ulParm2= 0, ulParm3= 0)"); + Perl_croak(aTHX_ "Usage: OS2::perfSysCall(ulCommand = CMD_KI_RDCNT, ulParm1= 0, ulParm2= 0, ulParm3= 0)"); SP -= items; { - dXSTARG; - ULONG RETVAL, ulCommand, ulParm1, ulParm2, ulParm3, res; - myCPUUTIL u[64]; - int total = 0, tot2 = 0; - - if (items < 1) - ulCommand = CMD_KI_RDCNT; - else { - ulCommand = (ULONG)SvUV(ST(0)); - } - - if (items < 2) { - total = (ulCommand == CMD_KI_RDCNT ? numprocessors() : 0); - ulParm1 = (total ? (ULONG)u : 0); - - if (total > C_ARRAY_LENGTH(u)) - croak("Unexpected number of processors: %d", total); - } else { - ulParm1 = (ULONG)SvUV(ST(1)); - } - - if (items < 3) { - tot2 = (ulCommand == CMD_KI_GETQTY); - ulParm2 = (tot2 ? (ULONG)&res : 0); - } else { - ulParm2 = (ULONG)SvUV(ST(2)); - } - - if (items < 4) - ulParm3 = 0; - else { - ulParm3 = (ULONG)SvUV(ST(3)); - } - - RETVAL = perfSysCall(ulCommand, ulParm1, ulParm2, ulParm3); - if (!RETVAL) - croak_with_os2error("perfSysCall() error"); - XSprePUSH; - if (total) { - int i,j; - - if (GIMME_V != G_ARRAY) { - PUSHn(u[0][0]); /* Total ticks on the first processor */ - XSRETURN(1); - } - EXTEND(SP, 4*total); - for (i=0; i < total; i++) - for (j=0; j < 4; j++) - PUSHs(sv_2mortal(newSVnv(u[i][j]))); - XSRETURN(4*total); - } - if (tot2) { - PUSHu(res); - XSRETURN(1); - } + dXSTARG; + ULONG RETVAL, ulCommand, ulParm1, ulParm2, ulParm3, res; + myCPUUTIL u[64]; + int total = 0, tot2 = 0; + + if (items < 1) + ulCommand = CMD_KI_RDCNT; + else { + ulCommand = (ULONG)SvUV(ST(0)); + } + + if (items < 2) { + total = (ulCommand == CMD_KI_RDCNT ? numprocessors() : 0); + ulParm1 = (total ? (ULONG)u : 0); + + if (total > C_ARRAY_LENGTH(u)) + croak("Unexpected number of processors: %d", total); + } else { + ulParm1 = (ULONG)SvUV(ST(1)); + } + + if (items < 3) { + tot2 = (ulCommand == CMD_KI_GETQTY); + ulParm2 = (tot2 ? (ULONG)&res : 0); + } else { + ulParm2 = (ULONG)SvUV(ST(2)); + } + + if (items < 4) + ulParm3 = 0; + else { + ulParm3 = (ULONG)SvUV(ST(3)); + } + + RETVAL = perfSysCall(ulCommand, ulParm1, ulParm2, ulParm3); + if (!RETVAL) + croak_with_os2error("perfSysCall() error"); + XSprePUSH; + if (total) { + int i,j; + + if (GIMME_V != G_ARRAY) { + PUSHn(u[0][0]); /* Total ticks on the first processor */ + XSRETURN(1); + } + EXTEND(SP, 4*total); + for (i=0; i < total; i++) + for (j=0; j < 4; j++) + PUSHs(sv_2mortal(newSVnv(u[i][j]))); + XSRETURN(4*total); + } + if (tot2) { + PUSHu(res); + XSRETURN(1); + } } XSRETURN_EMPTY; } @@ -2034,15 +2034,15 @@ mod2fname(pTHX_ SV *sv) len = strlen(s); if (len < 6) pos = len; while (*s) { - sum = 33 * sum + *(s++); /* Checksumming first chars to - * get the capitalization into c.s. */ + sum = 33 * sum + *(s++); /* Checksumming first chars to + * get the capitalization into c.s. */ } while (avlen > 0) { - s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a); - while (*s) { - sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */ - } - avlen --; + s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a); + while (*s) { + sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */ + } + avlen --; } /* We always load modules as *specific* DLLs, and with the full name. When loading a specific DLL by its full name, one cannot get a @@ -2066,15 +2066,15 @@ XS(XS_DynaLoader_mod2fname) { dXSARGS; if (items != 1) - Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)"); + Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)"); { - SV * sv = ST(0); - char * RETVAL; - dXSTARG; + SV * sv = ST(0); + char * RETVAL; + dXSTARG; - RETVAL = mod2fname(aTHX_ sv); - sv_setpv(TARG, RETVAL); - XSprePUSH; PUSHTARG; + RETVAL = mod2fname(aTHX_ sv); + sv_setpv(TARG, RETVAL); + XSprePUSH; PUSHTARG; } XSRETURN(1); } @@ -2082,75 +2082,75 @@ XS(XS_DynaLoader_mod2fname) char * os2error(int rc) { - dTHX; - ULONG len; - char *s; - int number = SvTRUE(get_sv("OS2::nsyserror", GV_ADD)); + dTHX; + ULONG len; + char *s; + int number = SvTRUE(get_sv("OS2::nsyserror", GV_ADD)); if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */ - if (rc == 0) - return ""; - if (number) { - sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc); - s = os2error_buf + strlen(os2error_buf); - } else - s = os2error_buf; - if (DosGetMessage(NULL, 0, s, sizeof(os2error_buf) - 1 - (s-os2error_buf), - rc, "OSO001.MSG", &len)) { - char *name = ""; - - if (!number) { - sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc); - s = os2error_buf + strlen(os2error_buf); - } - switch (rc) { - case PMERR_INVALID_HWND: - name = "PMERR_INVALID_HWND"; - break; - case PMERR_INVALID_HMQ: - name = "PMERR_INVALID_HMQ"; - break; - case PMERR_CALL_FROM_WRONG_THREAD: - name = "PMERR_CALL_FROM_WRONG_THREAD"; - break; - case PMERR_NO_MSG_QUEUE: - name = "PMERR_NO_MSG_QUEUE"; - break; - case PMERR_NOT_IN_A_PM_SESSION: - name = "PMERR_NOT_IN_A_PM_SESSION"; - break; - case PMERR_INVALID_ATOM: - name = "PMERR_INVALID_ATOM"; - break; - case PMERR_INVALID_HATOMTBL: - name = "PMERR_INVALID_HATOMTMB"; - break; - case PMERR_INVALID_INTEGER_ATOM: - name = "PMERR_INVALID_INTEGER_ATOM"; - break; - case PMERR_INVALID_ATOM_NAME: - name = "PMERR_INVALID_ATOM_NAME"; - break; - case PMERR_ATOM_NAME_NOT_FOUND: - name = "PMERR_ATOM_NAME_NOT_FOUND"; - break; - } - sprintf(s, "%s%s[No description found in OSO001.MSG]", - name, (*name ? "=" : "")); - } else { - s[len] = '\0'; - if (len && s[len - 1] == '\n') - s[--len] = 0; - if (len && s[len - 1] == '\r') - s[--len] = 0; - if (len && s[len - 1] == '.') - s[--len] = 0; - if (len >= 10 && number && strnEQ(s, os2error_buf, 7) - && s[7] == ':' && s[8] == ' ') - /* Some messages start with SYSdddd:, some not */ - Move(s + 9, s, (len -= 9) + 1, char); - } - return os2error_buf; + if (rc == 0) + return ""; + if (number) { + sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc); + s = os2error_buf + strlen(os2error_buf); + } else + s = os2error_buf; + if (DosGetMessage(NULL, 0, s, sizeof(os2error_buf) - 1 - (s-os2error_buf), + rc, "OSO001.MSG", &len)) { + char *name = ""; + + if (!number) { + sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc); + s = os2error_buf + strlen(os2error_buf); + } + switch (rc) { + case PMERR_INVALID_HWND: + name = "PMERR_INVALID_HWND"; + break; + case PMERR_INVALID_HMQ: + name = "PMERR_INVALID_HMQ"; + break; + case PMERR_CALL_FROM_WRONG_THREAD: + name = "PMERR_CALL_FROM_WRONG_THREAD"; + break; + case PMERR_NO_MSG_QUEUE: + name = "PMERR_NO_MSG_QUEUE"; + break; + case PMERR_NOT_IN_A_PM_SESSION: + name = "PMERR_NOT_IN_A_PM_SESSION"; + break; + case PMERR_INVALID_ATOM: + name = "PMERR_INVALID_ATOM"; + break; + case PMERR_INVALID_HATOMTBL: + name = "PMERR_INVALID_HATOMTMB"; + break; + case PMERR_INVALID_INTEGER_ATOM: + name = "PMERR_INVALID_INTEGER_ATOM"; + break; + case PMERR_INVALID_ATOM_NAME: + name = "PMERR_INVALID_ATOM_NAME"; + break; + case PMERR_ATOM_NAME_NOT_FOUND: + name = "PMERR_ATOM_NAME_NOT_FOUND"; + break; + } + sprintf(s, "%s%s[No description found in OSO001.MSG]", + name, (*name ? "=" : "")); + } else { + s[len] = '\0'; + if (len && s[len - 1] == '\n') + s[--len] = 0; + if (len && s[len - 1] == '\r') + s[--len] = 0; + if (len && s[len - 1] == '.') + s[--len] = 0; + if (len >= 10 && number && strnEQ(s, os2error_buf, 7) + && s[7] == ':' && s[8] == ' ') + /* Some messages start with SYSdddd:, some not */ + Move(s + 9, s, (len -= 9) + 1, char); + } + return os2error_buf; } void @@ -2196,12 +2196,12 @@ execname2buffer(char *buf, STRLEN l, char *oname) p = buf; while (*p) { if (*p == '\\') - *p = '/'; + *p = '/'; if (*p == '/') { - if (ok && *oname != '/' && *oname != '\\') - ok = 0; + if (ok && *oname != '/' && *oname != '\\') + ok = 0; } else if (ok && tolower(*oname) != tolower(*p)) - ok = 0; + ok = 0; p++; oname++; } @@ -2234,32 +2234,32 @@ Perl_OS2_handler_install(void *handler, enum Perlos2_handler how) switch (how) { case Perlos2_handler_mangle: - perllib_mangle_installed = (char *(*)(char *s, unsigned int l))handler; - return 1; + perllib_mangle_installed = (char *(*)(char *s, unsigned int l))handler; + return 1; case Perlos2_handler_perl_sh: - s = (char *)handler; - s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perl_sh"); - perl_sh_installed = savepv(s); - return 1; + s = (char *)handler; + s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perl_sh"); + perl_sh_installed = savepv(s); + return 1; case Perlos2_handler_perllib_from: - s = (char *)handler; - s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perllib_from"); - oldl = strlen(s); - oldp = savepv(s); - return 1; + s = (char *)handler; + s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perllib_from"); + oldl = strlen(s); + oldp = savepv(s); + return 1; case Perlos2_handler_perllib_to: - s = (char *)handler; - s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perllib_to"); - newl = strlen(s); - newp = savepv(s); - strcpy(mangle_ret, newp); - s = mangle_ret - 1; - while (*++s) - if (*s == '\\') - *s = '/'; - return 1; + s = (char *)handler; + s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perllib_to"); + newl = strlen(s); + newp = savepv(s); + strcpy(mangle_ret, newp); + s = mangle_ret - 1; + while (*++s) + if (*s == '\\') + *s = '/'; + return 1; default: - return 0; + return 0; } } @@ -2271,115 +2271,115 @@ dir_subst(char *s, unsigned int l, char *b, unsigned int bl, enum dir_subst_e fl STRLEN froml = 0, tol = 0, rest = 0; /* froml: likewise */ if (l >= 2 && s[0] == '~') { - switch (s[1]) { - case 'i': case 'I': - from = "installprefix"; break; - case 'd': case 'D': - from = "dll"; break; - case 'e': case 'E': - from = "exe"; break; - default: - from = NULL; - froml = l + 1; /* Will not match */ - break; - } - if (from) - froml = strlen(from) + 1; - if (l >= froml && strnicmp(s + 2, from + 1, froml - 2) == 0) { - int strip = 1; - - switch (s[1]) { - case 'i': case 'I': - strip = 0; - tol = strlen(INSTALL_PREFIX); - if (tol >= bl) { - if (flags & dir_subst_fatal) - Perl_croak_nocontext("INSTALL_PREFIX too long: `%s'", INSTALL_PREFIX); - else - return NULL; - } - memcpy(b, INSTALL_PREFIX, tol + 1); - to = b; - e = b + tol; - break; - case 'd': case 'D': - if (flags & dir_subst_fatal) { - dTHX; - - to = dllname2buffer(aTHX_ b, bl); - } else { /* No Perl present yet */ - HMODULE self = find_myself(); - APIRET rc = DosQueryModuleName(self, bl, b); - - if (rc) - return 0; - to = b - 1; - while (*++to) - if (*to == '\\') - *to = '/'; - to = b; - } - break; - case 'e': case 'E': - if (flags & dir_subst_fatal) { - dTHX; - - to = execname2buffer(b, bl, PL_origargv[0]); - } else - to = execname2buffer(b, bl, NULL); - break; - } - if (!to) - return NULL; - if (strip) { - e = strrchr(to, '/'); - if (!e && (flags & dir_subst_fatal)) - Perl_croak_nocontext("%s: Can't parse EXE/DLL name: '%s'", msg, to); - else if (!e) - return NULL; - *e = 0; - } - s += froml; l -= froml; - if (!l) - return to; - if (!tol) - tol = strlen(to); - - while (l >= 3 && (s[0] == '/' || s[0] == '\\') - && s[1] == '.' && s[2] == '.' - && (l == 3 || s[3] == '/' || s[3] == '\\' || s[3] == ';')) { - e = strrchr(b, '/'); - if (!e && (flags & dir_subst_fatal)) - Perl_croak_nocontext("%s: Error stripping dirs from EXE/DLL/INSTALLDIR name", msg); - else if (!e) - return NULL; - *e = 0; - l -= 3; s += 3; - } - if (l && s[0] != '/' && s[0] != '\\' && s[0] != ';') - *e++ = '/'; - } + switch (s[1]) { + case 'i': case 'I': + from = "installprefix"; break; + case 'd': case 'D': + from = "dll"; break; + case 'e': case 'E': + from = "exe"; break; + default: + from = NULL; + froml = l + 1; /* Will not match */ + break; + } + if (from) + froml = strlen(from) + 1; + if (l >= froml && strnicmp(s + 2, from + 1, froml - 2) == 0) { + int strip = 1; + + switch (s[1]) { + case 'i': case 'I': + strip = 0; + tol = strlen(INSTALL_PREFIX); + if (tol >= bl) { + if (flags & dir_subst_fatal) + Perl_croak_nocontext("INSTALL_PREFIX too long: `%s'", INSTALL_PREFIX); + else + return NULL; + } + memcpy(b, INSTALL_PREFIX, tol + 1); + to = b; + e = b + tol; + break; + case 'd': case 'D': + if (flags & dir_subst_fatal) { + dTHX; + + to = dllname2buffer(aTHX_ b, bl); + } else { /* No Perl present yet */ + HMODULE self = find_myself(); + APIRET rc = DosQueryModuleName(self, bl, b); + + if (rc) + return 0; + to = b - 1; + while (*++to) + if (*to == '\\') + *to = '/'; + to = b; + } + break; + case 'e': case 'E': + if (flags & dir_subst_fatal) { + dTHX; + + to = execname2buffer(b, bl, PL_origargv[0]); + } else + to = execname2buffer(b, bl, NULL); + break; + } + if (!to) + return NULL; + if (strip) { + e = strrchr(to, '/'); + if (!e && (flags & dir_subst_fatal)) + Perl_croak_nocontext("%s: Can't parse EXE/DLL name: '%s'", msg, to); + else if (!e) + return NULL; + *e = 0; + } + s += froml; l -= froml; + if (!l) + return to; + if (!tol) + tol = strlen(to); + + while (l >= 3 && (s[0] == '/' || s[0] == '\\') + && s[1] == '.' && s[2] == '.' + && (l == 3 || s[3] == '/' || s[3] == '\\' || s[3] == ';')) { + e = strrchr(b, '/'); + if (!e && (flags & dir_subst_fatal)) + Perl_croak_nocontext("%s: Error stripping dirs from EXE/DLL/INSTALLDIR name", msg); + else if (!e) + return NULL; + *e = 0; + l -= 3; s += 3; + } + if (l && s[0] != '/' && s[0] != '\\' && s[0] != ';') + *e++ = '/'; + } } /* Else: copy as is */ if (l && (flags & dir_subst_pathlike)) { - STRLEN i = 0; - - while ( i < l - 2 && s[i] != ';') /* May have ~char after `;' */ - i++; - if (i < l - 2) { /* Found */ - rest = l - i - 1; - l = i + 1; - } + STRLEN i = 0; + + while ( i < l - 2 && s[i] != ';') /* May have ~char after `;' */ + i++; + if (i < l - 2) { /* Found */ + rest = l - i - 1; + l = i + 1; + } } if (e + l >= b + bl) { - if (flags & dir_subst_fatal) - Perl_croak_nocontext("%s: name `%s%s' too long", msg, b, s); - else - return NULL; + if (flags & dir_subst_fatal) + Perl_croak_nocontext("%s: name `%s%s' too long", msg, b, s); + else + return NULL; } memcpy(e, s, l); if (rest) { - e = dir_subst(s + l, rest, e + l, bl - (e + l - b), flags, msg); - return e ? b : e; + e = dir_subst(s + l, rest, e + l, bl - (e + l - b), flags, msg); + return e ? b : e; } e[l] = 0; return b; @@ -2389,15 +2389,15 @@ char * perllib_mangle_with(char *s, unsigned int l, char *from, unsigned int froml, char *to, unsigned int tol) { if (!to) - return s; + return s; if (l == 0) - l = strlen(s); + l = strlen(s); if (l < froml || strnicmp(from, s, froml) != 0) - return s; + return s; if (l + tol - froml > STATIC_FILE_LENGTH || tol > STATIC_FILE_LENGTH) - Perl_croak_nocontext("Malformed PERLLIB_PREFIX"); + Perl_croak_nocontext("Malformed PERLLIB_PREFIX"); if (to && to != mangle_ret) - memcpy(mangle_ret, to, tol); + memcpy(mangle_ret, to, tol); strcpy(mangle_ret + tol, s + froml); return mangle_ret; } @@ -2408,44 +2408,44 @@ perllib_mangle(char *s, unsigned int l) char *name; if (perllib_mangle_installed && (name = perllib_mangle_installed(s,l))) - return name; + return name; if (!newp && !notfound) { - newp = PerlEnv_getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION) - STRINGIFY(PERL_VERSION) STRINGIFY(PERL_SUBVERSION) - "_PREFIX"); - if (!newp) - newp = PerlEnv_getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION) - STRINGIFY(PERL_VERSION) "_PREFIX"); - if (!newp) - newp = PerlEnv_getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION) "_PREFIX"); - if (!newp) - newp = PerlEnv_getenv(name = "PERLLIB_PREFIX"); - if (newp) { - char *s, b[300]; - - oldp = newp; - while (*newp && !isSPACE(*newp) && *newp != ';') - newp++; /* Skip old name. */ - oldl = newp - oldp; - s = dir_subst(oldp, oldl, b, sizeof b, dir_subst_fatal, name); - oldp = savepv(s); - oldl = strlen(s); - while (*newp && (isSPACE(*newp) || *newp == ';')) - newp++; /* Skip whitespace. */ - Perl_OS2_handler_install((void *)newp, Perlos2_handler_perllib_to); - if (newl == 0 || oldl == 0) - Perl_croak_nocontext("Malformed %s", name); - } else - notfound = 1; + newp = PerlEnv_getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION) + STRINGIFY(PERL_VERSION) STRINGIFY(PERL_SUBVERSION) + "_PREFIX"); + if (!newp) + newp = PerlEnv_getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION) + STRINGIFY(PERL_VERSION) "_PREFIX"); + if (!newp) + newp = PerlEnv_getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION) "_PREFIX"); + if (!newp) + newp = PerlEnv_getenv(name = "PERLLIB_PREFIX"); + if (newp) { + char *s, b[300]; + + oldp = newp; + while (*newp && !isSPACE(*newp) && *newp != ';') + newp++; /* Skip old name. */ + oldl = newp - oldp; + s = dir_subst(oldp, oldl, b, sizeof b, dir_subst_fatal, name); + oldp = savepv(s); + oldl = strlen(s); + while (*newp && (isSPACE(*newp) || *newp == ';')) + newp++; /* Skip whitespace. */ + Perl_OS2_handler_install((void *)newp, Perlos2_handler_perllib_to); + if (newl == 0 || oldl == 0) + Perl_croak_nocontext("Malformed %s", name); + } else + notfound = 1; } if (!newp) - return s; + return s; if (l == 0) - l = strlen(s); + l = strlen(s); if (l < oldl || strnicmp(oldp, s, oldl) != 0) - return s; + return s; if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) - Perl_croak_nocontext("Malformed PERLLIB_PREFIX"); + Perl_croak_nocontext("Malformed PERLLIB_PREFIX"); strcpy(mangle_ret + newl, s + oldl); return mangle_ret; } @@ -2465,15 +2465,15 @@ Create_HMQ(int serve, char *message) /* Assumes morphing */ /* 64 messages if before OS/2 3.0, ignored otherwise */ Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64); if (!Perl_hmq) { - dTHX; + dTHX; - SAVEINT(rmq_cnt); /* Allow catch()ing. */ - if (rmq_cnt++) - _exit(188); /* Panic can try to create a window. */ - CroakWinError(1, message ? message : "Cannot create a message queue"); + SAVEINT(rmq_cnt); /* Allow catch()ing. */ + if (rmq_cnt++) + _exit(188); /* Panic can try to create a window. */ + CroakWinError(1, message ? message : "Cannot create a message queue"); } if (serve != -1) - (*PMWIN_entries.CancelShutdown)(Perl_hmq, !serve); + (*PMWIN_entries.CancelShutdown)(Perl_hmq, !serve); /* We may have loaded some modules */ _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */ } @@ -2491,28 +2491,28 @@ Perl_Register_MQ(int serve) Perl_hmq_refcnt = 0; /* Be extra safe */ DosGetInfoBlocks(&tib, &pib); if (!Perl_morph_refcnt) { - Perl_os2_initial_mode = pib->pib_ultype; - /* Try morphing into a PM application. */ - if (pib->pib_ultype != 3) /* 2 is VIO */ - pib->pib_ultype = 3; /* 3 is PM */ + Perl_os2_initial_mode = pib->pib_ultype; + /* Try morphing into a PM application. */ + if (pib->pib_ultype != 3) /* 2 is VIO */ + pib->pib_ultype = 3; /* 3 is PM */ } Create_HMQ(-1, /* We do CancelShutdown ourselves */ - "Cannot create a message queue, or morph to a PM application"); + "Cannot create a message queue, or morph to a PM application"); if ((serve & REGISTERMQ_IMEDIATE_UNMORPH)) { - if (!Perl_morph_refcnt && Perl_os2_initial_mode != 3) - pib->pib_ultype = Perl_os2_initial_mode; + if (!Perl_morph_refcnt && Perl_os2_initial_mode != 3) + pib->pib_ultype = Perl_os2_initial_mode; } } if (serve & REGISTERMQ_WILL_SERVE) { - if ( Perl_hmq_servers <= 0 /* Safe to inform us on shutdown, */ - && Perl_hmq_refcnt > 0 ) /* this was switched off before... */ - (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0); - Perl_hmq_servers++; + if ( Perl_hmq_servers <= 0 /* Safe to inform us on shutdown, */ + && Perl_hmq_refcnt > 0 ) /* this was switched off before... */ + (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0); + Perl_hmq_servers++; } else if (!Perl_hmq_servers) /* Do not inform us on shutdown */ - (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); + (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); Perl_hmq_refcnt++; if (!(serve & REGISTERMQ_IMEDIATE_UNMORPH)) - Perl_morph_refcnt++; + Perl_morph_refcnt++; return Perl_hmq; } @@ -2523,14 +2523,14 @@ Perl_Serve_Messages(int force) QMSG msg; if (Perl_hmq_servers > 0 && !force) - return 0; + return 0; if (Perl_hmq_refcnt <= 0) - Perl_croak_nocontext("No message queue"); + Perl_croak_nocontext("No message queue"); while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) { - cnt++; - if (msg.msg == WM_QUIT) - Perl_croak_nocontext("QUITing..."); - (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg); + cnt++; + if (msg.msg == WM_QUIT) + Perl_croak_nocontext("QUITing..."); + (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg); } return cnt; } @@ -2541,17 +2541,17 @@ Perl_Process_Messages(int force, I32 *cntp) QMSG msg; if (Perl_hmq_servers > 0 && !force) - return 0; + return 0; if (Perl_hmq_refcnt <= 0) - Perl_croak_nocontext("No message queue"); + Perl_croak_nocontext("No message queue"); while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) { - if (cntp) - (*cntp)++; - (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg); - if (msg.msg == WM_DESTROY) - return -1; - if (msg.msg == WM_CREATE) - return +1; + if (cntp) + (*cntp)++; + (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg); + if (msg.msg == WM_DESTROY) + return -1; + if (msg.msg == WM_CREATE) + return +1; } Perl_croak_nocontext("QUITing..."); } @@ -2560,34 +2560,34 @@ void Perl_Deregister_MQ(int serve) { if (serve & REGISTERMQ_WILL_SERVE) - Perl_hmq_servers--; + Perl_hmq_servers--; if (--Perl_hmq_refcnt <= 0) { - unsigned fpflag = _control87(0,0); + unsigned fpflag = _control87(0,0); - init_PMWIN_entries(); /* To be extra safe */ - (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq); - Perl_hmq = 0; - /* We may have (un)loaded some modules */ - _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */ + init_PMWIN_entries(); /* To be extra safe */ + (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq); + Perl_hmq = 0; + /* We may have (un)loaded some modules */ + _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */ } else if ((serve & REGISTERMQ_WILL_SERVE) && Perl_hmq_servers <= 0) - (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); /* Last server exited */ + (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); /* Last server exited */ if (!(serve & REGISTERMQ_IMEDIATE_UNMORPH) && (--Perl_morph_refcnt <= 0)) { - /* Try morphing back from a PM application. */ - PPIB pib; - PTIB tib; - - DosGetInfoBlocks(&tib, &pib); - if (pib->pib_ultype == 3) /* 3 is PM */ - pib->pib_ultype = Perl_os2_initial_mode; - else - Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM", - pib->pib_ultype); + /* Try morphing back from a PM application. */ + PPIB pib; + PTIB tib; + + DosGetInfoBlocks(&tib, &pib); + if (pib->pib_ultype == 3) /* 3 is PM */ + pib->pib_ultype = Perl_os2_initial_mode; + else + Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM", + pib->pib_ultype); } } #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \ - && ((path)[2] == '/' || (path)[2] == '\\')) + && ((path)[2] == '/' || (path)[2] == '\\')) #define sys_is_rooted _fnisabs #define sys_is_relative _fnisrel #define current_drive _getdrive @@ -2600,21 +2600,21 @@ XS(XS_OS2_Error) { dXSARGS; if (items != 2) - Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)"); + Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)"); { - int arg1 = SvIV(ST(0)); - int arg2 = SvIV(ST(1)); - int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR) - | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION)); - int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0)); - unsigned long rc; - - if (CheckOSError(DosError(a))) - Perl_croak_nocontext("DosError(%d) failed: %s", a, os2error(Perl_rc)); - ST(0) = sv_newmortal(); - if (DOS_harderr_state >= 0) - sv_setiv(ST(0), DOS_harderr_state); - DOS_harderr_state = RETVAL; + int arg1 = SvIV(ST(0)); + int arg2 = SvIV(ST(1)); + int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR) + | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION)); + int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0)); + unsigned long rc; + + if (CheckOSError(DosError(a))) + Perl_croak_nocontext("DosError(%d) failed: %s", a, os2error(Perl_rc)); + ST(0) = sv_newmortal(); + if (DOS_harderr_state >= 0) + sv_setiv(ST(0), DOS_harderr_state); + DOS_harderr_state = RETVAL; } XSRETURN(1); } @@ -2623,29 +2623,29 @@ XS(XS_OS2_Errors2Drive) { dXSARGS; if (items != 1) - Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)"); + Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)"); { - STRLEN n_a; - SV *sv = ST(0); - int suppress = SvOK(sv); - char *s = suppress ? SvPV(sv, n_a) : NULL; - char drive = (s ? *s : 0); - unsigned long rc; - - if (suppress && !isALPHA(drive)) - Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive); - if (CheckOSError(DosSuppressPopUps((suppress - ? SPU_ENABLESUPPRESSION - : SPU_DISABLESUPPRESSION), - drive))) - Perl_croak_nocontext("DosSuppressPopUps(%c) failed: %s", drive, - os2error(Perl_rc)); - ST(0) = sv_newmortal(); - if (DOS_suppression_state > 0) - sv_setpvn(ST(0), &DOS_suppression_state, 1); - else if (DOS_suppression_state == 0) + STRLEN n_a; + SV *sv = ST(0); + int suppress = SvOK(sv); + char *s = suppress ? SvPV(sv, n_a) : NULL; + char drive = (s ? *s : 0); + unsigned long rc; + + if (suppress && !isALPHA(drive)) + Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive); + if (CheckOSError(DosSuppressPopUps((suppress + ? SPU_ENABLESUPPRESSION + : SPU_DISABLESUPPRESSION), + drive))) + Perl_croak_nocontext("DosSuppressPopUps(%c) failed: %s", drive, + os2error(Perl_rc)); + ST(0) = sv_newmortal(); + if (DOS_suppression_state > 0) + sv_setpvn(ST(0), &DOS_suppression_state, 1); + else if (DOS_suppression_state == 0) SvPVCLEAR(ST(0)); - DOS_suppression_state = drive; + DOS_suppression_state = drive; } XSRETURN(1); } @@ -2668,49 +2668,49 @@ async_mssleep(ULONG ms, int switch_priority) { return !_sleep2(ms); os2cp_croak(DosCreateEventSem(NULL, /* Unnamed */ - &hevEvent1, /* Handle of semaphore returned */ - DC_SEM_SHARED, /* Shared needed for DosAsyncTimer */ - FALSE), /* Semaphore is in RESET state */ - "DosCreateEventSem"); + &hevEvent1, /* Handle of semaphore returned */ + DC_SEM_SHARED, /* Shared needed for DosAsyncTimer */ + FALSE), /* Semaphore is in RESET state */ + "DosCreateEventSem"); if (ms >= switch_priority) switch_priority = 0; if (switch_priority) { if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) - switch_priority = 0; + switch_priority = 0; else { - /* In Warp3, to switch scheduling to 8ms step, one needs to do - DosAsyncTimer() in time-critical thread. On laters versions, - more and more cases of wait-for-something are covered. - - It turns out that on Warp3fp42 it is the priority at the time - of DosAsyncTimer() which matters. Let's hope that this works - with later versions too... XXXX - */ - priority = (tib->tib_ptib2->tib2_ulpri); - if ((priority & 0xFF00) == 0x0300) /* already time-critical */ - switch_priority = 0; - /* Make us time-critical. Just modifying TIB is not enough... */ - /* tib->tib_ptib2->tib2_ulpri = 0x0300;*/ - /* We do not want to run at high priority if a signal causes us - to longjmp() out of this section... */ - if (DosEnterMustComplete(&nesting)) - switch_priority = 0; - else - DosSetPriority(PRTYS_THREAD, PRTYC_TIMECRITICAL, 0, 0); + /* In Warp3, to switch scheduling to 8ms step, one needs to do + DosAsyncTimer() in time-critical thread. On laters versions, + more and more cases of wait-for-something are covered. + + It turns out that on Warp3fp42 it is the priority at the time + of DosAsyncTimer() which matters. Let's hope that this works + with later versions too... XXXX + */ + priority = (tib->tib_ptib2->tib2_ulpri); + if ((priority & 0xFF00) == 0x0300) /* already time-critical */ + switch_priority = 0; + /* Make us time-critical. Just modifying TIB is not enough... */ + /* tib->tib_ptib2->tib2_ulpri = 0x0300;*/ + /* We do not want to run at high priority if a signal causes us + to longjmp() out of this section... */ + if (DosEnterMustComplete(&nesting)) + switch_priority = 0; + else + DosSetPriority(PRTYS_THREAD, PRTYC_TIMECRITICAL, 0, 0); } } if ((badrc = DosAsyncTimer(ms, - (HSEM) hevEvent1, /* Semaphore to post */ - &htimerEvent1))) /* Timer handler (returned) */ + (HSEM) hevEvent1, /* Semaphore to post */ + &htimerEvent1))) /* Timer handler (returned) */ e = "DosAsyncTimer"; if (switch_priority && tib->tib_ptib2->tib2_ulpri == 0x0300) { - /* Nobody switched priority while we slept... Ignore errors... */ - /* tib->tib_ptib2->tib2_ulpri = priority; */ /* Get back... */ - if (!(rc = DosSetPriority(PRTYS_THREAD, (priority>>8) & 0xFF, 0, 0))) - rc = DosSetPriority(PRTYS_THREAD, 0, priority & 0xFF, 0); + /* Nobody switched priority while we slept... Ignore errors... */ + /* tib->tib_ptib2->tib2_ulpri = priority; */ /* Get back... */ + if (!(rc = DosSetPriority(PRTYS_THREAD, (priority>>8) & 0xFF, 0, 0))) + rc = DosSetPriority(PRTYS_THREAD, 0, priority & 0xFF, 0); } if (switch_priority) rc = DosExitMustComplete(&nesting); /* Ignore errors */ @@ -2742,7 +2742,7 @@ XS(XS_OS2_ms_sleep) /* for testing only... */ ULONG ms, lim; if (items > 2 || items < 1) - Perl_croak_nocontext("Usage: OS2::ms_sleep(wait_ms [, high_priority_limit])"); + Perl_croak_nocontext("Usage: OS2::ms_sleep(wait_ms [, high_priority_limit])"); ms = SvUV(ST(0)); lim = items > 1 ? SvUV(ST(1)) : ms + 1; async_mssleep(ms, lim); @@ -2760,22 +2760,22 @@ XS(XS_OS2_Timer) ULONG rc; if (items != 0) - Perl_croak_nocontext("Usage: OS2::Timer()"); + Perl_croak_nocontext("Usage: OS2::Timer()"); if (!freq) { - *(PFN*)&pDosTmrQueryFreq = loadByOrdinal(ORD_DosTmrQueryFreq, 0); - *(PFN*)&pDosTmrQueryTime = loadByOrdinal(ORD_DosTmrQueryTime, 0); - MUTEX_LOCK(&perlos2_state_mutex); - if (!freq) - if (CheckOSError(pDosTmrQueryFreq(&freq))) - croak_with_os2error("DosTmrQueryFreq"); - MUTEX_UNLOCK(&perlos2_state_mutex); + *(PFN*)&pDosTmrQueryFreq = loadByOrdinal(ORD_DosTmrQueryFreq, 0); + *(PFN*)&pDosTmrQueryTime = loadByOrdinal(ORD_DosTmrQueryTime, 0); + MUTEX_LOCK(&perlos2_state_mutex); + if (!freq) + if (CheckOSError(pDosTmrQueryFreq(&freq))) + croak_with_os2error("DosTmrQueryFreq"); + MUTEX_UNLOCK(&perlos2_state_mutex); } if (CheckOSError(pDosTmrQueryTime(&count))) - croak_with_os2error("DosTmrQueryTime"); + croak_with_os2error("DosTmrQueryTime"); { - dXSTARG; + dXSTARG; - XSprePUSH; PUSHn(((NV)count)/freq); + XSprePUSH; PUSHn(((NV)count)/freq); } XSRETURN(1); } @@ -2785,11 +2785,11 @@ XS(XS_OS2_msCounter) dXSARGS; if (items != 0) - Perl_croak_nocontext("Usage: OS2::msCounter()"); + Perl_croak_nocontext("Usage: OS2::msCounter()"); { - dXSTARG; + dXSTARG; - XSprePUSH; PUSHu(msCounter()); + XSprePUSH; PUSHu(msCounter()); } XSRETURN(1); } @@ -2800,13 +2800,13 @@ XS(XS_OS2__InfoTable) int is_local = 0; if (items > 1) - Perl_croak_nocontext("Usage: OS2::_infoTable([isLocal])"); + Perl_croak_nocontext("Usage: OS2::_infoTable([isLocal])"); if (items == 1) - is_local = (int)SvIV(ST(0)); + is_local = (int)SvIV(ST(0)); { - dXSTARG; + dXSTARG; - XSprePUSH; PUSHu(InfoTable(is_local)); + XSprePUSH; PUSHu(InfoTable(is_local)); } XSRETURN(1); } @@ -2871,76 +2871,76 @@ XS(XS_OS2_DevCap) { dXSARGS; if (items > 2) - Perl_croak_nocontext("Usage: OS2::DevCap()"); + Perl_croak_nocontext("Usage: OS2::DevCap()"); { - /* Device Capabilities Data Buffer (10 extra w.r.t. Warp 4.5) */ - LONG si[CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1]; - int i = 0, j = 0, how = DevCap_dc; - HDC hScreenDC; - DEVOPENSTRUC doStruc= {0L, (PSZ)"DISPLAY", NULL, 0L, 0L, 0L, 0L, 0L, 0L}; - ULONG rc1 = NO_ERROR; - HWND hwnd; - static volatile int devcap_loaded; - - if (!devcap_loaded) { - *(PFN*)&pWinOpenWindowDC = loadByOrdinal(ORD_WinOpenWindowDC, 0); - *(PFN*)&pDevOpenDC = loadByOrdinal(ORD_DevOpenDC, 0); - *(PFN*)&pDevCloseDC = loadByOrdinal(ORD_DevCloseDC, 0); - *(PFN*)&pDevQueryCaps = loadByOrdinal(ORD_DevQueryCaps, 0); - devcap_loaded = 1; - } - - if (items >= 2) - how = SvIV(ST(1)); - if (!items) { /* Get device contents from PM */ - hScreenDC = pDevOpenDC(perl_hab_GET(), OD_MEMORY, (PSZ)"*", 0, - (PDEVOPENDATA)&doStruc, NULLHANDLE); - if (CheckWinError(hScreenDC)) - croak_with_os2error("DevOpenDC() failed"); - } else if (how == DevCap_dc) - hScreenDC = (HDC)SvIV(ST(0)); - else { /* DevCap_hwnd */ - if (!Perl_hmq) - Perl_croak(aTHX_ "Getting a window's device context without a message queue would lock PM"); - hwnd = (HWND)SvIV(ST(0)); - hScreenDC = pWinOpenWindowDC(hwnd); /* No need to DevCloseDC() */ - if (CheckWinError(hScreenDC)) - croak_with_os2error("WinOpenWindowDC() failed"); - } - if (CheckWinError(pDevQueryCaps(hScreenDC, - CAPS_FAMILY, /* W3 documented caps */ - CAPS_DEVICE_POLYSET_POINTS - - CAPS_FAMILY + 1, - si))) - rc1 = Perl_rc; - else { - EXTEND(SP,2*(CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1)); - while (i < CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1) { - ST(j) = sv_newmortal(); - sv_setpv(ST(j++), dc_fields[i]); - ST(j) = sv_newmortal(); - sv_setiv(ST(j++), si[i]); - i++; - } - i = CAPS_DEVICE_POLYSET_POINTS + 1; - while (i < CAPS_DEVICE_POLYSET_POINTS + 11) { /* Just in case... */ - LONG l; - - if (CheckWinError(pDevQueryCaps(hScreenDC, i, 1, &l))) - break; - EXTEND(SP, j + 2); - ST(j) = sv_newmortal(); - sv_setiv(ST(j++), i); - ST(j) = sv_newmortal(); - sv_setiv(ST(j++), l); - i++; - } - } - if (!items && CheckWinError(pDevCloseDC(hScreenDC))) - Perl_warn_nocontext("DevCloseDC() failed: %s", os2error(Perl_rc)); - if (rc1) - Perl_rc = rc1, croak_with_os2error("DevQueryCaps() failed"); - XSRETURN(j); + /* Device Capabilities Data Buffer (10 extra w.r.t. Warp 4.5) */ + LONG si[CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1]; + int i = 0, j = 0, how = DevCap_dc; + HDC hScreenDC; + DEVOPENSTRUC doStruc= {0L, (PSZ)"DISPLAY", NULL, 0L, 0L, 0L, 0L, 0L, 0L}; + ULONG rc1 = NO_ERROR; + HWND hwnd; + static volatile int devcap_loaded; + + if (!devcap_loaded) { + *(PFN*)&pWinOpenWindowDC = loadByOrdinal(ORD_WinOpenWindowDC, 0); + *(PFN*)&pDevOpenDC = loadByOrdinal(ORD_DevOpenDC, 0); + *(PFN*)&pDevCloseDC = loadByOrdinal(ORD_DevCloseDC, 0); + *(PFN*)&pDevQueryCaps = loadByOrdinal(ORD_DevQueryCaps, 0); + devcap_loaded = 1; + } + + if (items >= 2) + how = SvIV(ST(1)); + if (!items) { /* Get device contents from PM */ + hScreenDC = pDevOpenDC(perl_hab_GET(), OD_MEMORY, (PSZ)"*", 0, + (PDEVOPENDATA)&doStruc, NULLHANDLE); + if (CheckWinError(hScreenDC)) + croak_with_os2error("DevOpenDC() failed"); + } else if (how == DevCap_dc) + hScreenDC = (HDC)SvIV(ST(0)); + else { /* DevCap_hwnd */ + if (!Perl_hmq) + Perl_croak(aTHX_ "Getting a window's device context without a message queue would lock PM"); + hwnd = (HWND)SvIV(ST(0)); + hScreenDC = pWinOpenWindowDC(hwnd); /* No need to DevCloseDC() */ + if (CheckWinError(hScreenDC)) + croak_with_os2error("WinOpenWindowDC() failed"); + } + if (CheckWinError(pDevQueryCaps(hScreenDC, + CAPS_FAMILY, /* W3 documented caps */ + CAPS_DEVICE_POLYSET_POINTS + - CAPS_FAMILY + 1, + si))) + rc1 = Perl_rc; + else { + EXTEND(SP,2*(CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1)); + while (i < CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1) { + ST(j) = sv_newmortal(); + sv_setpv(ST(j++), dc_fields[i]); + ST(j) = sv_newmortal(); + sv_setiv(ST(j++), si[i]); + i++; + } + i = CAPS_DEVICE_POLYSET_POINTS + 1; + while (i < CAPS_DEVICE_POLYSET_POINTS + 11) { /* Just in case... */ + LONG l; + + if (CheckWinError(pDevQueryCaps(hScreenDC, i, 1, &l))) + break; + EXTEND(SP, j + 2); + ST(j) = sv_newmortal(); + sv_setiv(ST(j++), i); + ST(j) = sv_newmortal(); + sv_setiv(ST(j++), l); + i++; + } + } + if (!items && CheckWinError(pDevCloseDC(hScreenDC))) + Perl_warn_nocontext("DevCloseDC() failed: %s", os2error(Perl_rc)); + if (rc1) + Perl_rc = rc1, croak_with_os2error("DevQueryCaps() failed"); + XSRETURN(j); } } @@ -3057,64 +3057,64 @@ const char * const sv_keys[] = { "106", "107", /* "CSYSVALUES",*/ - /* In recent DDK the limit is 108 */ + /* In recent DDK the limit is 108 */ }; XS(XS_OS2_SysValues) { dXSARGS; if (items > 2) - Perl_croak_nocontext("Usage: OS2::SysValues(which = -1, hwndDesktop = HWND_DESKTOP)"); + Perl_croak_nocontext("Usage: OS2::SysValues(which = -1, hwndDesktop = HWND_DESKTOP)"); { - int i = 0, j = 0, which = -1; - HWND hwnd = HWND_DESKTOP; - static volatile int sv_loaded; - LONG RETVAL; - - if (!sv_loaded) { - *(PFN*)&pWinQuerySysValue = loadByOrdinal(ORD_WinQuerySysValue, 0); - sv_loaded = 1; - } - - if (items == 2) - hwnd = (HWND)SvIV(ST(1)); - if (items >= 1) - which = (int)SvIV(ST(0)); - if (which == -1) { - EXTEND(SP,2*C_ARRAY_LENGTH(sv_keys)); - while (i < C_ARRAY_LENGTH(sv_keys)) { - ResetWinError(); - RETVAL = pWinQuerySysValue(hwnd, i); - if ( !RETVAL - && !(sv_keys[i][0] >= '0' && sv_keys[i][0] <= '9' - && i <= SV_PRINTSCREEN) ) { - FillWinError; - if (Perl_rc) { - if (i > SV_PRINTSCREEN) - break; /* May be not present on older systems */ - croak_with_os2error("SysValues():"); - } - - } - ST(j) = sv_newmortal(); - sv_setpv(ST(j++), sv_keys[i]); - ST(j) = sv_newmortal(); - sv_setiv(ST(j++), RETVAL); - i++; - } - XSRETURN(2 * i); - } else { - dXSTARG; - - ResetWinError(); - RETVAL = pWinQuerySysValue(hwnd, which); - if (!RETVAL) { - FillWinError; - if (Perl_rc) - croak_with_os2error("SysValues():"); - } - XSprePUSH; PUSHi((IV)RETVAL); - } + int i = 0, j = 0, which = -1; + HWND hwnd = HWND_DESKTOP; + static volatile int sv_loaded; + LONG RETVAL; + + if (!sv_loaded) { + *(PFN*)&pWinQuerySysValue = loadByOrdinal(ORD_WinQuerySysValue, 0); + sv_loaded = 1; + } + + if (items == 2) + hwnd = (HWND)SvIV(ST(1)); + if (items >= 1) + which = (int)SvIV(ST(0)); + if (which == -1) { + EXTEND(SP,2*C_ARRAY_LENGTH(sv_keys)); + while (i < C_ARRAY_LENGTH(sv_keys)) { + ResetWinError(); + RETVAL = pWinQuerySysValue(hwnd, i); + if ( !RETVAL + && !(sv_keys[i][0] >= '0' && sv_keys[i][0] <= '9' + && i <= SV_PRINTSCREEN) ) { + FillWinError; + if (Perl_rc) { + if (i > SV_PRINTSCREEN) + break; /* May be not present on older systems */ + croak_with_os2error("SysValues():"); + } + + } + ST(j) = sv_newmortal(); + sv_setpv(ST(j++), sv_keys[i]); + ST(j) = sv_newmortal(); + sv_setiv(ST(j++), RETVAL); + i++; + } + XSRETURN(2 * i); + } else { + dXSTARG; + + ResetWinError(); + RETVAL = pWinQuerySysValue(hwnd, which); + if (!RETVAL) { + FillWinError; + if (Perl_rc) + croak_with_os2error("SysValues():"); + } + XSprePUSH; PUSHi((IV)RETVAL); + } } } @@ -3122,22 +3122,22 @@ XS(XS_OS2_SysValues_set) { dXSARGS; if (items < 2 || items > 3) - Perl_croak_nocontext("Usage: OS2::SysValues_set(which, val, hwndDesktop = HWND_DESKTOP)"); + Perl_croak_nocontext("Usage: OS2::SysValues_set(which, val, hwndDesktop = HWND_DESKTOP)"); { - int which = (int)SvIV(ST(0)); - LONG val = (LONG)SvIV(ST(1)); - HWND hwnd = HWND_DESKTOP; - static volatile int svs_loaded; - - if (!svs_loaded) { - *(PFN*)&pWinSetSysValue = loadByOrdinal(ORD_WinSetSysValue, 0); - svs_loaded = 1; - } - - if (items == 3) - hwnd = (HWND)SvIV(ST(2)); - if (CheckWinError(pWinSetSysValue(hwnd, which, val))) - croak_with_os2error("SysValues_set()"); + int which = (int)SvIV(ST(0)); + LONG val = (LONG)SvIV(ST(1)); + HWND hwnd = HWND_DESKTOP; + static volatile int svs_loaded; + + if (!svs_loaded) { + *(PFN*)&pWinSetSysValue = loadByOrdinal(ORD_WinSetSysValue, 0); + svs_loaded = 1; + } + + if (items == 3) + hwnd = (HWND)SvIV(ST(2)); + if (CheckWinError(pWinSetSysValue(hwnd, which, val))) + croak_with_os2error("SysValues_set()"); } XSRETURN_YES; } @@ -3182,40 +3182,40 @@ XS(XS_OS2_SysInfo) { dXSARGS; if (items != 0) - Perl_croak_nocontext("Usage: OS2::SysInfo()"); + Perl_croak_nocontext("Usage: OS2::SysInfo()"); { - /* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */ - ULONG si[C_ARRAY_LENGTH(si_fields) + 10]; - APIRET rc = NO_ERROR; /* Return code */ - int i = 0, j = 0, last = QSV_MAX_WARP3; - - if (CheckOSError(DosQuerySysInfo(1L, /* Request documented system */ - last, /* info for Warp 3 */ - (PVOID)si, - sizeof(si)))) - croak_with_os2error("DosQuerySysInfo() failed"); - while (++last <= C_ARRAY_LENGTH(si)) { - if (CheckOSError(DosQuerySysInfo(last, last, /* One entry only */ - (PVOID)(si+last-1), - sizeof(*si)))) { - if (Perl_rc != ERROR_INVALID_PARAMETER) - croak_with_os2error("DosQuerySysInfo() failed"); - break; - } - } - last--; /* Count of successfully processed offsets */ - EXTEND(SP,2*last); - while (i < last) { - ST(j) = sv_newmortal(); - if (i < C_ARRAY_LENGTH(si_fields)) - sv_setpv(ST(j++), si_fields[i]); - else - sv_setiv(ST(j++), i + 1); - ST(j) = sv_newmortal(); - sv_setuv(ST(j++), si[i]); - i++; - } - XSRETURN(2 * last); + /* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */ + ULONG si[C_ARRAY_LENGTH(si_fields) + 10]; + APIRET rc = NO_ERROR; /* Return code */ + int i = 0, j = 0, last = QSV_MAX_WARP3; + + if (CheckOSError(DosQuerySysInfo(1L, /* Request documented system */ + last, /* info for Warp 3 */ + (PVOID)si, + sizeof(si)))) + croak_with_os2error("DosQuerySysInfo() failed"); + while (++last <= C_ARRAY_LENGTH(si)) { + if (CheckOSError(DosQuerySysInfo(last, last, /* One entry only */ + (PVOID)(si+last-1), + sizeof(*si)))) { + if (Perl_rc != ERROR_INVALID_PARAMETER) + croak_with_os2error("DosQuerySysInfo() failed"); + break; + } + } + last--; /* Count of successfully processed offsets */ + EXTEND(SP,2*last); + while (i < last) { + ST(j) = sv_newmortal(); + if (i < C_ARRAY_LENGTH(si_fields)) + sv_setpv(ST(j++), si_fields[i]); + else + sv_setiv(ST(j++), i + 1); + ST(j) = sv_newmortal(); + sv_setuv(ST(j++), si[i]); + i++; + } + XSRETURN(2 * last); } } @@ -3225,27 +3225,27 @@ XS(XS_OS2_SysInfoFor) int count = (items == 2 ? (int)SvIV(ST(1)) : 1); if (items < 1 || items > 2) - Perl_croak_nocontext("Usage: OS2::SysInfoFor(id[,count])"); + Perl_croak_nocontext("Usage: OS2::SysInfoFor(id[,count])"); { - /* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */ - ULONG si[C_ARRAY_LENGTH(si_fields) + 10]; - APIRET rc = NO_ERROR; /* Return code */ - int i = 0; - int start = (int)SvIV(ST(0)); - - if (count > C_ARRAY_LENGTH(si) || count <= 0) - Perl_croak(aTHX_ "unexpected count %d for OS2::SysInfoFor()", count); - if (CheckOSError(DosQuerySysInfo(start, - start + count - 1, - (PVOID)si, - sizeof(si)))) - croak_with_os2error("DosQuerySysInfo() failed"); - EXTEND(SP,count); - while (i < count) { - ST(i) = sv_newmortal(); - sv_setiv(ST(i), si[i]); - i++; - } + /* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */ + ULONG si[C_ARRAY_LENGTH(si_fields) + 10]; + APIRET rc = NO_ERROR; /* Return code */ + int i = 0; + int start = (int)SvIV(ST(0)); + + if (count > C_ARRAY_LENGTH(si) || count <= 0) + Perl_croak(aTHX_ "unexpected count %d for OS2::SysInfoFor()", count); + if (CheckOSError(DosQuerySysInfo(start, + start + count - 1, + (PVOID)si, + sizeof(si)))) + croak_with_os2error("DosQuerySysInfo() failed"); + EXTEND(SP,count); + while (i < count) { + ST(i) = sv_newmortal(); + sv_setiv(ST(i), si[i]); + i++; + } } XSRETURN(count); } @@ -3254,19 +3254,19 @@ XS(XS_OS2_BootDrive) { dXSARGS; if (items != 0) - Perl_croak_nocontext("Usage: OS2::BootDrive()"); + Perl_croak_nocontext("Usage: OS2::BootDrive()"); { - ULONG si[1] = {0}; /* System Information Data Buffer */ - APIRET rc = NO_ERROR; /* Return code */ - char c; - dXSTARG; - - if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE, - (PVOID)si, sizeof(si)))) - croak_with_os2error("DosQuerySysInfo() failed"); - c = 'a' - 1 + si[0]; - sv_setpvn(TARG, &c, 1); - XSprePUSH; PUSHTARG; + ULONG si[1] = {0}; /* System Information Data Buffer */ + APIRET rc = NO_ERROR; /* Return code */ + char c; + dXSTARG; + + if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE, + (PVOID)si, sizeof(si)))) + croak_with_os2error("DosQuerySysInfo() failed"); + c = 'a' - 1 + si[0]; + sv_setpvn(TARG, &c, 1); + XSprePUSH; PUSHTARG; } XSRETURN(1); } @@ -3275,14 +3275,14 @@ XS(XS_OS2_Beep) { dXSARGS; if (items > 2) /* Defaults as for WinAlarm(ERROR) */ - Perl_croak_nocontext("Usage: OS2::Beep(freq = 440, ms = 100)"); + Perl_croak_nocontext("Usage: OS2::Beep(freq = 440, ms = 100)"); { - ULONG freq = (items > 0 ? (ULONG)SvUV(ST(0)) : 440); - ULONG ms = (items > 1 ? (ULONG)SvUV(ST(1)) : 100); - ULONG rc; + ULONG freq = (items > 0 ? (ULONG)SvUV(ST(0)) : 440); + ULONG ms = (items > 1 ? (ULONG)SvUV(ST(1)) : 100); + ULONG rc; - if (CheckOSError(DosBeep(freq, ms))) - croak_with_os2error("SysValues_set()"); + if (CheckOSError(DosBeep(freq, ms))) + croak_with_os2error("SysValues_set()"); } XSRETURN_YES; } @@ -3293,13 +3293,13 @@ XS(XS_OS2_MorphPM) { dXSARGS; if (items != 1) - Perl_croak_nocontext("Usage: OS2::MorphPM(serve)"); + Perl_croak_nocontext("Usage: OS2::MorphPM(serve)"); { - bool serve = SvOK(ST(0)); - unsigned long pmq = perl_hmq_GET(serve); - dXSTARG; + bool serve = SvOK(ST(0)); + unsigned long pmq = perl_hmq_GET(serve); + dXSTARG; - XSprePUSH; PUSHi((IV)pmq); + XSprePUSH; PUSHi((IV)pmq); } XSRETURN(1); } @@ -3308,11 +3308,11 @@ XS(XS_OS2_UnMorphPM) { dXSARGS; if (items != 1) - Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)"); + Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)"); { - bool serve = SvOK(ST(0)); + bool serve = SvOK(ST(0)); - perl_hmq_UNSET(serve); + perl_hmq_UNSET(serve); } XSRETURN(0); } @@ -3321,13 +3321,13 @@ XS(XS_OS2_Serve_Messages) { dXSARGS; if (items != 1) - Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)"); + Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)"); { - bool force = SvOK(ST(0)); - unsigned long cnt = Perl_Serve_Messages(force); - dXSTARG; + bool force = SvOK(ST(0)); + unsigned long cnt = Perl_Serve_Messages(force); + dXSTARG; - XSprePUSH; PUSHi((IV)cnt); + XSprePUSH; PUSHi((IV)cnt); } XSRETURN(1); } @@ -3336,26 +3336,26 @@ XS(XS_OS2_Process_Messages) { dXSARGS; if (items < 1 || items > 2) - Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])"); + Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])"); { - bool force = SvOK(ST(0)); - unsigned long cnt; - dXSTARG; - - if (items == 2) { - I32 cntr; - SV *sv = ST(1); - - (void)SvIV(sv); /* Force SvIVX */ - if (!SvIOK(sv)) - Perl_croak_nocontext("Can't upgrade count to IV"); - cntr = SvIVX(sv); - cnt = Perl_Process_Messages(force, &cntr); - SvIVX(sv) = cntr; - } else { - cnt = Perl_Process_Messages(force, NULL); + bool force = SvOK(ST(0)); + unsigned long cnt; + dXSTARG; + + if (items == 2) { + I32 cntr; + SV *sv = ST(1); + + (void)SvIV(sv); /* Force SvIVX */ + if (!SvIOK(sv)) + Perl_croak_nocontext("Can't upgrade count to IV"); + cntr = SvIVX(sv); + cnt = Perl_Process_Messages(force, &cntr); + SvIVX(sv) = cntr; + } else { + cnt = Perl_Process_Messages(force, NULL); } - XSprePUSH; PUSHi((IV)cnt); + XSprePUSH; PUSHi((IV)cnt); } XSRETURN(1); } @@ -3364,14 +3364,14 @@ XS(XS_Cwd_current_drive) { dXSARGS; if (items != 0) - Perl_croak_nocontext("Usage: Cwd::current_drive()"); + Perl_croak_nocontext("Usage: Cwd::current_drive()"); { - char RETVAL; - dXSTARG; + char RETVAL; + dXSTARG; - RETVAL = current_drive(); - sv_setpvn(TARG, (char *)&RETVAL, 1); - XSprePUSH; PUSHTARG; + RETVAL = current_drive(); + sv_setpvn(TARG, (char *)&RETVAL, 1); + XSprePUSH; PUSHTARG; } XSRETURN(1); } @@ -3380,15 +3380,15 @@ XS(XS_Cwd_sys_chdir) { dXSARGS; if (items != 1) - Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)"); + Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)"); { - STRLEN n_a; - char * path = (char *)SvPV(ST(0),n_a); - bool RETVAL; + STRLEN n_a; + char * path = (char *)SvPV(ST(0),n_a); + bool RETVAL; - RETVAL = sys_chdir(path); - ST(0) = boolSV(RETVAL); - if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); + RETVAL = sys_chdir(path); + ST(0) = boolSV(RETVAL); + if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); } XSRETURN(1); } @@ -3397,15 +3397,15 @@ XS(XS_Cwd_change_drive) { dXSARGS; if (items != 1) - Perl_croak_nocontext("Usage: Cwd::change_drive(d)"); + Perl_croak_nocontext("Usage: Cwd::change_drive(d)"); { - STRLEN n_a; - char d = (char)*SvPV(ST(0),n_a); - bool RETVAL; + STRLEN n_a; + char d = (char)*SvPV(ST(0),n_a); + bool RETVAL; - RETVAL = change_drive(d); - ST(0) = boolSV(RETVAL); - if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); + RETVAL = change_drive(d); + ST(0) = boolSV(RETVAL); + if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); } XSRETURN(1); } @@ -3414,15 +3414,15 @@ XS(XS_Cwd_sys_is_absolute) { dXSARGS; if (items != 1) - Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)"); + Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)"); { - STRLEN n_a; - char * path = (char *)SvPV(ST(0),n_a); - bool RETVAL; + STRLEN n_a; + char * path = (char *)SvPV(ST(0),n_a); + bool RETVAL; - RETVAL = sys_is_absolute(path); - ST(0) = boolSV(RETVAL); - if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); + RETVAL = sys_is_absolute(path); + ST(0) = boolSV(RETVAL); + if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); } XSRETURN(1); } @@ -3431,15 +3431,15 @@ XS(XS_Cwd_sys_is_rooted) { dXSARGS; if (items != 1) - Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)"); + Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)"); { - STRLEN n_a; - char * path = (char *)SvPV(ST(0),n_a); - bool RETVAL; + STRLEN n_a; + char * path = (char *)SvPV(ST(0),n_a); + bool RETVAL; - RETVAL = sys_is_rooted(path); - ST(0) = boolSV(RETVAL); - if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); + RETVAL = sys_is_rooted(path); + ST(0) = boolSV(RETVAL); + if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); } XSRETURN(1); } @@ -3448,15 +3448,15 @@ XS(XS_Cwd_sys_is_relative) { dXSARGS; if (items != 1) - Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)"); + Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)"); { - STRLEN n_a; - char * path = (char *)SvPV(ST(0),n_a); - bool RETVAL; + STRLEN n_a; + char * path = (char *)SvPV(ST(0),n_a); + bool RETVAL; - RETVAL = sys_is_relative(path); - ST(0) = boolSV(RETVAL); - if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); + RETVAL = sys_is_relative(path); + ST(0) = boolSV(RETVAL); + if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); } XSRETURN(1); } @@ -3465,16 +3465,16 @@ XS(XS_Cwd_sys_cwd) { dXSARGS; if (items != 0) - Perl_croak_nocontext("Usage: Cwd::sys_cwd()"); + Perl_croak_nocontext("Usage: Cwd::sys_cwd()"); { - char p[MAXPATHLEN]; - char * RETVAL; - - /* Can't use TARG, since tainting behaves differently */ - RETVAL = _getcwd2(p, MAXPATHLEN); - ST(0) = sv_newmortal(); - sv_setpv(ST(0), RETVAL); - SvTAINTED_on(ST(0)); + char p[MAXPATHLEN]; + char * RETVAL; + + /* Can't use TARG, since tainting behaves differently */ + RETVAL = _getcwd2(p, MAXPATHLEN); + ST(0) = sv_newmortal(); + sv_setpv(ST(0), RETVAL); + SvTAINTED_on(ST(0)); } XSRETURN(1); } @@ -3483,131 +3483,131 @@ XS(XS_Cwd_sys_abspath) { dXSARGS; if (items > 2) - Perl_croak_nocontext("Usage: Cwd::sys_abspath(path = '.', dir = NULL)"); + Perl_croak_nocontext("Usage: Cwd::sys_abspath(path = '.', dir = NULL)"); { - STRLEN n_a; - char * path = items ? (char *)SvPV(ST(0),n_a) : "."; - char * dir, *s, *t, *e; - char p[MAXPATHLEN]; - char * RETVAL; - int l; - SV *sv; - - if (items < 2) - dir = NULL; - else { - dir = (char *)SvPV(ST(1),n_a); - } - if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) { - path += 2; - } - if (dir == NULL) { - if (_abspath(p, path, MAXPATHLEN) == 0) { - RETVAL = p; - } else { - RETVAL = NULL; - } - } else { - /* Absolute with drive: */ - if ( sys_is_absolute(path) ) { - if (_abspath(p, path, MAXPATHLEN) == 0) { - RETVAL = p; - } else { - RETVAL = NULL; - } - } else if (path[0] == '/' || path[0] == '\\') { - /* Rooted, but maybe on different drive. */ - if (isALPHA(dir[0]) && dir[1] == ':' ) { - char p1[MAXPATHLEN]; - - /* Need to prepend the drive. */ - p1[0] = dir[0]; - p1[1] = dir[1]; - Copy(path, p1 + 2, strlen(path) + 1, char); - RETVAL = p; - if (_abspath(p, p1, MAXPATHLEN) == 0) { - RETVAL = p; - } else { - RETVAL = NULL; - } - } else if (_abspath(p, path, MAXPATHLEN) == 0) { - RETVAL = p; - } else { - RETVAL = NULL; - } - } else { - /* Either path is relative, or starts with a drive letter. */ - /* If the path starts with a drive letter, then dir is - relevant only if - a/b) it is absolute/x:relative on the same drive. - c) path is on current drive, and dir is rooted - In all the cases it is safe to drop the drive part - of the path. */ - if ( !sys_is_relative(path) ) { - if ( ( ( sys_is_absolute(dir) - || (isALPHA(dir[0]) && dir[1] == ':' - && strnicmp(dir, path,1) == 0)) - && strnicmp(dir, path,1) == 0) - || ( !(isALPHA(dir[0]) && dir[1] == ':') - && toupper(path[0]) == current_drive())) { - path += 2; - } else if (_abspath(p, path, MAXPATHLEN) == 0) { - RETVAL = p; goto done; - } else { - RETVAL = NULL; goto done; - } - } - { - /* Need to prepend the absolute path of dir. */ - char p1[MAXPATHLEN]; - - if (_abspath(p1, dir, MAXPATHLEN) == 0) { - int l = strlen(p1); - - if (p1[ l - 1 ] != '/') { - p1[ l ] = '/'; - l++; - } - Copy(path, p1 + l, strlen(path) + 1, char); - if (_abspath(p, p1, MAXPATHLEN) == 0) { - RETVAL = p; - } else { - RETVAL = NULL; - } - } else { - RETVAL = NULL; - } - } - done: - } - } - if (!RETVAL) - XSRETURN_EMPTY; - /* Backslashes are already converted to slashes. */ - /* Remove trailing slashes */ - l = strlen(RETVAL); - while (l > 0 && RETVAL[l-1] == '/') - l--; - ST(0) = sv_newmortal(); - sv_setpvn( sv = (SV*)ST(0), RETVAL, l); - /* Remove duplicate slashes, skipping the first three, which - may be parts of a server-based path */ - s = t = 3 + SvPV_force(sv, n_a); - e = SvEND(sv); - /* Do not worry about multibyte chars here, this would contradict the - eventual UTFization, and currently most other places break too... */ - while (s < e) { - if (s[0] == t[-1] && s[0] == '/') - s++; /* Skip duplicate / */ - else - *t++ = *s++; - } - if (t < e) { - *t = 0; - SvCUR_set(sv, t - SvPVX(sv)); - } - if (!items) - SvTAINTED_on(ST(0)); + STRLEN n_a; + char * path = items ? (char *)SvPV(ST(0),n_a) : "."; + char * dir, *s, *t, *e; + char p[MAXPATHLEN]; + char * RETVAL; + int l; + SV *sv; + + if (items < 2) + dir = NULL; + else { + dir = (char *)SvPV(ST(1),n_a); + } + if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) { + path += 2; + } + if (dir == NULL) { + if (_abspath(p, path, MAXPATHLEN) == 0) { + RETVAL = p; + } else { + RETVAL = NULL; + } + } else { + /* Absolute with drive: */ + if ( sys_is_absolute(path) ) { + if (_abspath(p, path, MAXPATHLEN) == 0) { + RETVAL = p; + } else { + RETVAL = NULL; + } + } else if (path[0] == '/' || path[0] == '\\') { + /* Rooted, but maybe on different drive. */ + if (isALPHA(dir[0]) && dir[1] == ':' ) { + char p1[MAXPATHLEN]; + + /* Need to prepend the drive. */ + p1[0] = dir[0]; + p1[1] = dir[1]; + Copy(path, p1 + 2, strlen(path) + 1, char); + RETVAL = p; + if (_abspath(p, p1, MAXPATHLEN) == 0) { + RETVAL = p; + } else { + RETVAL = NULL; + } + } else if (_abspath(p, path, MAXPATHLEN) == 0) { + RETVAL = p; + } else { + RETVAL = NULL; + } + } else { + /* Either path is relative, or starts with a drive letter. */ + /* If the path starts with a drive letter, then dir is + relevant only if + a/b) it is absolute/x:relative on the same drive. + c) path is on current drive, and dir is rooted + In all the cases it is safe to drop the drive part + of the path. */ + if ( !sys_is_relative(path) ) { + if ( ( ( sys_is_absolute(dir) + || (isALPHA(dir[0]) && dir[1] == ':' + && strnicmp(dir, path,1) == 0)) + && strnicmp(dir, path,1) == 0) + || ( !(isALPHA(dir[0]) && dir[1] == ':') + && toupper(path[0]) == current_drive())) { + path += 2; + } else if (_abspath(p, path, MAXPATHLEN) == 0) { + RETVAL = p; goto done; + } else { + RETVAL = NULL; goto done; + } + } + { + /* Need to prepend the absolute path of dir. */ + char p1[MAXPATHLEN]; + + if (_abspath(p1, dir, MAXPATHLEN) == 0) { + int l = strlen(p1); + + if (p1[ l - 1 ] != '/') { + p1[ l ] = '/'; + l++; + } + Copy(path, p1 + l, strlen(path) + 1, char); + if (_abspath(p, p1, MAXPATHLEN) == 0) { + RETVAL = p; + } else { + RETVAL = NULL; + } + } else { + RETVAL = NULL; + } + } + done: + } + } + if (!RETVAL) + XSRETURN_EMPTY; + /* Backslashes are already converted to slashes. */ + /* Remove trailing slashes */ + l = strlen(RETVAL); + while (l > 0 && RETVAL[l-1] == '/') + l--; + ST(0) = sv_newmortal(); + sv_setpvn( sv = (SV*)ST(0), RETVAL, l); + /* Remove duplicate slashes, skipping the first three, which + may be parts of a server-based path */ + s = t = 3 + SvPV_force(sv, n_a); + e = SvEND(sv); + /* Do not worry about multibyte chars here, this would contradict the + eventual UTFization, and currently most other places break too... */ + while (s < e) { + if (s[0] == t[-1] && s[0] == '/') + s++; /* Skip duplicate / */ + else + *t++ = *s++; + } + if (t < e) { + *t = 0; + SvCUR_set(sv, t - SvPVX(sv)); + } + if (!items) + SvTAINTED_on(ST(0)); } XSRETURN(1); } @@ -3625,13 +3625,13 @@ ExtLIBPATH(ULONG ord, PSZ path, IV type, int fatal) PFN f = loadByOrdinal(ord, fatal); /* if fatal: load or die! */ if (!f) /* Impossible with fatal */ - return Perl_rc; + return Perl_rc; if (type > 0) - what = END_LIBPATH; + what = END_LIBPATH; else if (type == 0) - what = BEGIN_LIBPATH; + what = BEGIN_LIBPATH; else - what = LIBPATHSTRICT; + what = LIBPATHSTRICT; return (*(PELP)f)(path, what); } @@ -3656,31 +3656,31 @@ XS(XS_Cwd_extLibpath) { dXSARGS; if (items < 0 || items > 1) - Perl_croak_nocontext("Usage: OS2::extLibpath(type = 0)"); + Perl_croak_nocontext("Usage: OS2::extLibpath(type = 0)"); { - IV type; - char to[1024]; - U32 rc; - char * RETVAL; - dXSTARG; - STRLEN l; - - if (items < 1) - type = 0; - else { - type = SvIV(ST(0)); - } - - to[0] = 1; to[1] = 0; /* Sometimes no error reported */ - RETVAL = extLibpath(to, type, 1); /* Make errors fatal */ - if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0) - Perl_croak_nocontext("panic OS2::extLibpath parameter"); - l = strlen(to); - if (l >= sizeof(to)) - early_error("Buffer overflow while getting BEGIN/ENDLIBPATH: `", - to, "'\r\n"); /* Will not return */ - sv_setpv(TARG, RETVAL); - XSprePUSH; PUSHTARG; + IV type; + char to[1024]; + U32 rc; + char * RETVAL; + dXSTARG; + STRLEN l; + + if (items < 1) + type = 0; + else { + type = SvIV(ST(0)); + } + + to[0] = 1; to[1] = 0; /* Sometimes no error reported */ + RETVAL = extLibpath(to, type, 1); /* Make errors fatal */ + if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0) + Perl_croak_nocontext("panic OS2::extLibpath parameter"); + l = strlen(to); + if (l >= sizeof(to)) + early_error("Buffer overflow while getting BEGIN/ENDLIBPATH: `", + to, "'\r\n"); /* Will not return */ + sv_setpv(TARG, RETVAL); + XSprePUSH; PUSHTARG; } XSRETURN(1); } @@ -3689,23 +3689,23 @@ XS(XS_Cwd_extLibpath_set) { dXSARGS; if (items < 1 || items > 2) - Perl_croak_nocontext("Usage: OS2::extLibpath_set(s, type = 0)"); + Perl_croak_nocontext("Usage: OS2::extLibpath_set(s, type = 0)"); { - STRLEN n_a; - char * s = (char *)SvPV(ST(0),n_a); - IV type; - U32 rc; - bool RETVAL; - - if (items < 2) - type = 0; - else { - type = SvIV(ST(1)); - } - - RETVAL = extLibpath_set(s, type, 1); /* Make errors fatal */ - ST(0) = boolSV(RETVAL); - if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); + STRLEN n_a; + char * s = (char *)SvPV(ST(0),n_a); + IV type; + U32 rc; + bool RETVAL; + + if (items < 2) + type = 0; + else { + type = SvIV(ST(1)); + } + + RETVAL = extLibpath_set(s, type, 1); /* Make errors fatal */ + ST(0) = boolSV(RETVAL); + if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); } XSRETURN(1); } @@ -3718,53 +3718,53 @@ fill_extLibpath(int type, char *pre, char *post, int replace, char *msg) ULONG rc; if (!pre && !post) - return 0; + return 0; if (pre) { - pre = dir_subst(pre, strlen(pre), buf1, sizeof buf1, dir_subst_pathlike, msg); - if (!pre) - return ERROR_INVALID_PARAMETER; - l = strlen(pre); - if (l >= sizeof(buf)/2) - return ERROR_BUFFER_OVERFLOW; - s = pre - 1; - while (*++s) - if (*s == '/') - *s = '\\'; /* Be extra cautious */ - memcpy(to, pre, l); - if (!l || to[l-1] != ';') - to[l++] = ';'; - to += l; + pre = dir_subst(pre, strlen(pre), buf1, sizeof buf1, dir_subst_pathlike, msg); + if (!pre) + return ERROR_INVALID_PARAMETER; + l = strlen(pre); + if (l >= sizeof(buf)/2) + return ERROR_BUFFER_OVERFLOW; + s = pre - 1; + while (*++s) + if (*s == '/') + *s = '\\'; /* Be extra cautious */ + memcpy(to, pre, l); + if (!l || to[l-1] != ';') + to[l++] = ';'; + to += l; } if (!replace) { to[0] = 1; to[1] = 0; /* Sometimes no error reported */ rc = ExtLIBPATH(ORD_DosQueryExtLibpath, to, type, 0); /* Do not croak */ if (rc) - return rc; + return rc; if (to[0] == 1 && to[1] == 0) - return ERROR_INVALID_PARAMETER; + return ERROR_INVALID_PARAMETER; to += strlen(to); if (buf + sizeof(buf) - 1 <= to) /* Buffer overflow */ - early_error("Buffer overflow while getting BEGIN/ENDLIBPATH: `", - buf, "'\r\n"); /* Will not return */ + early_error("Buffer overflow while getting BEGIN/ENDLIBPATH: `", + buf, "'\r\n"); /* Will not return */ if (to > buf && to[-1] != ';') - *to++ = ';'; + *to++ = ';'; } if (post) { - post = dir_subst(post, strlen(post), buf1, sizeof buf1, dir_subst_pathlike, msg); - if (!post) - return ERROR_INVALID_PARAMETER; - l = strlen(post); - if (l + to - buf >= sizeof(buf) - 1) - return ERROR_BUFFER_OVERFLOW; - s = post - 1; - while (*++s) - if (*s == '/') - *s = '\\'; /* Be extra cautious */ - memcpy(to, post, l); - if (!l || to[l-1] != ';') - to[l++] = ';'; - to += l; + post = dir_subst(post, strlen(post), buf1, sizeof buf1, dir_subst_pathlike, msg); + if (!post) + return ERROR_INVALID_PARAMETER; + l = strlen(post); + if (l + to - buf >= sizeof(buf) - 1) + return ERROR_BUFFER_OVERFLOW; + s = post - 1; + while (*++s) + if (*s == '/') + *s = '\\'; /* Be extra cautious */ + memcpy(to, post, l); + if (!l || to[l-1] != ';') + to[l++] = ';'; + to += l; } *to = 0; rc = ExtLIBPATH(ORD_DosSetExtLibpath, buf, type, 0); /* Do not croak */ @@ -3774,13 +3774,13 @@ fill_extLibpath(int type, char *pre, char *post, int replace, char *msg) /* Input: Address, BufLen APIRET APIENTRY DosQueryModFromEIP (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf, - ULONG * Offset, ULONG Address); + ULONG * Offset, ULONG Address); */ DeclOSFuncByORD(APIRET, _DosQueryModFromEIP,ORD_DosQueryModFromEIP, - (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf, - ULONG * Offset, ULONG Address), - (hmod, obj, BufLen, Buf, Offset, Address)) + (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf, + ULONG * Offset, ULONG Address), + (hmod, obj, BufLen, Buf, Offset, Address)) static SV* module_name_at(void *pp, enum module_name_how how) @@ -3792,22 +3792,22 @@ module_name_at(void *pp, enum module_name_how how) ULONG obj, offset, rc, addr = (ULONG)pp; if (how & mod_name_HMODULE) { - if ((how & ~mod_name_HMODULE) == mod_name_shortname) - Perl_croak(aTHX_ "Can't get short module name from a handle"); - mod = (HMODULE)pp; - how &= ~mod_name_HMODULE; + if ((how & ~mod_name_HMODULE) == mod_name_shortname) + Perl_croak(aTHX_ "Can't get short module name from a handle"); + mod = (HMODULE)pp; + how &= ~mod_name_HMODULE; } else if (!_DosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, addr)) - return &PL_sv_undef; + return &PL_sv_undef; if (how == mod_name_handle) - return newSVuv(mod); + return newSVuv(mod); /* Full name... */ if ( how != mod_name_shortname - && CheckOSError(DosQueryModuleName(mod, sizeof(buf), buf)) ) - return &PL_sv_undef; + && CheckOSError(DosQueryModuleName(mod, sizeof(buf), buf)) ) + return &PL_sv_undef; while (*p) { - if (*p == '\\') - *p = '/'; - p++; + if (*p == '\\') + *p = '/'; + p++; } return newSVpv(buf, 0); } @@ -3816,13 +3816,13 @@ static SV* module_name_of_cv(SV *cv, enum module_name_how how) { if (!cv || !SvROK(cv) || SvTYPE(SvRV(cv)) != SVt_PVCV || !CvXSUB(SvRV(cv))) { - dTHX; + dTHX; - if (how & mod_name_C_function) - return module_name_at((void*)SvIV(cv), how & ~mod_name_C_function); - else if (how & mod_name_HMODULE) - return module_name_at((void*)SvIV(cv), how); - Perl_croak(aTHX_ "Not an XSUB reference"); + if (how & mod_name_C_function) + return module_name_at((void*)SvIV(cv), how & ~mod_name_C_function); + else if (how & mod_name_HMODULE) + return module_name_at((void*)SvIV(cv), how); + Perl_croak(aTHX_ "Not an XSUB reference"); } return module_name_at(CvXSUB(SvRV(cv)), how); } @@ -3831,52 +3831,52 @@ XS(XS_OS2_DLLname) { dXSARGS; if (items > 2) - Perl_croak(aTHX_ "Usage: OS2::DLLname( [ how, [\\&xsub] ] )"); + Perl_croak(aTHX_ "Usage: OS2::DLLname( [ how, [\\&xsub] ] )"); { - SV * RETVAL; - int how; - - if (items < 1) - how = mod_name_full; - else { - how = (int)SvIV(ST(0)); - } - if (items < 2) - RETVAL = module_name(how); - else - RETVAL = module_name_of_cv(ST(1), how); - ST(0) = RETVAL; - sv_2mortal(ST(0)); + SV * RETVAL; + int how; + + if (items < 1) + how = mod_name_full; + else { + how = (int)SvIV(ST(0)); + } + if (items < 2) + RETVAL = module_name(how); + else + RETVAL = module_name_of_cv(ST(1), how); + ST(0) = RETVAL; + sv_2mortal(ST(0)); } XSRETURN(1); } DeclOSFuncByORD(INT, _Dos32QueryHeaderInfo, ORD_Dos32QueryHeaderInfo, - (ULONG r1, ULONG r2, PVOID buf, ULONG szbuf, ULONG fnum), - (r1, r2, buf, szbuf, fnum)) + (ULONG r1, ULONG r2, PVOID buf, ULONG szbuf, ULONG fnum), + (r1, r2, buf, szbuf, fnum)) XS(XS_OS2__headerInfo) { dXSARGS; if (items > 4 || items < 2) - Perl_croak(aTHX_ "Usage: OS2::_headerInfo(req,size[,handle,[offset]])"); + Perl_croak(aTHX_ "Usage: OS2::_headerInfo(req,size[,handle,[offset]])"); { - ULONG req = (ULONG)SvIV(ST(0)); - STRLEN size = (STRLEN)SvIV(ST(1)), n_a; - ULONG handle = (items >= 3 ? (ULONG)SvIV(ST(2)) : 0); - ULONG offset = (items >= 4 ? (ULONG)SvIV(ST(3)) : 0); - - if (size <= 0) - Perl_croak(aTHX_ "OS2::_headerInfo(): unexpected size: %d", (int)size); - ST(0) = newSVpvs(""); - SvGROW(ST(0), size + 1); - sv_2mortal(ST(0)); - - if (!_Dos32QueryHeaderInfo(handle, offset, SvPV(ST(0), n_a), size, req)) - Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s", - req, size, handle, offset, os2error(Perl_rc)); - SvCUR_set(ST(0), size); - *SvEND(ST(0)) = 0; + ULONG req = (ULONG)SvIV(ST(0)); + STRLEN size = (STRLEN)SvIV(ST(1)), n_a; + ULONG handle = (items >= 3 ? (ULONG)SvIV(ST(2)) : 0); + ULONG offset = (items >= 4 ? (ULONG)SvIV(ST(3)) : 0); + + if (size <= 0) + Perl_croak(aTHX_ "OS2::_headerInfo(): unexpected size: %d", (int)size); + ST(0) = newSVpvs(""); + SvGROW(ST(0), size + 1); + sv_2mortal(ST(0)); + + if (!_Dos32QueryHeaderInfo(handle, offset, SvPV(ST(0), n_a), size, req)) + Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s", + req, size, handle, offset, os2error(Perl_rc)); + SvCUR_set(ST(0), size); + *SvEND(ST(0)) = 0; } XSRETURN(1); } @@ -3888,29 +3888,29 @@ XS(XS_OS2_libPath) { dXSARGS; if (items != 0) - Perl_croak(aTHX_ "Usage: OS2::libPath()"); + Perl_croak(aTHX_ "Usage: OS2::libPath()"); { - ULONG size; - STRLEN n_a; - - if (!_Dos32QueryHeaderInfo(0, 0, &size, sizeof(size), - DQHI_QUERYLIBPATHSIZE)) - Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s", - DQHI_QUERYLIBPATHSIZE, sizeof(size), 0, 0, - os2error(Perl_rc)); - ST(0) = newSVpvs(""); - SvGROW(ST(0), size + 1); - sv_2mortal(ST(0)); - - /* We should be careful: apparently, this entry point does not - pay attention to the size argument, so may overwrite - unrelated data! */ - if (!_Dos32QueryHeaderInfo(0, 0, SvPV(ST(0), n_a), size, - DQHI_QUERYLIBPATH)) - Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s", - DQHI_QUERYLIBPATH, size, 0, 0, os2error(Perl_rc)); - SvCUR_set(ST(0), size); - *SvEND(ST(0)) = 0; + ULONG size; + STRLEN n_a; + + if (!_Dos32QueryHeaderInfo(0, 0, &size, sizeof(size), + DQHI_QUERYLIBPATHSIZE)) + Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s", + DQHI_QUERYLIBPATHSIZE, sizeof(size), 0, 0, + os2error(Perl_rc)); + ST(0) = newSVpvs(""); + SvGROW(ST(0), size + 1); + sv_2mortal(ST(0)); + + /* We should be careful: apparently, this entry point does not + pay attention to the size argument, so may overwrite + unrelated data! */ + if (!_Dos32QueryHeaderInfo(0, 0, SvPV(ST(0), n_a), size, + DQHI_QUERYLIBPATH)) + Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s", + DQHI_QUERYLIBPATH, size, 0, 0, os2error(Perl_rc)); + SvCUR_set(ST(0), size); + *SvEND(ST(0)) = 0; } XSRETURN(1); } @@ -3922,15 +3922,15 @@ XS(XS_OS2__control87) { dXSARGS; if (items != 2) - Perl_croak(aTHX_ "Usage: OS2::_control87(new,mask)"); + Perl_croak(aTHX_ "Usage: OS2::_control87(new,mask)"); { - unsigned new = (unsigned)SvIV(ST(0)); - unsigned mask = (unsigned)SvIV(ST(1)); - unsigned RETVAL; - dXSTARG; + unsigned new = (unsigned)SvIV(ST(0)); + unsigned mask = (unsigned)SvIV(ST(1)); + unsigned RETVAL; + dXSTARG; - RETVAL = _control87(new, mask); - XSprePUSH; PUSHi((IV)RETVAL); + RETVAL = _control87(new, mask); + XSprePUSH; PUSHi((IV)RETVAL); } XSRETURN(1); } @@ -3941,30 +3941,30 @@ XS(XS_OS2_mytype) int which = 0; if (items < 0 || items > 1) - Perl_croak(aTHX_ "Usage: OS2::mytype([which])"); + Perl_croak(aTHX_ "Usage: OS2::mytype([which])"); if (items == 1) - which = (int)SvIV(ST(0)); + which = (int)SvIV(ST(0)); { - unsigned RETVAL; - dXSTARG; - - switch (which) { - case 0: - RETVAL = os2_mytype; /* Reset after fork */ - break; - case 1: - RETVAL = os2_mytype_ini; /* Before any fork */ - break; - case 2: - RETVAL = Perl_os2_initial_mode; /* Before first morphing */ - break; - case 3: - RETVAL = my_type(); /* Morphed type */ - break; - default: - Perl_croak(aTHX_ "OS2::mytype(which): unknown which=%d", which); - } - XSprePUSH; PUSHi((IV)RETVAL); + unsigned RETVAL; + dXSTARG; + + switch (which) { + case 0: + RETVAL = os2_mytype; /* Reset after fork */ + break; + case 1: + RETVAL = os2_mytype_ini; /* Before any fork */ + break; + case 2: + RETVAL = Perl_os2_initial_mode; /* Before first morphing */ + break; + case 3: + RETVAL = my_type(); /* Morphed type */ + break; + default: + Perl_croak(aTHX_ "OS2::mytype(which): unknown which=%d", which); + } + XSprePUSH; PUSHi((IV)RETVAL); } XSRETURN(1); } @@ -3976,9 +3976,9 @@ XS(XS_OS2_mytype_set) int type; if (items == 1) - type = (int)SvIV(ST(0)); + type = (int)SvIV(ST(0)); else - Perl_croak(aTHX_ "Usage: OS2::mytype_set(type)"); + Perl_croak(aTHX_ "Usage: OS2::mytype_set(type)"); my_type_set(type); XSRETURN_YES; } @@ -3988,13 +3988,13 @@ XS(XS_OS2_get_control87) { dXSARGS; if (items != 0) - Perl_croak(aTHX_ "Usage: OS2::get_control87()"); + Perl_croak(aTHX_ "Usage: OS2::get_control87()"); { - unsigned RETVAL; - dXSTARG; + unsigned RETVAL; + dXSTARG; - RETVAL = get_control87(); - XSprePUSH; PUSHi((IV)RETVAL); + RETVAL = get_control87(); + XSprePUSH; PUSHi((IV)RETVAL); } XSRETURN(1); } @@ -4004,27 +4004,27 @@ XS(XS_OS2_set_control87) { dXSARGS; if (items < 0 || items > 2) - Perl_croak(aTHX_ "Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)"); + Perl_croak(aTHX_ "Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)"); { - unsigned new; - unsigned mask; - unsigned RETVAL; - dXSTARG; - - if (items < 1) - new = MCW_EM; - else { - new = (unsigned)SvIV(ST(0)); - } - - if (items < 2) - mask = MCW_EM; - else { - mask = (unsigned)SvIV(ST(1)); - } - - RETVAL = set_control87(new, mask); - XSprePUSH; PUSHi((IV)RETVAL); + unsigned new; + unsigned mask; + unsigned RETVAL; + dXSTARG; + + if (items < 1) + new = MCW_EM; + else { + new = (unsigned)SvIV(ST(0)); + } + + if (items < 2) + mask = MCW_EM; + else { + mask = (unsigned)SvIV(ST(1)); + } + + RETVAL = set_control87(new, mask); + XSprePUSH; PUSHi((IV)RETVAL); } XSRETURN(1); } @@ -4033,20 +4033,20 @@ XS(XS_OS2_incrMaxFHandles) /* DosSetRelMaxFH */ { dXSARGS; if (items < 0 || items > 1) - Perl_croak(aTHX_ "Usage: OS2::incrMaxFHandles(delta = 0)"); + Perl_croak(aTHX_ "Usage: OS2::incrMaxFHandles(delta = 0)"); { - LONG delta; - ULONG RETVAL, rc; - dXSTARG; - - if (items < 1) - delta = 0; - else - delta = (LONG)SvIV(ST(0)); - - if (CheckOSError(DosSetRelMaxFH(&delta, &RETVAL))) - croak_with_os2error("OS2::incrMaxFHandles(): DosSetRelMaxFH() error"); - XSprePUSH; PUSHu((UV)RETVAL); + LONG delta; + ULONG RETVAL, rc; + dXSTARG; + + if (items < 1) + delta = 0; + else + delta = (LONG)SvIV(ST(0)); + + if (CheckOSError(DosSetRelMaxFH(&delta, &RETVAL))) + croak_with_os2error("OS2::incrMaxFHandles(): DosSetRelMaxFH() error"); + XSprePUSH; PUSHu((UV)RETVAL); } XSRETURN(1); } @@ -4061,24 +4061,24 @@ connectNPipe(ULONG hpipe, int wait, ULONG restore, ULONG oflags) ULONG ret = ERROR_INTERRUPT, rc, flags; if (restore && wait) - os2cp_croak(DosQueryNPHState(hpipe, &oflags), "DosQueryNPHState()"); + os2cp_croak(DosQueryNPHState(hpipe, &oflags), "DosQueryNPHState()"); /* DosSetNPHState fails if more bits than NP_NOWAIT|NP_READMODE_MESSAGE */ oflags &= (NP_NOWAIT | NP_READMODE_MESSAGE); flags = (oflags & ~NP_NOWAIT) | (wait > 0 ? NP_WAIT : NP_NOWAIT); /* We know (o)flags unless wait == 0 && restore */ if (wait && (flags != oflags)) - os2cp_croak(DosSetNPHState(hpipe, flags), "DosSetNPHState()"); + os2cp_croak(DosSetNPHState(hpipe, flags), "DosSetNPHState()"); while (ret == ERROR_INTERRUPT) - ret = DosConnectNPipe(hpipe); + ret = DosConnectNPipe(hpipe); (void)CheckOSError(ret); if (restore && wait && (flags != oflags)) - os2cp_croak(DosSetNPHState(hpipe, oflags), "DosSetNPHState() back"); + os2cp_croak(DosSetNPHState(hpipe, oflags), "DosSetNPHState() back"); /* We know flags unless wait == 0 && restore */ if ( ((wait || restore) ? (flags & NP_NOWAIT) : 1) - && (ret == ERROR_PIPE_NOT_CONNECTED) ) - return 0; /* normal return value */ + && (ret == ERROR_PIPE_NOT_CONNECTED) ) + return 0; /* normal return value */ if (ret == NO_ERROR) - return 1; + return 1; croak_with_os2error("DosConnectNPipe()"); } @@ -4086,196 +4086,196 @@ connectNPipe(ULONG hpipe, int wait, ULONG restore, ULONG oflags) NO_OUTPUT ULONG DosCreateNPipe(PCSZ pszName, OUTLIST HPIPE hpipe, ULONG ulOpenMode, int connect = 1, int count = 1, ULONG ulInbufLength = 8192, ULONG ulOutbufLength = ulInbufLength, ULONG ulPipeMode = count | NP_NOWAIT | NP_TYPE_BYTE | NP_READMODE_BYTE, ULONG ulTimeout = 0) PREINIT: - ULONG rc; + ULONG rc; C_ARGS: - pszName, &hpipe, ulOpenMode, ulPipeMode, ulInbufLength, ulOutbufLength, ulTimeout + pszName, &hpipe, ulOpenMode, ulPipeMode, ulInbufLength, ulOutbufLength, ulTimeout POSTCALL: - if (CheckOSError(RETVAL)) - croak_with_os2error("OS2::mkpipe() error"); + if (CheckOSError(RETVAL)) + croak_with_os2error("OS2::mkpipe() error"); */ XS(XS_OS2_pipe); /* prototype to pass -Wmissing-prototypes */ XS(XS_OS2_pipe) { dXSARGS; if (items < 2 || items > 8) - Perl_croak(aTHX_ "Usage: OS2::pipe(pszName, ulOpenMode, connect= 1, count= 1, ulInbufLength= 8192, ulOutbufLength= ulInbufLength, ulPipeMode= count | NP_NOWAIT | NP_TYPE_BYTE | NP_READMODE_BYTE, ulTimeout= 0)"); + Perl_croak(aTHX_ "Usage: OS2::pipe(pszName, ulOpenMode, connect= 1, count= 1, ulInbufLength= 8192, ulOutbufLength= ulInbufLength, ulPipeMode= count | NP_NOWAIT | NP_TYPE_BYTE | NP_READMODE_BYTE, ulTimeout= 0)"); { - ULONG RETVAL; - PCSZ pszName = ( SvOK(ST(0)) ? (PCSZ)SvPV_nolen(ST(0)) : NULL ); - HPIPE hpipe; - SV *OpenMode = ST(1); - ULONG ulOpenMode; - int connect = 0, count, message_r = 0, message = 0, b = 0; - ULONG ulInbufLength, ulOutbufLength, ulPipeMode, ulTimeout, rc; - STRLEN len; - char *s, buf[10], *s1, *perltype = NULL; - PerlIO *perlio; - double timeout; - - if (!pszName || !*pszName) - Perl_croak(aTHX_ "OS2::pipe(): empty pipe name"); - s = SvPV(OpenMode, len); - if (memEQs(s, len, "wait")) { /* DosWaitNPipe() */ - ULONG ms = 0xFFFFFFFF, ret = ERROR_INTERRUPT; /* Indefinite */ - - if (items == 3) { - timeout = (double)SvNV(ST(2)); - ms = timeout * 1000; - if (timeout < 0) - ms = 0xFFFFFFFF; /* Indefinite */ - else if (timeout && !ms) - ms = 1; - } else if (items > 3) - Perl_croak(aTHX_ "OS2::pipe(): too many arguments for wait-for-connect: %ld", (long)items); - - while (ret == ERROR_INTERRUPT) - ret = DosWaitNPipe(pszName, ms); /* XXXX Update ms? */ - os2cp_croak(ret, "DosWaitNPipe()"); - XSRETURN_YES; - } - if (memEQs(s, len, "call")) { /* DosCallNPipe() */ - ULONG ms = 0xFFFFFFFF, got; /* Indefinite */ - STRLEN l; - char *s; - char buf[8192]; - STRLEN ll = sizeof(buf); - char *b = buf; - - if (items < 3 || items > 5) - Perl_croak(aTHX_ "usage: OS2::pipe(pszName, 'call', write [, timeout= 0xFFFFFFFF, buffsize = 8192])"); - s = SvPV(ST(2), l); - if (items >= 4) { - timeout = (double)SvNV(ST(3)); - ms = timeout * 1000; - if (timeout < 0) - ms = 0xFFFFFFFF; /* Indefinite */ - else if (timeout && !ms) - ms = 1; - } - if (items >= 5) { - STRLEN lll = SvUV(ST(4)); - SV *sv = NEWSV(914, lll); - - sv_2mortal(sv); - ll = lll; - b = SvPVX(sv); - } - - os2cp_croak(DosCallNPipe(pszName, s, l, b, ll, &got, ms), - "DosCallNPipe()"); - XSRETURN_PVN(b, got); - } - s1 = buf; - if (len && len <= 3 && !(*s >= '0' && *s <= '9')) { - int r, w, R, W; - - r = strchr(s, 'r') != 0; - w = strchr(s, 'w') != 0; - R = strchr(s, 'R') != 0; - W = strchr(s, 'W') != 0; - b = strchr(s, 'b') != 0; - if (r + w + R + W + b != len || (r && R) || (w && W)) - Perl_croak(aTHX_ "OS2::pipe(): unknown OpenMode argument: `%s'", s); - if ((r || R) && (w || W)) - ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_DUPLEX; - else if (r || R) - ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_INBOUND; - else - ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_OUTBOUND; - if (R) - message = message_r = 1; - if (W) - message = 1; - else if (w && R) - Perl_croak(aTHX_ "OS2::pipe(): can't have message read mode for non-message pipes"); - } else - ulOpenMode = (ULONG)SvUV(OpenMode); /* ST(1) */ - - if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX - || (ulOpenMode & 0x3) == NP_ACCESS_INBOUND ) - *s1++ = 'r'; - if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX ) - *s1++ = '+'; - if ( (ulOpenMode & 0x3) == NP_ACCESS_OUTBOUND ) - *s1++ = 'w'; - if (b) - *s1++ = 'b'; - *s1 = 0; - if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX ) - perltype = "+<&"; - else if ( (ulOpenMode & 0x3) == NP_ACCESS_OUTBOUND ) - perltype = ">&"; - else - perltype = "<&"; - - if (items < 3) - connect = -1; /* no wait */ - else if (SvTRUE(ST(2))) { - s = SvPV(ST(2), len); - if (memEQs(s, len, "nowait")) - connect = -1; /* no wait */ - else if (memEQs(s, len, "wait")) - connect = 1; /* wait */ - else - Perl_croak(aTHX_ "OS2::pipe(): unknown connect argument: `%s'", s); - } - - if (items < 4) - count = 1; - else - count = (int)SvIV(ST(3)); - - if (items < 5) - ulInbufLength = 8192; - else - ulInbufLength = (ULONG)SvUV(ST(4)); - - if (items < 6) - ulOutbufLength = ulInbufLength; - else - ulOutbufLength = (ULONG)SvUV(ST(5)); - - if (count < -1 || count == 0 || count >= 255) - Perl_croak(aTHX_ "OS2::pipe(): count should be -1 or between 1 and 254: %ld", (long)count); - if (count < 0 ) - count = 255; /* Unlimited */ - - ulPipeMode = count; - if (items < 7) - ulPipeMode |= (NP_WAIT - | (message ? NP_TYPE_MESSAGE : NP_TYPE_BYTE) - | (message_r ? NP_READMODE_MESSAGE : NP_READMODE_BYTE)); - else - ulPipeMode |= (ULONG)SvUV(ST(6)); - - if (items < 8) - timeout = 0; - else - timeout = (double)SvNV(ST(7)); - ulTimeout = timeout * 1000; - if (timeout < 0) - ulTimeout = 0xFFFFFFFF; /* Indefinite */ - else if (timeout && !ulTimeout) - ulTimeout = 1; - - RETVAL = DosCreateNPipe(pszName, &hpipe, ulOpenMode, ulPipeMode, ulInbufLength, ulOutbufLength, ulTimeout); - if (CheckOSError(RETVAL)) - croak_with_os2error("OS2::pipe(): DosCreateNPipe() error"); - - if (connect) - connectNPipe(hpipe, connect, 1, 0); /* XXXX wait, retval */ - hpipe = __imphandle(hpipe); - - perlio = PerlIO_fdopen(hpipe, buf); - ST(0) = sv_newmortal(); - { - GV *gv = (GV *)sv_newmortal(); - gv_init_pvn(gv, gv_stashpvs("OS2::pipe",1),"__ANONIO__",10,0); - if ( do_open6(gv, perltype, strlen(perltype), perlio, NULL, 0) ) - sv_setsv(ST(0), sv_bless(newRV((SV*)gv), gv_stashpv("IO::Handle",1))); - else - ST(0) = &PL_sv_undef; - } + ULONG RETVAL; + PCSZ pszName = ( SvOK(ST(0)) ? (PCSZ)SvPV_nolen(ST(0)) : NULL ); + HPIPE hpipe; + SV *OpenMode = ST(1); + ULONG ulOpenMode; + int connect = 0, count, message_r = 0, message = 0, b = 0; + ULONG ulInbufLength, ulOutbufLength, ulPipeMode, ulTimeout, rc; + STRLEN len; + char *s, buf[10], *s1, *perltype = NULL; + PerlIO *perlio; + double timeout; + + if (!pszName || !*pszName) + Perl_croak(aTHX_ "OS2::pipe(): empty pipe name"); + s = SvPV(OpenMode, len); + if (memEQs(s, len, "wait")) { /* DosWaitNPipe() */ + ULONG ms = 0xFFFFFFFF, ret = ERROR_INTERRUPT; /* Indefinite */ + + if (items == 3) { + timeout = (double)SvNV(ST(2)); + ms = timeout * 1000; + if (timeout < 0) + ms = 0xFFFFFFFF; /* Indefinite */ + else if (timeout && !ms) + ms = 1; + } else if (items > 3) + Perl_croak(aTHX_ "OS2::pipe(): too many arguments for wait-for-connect: %ld", (long)items); + + while (ret == ERROR_INTERRUPT) + ret = DosWaitNPipe(pszName, ms); /* XXXX Update ms? */ + os2cp_croak(ret, "DosWaitNPipe()"); + XSRETURN_YES; + } + if (memEQs(s, len, "call")) { /* DosCallNPipe() */ + ULONG ms = 0xFFFFFFFF, got; /* Indefinite */ + STRLEN l; + char *s; + char buf[8192]; + STRLEN ll = sizeof(buf); + char *b = buf; + + if (items < 3 || items > 5) + Perl_croak(aTHX_ "usage: OS2::pipe(pszName, 'call', write [, timeout= 0xFFFFFFFF, buffsize = 8192])"); + s = SvPV(ST(2), l); + if (items >= 4) { + timeout = (double)SvNV(ST(3)); + ms = timeout * 1000; + if (timeout < 0) + ms = 0xFFFFFFFF; /* Indefinite */ + else if (timeout && !ms) + ms = 1; + } + if (items >= 5) { + STRLEN lll = SvUV(ST(4)); + SV *sv = NEWSV(914, lll); + + sv_2mortal(sv); + ll = lll; + b = SvPVX(sv); + } + + os2cp_croak(DosCallNPipe(pszName, s, l, b, ll, &got, ms), + "DosCallNPipe()"); + XSRETURN_PVN(b, got); + } + s1 = buf; + if (len && len <= 3 && !(*s >= '0' && *s <= '9')) { + int r, w, R, W; + + r = strchr(s, 'r') != 0; + w = strchr(s, 'w') != 0; + R = strchr(s, 'R') != 0; + W = strchr(s, 'W') != 0; + b = strchr(s, 'b') != 0; + if (r + w + R + W + b != len || (r && R) || (w && W)) + Perl_croak(aTHX_ "OS2::pipe(): unknown OpenMode argument: `%s'", s); + if ((r || R) && (w || W)) + ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_DUPLEX; + else if (r || R) + ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_INBOUND; + else + ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_OUTBOUND; + if (R) + message = message_r = 1; + if (W) + message = 1; + else if (w && R) + Perl_croak(aTHX_ "OS2::pipe(): can't have message read mode for non-message pipes"); + } else + ulOpenMode = (ULONG)SvUV(OpenMode); /* ST(1) */ + + if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX + || (ulOpenMode & 0x3) == NP_ACCESS_INBOUND ) + *s1++ = 'r'; + if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX ) + *s1++ = '+'; + if ( (ulOpenMode & 0x3) == NP_ACCESS_OUTBOUND ) + *s1++ = 'w'; + if (b) + *s1++ = 'b'; + *s1 = 0; + if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX ) + perltype = "+<&"; + else if ( (ulOpenMode & 0x3) == NP_ACCESS_OUTBOUND ) + perltype = ">&"; + else + perltype = "<&"; + + if (items < 3) + connect = -1; /* no wait */ + else if (SvTRUE(ST(2))) { + s = SvPV(ST(2), len); + if (memEQs(s, len, "nowait")) + connect = -1; /* no wait */ + else if (memEQs(s, len, "wait")) + connect = 1; /* wait */ + else + Perl_croak(aTHX_ "OS2::pipe(): unknown connect argument: `%s'", s); + } + + if (items < 4) + count = 1; + else + count = (int)SvIV(ST(3)); + + if (items < 5) + ulInbufLength = 8192; + else + ulInbufLength = (ULONG)SvUV(ST(4)); + + if (items < 6) + ulOutbufLength = ulInbufLength; + else + ulOutbufLength = (ULONG)SvUV(ST(5)); + + if (count < -1 || count == 0 || count >= 255) + Perl_croak(aTHX_ "OS2::pipe(): count should be -1 or between 1 and 254: %ld", (long)count); + if (count < 0 ) + count = 255; /* Unlimited */ + + ulPipeMode = count; + if (items < 7) + ulPipeMode |= (NP_WAIT + | (message ? NP_TYPE_MESSAGE : NP_TYPE_BYTE) + | (message_r ? NP_READMODE_MESSAGE : NP_READMODE_BYTE)); + else + ulPipeMode |= (ULONG)SvUV(ST(6)); + + if (items < 8) + timeout = 0; + else + timeout = (double)SvNV(ST(7)); + ulTimeout = timeout * 1000; + if (timeout < 0) + ulTimeout = 0xFFFFFFFF; /* Indefinite */ + else if (timeout && !ulTimeout) + ulTimeout = 1; + + RETVAL = DosCreateNPipe(pszName, &hpipe, ulOpenMode, ulPipeMode, ulInbufLength, ulOutbufLength, ulTimeout); + if (CheckOSError(RETVAL)) + croak_with_os2error("OS2::pipe(): DosCreateNPipe() error"); + + if (connect) + connectNPipe(hpipe, connect, 1, 0); /* XXXX wait, retval */ + hpipe = __imphandle(hpipe); + + perlio = PerlIO_fdopen(hpipe, buf); + ST(0) = sv_newmortal(); + { + GV *gv = (GV *)sv_newmortal(); + gv_init_pvn(gv, gv_stashpvs("OS2::pipe",1),"__ANONIO__",10,0); + if ( do_open6(gv, perltype, strlen(perltype), perlio, NULL, 0) ) + sv_setsv(ST(0), sv_bless(newRV((SV*)gv), gv_stashpv("IO::Handle",1))); + else + ST(0) = &PL_sv_undef; + } } XSRETURN(1); } @@ -4285,155 +4285,155 @@ XS(XS_OS2_pipeCntl) { dXSARGS; if (items < 2 || items > 3) - Perl_croak(aTHX_ "Usage: OS2::pipeCntl(pipe, op [, wait])"); + Perl_croak(aTHX_ "Usage: OS2::pipeCntl(pipe, op [, wait])"); { - ULONG rc; - PerlIO *perlio = IoIFP(sv_2io(ST(0))); - IV fn = PerlIO_fileno(perlio); - HPIPE hpipe = (HPIPE)fn; - STRLEN len; - char *s = SvPV(ST(1), len); - int wait = 0, disconnect = 0, connect = 0, message = -1, query = 0; - int peek = 0, state = 0, info = 0; - - if (fn < 0) - Perl_croak(aTHX_ "OS2::pipeCntl(): not a pipe"); - if (items == 3) - wait = (SvTRUE(ST(2)) ? 1 : -1); - - switch (len) { - case 4: - if (strEQ(s, "byte")) - message = 0; - else if (strEQ(s, "peek")) - peek = 1; - else if (strEQ(s, "info")) - info = 1; - else - goto unknown; - break; - case 5: - if (strEQ(s, "reset")) - disconnect = connect = 1; - else if (strEQ(s, "state")) - query = 1; - else - goto unknown; - break; - case 7: - if (strEQ(s, "connect")) - connect = 1; - else if (strEQ(s, "message")) - message = 1; - else - goto unknown; - break; - case 9: - if (!strEQ(s, "readstate")) - goto unknown; - state = 1; - break; - case 10: - if (!strEQ(s, "disconnect")) - goto unknown; - disconnect = 1; - break; - default: - unknown: - Perl_croak(aTHX_ "OS2::pipeCntl(): unknown argument: `%s'", s); - break; - } - - if (items == 3 && !connect) - Perl_croak(aTHX_ "OS2::pipeCntl(): no wait argument for `%s'", s); - - XSprePUSH; /* Do not need arguments any more */ - if (disconnect) { - os2cp_croak(DosDisConnectNPipe(hpipe), "OS2::pipeCntl(): DosDisConnectNPipe()"); - PerlIO_clearerr(perlio); - } - if (connect) { - if (!connectNPipe(hpipe, wait , 1, 0)) - XSRETURN_IV(-1); - } - if (query) { - ULONG flags; - - os2cp_croak(DosQueryNPHState(hpipe, &flags), "DosQueryNPHState()"); - XSRETURN_UV(flags); - } - if (peek || state || info) { - ULONG BytesRead, PipeState; - AVAILDATA BytesAvail; - - os2cp_croak( DosPeekNPipe(hpipe, NULL, 0, &BytesRead, &BytesAvail, - &PipeState), "DosPeekNPipe() for state"); - if (state) { - EXTEND(SP, 3); - mPUSHu(PipeState); - /* Bytes (available/in-message) */ - mPUSHi(BytesAvail.cbpipe); - mPUSHi(BytesAvail.cbmessage); - XSRETURN(3); - } else if (info) { - /* L S S C C C/Z* - ID of the (remote) computer - buffers (out/in) - instances (max/actual) - */ - struct pipe_info_t { - ULONG id; /* char id[4]; */ - PIPEINFO pInfo; - char buf[512]; - } b; - int size; - - os2cp_croak( DosQueryNPipeInfo(hpipe, 1, &b.pInfo, sizeof(b) - STRUCT_OFFSET(struct pipe_info_t, pInfo)), - "DosQueryNPipeInfo(1)"); - os2cp_croak( DosQueryNPipeInfo(hpipe, 2, &b.id, sizeof(b.id)), - "DosQueryNPipeInfo(2)"); - size = b.pInfo.cbName; - /* Trailing 0 is included in cbName - undocumented; so - one should always extract with Z* */ - if (size) /* name length 254 or less */ - size--; - else - size = strlen(b.pInfo.szName); - EXTEND(SP, 6); - mPUSHp(b.pInfo.szName, size); - mPUSHu(b.id); - mPUSHi(b.pInfo.cbOut); - mPUSHi(b.pInfo.cbIn); - mPUSHi(b.pInfo.cbMaxInst); - mPUSHi(b.pInfo.cbCurInst); - XSRETURN(6); - } else if (BytesAvail.cbpipe == 0) { - XSRETURN_NO; - } else { - SV *tmp = NEWSV(914, BytesAvail.cbpipe); - char *s = SvPVX(tmp); - - sv_2mortal(tmp); - os2cp_croak( DosPeekNPipe(hpipe, s, BytesAvail.cbpipe, &BytesRead, - &BytesAvail, &PipeState), "DosPeekNPipe()"); - SvCUR_set(tmp, BytesRead); - *SvEND(tmp) = 0; - SvPOK_on(tmp); - XSprePUSH; PUSHs(tmp); - XSRETURN(1); - } - } - if (message > -1) { - ULONG oflags, flags; - - os2cp_croak(DosQueryNPHState(hpipe, &oflags), "DosQueryNPHState()"); - /* DosSetNPHState fails if more bits than NP_NOWAIT|NP_READMODE_MESSAGE */ - oflags &= (NP_NOWAIT | NP_READMODE_MESSAGE); - flags = (oflags & NP_NOWAIT) - | (message ? NP_READMODE_MESSAGE : NP_READMODE_BYTE); - if (flags != oflags) - os2cp_croak(DosSetNPHState(hpipe, flags), "DosSetNPHState()"); - } + ULONG rc; + PerlIO *perlio = IoIFP(sv_2io(ST(0))); + IV fn = PerlIO_fileno(perlio); + HPIPE hpipe = (HPIPE)fn; + STRLEN len; + char *s = SvPV(ST(1), len); + int wait = 0, disconnect = 0, connect = 0, message = -1, query = 0; + int peek = 0, state = 0, info = 0; + + if (fn < 0) + Perl_croak(aTHX_ "OS2::pipeCntl(): not a pipe"); + if (items == 3) + wait = (SvTRUE(ST(2)) ? 1 : -1); + + switch (len) { + case 4: + if (strEQ(s, "byte")) + message = 0; + else if (strEQ(s, "peek")) + peek = 1; + else if (strEQ(s, "info")) + info = 1; + else + goto unknown; + break; + case 5: + if (strEQ(s, "reset")) + disconnect = connect = 1; + else if (strEQ(s, "state")) + query = 1; + else + goto unknown; + break; + case 7: + if (strEQ(s, "connect")) + connect = 1; + else if (strEQ(s, "message")) + message = 1; + else + goto unknown; + break; + case 9: + if (!strEQ(s, "readstate")) + goto unknown; + state = 1; + break; + case 10: + if (!strEQ(s, "disconnect")) + goto unknown; + disconnect = 1; + break; + default: + unknown: + Perl_croak(aTHX_ "OS2::pipeCntl(): unknown argument: `%s'", s); + break; + } + + if (items == 3 && !connect) + Perl_croak(aTHX_ "OS2::pipeCntl(): no wait argument for `%s'", s); + + XSprePUSH; /* Do not need arguments any more */ + if (disconnect) { + os2cp_croak(DosDisConnectNPipe(hpipe), "OS2::pipeCntl(): DosDisConnectNPipe()"); + PerlIO_clearerr(perlio); + } + if (connect) { + if (!connectNPipe(hpipe, wait , 1, 0)) + XSRETURN_IV(-1); + } + if (query) { + ULONG flags; + + os2cp_croak(DosQueryNPHState(hpipe, &flags), "DosQueryNPHState()"); + XSRETURN_UV(flags); + } + if (peek || state || info) { + ULONG BytesRead, PipeState; + AVAILDATA BytesAvail; + + os2cp_croak( DosPeekNPipe(hpipe, NULL, 0, &BytesRead, &BytesAvail, + &PipeState), "DosPeekNPipe() for state"); + if (state) { + EXTEND(SP, 3); + mPUSHu(PipeState); + /* Bytes (available/in-message) */ + mPUSHi(BytesAvail.cbpipe); + mPUSHi(BytesAvail.cbmessage); + XSRETURN(3); + } else if (info) { + /* L S S C C C/Z* + ID of the (remote) computer + buffers (out/in) + instances (max/actual) + */ + struct pipe_info_t { + ULONG id; /* char id[4]; */ + PIPEINFO pInfo; + char buf[512]; + } b; + int size; + + os2cp_croak( DosQueryNPipeInfo(hpipe, 1, &b.pInfo, sizeof(b) - STRUCT_OFFSET(struct pipe_info_t, pInfo)), + "DosQueryNPipeInfo(1)"); + os2cp_croak( DosQueryNPipeInfo(hpipe, 2, &b.id, sizeof(b.id)), + "DosQueryNPipeInfo(2)"); + size = b.pInfo.cbName; + /* Trailing 0 is included in cbName - undocumented; so + one should always extract with Z* */ + if (size) /* name length 254 or less */ + size--; + else + size = strlen(b.pInfo.szName); + EXTEND(SP, 6); + mPUSHp(b.pInfo.szName, size); + mPUSHu(b.id); + mPUSHi(b.pInfo.cbOut); + mPUSHi(b.pInfo.cbIn); + mPUSHi(b.pInfo.cbMaxInst); + mPUSHi(b.pInfo.cbCurInst); + XSRETURN(6); + } else if (BytesAvail.cbpipe == 0) { + XSRETURN_NO; + } else { + SV *tmp = NEWSV(914, BytesAvail.cbpipe); + char *s = SvPVX(tmp); + + sv_2mortal(tmp); + os2cp_croak( DosPeekNPipe(hpipe, s, BytesAvail.cbpipe, &BytesRead, + &BytesAvail, &PipeState), "DosPeekNPipe()"); + SvCUR_set(tmp, BytesRead); + *SvEND(tmp) = 0; + SvPOK_on(tmp); + XSprePUSH; PUSHs(tmp); + XSRETURN(1); + } + } + if (message > -1) { + ULONG oflags, flags; + + os2cp_croak(DosQueryNPHState(hpipe, &oflags), "DosQueryNPHState()"); + /* DosSetNPHState fails if more bits than NP_NOWAIT|NP_READMODE_MESSAGE */ + oflags &= (NP_NOWAIT | NP_READMODE_MESSAGE); + flags = (oflags & NP_NOWAIT) + | (message ? NP_READMODE_MESSAGE : NP_READMODE_BYTE); + if (flags != oflags) + os2cp_croak(DosSetNPHState(hpipe, flags), "DosSetNPHState()"); + } } XSRETURN_YES; } @@ -4442,65 +4442,65 @@ XS(XS_OS2_pipeCntl) NO_OUTPUT ULONG DosOpen(PCSZ pszFileName, OUTLIST HFILE hFile, OUTLIST ULONG ulAction, ULONG ulOpenFlags, ULONG ulOpenMode = OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW, ULONG ulAttribute = FILE_NORMAL, ULONG ulFileSize = 0, PEAOP2 pEABuf = NULL); PREINIT: - ULONG rc; + ULONG rc; C_ARGS: - pszFileName, &hFile, &ulAction, ulFileSize, ulAttribute, ulOpenFlags, ulOpenMode, pEABuf + pszFileName, &hFile, &ulAction, ulFileSize, ulAttribute, ulOpenFlags, ulOpenMode, pEABuf POSTCALL: - if (CheckOSError(RETVAL)) - croak_with_os2error("OS2::open() error"); + if (CheckOSError(RETVAL)) + croak_with_os2error("OS2::open() error"); */ XS(XS_OS2_open); /* prototype to pass -Wmissing-prototypes */ XS(XS_OS2_open) { dXSARGS; if (items < 2 || items > 6) - Perl_croak(aTHX_ "Usage: OS2::open(pszFileName, ulOpenMode, ulOpenFlags= OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW, ulAttribute= FILE_NORMAL, ulFileSize= 0, pEABuf= NULL)"); + Perl_croak(aTHX_ "Usage: OS2::open(pszFileName, ulOpenMode, ulOpenFlags= OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW, ulAttribute= FILE_NORMAL, ulFileSize= 0, pEABuf= NULL)"); { #line 39 "pipe.xs" - ULONG rc; + ULONG rc; #line 113 "pipe.c" - ULONG RETVAL; - PCSZ pszFileName = ( SvOK(ST(0)) ? (PCSZ)SvPV_nolen(ST(0)) : NULL ); - HFILE hFile; - ULONG ulAction; - ULONG ulOpenMode = (ULONG)SvUV(ST(1)); - ULONG ulOpenFlags; - ULONG ulAttribute; - ULONG ulFileSize; - PEAOP2 pEABuf; - - if (items < 3) - ulOpenFlags = OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW; - else { - ulOpenFlags = (ULONG)SvUV(ST(2)); - } - - if (items < 4) - ulAttribute = FILE_NORMAL; - else { - ulAttribute = (ULONG)SvUV(ST(3)); - } - - if (items < 5) - ulFileSize = 0; - else { - ulFileSize = (ULONG)SvUV(ST(4)); - } - - if (items < 6) - pEABuf = NULL; - else { - pEABuf = (PEAOP2)SvUV(ST(5)); - } - - RETVAL = DosOpen(pszFileName, &hFile, &ulAction, ulFileSize, ulAttribute, ulOpenFlags, ulOpenMode, pEABuf); - if (CheckOSError(RETVAL)) - croak_with_os2error("OS2::open() error"); - XSprePUSH; EXTEND(SP,2); - PUSHs(sv_newmortal()); - sv_setuv(ST(0), (UV)hFile); - PUSHs(sv_newmortal()); - sv_setuv(ST(1), (UV)ulAction); + ULONG RETVAL; + PCSZ pszFileName = ( SvOK(ST(0)) ? (PCSZ)SvPV_nolen(ST(0)) : NULL ); + HFILE hFile; + ULONG ulAction; + ULONG ulOpenMode = (ULONG)SvUV(ST(1)); + ULONG ulOpenFlags; + ULONG ulAttribute; + ULONG ulFileSize; + PEAOP2 pEABuf; + + if (items < 3) + ulOpenFlags = OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW; + else { + ulOpenFlags = (ULONG)SvUV(ST(2)); + } + + if (items < 4) + ulAttribute = FILE_NORMAL; + else { + ulAttribute = (ULONG)SvUV(ST(3)); + } + + if (items < 5) + ulFileSize = 0; + else { + ulFileSize = (ULONG)SvUV(ST(4)); + } + + if (items < 6) + pEABuf = NULL; + else { + pEABuf = (PEAOP2)SvUV(ST(5)); + } + + RETVAL = DosOpen(pszFileName, &hFile, &ulAction, ulFileSize, ulAttribute, ulOpenFlags, ulOpenMode, pEABuf); + if (CheckOSError(RETVAL)) + croak_with_os2error("OS2::open() error"); + XSprePUSH; EXTEND(SP,2); + PUSHs(sv_newmortal()); + sv_setuv(ST(0), (UV)hFile); + PUSHs(sv_newmortal()); + sv_setuv(ST(1), (UV)ulAction); } XSRETURN(2); } @@ -4510,15 +4510,15 @@ Xs_OS2_init(pTHX) { char *file = __FILE__; { - GV *gv; + GV *gv; - if (_emx_env & 0x200) { /* OS/2 */ + if (_emx_env & 0x200) { /* OS/2 */ newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file); newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file); newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file); newXS("OS2::extLibpath", XS_Cwd_extLibpath, file); newXS("OS2::extLibpath_set", XS_Cwd_extLibpath_set, file); - } + } newXS("OS2::Error", XS_OS2_Error, file); newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file); newXS("OS2::SysInfo", XS_OS2_SysInfo, file); @@ -4559,33 +4559,33 @@ Xs_OS2_init(pTHX) newXSproto("OS2::pipe", XS_OS2_pipe, file, "$$;$$$$$$"); newXSproto("OS2::pipeCntl", XS_OS2_pipeCntl, file, "$$;$"); newXSproto("OS2::open", XS_OS2_open, file, "$$;$$$$"); - gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV); - GvMULTI_on(gv); + gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV); + GvMULTI_on(gv); #ifdef PERL_IS_AOUT - sv_setiv(GvSV(gv), 1); + sv_setiv(GvSV(gv), 1); #endif - gv = gv_fetchpv("OS2::is_static", TRUE, SVt_PV); - GvMULTI_on(gv); + gv = gv_fetchpv("OS2::is_static", TRUE, SVt_PV); + GvMULTI_on(gv); #ifdef PERL_IS_AOUT - sv_setiv(GvSV(gv), 1); + sv_setiv(GvSV(gv), 1); #endif - gv = gv_fetchpv("OS2::can_fork", TRUE, SVt_PV); - GvMULTI_on(gv); - sv_setiv(GvSV(gv), exe_is_aout()); - gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV); - GvMULTI_on(gv); - sv_setiv(GvSV(gv), _emx_rev); - sv_setpv(GvSV(gv), _emx_vprt); - SvIOK_on(GvSV(gv)); - gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV); - GvMULTI_on(gv); - sv_setiv(GvSV(gv), _emx_env); - gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV); - GvMULTI_on(gv); - sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor); - gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV); - GvMULTI_on(gv); - sv_setiv(GvSV(gv), 1); /* DEFAULT: Show number on syserror */ + gv = gv_fetchpv("OS2::can_fork", TRUE, SVt_PV); + GvMULTI_on(gv); + sv_setiv(GvSV(gv), exe_is_aout()); + gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV); + GvMULTI_on(gv); + sv_setiv(GvSV(gv), _emx_rev); + sv_setpv(GvSV(gv), _emx_vprt); + SvIOK_on(GvSV(gv)); + gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV); + GvMULTI_on(gv); + sv_setiv(GvSV(gv), _emx_env); + gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV); + GvMULTI_on(gv); + sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor); + gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV); + GvMULTI_on(gv); + sv_setiv(GvSV(gv), 1); /* DEFAULT: Show number on syserror */ } return 0; } @@ -4604,13 +4604,13 @@ my_emx_init(void *layout) { /* Can't just call emx_init(), since it moves the stack pointer */ /* It also busts a lot of registers, so be extra careful */ __asm__( "pushf\n" - "pusha\n" - "movl %%esp, %1\n" - "push %0\n" - "call __emx_init\n" - "movl %1, %%esp\n" - "popa\n" - "popf\n" : : "r" (layout), "m" (old_esp) ); + "pusha\n" + "movl %%esp, %1\n" + "push %0\n" + "call __emx_init\n" + "movl %1, %%esp\n" + "popa\n" + "popf\n" : : "r" (layout), "m" (old_esp) ); } struct layout_table_t { @@ -4639,11 +4639,11 @@ my_os_version() { /* Can't just call __os_version(), since it does not follow C calling convention: it busts a lot of registers, so be extra careful */ __asm__( "pushf\n" - "pusha\n" - "call ___os_version\n" - "movl %%eax, %0\n" - "popa\n" - "popf\n" : "=m" (osv_res) ); + "pusha\n" + "call ___os_version\n" + "movl %%eax, %0\n" + "popa\n" + "popf\n" : "=m" (osv_res) ); return osv_res; } @@ -4661,9 +4661,9 @@ force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags) char buf[512]; static struct layout_table_t layout_table; struct { - char buf[48*1024]; /* _emx_init() requires 32K, cmd.exe has 64K only */ - double alignment1; - EXCEPTIONREGISTRATIONRECORD xreg; + char buf[48*1024]; /* _emx_init() requires 32K, cmd.exe has 64K only */ + double alignment1; + EXCEPTIONREGISTRATIONRECORD xreg; } *newstack; char *s; @@ -4677,23 +4677,23 @@ force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags) oldstackend = tib->tib_pstacklimit; if ( (char*)&s < (char*)oldstack + 4*1024 - || (char *)oldstackend < (char*)oldstack + 52*1024 ) - early_error("It is a lunacy to try to run EMX Perl ", - "with less than 64K of stack;\r\n", - " at least with non-EMX starter...\r\n"); + || (char *)oldstackend < (char*)oldstack + 52*1024 ) + early_error("It is a lunacy to try to run EMX Perl ", + "with less than 64K of stack;\r\n", + " at least with non-EMX starter...\r\n"); /* Minimize the damage to the stack via reducing the size of argv. */ if (flags & FORCE_EMX_INIT_CONTRACT_ARGV) { - pib->pib_pchcmd = "\0\0"; /* Need 3 concatenated strings */ - pib->pib_pchcmd = "\0"; /* Ended by an extra \0. */ + pib->pib_pchcmd = "\0\0"; /* Need 3 concatenated strings */ + pib->pib_pchcmd = "\0"; /* Ended by an extra \0. */ } newstack = alloca(sizeof(*newstack)); /* Emulate the stack probe */ s = ((char*)newstack) + sizeof(*newstack); while (s > (char*)newstack) { - s[-1] = 0; - s -= 4096; + s[-1] = 0; + s -= 4096; } /* Reassigning stack is documented to work */ @@ -4707,38 +4707,38 @@ force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags) Check whether it is inside the new stack. */ buf[0] = 0; if (tib->tib_pexchain >= tib->tib_pstacklimit - || tib->tib_pexchain < tib->tib_pstack) { - error = 1; - sprintf(buf, - "panic: ExceptionHandler misplaced: not %#lx <= %#lx < %#lx\n", - (unsigned long)tib->tib_pstack, - (unsigned long)tib->tib_pexchain, - (unsigned long)tib->tib_pstacklimit); - goto finish; + || tib->tib_pexchain < tib->tib_pstack) { + error = 1; + sprintf(buf, + "panic: ExceptionHandler misplaced: not %#lx <= %#lx < %#lx\n", + (unsigned long)tib->tib_pstack, + (unsigned long)tib->tib_pexchain, + (unsigned long)tib->tib_pstacklimit); + goto finish; } if (tib->tib_pexchain != &(newstack->xreg)) { - sprintf(buf, "ExceptionHandler misplaced: %#lx != %#lx\n", - (unsigned long)tib->tib_pexchain, - (unsigned long)&(newstack->xreg)); + sprintf(buf, "ExceptionHandler misplaced: %#lx != %#lx\n", + (unsigned long)tib->tib_pexchain, + (unsigned long)&(newstack->xreg)); } rc = DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)tib->tib_pexchain); if (rc) - sprintf(buf + strlen(buf), - "warning: DosUnsetExceptionHandler rc=%#lx=%lu\n", rc, rc); + sprintf(buf + strlen(buf), + "warning: DosUnsetExceptionHandler rc=%#lx=%lu\n", rc, rc); if (preg) { - /* ExceptionRecords should be on stack, in a correct order. Sigh... */ - preg->prev_structure = 0; - preg->ExceptionHandler = _emx_exception; - rc = DosSetExceptionHandler(preg); - if (rc) { - sprintf(buf + strlen(buf), - "warning: DosSetExceptionHandler rc=%#lx=%lu\n", rc, rc); - DosWrite(2, buf, strlen(buf), &out); - emx_exception_init = 1; /* Do it around spawn*() calls */ - } + /* ExceptionRecords should be on stack, in a correct order. Sigh... */ + preg->prev_structure = 0; + preg->ExceptionHandler = _emx_exception; + rc = DosSetExceptionHandler(preg); + if (rc) { + sprintf(buf + strlen(buf), + "warning: DosSetExceptionHandler rc=%#lx=%lu\n", rc, rc); + DosWrite(2, buf, strlen(buf), &out); + emx_exception_init = 1; /* Do it around spawn*() calls */ + } } else - emx_exception_init = 1; /* Do it around spawn*() calls */ + emx_exception_init = 1; /* Do it around spawn*() calls */ finish: /* Restore the damage */ @@ -4748,16 +4748,16 @@ force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags) tib->tib_pstack = oldstack; emx_runtime_init = 1; if (buf[0]) - DosWrite(2, buf, strlen(buf), &out); + DosWrite(2, buf, strlen(buf), &out); if (error) - exit(56); + exit(56); } static void jmp_out_of_atexit(void) { if (longjmp_at_exit) - longjmp(at_exit_buf, 1); + longjmp(at_exit_buf, 1); } extern void _CRT_term(void); @@ -4766,34 +4766,34 @@ void Perl_OS2_term(void **p, int exitstatus, int flags) { if (!emx_runtime_secondary) - return; + return; /* The principal executable is not running the same CRTL, so there is nobody to shutdown *this* CRTL except us... */ if (flags & FORCE_EMX_DEINIT_EXIT) { - if (p && !emx_exception_init) - DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p); - /* Do not run the executable's CRTL's termination routines */ - exit(exitstatus); /* Run at-exit, flush buffers, etc */ + if (p && !emx_exception_init) + DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p); + /* Do not run the executable's CRTL's termination routines */ + exit(exitstatus); /* Run at-exit, flush buffers, etc */ } /* Run at-exit list, and jump out at the end */ if ((flags & FORCE_EMX_DEINIT_RUN_ATEXIT) && !setjmp(at_exit_buf)) { - longjmp_at_exit = 1; - exit(exitstatus); /* The first pass through "if" */ + longjmp_at_exit = 1; + exit(exitstatus); /* The first pass through "if" */ } /* Get here if we managed to jump out of exit(), or did not run atexit. */ longjmp_at_exit = 0; /* Maybe exit() is called again? */ #if 0 /* _atexit_n is not exported */ if (flags & FORCE_EMX_DEINIT_RUN_ATEXIT) - _atexit_n = 0; /* Remove the atexit() handlers */ + _atexit_n = 0; /* Remove the atexit() handlers */ #endif /* Will segfault on program termination if we leave this dangling... */ if (p && !emx_exception_init) - DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p); + DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p); /* Typically there is no need to do this, done from _DLL_InitTerm() */ if (flags & FORCE_EMX_DEINIT_CRT_TERM) - _CRT_term(); /* Flush buffers, etc. */ + _CRT_term(); /* Flush buffers, etc. */ /* Now it is a good time to call exit() in the caller's CRTL... */ } @@ -4809,11 +4809,11 @@ check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg) static int emx_init_done = 0; /* If _environ is not set, this code sits in a DLL which - uses a CRT DLL which not compatible with the executable's - CRT library. Some parts of the DLL are not initialized. + uses a CRT DLL which not compatible with the executable's + CRT library. Some parts of the DLL are not initialized. */ if (_environ != NULL) - return; /* Properly initialized */ + return; /* Properly initialized */ /* It is not DOS, so we may use OS/2 API now */ /* Some data we manipulate is static; protect ourselves from @@ -4822,92 +4822,92 @@ check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg) rc1 = DosEnterCritSec(); if (!hmtx_emx_init) - rc = DosCreateMutexSem(NULL, &hmtx_emx_init, 0, TRUE); /*Create owned*/ + rc = DosCreateMutexSem(NULL, &hmtx_emx_init, 0, TRUE); /*Create owned*/ else - maybe_inited = 1; + maybe_inited = 1; if (rc != NO_ERROR) - hmtx_emx_init = NULLHANDLE; + hmtx_emx_init = NULLHANDLE; if (rc1 == NO_ERROR) - DosExitCritSec(); + DosExitCritSec(); DosExitMustComplete(&count); while (maybe_inited) { /* Other thread did or is doing the same now */ - if (emx_init_done) - return; - rc = DosRequestMutexSem(hmtx_emx_init, - (ULONG) SEM_INDEFINITE_WAIT); /* Timeout (none) */ - if (rc == ERROR_INTERRUPT) - continue; - if (rc != NO_ERROR) { - char buf[80]; - ULONG out; - - sprintf(buf, - "panic: EMX backdoor init: DosRequestMutexSem error: %lu=%#lx\n", rc, rc); - DosWrite(2, buf, strlen(buf), &out); - return; - } - DosReleaseMutexSem(hmtx_emx_init); - return; + if (emx_init_done) + return; + rc = DosRequestMutexSem(hmtx_emx_init, + (ULONG) SEM_INDEFINITE_WAIT); /* Timeout (none) */ + if (rc == ERROR_INTERRUPT) + continue; + if (rc != NO_ERROR) { + char buf[80]; + ULONG out; + + sprintf(buf, + "panic: EMX backdoor init: DosRequestMutexSem error: %lu=%#lx\n", rc, rc); + DosWrite(2, buf, strlen(buf), &out); + return; + } + DosReleaseMutexSem(hmtx_emx_init); + return; } /* If the executable does not use EMX.DLL, EMX.DLL is not completely - initialized either. Uninitialized EMX.DLL returns 0 in the low - nibble of __os_version(). */ + initialized either. Uninitialized EMX.DLL returns 0 in the low + nibble of __os_version(). */ v_emx = my_os_version(); /* _osmajor and _osminor are normally set in _DLL_InitTerm of CRT DLL - (=>_CRT_init=>_entry2) via a call to __os_version(), then - reset when the EXE initialization code calls _text=>_init=>_entry2. - The first time they are wrongly set to 0; the second time the - EXE initialization code had already called emx_init=>initialize1 - which correctly set version_major, version_minor used by - __os_version(). */ + (=>_CRT_init=>_entry2) via a call to __os_version(), then + reset when the EXE initialization code calls _text=>_init=>_entry2. + The first time they are wrongly set to 0; the second time the + EXE initialization code had already called emx_init=>initialize1 + which correctly set version_major, version_minor used by + __os_version(). */ v_crt = (_osmajor | _osminor); if ((_emx_env & 0x200) && !(v_emx & 0xFFFF)) { /* OS/2, EMX uninit. */ - force_init_emx_runtime( preg, - FORCE_EMX_INIT_CONTRACT_ARGV - | FORCE_EMX_INIT_INSTALL_ATEXIT ); - emx_wasnt_initialized = 1; - /* Update CRTL data basing on now-valid EMX runtime data */ - if (!v_crt) { /* The only wrong data are the versions. */ - v_emx = my_os_version(); /* *Now* it works */ - *(unsigned char *)&_osmajor = v_emx & 0xFF; /* Cast out const */ - *(unsigned char *)&_osminor = (v_emx>>8) & 0xFF; - } + force_init_emx_runtime( preg, + FORCE_EMX_INIT_CONTRACT_ARGV + | FORCE_EMX_INIT_INSTALL_ATEXIT ); + emx_wasnt_initialized = 1; + /* Update CRTL data basing on now-valid EMX runtime data */ + if (!v_crt) { /* The only wrong data are the versions. */ + v_emx = my_os_version(); /* *Now* it works */ + *(unsigned char *)&_osmajor = v_emx & 0xFF; /* Cast out const */ + *(unsigned char *)&_osminor = (v_emx>>8) & 0xFF; + } } emx_runtime_secondary = 1; /* if (flags & FORCE_EMX_INIT_INSTALL_ATEXIT) */ atexit(jmp_out_of_atexit); /* Allow run of atexit() w/o exit() */ if (env == NULL) { /* Fetch from the process info block */ - int c = 0; - PPIB pib; - PTIB tib; - char *e, **ep; - - DosGetInfoBlocks(&tib, &pib); - e = pib->pib_pchenv; - while (*e) { /* Get count */ - c++; - e = e + strlen(e) + 1; - } - Newx(env, c + 1, char*); - ep = env; - e = pib->pib_pchenv; - while (c--) { - *ep++ = e; - e = e + strlen(e) + 1; - } - *ep = NULL; + int c = 0; + PPIB pib; + PTIB tib; + char *e, **ep; + + DosGetInfoBlocks(&tib, &pib); + e = pib->pib_pchenv; + while (*e) { /* Get count */ + c++; + e = e + strlen(e) + 1; + } + Newx(env, c + 1, char*); + ep = env; + e = pib->pib_pchenv; + while (c--) { + *ep++ = e; + e = e + strlen(e) + 1; + } + *ep = NULL; } _environ = _org_environ = env; emx_init_done = 1; if (hmtx_emx_init) - DosReleaseMutexSem(hmtx_emx_init); + DosReleaseMutexSem(hmtx_emx_init); } #define ENTRY_POINT 0x10000 @@ -4917,16 +4917,16 @@ exe_is_aout(void) { struct layout_table_t *layout; if (emx_wasnt_initialized) - return 0; + return 0; /* Now we know that the principal executable is an EMX application - unless somebody did already play with delayed initialization... */ /* With EMX applications to determine whether it is AOUT one needs to examine the start of the executable to find "layout" */ if ( *(unsigned char*)ENTRY_POINT != 0x68 /* PUSH n */ - || *(unsigned char*)(ENTRY_POINT+5) != 0xe8 /* CALL */ - || *(unsigned char*)(ENTRY_POINT+10) != 0xeb /* JMP */ - || *(unsigned char*)(ENTRY_POINT+12) != 0xe8) /* CALL */ - return 0; /* ! EMX executable */ + || *(unsigned char*)(ENTRY_POINT+5) != 0xe8 /* CALL */ + || *(unsigned char*)(ENTRY_POINT+10) != 0xeb /* JMP */ + || *(unsigned char*)(ENTRY_POINT+12) != 0xe8) /* CALL */ + return 0; /* ! EMX executable */ /* Fix alignment */ Copy((char*)(ENTRY_POINT+1), &layout, 1, struct layout_table_t*); return !(layout->flags & 2); @@ -4952,25 +4952,25 @@ Perl_OS2_init3(char **env, void **preg, int flags) settmppath(); OS2_Perl_data.xs_init = &Xs_OS2_init; if (perl_sh_installed) { - int l = strlen(perl_sh_installed); + int l = strlen(perl_sh_installed); - Newx(PL_sh_path, l + 1, char); - memcpy(PL_sh_path, perl_sh_installed, l + 1); + Newx(PL_sh_path, l + 1, char); + memcpy(PL_sh_path, perl_sh_installed, l + 1); } else if ( (shell = PerlEnv_getenv("PERL_SH_DRIVE")) ) { - Newx(PL_sh_path, strlen(SH_PATH) + 1, char); - strcpy(PL_sh_path, SH_PATH); - PL_sh_path[0] = shell[0]; + Newx(PL_sh_path, strlen(SH_PATH) + 1, char); + strcpy(PL_sh_path, SH_PATH); + PL_sh_path[0] = shell[0]; } else if ( (shell = PerlEnv_getenv("PERL_SH_DIR")) ) { - int l = strlen(shell), i; - - while (l && (shell[l-1] == '/' || shell[l-1] == '\\')) - l--; - Newx(PL_sh_path, l + 8, char); - strncpy(PL_sh_path, shell, l); - strcpy(PL_sh_path + l, "/sh.exe"); - for (i = 0; i < l; i++) { - if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/'; - } + int l = strlen(shell), i; + + while (l && (shell[l-1] == '/' || shell[l-1] == '\\')) + l--; + Newx(PL_sh_path, l + 8, char); + strncpy(PL_sh_path, shell, l); + strcpy(PL_sh_path + l, "/sh.exe"); + for (i = 0; i < l; i++) { + if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/'; + } } MUTEX_INIT(&start_thread_mutex); MUTEX_INIT(&perlos2_state_mutex); @@ -4984,19 +4984,19 @@ Perl_OS2_init3(char **env, void **preg, int flags) else rc = fill_extLibpath(0, PerlEnv_getenv("PERL_PRE_BEGINLIBPATH"), PerlEnv_getenv("PERL_POST_BEGINLIBPATH"), 0, "PERL_(PRE/POST)_BEGINLIBPATH"); if (!rc) { - s = PerlEnv_getenv("PERL_ENDLIBPATH"); - if (s) - rc = fill_extLibpath(1, s, NULL, 1, "PERL_ENDLIBPATH"); - else - rc = fill_extLibpath(1, PerlEnv_getenv("PERL_PRE_ENDLIBPATH"), PerlEnv_getenv("PERL_POST_ENDLIBPATH"), 0, "PERL_(PRE/POST)_ENDLIBPATH"); + s = PerlEnv_getenv("PERL_ENDLIBPATH"); + if (s) + rc = fill_extLibpath(1, s, NULL, 1, "PERL_ENDLIBPATH"); + else + rc = fill_extLibpath(1, PerlEnv_getenv("PERL_PRE_ENDLIBPATH"), PerlEnv_getenv("PERL_POST_ENDLIBPATH"), 0, "PERL_(PRE/POST)_ENDLIBPATH"); } if (rc) { - char buf[1024]; + char buf[1024]; - snprintf(buf, sizeof buf, "Error setting BEGIN/ENDLIBPATH: %s\n", - os2error(rc)); - DosWrite(2, buf, strlen(buf), &rc); - exit(2); + snprintf(buf, sizeof buf, "Error setting BEGIN/ENDLIBPATH: %s\n", + os2error(rc)); + DosWrite(2, buf, strlen(buf), &rc); + exit(2); } _emxload_env("PERL_EMXLOAD_SECS"); @@ -5011,10 +5011,10 @@ fd_ok(int fd) if (!(_emx_env & 0x200)) return 1; /* not OS/2. */ if (fd >= max_fh) { /* Renew */ - LONG delta = 0; + LONG delta = 0; - if (DosSetRelMaxFH(&delta, &max_fh)) /* Assume it OK??? */ - return 1; + if (DosSetRelMaxFH(&delta, &max_fh)) /* Assume it OK??? */ + return 1; } return fd < max_fh; } @@ -5024,7 +5024,7 @@ int dup2(int from, int to) { if (fd_ok(from < to ? to : from)) - return _dup2(from, to); + return _dup2(from, to); errno = EBADF; return -1; } @@ -5033,7 +5033,7 @@ int dup(int from) { if (fd_ok(from)) - return _dup(from); + return _dup(from); errno = EBADF; return -1; } @@ -5050,9 +5050,9 @@ my_tmpnam (char *str) ENV_LOCK; tpath = tempnam(p, "pltmp"); if (str && tpath) { - strcpy(str, tpath); + strcpy(str, tpath); ENV_UNLOCK; - return str; + return str; } ENV_UNLOCK; return tpath; @@ -5065,10 +5065,10 @@ my_tmpfile () stat(".", &s); if (s.st_mode & S_IWOTH) { - return tmpfile(); + return tmpfile(); } return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but - grants TMP. */ + grants TMP. */ } #undef rmdir @@ -5085,17 +5085,17 @@ my_rmdir (__const__ char *s) int rc; if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */ - if (l >= sizeof b) - Newx(buf, l + 1, char); - strcpy(buf,s); - while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\')) - l--; - buf[l] = 0; - s = buf; + if (l >= sizeof b) + Newx(buf, l + 1, char); + strcpy(buf,s); + while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\')) + l--; + buf[l] = 0; + s = buf; } rc = rmdir(s); if (b != buf) - Safefree(buf); + Safefree(buf); return rc; } @@ -5110,17 +5110,17 @@ my_mkdir (__const__ char *s, long perm) int rc; if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */ - if (l >= sizeof b) - Newx(buf, l + 1, char); - strcpy(buf,s); - while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\')) - l--; - buf[l] = 0; - s = buf; + if (l >= sizeof b) + Newx(buf, l + 1, char); + strcpy(buf,s); + while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\')) + l--; + buf[l] = 0; + s = buf; } rc = mkdir(s, perm); if (b != buf) - Safefree(buf); + Safefree(buf); return rc; } @@ -5141,9 +5141,9 @@ my_flock(int handle, int o) if (use_my_flock == -1) { char *s = PerlEnv_getenv("USE_PERL_FLOCK"); if (s) - use_my_flock = atoi(s); + use_my_flock = atoi(s); else - use_my_flock = 1; + use_my_flock = 1; } MUTEX_UNLOCK(&perlos2_state_mutex); } @@ -5247,9 +5247,9 @@ use_my_pwent(void) if (_my_pwent == -1) { char *s = PerlEnv_getenv("USE_PERL_PWENT"); if (s) - _my_pwent = atoi(s); + _my_pwent = atoi(s); else - _my_pwent = 1; + _my_pwent = 1; } return _my_pwent; } @@ -5318,11 +5318,11 @@ passw_wrap(struct passwd *p) char *s; if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */ - return p; + return p; pw = *p; s = PerlEnv_getenv("PW_PASSWD"); if (!s) - s = (char*)pw_p; /* Make match impossible */ + s = (char*)pw_p; /* Make match impossible */ pw.pw_passwd = s; @@ -5385,51 +5385,51 @@ int fork_with_resources() #endif { /* Reload loaded-on-demand DLLs */ - struct dll_handle_t *dlls = dll_handles; - - while (dlls->modname) { - char dllname[260], fail[260]; - ULONG rc; - - if (!dlls->handle) { /* Was not loaded */ - dlls++; - continue; - } - /* It was loaded in the parent. We need to reload it. */ - - rc = DosQueryModuleName(dlls->handle, sizeof(dllname), dllname); - if (rc) { - Perl_warn_nocontext("Can't find DLL name for the module `%s' by the handle %d, rc=%lu=%#lx", - dlls->modname, (int)dlls->handle, rc, rc); - dlls++; - continue; - } - rc = DosLoadModule(fail, sizeof fail, dllname, &dlls->handle); - if (rc) - Perl_warn_nocontext("Can't load DLL `%s', possible problematic module `%s'", - dllname, fail); - dlls++; - } + struct dll_handle_t *dlls = dll_handles; + + while (dlls->modname) { + char dllname[260], fail[260]; + ULONG rc; + + if (!dlls->handle) { /* Was not loaded */ + dlls++; + continue; + } + /* It was loaded in the parent. We need to reload it. */ + + rc = DosQueryModuleName(dlls->handle, sizeof(dllname), dllname); + if (rc) { + Perl_warn_nocontext("Can't find DLL name for the module `%s' by the handle %d, rc=%lu=%#lx", + dlls->modname, (int)dlls->handle, rc, rc); + dlls++; + continue; + } + rc = DosLoadModule(fail, sizeof fail, dllname, &dlls->handle); + if (rc) + Perl_warn_nocontext("Can't load DLL `%s', possible problematic module `%s'", + dllname, fail); + dlls++; + } } { /* Support message queue etc. */ - os2_mytype = my_type(); - /* Apparently, subprocesses (in particular, fork()) do not - inherit the morphed state, so os2_mytype is the same as - os2_mytype_ini. */ - - if (Perl_os2_initial_mode != -1 - && Perl_os2_initial_mode != os2_mytype) { - /* XXXX ??? */ - } + os2_mytype = my_type(); + /* Apparently, subprocesses (in particular, fork()) do not + inherit the morphed state, so os2_mytype is the same as + os2_mytype_ini. */ + + if (Perl_os2_initial_mode != -1 + && Perl_os2_initial_mode != os2_mytype) { + /* XXXX ??? */ + } } if (Perl_HAB_set) - (void)_obtain_Perl_HAB; + (void)_obtain_Perl_HAB; if (Perl_hmq_refcnt) { - if (my_type() != 3) - my_type_set(3); - Create_HMQ(Perl_hmq_servers != 0, - "Cannot create a message queue on fork"); + if (my_type() != 3) + my_type_set(3); + Create_HMQ(Perl_hmq_servers != 0, + "Cannot create a message queue on fork"); } /* We may have loaded some modules */ @@ -5454,7 +5454,7 @@ myDosGetInfoSeg(PGINFOSEG *pGlobal, PLINFOSEG *pLocal) _THUNK_FLAT (&lSel); _THUNK_CALL (Dos16GetInfoSeg))); if (rc) - return rc; + return rc; *pGlobal = MAKEPGINFOSEG(gSel); *pLocal = MAKEPLINFOSEG(lSel); return rc; diff --git a/os2/os2ish.h b/os2/os2ish.h index e209fb560500..1acc2765c215 100644 --- a/os2/os2ish.h +++ b/os2/os2ish.h @@ -117,68 +117,68 @@ extern int rc; #define MUTEX_INIT(m) \ STMT_START { \ - int rc; \ - if ((rc = _rmutex_create(m,0))) \ - Perl_croak_nocontext("panic: MUTEX_INIT: rc=%i", rc); \ + int rc; \ + if ((rc = _rmutex_create(m,0))) \ + Perl_croak_nocontext("panic: MUTEX_INIT: rc=%i", rc); \ } STMT_END #define MUTEX_LOCK(m) \ STMT_START { \ - int rc; \ - if ((rc = _rmutex_request(m,_FMR_IGNINT))) \ - Perl_croak_nocontext("panic: MUTEX_LOCK: rc=%i", rc); \ + int rc; \ + if ((rc = _rmutex_request(m,_FMR_IGNINT))) \ + Perl_croak_nocontext("panic: MUTEX_LOCK: rc=%i", rc); \ } STMT_END #define MUTEX_UNLOCK(m) \ STMT_START { \ - int rc; \ - if ((rc = _rmutex_release(m))) \ - Perl_croak_nocontext("panic: MUTEX_UNLOCK: rc=%i", rc); \ + int rc; \ + if ((rc = _rmutex_release(m))) \ + Perl_croak_nocontext("panic: MUTEX_UNLOCK: rc=%i", rc); \ } STMT_END #define MUTEX_DESTROY(m) \ STMT_START { \ - int rc; \ - if ((rc = _rmutex_close(m))) \ - Perl_croak_nocontext("panic: MUTEX_DESTROY: rc=%i", rc); \ + int rc; \ + if ((rc = _rmutex_close(m))) \ + Perl_croak_nocontext("panic: MUTEX_DESTROY: rc=%i", rc); \ } STMT_END #define COND_INIT(c) \ STMT_START { \ - int rc; \ - if ((rc = DosCreateEventSem(NULL,c,0,0))) \ - Perl_croak_nocontext("panic: COND_INIT: rc=%i", rc); \ + int rc; \ + if ((rc = DosCreateEventSem(NULL,c,0,0))) \ + Perl_croak_nocontext("panic: COND_INIT: rc=%i", rc); \ } STMT_END #define COND_SIGNAL(c) \ STMT_START { \ - int rc; \ - if ((rc = DosPostEventSem(*(c))) && rc != OS2_ERROR_ALREADY_POSTED)\ - Perl_croak_nocontext("panic: COND_SIGNAL, rc=%ld", rc); \ + int rc; \ + if ((rc = DosPostEventSem(*(c))) && rc != OS2_ERROR_ALREADY_POSTED)\ + Perl_croak_nocontext("panic: COND_SIGNAL, rc=%ld", rc); \ } STMT_END #define COND_BROADCAST(c) \ STMT_START { \ - int rc; \ - if ((rc = DosPostEventSem(*(c))) && rc != OS2_ERROR_ALREADY_POSTED)\ - Perl_croak_nocontext("panic: COND_BROADCAST, rc=%i", rc); \ + int rc; \ + if ((rc = DosPostEventSem(*(c))) && rc != OS2_ERROR_ALREADY_POSTED)\ + Perl_croak_nocontext("panic: COND_BROADCAST, rc=%i", rc); \ } STMT_END /* #define COND_WAIT(c, m) \ STMT_START { \ - if (WaitForSingleObject(*(c),INFINITE) == WAIT_FAILED) \ - Perl_croak_nocontext("panic: COND_WAIT"); \ + if (WaitForSingleObject(*(c),INFINITE) == WAIT_FAILED) \ + Perl_croak_nocontext("panic: COND_WAIT"); \ } STMT_END */ #define COND_WAIT(c, m) os2_cond_wait(c,m) #define COND_WAIT_win32(c, m) \ STMT_START { \ - int rc; \ - if ((rc = SignalObjectAndWait(*(m),*(c),INFINITE,FALSE))) \ - Perl_croak_nocontext("panic: COND_WAIT"); \ - else \ - MUTEX_LOCK(m); \ + int rc; \ + if ((rc = SignalObjectAndWait(*(m),*(c),INFINITE,FALSE))) \ + Perl_croak_nocontext("panic: COND_WAIT"); \ + else \ + MUTEX_LOCK(m); \ } STMT_END #define COND_DESTROY(c) \ STMT_START { \ - int rc; \ - if ((rc = DosCloseEventSem(*(c)))) \ - Perl_croak_nocontext("panic: COND_DESTROY, rc=%i", rc); \ + int rc; \ + if ((rc = DosCloseEventSem(*(c)))) \ + Perl_croak_nocontext("panic: COND_DESTROY, rc=%i", rc); \ } STMT_END /*#define THR ((struct thread *) TlsGetValue(PL_thr_key)) */ @@ -191,10 +191,10 @@ extern int rc; # define pthread_getspecific(k) (*(k)) # define pthread_setspecific(k,v) (*(k)=(v),0) # define pthread_key_create(keyp,flag) \ - ( DosAllocThreadLocalMemory(1,(unsigned long**)keyp) \ - ? Perl_croak_nocontext("LocalMemory"),1 \ - : 0 \ - ) + ( DosAllocThreadLocalMemory(1,(unsigned long**)keyp) \ + ? Perl_croak_nocontext("LocalMemory"),1 \ + : 0 \ + ) #endif /* USE_SLOW_THREAD_SPECIFIC */ #define pthread_key_delete(keyp) #define pthread_self() _gettid() @@ -204,7 +204,7 @@ extern int rc; int pthread_join(pthread_t tid, void **status); int pthread_detach(pthread_t tid); int pthread_create(pthread_t *tid, const pthread_attr_t *attr, - void *(*start_routine)(void*), void *arg); + void *(*start_routine)(void*), void *arg); #endif /* PTHREAD_INCLUDED */ #define THREADS_ELSEWHERE @@ -410,10 +410,10 @@ void *emx_realloc (void *, size_t); /* This guy is needed for quick stdstd */ #if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) - /* Perl uses ungetc only with successful return */ + /* Perl uses ungetc only with successful return */ # define ungetc(c,fp) \ - (FILE_ptr(fp) > FILE_base(fp) && c == (int)*(FILE_ptr(fp) - 1) \ - ? (--FILE_ptr(fp), ++FILE_cnt(fp), (int)c) : ungetc(c,fp)) + (FILE_ptr(fp) > FILE_base(fp) && c == (int)*(FILE_ptr(fp) - 1) \ + ? (--FILE_ptr(fp), ++FILE_cnt(fp), (int)c) : ungetc(c,fp)) #endif #define PERLIO_IS_BINMODE_FD(fd) _PERLIO_IS_BINMODE_FD(fd) @@ -500,8 +500,8 @@ extern OS2_Perl_data_t OS2_Perl_data; #define set_Perl_HAB_f (OS2_Perl_flags |= Perl_HAB_set_f) #define set_Perl_HAB(h) (set_Perl_HAB_f, Perl_hab = h) #define _obtain_Perl_HAB (init_PMWIN_entries(), \ - Perl_hab = (*PMWIN_entries.Initialize)(0), \ - set_Perl_HAB_f, Perl_hab) + Perl_hab = (*PMWIN_entries.Initialize)(0), \ + set_Perl_HAB_f, Perl_hab) #define perl_hab_GET() (Perl_HAB_set ? Perl_hab : _obtain_Perl_HAB) #define Acquire_hab() perl_hab_GET() #define Perl_hmq ((HMQ)OS2_Perl_data.phmq) @@ -524,11 +524,11 @@ struct PMWIN_entries_t { unsigned long (*CreateMsgQueue)(unsigned long hab, long cmsg); int (*DestroyMsgQueue)(unsigned long hmq); int (*PeekMsg)(unsigned long hab, struct _QMSG *pqmsg, - unsigned long hwndFilter, unsigned long msgFilterFirst, - unsigned long msgFilterLast, unsigned long fl); + unsigned long hwndFilter, unsigned long msgFilterFirst, + unsigned long msgFilterLast, unsigned long fl); int (*GetMsg)(unsigned long hab, struct _QMSG *pqmsg, - unsigned long hwndFilter, unsigned long msgFilterFirst, - unsigned long msgFilterLast); + unsigned long hwndFilter, unsigned long msgFilterFirst, + unsigned long msgFilterLast); void * (*DispatchMsg)(unsigned long hab, struct _QMSG *pqmsg); unsigned long (*GetLastError)(unsigned long hab); unsigned long (*CancelShutdown)(unsigned long hmq, unsigned long fCancelAlways); @@ -543,7 +543,7 @@ void init_PMWIN_entries(void); #if _EMX_CRT_REV_ >= 60 # define os2_setsyserrno(rc) (Perl_rc = rc, errno = errno_isOS2_set, \ - _setsyserrno(rc)) + _setsyserrno(rc)) #else # define os2_setsyserrno(rc) (Perl_rc = rc, errno = errno_isOS2) #endif @@ -562,11 +562,11 @@ void init_PMWIN_entries(void); ((expr) ? : (CroakWinError(die,name1 name2), 0)) #define FillOSError(rc) (os2_setsyserrno(rc), \ - Perl_severity = SEVERITY_ERROR) + Perl_severity = SEVERITY_ERROR) #define WinError_2_Perl_rc \ ( init_PMWIN_entries(), \ - Perl_rc=(*PMWIN_entries.GetLastError)(perl_hab_GET()) ) + Perl_rc=(*PMWIN_entries.GetLastError)(perl_hab_GET()) ) /* Calling WinGetLastError() resets the error code of the current thread. Since for some Win* API return value 0 is normal, one needs to call @@ -576,9 +576,9 @@ void init_PMWIN_entries(void); /* At this moment init_PMWIN_entries() should be a nop (WinInitialize should be called already, right?), so we do not risk stepping over our own error */ #define FillWinError ( WinError_2_Perl_rc, \ - Perl_severity = ERRORIDSEV(Perl_rc), \ - Perl_rc = ERRORIDERROR(Perl_rc), \ - os2_setsyserrno(Perl_rc)) + Perl_severity = ERRORIDSEV(Perl_rc), \ + Perl_rc = ERRORIDERROR(Perl_rc), \ + os2_setsyserrno(Perl_rc)) #define STATIC_FILE_LENGTH 127 @@ -726,38 +726,38 @@ enum entries_ordinals { /* This flavor caches the procedure pointer (named as p__Win#name) locally */ #define DeclWinFuncByORD_CACHE(ret,name,o,at,args) \ - DeclWinFuncByORD_CACHE_r(ret,name,o,at,args,0,1) + DeclWinFuncByORD_CACHE_r(ret,name,o,at,args,0,1) /* This flavor may reset the last error before the call (if ret=0 may be OK) */ #define DeclWinFuncByORD_CACHE_resetError(ret,name,o,at,args) \ - DeclWinFuncByORD_CACHE_r(ret,name,o,at,args,1,1) + DeclWinFuncByORD_CACHE_r(ret,name,o,at,args,1,1) /* Two flavors below do the same as above, but do not auto-croak */ /* This flavor caches the procedure pointer (named as p__Win#name) locally */ #define DeclWinFuncByORD_CACHE_survive(ret,name,o,at,args) \ - DeclWinFuncByORD_CACHE_r(ret,name,o,at,args,0,0) + DeclWinFuncByORD_CACHE_r(ret,name,o,at,args,0,0) /* This flavor may reset the last error before the call (if ret=0 may be OK) */ #define DeclWinFuncByORD_CACHE_resetError_survive(ret,name,o,at,args) \ - DeclWinFuncByORD_CACHE_r(ret,name,o,at,args,1,0) + DeclWinFuncByORD_CACHE_r(ret,name,o,at,args,1,0) #define DeclWinFuncByORD_CACHE_r(ret,name,o,at,args,r,die) \ static ret (*CAT2(p__Win,name)) at; \ static ret name at { \ - if (!CAT2(p__Win,name)) \ - AssignFuncPByORD(CAT2(p__Win,name), o); \ - if (r) ResetWinError(); \ - return SaveCroakWinError(CAT2(p__Win,name) args, die, "[Win]", STRINGIFY(name)); } + if (!CAT2(p__Win,name)) \ + AssignFuncPByORD(CAT2(p__Win,name), o); \ + if (r) ResetWinError(); \ + return SaveCroakWinError(CAT2(p__Win,name) args, die, "[Win]", STRINGIFY(name)); } /* These flavors additionally assume ORD is name with prepended ORD_Win */ #define DeclWinFunc_CACHE(ret,name,at,args) \ - DeclWinFuncByORD_CACHE(ret,name,CAT2(ORD_Win,name),at,args) + DeclWinFuncByORD_CACHE(ret,name,CAT2(ORD_Win,name),at,args) #define DeclWinFunc_CACHE_resetError(ret,name,at,args) \ - DeclWinFuncByORD_CACHE_resetError(ret,name,CAT2(ORD_Win,name),at,args) + DeclWinFuncByORD_CACHE_resetError(ret,name,CAT2(ORD_Win,name),at,args) #define DeclWinFunc_CACHE_survive(ret,name,at,args) \ - DeclWinFuncByORD_CACHE_survive(ret,name,CAT2(ORD_Win,name),at,args) + DeclWinFuncByORD_CACHE_survive(ret,name,CAT2(ORD_Win,name),at,args) #define DeclWinFunc_CACHE_resetError_survive(ret,name,at,args) \ - DeclWinFuncByORD_CACHE_resetError_survive(ret,name,CAT2(ORD_Win,name),at,args) + DeclWinFuncByORD_CACHE_resetError_survive(ret,name,CAT2(ORD_Win,name),at,args) void ResetWinError(void); void CroakWinError(int die, char *name); @@ -815,12 +815,12 @@ void croak_with_os2error(char *s) __attribute__((noreturn)); /* propagates rc */ #define os2win_croak(rc,msg) \ - SaveCroakWinError((expr), 1 /* die */, /* no prefix */, (msg)) + SaveCroakWinError((expr), 1 /* die */, /* no prefix */, (msg)) /* propagates rc; use with functions which may return 0 on success */ #define os2win_croak_0OK(rc,msg) \ - SaveCroakWinError((ResetWinError, (expr)), \ - 1 /* die */, /* no prefix */, (msg)) + SaveCroakWinError((ResetWinError, (expr)), \ + 1 /* die */, /* no prefix */, (msg)) #ifdef PERL_CORE int os2_do_spawn(pTHX_ char *cmd); @@ -840,7 +840,7 @@ int os2_do_aspawn(pTHX_ SV *really, SV **vmark, SV **vsp); # define LOG_DEBUG 7 /* debug-level messages */ # define LOG_PRIMASK 0x007 /* mask to extract priority part (internal) */ - /* extract priority */ + /* extract priority */ # define LOG_PRI(p) ((p) & LOG_PRIMASK) # define LOG_MAKEPRI(fac, pri) (((fac) << 3) | (pri)) @@ -855,7 +855,7 @@ int os2_do_aspawn(pTHX_ SV *really, SV **vmark, SV **vsp); # define LOG_NEWS (7<<3) /* network news subsystem */ # define LOG_UUCP (8<<3) /* UUCP subsystem */ # define LOG_CRON (15<<3) /* clock daemon */ - /* other codes through 15 reserved for system use */ + /* other codes through 15 reserved for system use */ # define LOG_LOCAL0 (16<<3) /* reserved for local use */ # define LOG_LOCAL1 (17<<3) /* reserved for local use */ # define LOG_LOCAL2 (18<<3) /* reserved for local use */ @@ -867,7 +867,7 @@ int os2_do_aspawn(pTHX_ SV *really, SV **vmark, SV **vsp); # define LOG_NFACILITIES 24 /* current number of facilities */ # define LOG_FACMASK 0x03f8 /* mask to extract facility part */ - /* facility of pri */ + /* facility of pri */ # define LOG_FAC(p) (((p) & LOG_FACMASK) >> 3) /* @@ -1080,7 +1080,7 @@ unsigned long LIS_pPIB; /* Pointer to PIB */ /* ************************************************************ */ #define Dos32QuerySysState DosQuerySysState #define QuerySysState(flags, pid, buf, bufsz) \ - Dos32QuerySysState(flags, 0, pid, 0, buf, bufsz) + Dos32QuerySysState(flags, 0, pid, 0, buf, bufsz) #define QSS_PROCESS 1 #define QSS_MODULE 4 @@ -1091,156 +1091,156 @@ unsigned long LIS_pPIB; /* Pointer to PIB */ #ifdef _OS2_H APIRET APIENTRY Dos32QuerySysState(ULONG func,ULONG arg1,ULONG pid, - ULONG _res_,PVOID buf,ULONG bufsz); + ULONG _res_,PVOID buf,ULONG bufsz); typedef struct { - ULONG threadcnt; - ULONG proccnt; - ULONG modulecnt; + ULONG threadcnt; + ULONG proccnt; + ULONG modulecnt; } QGLOBAL, *PQGLOBAL; typedef struct { - ULONG rectype; - USHORT threadid; - USHORT slotid; - ULONG sleepid; - ULONG priority; - ULONG systime; - ULONG usertime; - UCHAR state; - UCHAR _reserved1_; /* padding to ULONG */ - USHORT _reserved2_; /* padding to ULONG */ + ULONG rectype; + USHORT threadid; + USHORT slotid; + ULONG sleepid; + ULONG priority; + ULONG systime; + ULONG usertime; + UCHAR state; + UCHAR _reserved1_; /* padding to ULONG */ + USHORT _reserved2_; /* padding to ULONG */ } QTHREAD, *PQTHREAD; typedef struct { - USHORT sfn; - USHORT refcnt; - USHORT flags1; - USHORT flags2; - USHORT accmode1; - USHORT accmode2; - ULONG filesize; - USHORT volhnd; - USHORT attrib; - USHORT _reserved_; + USHORT sfn; + USHORT refcnt; + USHORT flags1; + USHORT flags2; + USHORT accmode1; + USHORT accmode2; + ULONG filesize; + USHORT volhnd; + USHORT attrib; + USHORT _reserved_; } QFDS, *PQFDS; typedef struct qfile { - ULONG rectype; - struct qfile *next; - ULONG opencnt; - PQFDS filedata; - char name[1]; + ULONG rectype; + struct qfile *next; + ULONG opencnt; + PQFDS filedata; + char name[1]; } QFILE, *PQFILE; typedef struct { - ULONG rectype; - PQTHREAD threads; - USHORT pid; - USHORT ppid; - ULONG type; - ULONG state; - ULONG sessid; - USHORT hndmod; - USHORT threadcnt; - ULONG privsem32cnt; - ULONG _reserved2_; - USHORT sem16cnt; - USHORT dllcnt; - USHORT shrmemcnt; - USHORT fdscnt; - PUSHORT sem16s; - PUSHORT dlls; - PUSHORT shrmems; - PUSHORT fds; + ULONG rectype; + PQTHREAD threads; + USHORT pid; + USHORT ppid; + ULONG type; + ULONG state; + ULONG sessid; + USHORT hndmod; + USHORT threadcnt; + ULONG privsem32cnt; + ULONG _reserved2_; + USHORT sem16cnt; + USHORT dllcnt; + USHORT shrmemcnt; + USHORT fdscnt; + PUSHORT sem16s; + PUSHORT dlls; + PUSHORT shrmems; + PUSHORT fds; } QPROCESS, *PQPROCESS; typedef struct sema { - struct sema *next; - USHORT refcnt; - UCHAR sysflags; - UCHAR sysproccnt; - ULONG _reserved1_; - USHORT index; - CHAR name[1]; + struct sema *next; + USHORT refcnt; + UCHAR sysflags; + UCHAR sysproccnt; + ULONG _reserved1_; + USHORT index; + CHAR name[1]; } QSEMA, *PQSEMA; typedef struct { - ULONG rectype; - ULONG _reserved1_; - USHORT _reserved2_; - USHORT syssemidx; - ULONG index; - QSEMA sema; + ULONG rectype; + ULONG _reserved1_; + USHORT _reserved2_; + USHORT syssemidx; + ULONG index; + QSEMA sema; } QSEMSTRUC, *PQSEMSTRUC; typedef struct { - USHORT pid; - USHORT opencnt; + USHORT pid; + USHORT opencnt; } QSEMOWNER32, *PQSEMOWNER32; typedef struct { - PQSEMOWNER32 own; - PCHAR name; - PVOID semrecs; /* array of associated sema's */ - USHORT flags; - USHORT semreccnt; - USHORT waitcnt; - USHORT _reserved_; /* padding to ULONG */ + PQSEMOWNER32 own; + PCHAR name; + PVOID semrecs; /* array of associated sema's */ + USHORT flags; + USHORT semreccnt; + USHORT waitcnt; + USHORT _reserved_; /* padding to ULONG */ } QSEMSMUX32, *PQSEMSMUX32; typedef struct { - PQSEMOWNER32 own; - PCHAR name; - PQSEMSMUX32 mux; - USHORT flags; - USHORT postcnt; + PQSEMOWNER32 own; + PCHAR name; + PQSEMSMUX32 mux; + USHORT flags; + USHORT postcnt; } QSEMEV32, *PQSEMEV32; typedef struct { - PQSEMOWNER32 own; - PCHAR name; - PQSEMSMUX32 mux; - USHORT flags; - USHORT refcnt; - USHORT thrdnum; - USHORT _reserved_; /* padding to ULONG */ + PQSEMOWNER32 own; + PCHAR name; + PQSEMSMUX32 mux; + USHORT flags; + USHORT refcnt; + USHORT thrdnum; + USHORT _reserved_; /* padding to ULONG */ } QSEMMUX32, *PQSEMMUX32; typedef struct semstr32 { - struct semstr *next; - QSEMEV32 evsem; - QSEMMUX32 muxsem; - QSEMSMUX32 smuxsem; + struct semstr *next; + QSEMEV32 evsem; + QSEMMUX32 muxsem; + QSEMSMUX32 smuxsem; } QSEMSTRUC32, *PQSEMSTRUC32; typedef struct shrmem { - struct shrmem *next; - USHORT hndshr; - USHORT selshr; - USHORT refcnt; - CHAR name[1]; + struct shrmem *next; + USHORT hndshr; + USHORT selshr; + USHORT refcnt; + CHAR name[1]; } QSHRMEM, *PQSHRMEM; typedef struct module { - struct module *next; - USHORT hndmod; - USHORT type; - ULONG refcnt; - ULONG segcnt; - PVOID _reserved_; - PCHAR name; - USHORT modref[1]; + struct module *next; + USHORT hndmod; + USHORT type; + ULONG refcnt; + ULONG segcnt; + PVOID _reserved_; + PCHAR name; + USHORT modref[1]; } QMODULE, *PQMODULE; typedef struct { - PQGLOBAL gbldata; - PQPROCESS procdata; - PQSEMSTRUC semadata; - PQSEMSTRUC32 sem32data; - PQSHRMEM shrmemdata; - PQMODULE moddata; - PVOID _reserved2_; - PQFILE filedata; + PQGLOBAL gbldata; + PQPROCESS procdata; + PQSEMSTRUC semadata; + PQSEMSTRUC32 sem32data; + PQSHRMEM shrmemdata; + PQMODULE moddata; + PVOID _reserved2_; + PQFILE filedata; } QTOPLEVEL, *PQTOPLEVEL; /* ************************************************************ */ diff --git a/os2/perlrexx.c b/os2/perlrexx.c index 18d655137d85..8d3237e887da 100644 --- a/os2/perlrexx.c +++ b/os2/perlrexx.c @@ -64,17 +64,17 @@ init_perl(int doparse) char *argv[3] = {"perl_in_REXX", "-e", ""}; if (!perlos2_is_inited) { - perlos2_is_inited = 1; - init_perlos2(); + perlos2_is_inited = 1; + init_perlos2(); } if (my_perl) - return 1; + return 1; if (!PL_do_undump) { - my_perl = perl_alloc(); - if (!my_perl) - return 0; - perl_construct(my_perl); - PL_perl_destruct_level = 1; + my_perl = perl_alloc(); + if (!my_perl) + return 0; + perl_construct(my_perl); + PL_perl_destruct_level = 1; } if (!doparse) return 1; @@ -86,19 +86,19 @@ static char last_error[4096]; static int seterr(char *format, ...) { - va_list va; - char *s = last_error; - - va_start(va, format); - if (s[0]) { - s += strlen(s); - if (s[-1] != '\n') { - snprintf(s, sizeof(last_error) - (s - last_error), "\n"); - s += strlen(s); - } - } - vsnprintf(s, sizeof(last_error) - (s - last_error), format, va); - return 1; + va_list va; + char *s = last_error; + + va_start(va, format); + if (s[0]) { + s += strlen(s); + if (s[-1] != '\n') { + snprintf(s, sizeof(last_error) - (s - last_error), "\n"); + s += strlen(s); + } + } + vsnprintf(s, sizeof(last_error) - (s - last_error), format, va); + return 1; } /* The REXX-callable entrypoints ... */ @@ -112,30 +112,30 @@ ULONG PERL (PCSZ name, LONG rargc, const RXSTRING *rargv, ULONG ret; if (rargc != 1) - return seterr("one argument expected, got %ld", rargc); + return seterr("one argument expected, got %ld", rargc); if (rargv[0].strlength >= sizeof(buf)) - return seterr("length of the argument %ld exceeds the maximum %ld", - rargv[0].strlength, (long)sizeof(buf) - 1); + return seterr("length of the argument %ld exceeds the maximum %ld", + rargv[0].strlength, (long)sizeof(buf) - 1); if (!init_perl(0)) - return 1; + return 1; memcpy(buf, rargv[0].strptr, rargv[0].strlength); buf[rargv[0].strlength] = 0; if (!perl_parse(my_perl, xs_init, 3, argv, (char **)NULL)) - perl_run(my_perl); + perl_run(my_perl); exitstatus = perl_destruct(my_perl); perl_free(my_perl); my_perl = 0; if (exitstatus) - ret = 1; + ret = 1; else { - ret = 0; - sprintf(retstr->strptr, "%s", "ok"); - retstr->strlength = strlen (retstr->strptr); + ret = 0; + sprintf(retstr->strptr, "%s", "ok"); + retstr->strlength = strlen (retstr->strptr); } PERL_SYS_TERM1(0); return ret; @@ -145,7 +145,7 @@ ULONG PERLEXIT (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr) { if (rargc != 0) - return seterr("no arguments expected, got %ld", rargc); + return seterr("no arguments expected, got %ld", rargc); PERL_SYS_TERM1(0); return 0; } @@ -154,9 +154,9 @@ ULONG PERLTERM (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr) { if (rargc != 0) - return seterr("no arguments expected, got %ld", rargc); + return seterr("no arguments expected, got %ld", rargc); if (!my_perl) - return seterr("no perl interpreter present"); + return seterr("no perl interpreter present"); perl_destruct(my_perl); perl_free(my_perl); my_perl = 0; @@ -171,9 +171,9 @@ ULONG PERLINIT (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr) { if (rargc != 0) - return seterr("no argument expected, got %ld", rargc); + return seterr("no argument expected, got %ld", rargc); if (!init_perl(1)) - return 1; + return 1; sprintf(retstr->strptr, "%s", "ok"); retstr->strlength = strlen (retstr->strptr); @@ -186,13 +186,13 @@ PERLLASTERROR (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRX int len = strlen(last_error); if (len <= 256 /* Default buffer is 256-char long */ - || !DosAllocMem((PPVOID)&retstr->strptr, len, - PAG_READ|PAG_WRITE|PAG_COMMIT)) { - memcpy(retstr->strptr, last_error, len); - retstr->strlength = len; + || !DosAllocMem((PPVOID)&retstr->strptr, len, + PAG_READ|PAG_WRITE|PAG_COMMIT)) { + memcpy(retstr->strptr, last_error, len); + retstr->strlength = len; } else { - strcpy(retstr->strptr, "[Not enough memory to copy the errortext]"); - retstr->strlength = strlen(retstr->strptr); + strcpy(retstr->strptr, "[Not enough memory to copy the errortext]"); + retstr->strlength = strlen(retstr->strptr); } return 0; } @@ -206,10 +206,10 @@ PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRIN last_error[0] = 0; if (rargc != 1) - return seterr("one argument expected, got %ld", rargc); + return seterr("one argument expected, got %ld", rargc); if (!init_perl(1)) - return seterr("error initializing perl"); + return seterr("error initializing perl"); { dSP; @@ -227,17 +227,17 @@ PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRIN ret = 0; if (SvTRUE(ERRSV)) - ret = seterr(SvPV(ERRSV, n_a)); + ret = seterr(SvPV(ERRSV, n_a)); if (!SvOK(res)) - ret = seterr("undefined value returned by Perl-in-REXX"); + ret = seterr("undefined value returned by Perl-in-REXX"); str = SvPV(res, len); if (len <= 256 /* Default buffer is 256-char long */ - || !DosAllocMem((PPVOID)&retstr->strptr, len, - PAG_READ|PAG_WRITE|PAG_COMMIT)) { - memcpy(retstr->strptr, str, len); - retstr->strlength = len; + || !DosAllocMem((PPVOID)&retstr->strptr, len, + PAG_READ|PAG_WRITE|PAG_COMMIT)) { + memcpy(retstr->strptr, str, len); + retstr->strlength = len; } else - ret = seterr("Not enough memory for the return string of Perl-in-REXX"); + ret = seterr("Not enough memory for the return string of Perl-in-REXX"); FREETMPS; LEAVE; @@ -255,7 +255,7 @@ PERLEVALSUBCOMMAND( ULONG rc = PERLEVAL(NULL, 1, command, NULL, retstr); if (rc) - *flags = RXSUBCOM_ERROR; /* raise error condition */ + *flags = RXSUBCOM_ERROR; /* raise error condition */ return 0; /* finished */ } @@ -284,7 +284,7 @@ PERLEXPORTALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXS int i = -1; while (++i < ArrLength(funcs) - 1) - RexxRegisterFunctionExe(funcs[i].name, funcs[i].f); + RexxRegisterFunctionExe(funcs[i].name, funcs[i].f); RexxRegisterSubcomExe("EVALPERL", (PFN)&PERLEVALSUBCOMMAND, NULL); retstr->strlength = 0; return 0; @@ -296,7 +296,7 @@ PERLDROPALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTR int i = -1; while (++i < ArrLength(funcs)) - RexxDeregisterFunction(funcs[i].name); + RexxDeregisterFunction(funcs[i].name); RexxDeregisterSubcom("EVALPERL", NULL /* Not a DLL version */); retstr->strlength = 0; return 0; @@ -308,7 +308,7 @@ PERLDROPALLEXIT(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PR int i = -1; while (++i < ArrLength(funcs)) - RexxDeregisterFunction(funcs[i].name); + RexxDeregisterFunction(funcs[i].name); RexxDeregisterSubcom("EVALPERL", NULL /* Not a DLL version */); PERL_SYS_TERM1(0); retstr->strlength = 0; diff --git a/pad.c b/pad.c index 9283e43867b4..543264fc7057 100644 --- a/pad.c +++ b/pad.c @@ -201,19 +201,19 @@ Perl_pad_new(pTHX_ int flags) /* save existing state, ... */ if (flags & padnew_SAVE) { - SAVECOMPPAD(); - if (! (flags & padnew_CLONE)) { - SAVESPTR(PL_comppad_name); + SAVECOMPPAD(); + if (! (flags & padnew_CLONE)) { + SAVESPTR(PL_comppad_name); save_strlen((STRLEN *)&PL_padix); save_strlen((STRLEN *)&PL_constpadix); - save_strlen((STRLEN *)&PL_comppad_name_fill); - save_strlen((STRLEN *)&PL_min_intro_pending); - save_strlen((STRLEN *)&PL_max_intro_pending); - SAVEBOOL(PL_cv_has_eval); - if (flags & padnew_SAVESUB) { - SAVEBOOL(PL_pad_reset_pending); - } - } + save_strlen((STRLEN *)&PL_comppad_name_fill); + save_strlen((STRLEN *)&PL_min_intro_pending); + save_strlen((STRLEN *)&PL_max_intro_pending); + SAVEBOOL(PL_cv_has_eval); + if (flags & padnew_SAVESUB) { + SAVEBOOL(PL_pad_reset_pending); + } + } } /* ... create new pad ... */ @@ -223,16 +223,16 @@ Perl_pad_new(pTHX_ int flags) if (flags & padnew_CLONE) { AV * const a0 = newAV(); /* will be @_ */ - av_store(pad, 0, MUTABLE_SV(a0)); - AvREIFY_only(a0); + av_store(pad, 0, MUTABLE_SV(a0)); + AvREIFY_only(a0); - PadnamelistREFCNT(padname = PL_comppad_name)++; + PadnamelistREFCNT(padname = PL_comppad_name)++; } else { - padlist->xpadl_id = PL_padlist_generation++; - av_store(pad, 0, NULL); - padname = newPADNAMELIST(0); - padnamelist_store(padname, 0, &PL_padname_undef); + padlist->xpadl_id = PL_padlist_generation++; + av_store(pad, 0, NULL); + padname = newPADNAMELIST(0); + padnamelist_store(padname, 0, &PL_padname_undef); } /* Most subroutines never recurse, hence only need 2 entries in the padlist @@ -251,20 +251,20 @@ Perl_pad_new(pTHX_ int flags) PL_curpad = AvARRAY(pad); if (! (flags & padnew_CLONE)) { - PL_comppad_name = padname; - PL_comppad_name_fill = 0; - PL_min_intro_pending = 0; - PL_padix = 0; - PL_constpadix = 0; - PL_cv_has_eval = 0; + PL_comppad_name = padname; + PL_comppad_name_fill = 0; + PL_min_intro_pending = 0; + PL_padix = 0; + PL_constpadix = 0; + PL_cv_has_eval = 0; } DEBUG_X(PerlIO_printf(Perl_debug_log, - "Pad 0x%" UVxf "[0x%" UVxf "] new: compcv=0x%" UVxf - " name=0x%" UVxf " flags=0x%" UVxf "\n", - PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv), - PTR2UV(padname), (UV)flags - ) + "Pad 0x%" UVxf "[0x%" UVxf "] new: compcv=0x%" UVxf + " name=0x%" UVxf " flags=0x%" UVxf "\n", + PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv), + PTR2UV(padname), (UV)flags + ) ); return (PADLIST*)padlist; @@ -302,15 +302,15 @@ Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags) PERL_ARGS_ASSERT_CV_UNDEF_FLAGS; DEBUG_X(PerlIO_printf(Perl_debug_log, - "CV undef: cv=0x%" UVxf " comppad=0x%" UVxf "\n", - PTR2UV(cv), PTR2UV(PL_comppad)) + "CV undef: cv=0x%" UVxf " comppad=0x%" UVxf "\n", + PTR2UV(cv), PTR2UV(PL_comppad)) ); if (CvFILE(&cvbody)) { - char * file = CvFILE(&cvbody); - CvFILE(&cvbody) = NULL; - if(CvDYNFILE(&cvbody)) - Safefree(file); + char * file = CvFILE(&cvbody); + CvFILE(&cvbody) = NULL; + if(CvDYNFILE(&cvbody)) + Safefree(file); } /* CvSLABBED_off(&cvbody); *//* turned off below */ @@ -332,7 +332,7 @@ Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags) CvSTART(&cvbody) = NULL; LEAVE; } - else if (CvSLABBED(&cvbody)) { + else if (CvSLABBED(&cvbody)) { if( CvSTART(&cvbody)) { ENTER; PAD_SAVE_SETNULLPAD(); @@ -351,128 +351,128 @@ Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags) } } else { /* dont bother checking if CvXSUB(cv) is true, less branching */ - CvXSUB(&cvbody) = NULL; + CvXSUB(&cvbody) = NULL; } SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */ sv_unmagic((SV *)cv, PERL_MAGIC_checkcall); if (!(flags & CV_UNDEF_KEEP_NAME)) { - if (CvNAMED(&cvbody)) { - CvNAME_HEK_set(&cvbody, NULL); - CvNAMED_off(&cvbody); - } - else CvGV_set(cv, NULL); + if (CvNAMED(&cvbody)) { + CvNAME_HEK_set(&cvbody, NULL); + CvNAMED_off(&cvbody); + } + else CvGV_set(cv, NULL); } /* This statement and the subsequence if block was pad_undef(). */ pad_peg("pad_undef"); if (!CvISXSUB(&cvbody) && CvPADLIST(&cvbody)) { - PADOFFSET ix; - const PADLIST *padlist = CvPADLIST(&cvbody); - - /* Free the padlist associated with a CV. - If parts of it happen to be current, we null the relevant PL_*pad* - global vars so that we don't have any dangling references left. - We also repoint the CvOUTSIDE of any about-to-be-orphaned inner - subs to the outer of this cv. */ - - DEBUG_X(PerlIO_printf(Perl_debug_log, - "Pad undef: cv=0x%" UVxf " padlist=0x%" UVxf " comppad=0x%" UVxf "\n", - PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad)) - ); - - /* detach any '&' anon children in the pad; if afterwards they - * are still live, fix up their CvOUTSIDEs to point to our outside, - * bypassing us. */ - - if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */ - CV * const outercv = CvOUTSIDE(&cvbody); - const U32 seq = CvOUTSIDE_SEQ(&cvbody); - PADNAMELIST * const comppad_name = PadlistNAMES(padlist); - PADNAME ** const namepad = PadnamelistARRAY(comppad_name); - PAD * const comppad = PadlistARRAY(padlist)[1]; - SV ** const curpad = AvARRAY(comppad); - for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) { - PADNAME * const name = namepad[ix]; - if (name && PadnamePV(name) && *PadnamePV(name) == '&') - { - CV * const innercv = MUTABLE_CV(curpad[ix]); - U32 inner_rc; - assert(innercv); - assert(SvTYPE(innercv) != SVt_PVFM); - inner_rc = SvREFCNT(innercv); - assert(inner_rc); - - if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */ - curpad[ix] = NULL; - SvREFCNT_dec_NN(innercv); - inner_rc--; - } - - /* in use, not just a prototype */ - if (inner_rc && SvTYPE(innercv) == SVt_PVCV - && (CvOUTSIDE(innercv) == cv)) - { - assert(CvWEAKOUTSIDE(innercv)); - /* don't relink to grandfather if he's being freed */ - if (outercv && SvREFCNT(outercv)) { - CvWEAKOUTSIDE_off(innercv); - CvOUTSIDE(innercv) = outercv; - CvOUTSIDE_SEQ(innercv) = seq; - SvREFCNT_inc_simple_void_NN(outercv); - } - else { - CvOUTSIDE(innercv) = NULL; - } - } - } - } - } - - ix = PadlistMAX(padlist); - while (ix > 0) { - PAD * const sv = PadlistARRAY(padlist)[ix--]; - if (sv) { - if (sv == PL_comppad) { - PL_comppad = NULL; - PL_curpad = NULL; - } - SvREFCNT_dec_NN(sv); - } - } - { - PADNAMELIST * const names = PadlistNAMES(padlist); - if (names == PL_comppad_name && PadnamelistREFCNT(names) == 1) - PL_comppad_name = NULL; - PadnamelistREFCNT_dec(names); - } - if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist)); - Safefree(padlist); - CvPADLIST_set(&cvbody, NULL); + PADOFFSET ix; + const PADLIST *padlist = CvPADLIST(&cvbody); + + /* Free the padlist associated with a CV. + If parts of it happen to be current, we null the relevant PL_*pad* + global vars so that we don't have any dangling references left. + We also repoint the CvOUTSIDE of any about-to-be-orphaned inner + subs to the outer of this cv. */ + + DEBUG_X(PerlIO_printf(Perl_debug_log, + "Pad undef: cv=0x%" UVxf " padlist=0x%" UVxf " comppad=0x%" UVxf "\n", + PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad)) + ); + + /* detach any '&' anon children in the pad; if afterwards they + * are still live, fix up their CvOUTSIDEs to point to our outside, + * bypassing us. */ + + if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */ + CV * const outercv = CvOUTSIDE(&cvbody); + const U32 seq = CvOUTSIDE_SEQ(&cvbody); + PADNAMELIST * const comppad_name = PadlistNAMES(padlist); + PADNAME ** const namepad = PadnamelistARRAY(comppad_name); + PAD * const comppad = PadlistARRAY(padlist)[1]; + SV ** const curpad = AvARRAY(comppad); + for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) { + PADNAME * const name = namepad[ix]; + if (name && PadnamePV(name) && *PadnamePV(name) == '&') + { + CV * const innercv = MUTABLE_CV(curpad[ix]); + U32 inner_rc; + assert(innercv); + assert(SvTYPE(innercv) != SVt_PVFM); + inner_rc = SvREFCNT(innercv); + assert(inner_rc); + + if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */ + curpad[ix] = NULL; + SvREFCNT_dec_NN(innercv); + inner_rc--; + } + + /* in use, not just a prototype */ + if (inner_rc && SvTYPE(innercv) == SVt_PVCV + && (CvOUTSIDE(innercv) == cv)) + { + assert(CvWEAKOUTSIDE(innercv)); + /* don't relink to grandfather if he's being freed */ + if (outercv && SvREFCNT(outercv)) { + CvWEAKOUTSIDE_off(innercv); + CvOUTSIDE(innercv) = outercv; + CvOUTSIDE_SEQ(innercv) = seq; + SvREFCNT_inc_simple_void_NN(outercv); + } + else { + CvOUTSIDE(innercv) = NULL; + } + } + } + } + } + + ix = PadlistMAX(padlist); + while (ix > 0) { + PAD * const sv = PadlistARRAY(padlist)[ix--]; + if (sv) { + if (sv == PL_comppad) { + PL_comppad = NULL; + PL_curpad = NULL; + } + SvREFCNT_dec_NN(sv); + } + } + { + PADNAMELIST * const names = PadlistNAMES(padlist); + if (names == PL_comppad_name && PadnamelistREFCNT(names) == 1) + PL_comppad_name = NULL; + PadnamelistREFCNT_dec(names); + } + if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist)); + Safefree(padlist); + CvPADLIST_set(&cvbody, NULL); } else if (CvISXSUB(&cvbody)) - CvHSCXT(&cvbody) = NULL; + CvHSCXT(&cvbody) = NULL; /* else is (!CvISXSUB(&cvbody) && !CvPADLIST(&cvbody)) {do nothing;} */ /* remove CvOUTSIDE unless this is an undef rather than a free */ if (!SvREFCNT(cv)) { - CV * outside = CvOUTSIDE(&cvbody); - if(outside) { - CvOUTSIDE(&cvbody) = NULL; - if (!CvWEAKOUTSIDE(&cvbody)) - SvREFCNT_dec_NN(outside); - } + CV * outside = CvOUTSIDE(&cvbody); + if(outside) { + CvOUTSIDE(&cvbody) = NULL; + if (!CvWEAKOUTSIDE(&cvbody)) + SvREFCNT_dec_NN(outside); + } } if (CvCONST(&cvbody)) { - SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(&cvbody).any_ptr)); - /* CvCONST_off(cv); *//* turned off below */ + SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(&cvbody).any_ptr)); + /* CvCONST_off(cv); *//* turned off below */ } /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the * ref status of CvOUTSIDE and CvGV, and ANON, NAMED and * LEXICAL, which are used to determine the sub's name. */ CvFLAGS(&cvbody) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON|CVf_LEXICAL - |CVf_NAMED); + |CVf_NAMED); } /* @@ -508,11 +508,11 @@ Perl_cv_forget_slab(pTHX_ CV *cv) if (slab) { #ifdef PERL_DEBUG_READONLY_OPS - const size_t refcnt = slab->opslab_refcnt; + const size_t refcnt = slab->opslab_refcnt; #endif - OpslabREFCNT_dec(slab); + OpslabREFCNT_dec(slab); #ifdef PERL_DEBUG_READONLY_OPS - if (refcnt > 1) Slab_to_ro(slab); + if (refcnt > 1) Slab_to_ro(slab); #endif } } @@ -534,7 +534,7 @@ is done. Returns the offset of the allocated pad slot. static PADOFFSET S_pad_alloc_name(pTHX_ PADNAME *name, U32 flags, HV *typestash, - HV *ourstash) + HV *ourstash) { const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY); @@ -543,22 +543,22 @@ S_pad_alloc_name(pTHX_ PADNAME *name, U32 flags, HV *typestash, ASSERT_CURPAD_ACTIVE("pad_alloc_name"); if (typestash) { - SvPAD_TYPED_on(name); - PadnameTYPE(name) = - MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))); + SvPAD_TYPED_on(name); + PadnameTYPE(name) = + MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))); } if (ourstash) { - SvPAD_OUR_on(name); - SvOURSTASH_set(name, ourstash); - SvREFCNT_inc_simple_void_NN(ourstash); + SvPAD_OUR_on(name); + SvOURSTASH_set(name, ourstash); + SvREFCNT_inc_simple_void_NN(ourstash); } else if (flags & padadd_STATE) { - SvPAD_STATE_on(name); + SvPAD_STATE_on(name); } padnamelist_store(PL_comppad_name, offset, name); if (PadnameLEN(name) > 1) - PadnamelistMAXNAMED(PL_comppad_name) = offset; + PadnamelistMAXNAMED(PL_comppad_name) = offset; return offset; } @@ -585,7 +585,7 @@ flags can be OR'ed together: PADOFFSET Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen, - U32 flags, HV *typestash, HV *ourstash) + U32 flags, HV *typestash, HV *ourstash) { PADOFFSET offset; PADNAME *name; @@ -593,18 +593,18 @@ Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen, PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN; if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK)) - Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf, - (UV)flags); + Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf, + (UV)flags); name = newPADNAMEpvn(namepv, namelen); if ((flags & padadd_NO_DUP_CHECK) == 0) { - ENTER; - SAVEFREEPADNAME(name); /* in case of fatal warnings */ - /* check for duplicate declaration */ - pad_check_dup(name, flags & padadd_OUR, ourstash); - PadnameREFCNT(name)++; - LEAVE; + ENTER; + SAVEFREEPADNAME(name); /* in case of fatal warnings */ + /* check for duplicate declaration */ + pad_check_dup(name, flags & padadd_OUR, ourstash); + PadnameREFCNT(name)++; + LEAVE; } offset = pad_alloc_name(name, flags, typestash, ourstash); @@ -614,22 +614,22 @@ Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen, COP_SEQ_RANGE_HIGH_set(name, 0); if (!PL_min_intro_pending) - PL_min_intro_pending = offset; + PL_min_intro_pending = offset; PL_max_intro_pending = offset; /* if it's not a simple scalar, replace with an AV or HV */ assert(SvTYPE(PL_curpad[offset]) == SVt_NULL); assert(SvREFCNT(PL_curpad[offset]) == 1); if (namelen != 0 && *namepv == '@') - sv_upgrade(PL_curpad[offset], SVt_PVAV); + sv_upgrade(PL_curpad[offset], SVt_PVAV); else if (namelen != 0 && *namepv == '%') - sv_upgrade(PL_curpad[offset], SVt_PVHV); + sv_upgrade(PL_curpad[offset], SVt_PVHV); else if (namelen != 0 && *namepv == '&') - sv_upgrade(PL_curpad[offset], SVt_PVCV); + sv_upgrade(PL_curpad[offset], SVt_PVCV); assert(SvPADMY(PL_curpad[offset])); DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad addname: %ld \"%s\" new lex=0x%" UVxf "\n", - (long)offset, PadnamePV(name), - PTR2UV(PL_curpad[offset]))); + "Pad addname: %ld \"%s\" new lex=0x%" UVxf "\n", + (long)offset, PadnamePV(name), + PTR2UV(PL_curpad[offset]))); return offset; } @@ -645,7 +645,7 @@ instead of a string/length pair. PADOFFSET Perl_pad_add_name_pv(pTHX_ const char *name, - const U32 flags, HV *typestash, HV *ourstash) + const U32 flags, HV *typestash, HV *ourstash) { PERL_ARGS_ASSERT_PAD_ADD_NAME_PV; return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash); @@ -706,63 +706,63 @@ Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype) ASSERT_CURPAD_ACTIVE("pad_alloc"); if (AvARRAY(PL_comppad) != PL_curpad) - Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p", - AvARRAY(PL_comppad), PL_curpad); + Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p", + AvARRAY(PL_comppad), PL_curpad); if (PL_pad_reset_pending) - pad_reset(); + pad_reset(); if (tmptype == SVs_PADMY) { /* Not & because this ‘flag’ is 0. */ - /* For a my, simply push a null SV onto the end of PL_comppad. */ - sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE); - retval = (PADOFFSET)AvFILLp(PL_comppad); + /* For a my, simply push a null SV onto the end of PL_comppad. */ + sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE); + retval = (PADOFFSET)AvFILLp(PL_comppad); } else { - /* For a tmp, scan the pad from PL_padix upwards - * for a slot which has no name and no active value. - * For a constant, likewise, but use PL_constpadix. - */ - PADNAME * const * const names = PadnamelistARRAY(PL_comppad_name); - const SSize_t names_fill = PadnamelistMAX(PL_comppad_name); - const bool konst = cBOOL(tmptype & SVf_READONLY); - retval = konst ? PL_constpadix : PL_padix; - for (;;) { - /* - * Entries that close over unavailable variables - * in outer subs contain values not marked PADMY. - * Thus we must skip, not just pad values that are - * marked as current pad values, but also those with names. - * If pad_reset is enabled, ‘current’ means different - * things depending on whether we are allocating a con- - * stant or a target. For a target, things marked PADTMP - * can be reused; not so for constants. - */ - PADNAME *pn; - if (++retval <= names_fill && - (pn = names[retval]) && PadnamePV(pn)) - continue; - sv = *av_fetch(PL_comppad, retval, TRUE); - if (!(SvFLAGS(sv) & + /* For a tmp, scan the pad from PL_padix upwards + * for a slot which has no name and no active value. + * For a constant, likewise, but use PL_constpadix. + */ + PADNAME * const * const names = PadnamelistARRAY(PL_comppad_name); + const SSize_t names_fill = PadnamelistMAX(PL_comppad_name); + const bool konst = cBOOL(tmptype & SVf_READONLY); + retval = konst ? PL_constpadix : PL_padix; + for (;;) { + /* + * Entries that close over unavailable variables + * in outer subs contain values not marked PADMY. + * Thus we must skip, not just pad values that are + * marked as current pad values, but also those with names. + * If pad_reset is enabled, ‘current’ means different + * things depending on whether we are allocating a con- + * stant or a target. For a target, things marked PADTMP + * can be reused; not so for constants. + */ + PADNAME *pn; + if (++retval <= names_fill && + (pn = names[retval]) && PadnamePV(pn)) + continue; + sv = *av_fetch(PL_comppad, retval, TRUE); + if (!(SvFLAGS(sv) & #ifdef USE_PAD_RESET - (konst ? SVs_PADTMP : 0) + (konst ? SVs_PADTMP : 0) #else - SVs_PADTMP + SVs_PADTMP #endif - )) - break; - } - if (konst) { - padnamelist_store(PL_comppad_name, retval, &PL_padname_const); - tmptype &= ~SVf_READONLY; - tmptype |= SVs_PADTMP; - } - *(konst ? &PL_constpadix : &PL_padix) = retval; + )) + break; + } + if (konst) { + padnamelist_store(PL_comppad_name, retval, &PL_padname_const); + tmptype &= ~SVf_READONLY; + tmptype |= SVs_PADTMP; + } + *(konst ? &PL_constpadix : &PL_padix) = retval; } SvFLAGS(sv) |= tmptype; PL_curpad = AvARRAY(PL_comppad); DEBUG_X(PerlIO_printf(Perl_debug_log, - "Pad 0x%" UVxf "[0x%" UVxf "] alloc: %ld for %s\n", - PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval, - PL_op_name[optype])); + "Pad 0x%" UVxf "[0x%" UVxf "] alloc: %ld for %s\n", + PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval, + PL_op_name[optype])); #ifdef DEBUG_LEAKING_SCALARS sv->sv_debug_optype = optype; sv->sv_debug_inpad = 1; @@ -809,9 +809,9 @@ Perl_pad_add_anon(pTHX_ CV* func, I32 optype) /* to avoid ref loops, we never have parent + child referencing each * other simultaneously */ if (CvOUTSIDE(func)) { - assert(!CvWEAKOUTSIDE(func)); - CvWEAKOUTSIDE_on(func); - SvREFCNT_dec_NN(CvOUTSIDE(func)); + assert(!CvWEAKOUTSIDE(func)); + CvWEAKOUTSIDE_on(func); + SvREFCNT_dec_NN(CvOUTSIDE(func)); } return ix; } @@ -862,58 +862,58 @@ S_pad_check_dup(pTHX_ PADNAME *name, U32 flags, const HV *ourstash) assert((flags & ~padadd_OUR) == 0); if (PadnamelistMAX(PL_comppad_name) < 0 || !ckWARN(WARN_SHADOW)) - return; /* nothing to check */ + return; /* nothing to check */ svp = PadnamelistARRAY(PL_comppad_name); top = PadnamelistMAX(PL_comppad_name); /* check the current scope */ for (off = top; off > PL_comppad_name_floor; off--) { - PADNAME * const sv = svp[off]; - if (sv - && PadnameLEN(sv) == PadnameLEN(name) - && !PadnameOUTER(sv) - && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO - || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO) - && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name))) - { - if (is_our && (SvPAD_OUR(sv))) - break; /* "our" masking "our" */ - /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */ - Perl_warner(aTHX_ packWARN(WARN_SHADOW), - "\"%s\" %s %" PNf " masks earlier declaration in same %s", - ( is_our ? "our" : + PADNAME * const sv = svp[off]; + if (sv + && PadnameLEN(sv) == PadnameLEN(name) + && !PadnameOUTER(sv) + && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO + || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO) + && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name))) + { + if (is_our && (SvPAD_OUR(sv))) + break; /* "our" masking "our" */ + /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */ + Perl_warner(aTHX_ packWARN(WARN_SHADOW), + "\"%s\" %s %" PNf " masks earlier declaration in same %s", + ( is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : PL_parser->in_my == KEY_sigvar ? "my" : "state" ), - *PadnamePV(sv) == '&' ? "subroutine" : "variable", - PNfARG(sv), - (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO - ? "scope" : "statement")); - --off; - break; - } + *PadnamePV(sv) == '&' ? "subroutine" : "variable", + PNfARG(sv), + (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO + ? "scope" : "statement")); + --off; + break; + } } /* check the rest of the pad */ if (is_our) { - while (off > 0) { - PADNAME * const sv = svp[off]; - if (sv - && PadnameLEN(sv) == PadnameLEN(name) - && !PadnameOUTER(sv) - && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO - || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO) - && SvOURSTASH(sv) == ourstash - && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name))) - { - Perl_warner(aTHX_ packWARN(WARN_SHADOW), - "\"our\" variable %" PNf " redeclared", PNfARG(sv)); - if (off <= PL_comppad_name_floor) - Perl_warner(aTHX_ packWARN(WARN_SHADOW), - "\t(Did you mean \"local\" instead of \"our\"?)\n"); - break; - } - --off; - } + while (off > 0) { + PADNAME * const sv = svp[off]; + if (sv + && PadnameLEN(sv) == PadnameLEN(name) + && !PadnameOUTER(sv) + && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO + || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO) + && SvOURSTASH(sv) == ourstash + && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name))) + { + Perl_warner(aTHX_ packWARN(WARN_SHADOW), + "\"our\" variable %" PNf " redeclared", PNfARG(sv)); + if (off <= PL_comppad_name_floor) + Perl_warner(aTHX_ packWARN(WARN_SHADOW), + "\t(Did you mean \"local\" instead of \"our\"?)\n"); + break; + } + --off; + } } } @@ -947,8 +947,8 @@ Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags) pad_peg("pad_findmy_pvn"); if (flags) - Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf, - (UV)flags); + Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf, + (UV)flags); /* compilation errors can zero PL_compcv */ if (!PL_compcv) @@ -957,7 +957,7 @@ Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags) offset = pad_findlex(namepv, namelen, flags, PL_compcv, PL_cop_seqmax, 1, NULL, &out_pn, &out_flags); if (offset != NOT_IN_PAD) - return offset; + return offset; /* Skip the ‘our’ hack for subroutines, as the warning does not apply. */ @@ -977,8 +977,8 @@ Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags) && ( PadnamePV(name) == namepv || memEQ(PadnamePV(name), namepv, namelen) ) && COP_SEQ_RANGE_LOW(name) == PERL_PADSEQ_INTRO - ) - return offset; + ) + return offset; } return NOT_IN_PAD; } @@ -1088,16 +1088,16 @@ S_unavailable(pTHX_ PADNAME *name) { /* diag_listed_as: Variable "%s" is not available */ Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), - "%s \"%" PNf "\" is not available", - *PadnamePV(name) == '&' - ? "Subroutine" - : "Variable", - PNfARG(name)); + "%s \"%" PNf "\" is not available", + *PadnamePV(name) == '&' + ? "Subroutine" + : "Variable", + PNfARG(name)); } STATIC PADOFFSET S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq, - int warn, SV** out_capture, PADNAME** out_name, int *out_flags) + int warn, SV** out_capture, PADNAME** out_name, int *out_flags) { PADOFFSET offset, new_offset; SV *new_capture; @@ -1109,226 +1109,226 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, flags &= ~ padadd_STALEOK; /* one-shot flag */ if (flags) - Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf, - (UV)flags); + Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf, + (UV)flags); *out_flags = 0; DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad findlex cv=0x%" UVxf " searching \"%.*s\" seq=%d%s\n", - PTR2UV(cv), (int)namelen, namepv, (int)seq, - out_capture ? " capturing" : "" )); + "Pad findlex cv=0x%" UVxf " searching \"%.*s\" seq=%d%s\n", + PTR2UV(cv), (int)namelen, namepv, (int)seq, + out_capture ? " capturing" : "" )); /* first, search this pad */ if (padlist) { /* not an undef CV */ - PADOFFSET fake_offset = 0; + PADOFFSET fake_offset = 0; const PADNAMELIST * const names = PadlistNAMES(padlist); - PADNAME * const * const name_p = PadnamelistARRAY(names); + PADNAME * const * const name_p = PadnamelistARRAY(names); - for (offset = PadnamelistMAXNAMED(names); offset > 0; offset--) { + for (offset = PadnamelistMAXNAMED(names); offset > 0; offset--) { const PADNAME * const name = name_p[offset]; if (name && PadnameLEN(name) == namelen && ( PadnamePV(name) == namepv || memEQ(PadnamePV(name), namepv, namelen) )) - { - if (PadnameOUTER(name)) { - fake_offset = offset; /* in case we don't find a real one */ - continue; - } - if (PadnameIN_SCOPE(name, seq)) - break; - } - } - - if (offset > 0 || fake_offset > 0 ) { /* a match! */ - if (offset > 0) { /* not fake */ - fake_offset = 0; - *out_name = name_p[offset]; /* return the name */ - - /* set PAD_FAKELEX_MULTI if this lex can have multiple - * instances. For now, we just test !CvUNIQUE(cv), but - * ideally, we should detect my's declared within loops - * etc - this would allow a wider range of 'not stayed - * shared' warnings. We also treated already-compiled - * lexes as not multi as viewed from evals. */ - - *out_flags = CvANON(cv) ? - PAD_FAKELEX_ANON : - (!CvUNIQUE(cv) && ! CvCOMPILED(cv)) - ? PAD_FAKELEX_MULTI : 0; - - DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad findlex cv=0x%" UVxf " matched: offset=%ld (%lu,%lu)\n", - PTR2UV(cv), (long)offset, - (unsigned long)COP_SEQ_RANGE_LOW(*out_name), - (unsigned long)COP_SEQ_RANGE_HIGH(*out_name))); - } - else { /* fake match */ - offset = fake_offset; - *out_name = name_p[offset]; /* return the name */ - *out_flags = PARENT_FAKELEX_FLAGS(*out_name); - DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad findlex cv=0x%" UVxf " matched: offset=%ld flags=0x%lx index=%lu\n", - PTR2UV(cv), (long)offset, (unsigned long)*out_flags, - (unsigned long) PARENT_PAD_INDEX(*out_name) - )); - } - - /* return the lex? */ - - if (out_capture) { - - /* our ? */ - if (PadnameIsOUR(*out_name)) { - *out_capture = NULL; - return offset; - } - - /* trying to capture from an anon prototype? */ - if (CvCOMPILED(cv) - ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv) - : *out_flags & PAD_FAKELEX_ANON) - { - if (warn) - S_unavailable(aTHX_ - *out_name); - - *out_capture = NULL; - } - - /* real value */ - else { - int newwarn = warn; - if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI) - && !PadnameIsSTATE(name_p[offset]) - && warn && ckWARN(WARN_CLOSURE)) { - newwarn = 0; - /* diag_listed_as: Variable "%s" will not stay - shared */ - Perl_warner(aTHX_ packWARN(WARN_CLOSURE), - "%s \"%" UTF8f "\" will not stay shared", - *namepv == '&' ? "Subroutine" : "Variable", - UTF8fARG(1, namelen, namepv)); - } - - if (fake_offset && CvANON(cv) - && CvCLONE(cv) &&!CvCLONED(cv)) - { - PADNAME *n; - /* not yet caught - look further up */ - DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad findlex cv=0x%" UVxf " chasing lex in outer pad\n", - PTR2UV(cv))); - n = *out_name; - (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv), - CvOUTSIDE_SEQ(cv), - newwarn, out_capture, out_name, out_flags); - *out_name = n; - return offset; - } - - *out_capture = AvARRAY(PadlistARRAY(padlist)[ - CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset]; - DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad findlex cv=0x%" UVxf " found lex=0x%" UVxf "\n", - PTR2UV(cv), PTR2UV(*out_capture))); - - if (SvPADSTALE(*out_capture) - && (!CvDEPTH(cv) || !staleok) - && !PadnameIsSTATE(name_p[offset])) - { - S_unavailable(aTHX_ - name_p[offset]); - *out_capture = NULL; - } - } - if (!*out_capture) { - if (namelen != 0 && *namepv == '@') - *out_capture = sv_2mortal(MUTABLE_SV(newAV())); - else if (namelen != 0 && *namepv == '%') - *out_capture = sv_2mortal(MUTABLE_SV(newHV())); - else if (namelen != 0 && *namepv == '&') - *out_capture = sv_2mortal(newSV_type(SVt_PVCV)); - else - *out_capture = sv_newmortal(); - } - } - - return offset; - } + { + if (PadnameOUTER(name)) { + fake_offset = offset; /* in case we don't find a real one */ + continue; + } + if (PadnameIN_SCOPE(name, seq)) + break; + } + } + + if (offset > 0 || fake_offset > 0 ) { /* a match! */ + if (offset > 0) { /* not fake */ + fake_offset = 0; + *out_name = name_p[offset]; /* return the name */ + + /* set PAD_FAKELEX_MULTI if this lex can have multiple + * instances. For now, we just test !CvUNIQUE(cv), but + * ideally, we should detect my's declared within loops + * etc - this would allow a wider range of 'not stayed + * shared' warnings. We also treated already-compiled + * lexes as not multi as viewed from evals. */ + + *out_flags = CvANON(cv) ? + PAD_FAKELEX_ANON : + (!CvUNIQUE(cv) && ! CvCOMPILED(cv)) + ? PAD_FAKELEX_MULTI : 0; + + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad findlex cv=0x%" UVxf " matched: offset=%ld (%lu,%lu)\n", + PTR2UV(cv), (long)offset, + (unsigned long)COP_SEQ_RANGE_LOW(*out_name), + (unsigned long)COP_SEQ_RANGE_HIGH(*out_name))); + } + else { /* fake match */ + offset = fake_offset; + *out_name = name_p[offset]; /* return the name */ + *out_flags = PARENT_FAKELEX_FLAGS(*out_name); + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad findlex cv=0x%" UVxf " matched: offset=%ld flags=0x%lx index=%lu\n", + PTR2UV(cv), (long)offset, (unsigned long)*out_flags, + (unsigned long) PARENT_PAD_INDEX(*out_name) + )); + } + + /* return the lex? */ + + if (out_capture) { + + /* our ? */ + if (PadnameIsOUR(*out_name)) { + *out_capture = NULL; + return offset; + } + + /* trying to capture from an anon prototype? */ + if (CvCOMPILED(cv) + ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv) + : *out_flags & PAD_FAKELEX_ANON) + { + if (warn) + S_unavailable(aTHX_ + *out_name); + + *out_capture = NULL; + } + + /* real value */ + else { + int newwarn = warn; + if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI) + && !PadnameIsSTATE(name_p[offset]) + && warn && ckWARN(WARN_CLOSURE)) { + newwarn = 0; + /* diag_listed_as: Variable "%s" will not stay + shared */ + Perl_warner(aTHX_ packWARN(WARN_CLOSURE), + "%s \"%" UTF8f "\" will not stay shared", + *namepv == '&' ? "Subroutine" : "Variable", + UTF8fARG(1, namelen, namepv)); + } + + if (fake_offset && CvANON(cv) + && CvCLONE(cv) &&!CvCLONED(cv)) + { + PADNAME *n; + /* not yet caught - look further up */ + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad findlex cv=0x%" UVxf " chasing lex in outer pad\n", + PTR2UV(cv))); + n = *out_name; + (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv), + CvOUTSIDE_SEQ(cv), + newwarn, out_capture, out_name, out_flags); + *out_name = n; + return offset; + } + + *out_capture = AvARRAY(PadlistARRAY(padlist)[ + CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset]; + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad findlex cv=0x%" UVxf " found lex=0x%" UVxf "\n", + PTR2UV(cv), PTR2UV(*out_capture))); + + if (SvPADSTALE(*out_capture) + && (!CvDEPTH(cv) || !staleok) + && !PadnameIsSTATE(name_p[offset])) + { + S_unavailable(aTHX_ + name_p[offset]); + *out_capture = NULL; + } + } + if (!*out_capture) { + if (namelen != 0 && *namepv == '@') + *out_capture = sv_2mortal(MUTABLE_SV(newAV())); + else if (namelen != 0 && *namepv == '%') + *out_capture = sv_2mortal(MUTABLE_SV(newHV())); + else if (namelen != 0 && *namepv == '&') + *out_capture = sv_2mortal(newSV_type(SVt_PVCV)); + else + *out_capture = sv_newmortal(); + } + } + + return offset; + } } /* it's not in this pad - try above */ if (!CvOUTSIDE(cv)) - return NOT_IN_PAD; + return NOT_IN_PAD; /* out_capture non-null means caller wants us to capture lex; in * addition we capture ourselves unless it's an ANON/format */ new_capturep = out_capture ? out_capture : - CvLATE(cv) ? NULL : &new_capture; + CvLATE(cv) ? NULL : &new_capture; offset = pad_findlex(namepv, namelen, - flags | padadd_STALEOK*(new_capturep == &new_capture), - CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1, - new_capturep, out_name, out_flags); + flags | padadd_STALEOK*(new_capturep == &new_capture), + CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1, + new_capturep, out_name, out_flags); if (offset == NOT_IN_PAD) - return NOT_IN_PAD; + return NOT_IN_PAD; /* found in an outer CV. Add appropriate fake entry to this pad */ /* don't add new fake entries (via eval) to CVs that we have already * finished compiling, or to undef CVs */ if (CvCOMPILED(cv) || !padlist) - return 0; /* this dummy (and invalid) value isnt used by the caller */ + return 0; /* this dummy (and invalid) value isnt used by the caller */ { - PADNAME *new_name = newPADNAMEouter(*out_name); - PADNAMELIST * const ocomppad_name = PL_comppad_name; - PAD * const ocomppad = PL_comppad; - PL_comppad_name = PadlistNAMES(padlist); - PL_comppad = PadlistARRAY(padlist)[1]; - PL_curpad = AvARRAY(PL_comppad); - - new_offset - = pad_alloc_name(new_name, - PadnameIsSTATE(*out_name) ? padadd_STATE : 0, - PadnameTYPE(*out_name), - PadnameOURSTASH(*out_name) - ); - - DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad addname: %ld \"%.*s\" FAKE\n", - (long)new_offset, - (int) PadnameLEN(new_name), - PadnamePV(new_name))); - PARENT_FAKELEX_FLAGS_set(new_name, *out_flags); - - PARENT_PAD_INDEX_set(new_name, 0); - if (PadnameIsOUR(new_name)) { - NOOP; /* do nothing */ - } - else if (CvLATE(cv)) { - /* delayed creation - just note the offset within parent pad */ - PARENT_PAD_INDEX_set(new_name, offset); - CvCLONE_on(cv); - } - else { - /* immediate creation - capture outer value right now */ - av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep)); - /* But also note the offset, as newMYSUB needs it */ - PARENT_PAD_INDEX_set(new_name, offset); - DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad findlex cv=0x%" UVxf " saved captured sv 0x%" UVxf " at offset %ld\n", - PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset)); - } - *out_name = new_name; - *out_flags = PARENT_FAKELEX_FLAGS(new_name); - - PL_comppad_name = ocomppad_name; - PL_comppad = ocomppad; - PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL; + PADNAME *new_name = newPADNAMEouter(*out_name); + PADNAMELIST * const ocomppad_name = PL_comppad_name; + PAD * const ocomppad = PL_comppad; + PL_comppad_name = PadlistNAMES(padlist); + PL_comppad = PadlistARRAY(padlist)[1]; + PL_curpad = AvARRAY(PL_comppad); + + new_offset + = pad_alloc_name(new_name, + PadnameIsSTATE(*out_name) ? padadd_STATE : 0, + PadnameTYPE(*out_name), + PadnameOURSTASH(*out_name) + ); + + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad addname: %ld \"%.*s\" FAKE\n", + (long)new_offset, + (int) PadnameLEN(new_name), + PadnamePV(new_name))); + PARENT_FAKELEX_FLAGS_set(new_name, *out_flags); + + PARENT_PAD_INDEX_set(new_name, 0); + if (PadnameIsOUR(new_name)) { + NOOP; /* do nothing */ + } + else if (CvLATE(cv)) { + /* delayed creation - just note the offset within parent pad */ + PARENT_PAD_INDEX_set(new_name, offset); + CvCLONE_on(cv); + } + else { + /* immediate creation - capture outer value right now */ + av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep)); + /* But also note the offset, as newMYSUB needs it */ + PARENT_PAD_INDEX_set(new_name, offset); + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad findlex cv=0x%" UVxf " saved captured sv 0x%" UVxf " at offset %ld\n", + PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset)); + } + *out_name = new_name; + *out_flags = PARENT_FAKELEX_FLAGS(new_name); + + PL_comppad_name = ocomppad_name; + PL_comppad = ocomppad; + PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL; } return new_offset; } @@ -1350,10 +1350,10 @@ Perl_pad_sv(pTHX_ PADOFFSET po) ASSERT_CURPAD_ACTIVE("pad_sv"); if (!po) - Perl_croak(aTHX_ "panic: pad_sv po"); + Perl_croak(aTHX_ "panic: pad_sv po"); DEBUG_X(PerlIO_printf(Perl_debug_log, - "Pad 0x%" UVxf "[0x%" UVxf "] sv: %ld sv=0x%" UVxf "\n", - PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po])) + "Pad 0x%" UVxf "[0x%" UVxf "] sv: %ld sv=0x%" UVxf "\n", + PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po])) ); return PL_curpad[po]; } @@ -1375,8 +1375,8 @@ Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv) ASSERT_CURPAD_ACTIVE("pad_setsv"); DEBUG_X(PerlIO_printf(Perl_debug_log, - "Pad 0x%" UVxf "[0x%" UVxf "] setsv: %ld sv=0x%" UVxf "\n", - PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv)) + "Pad 0x%" UVxf "[0x%" UVxf "] setsv: %ld sv=0x%" UVxf "\n", + PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv)) ); PL_curpad[po] = sv; } @@ -1398,9 +1398,9 @@ Perl_pad_block_start(pTHX_ int full) save_strlen((STRLEN *)&PL_comppad_name_floor); PL_comppad_name_floor = PadnamelistMAX(PL_comppad_name); if (full) - PL_comppad_name_fill = PL_comppad_name_floor; + PL_comppad_name_fill = PL_comppad_name_floor; if (PL_comppad_name_floor < 0) - PL_comppad_name_floor = 0; + PL_comppad_name_floor = 0; save_strlen((STRLEN *)&PL_min_intro_pending); save_strlen((STRLEN *)&PL_max_intro_pending); PL_min_intro_pending = 0; @@ -1409,7 +1409,7 @@ Perl_pad_block_start(pTHX_ int full) /* PL_padix_floor is what PL_padix is reset to at the start of each statement, by pad_reset(). We set it when entering a new scope to keep things like this working: - print "$foo$bar", do { this(); that() . "foo" }; + print "$foo$bar", do { this(); that() . "foo" }; We must not let "$foo$bar" and the later concatenation share the same target. */ PL_padix_floor = PL_padix; @@ -1435,36 +1435,36 @@ Perl_intro_my(pTHX) ASSERT_CURPAD_ACTIVE("intro_my"); if (PL_compiling.cop_seq) { - seq = PL_compiling.cop_seq; - PL_compiling.cop_seq = 0; + seq = PL_compiling.cop_seq; + PL_compiling.cop_seq = 0; } else - seq = PL_cop_seqmax; + seq = PL_cop_seqmax; if (! PL_min_intro_pending) - return seq; + return seq; svp = PadnamelistARRAY(PL_comppad_name); for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) { - PADNAME * const sv = svp[i]; - - if (sv && PadnameLEN(sv) && !PadnameOUTER(sv) - && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO) - { - COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */ - COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax); - DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad intromy: %ld \"%s\", (%lu,%lu)\n", - (long)i, PadnamePV(sv), - (unsigned long)COP_SEQ_RANGE_LOW(sv), - (unsigned long)COP_SEQ_RANGE_HIGH(sv)) - ); - } + PADNAME * const sv = svp[i]; + + if (sv && PadnameLEN(sv) && !PadnameOUTER(sv) + && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO) + { + COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */ + COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax); + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad intromy: %ld \"%s\", (%lu,%lu)\n", + (long)i, PadnamePV(sv), + (unsigned long)COP_SEQ_RANGE_LOW(sv), + (unsigned long)COP_SEQ_RANGE_HIGH(sv)) + ); + } } COP_SEQMAX_INC; PL_min_intro_pending = 0; PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */ DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax))); + "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax))); return seq; } @@ -1489,39 +1489,39 @@ Perl_pad_leavemy(pTHX) ASSERT_CURPAD_ACTIVE("pad_leavemy"); if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) { - for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) { - const PADNAME * const name = svp[off]; - if (name && PadnameLEN(name) && !PadnameOUTER(name)) - Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), - "%" PNf " never introduced", - PNfARG(name)); - } + for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) { + const PADNAME * const name = svp[off]; + if (name && PadnameLEN(name) && !PadnameOUTER(name)) + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "%" PNf " never introduced", + PNfARG(name)); + } } /* "Deintroduce" my variables that are leaving with this scope. */ for (off = PadnamelistMAX(PL_comppad_name); - off > PL_comppad_name_fill; off--) { - PADNAME * const sv = svp[off]; - if (sv && PadnameLEN(sv) && !PadnameOUTER(sv) - && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO) - { - COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax); - DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad leavemy: %ld \"%s\", (%lu,%lu)\n", - (long)off, PadnamePV(sv), - (unsigned long)COP_SEQ_RANGE_LOW(sv), - (unsigned long)COP_SEQ_RANGE_HIGH(sv)) - ); - if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv) - && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) { - OP *kid = newOP(OP_INTROCV, 0); - kid->op_targ = off; - o = op_prepend_elem(OP_LINESEQ, kid, o); - } - } + off > PL_comppad_name_fill; off--) { + PADNAME * const sv = svp[off]; + if (sv && PadnameLEN(sv) && !PadnameOUTER(sv) + && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO) + { + COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax); + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad leavemy: %ld \"%s\", (%lu,%lu)\n", + (long)off, PadnamePV(sv), + (unsigned long)COP_SEQ_RANGE_LOW(sv), + (unsigned long)COP_SEQ_RANGE_HIGH(sv)) + ); + if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv) + && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) { + OP *kid = newOP(OP_INTROCV, 0); + kid->op_targ = off; + o = op_prepend_elem(OP_LINESEQ, kid, o); + } + } } COP_SEQMAX_INC; DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax)); + "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax)); return o; } @@ -1539,20 +1539,20 @@ Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust) { ASSERT_CURPAD_LEGAL("pad_swipe"); if (!PL_curpad) - return; + return; if (AvARRAY(PL_comppad) != PL_curpad) - Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p", - AvARRAY(PL_comppad), PL_curpad); + Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p", + AvARRAY(PL_comppad), PL_curpad); if (!po || ((SSize_t)po) > AvFILLp(PL_comppad)) - Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld", - (long)po, (long)AvFILLp(PL_comppad)); + Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld", + (long)po, (long)AvFILLp(PL_comppad)); DEBUG_X(PerlIO_printf(Perl_debug_log, - "Pad 0x%" UVxf "[0x%" UVxf "] swipe: %ld\n", - PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)); + "Pad 0x%" UVxf "[0x%" UVxf "] swipe: %ld\n", + PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)); if (refadjust) - SvREFCNT_dec(PL_curpad[po]); + SvREFCNT_dec(PL_curpad[po]); /* if pad tmps aren't shared between ops, then there's no need to @@ -1565,16 +1565,16 @@ Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust) #endif if (PadnamelistMAX(PL_comppad_name) != -1 && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) { - if (PadnamelistARRAY(PL_comppad_name)[po]) { - assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po])); - } - PadnamelistARRAY(PL_comppad_name)[po] = &PL_padname_undef; + if (PadnamelistARRAY(PL_comppad_name)[po]) { + assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po])); + } + PadnamelistARRAY(PL_comppad_name)[po] = &PL_padname_undef; } /* Use PL_constpadix here, not PL_padix. The latter may have been reset by pad_reset. We don’t want pad_alloc to have to scan the whole pad when allocating a constant. */ if (po < PL_constpadix) - PL_constpadix = po - 1; + PL_constpadix = po - 1; } /* @@ -1595,18 +1595,18 @@ S_pad_reset(pTHX) { #ifdef USE_PAD_RESET if (AvARRAY(PL_comppad) != PL_curpad) - Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p", - AvARRAY(PL_comppad), PL_curpad); + Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p", + AvARRAY(PL_comppad), PL_curpad); DEBUG_X(PerlIO_printf(Perl_debug_log, - "Pad 0x%" UVxf "[0x%" UVxf "] reset: padix %ld -> %ld", - PTR2UV(PL_comppad), PTR2UV(PL_curpad), - (long)PL_padix, (long)PL_padix_floor - ) + "Pad 0x%" UVxf "[0x%" UVxf "] reset: padix %ld -> %ld", + PTR2UV(PL_comppad), PTR2UV(PL_curpad), + (long)PL_padix, (long)PL_padix_floor + ) ); if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */ - PL_padix = PL_padix_floor; + PL_padix = PL_padix_floor; } #endif PL_pad_reset_pending = FALSE; @@ -1652,79 +1652,79 @@ Perl_pad_tidy(pTHX_ padtidy_type type) if (PL_cv_has_eval || PL_perldb) { const CV *cv; - for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) { - if (cv != PL_compcv && CvCOMPILED(cv)) - break; /* no need to mark already-compiled code */ - if (CvANON(cv)) { - DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad clone on cv=0x%" UVxf "\n", PTR2UV(cv))); - CvCLONE_on(cv); - } - CvHASEVAL_on(cv); - } + for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) { + if (cv != PL_compcv && CvCOMPILED(cv)) + break; /* no need to mark already-compiled code */ + if (CvANON(cv)) { + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad clone on cv=0x%" UVxf "\n", PTR2UV(cv))); + CvCLONE_on(cv); + } + CvHASEVAL_on(cv); + } } /* extend namepad to match curpad */ if (PadnamelistMAX(PL_comppad_name) < AvFILLp(PL_comppad)) - padnamelist_store(PL_comppad_name, AvFILLp(PL_comppad), NULL); + padnamelist_store(PL_comppad_name, AvFILLp(PL_comppad), NULL); if (type == padtidy_SUBCLONE) { - PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name); - PADOFFSET ix; - - for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { - PADNAME *namesv; - if (!namep[ix]) namep[ix] = &PL_padname_undef; - - /* - * The only things that a clonable function needs in its - * pad are anonymous subs, constants and GVs. - * The rest are created anew during cloning. - */ - if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])) - continue; - namesv = namep[ix]; - if (!(PadnamePV(namesv) && - (!PadnameLEN(namesv) || *PadnamePV(namesv) == '&'))) - { - SvREFCNT_dec(PL_curpad[ix]); - PL_curpad[ix] = NULL; - } - } + PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name); + PADOFFSET ix; + + for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { + PADNAME *namesv; + if (!namep[ix]) namep[ix] = &PL_padname_undef; + + /* + * The only things that a clonable function needs in its + * pad are anonymous subs, constants and GVs. + * The rest are created anew during cloning. + */ + if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])) + continue; + namesv = namep[ix]; + if (!(PadnamePV(namesv) && + (!PadnameLEN(namesv) || *PadnamePV(namesv) == '&'))) + { + SvREFCNT_dec(PL_curpad[ix]); + PL_curpad[ix] = NULL; + } + } } else if (type == padtidy_SUB) { - AV * const av = newAV(); /* Will be @_ */ - av_store(PL_comppad, 0, MUTABLE_SV(av)); - AvREIFY_only(av); + AV * const av = newAV(); /* Will be @_ */ + av_store(PL_comppad, 0, MUTABLE_SV(av)); + AvREIFY_only(av); } if (type == padtidy_SUB || type == padtidy_FORMAT) { - PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name); - PADOFFSET ix; - for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { - if (!namep[ix]) namep[ix] = &PL_padname_undef; - if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])) - continue; - if (SvPADMY(PL_curpad[ix]) && !PadnameOUTER(namep[ix])) { - /* This is a work around for how the current implementation of - ?{ } blocks in regexps interacts with lexicals. - - One of our lexicals. - Can't do this on all lexicals, otherwise sub baz() won't - compile in - - my $foo; - - sub bar { ++$foo; } - - sub baz { ++$foo; } - - because completion of compiling &bar calling pad_tidy() - would cause (top level) $foo to be marked as stale, and - "no longer available". */ - SvPADSTALE_on(PL_curpad[ix]); - } - } + PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name); + PADOFFSET ix; + for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { + if (!namep[ix]) namep[ix] = &PL_padname_undef; + if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])) + continue; + if (SvPADMY(PL_curpad[ix]) && !PadnameOUTER(namep[ix])) { + /* This is a work around for how the current implementation of + ?{ } blocks in regexps interacts with lexicals. + + One of our lexicals. + Can't do this on all lexicals, otherwise sub baz() won't + compile in + + my $foo; + + sub bar { ++$foo; } + + sub baz { ++$foo; } + + because completion of compiling &bar calling pad_tidy() + would cause (top level) $foo to be marked as stale, and + "no longer available". */ + SvPADSTALE_on(PL_curpad[ix]); + } + } } PL_curpad = AvARRAY(PL_comppad); } @@ -1745,25 +1745,25 @@ Perl_pad_free(pTHX_ PADOFFSET po) #endif ASSERT_CURPAD_LEGAL("pad_free"); if (!PL_curpad) - return; + return; if (AvARRAY(PL_comppad) != PL_curpad) - Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p", - AvARRAY(PL_comppad), PL_curpad); + Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p", + AvARRAY(PL_comppad), PL_curpad); if (!po) - Perl_croak(aTHX_ "panic: pad_free po"); + Perl_croak(aTHX_ "panic: pad_free po"); DEBUG_X(PerlIO_printf(Perl_debug_log, - "Pad 0x%" UVxf "[0x%" UVxf "] free: %ld\n", - PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po) + "Pad 0x%" UVxf "[0x%" UVxf "] free: %ld\n", + PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po) ); #ifndef USE_PAD_RESET sv = PL_curpad[po]; if (sv && sv != &PL_sv_undef && !SvPADMY(sv)) - SvFLAGS(sv) &= ~SVs_PADTMP; + SvFLAGS(sv) &= ~SVs_PADTMP; if (po < PL_padix) - PL_padix = po - 1; + PL_padix = po - 1; #endif } @@ -1787,53 +1787,53 @@ Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full) PERL_ARGS_ASSERT_DO_DUMP_PAD; if (!padlist) { - return; + return; } pad_name = PadlistNAMES(padlist); pad = PadlistARRAY(padlist)[1]; pname = PadnamelistARRAY(pad_name); ppad = AvARRAY(pad); Perl_dump_indent(aTHX_ level, file, - "PADNAME = 0x%" UVxf "(0x%" UVxf ") PAD = 0x%" UVxf "(0x%" UVxf ")\n", - PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad) + "PADNAME = 0x%" UVxf "(0x%" UVxf ") PAD = 0x%" UVxf "(0x%" UVxf ")\n", + PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad) ); for (ix = 1; ix <= PadnamelistMAX(pad_name); ix++) { const PADNAME *namesv = pname[ix]; - if (namesv && !PadnameLEN(namesv)) { - namesv = NULL; - } - if (namesv) { - if (PadnameOUTER(namesv)) - Perl_dump_indent(aTHX_ level+1, file, - "%2d. 0x%" UVxf "<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n", - (int) ix, - PTR2UV(ppad[ix]), - (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0), - PadnamePV(namesv), - (unsigned long)PARENT_FAKELEX_FLAGS(namesv), - (unsigned long)PARENT_PAD_INDEX(namesv) - - ); - else - Perl_dump_indent(aTHX_ level+1, file, - "%2d. 0x%" UVxf "<%lu> (%lu,%lu) \"%s\"\n", - (int) ix, - PTR2UV(ppad[ix]), - (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0), - (unsigned long)COP_SEQ_RANGE_LOW(namesv), - (unsigned long)COP_SEQ_RANGE_HIGH(namesv), - PadnamePV(namesv) - ); - } - else if (full) { - Perl_dump_indent(aTHX_ level+1, file, - "%2d. 0x%" UVxf "<%lu>\n", - (int) ix, - PTR2UV(ppad[ix]), - (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0) - ); - } + if (namesv && !PadnameLEN(namesv)) { + namesv = NULL; + } + if (namesv) { + if (PadnameOUTER(namesv)) + Perl_dump_indent(aTHX_ level+1, file, + "%2d. 0x%" UVxf "<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n", + (int) ix, + PTR2UV(ppad[ix]), + (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0), + PadnamePV(namesv), + (unsigned long)PARENT_FAKELEX_FLAGS(namesv), + (unsigned long)PARENT_PAD_INDEX(namesv) + + ); + else + Perl_dump_indent(aTHX_ level+1, file, + "%2d. 0x%" UVxf "<%lu> (%lu,%lu) \"%s\"\n", + (int) ix, + PTR2UV(ppad[ix]), + (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0), + (unsigned long)COP_SEQ_RANGE_LOW(namesv), + (unsigned long)COP_SEQ_RANGE_HIGH(namesv), + PadnamePV(namesv) + ); + } + else if (full) { + Perl_dump_indent(aTHX_ level+1, file, + "%2d. 0x%" UVxf "<%lu>\n", + (int) ix, + PTR2UV(ppad[ix]), + (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0) + ); + } } } @@ -1856,23 +1856,23 @@ S_cv_dump(pTHX_ const CV *cv, const char *title) PERL_ARGS_ASSERT_CV_DUMP; PerlIO_printf(Perl_debug_log, - " %s: CV=0x%" UVxf " (%s), OUTSIDE=0x%" UVxf " (%s)\n", - title, - PTR2UV(cv), - (CvANON(cv) ? "ANON" - : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT" - : (cv == PL_main_cv) ? "MAIN" - : CvUNIQUE(cv) ? "UNIQUE" - : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"), - PTR2UV(outside), - (!outside ? "null" - : CvANON(outside) ? "ANON" - : (outside == PL_main_cv) ? "MAIN" - : CvUNIQUE(outside) ? "UNIQUE" - : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED")); + " %s: CV=0x%" UVxf " (%s), OUTSIDE=0x%" UVxf " (%s)\n", + title, + PTR2UV(cv), + (CvANON(cv) ? "ANON" + : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT" + : (cv == PL_main_cv) ? "MAIN" + : CvUNIQUE(cv) ? "UNIQUE" + : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"), + PTR2UV(outside), + (!outside ? "null" + : CvANON(outside) ? "ANON" + : (outside == PL_main_cv) ? "MAIN" + : CvUNIQUE(outside) ? "UNIQUE" + : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED")); PerlIO_printf(Perl_debug_log, - " PADLIST = 0x%" UVxf "\n", PTR2UV(padlist)); + " PADLIST = 0x%" UVxf "\n", PTR2UV(padlist)); do_dump_pad(1, Perl_debug_log, padlist, 1); } @@ -1894,7 +1894,7 @@ static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned); static CV * S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned, - bool newcv) + bool newcv) { PADOFFSET ix; PADLIST* const protopadlist = CvPADLIST(proto); @@ -1923,22 +1923,22 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned, if (!outside) { if (CvWEAKOUTSIDE(proto)) - outside = find_runcv(NULL); + outside = find_runcv(NULL); else { - outside = CvOUTSIDE(proto); - if ((CvCLONE(outside) && ! CvCLONED(outside)) - || !CvPADLIST(outside) - || CvPADLIST(outside)->xpadl_id != protopadlist->xpadl_outid) { - outside = find_runcv_where( - FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL - ); - /* outside could be null */ - } + outside = CvOUTSIDE(proto); + if ((CvCLONE(outside) && ! CvCLONED(outside)) + || !CvPADLIST(outside) + || CvPADLIST(outside)->xpadl_id != protopadlist->xpadl_outid) { + outside = find_runcv_where( + FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL + ); + /* outside could be null */ + } } } depth = outside ? CvDEPTH(outside) : 0; if (!depth) - depth = 1; + depth = 1; ENTER; SAVESPTR(PL_compcv); @@ -1946,7 +1946,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned, if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */ if (CvHASEVAL(cv)) - CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside)); + CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside)); SAVESPTR(PL_comppad_name); PL_comppad_name = protopad_name; @@ -1958,226 +1958,226 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned, PL_curpad = AvARRAY(PL_comppad); outpad = outside && CvPADLIST(outside) - ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth]) - : NULL; + ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth]) + : NULL; if (outpad) CvPADLIST(cv)->xpadl_outid = CvPADLIST(outside)->xpadl_id; for (ix = fpad; ix > 0; ix--) { - PADNAME* const namesv = (ix <= fname) ? pname[ix] : NULL; - SV *sv = NULL; - if (namesv && PadnameLEN(namesv)) { /* lexical */ - if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */ - NOOP; - } - else { - if (PadnameOUTER(namesv)) { /* lexical from outside? */ - /* formats may have an inactive, or even undefined, parent; - but state vars are always available. */ - if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)]) - || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv) - && (!outside || !CvDEPTH(outside))) ) { - S_unavailable(aTHX_ namesv); - sv = NULL; - } - else - SvREFCNT_inc_simple_void_NN(sv); - } - if (!sv) { + PADNAME* const namesv = (ix <= fname) ? pname[ix] : NULL; + SV *sv = NULL; + if (namesv && PadnameLEN(namesv)) { /* lexical */ + if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */ + NOOP; + } + else { + if (PadnameOUTER(namesv)) { /* lexical from outside? */ + /* formats may have an inactive, or even undefined, parent; + but state vars are always available. */ + if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)]) + || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv) + && (!outside || !CvDEPTH(outside))) ) { + S_unavailable(aTHX_ namesv); + sv = NULL; + } + else + SvREFCNT_inc_simple_void_NN(sv); + } + if (!sv) { const char sigil = PadnamePV(namesv)[0]; if (sigil == '&') - /* If there are state subs, we need to clone them, too. - But they may need to close over variables we have - not cloned yet. So we will have to do a second - pass. Furthermore, there may be state subs clos- - ing over other state subs’ entries, so we have - to put a stub here and then clone into it on the - second pass. */ - if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) { - assert(SvTYPE(ppad[ix]) == SVt_PVCV); - subclones ++; - if (CvOUTSIDE(ppad[ix]) != proto) - trouble = TRUE; - sv = newSV_type(SVt_PVCV); - CvLEXICAL_on(sv); - } - else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv)) - { - /* my sub */ - /* Just provide a stub, but name it. It will be - upgraded to the real thing on scope entry. */ - U32 hash; - PERL_HASH(hash, PadnamePV(namesv)+1, - PadnameLEN(namesv) - 1); - sv = newSV_type(SVt_PVCV); - CvNAME_HEK_set( - sv, - share_hek(PadnamePV(namesv)+1, - 1 - PadnameLEN(namesv), - hash) - ); - CvLEXICAL_on(sv); - } - else sv = SvREFCNT_inc(ppad[ix]); + /* If there are state subs, we need to clone them, too. + But they may need to close over variables we have + not cloned yet. So we will have to do a second + pass. Furthermore, there may be state subs clos- + ing over other state subs’ entries, so we have + to put a stub here and then clone into it on the + second pass. */ + if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) { + assert(SvTYPE(ppad[ix]) == SVt_PVCV); + subclones ++; + if (CvOUTSIDE(ppad[ix]) != proto) + trouble = TRUE; + sv = newSV_type(SVt_PVCV); + CvLEXICAL_on(sv); + } + else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv)) + { + /* my sub */ + /* Just provide a stub, but name it. It will be + upgraded to the real thing on scope entry. */ + U32 hash; + PERL_HASH(hash, PadnamePV(namesv)+1, + PadnameLEN(namesv) - 1); + sv = newSV_type(SVt_PVCV); + CvNAME_HEK_set( + sv, + share_hek(PadnamePV(namesv)+1, + 1 - PadnameLEN(namesv), + hash) + ); + CvLEXICAL_on(sv); + } + else sv = SvREFCNT_inc(ppad[ix]); else if (sigil == '@') - sv = MUTABLE_SV(newAV()); + sv = MUTABLE_SV(newAV()); else if (sigil == '%') - sv = MUTABLE_SV(newHV()); - else - sv = newSV(0); - /* reset the 'assign only once' flag on each state var */ - if (sigil != '&' && SvPAD_STATE(namesv)) - SvPADSTALE_on(sv); - } - } - } - else if (namesv && PadnamePV(namesv)) { - sv = SvREFCNT_inc_NN(ppad[ix]); - } - else { - sv = newSV(0); - SvPADTMP_on(sv); - } - PL_curpad[ix] = sv; + sv = MUTABLE_SV(newHV()); + else + sv = newSV(0); + /* reset the 'assign only once' flag on each state var */ + if (sigil != '&' && SvPAD_STATE(namesv)) + SvPADSTALE_on(sv); + } + } + } + else if (namesv && PadnamePV(namesv)) { + sv = SvREFCNT_inc_NN(ppad[ix]); + } + else { + sv = newSV(0); + SvPADTMP_on(sv); + } + PL_curpad[ix] = sv; } if (subclones) { - if (trouble || cloned) { - /* Uh-oh, we have trouble! At least one of the state subs here - has its CvOUTSIDE pointer pointing somewhere unexpected. It - could be pointing to another state protosub that we are - about to clone. So we have to track which sub clones come - from which protosubs. If the CvOUTSIDE pointer for a parti- - cular sub points to something we have not cloned yet, we - delay cloning it. We must loop through the pad entries, - until we get a full pass with no cloning. If any uncloned - subs remain (probably nested inside anonymous or ‘my’ subs), - then they get cloned in a final pass. - */ - bool cloned_in_this_pass; - if (!cloned) - cloned = (HV *)sv_2mortal((SV *)newHV()); - do { - cloned_in_this_pass = FALSE; - for (ix = fpad; ix > 0; ix--) { - PADNAME * const name = - (ix <= fname) ? pname[ix] : NULL; - if (name && name != &PL_padname_undef - && !PadnameOUTER(name) && PadnamePV(name)[0] == '&' - && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix])) - { - CV * const protokey = CvOUTSIDE(ppad[ix]); - CV ** const cvp = protokey == proto - ? &cv - : (CV **)hv_fetch(cloned, (char *)&protokey, - sizeof(CV *), 0); - if (cvp && *cvp) { - S_cv_clone(aTHX_ (CV *)ppad[ix], - (CV *)PL_curpad[ix], - *cvp, cloned); - (void)hv_store(cloned, (char *)&ppad[ix], - sizeof(CV *), - SvREFCNT_inc_simple_NN(PL_curpad[ix]), - 0); - subclones--; - cloned_in_this_pass = TRUE; - } - } - } - } while (cloned_in_this_pass); - if (subclones) - for (ix = fpad; ix > 0; ix--) { - PADNAME * const name = - (ix <= fname) ? pname[ix] : NULL; - if (name && name != &PL_padname_undef - && !PadnameOUTER(name) && PadnamePV(name)[0] == '&' - && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix])) - S_cv_clone(aTHX_ (CV *)ppad[ix], - (CV *)PL_curpad[ix], - CvOUTSIDE(ppad[ix]), cloned); - } - } - else for (ix = fpad; ix > 0; ix--) { - PADNAME * const name = (ix <= fname) ? pname[ix] : NULL; - if (name && name != &PL_padname_undef && !PadnameOUTER(name) - && PadnamePV(name)[0] == '&' && PadnameIsSTATE(name)) - S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv, - NULL); - } + if (trouble || cloned) { + /* Uh-oh, we have trouble! At least one of the state subs here + has its CvOUTSIDE pointer pointing somewhere unexpected. It + could be pointing to another state protosub that we are + about to clone. So we have to track which sub clones come + from which protosubs. If the CvOUTSIDE pointer for a parti- + cular sub points to something we have not cloned yet, we + delay cloning it. We must loop through the pad entries, + until we get a full pass with no cloning. If any uncloned + subs remain (probably nested inside anonymous or ‘my’ subs), + then they get cloned in a final pass. + */ + bool cloned_in_this_pass; + if (!cloned) + cloned = (HV *)sv_2mortal((SV *)newHV()); + do { + cloned_in_this_pass = FALSE; + for (ix = fpad; ix > 0; ix--) { + PADNAME * const name = + (ix <= fname) ? pname[ix] : NULL; + if (name && name != &PL_padname_undef + && !PadnameOUTER(name) && PadnamePV(name)[0] == '&' + && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix])) + { + CV * const protokey = CvOUTSIDE(ppad[ix]); + CV ** const cvp = protokey == proto + ? &cv + : (CV **)hv_fetch(cloned, (char *)&protokey, + sizeof(CV *), 0); + if (cvp && *cvp) { + S_cv_clone(aTHX_ (CV *)ppad[ix], + (CV *)PL_curpad[ix], + *cvp, cloned); + (void)hv_store(cloned, (char *)&ppad[ix], + sizeof(CV *), + SvREFCNT_inc_simple_NN(PL_curpad[ix]), + 0); + subclones--; + cloned_in_this_pass = TRUE; + } + } + } + } while (cloned_in_this_pass); + if (subclones) + for (ix = fpad; ix > 0; ix--) { + PADNAME * const name = + (ix <= fname) ? pname[ix] : NULL; + if (name && name != &PL_padname_undef + && !PadnameOUTER(name) && PadnamePV(name)[0] == '&' + && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix])) + S_cv_clone(aTHX_ (CV *)ppad[ix], + (CV *)PL_curpad[ix], + CvOUTSIDE(ppad[ix]), cloned); + } + } + else for (ix = fpad; ix > 0; ix--) { + PADNAME * const name = (ix <= fname) ? pname[ix] : NULL; + if (name && name != &PL_padname_undef && !PadnameOUTER(name) + && PadnamePV(name)[0] == '&' && PadnameIsSTATE(name)) + S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv, + NULL); + } } if (newcv) SvREFCNT_inc_simple_void_NN(cv); LEAVE; if (CvCONST(cv)) { - /* Constant sub () { $x } closing over $x: - * The prototype was marked as a candiate for const-ization, - * so try to grab the current const value, and if successful, - * turn into a const sub: - */ - SV* const_sv; - OP *o = CvSTART(cv); - assert(newcv); - for (; o; o = o->op_next) - if (o->op_type == OP_PADSV) - break; - ASSUME(o->op_type == OP_PADSV); - const_sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); - /* the candidate should have 1 ref from this pad and 1 ref - * from the parent */ - if (const_sv && SvREFCNT(const_sv) == 2) { - const bool was_method = cBOOL(CvMETHOD(cv)); - if (outside) { - PADNAME * const pn = - PadlistNAMESARRAY(CvPADLIST(outside)) - [PARENT_PAD_INDEX(PadlistNAMESARRAY( - CvPADLIST(cv))[o->op_targ])]; - assert(PadnameOUTER(PadlistNAMESARRAY(CvPADLIST(cv)) - [o->op_targ])); - if (PadnameLVALUE(pn)) { - /* We have a lexical that is potentially modifiable - elsewhere, so making a constant will break clo- - sure behaviour. If this is a ‘simple lexical - op tree’, i.e., sub(){$x}, emit a deprecation - warning, but continue to exhibit the old behav- - iour of making it a constant based on the ref- - count of the candidate variable. - - A simple lexical op tree looks like this: - - leavesub - lineseq - nextstate - padsv - */ - if (OpSIBLING( - cUNOPx(cUNOPx(CvROOT(cv))->op_first)->op_first - ) == o - && !OpSIBLING(o)) - { + /* Constant sub () { $x } closing over $x: + * The prototype was marked as a candiate for const-ization, + * so try to grab the current const value, and if successful, + * turn into a const sub: + */ + SV* const_sv; + OP *o = CvSTART(cv); + assert(newcv); + for (; o; o = o->op_next) + if (o->op_type == OP_PADSV) + break; + ASSUME(o->op_type == OP_PADSV); + const_sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); + /* the candidate should have 1 ref from this pad and 1 ref + * from the parent */ + if (const_sv && SvREFCNT(const_sv) == 2) { + const bool was_method = cBOOL(CvMETHOD(cv)); + if (outside) { + PADNAME * const pn = + PadlistNAMESARRAY(CvPADLIST(outside)) + [PARENT_PAD_INDEX(PadlistNAMESARRAY( + CvPADLIST(cv))[o->op_targ])]; + assert(PadnameOUTER(PadlistNAMESARRAY(CvPADLIST(cv)) + [o->op_targ])); + if (PadnameLVALUE(pn)) { + /* We have a lexical that is potentially modifiable + elsewhere, so making a constant will break clo- + sure behaviour. If this is a ‘simple lexical + op tree’, i.e., sub(){$x}, emit a deprecation + warning, but continue to exhibit the old behav- + iour of making it a constant based on the ref- + count of the candidate variable. + + A simple lexical op tree looks like this: + + leavesub + lineseq + nextstate + padsv + */ + if (OpSIBLING( + cUNOPx(cUNOPx(CvROOT(cv))->op_first)->op_first + ) == o + && !OpSIBLING(o)) + { Perl_croak(aTHX_ "Constants from lexical variables potentially modified " "elsewhere are no longer permitted"); - } - else - goto constoff; - } - } + } + else + goto constoff; + } + } SvREFCNT_inc_simple_void_NN(const_sv); - /* If the lexical is not used elsewhere, it is safe to turn on - SvPADTMP, since it is only when it is used in lvalue con- - text that the difference is observable. */ - SvREADONLY_on(const_sv); - SvPADTMP_on(const_sv); - SvREFCNT_dec_NN(cv); - cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv); - if (was_method) - CvMETHOD_on(cv); - } - else { - constoff: - CvCONST_off(cv); - } + /* If the lexical is not used elsewhere, it is safe to turn on + SvPADTMP, since it is only when it is used in lvalue con- + text that the difference is observable. */ + SvREADONLY_on(const_sv); + SvPADTMP_on(const_sv); + SvREFCNT_dec_NN(cv); + cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv); + if (was_method) + CvMETHOD_on(cv); + } + else { + constoff: + CvCONST_off(cv); + } } return cv; @@ -2186,21 +2186,19 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned, static CV * S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned) { -#ifdef USE_ITHREADS -#endif const bool newcv = !cv; assert(!CvUNIQUE(proto)); if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto))); CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC - |CVf_SLABBED); + |CVf_SLABBED); CvCLONED_on(cv); CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto)) - : CvFILE(proto); + : CvFILE(proto); if (CvNAMED(proto)) - CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto))); + CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto))); else CvGV_set(cv,CvGV(proto)); CvSTASH_set(cv, CvSTASH(proto)); OP_REFCNT_LOCK; @@ -2210,21 +2208,21 @@ S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned) CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto); if (SvPOK(proto)) { - sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto)); + sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto)); if (SvUTF8(proto)) SvUTF8_on(MUTABLE_SV(cv)); } if (SvMAGIC(proto)) - mg_copy((SV *)proto, (SV *)cv, 0, 0); + mg_copy((SV *)proto, (SV *)cv, 0, 0); if (CvPADLIST(proto)) - cv = S_cv_clone_pad(aTHX_ proto, cv, outside, cloned, newcv); + cv = S_cv_clone_pad(aTHX_ proto, cv, outside, cloned, newcv); DEBUG_Xv( - PerlIO_printf(Perl_debug_log, "\nPad CV clone\n"); - if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside"); - cv_dump(proto, "Proto"); - cv_dump(cv, "To"); + PerlIO_printf(Perl_debug_log, "\nPad CV clone\n"); + if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside"); + cv_dump(proto, "Proto"); + cv_dump(cv, "To"); ); return cv; @@ -2274,31 +2272,31 @@ Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags) { PERL_ARGS_ASSERT_CV_NAME; if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) { - if (sv) sv_setsv(sv,(SV *)cv); - return sv ? (sv) : (SV *)cv; + if (sv) sv_setsv(sv,(SV *)cv); + return sv ? (sv) : (SV *)cv; } { - SV * const retsv = sv ? (sv) : sv_newmortal(); - if (SvTYPE(cv) == SVt_PVCV) { - if (CvNAMED(cv)) { - if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL) - sv_sethek(retsv, CvNAME_HEK(cv)); - else { - if (CvSTASH(cv) && HvNAME_HEK(CvSTASH(cv))) - sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv))); - else - sv_setpvs(retsv, "__ANON__"); - sv_catpvs(retsv, "::"); - sv_cathek(retsv, CvNAME_HEK(cv)); - } - } - else if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL) - sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv)))); - else gv_efullname3(retsv, CvGV(cv), NULL); - } - else if (flags & CV_NAME_NOTQUAL) sv_sethek(retsv, GvNAME_HEK(cv)); - else gv_efullname3(retsv,(GV *)cv,NULL); - return retsv; + SV * const retsv = sv ? (sv) : sv_newmortal(); + if (SvTYPE(cv) == SVt_PVCV) { + if (CvNAMED(cv)) { + if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL) + sv_sethek(retsv, CvNAME_HEK(cv)); + else { + if (CvSTASH(cv) && HvNAME_HEK(CvSTASH(cv))) + sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv))); + else + sv_setpvs(retsv, "__ANON__"); + sv_catpvs(retsv, "::"); + sv_cathek(retsv, CvNAME_HEK(cv)); + } + } + else if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL) + sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv)))); + else gv_efullname3(retsv, CvGV(cv), NULL); + } + else if (flags & CV_NAME_NOTQUAL) sv_sethek(retsv, GvNAME_HEK(cv)); + else gv_efullname3(retsv,(GV *)cv,NULL); + return retsv; } } @@ -2326,51 +2324,51 @@ Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv) for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) { const PADNAME *name = namepad[ix]; - if (name && name != &PL_padname_undef && !PadnameIsOUR(name) - && *PadnamePV(name) == '&') - { - CV *innercv = MUTABLE_CV(curpad[ix]); - if (UNLIKELY(PadnameOUTER(name))) { - CV *cv = new_cv; - PADNAME **names = namepad; - PADOFFSET i = ix; - while (PadnameOUTER(name)) { - assert(SvTYPE(cv) == SVt_PVCV); - cv = CvOUTSIDE(cv); - names = PadlistNAMESARRAY(CvPADLIST(cv)); - i = PARENT_PAD_INDEX(name); - name = names[i]; - } - innercv = (CV *)PadARRAY(PadlistARRAY(CvPADLIST(cv))[1])[i]; - } - if (SvTYPE(innercv) == SVt_PVCV) { - /* XXX 0afba48f added code here to check for a proto CV - attached to the pad entry by magic. But shortly there- - after 81df9f6f95 moved the magic to the pad name. The - code here was never updated, so it wasn’t doing anything - and got deleted when PADNAME became a distinct type. Is - there any bug as a result? */ - if (CvOUTSIDE(innercv) == old_cv) { - if (!CvWEAKOUTSIDE(innercv)) { - SvREFCNT_dec(old_cv); - SvREFCNT_inc_simple_void_NN(new_cv); - } - CvOUTSIDE(innercv) = new_cv; - } - } - else { /* format reference */ - SV * const rv = curpad[ix]; - CV *innercv; - if (!SvOK(rv)) continue; - assert(SvROK(rv)); - assert(SvWEAKREF(rv)); - innercv = (CV *)SvRV(rv); - assert(!CvWEAKOUTSIDE(innercv)); - assert(CvOUTSIDE(innercv) == old_cv); - SvREFCNT_dec(CvOUTSIDE(innercv)); - CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv); - } - } + if (name && name != &PL_padname_undef && !PadnameIsOUR(name) + && *PadnamePV(name) == '&') + { + CV *innercv = MUTABLE_CV(curpad[ix]); + if (UNLIKELY(PadnameOUTER(name))) { + CV *cv = new_cv; + PADNAME **names = namepad; + PADOFFSET i = ix; + while (PadnameOUTER(name)) { + assert(SvTYPE(cv) == SVt_PVCV); + cv = CvOUTSIDE(cv); + names = PadlistNAMESARRAY(CvPADLIST(cv)); + i = PARENT_PAD_INDEX(name); + name = names[i]; + } + innercv = (CV *)PadARRAY(PadlistARRAY(CvPADLIST(cv))[1])[i]; + } + if (SvTYPE(innercv) == SVt_PVCV) { + /* XXX 0afba48f added code here to check for a proto CV + attached to the pad entry by magic. But shortly there- + after 81df9f6f95 moved the magic to the pad name. The + code here was never updated, so it wasn’t doing anything + and got deleted when PADNAME became a distinct type. Is + there any bug as a result? */ + if (CvOUTSIDE(innercv) == old_cv) { + if (!CvWEAKOUTSIDE(innercv)) { + SvREFCNT_dec(old_cv); + SvREFCNT_inc_simple_void_NN(new_cv); + } + CvOUTSIDE(innercv) = new_cv; + } + } + else { /* format reference */ + SV * const rv = curpad[ix]; + CV *innercv; + if (!SvOK(rv)) continue; + assert(SvROK(rv)); + assert(SvWEAKREF(rv)); + innercv = (CV *)SvRV(rv); + assert(!CvWEAKOUTSIDE(innercv)); + assert(CvOUTSIDE(innercv) == old_cv); + SvREFCNT_dec(CvOUTSIDE(innercv)); + CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv); + } + } } } @@ -2390,50 +2388,50 @@ Perl_pad_push(pTHX_ PADLIST *padlist, int depth) PERL_ARGS_ASSERT_PAD_PUSH; if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) { - PAD** const svp = PadlistARRAY(padlist); - AV* const newpad = newAV(); - SV** const oldpad = AvARRAY(svp[depth-1]); - PADOFFSET ix = AvFILLp((const AV *)svp[1]); - const PADOFFSET names_fill = PadnamelistMAX((PADNAMELIST *)svp[0]); - PADNAME ** const names = PadnamelistARRAY((PADNAMELIST *)svp[0]); - AV *av; - - for ( ;ix > 0; ix--) { - if (names_fill >= ix && PadnameLEN(names[ix])) { - const char sigil = PadnamePV(names[ix])[0]; - if (PadnameOUTER(names[ix]) - || PadnameIsSTATE(names[ix]) - || sigil == '&') - { - /* outer lexical or anon code */ - av_store(newpad, ix, SvREFCNT_inc(oldpad[ix])); - } - else { /* our own lexical */ - SV *sv; - if (sigil == '@') - sv = MUTABLE_SV(newAV()); - else if (sigil == '%') - sv = MUTABLE_SV(newHV()); - else - sv = newSV(0); - av_store(newpad, ix, sv); - } - } - else if (PadnamePV(names[ix])) { - av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix])); - } - else { - /* save temporaries on recursion? */ - SV * const sv = newSV(0); - av_store(newpad, ix, sv); - SvPADTMP_on(sv); - } - } - av = newAV(); - av_store(newpad, 0, MUTABLE_SV(av)); - AvREIFY_only(av); - - padlist_store(padlist, depth, newpad); + PAD** const svp = PadlistARRAY(padlist); + AV* const newpad = newAV(); + SV** const oldpad = AvARRAY(svp[depth-1]); + PADOFFSET ix = AvFILLp((const AV *)svp[1]); + const PADOFFSET names_fill = PadnamelistMAX((PADNAMELIST *)svp[0]); + PADNAME ** const names = PadnamelistARRAY((PADNAMELIST *)svp[0]); + AV *av; + + for ( ;ix > 0; ix--) { + if (names_fill >= ix && PadnameLEN(names[ix])) { + const char sigil = PadnamePV(names[ix])[0]; + if (PadnameOUTER(names[ix]) + || PadnameIsSTATE(names[ix]) + || sigil == '&') + { + /* outer lexical or anon code */ + av_store(newpad, ix, SvREFCNT_inc(oldpad[ix])); + } + else { /* our own lexical */ + SV *sv; + if (sigil == '@') + sv = MUTABLE_SV(newAV()); + else if (sigil == '%') + sv = MUTABLE_SV(newHV()); + else + sv = newSV(0); + av_store(newpad, ix, sv); + } + } + else if (PadnamePV(names[ix])) { + av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix])); + } + else { + /* save temporaries on recursion? */ + SV * const sv = newSV(0); + av_store(newpad, ix, sv); + SvPADTMP_on(sv); + } + } + av = newAV(); + av_store(newpad, 0, MUTABLE_SV(av)); + AvREIFY_only(av); + + padlist_store(padlist, depth, newpad); } } @@ -2469,89 +2467,89 @@ Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param) Newx(PadlistARRAY(dstpad), max + 1, PAD *); PadlistARRAY(dstpad)[0] = (PAD *) - padnamelist_dup(PadlistNAMES(srcpad), param); + padnamelist_dup(PadlistNAMES(srcpad), param); PadnamelistREFCNT(PadlistNAMES(dstpad))++; if (cloneall) { - PADOFFSET depth; - for (depth = 1; depth <= max; ++depth) - PadlistARRAY(dstpad)[depth] = - av_dup_inc(PadlistARRAY(srcpad)[depth], param); + PADOFFSET depth; + for (depth = 1; depth <= max; ++depth) + PadlistARRAY(dstpad)[depth] = + av_dup_inc(PadlistARRAY(srcpad)[depth], param); } else { - /* CvDEPTH() on our subroutine will be set to 0, so there's no need - to build anything other than the first level of pads. */ - PADOFFSET ix = AvFILLp(PadlistARRAY(srcpad)[1]); - AV *pad1; - const PADOFFSET names_fill = PadnamelistMAX(PadlistNAMES(srcpad)); - const PAD *const srcpad1 = PadlistARRAY(srcpad)[1]; - SV **oldpad = AvARRAY(srcpad1); - PADNAME ** const names = PadnamelistARRAY(PadlistNAMES(dstpad)); - SV **pad1a; - AV *args; - - pad1 = newAV(); - - av_extend(pad1, ix); - PadlistARRAY(dstpad)[1] = pad1; - pad1a = AvARRAY(pad1); - - if (ix > -1) { - AvFILLp(pad1) = ix; - - for ( ;ix > 0; ix--) { - if (!oldpad[ix]) { - pad1a[ix] = NULL; - } else if (names_fill >= ix && names[ix] && - PadnameLEN(names[ix])) { - const char sigil = PadnamePV(names[ix])[0]; - if (PadnameOUTER(names[ix]) - || PadnameIsSTATE(names[ix]) - || sigil == '&') - { - /* outer lexical or anon code */ - pad1a[ix] = sv_dup_inc(oldpad[ix], param); - } - else { /* our own lexical */ - if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) { - /* This is a work around for how the current - implementation of ?{ } blocks in regexps - interacts with lexicals. */ - pad1a[ix] = sv_dup_inc(oldpad[ix], param); - } else { - SV *sv; - - if (sigil == '@') - sv = MUTABLE_SV(newAV()); - else if (sigil == '%') - sv = MUTABLE_SV(newHV()); - else - sv = newSV(0); - pad1a[ix] = sv; - } - } - } - else if (( names_fill >= ix && names[ix] - && PadnamePV(names[ix]) )) { - pad1a[ix] = sv_dup_inc(oldpad[ix], param); - } - else { - /* save temporaries on recursion? */ - SV * const sv = newSV(0); - pad1a[ix] = sv; - - /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs - FIXTHAT before merging this branch. - (And I know how to) */ - if (SvPADTMP(oldpad[ix])) - SvPADTMP_on(sv); - } - } - - if (oldpad[0]) { - args = newAV(); /* Will be @_ */ - AvREIFY_only(args); - pad1a[0] = (SV *)args; - } - } + /* CvDEPTH() on our subroutine will be set to 0, so there's no need + to build anything other than the first level of pads. */ + PADOFFSET ix = AvFILLp(PadlistARRAY(srcpad)[1]); + AV *pad1; + const PADOFFSET names_fill = PadnamelistMAX(PadlistNAMES(srcpad)); + const PAD *const srcpad1 = PadlistARRAY(srcpad)[1]; + SV **oldpad = AvARRAY(srcpad1); + PADNAME ** const names = PadnamelistARRAY(PadlistNAMES(dstpad)); + SV **pad1a; + AV *args; + + pad1 = newAV(); + + av_extend(pad1, ix); + PadlistARRAY(dstpad)[1] = pad1; + pad1a = AvARRAY(pad1); + + if (ix > -1) { + AvFILLp(pad1) = ix; + + for ( ;ix > 0; ix--) { + if (!oldpad[ix]) { + pad1a[ix] = NULL; + } else if (names_fill >= ix && names[ix] && + PadnameLEN(names[ix])) { + const char sigil = PadnamePV(names[ix])[0]; + if (PadnameOUTER(names[ix]) + || PadnameIsSTATE(names[ix]) + || sigil == '&') + { + /* outer lexical or anon code */ + pad1a[ix] = sv_dup_inc(oldpad[ix], param); + } + else { /* our own lexical */ + if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) { + /* This is a work around for how the current + implementation of ?{ } blocks in regexps + interacts with lexicals. */ + pad1a[ix] = sv_dup_inc(oldpad[ix], param); + } else { + SV *sv; + + if (sigil == '@') + sv = MUTABLE_SV(newAV()); + else if (sigil == '%') + sv = MUTABLE_SV(newHV()); + else + sv = newSV(0); + pad1a[ix] = sv; + } + } + } + else if (( names_fill >= ix && names[ix] + && PadnamePV(names[ix]) )) { + pad1a[ix] = sv_dup_inc(oldpad[ix], param); + } + else { + /* save temporaries on recursion? */ + SV * const sv = newSV(0); + pad1a[ix] = sv; + + /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs + FIXTHAT before merging this branch. + (And I know how to) */ + if (SvPADTMP(oldpad[ix])) + SvPADTMP_on(sv); + } + } + + if (oldpad[0]) { + args = newAV(); /* Will be @_ */ + AvREIFY_only(args); + pad1a[0] = (SV *)args; + } + } } return dstpad; @@ -2570,11 +2568,11 @@ Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val) assert(key >= 0); if (key > PadlistMAX(padlist)) { - av_extend_guts(NULL,key,&PadlistMAX(padlist), - (SV ***)&PadlistARRAY(padlist), - (SV ***)&PadlistARRAY(padlist)); - Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax, - PAD *); + av_extend_guts(NULL,key,&PadlistMAX(padlist), + (SV ***)&PadlistARRAY(padlist), + (SV ***)&PadlistARRAY(padlist)); + Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax, + PAD *); } ary = PadlistARRAY(padlist); SvREFCNT_dec(ary[key]); @@ -2623,17 +2621,17 @@ Perl_padnamelist_store(pTHX_ PADNAMELIST *pnl, SSize_t key, PADNAME *val) assert(key >= 0); if (key > pnl->xpadnl_max) - av_extend_guts(NULL,key,&pnl->xpadnl_max, - (SV ***)&PadnamelistARRAY(pnl), - (SV ***)&PadnamelistARRAY(pnl)); + av_extend_guts(NULL,key,&pnl->xpadnl_max, + (SV ***)&PadnamelistARRAY(pnl), + (SV ***)&PadnamelistARRAY(pnl)); if (PadnamelistMAX(pnl) < key) { - Zero(PadnamelistARRAY(pnl)+PadnamelistMAX(pnl)+1, - key-PadnamelistMAX(pnl), PADNAME *); - PadnamelistMAX(pnl) = key; + Zero(PadnamelistARRAY(pnl)+PadnamelistMAX(pnl)+1, + key-PadnamelistMAX(pnl), PADNAME *); + PadnamelistMAX(pnl) = key; } ary = PadnamelistARRAY(pnl); if (ary[key]) - PadnameREFCNT_dec(ary[key]); + PadnameREFCNT_dec(ary[key]); ary[key] = val; return &ary[key]; } @@ -2660,15 +2658,15 @@ Perl_padnamelist_free(pTHX_ PADNAMELIST *pnl) { PERL_ARGS_ASSERT_PADNAMELIST_FREE; if (!--PadnamelistREFCNT(pnl)) { - while(PadnamelistMAX(pnl) >= 0) - { - PADNAME * const pn = - PadnamelistARRAY(pnl)[PadnamelistMAX(pnl)--]; - if (pn) - PadnameREFCNT_dec(pn); - } - Safefree(PadnamelistARRAY(pnl)); - Safefree(pnl); + while(PadnamelistMAX(pnl) >= 0) + { + PADNAME * const pn = + PadnamelistARRAY(pnl)[PadnamelistMAX(pnl)--]; + if (pn) + PadnameREFCNT_dec(pn); + } + Safefree(PadnamelistARRAY(pnl)); + Safefree(pnl); } } @@ -2693,7 +2691,7 @@ Perl_padnamelist_dup(pTHX_ PADNAMELIST *srcpad, CLONE_PARAMS *param) /* look for it in the table first */ dstpad = (PADNAMELIST *)ptr_table_fetch(PL_ptr_table, srcpad); if (dstpad) - return dstpad; + return dstpad; dstpad = newPADNAMELIST(max); PadnamelistREFCNT(dstpad) = 0; /* The caller will increment it. */ @@ -2703,9 +2701,9 @@ Perl_padnamelist_dup(pTHX_ PADNAMELIST *srcpad, CLONE_PARAMS *param) ptr_table_store(PL_ptr_table, srcpad, dstpad); for (; max >= 0; max--) if (PadnamelistARRAY(srcpad)[max]) { - PadnamelistARRAY(dstpad)[max] = - padname_dup(PadnamelistARRAY(srcpad)[max], param); - PadnameREFCNT(PadnamelistARRAY(dstpad)[max])++; + PadnamelistARRAY(dstpad)[max] = + padname_dup(PadnamelistARRAY(srcpad)[max], param); + PadnameREFCNT(PadnamelistARRAY(dstpad)[max])++; } return dstpad; @@ -2731,8 +2729,8 @@ Perl_newPADNAMEpvn(const char *s, STRLEN len) PADNAME *pn; PERL_ARGS_ASSERT_NEWPADNAMEPVN; Newxz(alloc2, - STRUCT_OFFSET(struct padname_with_str, xpadn_str[0]) + len + 1, - char); + STRUCT_OFFSET(struct padname_with_str, xpadn_str[0]) + len + 1, + char); alloc = (struct padname_with_str *)alloc2; pn = (PADNAME *)alloc; PadnameREFCNT(pn) = 1; @@ -2777,15 +2775,15 @@ Perl_padname_free(pTHX_ PADNAME *pn) { PERL_ARGS_ASSERT_PADNAME_FREE; if (!--PadnameREFCNT(pn)) { - if (UNLIKELY(pn == &PL_padname_undef || pn == &PL_padname_const)) { - PadnameREFCNT(pn) = SvREFCNT_IMMORTAL; - return; - } - SvREFCNT_dec(PadnameTYPE(pn)); /* Takes care of protocv, too. */ - SvREFCNT_dec(PadnameOURSTASH(pn)); - if (PadnameOUTER(pn)) - PadnameREFCNT_dec(PADNAME_FROM_PV(PadnamePV(pn))); - Safefree(pn); + if (UNLIKELY(pn == &PL_padname_undef || pn == &PL_padname_const)) { + PadnameREFCNT(pn) = SvREFCNT_IMMORTAL; + return; + } + SvREFCNT_dec(PadnameTYPE(pn)); /* Takes care of protocv, too. */ + SvREFCNT_dec(PadnameOURSTASH(pn)); + if (PadnameOUTER(pn)) + PadnameREFCNT_dec(PADNAME_FROM_PV(PadnamePV(pn))); + Safefree(pn); } } @@ -2809,12 +2807,12 @@ Perl_padname_dup(pTHX_ PADNAME *src, CLONE_PARAMS *param) /* look for it in the table first */ dst = (PADNAME *)ptr_table_fetch(PL_ptr_table, src); if (dst) - return dst; + return dst; if (!PadnamePV(src)) { - dst = &PL_padname_undef; - ptr_table_store(PL_ptr_table, src, dst); - return dst; + dst = &PL_padname_undef; + ptr_table_store(PL_ptr_table, src, dst); + return dst; } dst = PadnameOUTER(src) @@ -2826,7 +2824,7 @@ Perl_padname_dup(pTHX_ PADNAME *src, CLONE_PARAMS *param) PadnameREFCNT(dst) = 0; /* The caller will increment it. */ PadnameTYPE (dst) = (HV *)sv_dup_inc((SV *)PadnameTYPE(src), param); PadnameOURSTASH(dst) = (HV *)sv_dup_inc((SV *)PadnameOURSTASH(src), - param); + param); dst->xpadn_low = src->xpadn_low; dst->xpadn_high = src->xpadn_high; dst->xpadn_gen = src->xpadn_gen; diff --git a/pad.h b/pad.h index 6636ca79a0c1..07c4d8686330 100644 --- a/pad.h +++ b/pad.h @@ -23,13 +23,13 @@ typedef SSize_t PADOFFSET; /* signed so that -1 is a valid value */ struct padlist { SSize_t xpadl_max; /* max index for which array has space */ union { - PAD ** xpadlarr_alloc; /* Pointer to beginning of array of AVs. - index 0 is a padnamelist * */ - struct { - PADNAMELIST * padnl; - PAD * pad_1; /* this slice of PAD * array always alloced */ - PAD * pad_2; /* maybe unalloced */ - } * xpadlarr_dbg; /* for use with a C debugger only */ + PAD ** xpadlarr_alloc; /* Pointer to beginning of array of AVs. + index 0 is a padnamelist * */ + struct { + PADNAMELIST * padnl; + PAD * pad_1; /* this slice of PAD * array always alloced */ + PAD * pad_2; /* maybe unalloced */ + } * xpadlarr_dbg; /* for use with a C debugger only */ } xpadl_arr; U32 xpadl_id; /* Semi-unique ID, shared between clones */ U32 xpadl_outid; /* ID of outer pad */ @@ -58,8 +58,8 @@ struct padnamelist { char * xpadn_pv; \ HV * xpadn_ourstash; \ union { \ - HV * xpadn_typestash; \ - CV * xpadn_protocv; \ + HV * xpadn_typestash; \ + CV * xpadn_protocv; \ } xpadn_type_u; \ U32 xpadn_low; \ U32 xpadn_high; \ @@ -92,8 +92,8 @@ struct padname_with_str { */ #define PERL_PADSEQ_INTRO U32_MAX #define COP_SEQMAX_INC \ - (PL_cop_seqmax++, \ - (void)(PL_cop_seqmax == PERL_PADSEQ_INTRO && PL_cop_seqmax++)) + (PL_cop_seqmax++, \ + (void)(PL_cop_seqmax == PERL_PADSEQ_INTRO && PL_cop_seqmax++)) /* B.xs needs these for the benefit of B::Deparse */ @@ -119,9 +119,9 @@ struct padname_with_str { /* values for the pad_tidy() function */ typedef enum { - padtidy_SUB, /* tidy up a pad for a sub, */ - padtidy_SUBCLONE, /* a cloned sub, */ - padtidy_FORMAT /* or a format */ + padtidy_SUB, /* tidy up a pad for a sub, */ + padtidy_SUBCLONE, /* a cloned sub, */ + padtidy_FORMAT /* or a format */ } padtidy_type; /* flags for pad_add_name_pvn. */ @@ -130,7 +130,7 @@ typedef enum { #define padadd_STATE 0x02 /* state declaration. */ #define padadd_NO_DUP_CHECK 0x04 /* skip warning on dups. */ #define padadd_STALEOK 0x08 /* allow stale lexical in active - * sub, but only one level up */ + * sub, but only one level up */ /* ASSERT_CURPAD_LEGAL and ASSERT_CURPAD_ACTIVE respectively determine * whether PL_comppad and PL_curpad are consistent and whether they have @@ -142,15 +142,15 @@ typedef enum { # define ASSERT_CURPAD_LEGAL(label) \ pad_peg(label); \ if (PL_comppad ? (AvARRAY(PL_comppad) != PL_curpad) : (PL_curpad != 0)) \ - Perl_croak(aTHX_ "panic: illegal pad in %s: 0x%" UVxf "[0x%" UVxf "]",\ - label, PTR2UV(PL_comppad), PTR2UV(PL_curpad)); + Perl_croak(aTHX_ "panic: illegal pad in %s: 0x%" UVxf "[0x%" UVxf "]",\ + label, PTR2UV(PL_comppad), PTR2UV(PL_curpad)); # define ASSERT_CURPAD_ACTIVE(label) \ pad_peg(label); \ if (!PL_comppad || (AvARRAY(PL_comppad) != PL_curpad)) \ - Perl_croak(aTHX_ "panic: invalid pad in %s: 0x%" UVxf "[0x%" UVxf "]",\ - label, PTR2UV(PL_comppad), PTR2UV(PL_curpad)); + Perl_croak(aTHX_ "panic: invalid pad in %s: 0x%" UVxf "[0x%" UVxf "]",\ + label, PTR2UV(PL_comppad), PTR2UV(PL_curpad)); #else # define ASSERT_CURPAD_LEGAL(label) # define ASSERT_CURPAD_ACTIVE(label) @@ -313,7 +313,7 @@ Restore the old pad saved into the local variable C by C #define PadnameLEN(pn) (pn)->xpadn_len #define PadnameUTF8(pn) 1 #define PadnameSV(pn) \ - newSVpvn_flags(PadnamePV(pn), PadnameLEN(pn), SVs_TEMP|SVf_UTF8) + newSVpvn_flags(PadnamePV(pn), PadnameLEN(pn), SVs_TEMP|SVf_UTF8) #define PadnameFLAGS(pn) (pn)->xpadn_flags #define PadnameIsOUR(pn) (!!(pn)->xpadn_ourstash) #define PadnameOURSTASH(pn) (pn)->xpadn_ourstash @@ -360,43 +360,43 @@ Restore the old pad saved into the local variable C by C #define PAD_SVl(po) (PL_curpad[po]) #define PAD_BASE_SV(padlist, po) \ - (PadlistARRAY(padlist)[1]) \ - ? AvARRAY(MUTABLE_AV((PadlistARRAY(padlist)[1])))[po] \ - : NULL; + (PadlistARRAY(padlist)[1]) \ + ? AvARRAY(MUTABLE_AV((PadlistARRAY(padlist)[1])))[po] \ + : NULL; #define PAD_SET_CUR_NOSAVE(padlist,nth) \ - PL_comppad = (PAD*) (PadlistARRAY(padlist)[nth]); \ - PL_curpad = AvARRAY(PL_comppad); \ - DEBUG_Xv(PerlIO_printf(Perl_debug_log, \ - "Pad 0x%" UVxf "[0x%" UVxf "] set_cur depth=%d\n", \ - PTR2UV(PL_comppad), PTR2UV(PL_curpad), (int)(nth))); + PL_comppad = (PAD*) (PadlistARRAY(padlist)[nth]); \ + PL_curpad = AvARRAY(PL_comppad); \ + DEBUG_Xv(PerlIO_printf(Perl_debug_log, \ + "Pad 0x%" UVxf "[0x%" UVxf "] set_cur depth=%d\n", \ + PTR2UV(PL_comppad), PTR2UV(PL_curpad), (int)(nth))); #define PAD_SET_CUR(padlist,nth) \ - SAVECOMPPAD(); \ - PAD_SET_CUR_NOSAVE(padlist,nth); + SAVECOMPPAD(); \ + PAD_SET_CUR_NOSAVE(padlist,nth); #define PAD_SAVE_SETNULLPAD() SAVECOMPPAD(); \ - PL_comppad = NULL; PL_curpad = NULL; \ - DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad set_null\n")); + PL_comppad = NULL; PL_curpad = NULL; \ + DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad set_null\n")); #define PAD_SAVE_LOCAL(opad,npad) \ - opad = PL_comppad; \ - PL_comppad = (npad); \ - PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : NULL; \ - DEBUG_Xv(PerlIO_printf(Perl_debug_log, \ - "Pad 0x%" UVxf "[0x%" UVxf "] save_local\n", \ - PTR2UV(PL_comppad), PTR2UV(PL_curpad))); + opad = PL_comppad; \ + PL_comppad = (npad); \ + PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : NULL; \ + DEBUG_Xv(PerlIO_printf(Perl_debug_log, \ + "Pad 0x%" UVxf "[0x%" UVxf "] save_local\n", \ + PTR2UV(PL_comppad), PTR2UV(PL_curpad))); #define PAD_RESTORE_LOCAL(opad) \ assert(!opad || !SvIS_FREED(opad)); \ - PL_comppad = opad; \ - PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : NULL; \ - DEBUG_Xv(PerlIO_printf(Perl_debug_log, \ - "Pad 0x%" UVxf "[0x%" UVxf "] restore_local\n", \ - PTR2UV(PL_comppad), PTR2UV(PL_curpad))); + PL_comppad = opad; \ + PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : NULL; \ + DEBUG_Xv(PerlIO_printf(Perl_debug_log, \ + "Pad 0x%" UVxf "[0x%" UVxf "] restore_local\n", \ + PTR2UV(PL_comppad), PTR2UV(PL_curpad))); /* @@ -479,7 +479,7 @@ Clone the state variables associated with running and compiling pads. PL_comppad = av_dup(proto_perl->Icomppad, param); \ PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : NULL; \ PL_comppad_name = \ - padnamelist_dup(proto_perl->Icomppad_name, param); \ + padnamelist_dup(proto_perl->Icomppad_name, param); \ PL_comppad_name_fill = proto_perl->Icomppad_name_fill; \ PL_comppad_name_floor = proto_perl->Icomppad_name_floor; \ PL_min_intro_pending = proto_perl->Imin_intro_pending; \ diff --git a/parser.h b/parser.h index abffd25c424b..d5bc3c86165f 100644 --- a/parser.h +++ b/parser.h @@ -56,7 +56,7 @@ typedef struct yy_parser { char *lex_casestack; /* what kind of case mods in effect */ U8 lex_defer; /* state after determined token */ U8 lex_dojoin; /* doing an array interpolation - 1 = @{...} 2 = ->@ */ + 1 = @{...} 2 = ->@ */ U8 expect; /* how to interpret ambiguous tokens */ bool preambled; bool sub_no_recover; /* can't recover from a sublex error */ @@ -81,8 +81,8 @@ typedef struct yy_parser { LEXSHARED *lex_shared; SV *linestr; /* current chunk of src text */ char *bufptr; /* carries the cursor (current parsing - position) from one invocation of yylex - to the next */ + position) from one invocation of yylex + to the next */ char *oldbufptr; /* in yylex, beginning of current token */ char *oldoldbufptr; /* in yylex, beginning of previous token */ char *bufend; @@ -137,8 +137,8 @@ typedef struct yy_parser { # define LEX_START_COPIED 0x00000008 # define LEX_DONT_CLOSE_RSFP 0x00000010 # define LEX_START_FLAGS \ - (LEX_START_SAME_FILTER|LEX_START_COPIED \ - |LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES|LEX_DONT_CLOSE_RSFP) + (LEX_START_SAME_FILTER|LEX_START_COPIED \ + |LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES|LEX_DONT_CLOSE_RSFP) #endif /* flags for parser API */ diff --git a/patchlevel.h b/patchlevel.h index 69b9ef536490..973071099bd3 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -39,7 +39,7 @@ Instead use one of the version comparison macros. See C>. #define PERL_REVISION 5 /* age */ #define PERL_VERSION 33 /* epoch */ -#define PERL_SUBVERSION 4 /* generation */ +#define PERL_SUBVERSION 7 /* generation */ /* The following numbers describe the earliest compatible version of Perl ("compatibility" here being defined as sufficient binary/API @@ -60,7 +60,7 @@ Instead use one of the version comparison macros. See C>. */ #define PERL_API_REVISION 5 #define PERL_API_VERSION 33 -#define PERL_API_SUBVERSION 4 +#define PERL_API_SUBVERSION 7 /* XXX Note: The selection of non-default Configure options, such as -Duselonglong may invalidate these settings. Currently, Configure @@ -71,42 +71,42 @@ Instead use one of the version comparison macros. See C>. #endif /* - local_patches -- list of locally applied less-than-subversion patches. - If you're distributing such a patch, please give it a name and a - one-line description, placed just before the last NULL in the array - below. If your patch fixes a bug in the perlbug database, please - mention the bugid. If your patch *IS* dependent on a prior patch, - please place your applied patch line after its dependencies. This - will help tracking of patch dependencies. - - Please either use 'diff --unified=0' if your diff supports - that or edit the hunk of the diff output which adds your patch - to this list, to remove context lines which would give patch - problems. For instance, if the original context diff is - - *** patchlevel.h.orig - --- patchlevel.h - *** 38,43 *** - --- 38,44 --- - ,"FOO1235 - some patch" - ,"BAR3141 - another patch" - ,"BAZ2718 - and another patch" - + ,"MINE001 - my new patch" - ,NULL - }; - - please change it to - *** patchlevel.h.orig - --- patchlevel.h - *** 41,43 *** - --- 41,44 --- - + ,"MINE001 - my new patch" - ,NULL - }; - - (Note changes to line numbers as well as removal of context lines.) - This will prevent patch from choking if someone has previously - applied different patches than you. + local_patches -- list of locally applied less-than-subversion patches. + If you're distributing such a patch, please give it a name and a + one-line description, placed just before the last NULL in the array + below. If your patch fixes a bug in the perlbug database, please + mention the bugid. If your patch *IS* dependent on a prior patch, + please place your applied patch line after its dependencies. This + will help tracking of patch dependencies. + + Please either use 'diff --unified=0' if your diff supports + that or edit the hunk of the diff output which adds your patch + to this list, to remove context lines which would give patch + problems. For instance, if the original context diff is + + *** patchlevel.h.orig + --- patchlevel.h + *** 38,43 *** + --- 38,44 --- + ,"FOO1235 - some patch" + ,"BAR3141 - another patch" + ,"BAZ2718 - and another patch" + + ,"MINE001 - my new patch" + ,NULL + }; + + please change it to + *** patchlevel.h.orig + --- patchlevel.h + *** 41,43 *** + --- 41,44 --- + + ,"MINE001 - my new patch" + ,NULL + }; + + (Note changes to line numbers as well as removal of context lines.) + This will prevent patch from choking if someone has previously + applied different patches than you. History has shown that nobody distributes patches that also modify patchlevel.h. Do it yourself. The following perl @@ -120,8 +120,8 @@ my $seen=0; while () { if (/\t,NULL/ and $seen) { while (my $c = shift @ARGV){ - $c =~ s|\\|\\\\|g; - $c =~ s|"|\\"|g; + $c =~ s|\\|\\\\|g; + $c =~ s|"|\\"|g; print PLOUT qq{\t,"$c"\n}; } } @@ -156,19 +156,19 @@ hunk. #include "git_version.h" # endif static const char * const local_patches[] = { - NULL + NULL #ifdef PERL_GIT_UNCOMMITTED_CHANGES - ,"uncommitted-changes" + ,"uncommitted-changes" #endif - PERL_GIT_UNPUSHED_COMMITS /* do not remove this line */ - ,NULL + PERL_GIT_UNPUSHED_COMMITS /* do not remove this line */ + ,NULL }; /* Initial space prevents this variable from being inserted in config.sh */ # define LOCAL_PATCH_COUNT \ - ((int)(C_ARRAY_LENGTH(local_patches)-2)) + ((int)(C_ARRAY_LENGTH(local_patches)-2)) /* the old terms of reference, add them only when explicitly included */ #define PATCHLEVEL PERL_VERSION diff --git a/perl.c b/perl.c index 488cebcb5b9f..48ae9a3a04fd 100644 --- a/perl.c +++ b/perl.c @@ -3,7 +3,8 @@ * * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 * 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 - * 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 by Larry Wall and others + * 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 by Larry Wall + * and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -2831,17 +2832,24 @@ Perl_get_hv(pTHX_ const char *name, I32 flags) /* =for apidoc_section $CV -=for apidoc get_cvn_flags +=for apidoc get_cv +=for apidoc_item |CV *|get_cvs|"string"|I32 flags +=for apidoc_item get_cvn_flags -Returns the CV of the specified Perl subroutine. C are passed to +These return the CV of the specified Perl subroutine. C are passed to C. If C is set and the Perl subroutine does not exist then it will be declared (which has the same effect as saying -C). If C is not set and the subroutine does not exist +C). If C is not set and the subroutine does not exist, then NULL is returned. -=for apidoc get_cv +The forms differ only in how the subroutine is specified.. With C, +the name is a literal C string, enclosed in double quotes. With C, the +name is given by the C parameter, which must be a NUL-terminated C +string. With C, the name is also given by the C +parameter, but it is a Perl string (possibly containing embedded NUL bytes), +and its length in bytes is contained in the C parameter. -Uses C to get the length of C, then calls C. +=for apidoc Amnh||GV_ADD =cut */ @@ -3308,34 +3316,34 @@ S_usage(pTHX) /* XXX move this out into a module ? */ /* Grouped as 6 lines per C string literal, to keep under the ANSI C 89 minimum of 509 character string literals. */ static const char * const usage_msg[] = { -" -0[octal] specify record separator (\\0, if no argument)\n" -" -a autosplit mode with -n or -p (splits $_ into @F)\n" -" -C[number/list] enables the listed Unicode features\n" -" -c check syntax only (runs BEGIN and CHECK blocks)\n" -" -d[:debugger] run program under debugger\n" -" -D[number/list] set debugging flags (argument is a bit mask or alphabets)\n", -" -e program one line of program (several -e's allowed, omit programfile)\n" -" -E program like -e, but enables all optional features\n" -" -f don't do $sitelib/sitecustomize.pl at startup\n" -" -F/pattern/ split() pattern for -a switch (//'s are optional)\n" -" -i[extension] edit <> files in place (makes backup if extension supplied)\n" -" -Idirectory specify @INC/#include directory (several -I's allowed)\n", -" -l[octal] enable line ending processing, specifies line terminator\n" -" -[mM][-]module execute \"use/no module...\" before executing program\n" -" -n assume \"while (<>) { ... }\" loop around program\n" -" -p assume loop like -n but print line also, like sed\n" -" -s enable rudimentary parsing for switches after programfile\n" -" -S look for programfile using PATH environment variable\n", -" -t enable tainting warnings\n" -" -T enable tainting checks\n" -" -u dump core after parsing program\n" -" -U allow unsafe operations\n" -" -v print version, patchlevel and license\n" -" -V[:variable] print configuration summary (or a single Config.pm variable)\n", -" -w enable many useful warnings\n" -" -W enable all warnings\n" -" -x[directory] ignore text before #!perl line (optionally cd to directory)\n" -" -X disable all warnings\n" +" -0[octal/hexadecimal] specify record separator (\\0, if no argument)\n" +" -a autosplit mode with -n or -p (splits $_ into @F)\n" +" -C[number/list] enables the listed Unicode features\n" +" -c check syntax only (runs BEGIN and CHECK blocks)\n" +" -d[t][:MOD] run program under debugger or module Devel::MOD\n" +" -D[number/letters] set debugging flags (argument is a bit mask or alphabets)\n", +" -e commandline one line of program (several -e's allowed, omit programfile)\n" +" -E commandline like -e, but enables all optional features\n" +" -f don't do $sitelib/sitecustomize.pl at startup\n" +" -F/pattern/ split() pattern for -a switch (//'s are optional)\n" +" -i[extension] edit <> files in place (makes backup if extension supplied)\n" +" -Idirectory specify @INC/#include directory (several -I's allowed)\n", +" -l[octnum] enable line ending processing, specifies line terminator\n" +" -[mM][-]module execute \"use/no module...\" before executing program\n" +" -n assume \"while (<>) { ... }\" loop around program\n" +" -p assume loop like -n but print line also, like sed\n" +" -s enable rudimentary parsing for switches after programfile\n" +" -S look for programfile using PATH environment variable\n", +" -t enable tainting warnings\n" +" -T enable tainting checks\n" +" -u dump core after parsing program\n" +" -U allow unsafe operations\n" +" -v print version, patchlevel and license\n" +" -V[:configvar] print configuration summary (or a single Config.pm variable)\n", +" -w enable many useful warnings\n" +" -W enable all warnings\n" +" -x[directory] ignore text before #!perl line (optionally cd to directory)\n" +" -X disable all warnings\n" " \n" "Run 'perldoc perl' for more help with Perl.\n\n", NULL @@ -3812,7 +3820,7 @@ S_minus_v(pTHX) #endif PerlIO_printf(PIO_stdout, - "\n\nCopyright 1987-2020, Larry Wall\n"); + "\n\nCopyright 1987-2021, Larry Wall\n"); #ifdef MSDOS PerlIO_printf(PIO_stdout, "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); @@ -4536,8 +4544,6 @@ Perl_init_argv_symbols(pTHX_ int argc, char **argv) STATIC void S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env) { -#ifdef USE_ITHREADS -#endif GV* tmpgv; PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS; diff --git a/perl.h b/perl.h index 2358a7075b8f..93cc6b91cb39 100644 --- a/perl.h +++ b/perl.h @@ -31,11 +31,11 @@ /* this is used for functions which take a depth trailing * argument under debugging */ #ifdef DEBUGGING -#define _pDEPTH ,U32 depth -#define _aDEPTH ,depth +# define _pDEPTH ,U32 depth +# define _aDEPTH ,depth #else -#define _pDEPTH -#define _aDEPTH +# define _pDEPTH +# define _aDEPTH #endif /* NOTE 1: that with gcc -std=c89 the __STDC_VERSION__ is *not* defined @@ -135,8 +135,16 @@ Otherwise ends a section of code already begun by a C>. # endif #endif -/* this used to be off by default, now its on, see perlio.h */ -#define PERLIO_FUNCS_CONST +/* +=for apidoc_section $concurrency +=for apidoc AmU|void|dTHXa|PerlInterpreter * a +On threaded perls, set C to C; on unthreaded perls, do nothing + +=for apidoc AmU|void|dTHXoa|PerlInterpreter * a +Now a synonym for C>. + +=cut +*/ #ifdef PERL_IMPLICIT_CONTEXT # ifndef MULTIPLICITY @@ -189,15 +197,15 @@ Now a no-op. =cut */ -#define CPERLscope(x) x -#define CPERLarg void -#define CPERLarg_ -#define _CPERLarg -#define PERL_OBJECT_THIS -#define _PERL_OBJECT_THIS -#define PERL_OBJECT_THIS_ -#define CALL_FPTR(fptr) (*fptr) -#define MEMBER_TO_FPTR(name) name +# define CPERLscope(x) x +# define CPERLarg void +# define CPERLarg_ +# define _CPERLarg +# define PERL_OBJECT_THIS +# define _PERL_OBJECT_THIS +# define PERL_OBJECT_THIS_ +# define CALL_FPTR(fptr) (*fptr) +# define MEMBER_TO_FPTR(name) name #endif /* !PERL_CORE */ #define CALLRUNOPS PL_runops @@ -263,10 +271,10 @@ Now a no-op. RX_ENGINE(rx)->qr_package(aTHX_ (rx)) #if defined(USE_ITHREADS) -#define CALLREGDUPE(prog,param) \ +# define CALLREGDUPE(prog,param) \ Perl_re_dup(aTHX_ (prog),(param)) -#define CALLREGDUPE_PVT(prog,param) \ +# define CALLREGDUPE_PVT(prog,param) \ (prog ? RX_ENGINE(prog)->dupe(aTHX_ (prog),(param)) \ : (REGEXP *)NULL) #endif @@ -291,42 +299,42 @@ Now a no-op. */ #ifndef PERL_MICRO -#if defined __GNUC__ && !defined(__INTEL_COMPILER) -# if __GNUC__ == 3 && __GNUC_MINOR__ >= 1 || __GNUC__ > 3 /* 3.1 -> */ -# define HASATTRIBUTE_DEPRECATED -# endif -# if __GNUC__ >= 3 /* 3.0 -> */ /* XXX Verify this version */ -# define HASATTRIBUTE_FORMAT -# if defined __MINGW32__ -# define PRINTF_FORMAT_NULL_OK +# if defined __GNUC__ && !defined(__INTEL_COMPILER) +# if __GNUC__ == 3 && __GNUC_MINOR__ >= 1 || __GNUC__ > 3 /* 3.1 -> */ +# define HASATTRIBUTE_DEPRECATED +# endif +# if __GNUC__ >= 3 /* 3.0 -> */ /* XXX Verify this version */ +# define HASATTRIBUTE_FORMAT +# if defined __MINGW32__ +# define PRINTF_FORMAT_NULL_OK +# endif +# endif +# if __GNUC__ >= 3 /* 3.0 -> */ +# define HASATTRIBUTE_MALLOC +# endif +# if __GNUC__ == 3 && __GNUC_MINOR__ >= 3 || __GNUC__ > 3 /* 3.3 -> */ +# define HASATTRIBUTE_NONNULL +# endif +# if __GNUC__ == 2 && __GNUC_MINOR__ >= 5 || __GNUC__ > 2 /* 2.5 -> */ +# define HASATTRIBUTE_NORETURN +# endif +# if __GNUC__ >= 3 /* gcc 3.0 -> */ +# define HASATTRIBUTE_PURE +# endif +# if __GNUC__ == 3 && __GNUC_MINOR__ >= 4 || __GNUC__ > 3 /* 3.4 -> */ +# define HASATTRIBUTE_UNUSED +# endif +# if __GNUC__ == 3 && __GNUC_MINOR__ == 3 && !defined(__cplusplus) +# define HASATTRIBUTE_UNUSED /* gcc-3.3, but not g++-3.3. */ +# endif +# if __GNUC__ == 3 && __GNUC_MINOR__ >= 4 || __GNUC__ > 3 /* 3.4 -> */ +# define HASATTRIBUTE_WARN_UNUSED_RESULT +# endif + /* always_inline is buggy in gcc <= 4.6 and causes compilation errors */ +# if __GNUC__ == 4 && __GNUC_MINOR__ >= 7 || __GNUC__ > 4 /* 4.7 -> */ +# define HASATTRIBUTE_ALWAYS_INLINE # endif # endif -# if __GNUC__ >= 3 /* 3.0 -> */ -# define HASATTRIBUTE_MALLOC -# endif -# if __GNUC__ == 3 && __GNUC_MINOR__ >= 3 || __GNUC__ > 3 /* 3.3 -> */ -# define HASATTRIBUTE_NONNULL -# endif -# if __GNUC__ == 2 && __GNUC_MINOR__ >= 5 || __GNUC__ > 2 /* 2.5 -> */ -# define HASATTRIBUTE_NORETURN -# endif -# if __GNUC__ >= 3 /* gcc 3.0 -> */ -# define HASATTRIBUTE_PURE -# endif -# if __GNUC__ == 3 && __GNUC_MINOR__ >= 4 || __GNUC__ > 3 /* 3.4 -> */ -# define HASATTRIBUTE_UNUSED -# endif -# if __GNUC__ == 3 && __GNUC_MINOR__ == 3 && !defined(__cplusplus) -# define HASATTRIBUTE_UNUSED /* gcc-3.3, but not g++-3.3. */ -# endif -# if __GNUC__ == 3 && __GNUC_MINOR__ >= 4 || __GNUC__ > 3 /* 3.4 -> */ -# define HASATTRIBUTE_WARN_UNUSED_RESULT -# endif -/* always_inline is buggy in gcc <= 4.6 and causes compilation errors */ -# if __GNUC__ == 4 && __GNUC_MINOR__ >= 7 || __GNUC__ > 4 /* 4.7 -> */ -# define HASATTRIBUTE_ALWAYS_INLINE -# endif -#endif #endif /* #ifndef PERL_MICRO */ #ifdef HASATTRIBUTE_DEPRECATED @@ -521,9 +529,9 @@ __typeof__ and nothing else. # endif #endif -#if defined(_MSC_VER) +#if defined(_MSC_VER) && _MSC_VER < 1400 /* XXX older MSVC versions have a smallish macro buffer */ -#define PERL_SMALL_MACRO_BUFFER +# define PERL_SMALL_MACRO_BUFFER #endif /* on gcc (and clang), specify that a warning should be temporarily @@ -635,6 +643,10 @@ code. =for apidoc AmnU||dVAR This is now a synonym for dNOOP: declare nothing +=for apidoc_section $XS +=for apidoc Amns||dMY_CXT_SV +Now a placeholder that declares nothing + =cut */ @@ -645,6 +657,7 @@ This is now a synonym for dNOOP: declare nothing /* these are only defined for compatibility; should not be used internally. * */ +# define dMY_CXT_SV dNOOP # ifndef pTHXo # define pTHXo pTHX # define pTHXo_ pTHX_ @@ -1379,6 +1392,12 @@ Use L to declare variables of the maximum usable size on this platform. #define MALLOC_TOO_LATE_FOR(ch) TOO_LATE_FOR_(ch, " with $ENV{PERL_MALLOC_OPT}") #define MALLOC_CHECK_TAINT2(argc,argv) MALLOC_CHECK_TAINT(argc,argv,NULL) +/* +=for apidoc Am|void|memzero|void * d|Size_t l +Set the C bytes starting at C<*d> to all zeroes. + +=cut +*/ #ifndef memzero # define memzero(d,l) memset(d,0,l) #endif @@ -2109,6 +2128,14 @@ typedef UVTYPE UV; # define PTR2ul(p) INT2PTR(unsigned long,p) #endif +/* +=for apidoc_section Casting +=for apidoc Cyh|type|NUM2PTR|type|int value +You probably want to be using L> instead. + +=cut +*/ + #define NUM2PTR(any,d) (any)(PTRV)(d) #define PTR2IV(p) INT2PTR(IV,p) #define PTR2UV(p) INT2PTR(UV,p) @@ -2151,7 +2178,22 @@ typedef UVTYPE UV; # endif #endif -typedef NVTYPE NV; +/* On MS Windows,with 64-bit mingw-w64 compilers, we + need to attend to a __float128 alignment issue if + USE_QUADMATH is defined. Otherwise we simply: + typedef NVTYPE NV + 32-bit mingw.org compilers might also require + aligned(32) - at least that's what I found with my + Math::Foat128 module. But this is as yet untested + here, so no allowance is being made for mingw.org + compilers at this stage. -- sisyphus January 2021 +*/ +#if defined(USE_QUADMATH) && defined(__MINGW64__) + /* 64-bit build, mingw-w64 compiler only */ + typedef NVTYPE NV __attribute__ ((aligned(8))); +#else + typedef NVTYPE NV; +#endif #ifdef I_IEEEFP # include @@ -2441,7 +2483,7 @@ extern long double Perl_my_frexpl(long double x, int *e); # define FP_QNAN FP_QNAN # endif # include -# ifdef I_IEEFP +# ifdef I_IEEEFP # include # endif # ifdef I_FP @@ -2650,7 +2692,7 @@ extern long double Perl_my_frexpl(long double x, int *e); # define Perl_isfinitel(x) isfinitel(x) # elif defined(HAS_FINITEL) # define Perl_isfinitel(x) finitel(x) -# elif defined(HAS_INFL) && defined(HAS_NANL) +# elif defined(HAS_ISINFL) && defined(HAS_ISNANL) # define Perl_isfinitel(x) !(isinfl(x)||isnanl(x)) # else # define Perl_isfinitel(x) ((x) * 0 == 0) /* See Perl_isfinite. */ @@ -3049,37 +3091,6 @@ typedef struct padname PADNAME; # define USE_ENVIRON_ARRAY #endif -#ifdef USE_ITHREADS - /* On some platforms it would be safe to use a read/write mutex with many - * readers possible at the same time. On other platforms, notably IBM ones, - * subsequent getenv calls destroy earlier ones. Those platforms would not - * be able to handle simultaneous getenv calls */ -# define ENV_LOCK MUTEX_LOCK(&PL_env_mutex) -# define ENV_UNLOCK MUTEX_UNLOCK(&PL_env_mutex) -# define ENV_INIT MUTEX_INIT(&PL_env_mutex); -# define ENV_TERM MUTEX_DESTROY(&PL_env_mutex); -#else -# define ENV_LOCK NOOP; -# define ENV_UNLOCK NOOP; -# define ENV_INIT NOOP; -# define ENV_TERM NOOP; -#endif - -/* Some critical sections need to lock both the locale and the environment. - * XXX khw intends to change this to lock both mutexes, but that brings up - * issues of potential deadlock, so should be done at the beginning of a - * development cycle. So for now, it just locks the environment. Note that - * many modern platforms are locale-thread-safe anyway, so locking the locale - * mutex is a no-op anyway */ -#define ENV_LOCALE_LOCK ENV_LOCK -#define ENV_LOCALE_UNLOCK ENV_UNLOCK - -/* And some critical sections care only that no one else is writing either the - * locale nor the environment. XXX Again this is for the future. This can be - * simulated with using COND_WAIT in thread.h */ -#define ENV_LOCALE_READ_LOCK ENV_LOCALE_LOCK -#define ENV_LOCALE_READ_UNLOCK ENV_LOCALE_UNLOCK - #if defined(HAS_SIGACTION) && defined(SA_SIGINFO) /* having sigaction(2) means that the OS supports both 1-arg and 3-arg * signal handlers. But the perl core itself only fully supports 1-arg @@ -3344,6 +3355,15 @@ typedef pthread_mutex_t PERL_TSA_CAPABILITY("mutex") perl_mutex; typedef pthread_cond_t perl_cond; typedef pthread_key_t perl_key; # endif + +/* Many readers; single writer */ +typedef struct { + perl_mutex lock; + perl_cond wakeup; + SSize_t readers_count; +} perl_RnW1_mutex_t; + + #endif /* USE_ITHREADS */ #ifdef PERL_TSA_ACTIVE @@ -3748,7 +3768,13 @@ EXTERN_C int perl_tsa_mutex_unlock(perl_mutex* mutex) #define PNfARG(pn) (int)1, (UV)PadnameLEN(pn), (void *)PadnamePV(pn) #ifdef PERL_CORE -/* not used; but needed for backward compatibility with XS code? - RMB */ +/* not used; but needed for backward compatibility with XS code? - RMB +=for apidoc AmnD|const char *|UVf + +Obsolete form of C, which you should convert to instead use + +=cut +*/ # undef UVf #elif !defined(UVf) # define UVf UVuf @@ -6227,22 +6253,6 @@ EXTCONST U8 PL_c9_utf8_dfa_tab[]; # endif #endif /* end of isn't EBCDIC */ -#ifndef PERL_NO_INLINE_FUNCTIONS -/* Static inline funcs that depend on includes and declarations above. - Some of these reference functions in the perl object files, and some - compilers aren't smart enough to eliminate unused static inline - functions, so including this file in source code can cause link errors - even if the source code uses none of the functions. Hence including these - can be suppressed by setting PERL_NO_INLINE_FUNCTIONS. Doing this will - (obviously) result in unworkable XS code, but allows simple probing code - to continue to work, because it permits tests to include the perl headers - for definitions without creating a link dependency on the perl library - (which may not exist yet). -*/ - -# include "inline.h" -#endif - #include "overload.h" END_EXTERN_C @@ -6488,89 +6498,135 @@ the plain locale pragma without a parameter (S>) is in effect. #endif -/* Locale/thread synchronization macros. These aren't needed if using - * thread-safe locale operations, except if something is broken */ -#if defined(USE_LOCALE) \ - && defined(USE_ITHREADS) \ - && (! defined(USE_THREAD_SAFE_LOCALE) || defined(TS_W32_BROKEN_LOCALECONV)) +/* Locale/thread synchronization macros. */ +#if ! ( defined(USE_LOCALE) \ + && defined(USE_ITHREADS) \ + && ( ! defined(USE_THREAD_SAFE_LOCALE) \ + || ( defined(HAS_LOCALECONV) \ + && ( ! defined(HAS_LOCALECONV_L) \ + || defined(TS_W32_BROKEN_LOCALECONV))) \ + || ( defined(HAS_NL_LANGINFO) \ + && ! defined(HAS_THREAD_SAFE_NL_LANGINFO_L)) \ + || (defined(HAS_MBLEN) && ! defined(HAS_MBRLEN)) \ + || (defined(HAS_MBTOWC) && ! defined(HAS_MBRTOWC)) \ + || (defined(HAS_WCTOMB) && ! defined(HAS_WCRTOMB)))) -/* We have a locale object holding the 'C' locale for Posix 2008 */ -# ifndef USE_POSIX_2008_LOCALE -# define _LOCALE_TERM_POSIX_2008 NOOP -# else -# define _LOCALE_TERM_POSIX_2008 \ - STMT_START { \ - if (PL_C_locale_obj) { \ - /* Make sure we aren't using the locale \ - * space we are about to free */ \ - uselocale(LC_GLOBAL_LOCALE); \ - freelocale(PL_C_locale_obj); \ - PL_C_locale_obj = (locale_t) NULL; \ - } \ - } STMT_END -# endif +/* The whole expression just above was complemented, so here we have no need + * for thread synchronization, most likely it would be that this isn't a + * threaded build. */ +# define LOCALE_INIT +# define LOCALE_TERM +# define LC_NUMERIC_LOCK(cond) NOOP +# define LC_NUMERIC_UNLOCK NOOP +# define LOCALECONV_LOCK NOOP +# define LOCALECONV_UNLOCK NOOP +# define LOCALE_READ_LOCK NOOP +# define LOCALE_READ_UNLOCK NOOP +# define MBLEN_LOCK NOOP +# define MBLEN_UNLOCK NOOP +# define MBTOWC_LOCK NOOP +# define MBTOWC_UNLOCK NOOP +# define NL_LANGINFO_LOCK NOOP +# define NL_LANGINFO_UNLOCK NOOP +# define SETLOCALE_LOCK NOOP +# define SETLOCALE_UNLOCK NOOP +# define WCTOMB_LOCK NOOP +# define WCTOMB_UNLOCK NOOP +#else -/* This is used as a generic lock for locale operations. For example this is - * used when calling nl_langinfo() so that another thread won't zap the - * contents of its buffer before it gets saved; and it's called when changing - * the locale of LC_MESSAGES. On some systems the latter can cause the - * nl_langinfo buffer to be zapped under a race condition. - * - * If combined with LC_NUMERIC_LOCK, calls to this and its corresponding unlock - * should be contained entirely within the locked portion of LC_NUMERIC. This - * mutex should be used only in very short sections of code, while - * LC_NUMERIC_LOCK may span more operations. By always following this - * convention, deadlock should be impossible. But if necessary, the two - * mutexes could be combined. - * - * Actually, the two macros just below with the '_V' suffixes are used in just - * a few places where there is a broken localeconv(), but otherwise things are - * thread safe, and hence don't need locking. Just below LOCALE_LOCK and - * LOCALE_UNLOCK are defined in terms of these for use everywhere else */ -# define LOCALE_LOCK_V \ + /* Here, we will need critical sections in locale handling, because one or + * more of the above conditions are true. This could be because the + * platform doesn't have thread-safe locales, or that at least one of the + * locale-dependent functions in the core isn't thread-safe. The latter + * case is generally because they return a pointer to a static buffer, which + * may be per-process instead of per-thread. There are supposedly + * re-entrant, safe versions for all of them Perl currently uses (which the + * #if above checks for), but most platforms don't have all the needed ones + * available, and the Posix standard doesn't require nl_langinfo_l() to be + * fully thread-safe, so a Configure probe was written. localeconv_l() is + * uncommon, and judging by bug reports on the web, some earlier library + * localeconv_l versions were broken, so perhaps a probe is in order for + * that, but it would be a pain to write. + * + * On non-thread-safe systems, some of the above functions are vulnerable to + * races should another thread get control and change the locale in the + * middle of their execution. + * + * We currently use a single mutex for all these cases. This solves both + * the problem of another thread changing the locale, and the buffer being + * overwritten (the code copies the results to a safe place before releasing + * the mutex). Ideally, for locale thread-safe platforms where the only + * issue is another thread clobbering the function's static buffer, there + * would be a separate mutex for each such buffer. Otherwise, things get + * locked that don't need to. But, it is not expected that any of these + * will be called frequently, and the locked interval should be short, and + * modern platforms will have reentrant versions (which don't lock) for + * almost all of them, so khw thinks a single mutex should suffice. */ +# define LOCALE_LOCK_ \ STMT_START { \ DEBUG_Lv(PerlIO_printf(Perl_debug_log, \ "%s: %d: locking locale\n", __FILE__, __LINE__)); \ MUTEX_LOCK(&PL_locale_mutex); \ } STMT_END -# define LOCALE_UNLOCK_V \ +# define LOCALE_UNLOCK_ \ STMT_START { \ DEBUG_Lv(PerlIO_printf(Perl_debug_log, \ "%s: %d: unlocking locale\n", __FILE__, __LINE__)); \ MUTEX_UNLOCK(&PL_locale_mutex); \ } STMT_END -/* On windows, we just need the mutex for LOCALE_LOCK */ -# ifdef TS_W32_BROKEN_LOCALECONV -# define LOCALE_LOCK NOOP -# define LOCALE_UNLOCK NOOP -# define LOCALE_INIT MUTEX_INIT(&PL_locale_mutex); -# define LOCALE_TERM MUTEX_DESTROY(&PL_locale_mutex) -# define LC_NUMERIC_LOCK(cond) -# define LC_NUMERIC_UNLOCK + /* We do define a different macro for each case; then if we want to have + * separate mutexes for some of them, the only changes needed are here. + * Define just the necessary macros. The compiler should then croak if the + * #ifdef's in the code are incorrect */ +# if defined(HAS_LOCALECONV) && ( ! defined(HAS_POSIX_2008_LOCALE) \ + || ! defined(HAS_LOCALECONV_L) \ + || defined(TS_W32_BROKEN_LOCALECONV)) +# define LOCALECONV_LOCK LOCALE_LOCK_ +# define LOCALECONV_UNLOCK LOCALE_UNLOCK_ +# endif +# if defined(HAS_NL_LANGINFO) && ( ! defined(HAS_THREAD_SAFE_NL_LANGINFO_L) \ + || ! defined(HAS_POSIX_2008_LOCALE)) +# define NL_LANGINFO_LOCK LOCALE_LOCK_ +# define NL_LANGINFO_UNLOCK LOCALE_UNLOCK_ +# endif +# if defined(HAS_MBLEN) && ! defined(HAS_MBRLEN) +# define MBLEN_LOCK LOCALE_LOCK_ +# define MBLEN_UNLOCK LOCALE_UNLOCK_ +# endif +# if defined(HAS_MBTOWC) && ! defined(HAS_MBRTOWC) +# define MBTOWC_LOCK LOCALE_LOCK_ +# define MBTOWC_UNLOCK LOCALE_UNLOCK_ +# endif +# if defined(HAS_WCTOMB) && ! defined(HAS_WCRTOMB) +# define WCTOMB_LOCK LOCALE_LOCK_ +# define WCTOMB_UNLOCK LOCALE_UNLOCK_ +# endif +# if defined(USE_THREAD_SAFE_LOCALE) + /* On locale thread-safe systems, we don't need these workarounds */ +# define LOCALE_TERM_LC_NUMERIC_ NOOP +# define LOCALE_INIT_LC_NUMERIC_ NOOP +# define LC_NUMERIC_LOCK(cond) NOOP +# define LC_NUMERIC_UNLOCK NOOP +# define LOCALE_INIT_LC_NUMERIC_ NOOP +# define LOCALE_TERM_LC_NUMERIC_ NOOP + + /* There may be instance core where we this is invoked yet should do + * nothing. Rather than have #ifdef's around them, define it here */ +# define SETLOCALE_LOCK NOOP +# define SETLOCALE_UNLOCK NOOP # else -# define LOCALE_LOCK LOCALE_LOCK_V -# define LOCALE_UNLOCK LOCALE_UNLOCK_V - - /* We also need to lock LC_NUMERIC for non-windows (hence Posix 2008) - * systems */ -# define LOCALE_INIT STMT_START { \ - MUTEX_INIT(&PL_locale_mutex); \ - MUTEX_INIT(&PL_lc_numeric_mutex); \ - } STMT_END - -# define LOCALE_TERM STMT_START { \ - MUTEX_DESTROY(&PL_locale_mutex); \ - MUTEX_DESTROY(&PL_lc_numeric_mutex); \ - _LOCALE_TERM_POSIX_2008; \ - } STMT_END - - /* This mutex is used to create critical sections where we want the - * LC_NUMERIC locale to be locked into either the C (standard) locale, or - * the underlying locale, so that other threads interrupting this one don't - * change it to the wrong state before we've had a chance to complete our - * operation. It can stay locked over an entire printf operation, for - * example. And so is made distinct from the LOCALE_LOCK mutex. +# define SETLOCALE_LOCK LOCALE_LOCK_ +# define SETLOCALE_UNLOCK LOCALE_UNLOCK_ + + /* On platforms without per-thread locales, when another thread can switch + * our locale, we need another mutex to create critical sections where we + * want the LC_NUMERIC locale to be locked into either the C (standard) + * locale, or the underlying locale, so that other threads interrupting + * this one don't change it to the wrong state before we've had a chance to + * complete our operation. It can stay locked over an entire printf + * operation, for example. And so is made distinct from the LOCALE_LOCK + * mutex. * * This simulates kind of a general semaphore. The current thread will * lock the mutex if the per-thread variable is zero, and then increments @@ -6584,7 +6640,13 @@ the plain locale pragma without a parameter (S>) is in effect. * * Clang improperly gives warnings for this, if not silenced: * https://clang.llvm.org/docs/ThreadSafetyAnalysis.html#conditional-locks - * */ + * + * If LC_NUMERIC_LOCK is combined with one of the LOCKs above, calls to + * that and its corresponding unlock should be contained entirely within + * the locked portion of LC_NUMERIC. Those mutexes should be used only in + * very short sections of code, while LC_NUMERIC_LOCK may span more + * operations. By always following this convention, deadlock should be + * impossible. But if necessary, the two mutexes could be combined. */ # define LC_NUMERIC_LOCK(cond_to_panic_if_already_locked) \ CLANG_DIAG_IGNORE(-Wthread-safety) \ STMT_START { \ @@ -6626,16 +6688,36 @@ the plain locale pragma without a parameter (S>) is in effect. } STMT_END \ CLANG_DIAG_RESTORE -# endif /* End of needs locking LC_NUMERIC */ -#else /* Below is no locale sync needed */ -# define LOCALE_INIT -# define LOCALE_LOCK -# define LOCALE_LOCK_V -# define LOCALE_UNLOCK -# define LOCALE_UNLOCK_V -# define LC_NUMERIC_LOCK(cond) -# define LC_NUMERIC_UNLOCK -# define LOCALE_TERM +# define LOCALE_INIT_LC_NUMERIC_ MUTEX_INIT(&PL_lc_numeric_mutex) +# define LOCALE_TERM_LC_NUMERIC_ MUTEX_DESTROY(&PL_lc_numeric_mutex) +# endif + +# ifdef USE_POSIX_2008_LOCALE + /* We have a locale object holding the 'C' locale for Posix 2008 */ +# define LOCALE_TERM_POSIX_2008_ \ + STMT_START { \ + if (PL_C_locale_obj) { \ + /* Make sure we aren't using the locale \ + * space we are about to free */ \ + uselocale(LC_GLOBAL_LOCALE); \ + freelocale(PL_C_locale_obj); \ + PL_C_locale_obj = (locale_t) NULL; \ + } \ + } STMT_END +# else +# define LOCALE_TERM_POSIX_2008_ NOOP +# endif + +# define LOCALE_INIT STMT_START { \ + MUTEX_INIT(&PL_locale_mutex); \ + LOCALE_INIT_LC_NUMERIC_; \ + } STMT_END + +# define LOCALE_TERM STMT_START { \ + MUTEX_DESTROY(&PL_locale_mutex); \ + LOCALE_TERM_LC_NUMERIC_; \ + LOCALE_TERM_POSIX_2008_; \ + } STMT_END #endif #ifdef USE_LOCALE_NUMERIC @@ -6935,6 +7017,75 @@ cannot have changed since the precalculation. #endif /* !USE_LOCALE_NUMERIC */ +#ifdef USE_ITHREADS +# define ENV_LOCK PERL_WRITE_LOCK(&PL_env_mutex) +# define ENV_UNLOCK PERL_WRITE_UNLOCK(&PL_env_mutex) +# define ENV_READ_LOCK PERL_READ_LOCK(&PL_env_mutex) +# define ENV_READ_UNLOCK PERL_READ_UNLOCK(&PL_env_mutex) +# define ENV_INIT PERL_RW_MUTEX_INIT(&PL_env_mutex) +# define ENV_TERM PERL_RW_MUTEX_DESTROY(&PL_env_mutex) + + /* On platforms where the static buffer contained in getenv() is per-thread + * rather than process-wide, another thread executing a getenv() at the same + * time won't destroy ours before we have copied the result safely away and + * unlocked the mutex. On such platforms (which is most), we can have many + * readers of the environment at the same time. */ +# ifdef GETENV_PRESERVES_OTHER_THREAD +# define GETENV_LOCK ENV_READ_LOCK +# define GETENV_UNLOCK ENV_READ_UNLOCK +# else + /* If, on the other hand, another thread could zap our getenv() return, we + * need to keep them from executing until we are done */ +# define GETENV_LOCK ENV_LOCK +# define GETENV_UNLOCK ENV_UNLOCK +# endif +#else +# define ENV_LOCK NOOP +# define ENV_UNLOCK NOOP +# define ENV_READ_LOCK NOOP +# define ENV_READ_UNLOCK NOOP +# define ENV_INIT NOOP +# define ENV_TERM NOOP +# define GETENV_LOCK NOOP +# define GETENV_UNLOCK NOOP +#endif + +#ifndef PERL_NO_INLINE_FUNCTIONS +/* Static inline funcs that depend on includes and declarations above. + Some of these reference functions in the perl object files, and some + compilers aren't smart enough to eliminate unused static inline + functions, so including this file in source code can cause link errors + even if the source code uses none of the functions. Hence including these + can be suppressed by setting PERL_NO_INLINE_FUNCTIONS. Doing this will + (obviously) result in unworkable XS code, but allows simple probing code + to continue to work, because it permits tests to include the perl headers + for definitions without creating a link dependency on the perl library + (which may not exist yet). +*/ + +START_EXTERN_C + +# include "inline.h" + +END_EXTERN_C + +#endif + +/* Some critical sections need to lock both the locale and the environment. + * XXX khw intends to change this to lock both mutexes, but that brings up + * issues of potential deadlock, so should be done at the beginning of a + * development cycle. So for now, it just locks the environment. Note that + * many modern platforms are locale-thread-safe anyway, so locking the locale + * mutex is a no-op anyway */ +#define ENV_LOCALE_LOCK ENV_LOCK +#define ENV_LOCALE_UNLOCK ENV_UNLOCK + +/* And some critical sections care only that no one else is writing either the + * locale nor the environment. XXX Again this is for the future. This can be + * simulated with using COND_WAIT in thread.h */ +#define ENV_LOCALE_READ_LOCK ENV_LOCALE_LOCK +#define ENV_LOCALE_READ_UNLOCK ENV_LOCALE_UNLOCK + #define Atof my_atof /* @@ -7177,9 +7328,7 @@ C. # define _aMY_CXT ,aMY_CXT #else /* PERL_IMPLICIT_CONTEXT */ - # define START_MY_CXT static my_cxt_t my_cxt; -# define dMY_CXT_SV dNOOP # define dMY_CXT dNOOP # define dMY_CXT_INTERP(my_perl) dNOOP # define MY_CXT_INIT NOOP diff --git a/perl_inc_macro.h b/perl_inc_macro.h index 5a2f20dfaeb2..b9cd60947e1f 100644 --- a/perl_inc_macro.h +++ b/perl_inc_macro.h @@ -24,7 +24,7 @@ #ifdef APPLLIB_EXP # define INCPUSH_APPLLIB_EXP S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), \ - INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); + INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); #endif #ifdef SITEARCH_EXP @@ -32,7 +32,7 @@ * DLL-based path intuition to work correctly */ # if !defined(WIN32) # define INCPUSH_SITEARCH_EXP S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITEARCH_EXP), \ - INCPUSH_CAN_RELOCATE); + INCPUSH_CAN_RELOCATE); # endif #endif @@ -40,10 +40,10 @@ # if defined(WIN32) /* this picks up sitearch as well */ # define INCPUSH_SITELIB_EXP s = PerlEnv_sitelib_path(PERL_FS_VERSION, &len); \ - if (s) incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); + if (s) incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); # else # define INCPUSH_SITELIB_EXP S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_EXP), \ - INCPUSH_CAN_RELOCATE); + INCPUSH_CAN_RELOCATE); # endif #endif @@ -59,7 +59,7 @@ # if defined(WIN32) /* this picks up vendorarch as well */ # define INCPUSH_PERL_VENDORLIB_EXP s = PerlEnv_vendorlib_path(PERL_FS_VERSION, &len); \ - if (s) incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); + if (s) incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); # else # define INCPUSH_PERL_VENDORLIB_EXP S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_EXP), INCPUSH_CAN_RELOCATE); # endif @@ -85,7 +85,7 @@ #ifdef PERL_OTHERLIBDIRS # define INCPUSH_PERL_OTHERLIBDIRS S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS), \ - INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE); + INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE); #endif @@ -106,17 +106,17 @@ # define _INCPUSH_PERL5LIB_ADD _INCPUSH_PERL5LIB_IF incpush_use_sep(perl5lib, 0, INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR); #else /* VMS */ - /* Treat PERL5?LIB as a possible search list logical name -- the - * "natural" VMS idiom for a Unix path string. We allow each - * element to be a set of |-separated directories for compatibility. - */ + /* Treat PERL5?LIB as a possible search list logical name -- the + * "natural" VMS idiom for a Unix path string. We allow each + * element to be a set of |-separated directories for compatibility. + */ # define _INCPUSH_PERL5LIB_ADD char buf[256]; \ - int idx = 0; \ - if (vmstrnenv("PERL5LIB",buf,0,NULL,0)) \ - do { \ - incpush_use_sep(buf, 0, \ - INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR); \ - } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0)); + int idx = 0; \ + if (vmstrnenv("PERL5LIB",buf,0,NULL,0)) \ + do { \ + incpush_use_sep(buf, 0, \ + INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR); \ + } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0)); #endif /* this macro is special and use submacros from above */ @@ -127,25 +127,25 @@ */ #ifdef APPLLIB_EXP # define INCPUSH_APPLLIB_OLD_EXP S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), \ - INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE); + INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE); #endif #if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST) /* Search for version-specific dirs below here */ # define INCPUSH_SITELIB_STEM S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_STEM), \ - INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE); + INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE); #endif #if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST) /* Search for version-specific dirs below here */ # define INCPUSH_PERL_VENDORLIB_STEM S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_STEM), \ - INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE); + INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE); #endif #ifdef PERL_OTHERLIBDIRS # define INCPUSH_PERL_OTHERLIBDIRS_ARCHONLY S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS), \ - INCPUSH_ADD_OLD_VERS|INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_CAN_RELOCATE); + INCPUSH_ADD_OLD_VERS|INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_CAN_RELOCATE); #endif diff --git a/perlio.c b/perlio.c index b3b4327491f7..aa85c16f8c90 100644 --- a/perlio.c +++ b/perlio.c @@ -57,52 +57,52 @@ /* Call the callback or PerlIOBase, and return failure. */ #define Perl_PerlIO_or_Base(f, callback, base, failure, args) \ - if (PerlIOValid(f)) { \ - const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\ - if (tab && tab->callback) \ - return (*tab->callback) args; \ - else \ - return PerlIOBase_ ## base args; \ - } \ - else \ - SETERRNO(EBADF, SS_IVCHAN); \ - return failure + if (PerlIOValid(f)) { \ + const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\ + if (tab && tab->callback) \ + return (*tab->callback) args; \ + else \ + return PerlIOBase_ ## base args; \ + } \ + else \ + SETERRNO(EBADF, SS_IVCHAN); \ + return failure /* Call the callback or fail, and return failure. */ #define Perl_PerlIO_or_fail(f, callback, failure, args) \ - if (PerlIOValid(f)) { \ - const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\ - if (tab && tab->callback) \ - return (*tab->callback) args; \ - SETERRNO(EINVAL, LIB_INVARG); \ - } \ - else \ - SETERRNO(EBADF, SS_IVCHAN); \ - return failure + if (PerlIOValid(f)) { \ + const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\ + if (tab && tab->callback) \ + return (*tab->callback) args; \ + SETERRNO(EINVAL, LIB_INVARG); \ + } \ + else \ + SETERRNO(EBADF, SS_IVCHAN); \ + return failure /* Call the callback or PerlIOBase, and be void. */ #define Perl_PerlIO_or_Base_void(f, callback, base, args) \ - if (PerlIOValid(f)) { \ - const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\ - if (tab && tab->callback) \ - (*tab->callback) args; \ - else \ - PerlIOBase_ ## base args; \ - } \ - else \ - SETERRNO(EBADF, SS_IVCHAN) + if (PerlIOValid(f)) { \ + const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\ + if (tab && tab->callback) \ + (*tab->callback) args; \ + else \ + PerlIOBase_ ## base args; \ + } \ + else \ + SETERRNO(EBADF, SS_IVCHAN) /* Call the callback or fail, and be void. */ #define Perl_PerlIO_or_fail_void(f, callback, args) \ - if (PerlIOValid(f)) { \ - const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\ - if (tab && tab->callback) \ - (*tab->callback) args; \ - else \ - SETERRNO(EINVAL, LIB_INVARG); \ - } \ - else \ - SETERRNO(EBADF, SS_IVCHAN) + if (PerlIOValid(f)) { \ + const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\ + if (tab && tab->callback) \ + (*tab->callback) args; \ + else \ + SETERRNO(EINVAL, LIB_INVARG); \ + } \ + else \ + SETERRNO(EBADF, SS_IVCHAN) #if defined(__osf__) && _XOPEN_SOURCE < 500 extern int fseeko(FILE *, off_t, int); @@ -163,42 +163,42 @@ PerlIO_intmode2str(int rawmode, char *mode, int *writing) int ptype; switch (result) { case O_RDONLY: - ptype = IoTYPE_RDONLY; - break; + ptype = IoTYPE_RDONLY; + break; case O_WRONLY: - ptype = IoTYPE_WRONLY; - break; + ptype = IoTYPE_WRONLY; + break; case O_RDWR: default: - ptype = IoTYPE_RDWR; - break; + ptype = IoTYPE_RDWR; + break; } if (writing) - *writing = (result != O_RDONLY); + *writing = (result != O_RDONLY); if (result == O_RDONLY) { - mode[ix++] = 'r'; + mode[ix++] = 'r'; } #ifdef O_APPEND else if (rawmode & O_APPEND) { - mode[ix++] = 'a'; - if (result != O_WRONLY) - mode[ix++] = '+'; + mode[ix++] = 'a'; + if (result != O_WRONLY) + mode[ix++] = '+'; } #endif else { - if (result == O_WRONLY) - mode[ix++] = 'w'; - else { - mode[ix++] = 'r'; - mode[ix++] = '+'; - } + if (result == O_WRONLY) + mode[ix++] = 'w'; + else { + mode[ix++] = 'r'; + mode[ix++] = '+'; + } } #if O_BINARY != 0 /* Unless O_BINARY is different from zero, bit-and:ing * with it won't do much good. */ if (rawmode & O_BINARY) - mode[ix++] = 'b'; + mode[ix++] = 'b'; #endif mode[ix] = '\0'; return ptype; @@ -213,7 +213,7 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) || strEQ(names, ":raw") || strEQ(names, ":bytes") ) { - return 0; + return 0; } Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names); /* @@ -245,22 +245,22 @@ PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags) return win32_fdupopen(f); # else if (f) { - const int fd = PerlLIO_dup_cloexec(PerlIO_fileno(f)); - if (fd >= 0) { - char mode[8]; + const int fd = PerlLIO_dup_cloexec(PerlIO_fileno(f)); + if (fd >= 0) { + char mode[8]; # ifdef DJGPP - const int omode = djgpp_get_stream_mode(f); + const int omode = djgpp_get_stream_mode(f); # else - const int omode = fcntl(fd, F_GETFL); + const int omode = fcntl(fd, F_GETFL); # endif - PerlIO_intmode2str(omode,mode,NULL); - /* the r+ is a hack */ - return PerlIO_fdopen(fd, mode); - } - return NULL; + PerlIO_intmode2str(omode,mode,NULL); + /* the r+ is a hack */ + return PerlIO_fdopen(fd, mode); + } + return NULL; } else { - SETERRNO(EBADF, SS_IVCHAN); + SETERRNO(EBADF, SS_IVCHAN); } # endif return NULL; @@ -274,35 +274,35 @@ PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags) PerlIO * PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, - int imode, int perm, PerlIO *old, int narg, SV **args) + int imode, int perm, PerlIO *old, int narg, SV **args) { if (narg) { - if (narg > 1) { - Perl_croak(aTHX_ "More than one argument to open"); - } - if (*args == &PL_sv_undef) - return PerlIO_tmpfile(); - else { + if (narg > 1) { + Perl_croak(aTHX_ "More than one argument to open"); + } + if (*args == &PL_sv_undef) + return PerlIO_tmpfile(); + else { STRLEN len; - const char *name = SvPV_const(*args, len); + const char *name = SvPV_const(*args, len); if (!IS_SAFE_PATHNAME(name, len, "open")) return NULL; - if (*mode == IoTYPE_NUMERIC) { - fd = PerlLIO_open3_cloexec(name, imode, perm); - if (fd >= 0) - return PerlIO_fdopen(fd, mode + 1); - } - else if (old) { - return PerlIO_reopen(name, mode, old); - } - else { - return PerlIO_open(name, mode); - } - } + if (*mode == IoTYPE_NUMERIC) { + fd = PerlLIO_open3_cloexec(name, imode, perm); + if (fd >= 0) + return PerlIO_fdopen(fd, mode + 1); + } + else if (old) { + return PerlIO_reopen(name, mode, old); + } + else { + return PerlIO_open(name, mode); + } + } } else { - return PerlIO_fdopen(fd, (char *) mode); + return PerlIO_fdopen(fd, (char *) mode); } return NULL; } @@ -312,12 +312,12 @@ XS(XS_PerlIO__Layer__find) { dXSARGS; if (items < 2) - Perl_croak(aTHX_ "Usage class->find(name[,load])"); + Perl_croak(aTHX_ "Usage class->find(name[,load])"); else { - const char * const name = SvPV_nolen_const(ST(1)); - ST(0) = (strEQ(name, "crlf") - || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef; - XSRETURN(1); + const char * const name = SvPV_nolen_const(ST(1)); + ST(0) = (strEQ(name, "crlf") + || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef; + XSRETURN(1); } } @@ -350,27 +350,27 @@ PerlIO_debug(const char *fmt, ...) va_start(ap, fmt); if (!PL_perlio_debug_fd) { - if (!TAINTING_get && - PerlProc_getuid() == PerlProc_geteuid() && - PerlProc_getgid() == PerlProc_getegid()) { - const char * const s = PerlEnv_getenv("PERLIO_DEBUG"); - if (s && *s) - PL_perlio_debug_fd = PerlLIO_open3_cloexec(s, - O_WRONLY | O_CREAT | O_APPEND, 0666); - else - PL_perlio_debug_fd = PerlLIO_dup_cloexec(2); /* stderr */ - } else { - /* tainting or set*id, so ignore the environment and send the + if (!TAINTING_get && + PerlProc_getuid() == PerlProc_geteuid() && + PerlProc_getgid() == PerlProc_getegid()) { + const char * const s = PerlEnv_getenv("PERLIO_DEBUG"); + if (s && *s) + PL_perlio_debug_fd = PerlLIO_open3_cloexec(s, + O_WRONLY | O_CREAT | O_APPEND, 0666); + else + PL_perlio_debug_fd = PerlLIO_dup_cloexec(2); /* stderr */ + } else { + /* tainting or set*id, so ignore the environment and send the debug output to stderr, like other -D switches. */ - PL_perlio_debug_fd = PerlLIO_dup_cloexec(2); /* stderr */ - } + PL_perlio_debug_fd = PerlLIO_dup_cloexec(2); /* stderr */ + } } if (PL_perlio_debug_fd > 0) { #ifdef USE_ITHREADS - const char * const s = CopFILE(PL_curcop); - /* Use fixed buffer as sv_catpvf etc. needs SVs */ - char buffer[1024]; - const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop)); + const char * const s = CopFILE(PL_curcop); + /* Use fixed buffer as sv_catpvf etc. needs SVs */ + char buffer[1024]; + const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop)); # ifdef USE_QUADMATH # ifdef HAS_VSNPRINTF /* my_vsnprintf() isn't available with quadmath, but the native vsnprintf() @@ -382,19 +382,19 @@ PerlIO_debug(const char *fmt, ...) STATIC_ASSERT_STMT(0); # endif # else - const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap); + const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap); # endif - PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2)); + PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2)); #else - const char *s = CopFILE(PL_curcop); - STRLEN len; - SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)", - (IV) CopLINE(PL_curcop)); - Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap); - - s = SvPV_const(sv, len); - PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, s, len)); - SvREFCNT_dec(sv); + const char *s = CopFILE(PL_curcop); + STRLEN len; + SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)", + (IV) CopLINE(PL_curcop)); + Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap); + + s = SvPV_const(sv, len); + PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, s, len)); + SvREFCNT_dec(sv); #endif } va_end(ap); @@ -419,14 +419,14 @@ PerlIO_verify_head(pTHX_ PerlIO *f) PERL_UNUSED_CONTEXT; # endif if (!PerlIOValid(f)) - return; + return; p = head = PerlIOBase(f)->head; assert(p); do { - assert(p->head == head); - if (p == (PerlIOl*)f) - seen = 1; - p = p->next; + assert(p->head == head); + if (p == (PerlIOl*)f) + seen = 1; + p = p->next; } while (p); assert(seen); } @@ -444,7 +444,7 @@ static void PerlIO_init_table(pTHX) { if (PL_perlio) - return; + return; Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl); } @@ -460,17 +460,17 @@ PerlIO_allocate(pTHX) PerlIOl *f; last = &PL_perlio; while ((f = *last)) { - int i; - last = (PerlIOl **) (f); - for (i = 1; i < PERLIO_TABLE_SIZE; i++) { - if (!((++f)->next)) { - goto good_exit; - } - } + int i; + last = (PerlIOl **) (f); + for (i = 1; i < PERLIO_TABLE_SIZE; i++) { + if (!((++f)->next)) { + goto good_exit; + } + } } Newxz(f,PERLIO_TABLE_SIZE,PerlIOl); if (!f) { - return NULL; + return NULL; } *last = (PerlIOl*) f++; @@ -486,16 +486,16 @@ PerlIO * PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags) { if (PerlIOValid(f)) { - const PerlIO_funcs * const tab = PerlIOBase(f)->tab; - DEBUG_i( PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param) ); - if (tab && tab->Dup) - return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags); - else { - return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags); - } + const PerlIO_funcs * const tab = PerlIOBase(f)->tab; + DEBUG_i( PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param) ); + if (tab && tab->Dup) + return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags); + else { + return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags); + } } else - SETERRNO(EBADF, SS_IVCHAN); + SETERRNO(EBADF, SS_IVCHAN); return NULL; } @@ -505,16 +505,16 @@ PerlIO_cleantable(pTHX_ PerlIOl **tablep) { PerlIOl * const table = *tablep; if (table) { - int i; - PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0])); - for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) { - PerlIOl * const f = table + i; - if (f->next) { - PerlIO_close(&(f->next)); - } - } - Safefree(table); - *tablep = NULL; + int i; + PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0])); + for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) { + PerlIOl * const f = table + i; + if (f->next) { + PerlIO_close(&(f->next)); + } + } + Safefree(table); + *tablep = NULL; } } @@ -533,15 +533,15 @@ void PerlIO_list_free(pTHX_ PerlIO_list_t *list) { if (list) { - if (--list->refcnt == 0) { - if (list->array) { - IV i; - for (i = 0; i < list->cur; i++) - SvREFCNT_dec(list->array[i].arg); - Safefree(list->array); - } - Safefree(list); - } + if (--list->refcnt == 0) { + if (list->array) { + IV i; + for (i = 0; i < list->cur; i++) + SvREFCNT_dec(list->array[i].arg); + Safefree(list->array); + } + Safefree(list); + } } } @@ -553,16 +553,16 @@ PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg) if (list->cur >= list->len) { const IV new_len = list->len + 8; - if (list->array) - Renew(list->array, new_len, PerlIO_pair_t); - else - Newx(list->array, new_len, PerlIO_pair_t); - list->len = new_len; + if (list->array) + Renew(list->array, new_len, PerlIO_pair_t); + else + Newx(list->array, new_len, PerlIO_pair_t); + list->len = new_len; } p = &(list->array[list->cur++]); p->funcs = funcs; if ((p->arg = arg)) { - SvREFCNT_inc_simple_void_NN(arg); + SvREFCNT_inc_simple_void_NN(arg); } } @@ -571,18 +571,18 @@ PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param) { PerlIO_list_t *list = NULL; if (proto) { - int i; - list = PerlIO_list_alloc(aTHX); - for (i=0; i < proto->cur; i++) { - SV *arg = proto->array[i].arg; + int i; + list = PerlIO_list_alloc(aTHX); + for (i=0; i < proto->cur; i++) { + SV *arg = proto->array[i].arg; #ifdef USE_ITHREADS - if (arg && param) - arg = sv_dup(arg, param); + if (arg && param) + arg = sv_dup(arg, param); #else - PERL_UNUSED_ARG(param); + PERL_UNUSED_ARG(param); #endif - PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg); - } + PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg); + } } return list; } @@ -599,15 +599,15 @@ PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param) PerlIO_init_table(aTHX); DEBUG_i( PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto) ); while ((f = *table)) { - int i; - table = (PerlIOl **) (f++); - for (i = 1; i < PERLIO_TABLE_SIZE; i++) { - if (f->next) { - (void) fp_dup(&(f->next), 0, param); - } - f++; - } - } + int i; + table = (PerlIOl **) (f++); + for (i = 1; i < PERLIO_TABLE_SIZE; i++) { + if (f->next) { + (void) fp_dup(&(f->next), 0, param); + } + f++; + } + } #else PERL_UNUSED_CONTEXT; PERL_UNUSED_ARG(proto); @@ -624,23 +624,23 @@ PerlIO_destruct(pTHX) DEBUG_i( PerlIO_debug("Destruct %p\n",(void*)aTHX) ); #endif while ((f = *table)) { - int i; - table = (PerlIOl **) (f++); - for (i = 1; i < PERLIO_TABLE_SIZE; i++) { - PerlIO *x = &(f->next); - const PerlIOl *l; - while ((l = *x)) { - if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) { - DEBUG_i( PerlIO_debug("Destruct popping %s\n", l->tab->name) ); - PerlIO_flush(x); - PerlIO_pop(aTHX_ x); - } - else { - x = PerlIONext(x); - } - } - f++; - } + int i; + table = (PerlIOl **) (f++); + for (i = 1; i < PERLIO_TABLE_SIZE; i++) { + PerlIO *x = &(f->next); + const PerlIOl *l; + while ((l = *x)) { + if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) { + DEBUG_i( PerlIO_debug("Destruct popping %s\n", l->tab->name) ); + PerlIO_flush(x); + PerlIO_pop(aTHX_ x); + } + else { + x = PerlIONext(x); + } + } + f++; + } } } @@ -650,26 +650,26 @@ PerlIO_pop(pTHX_ PerlIO *f) const PerlIOl *l = *f; VERIFY_HEAD(f); if (l) { - DEBUG_i( PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f, + DEBUG_i( PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f, l->tab ? l->tab->name : "(Null)") ); - if (l->tab && l->tab->Popped) { - /* - * If popped returns non-zero do not free its layer structure - * it has either done so itself, or it is shared and still in - * use - */ - if ((*l->tab->Popped) (aTHX_ f) != 0) - return; - } - if (PerlIO_lockcnt(f)) { - /* we're in use; defer freeing the structure */ - PerlIOBase(f)->flags = PERLIO_F_CLEARED; - PerlIOBase(f)->tab = NULL; - } - else { - *f = l->next; - Safefree(l); - } + if (l->tab && l->tab->Popped) { + /* + * If popped returns non-zero do not free its layer structure + * it has either done so itself, or it is shared and still in + * use + */ + if ((*l->tab->Popped) (aTHX_ f) != 0) + return; + } + if (PerlIO_lockcnt(f)) { + /* we're in use; defer freeing the structure */ + PerlIOBase(f)->flags = PERLIO_F_CLEARED; + PerlIOBase(f)->tab = NULL; + } + else { + *f = l->next; + Safefree(l); + } } } @@ -686,23 +686,23 @@ PerlIO_get_layers(pTHX_ PerlIO *f) AV * const av = newAV(); if (PerlIOValid(f)) { - PerlIOl *l = PerlIOBase(f); - - while (l) { - /* There is some collusion in the implementation of - XS_PerlIO_get_layers - it knows that name and flags are - generated as fresh SVs here, and takes advantage of that to - "copy" them by taking a reference. If it changes here, it needs - to change there too. */ - SV * const name = l->tab && l->tab->name ? - newSVpv(l->tab->name, 0) : &PL_sv_undef; - SV * const arg = l->tab && l->tab->Getarg ? - (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef; - av_push(av, name); - av_push(av, arg); - av_push(av, newSViv((IV)l->flags)); - l = l->next; - } + PerlIOl *l = PerlIOBase(f); + + while (l) { + /* There is some collusion in the implementation of + XS_PerlIO_get_layers - it knows that name and flags are + generated as fresh SVs here, and takes advantage of that to + "copy" them by taking a reference. If it changes here, it needs + to change there too. */ + SV * const name = l->tab && l->tab->name ? + newSVpv(l->tab->name, 0) : &PL_sv_undef; + SV * const arg = l->tab && l->tab->Getarg ? + (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef; + av_push(av, name); + av_push(av, arg); + av_push(av, newSViv((IV)l->flags)); + l = l->next; + } } return av; @@ -719,38 +719,38 @@ PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load) IV i; if ((SSize_t) len <= 0) - len = strlen(name); + len = strlen(name); for (i = 0; i < PL_known_layers->cur; i++) { - PerlIO_funcs * const f = PL_known_layers->array[i].funcs; + PerlIO_funcs * const f = PL_known_layers->array[i].funcs; const STRLEN this_len = strlen(f->name); if (this_len == len && memEQ(f->name, name, len)) { - DEBUG_i( PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f) ); - return f; - } + DEBUG_i( PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f) ); + return f; + } } if (load && PL_subname && PL_def_layerlist - && PL_def_layerlist->cur >= 2) { - if (PL_in_load_module) { - Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer"); - return NULL; - } else { - SV * const pkgsv = newSVpvs("PerlIO"); - SV * const layer = newSVpvn(name, len); - CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0); - ENTER; - SAVEBOOL(PL_in_load_module); - if (cv) { - SAVEGENERICSV(PL_warnhook); - PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv))); - } - PL_in_load_module = TRUE; - /* - * The two SVs are magically freed by load_module - */ - Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL); - LEAVE; - return PerlIO_find_layer(aTHX_ name, len, 0); - } + && PL_def_layerlist->cur >= 2) { + if (PL_in_load_module) { + Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer"); + return NULL; + } else { + SV * const pkgsv = newSVpvs("PerlIO"); + SV * const layer = newSVpvn(name, len); + CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0); + ENTER; + SAVEBOOL(PL_in_load_module); + if (cv) { + SAVEGENERICSV(PL_warnhook); + PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv))); + } + PL_in_load_module = TRUE; + /* + * The two SVs are magically freed by load_module + */ + Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL); + LEAVE; + return PerlIO_find_layer(aTHX_ name, len, 0); + } } DEBUG_i( PerlIO_debug("Cannot find %.*s\n", (int) len, name) ); return NULL; @@ -762,11 +762,11 @@ static int perlio_mg_set(pTHX_ SV *sv, MAGIC *mg) { if (SvROK(sv)) { - IO * const io = GvIOn(MUTABLE_GV(SvRV(sv))); - PerlIO * const ifp = IoIFP(io); - PerlIO * const ofp = IoOFP(io); - Perl_warn(aTHX_ "set %" SVf " %p %p %p", - SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp); + IO * const io = GvIOn(MUTABLE_GV(SvRV(sv))); + PerlIO * const ifp = IoIFP(io); + PerlIO * const ofp = IoOFP(io); + Perl_warn(aTHX_ "set %" SVf " %p %p %p", + SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp); } return 0; } @@ -775,11 +775,11 @@ static int perlio_mg_get(pTHX_ SV *sv, MAGIC *mg) { if (SvROK(sv)) { - IO * const io = GvIOn(MUTABLE_GV(SvRV(sv))); - PerlIO * const ifp = IoIFP(io); - PerlIO * const ofp = IoOFP(io); - Perl_warn(aTHX_ "get %" SVf " %p %p %p", - SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp); + IO * const io = GvIOn(MUTABLE_GV(SvRV(sv))); + PerlIO * const ifp = IoIFP(io); + PerlIO * const ofp = IoOFP(io); + Perl_warn(aTHX_ "get %" SVf " %p %p %p", + SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp); } return 0; } @@ -822,16 +822,16 @@ XS(XS_io_MODIFY_SCALAR_ATTRIBUTES) mg_magical(sv); Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv)); for (i = 2; i < items; i++) { - STRLEN len; - const char * const name = SvPV_const(ST(i), len); - SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1); - if (layer) { - av_push(av, SvREFCNT_inc_simple_NN(layer)); - } - else { - ST(count) = ST(i); - count++; - } + STRLEN len; + const char * const name = SvPV_const(ST(i), len); + SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1); + if (layer) { + av_push(av, SvREFCNT_inc_simple_NN(layer)); + } + else { + ST(count) = ST(i); + count++; + } } SvREFCNT_dec(av); XSRETURN(count); @@ -866,16 +866,16 @@ XS(XS_PerlIO__Layer__find) { dXSARGS; if (items < 2) - Perl_croak(aTHX_ "Usage class->find(name[,load])"); + Perl_croak(aTHX_ "Usage class->find(name[,load])"); else { - STRLEN len; - const char * const name = SvPV_const(ST(1), len); - const bool load = (items > 2) ? SvTRUE_NN(ST(2)) : 0; - PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load); - ST(0) = - (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) : - &PL_sv_undef; - XSRETURN(1); + STRLEN len; + const char * const name = SvPV_const(ST(1), len); + const bool load = (items > 2) ? SvTRUE_NN(ST(2)) : 0; + PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load); + ST(0) = + (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) : + &PL_sv_undef; + XSRETURN(1); } } @@ -883,7 +883,7 @@ void PerlIO_define_layer(pTHX_ PerlIO_funcs *tab) { if (!PL_known_layers) - PL_known_layers = PerlIO_list_alloc(aTHX); + PL_known_layers = PerlIO_list_alloc(aTHX); PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL); DEBUG_i( PerlIO_debug("define %s %p\n", tab->name, (void*)tab) ); } @@ -892,88 +892,88 @@ int PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names) { if (names) { - const char *s = names; - while (*s) { - while (isSPACE(*s) || *s == ':') - s++; - if (*s) { - STRLEN llen = 0; - const char *e = s; - const char *as = NULL; - STRLEN alen = 0; - if (!isIDFIRST(*s)) { - /* - * Message is consistent with how attribute lists are - * passed. Even though this means "foo : : bar" is - * seen as an invalid separator character. - */ - const char q = ((*s == '\'') ? '"' : '\''); - Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), - "Invalid separator character %c%c%c in PerlIO layer specification %s", - q, *s, q, s); - SETERRNO(EINVAL, LIB_INVARG); - return -1; - } - do { - e++; - } while (isWORDCHAR(*e)); - llen = e - s; - if (*e == '(') { - int nesting = 1; - as = ++e; - while (nesting) { - switch (*e++) { - case ')': - if (--nesting == 0) - alen = (e - 1) - as; - break; - case '(': - ++nesting; - break; - case '\\': - /* - * It's a nul terminated string, not allowed - * to \ the terminating null. Anything other - * character is passed over. - */ - if (*e++) { - break; - } + const char *s = names; + while (*s) { + while (isSPACE(*s) || *s == ':') + s++; + if (*s) { + STRLEN llen = 0; + const char *e = s; + const char *as = NULL; + STRLEN alen = 0; + if (!isIDFIRST(*s)) { + /* + * Message is consistent with how attribute lists are + * passed. Even though this means "foo : : bar" is + * seen as an invalid separator character. + */ + const char q = ((*s == '\'') ? '"' : '\''); + Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), + "Invalid separator character %c%c%c in PerlIO layer specification %s", + q, *s, q, s); + SETERRNO(EINVAL, LIB_INVARG); + return -1; + } + do { + e++; + } while (isWORDCHAR(*e)); + llen = e - s; + if (*e == '(') { + int nesting = 1; + as = ++e; + while (nesting) { + switch (*e++) { + case ')': + if (--nesting == 0) + alen = (e - 1) - as; + break; + case '(': + ++nesting; + break; + case '\\': + /* + * It's a nul terminated string, not allowed + * to \ the terminating null. Anything other + * character is passed over. + */ + if (*e++) { + break; + } /* Fall through */ - case '\0': - e--; - Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), - "Argument list not closed for PerlIO layer \"%.*s\"", - (int) (e - s), s); - return -1; - default: - /* - * boring. - */ - break; - } - } - } - if (e > s) { - PerlIO_funcs * const layer = - PerlIO_find_layer(aTHX_ s, llen, 1); - if (layer) { - SV *arg = NULL; - if (as) - arg = newSVpvn(as, alen); - PerlIO_list_push(aTHX_ av, layer, - (arg) ? arg : &PL_sv_undef); - SvREFCNT_dec(arg); - } - else { - Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"", - (int) llen, s); - return -1; - } - } - s = e; - } - } + case '\0': + e--; + Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), + "Argument list not closed for PerlIO layer \"%.*s\"", + (int) (e - s), s); + return -1; + default: + /* + * boring. + */ + break; + } + } + } + if (e > s) { + PerlIO_funcs * const layer = + PerlIO_find_layer(aTHX_ s, llen, 1); + if (layer) { + SV *arg = NULL; + if (as) + arg = newSVpvn(as, alen); + PerlIO_list_push(aTHX_ av, layer, + (arg) ? arg : &PL_sv_undef); + SvREFCNT_dec(arg); + } + else { + Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"", + (int) llen, s); + return -1; + } + } + s = e; + } + } } return 0; } @@ -986,7 +986,7 @@ PerlIO_default_buffer(pTHX_ PerlIO_list_t *av) tab = &PerlIO_crlf; #else if (PerlIO_stdio.Set_ptrcnt) - tab = &PerlIO_stdio; + tab = &PerlIO_stdio; #endif DEBUG_i( PerlIO_debug("Pushing %s\n", tab->name) ); PerlIO_list_push(aTHX_ av, (PerlIO_funcs *)tab, &PL_sv_undef); @@ -1002,12 +1002,12 @@ PerlIO_funcs * PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def) { if (n >= 0 && n < av->cur) { - DEBUG_i( PerlIO_debug("Layer %" IVdf " is %s\n", n, + DEBUG_i( PerlIO_debug("Layer %" IVdf " is %s\n", n, av->array[n].funcs->name) ); - return av->array[n].funcs; + return av->array[n].funcs; } if (!def) - Perl_croak(aTHX_ "panic: PerlIO layer array corrupt"); + Perl_croak(aTHX_ "panic: PerlIO layer array corrupt"); return def; } @@ -1018,9 +1018,9 @@ PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) PERL_UNUSED_ARG(arg); PERL_UNUSED_ARG(tab); if (PerlIOValid(f)) { - PerlIO_flush(f); - PerlIO_pop(aTHX_ f); - return 0; + PerlIO_flush(f); + PerlIO_pop(aTHX_ f); + return 0; } return -1; } @@ -1060,34 +1060,34 @@ PerlIO_list_t * PerlIO_default_layers(pTHX) { if (!PL_def_layerlist) { - const char * const s = TAINTING_get ? NULL : PerlEnv_getenv("PERLIO"); - PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix; - PL_def_layerlist = PerlIO_list_alloc(aTHX); - PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix)); + const char * const s = TAINTING_get ? NULL : PerlEnv_getenv("PERLIO"); + PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix; + PL_def_layerlist = PerlIO_list_alloc(aTHX); + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix)); #if defined(WIN32) - PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32)); + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32)); # if 0 - osLayer = &PerlIO_win32; + osLayer = &PerlIO_win32; # endif #endif - PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw)); - PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio)); - PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio)); - PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf)); - PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8)); - PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove)); - PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte)); - PerlIO_list_push(aTHX_ PL_def_layerlist, (PerlIO_funcs *)osLayer, + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw)); + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio)); + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio)); + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf)); + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8)); + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove)); + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte)); + PerlIO_list_push(aTHX_ PL_def_layerlist, (PerlIO_funcs *)osLayer, &PL_sv_undef); - if (s) { - PerlIO_parse_layers(aTHX_ PL_def_layerlist, s); - } - else { - PerlIO_default_buffer(aTHX_ PL_def_layerlist); - } + if (s) { + PerlIO_parse_layers(aTHX_ PL_def_layerlist, s); + } + else { + PerlIO_default_buffer(aTHX_ PL_def_layerlist); + } } if (PL_def_layerlist->cur < 2) { - PerlIO_default_buffer(aTHX_ PL_def_layerlist); + PerlIO_default_buffer(aTHX_ PL_def_layerlist); } return PL_def_layerlist; } @@ -1097,7 +1097,7 @@ Perl_boot_core_PerlIO(pTHX) { #ifdef USE_ATTRIBUTES_FOR_PERLIO newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES, - __FILE__); + __FILE__); #endif newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__); newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__); @@ -1108,7 +1108,7 @@ PerlIO_default_layer(pTHX_ I32 n) { PerlIO_list_t * const av = PerlIO_default_layers(aTHX); if (n < 0) - n += av->cur; + n += av->cur; return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio)); } @@ -1119,10 +1119,10 @@ void PerlIO_stdstreams(pTHX) { if (!PL_perlio) { - PerlIO_init_table(aTHX); - PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT); - PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT); - PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT); + PerlIO_init_table(aTHX); + PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT); + PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT); + PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT); } } @@ -1131,68 +1131,68 @@ PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg) { VERIFY_HEAD(f); if (tab->fsize != sizeof(PerlIO_funcs)) { - Perl_croak( aTHX_ - "%s (%" UVuf ") does not match %s (%" UVuf ")", - "PerlIO layer function table size", (UV)tab->fsize, - "size expected by this perl", (UV)sizeof(PerlIO_funcs) ); + Perl_croak( aTHX_ + "%s (%" UVuf ") does not match %s (%" UVuf ")", + "PerlIO layer function table size", (UV)tab->fsize, + "size expected by this perl", (UV)sizeof(PerlIO_funcs) ); } if (tab->size) { - PerlIOl *l; - if (tab->size < sizeof(PerlIOl)) { - Perl_croak( aTHX_ - "%s (%" UVuf ") smaller than %s (%" UVuf ")", - "PerlIO layer instance size", (UV)tab->size, - "size expected by this perl", (UV)sizeof(PerlIOl) ); - } - /* Real layer with a data area */ - if (f) { - char *temp; - Newxz(temp, tab->size, char); - l = (PerlIOl*)temp; - if (l) { - l->next = *f; - l->tab = (PerlIO_funcs*) tab; - l->head = ((PerlIOl*)f)->head; - *f = l; - DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n", + PerlIOl *l; + if (tab->size < sizeof(PerlIOl)) { + Perl_croak( aTHX_ + "%s (%" UVuf ") smaller than %s (%" UVuf ")", + "PerlIO layer instance size", (UV)tab->size, + "size expected by this perl", (UV)sizeof(PerlIOl) ); + } + /* Real layer with a data area */ + if (f) { + char *temp; + Newxz(temp, tab->size, char); + l = (PerlIOl*)temp; + if (l) { + l->next = *f; + l->tab = (PerlIO_funcs*) tab; + l->head = ((PerlIOl*)f)->head; + *f = l; + DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name, (mode) ? mode : "(Null)", (void*)arg) ); - if (*l->tab->Pushed && - (*l->tab->Pushed) - (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) { - PerlIO_pop(aTHX_ f); - return NULL; - } - } - else - return NULL; - } + if (*l->tab->Pushed && + (*l->tab->Pushed) + (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) { + PerlIO_pop(aTHX_ f); + return NULL; + } + } + else + return NULL; + } } else if (f) { - /* Pseudo-layer where push does its own stack adjust */ - DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name, + /* Pseudo-layer where push does its own stack adjust */ + DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name, (mode) ? mode : "(Null)", (void*)arg) ); - if (tab->Pushed && - (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) { - return NULL; - } + if (tab->Pushed && + (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) { + return NULL; + } } return f; } PerlIO * PerlIOBase_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, - IV n, const char *mode, int fd, int imode, int perm, - PerlIO *old, int narg, SV **args) + IV n, const char *mode, int fd, int imode, int perm, + PerlIO *old, int narg, SV **args) { PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_layer(aTHX_ 0)); if (tab && tab->Open) { - PerlIO* ret = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args); - if (ret && PerlIO_push(aTHX_ ret, self, mode, PerlIOArg) == NULL) { - PerlIO_close(ret); - return NULL; - } - return ret; + PerlIO* ret = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args); + if (ret && PerlIO_push(aTHX_ ret, self, mode, PerlIOArg) == NULL) { + PerlIO_close(ret); + return NULL; + } + return ret; } SETERRNO(EINVAL, LIB_INVARG); return NULL; @@ -1202,16 +1202,16 @@ IV PerlIOBase_binmode(pTHX_ PerlIO *f) { if (PerlIOValid(f)) { - /* Is layer suitable for raw stream ? */ - if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) { - /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */ - PerlIOBase(f)->flags &= ~PERLIO_F_UTF8; - } - else { - /* Not suitable - pop it */ - PerlIO_pop(aTHX_ f); - } - return 0; + /* Is layer suitable for raw stream ? */ + if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) { + /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */ + PerlIOBase(f)->flags &= ~PERLIO_F_UTF8; + } + else { + /* Not suitable - pop it */ + PerlIO_pop(aTHX_ f); + } + return 0; } return -1; } @@ -1224,54 +1224,54 @@ PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) PERL_UNUSED_ARG(tab); if (PerlIOValid(f)) { - PerlIO *t; - const PerlIOl *l; - PerlIO_flush(f); - /* - * Strip all layers that are not suitable for a raw stream - */ - t = f; - while (t && (l = *t)) { - if (l->tab && l->tab->Binmode) { - /* Has a handler - normal case */ - if ((*l->tab->Binmode)(aTHX_ t) == 0) { - if (*t == l) { - /* Layer still there - move down a layer */ - t = PerlIONext(t); - } - } - else { - return -1; - } - } - else { - /* No handler - pop it */ - PerlIO_pop(aTHX_ t); - } - } - if (PerlIOValid(f)) { - DEBUG_i( PerlIO_debug(":raw f=%p :%s\n", (void*)f, + PerlIO *t; + const PerlIOl *l; + PerlIO_flush(f); + /* + * Strip all layers that are not suitable for a raw stream + */ + t = f; + while (t && (l = *t)) { + if (l->tab && l->tab->Binmode) { + /* Has a handler - normal case */ + if ((*l->tab->Binmode)(aTHX_ t) == 0) { + if (*t == l) { + /* Layer still there - move down a layer */ + t = PerlIONext(t); + } + } + else { + return -1; + } + } + else { + /* No handler - pop it */ + PerlIO_pop(aTHX_ t); + } + } + if (PerlIOValid(f)) { + DEBUG_i( PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)") ); - return 0; - } + return 0; + } } return -1; } int PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, - PerlIO_list_t *layers, IV n, IV max) + PerlIO_list_t *layers, IV n, IV max) { int code = 0; while (n < max) { - PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL); - if (tab) { - if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) { - code = -1; - break; - } - } - n++; + PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL); + if (tab) { + if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) { + code = -1; + break; + } + } + n++; } return code; } @@ -1283,12 +1283,12 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) ENTER; save_scalar(PL_errgv); if (f && names) { - PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX); - code = PerlIO_parse_layers(aTHX_ layers, names); - if (code == 0) { - code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur); - } - PerlIO_list_free(aTHX_ layers); + PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX); + code = PerlIO_parse_layers(aTHX_ layers, names); + if (code == 0) { + code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur); + } + PerlIO_list_free(aTHX_ layers); } LEAVE; return code; @@ -1313,53 +1313,53 @@ PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names) iotype, mode, (names) ? names : "(Null)") ); if (names) { - /* Do not flush etc. if (e.g.) switching encodings. - if a pushed layer knows it needs to flush lower layers - (for example :unix which is never going to call them) - it can do the flush when it is pushed. - */ - return cBOOL(PerlIO_apply_layers(aTHX_ f, NULL, names) == 0); + /* Do not flush etc. if (e.g.) switching encodings. + if a pushed layer knows it needs to flush lower layers + (for example :unix which is never going to call them) + it can do the flush when it is pushed. + */ + return cBOOL(PerlIO_apply_layers(aTHX_ f, NULL, names) == 0); } else { - /* Fake 5.6 legacy of using this call to turn ON O_TEXT */ + /* Fake 5.6 legacy of using this call to turn ON O_TEXT */ #ifdef PERLIO_USING_CRLF - /* Legacy binmode only has meaning if O_TEXT has a value distinct from - O_BINARY so we can look for it in mode. - */ - if (!(mode & O_BINARY)) { - /* Text mode */ - /* FIXME?: Looking down the layer stack seems wrong, - but is a way of reaching past (say) an encoding layer - to flip CRLF-ness of the layer(s) below - */ - while (*f) { - /* Perhaps we should turn on bottom-most aware layer - e.g. Ilya's idea that UNIX TTY could serve - */ - if (PerlIOBase(f)->tab && - PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) - { - if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) { - /* Not in text mode - flush any pending stuff and flip it */ - PerlIO_flush(f); - PerlIOBase(f)->flags |= PERLIO_F_CRLF; - } - /* Only need to turn it on in one layer so we are done */ - return TRUE; - } - f = PerlIONext(f); - } - /* Not finding a CRLF aware layer presumably means we are binary - which is not what was requested - so we failed - We _could_ push :crlf layer but so could caller - */ - return FALSE; - } + /* Legacy binmode only has meaning if O_TEXT has a value distinct from + O_BINARY so we can look for it in mode. + */ + if (!(mode & O_BINARY)) { + /* Text mode */ + /* FIXME?: Looking down the layer stack seems wrong, + but is a way of reaching past (say) an encoding layer + to flip CRLF-ness of the layer(s) below + */ + while (*f) { + /* Perhaps we should turn on bottom-most aware layer + e.g. Ilya's idea that UNIX TTY could serve + */ + if (PerlIOBase(f)->tab && + PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) + { + if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) { + /* Not in text mode - flush any pending stuff and flip it */ + PerlIO_flush(f); + PerlIOBase(f)->flags |= PERLIO_F_CRLF; + } + /* Only need to turn it on in one layer so we are done */ + return TRUE; + } + f = PerlIONext(f); + } + /* Not finding a CRLF aware layer presumably means we are binary + which is not what was requested - so we failed + We _could_ push :crlf layer but so could caller + */ + return FALSE; + } #endif - /* Legacy binmode is now _defined_ as being equivalent to pushing :raw - So code that used to be here is now in PerlIORaw_pushed(). - */ - return cBOOL(PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL)); + /* Legacy binmode is now _defined_ as being equivalent to pushing :raw + So code that used to be here is now in PerlIORaw_pushed(). + */ + return cBOOL(PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL)); } } @@ -1367,15 +1367,15 @@ int PerlIO__close(pTHX_ PerlIO *f) { if (PerlIOValid(f)) { - PerlIO_funcs * const tab = PerlIOBase(f)->tab; - if (tab && tab->Close) - return (*tab->Close)(aTHX_ f); - else - return PerlIOBase_close(aTHX_ f); + PerlIO_funcs * const tab = PerlIOBase(f)->tab; + if (tab && tab->Close) + return (*tab->Close)(aTHX_ f); + else + return PerlIOBase_close(aTHX_ f); } else { - SETERRNO(EBADF, SS_IVCHAN); - return -1; + SETERRNO(EBADF, SS_IVCHAN); + return -1; } } @@ -1384,10 +1384,10 @@ Perl_PerlIO_close(pTHX_ PerlIO *f) { const int code = PerlIO__close(aTHX_ f); while (PerlIOValid(f)) { - PerlIO_pop(aTHX_ f); - if (PerlIO_lockcnt(f)) - /* we're in use; the 'pop' deferred freeing the structure */ - f = PerlIONext(f); + PerlIO_pop(aTHX_ f); + if (PerlIO_lockcnt(f)) + /* we're in use; the 'pop' deferred freeing the structure */ + f = PerlIONext(f); } return code; } @@ -1406,13 +1406,13 @@ PerlIO_layer_from_ref(pTHX_ SV *sv) * For any scalar type load the handler which is bundled with perl */ if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) { - PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1); - /* This isn't supposed to happen, since PerlIO::scalar is core, - * but could happen anyway in smaller installs or with PAR */ - if (!f) - /* diag_listed_as: Unknown PerlIO layer "%s" */ - Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\""); - return f; + PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1); + /* This isn't supposed to happen, since PerlIO::scalar is core, + * but could happen anyway in smaller installs or with PAR */ + if (!f) + /* diag_listed_as: Unknown PerlIO layer "%s" */ + Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\""); + return f; } /* @@ -1420,156 +1420,156 @@ PerlIO_layer_from_ref(pTHX_ SV *sv) */ switch (SvTYPE(sv)) { case SVt_PVAV: - return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0); + return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0); case SVt_PVHV: - return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0); + return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0); case SVt_PVCV: - return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0); + return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0); case SVt_PVGV: - return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0); + return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0); default: - return NULL; + return NULL; } } PerlIO_list_t * PerlIO_resolve_layers(pTHX_ const char *layers, - const char *mode, int narg, SV **args) + const char *mode, int narg, SV **args) { PerlIO_list_t *def = PerlIO_default_layers(aTHX); int incdef = 1; if (!PL_perlio) - PerlIO_stdstreams(aTHX); + PerlIO_stdstreams(aTHX); if (narg) { - SV * const arg = *args; - /* - * If it is a reference but not an object see if we have a handler - * for it - */ - if (SvROK(arg) && !SvOBJECT(SvRV(arg))) { - PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg)); - if (handler) { - def = PerlIO_list_alloc(aTHX); - PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef); - incdef = 0; - } - /* - * Don't fail if handler cannot be found :via(...) etc. may do - * something sensible else we will just stringfy and open - * resulting string. - */ - } + SV * const arg = *args; + /* + * If it is a reference but not an object see if we have a handler + * for it + */ + if (SvROK(arg) && !SvOBJECT(SvRV(arg))) { + PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg)); + if (handler) { + def = PerlIO_list_alloc(aTHX); + PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef); + incdef = 0; + } + /* + * Don't fail if handler cannot be found :via(...) etc. may do + * something sensible else we will just stringfy and open + * resulting string. + */ + } } if (!layers || !*layers) - layers = Perl_PerlIO_context_layers(aTHX_ mode); + layers = Perl_PerlIO_context_layers(aTHX_ mode); if (layers && *layers) { - PerlIO_list_t *av; - if (incdef) { - av = PerlIO_clone_list(aTHX_ def, NULL); - } - else { - av = def; - } - if (PerlIO_parse_layers(aTHX_ av, layers) == 0) { - return av; - } - else { - PerlIO_list_free(aTHX_ av); - return NULL; - } + PerlIO_list_t *av; + if (incdef) { + av = PerlIO_clone_list(aTHX_ def, NULL); + } + else { + av = def; + } + if (PerlIO_parse_layers(aTHX_ av, layers) == 0) { + return av; + } + else { + PerlIO_list_free(aTHX_ av); + return NULL; + } } else { - if (incdef) - def->refcnt++; - return def; + if (incdef) + def->refcnt++; + return def; } } PerlIO * PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, - int imode, int perm, PerlIO *f, int narg, SV **args) + int imode, int perm, PerlIO *f, int narg, SV **args) { if (!f && narg == 1 && *args == &PL_sv_undef) { imode = PerlIOUnix_oflags(mode); - if (imode != -1 && (f = PerlIO_tmpfile_flags(imode))) { - if (!layers || !*layers) - layers = Perl_PerlIO_context_layers(aTHX_ mode); - if (layers && *layers) - PerlIO_apply_layers(aTHX_ f, mode, layers); - } + if (imode != -1 && (f = PerlIO_tmpfile_flags(imode))) { + if (!layers || !*layers) + layers = Perl_PerlIO_context_layers(aTHX_ mode); + if (layers && *layers) + PerlIO_apply_layers(aTHX_ f, mode, layers); + } } else { - PerlIO_list_t *layera; - IV n; - PerlIO_funcs *tab = NULL; - if (PerlIOValid(f)) { - /* - * This is "reopen" - it is not tested as perl does not use it - * yet - */ - PerlIOl *l = *f; - layera = PerlIO_list_alloc(aTHX); - while (l) { - SV *arg = NULL; - if (l->tab && l->tab->Getarg) - arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0); - PerlIO_list_push(aTHX_ layera, l->tab, - (arg) ? arg : &PL_sv_undef); - SvREFCNT_dec(arg); - l = *PerlIONext(&l); - } - } - else { - layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args); - if (!layera) { - return NULL; - } - } - /* - * Start at "top" of layer stack - */ - n = layera->cur - 1; - while (n >= 0) { - PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL); - if (t && t->Open) { - tab = t; - break; - } - n--; - } - if (tab) { - /* - * Found that layer 'n' can do opens - call it - */ - if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) { - Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name); - } - DEBUG_i( PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n", + PerlIO_list_t *layera; + IV n; + PerlIO_funcs *tab = NULL; + if (PerlIOValid(f)) { + /* + * This is "reopen" - it is not tested as perl does not use it + * yet + */ + PerlIOl *l = *f; + layera = PerlIO_list_alloc(aTHX); + while (l) { + SV *arg = NULL; + if (l->tab && l->tab->Getarg) + arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0); + PerlIO_list_push(aTHX_ layera, l->tab, + (arg) ? arg : &PL_sv_undef); + SvREFCNT_dec(arg); + l = *PerlIONext(&l); + } + } + else { + layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args); + if (!layera) { + return NULL; + } + } + /* + * Start at "top" of layer stack + */ + n = layera->cur - 1; + while (n >= 0) { + PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL); + if (t && t->Open) { + tab = t; + break; + } + n--; + } + if (tab) { + /* + * Found that layer 'n' can do opens - call it + */ + if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) { + Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name); + } + DEBUG_i( PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n", tab->name, layers ? layers : "(Null)", mode, fd, imode, perm, (void*)f, narg, (void*)args) ); - if (tab->Open) - f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm, - f, narg, args); - else { - SETERRNO(EINVAL, LIB_INVARG); - f = NULL; - } - if (f) { - if (n + 1 < layera->cur) { - /* - * More layers above the one that we used to open - - * apply them now - */ - if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) { - /* If pushing layers fails close the file */ - PerlIO_close(f); - f = NULL; - } - } - } - } - PerlIO_list_free(aTHX_ layera); + if (tab->Open) + f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm, + f, narg, args); + else { + SETERRNO(EINVAL, LIB_INVARG); + f = NULL; + } + if (f) { + if (n + 1 < layera->cur) { + /* + * More layers above the one that we used to open - + * apply them now + */ + if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) { + /* If pushing layers fails close the file */ + PerlIO_close(f); + f = NULL; + } + } + } + } + PerlIO_list_free(aTHX_ layera); } return f; } @@ -1615,41 +1615,41 @@ int Perl_PerlIO_flush(pTHX_ PerlIO *f) { if (f) { - if (*f) { - const PerlIO_funcs *tab = PerlIOBase(f)->tab; - - if (tab && tab->Flush) - return (*tab->Flush) (aTHX_ f); - else - return 0; /* If no Flush defined, silently succeed. */ - } - else { - DEBUG_i( PerlIO_debug("Cannot flush f=%p\n", (void*)f) ); - SETERRNO(EBADF, SS_IVCHAN); - return -1; - } + if (*f) { + const PerlIO_funcs *tab = PerlIOBase(f)->tab; + + if (tab && tab->Flush) + return (*tab->Flush) (aTHX_ f); + else + return 0; /* If no Flush defined, silently succeed. */ + } + else { + DEBUG_i( PerlIO_debug("Cannot flush f=%p\n", (void*)f) ); + SETERRNO(EBADF, SS_IVCHAN); + return -1; + } } else { - /* - * Is it good API design to do flush-all on NULL, a potentially - * erroneous input? Maybe some magical value (PerlIO* - * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar - * things on fflush(NULL), but should we be bound by their design - * decisions? --jhi - */ - PerlIOl **table = &PL_perlio; - PerlIOl *ff; - int code = 0; - while ((ff = *table)) { - int i; - table = (PerlIOl **) (ff++); - for (i = 1; i < PERLIO_TABLE_SIZE; i++) { - if (ff->next && PerlIO_flush(&(ff->next)) != 0) - code = -1; - ff++; - } - } - return code; + /* + * Is it good API design to do flush-all on NULL, a potentially + * erroneous input? Maybe some magical value (PerlIO* + * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar + * things on fflush(NULL), but should we be bound by their design + * decisions? --jhi + */ + PerlIOl **table = &PL_perlio; + PerlIOl *ff; + int code = 0; + while ((ff = *table)) { + int i; + table = (PerlIOl **) (ff++); + for (i = 1; i < PERLIO_TABLE_SIZE; i++) { + if (ff->next && PerlIO_flush(&(ff->next)) != 0) + code = -1; + ff++; + } + } + return code; } } @@ -1659,16 +1659,16 @@ PerlIOBase_flush_linebuf(pTHX) PerlIOl **table = &PL_perlio; PerlIOl *f; while ((f = *table)) { - int i; - table = (PerlIOl **) (f++); - for (i = 1; i < PERLIO_TABLE_SIZE; i++) { - if (f->next - && (PerlIOBase(&(f->next))-> - flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE)) - == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE)) - PerlIO_flush(&(f->next)); - f++; - } + int i; + table = (PerlIOl **) (f++); + for (i = 1; i < PERLIO_TABLE_SIZE; i++) { + if (f->next + && (PerlIOBase(&(f->next))-> + flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE)) + == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE)) + PerlIO_flush(&(f->next)); + f++; + } } } @@ -1682,9 +1682,9 @@ int PerlIO_isutf8(PerlIO *f) { if (PerlIOValid(f)) - return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0; + return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0; else - SETERRNO(EBADF, SS_IVCHAN); + SETERRNO(EBADF, SS_IVCHAN); return -1; } @@ -1717,10 +1717,10 @@ int PerlIO_has_base(PerlIO *f) { if (PerlIOValid(f)) { - const PerlIO_funcs * const tab = PerlIOBase(f)->tab; + const PerlIO_funcs * const tab = PerlIOBase(f)->tab; - if (tab) - return (tab->Get_base != NULL); + if (tab) + return (tab->Get_base != NULL); } return 0; @@ -1730,12 +1730,12 @@ int PerlIO_fast_gets(PerlIO *f) { if (PerlIOValid(f)) { - if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) { - const PerlIO_funcs * const tab = PerlIOBase(f)->tab; + if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) { + const PerlIO_funcs * const tab = PerlIOBase(f)->tab; - if (tab) - return (tab->Set_ptrcnt != NULL); - } + if (tab) + return (tab->Set_ptrcnt != NULL); + } } return 0; @@ -1745,10 +1745,10 @@ int PerlIO_has_cntptr(PerlIO *f) { if (PerlIOValid(f)) { - const PerlIO_funcs * const tab = PerlIOBase(f)->tab; + const PerlIO_funcs * const tab = PerlIOBase(f)->tab; - if (tab) - return (tab->Get_ptr != NULL && tab->Get_cnt != NULL); + if (tab) + return (tab->Get_ptr != NULL && tab->Get_cnt != NULL); } return 0; @@ -1758,10 +1758,10 @@ int PerlIO_canset_cnt(PerlIO *f) { if (PerlIOValid(f)) { - const PerlIO_funcs * const tab = PerlIOBase(f)->tab; + const PerlIO_funcs * const tab = PerlIOBase(f)->tab; - if (tab) - return (tab->Set_ptrcnt != NULL); + if (tab) + return (tab->Set_ptrcnt != NULL); } return 0; @@ -1817,11 +1817,11 @@ PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) PERL_UNUSED_ARG(mode); PERL_UNUSED_ARG(arg); if (PerlIOValid(f)) { - if (tab && tab->kind & PERLIO_K_UTF8) - PerlIOBase(f)->flags |= PERLIO_F_UTF8; - else - PerlIOBase(f)->flags &= ~PERLIO_F_UTF8; - return 0; + if (tab && tab->kind & PERLIO_K_UTF8) + PerlIOBase(f)->flags |= PERLIO_F_UTF8; + else + PerlIOBase(f)->flags &= ~PERLIO_F_UTF8; + return 0; } return -1; } @@ -1935,27 +1935,27 @@ PerlIO_modestr(PerlIO * f, char *buf) { char *s = buf; if (PerlIOValid(f)) { - const IV flags = PerlIOBase(f)->flags; - if (flags & PERLIO_F_APPEND) { - *s++ = 'a'; - if (flags & PERLIO_F_CANREAD) { - *s++ = '+'; - } - } - else if (flags & PERLIO_F_CANREAD) { - *s++ = 'r'; - if (flags & PERLIO_F_CANWRITE) - *s++ = '+'; - } - else if (flags & PERLIO_F_CANWRITE) { - *s++ = 'w'; - if (flags & PERLIO_F_CANREAD) { - *s++ = '+'; - } - } + const IV flags = PerlIOBase(f)->flags; + if (flags & PERLIO_F_APPEND) { + *s++ = 'a'; + if (flags & PERLIO_F_CANREAD) { + *s++ = '+'; + } + } + else if (flags & PERLIO_F_CANREAD) { + *s++ = 'r'; + if (flags & PERLIO_F_CANWRITE) + *s++ = '+'; + } + else if (flags & PERLIO_F_CANWRITE) { + *s++ = 'w'; + if (flags & PERLIO_F_CANREAD) { + *s++ = '+'; + } + } #ifdef PERLIO_USING_CRLF - if (!(flags & PERLIO_F_CRLF)) - *s++ = 'b'; + if (!(flags & PERLIO_F_CRLF)) + *s++ = 'b'; #endif } *s = '\0'; @@ -1971,87 +1971,87 @@ PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) PERL_UNUSED_ARG(arg); l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | - PERLIO_F_TRUNCATE | PERLIO_F_APPEND); + PERLIO_F_TRUNCATE | PERLIO_F_APPEND); if (tab && tab->Set_ptrcnt != NULL) - l->flags |= PERLIO_F_FASTGETS; + l->flags |= PERLIO_F_FASTGETS; if (mode) { - if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT) - mode++; - switch (*mode++) { - case 'r': - l->flags |= PERLIO_F_CANREAD; - break; - case 'a': - l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE; - break; - case 'w': - l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE; - break; - default: - SETERRNO(EINVAL, LIB_INVARG); - return -1; - } + if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT) + mode++; + switch (*mode++) { + case 'r': + l->flags |= PERLIO_F_CANREAD; + break; + case 'a': + l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE; + break; + case 'w': + l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE; + break; + default: + SETERRNO(EINVAL, LIB_INVARG); + return -1; + } #ifdef EBCDIC - { + { /* The mode variable contains one positional parameter followed by * optional keyword parameters. The positional parameters must be * passed as lowercase characters. The keyword parameters can be * passed in mixed case. They must be separated by commas. Only one * instance of a keyword can be specified. */ - int comma = 0; - while (*mode) { - switch (*mode++) { - case '+': - if(!comma) - l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE; - break; - case 'b': - if(!comma) - l->flags &= ~PERLIO_F_CRLF; - break; - case 't': - if(!comma) - l->flags |= PERLIO_F_CRLF; - break; - case ',': - comma = 1; - break; - default: - break; - } - } - } + int comma = 0; + while (*mode) { + switch (*mode++) { + case '+': + if(!comma) + l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE; + break; + case 'b': + if(!comma) + l->flags &= ~PERLIO_F_CRLF; + break; + case 't': + if(!comma) + l->flags |= PERLIO_F_CRLF; + break; + case ',': + comma = 1; + break; + default: + break; + } + } + } #else - while (*mode) { - switch (*mode++) { - case '+': - l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE; - break; - case 'b': - l->flags &= ~PERLIO_F_CRLF; - break; - case 't': - l->flags |= PERLIO_F_CRLF; - break; - default: - SETERRNO(EINVAL, LIB_INVARG); - return -1; - } - } + while (*mode) { + switch (*mode++) { + case '+': + l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE; + break; + case 'b': + l->flags &= ~PERLIO_F_CRLF; + break; + case 't': + l->flags |= PERLIO_F_CRLF; + break; + default: + SETERRNO(EINVAL, LIB_INVARG); + return -1; + } + } #endif } else { - if (l->next) { - l->flags |= l->next->flags & - (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE | - PERLIO_F_APPEND); - } + if (l->next) { + l->flags |= l->next->flags & + (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE | + PERLIO_F_APPEND); + } } #if 0 DEBUG_i( PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n", - (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)", - l->flags, PerlIO_modestr(f, temp)); + (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)", + l->flags, PerlIO_modestr(f, temp)); ); #endif return 0; @@ -2083,34 +2083,34 @@ PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) STDCHAR *buf = (STDCHAR *) vbuf; if (f) { if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) { - PerlIOBase(f)->flags |= PERLIO_F_ERROR; - SETERRNO(EBADF, SS_IVCHAN); - PerlIO_save_errno(f); - return 0; - } - while (count > 0) { - get_cnt: - { - SSize_t avail = PerlIO_get_cnt(f); - SSize_t take = 0; - if (avail > 0) - take = (((SSize_t) count >= 0) && ((SSize_t)count < avail)) ? (SSize_t)count : avail; - if (take > 0) { - STDCHAR *ptr = PerlIO_get_ptr(f); - Copy(ptr, buf, take, STDCHAR); - PerlIO_set_ptrcnt(f, ptr + take, (avail -= take)); - count -= take; - buf += take; - if (avail == 0) /* set_ptrcnt could have reset avail */ - goto get_cnt; - } - if (count > 0 && avail <= 0) { - if (PerlIO_fill(f) != 0) - break; - } - } - } - return (buf - (STDCHAR *) vbuf); + PerlIOBase(f)->flags |= PERLIO_F_ERROR; + SETERRNO(EBADF, SS_IVCHAN); + PerlIO_save_errno(f); + return 0; + } + while (count > 0) { + get_cnt: + { + SSize_t avail = PerlIO_get_cnt(f); + SSize_t take = 0; + if (avail > 0) + take = (((SSize_t) count >= 0) && ((SSize_t)count < avail)) ? (SSize_t)count : avail; + if (take > 0) { + STDCHAR *ptr = PerlIO_get_ptr(f); + Copy(ptr, buf, take, STDCHAR); + PerlIO_set_ptrcnt(f, ptr + take, (avail -= take)); + count -= take; + buf += take; + if (avail == 0) /* set_ptrcnt could have reset avail */ + goto get_cnt; + } + if (count > 0 && avail <= 0) { + if (PerlIO_fill(f) != 0) + break; + } + } + } + return (buf - (STDCHAR *) vbuf); } return 0; } @@ -2136,26 +2136,26 @@ PerlIOBase_close(pTHX_ PerlIO *f) { IV code = -1; if (PerlIOValid(f)) { - PerlIO *n = PerlIONext(f); - code = PerlIO_flush(f); - PerlIOBase(f)->flags &= - ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN); - while (PerlIOValid(n)) { - const PerlIO_funcs * const tab = PerlIOBase(n)->tab; - if (tab && tab->Close) { - if ((*tab->Close)(aTHX_ n) != 0) - code = -1; - break; - } - else { - PerlIOBase(n)->flags &= - ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN); - } - n = PerlIONext(n); - } + PerlIO *n = PerlIONext(f); + code = PerlIO_flush(f); + PerlIOBase(f)->flags &= + ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN); + while (PerlIOValid(n)) { + const PerlIO_funcs * const tab = PerlIOBase(n)->tab; + if (tab && tab->Close) { + if ((*tab->Close)(aTHX_ n) != 0) + code = -1; + break; + } + else { + PerlIOBase(n)->flags &= + ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN); + } + n = PerlIONext(n); + } } else { - SETERRNO(EBADF, SS_IVCHAN); + SETERRNO(EBADF, SS_IVCHAN); } return code; } @@ -2165,7 +2165,7 @@ PerlIOBase_eof(pTHX_ PerlIO *f) { PERL_UNUSED_CONTEXT; if (PerlIOValid(f)) { - return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0; + return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0; } return 1; } @@ -2175,7 +2175,7 @@ PerlIOBase_error(pTHX_ PerlIO *f) { PERL_UNUSED_CONTEXT; if (PerlIOValid(f)) { - return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0; + return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0; } return 1; } @@ -2184,10 +2184,10 @@ void PerlIOBase_clearerr(pTHX_ PerlIO *f) { if (PerlIOValid(f)) { - PerlIO * const n = PerlIONext(f); - PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF); - if (PerlIOValid(n)) - PerlIO_clearerr(n); + PerlIO * const n = PerlIONext(f); + PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF); + if (PerlIOValid(n)) + PerlIO_clearerr(n); } } @@ -2196,7 +2196,7 @@ PerlIOBase_setlinebuf(pTHX_ PerlIO *f) { PERL_UNUSED_CONTEXT; if (PerlIOValid(f)) { - PerlIOBase(f)->flags |= PERLIO_F_LINEBUF; + PerlIOBase(f)->flags |= PERLIO_F_LINEBUF; } } @@ -2204,15 +2204,15 @@ SV * PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param) { if (!arg) - return NULL; + return NULL; #ifdef USE_ITHREADS if (param) { - arg = sv_dup(arg, param); - SvREFCNT_inc_simple_void_NN(arg); - return arg; + arg = sv_dup(arg, param); + SvREFCNT_inc_simple_void_NN(arg); + return arg; } else { - return newSVsv(arg); + return newSVsv(arg); } #else PERL_UNUSED_ARG(param); @@ -2225,26 +2225,26 @@ PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) { PerlIO * const nexto = PerlIONext(o); if (PerlIOValid(nexto)) { - const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab; - if (tab && tab->Dup) - f = (*tab->Dup)(aTHX_ f, nexto, param, flags); - else - f = PerlIOBase_dup(aTHX_ f, nexto, param, flags); + const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab; + if (tab && tab->Dup) + f = (*tab->Dup)(aTHX_ f, nexto, param, flags); + else + f = PerlIOBase_dup(aTHX_ f, nexto, param, flags); } if (f) { - PerlIO_funcs * const self = PerlIOBase(o)->tab; - SV *arg = NULL; - char buf[8]; - assert(self); - DEBUG_i(PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n", + PerlIO_funcs * const self = PerlIOBase(o)->tab; + SV *arg = NULL; + char buf[8]; + assert(self); + DEBUG_i(PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n", self->name, (void*)f, (void*)o, (void*)param) ); - if (self->Getarg) - arg = (*self->Getarg)(aTHX_ o, param, flags); - f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg); - if (f && PerlIOBase(o)->flags & PERLIO_F_UTF8) - PerlIOBase(f)->flags |= PERLIO_F_UTF8; - SvREFCNT_dec(arg); + if (self->Getarg) + arg = (*self->Getarg)(aTHX_ o, param, flags); + f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg); + if (f && PerlIOBase(o)->flags & PERLIO_F_UTF8) + PerlIOBase(f)->flags |= PERLIO_F_UTF8; + SvREFCNT_dec(arg); } return f; } @@ -2268,7 +2268,7 @@ S_more_refcounted_fds(pTHX_ const int new_fd) old_max, new_fd, new_max) ); if (new_fd < old_max) { - return; + return; } assert (new_max > new_fd); @@ -2278,8 +2278,8 @@ S_more_refcounted_fds(pTHX_ const int new_fd) new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int)); if (!new_array) { - MUTEX_UNLOCK(&PL_perlio_mutex); - croak_no_mem(); + MUTEX_UNLOCK(&PL_perlio_mutex); + croak_no_mem(); } PL_perlio_fd_refcnt_size = new_max; @@ -2306,23 +2306,23 @@ PerlIOUnix_refcnt_inc(int fd) dTHX; if (fd >= 0) { - MUTEX_LOCK(&PL_perlio_mutex); - if (fd >= PL_perlio_fd_refcnt_size) - S_more_refcounted_fds(aTHX_ fd); - - PL_perlio_fd_refcnt[fd]++; - if (PL_perlio_fd_refcnt[fd] <= 0) { - /* diag_listed_as: refcnt_inc: fd %d%s */ - Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n", - fd, PL_perlio_fd_refcnt[fd]); - } - DEBUG_i( PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n", + MUTEX_LOCK(&PL_perlio_mutex); + if (fd >= PL_perlio_fd_refcnt_size) + S_more_refcounted_fds(aTHX_ fd); + + PL_perlio_fd_refcnt[fd]++; + if (PL_perlio_fd_refcnt[fd] <= 0) { + /* diag_listed_as: refcnt_inc: fd %d%s */ + Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n", + fd, PL_perlio_fd_refcnt[fd]); + } + DEBUG_i( PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n", fd, PL_perlio_fd_refcnt[fd]) ); - MUTEX_UNLOCK(&PL_perlio_mutex); + MUTEX_UNLOCK(&PL_perlio_mutex); } else { - /* diag_listed_as: refcnt_inc: fd %d%s */ - Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd); + /* diag_listed_as: refcnt_inc: fd %d%s */ + Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd); } } @@ -2334,23 +2334,23 @@ PerlIOUnix_refcnt_dec(int fd) #ifdef DEBUGGING dTHX; #endif - MUTEX_LOCK(&PL_perlio_mutex); - if (fd >= PL_perlio_fd_refcnt_size) { - /* diag_listed_as: refcnt_dec: fd %d%s */ - Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n", - fd, PL_perlio_fd_refcnt_size); - } - if (PL_perlio_fd_refcnt[fd] <= 0) { - /* diag_listed_as: refcnt_dec: fd %d%s */ - Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n", - fd, PL_perlio_fd_refcnt[fd]); - } - cnt = --PL_perlio_fd_refcnt[fd]; - DEBUG_i( PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt) ); - MUTEX_UNLOCK(&PL_perlio_mutex); + MUTEX_LOCK(&PL_perlio_mutex); + if (fd >= PL_perlio_fd_refcnt_size) { + /* diag_listed_as: refcnt_dec: fd %d%s */ + Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n", + fd, PL_perlio_fd_refcnt_size); + } + if (PL_perlio_fd_refcnt[fd] <= 0) { + /* diag_listed_as: refcnt_dec: fd %d%s */ + Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n", + fd, PL_perlio_fd_refcnt[fd]); + } + cnt = --PL_perlio_fd_refcnt[fd]; + DEBUG_i( PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt) ); + MUTEX_UNLOCK(&PL_perlio_mutex); } else { - /* diag_listed_as: refcnt_dec: fd %d%s */ - Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd); + /* diag_listed_as: refcnt_dec: fd %d%s */ + Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd); } return cnt; } @@ -2361,22 +2361,22 @@ PerlIOUnix_refcnt(int fd) dTHX; int cnt = 0; if (fd >= 0) { - MUTEX_LOCK(&PL_perlio_mutex); - if (fd >= PL_perlio_fd_refcnt_size) { - /* diag_listed_as: refcnt: fd %d%s */ - Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n", - fd, PL_perlio_fd_refcnt_size); - } - if (PL_perlio_fd_refcnt[fd] <= 0) { - /* diag_listed_as: refcnt: fd %d%s */ - Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n", - fd, PL_perlio_fd_refcnt[fd]); - } - cnt = PL_perlio_fd_refcnt[fd]; - MUTEX_UNLOCK(&PL_perlio_mutex); + MUTEX_LOCK(&PL_perlio_mutex); + if (fd >= PL_perlio_fd_refcnt_size) { + /* diag_listed_as: refcnt: fd %d%s */ + Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n", + fd, PL_perlio_fd_refcnt_size); + } + if (PL_perlio_fd_refcnt[fd] <= 0) { + /* diag_listed_as: refcnt: fd %d%s */ + Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n", + fd, PL_perlio_fd_refcnt[fd]); + } + cnt = PL_perlio_fd_refcnt[fd]; + MUTEX_UNLOCK(&PL_perlio_mutex); } else { - /* diag_listed_as: refcnt: fd %d%s */ - Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd); + /* diag_listed_as: refcnt: fd %d%s */ + Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd); } return cnt; } @@ -2393,19 +2393,19 @@ PerlIO_cleanup(pTHX) /* Raise STDIN..STDERR refcount so we don't close them */ for (i=0; i < 3; i++) - PerlIOUnix_refcnt_inc(i); + PerlIOUnix_refcnt_inc(i); PerlIO_cleantable(aTHX_ &PL_perlio); /* Restore STDIN..STDERR refcount */ for (i=0; i < 3; i++) - PerlIOUnix_refcnt_dec(i); + PerlIOUnix_refcnt_dec(i); if (PL_known_layers) { - PerlIO_list_free(aTHX_ PL_known_layers); - PL_known_layers = NULL; + PerlIO_list_free(aTHX_ PL_known_layers); + PL_known_layers = NULL; } if (PL_def_layerlist) { - PerlIO_list_free(aTHX_ PL_def_layerlist); - PL_def_layerlist = NULL; + PerlIO_list_free(aTHX_ PL_def_layerlist); + PL_def_layerlist = NULL; } } @@ -2419,22 +2419,22 @@ void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */ */ # ifdef DEBUGGING { - /* By now all filehandles should have been closed, so any - * stray (non-STD-)filehandles indicate *possible* (PerlIO) - * errors. */ + /* By now all filehandles should have been closed, so any + * stray (non-STD-)filehandles indicate *possible* (PerlIO) + * errors. */ #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64 #define PERLIO_TEARDOWN_MESSAGE_FD 2 - char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE]; - int i; - for (i = 3; i < PL_perlio_fd_refcnt_size; i++) { - if (PL_perlio_fd_refcnt[i]) { - const STRLEN len = - my_snprintf(buf, sizeof(buf), - "PerlIO_teardown: fd %d refcnt=%d\n", - i, PL_perlio_fd_refcnt[i]); - PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len); - } - } + char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE]; + int i; + for (i = 3; i < PL_perlio_fd_refcnt_size; i++) { + if (PL_perlio_fd_refcnt[i]) { + const STRLEN len = + my_snprintf(buf, sizeof(buf), + "PerlIO_teardown: fd %d refcnt=%d\n", + i, PL_perlio_fd_refcnt[i]); + PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len); + } + } } # endif #endif @@ -2442,9 +2442,9 @@ void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */ * all the interpreters are gone. */ if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */ && PL_perlio_fd_refcnt) { - free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */ - PL_perlio_fd_refcnt = NULL; - PL_perlio_fd_refcnt_size = 0; + free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */ + PL_perlio_fd_refcnt = NULL; + PL_perlio_fd_refcnt_size = 0; } } @@ -2479,19 +2479,19 @@ S_perlio_async_run(pTHX_ PerlIO* f) { PerlIO_lockcnt(f)++; PERL_ASYNC_CHECK(); if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) { - LEAVE; - return 0; + LEAVE; + return 0; } /* we've just run some perl-level code that could have done * anything, including closing the file or clearing this layer. * If so, free any lower layers that have already been * cleared, then return an error. */ while (PerlIOValid(f) && - (PerlIOBase(f)->flags & PERLIO_F_CLEARED)) + (PerlIOBase(f)->flags & PERLIO_F_CLEARED)) { - const PerlIOl *l = *f; - *f = l->next; - Safefree(l); + const PerlIOl *l = *f; + *f = l->next; + Safefree(l); } LEAVE; return 1; @@ -2502,35 +2502,35 @@ PerlIOUnix_oflags(const char *mode) { int oflags = -1; if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC) - mode++; + mode++; switch (*mode) { case 'r': - oflags = O_RDONLY; - if (*++mode == '+') { - oflags = O_RDWR; - mode++; - } - break; + oflags = O_RDONLY; + if (*++mode == '+') { + oflags = O_RDWR; + mode++; + } + break; case 'w': - oflags = O_CREAT | O_TRUNC; - if (*++mode == '+') { - oflags |= O_RDWR; - mode++; - } - else - oflags |= O_WRONLY; - break; + oflags = O_CREAT | O_TRUNC; + if (*++mode == '+') { + oflags |= O_RDWR; + mode++; + } + else + oflags |= O_WRONLY; + break; case 'a': - oflags = O_CREAT | O_APPEND; - if (*++mode == '+') { - oflags |= O_RDWR; - mode++; - } - else - oflags |= O_WRONLY; - break; + oflags = O_CREAT | O_APPEND; + if (*++mode == '+') { + oflags |= O_RDWR; + mode++; + } + else + oflags |= O_WRONLY; + break; } /* XXX TODO: PerlIO_open() test that exercises 'rb' and 'rt'. */ @@ -2542,35 +2542,35 @@ PerlIOUnix_oflags(const char *mode) case 'b': #if O_TEXT != O_BINARY oflags |= O_BINARY; - oflags &= ~O_TEXT; + oflags &= ~O_TEXT; #endif mode++; break; case 't': #if O_TEXT != O_BINARY - oflags |= O_TEXT; - oflags &= ~O_BINARY; + oflags |= O_TEXT; + oflags &= ~O_BINARY; #endif mode++; break; default: #if O_BINARY != 0 /* bit-or:ing with zero O_BINARY would be useless. */ - /* - * If neither "t" nor "b" was specified, open the file - * in O_BINARY mode. + /* + * If neither "t" nor "b" was specified, open the file + * in O_BINARY mode. * * Note that if something else than the zero byte was seen * here (e.g. bogus mode "rx"), just few lines later we will * set the errno and invalidate the flags. - */ - oflags |= O_BINARY; + */ + oflags |= O_BINARY; #endif break; } if (*mode || oflags == -1) { - SETERRNO(EINVAL, LIB_INVARG); - oflags = -1; + SETERRNO(EINVAL, LIB_INVARG); + oflags = -1; } return oflags; } @@ -2589,13 +2589,13 @@ PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode) #if defined(WIN32) Stat_t st; if (PerlLIO_fstat(fd, &st) == 0) { - if (!S_ISREG(st.st_mode)) { - DEBUG_i( PerlIO_debug("%d is not regular file\n",fd) ); - PerlIOBase(f)->flags |= PERLIO_F_NOTREG; - } - else { - DEBUG_i( PerlIO_debug("%d _is_ a regular file\n",fd) ); - } + if (!S_ISREG(st.st_mode)) { + DEBUG_i( PerlIO_debug("%d is not regular file\n",fd) ); + PerlIOBase(f)->flags |= PERLIO_F_NOTREG; + } + else { + DEBUG_i( PerlIO_debug("%d _is_ a regular file\n",fd) ); + } } #endif s->fd = fd; @@ -2609,13 +2609,13 @@ PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) { IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab); if (*PerlIONext(f)) { - /* We never call down so do any pending stuff now */ - PerlIO_flush(PerlIONext(f)); - /* - * XXX could (or should) we retrieve the oflags from the open file - * handle rather than believing the "mode" we are passed in? XXX - * Should the value on NULL mode be 0 or -1? - */ + /* We never call down so do any pending stuff now */ + PerlIO_flush(PerlIONext(f)); + /* + * XXX could (or should) we retrieve the oflags from the open file + * handle rather than believing the "mode" we are passed in? XXX + * Should the value on NULL mode be 0 or -1? + */ PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)), mode ? PerlIOUnix_oflags(mode) : -1); } @@ -2632,79 +2632,79 @@ PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence) PERL_UNUSED_CONTEXT; if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) { #ifdef ESPIPE - SETERRNO(ESPIPE, LIB_INVARG); + SETERRNO(ESPIPE, LIB_INVARG); #else - SETERRNO(EINVAL, LIB_INVARG); + SETERRNO(EINVAL, LIB_INVARG); #endif - return -1; + return -1; } new_loc = PerlLIO_lseek(fd, offset, whence); if (new_loc == (Off_t) - 1) - return -1; + return -1; PerlIOBase(f)->flags &= ~PERLIO_F_EOF; return 0; } PerlIO * PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, - IV n, const char *mode, int fd, int imode, - int perm, PerlIO *f, int narg, SV **args) + IV n, const char *mode, int fd, int imode, + int perm, PerlIO *f, int narg, SV **args) { bool known_cloexec = 0; if (PerlIOValid(f)) { - if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN) - (*PerlIOBase(f)->tab->Close)(aTHX_ f); + if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN) + (*PerlIOBase(f)->tab->Close)(aTHX_ f); } if (narg > 0) { - if (*mode == IoTYPE_NUMERIC) - mode++; - else { - imode = PerlIOUnix_oflags(mode); + if (*mode == IoTYPE_NUMERIC) + mode++; + else { + imode = PerlIOUnix_oflags(mode); #ifdef VMS - perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */ + perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */ #else - perm = 0666; + perm = 0666; #endif - } - if (imode != -1) { + } + if (imode != -1) { STRLEN len; - const char *path = SvPV_const(*args, len); - if (!IS_SAFE_PATHNAME(path, len, "open")) + const char *path = SvPV_const(*args, len); + if (!IS_SAFE_PATHNAME(path, len, "open")) return NULL; - fd = PerlLIO_open3_cloexec(path, imode, perm); - known_cloexec = 1; - } + fd = PerlLIO_open3_cloexec(path, imode, perm); + known_cloexec = 1; + } } if (fd >= 0) { - if (known_cloexec) - setfd_inhexec_for_sysfd(fd); - else - setfd_cloexec_or_inhexec_by_sysfdness(fd); - if (*mode == IoTYPE_IMPLICIT) - mode++; - if (!f) { - f = PerlIO_allocate(aTHX); - } - if (!PerlIOValid(f)) { - if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) { - PerlLIO_close(fd); - return NULL; - } - } + if (known_cloexec) + setfd_inhexec_for_sysfd(fd); + else + setfd_cloexec_or_inhexec_by_sysfdness(fd); + if (*mode == IoTYPE_IMPLICIT) + mode++; + if (!f) { + f = PerlIO_allocate(aTHX); + } + if (!PerlIOValid(f)) { + if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) { + PerlLIO_close(fd); + return NULL; + } + } PerlIOUnix_setfd(aTHX_ f, fd, imode); - PerlIOBase(f)->flags |= PERLIO_F_OPEN; - if (*mode == IoTYPE_APPEND) - PerlIOUnix_seek(aTHX_ f, 0, SEEK_END); - return f; + PerlIOBase(f)->flags |= PERLIO_F_OPEN; + if (*mode == IoTYPE_APPEND) + PerlIOUnix_seek(aTHX_ f, 0, SEEK_END); + return f; } else { - if (f) { - NOOP; - /* - * FIXME: pop layers ??? - */ - } - return NULL; + if (f) { + NOOP; + /* + * FIXME: pop layers ??? + */ + } + return NULL; } } @@ -2714,17 +2714,17 @@ PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix); int fd = os->fd; if (flags & PERLIO_DUP_FD) { - fd = PerlLIO_dup_cloexec(fd); - if (fd >= 0) - setfd_inhexec_for_sysfd(fd); + fd = PerlLIO_dup_cloexec(fd); + if (fd >= 0) + setfd_inhexec_for_sysfd(fd); } if (fd >= 0) { - f = PerlIOBase_dup(aTHX_ f, o, param, flags); - if (f) { - /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */ - PerlIOUnix_setfd(aTHX_ f, fd, os->oflags); - return f; - } + f = PerlIOBase_dup(aTHX_ f, o, param, flags); + if (f) { + /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */ + PerlIOUnix_setfd(aTHX_ f, fd, os->oflags); + return f; + } PerlLIO_close(fd); } return NULL; @@ -2736,30 +2736,30 @@ PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) { int fd; if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ - return -1; + return -1; fd = PerlIOSelf(f, PerlIOUnix)->fd; if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) || PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) { - return 0; + return 0; } while (1) { - const SSize_t len = PerlLIO_read(fd, vbuf, count); - if (len >= 0 || errno != EINTR) { - if (len < 0) { - if (errno != EAGAIN) { - PerlIOBase(f)->flags |= PERLIO_F_ERROR; - PerlIO_save_errno(f); - } - } - else if (len == 0 && count != 0) { - PerlIOBase(f)->flags |= PERLIO_F_EOF; - SETERRNO(0,0); - } - return len; - } - /* EINTR */ - if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) - return -1; + const SSize_t len = PerlLIO_read(fd, vbuf, count); + if (len >= 0 || errno != EINTR) { + if (len < 0) { + if (errno != EAGAIN) { + PerlIOBase(f)->flags |= PERLIO_F_ERROR; + PerlIO_save_errno(f); + } + } + else if (len == 0 && count != 0) { + PerlIOBase(f)->flags |= PERLIO_F_EOF; + SETERRNO(0,0); + } + return len; + } + /* EINTR */ + if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) + return -1; } NOT_REACHED; /*NOTREACHED*/ } @@ -2769,22 +2769,22 @@ PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) { int fd; if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ - return -1; + return -1; fd = PerlIOSelf(f, PerlIOUnix)->fd; while (1) { - const SSize_t len = PerlLIO_write(fd, vbuf, count); - if (len >= 0 || errno != EINTR) { - if (len < 0) { - if (errno != EAGAIN) { - PerlIOBase(f)->flags |= PERLIO_F_ERROR; - PerlIO_save_errno(f); - } - } - return len; - } - /* EINTR */ - if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) - return -1; + const SSize_t len = PerlLIO_write(fd, vbuf, count); + if (len >= 0 || errno != EINTR) { + if (len < 0) { + if (errno != EAGAIN) { + PerlIOBase(f)->flags |= PERLIO_F_ERROR; + PerlIO_save_errno(f); + } + } + return len; + } + /* EINTR */ + if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) + return -1; } NOT_REACHED; /*NOTREACHED*/ } @@ -2805,26 +2805,26 @@ PerlIOUnix_close(pTHX_ PerlIO *f) int code = 0; if (PerlIOBase(f)->flags & PERLIO_F_OPEN) { code = PerlIOBase_close(aTHX_ f); - if (PerlIOUnix_refcnt_dec(fd) > 0) { - PerlIOBase(f)->flags &= ~PERLIO_F_OPEN; - return 0; - } + if (PerlIOUnix_refcnt_dec(fd) > 0) { + PerlIOBase(f)->flags &= ~PERLIO_F_OPEN; + return 0; + } } else { - SETERRNO(EBADF,SS_IVCHAN); - return -1; + SETERRNO(EBADF,SS_IVCHAN); + return -1; } while (PerlLIO_close(fd) != 0) { - if (errno != EINTR) { - code = -1; - break; - } - /* EINTR */ - if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) - return -1; + if (errno != EINTR) { + code = -1; + break; + } + /* EINTR */ + if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) + return -1; } if (code == 0) { - PerlIOBase(f)->flags &= ~PERLIO_F_OPEN; + PerlIOBase(f)->flags &= ~PERLIO_F_OPEN; } return code; } @@ -2884,9 +2884,9 @@ PerlIOStdio_fileno(pTHX_ PerlIO *f) PERL_UNUSED_CONTEXT; if (PerlIOValid(f)) { - FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio; - if (s) - return PerlSIO_fileno(s); + FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio; + if (s) + return PerlSIO_fileno(s); } errno = EBADF; return -1; @@ -2897,9 +2897,9 @@ PerlIOStdio_mode(const char *mode, char *tmode) { char * const ret = tmode; if (mode) { - while (*mode) { - *tmode++ = *mode++; - } + while (*mode) { + *tmode++ = *mode++; + } } #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__) *tmode++ = 'b'; @@ -2913,25 +2913,25 @@ PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab { PerlIO *n; if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) { - PerlIO_funcs * const toptab = PerlIOBase(n)->tab; + PerlIO_funcs * const toptab = PerlIOBase(n)->tab; if (toptab == tab) { - /* Top is already stdio - pop self (duplicate) and use original */ - PerlIO_pop(aTHX_ f); - return 0; - } else { - const int fd = PerlIO_fileno(n); - char tmode[8]; - FILE *stdio; - if (fd >= 0 && (stdio = PerlSIO_fdopen(fd, - mode = PerlIOStdio_mode(mode, tmode)))) { - PerlIOSelf(f, PerlIOStdio)->stdio = stdio; - /* We never call down so do any pending stuff now */ - PerlIO_flush(PerlIONext(f)); + /* Top is already stdio - pop self (duplicate) and use original */ + PerlIO_pop(aTHX_ f); + return 0; + } else { + const int fd = PerlIO_fileno(n); + char tmode[8]; + FILE *stdio; + if (fd >= 0 && (stdio = PerlSIO_fdopen(fd, + mode = PerlIOStdio_mode(mode, tmode)))) { + PerlIOSelf(f, PerlIOStdio)->stdio = stdio; + /* We never call down so do any pending stuff now */ + PerlIO_flush(PerlIONext(f)); return PerlIOBase_pushed(aTHX_ f, mode, arg, tab); - } - else { - return -1; - } + } + else { + return -1; + } } } return PerlIOBase_pushed(aTHX_ f, mode, arg, tab); @@ -2944,182 +2944,182 @@ PerlIO_importFILE(FILE *stdio, const char *mode) dTHX; PerlIO *f = NULL; #ifdef EBCDIC - int rc; - char filename[FILENAME_MAX]; - fldata_t fileinfo; + int rc; + char filename[FILENAME_MAX]; + fldata_t fileinfo; #endif if (stdio) { - PerlIOStdio *s; + PerlIOStdio *s; int fd0 = fileno(stdio); if (fd0 < 0) { #ifdef EBCDIC - rc = fldata(stdio,filename,&fileinfo); - if(rc != 0){ - return NULL; - } - if(fileinfo.__dsorgHFS){ + rc = fldata(stdio,filename,&fileinfo); + if(rc != 0){ + return NULL; + } + if(fileinfo.__dsorgHFS){ return NULL; } - /*This MVS dataset , OK!*/ + /*This MVS dataset , OK!*/ #else return NULL; #endif } - if (!mode || !*mode) { - /* We need to probe to see how we can open the stream - so start with read/write and then try write and read - we dup() so that we can fclose without loosing the fd. - - Note that the errno value set by a failing fdopen - varies between stdio implementations. - */ + if (!mode || !*mode) { + /* We need to probe to see how we can open the stream + so start with read/write and then try write and read + we dup() so that we can fclose without loosing the fd. + + Note that the errno value set by a failing fdopen + varies between stdio implementations. + */ const int fd = PerlLIO_dup_cloexec(fd0); - FILE *f2; + FILE *f2; if (fd < 0) { return f; } - f2 = PerlSIO_fdopen(fd, (mode = "r+")); - if (!f2) { - f2 = PerlSIO_fdopen(fd, (mode = "w")); - } - if (!f2) { - f2 = PerlSIO_fdopen(fd, (mode = "r")); - } - if (!f2) { - /* Don't seem to be able to open */ - PerlLIO_close(fd); - return f; - } - fclose(f2); - } - if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) { - s = PerlIOSelf(f, PerlIOStdio); - s->stdio = stdio; - fd0 = fileno(stdio); - if(fd0 != -1){ - PerlIOUnix_refcnt_inc(fd0); - setfd_cloexec_or_inhexec_by_sysfdness(fd0); - } + f2 = PerlSIO_fdopen(fd, (mode = "r+")); + if (!f2) { + f2 = PerlSIO_fdopen(fd, (mode = "w")); + } + if (!f2) { + f2 = PerlSIO_fdopen(fd, (mode = "r")); + } + if (!f2) { + /* Don't seem to be able to open */ + PerlLIO_close(fd); + return f; + } + fclose(f2); + } + if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) { + s = PerlIOSelf(f, PerlIOStdio); + s->stdio = stdio; + fd0 = fileno(stdio); + if(fd0 != -1){ + PerlIOUnix_refcnt_inc(fd0); + setfd_cloexec_or_inhexec_by_sysfdness(fd0); + } #ifdef EBCDIC - else{ - rc = fldata(stdio,filename,&fileinfo); - if(rc != 0){ - PerlIOUnix_refcnt_inc(fd0); - } - if(fileinfo.__dsorgHFS){ - PerlIOUnix_refcnt_inc(fd0); - } - /*This MVS dataset , OK!*/ - } + else{ + rc = fldata(stdio,filename,&fileinfo); + if(rc != 0){ + PerlIOUnix_refcnt_inc(fd0); + } + if(fileinfo.__dsorgHFS){ + PerlIOUnix_refcnt_inc(fd0); + } + /*This MVS dataset , OK!*/ + } #endif - } + } } return f; } PerlIO * PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, - IV n, const char *mode, int fd, int imode, - int perm, PerlIO *f, int narg, SV **args) + IV n, const char *mode, int fd, int imode, + int perm, PerlIO *f, int narg, SV **args) { char tmode[8]; if (PerlIOValid(f)) { STRLEN len; - const char * const path = SvPV_const(*args, len); - PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio); - FILE *stdio; - if (!IS_SAFE_PATHNAME(path, len, "open")) + const char * const path = SvPV_const(*args, len); + PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio); + FILE *stdio; + if (!IS_SAFE_PATHNAME(path, len, "open")) return NULL; - PerlIOUnix_refcnt_dec(fileno(s->stdio)); - stdio = PerlSIO_freopen(path, PerlIOStdio_mode(mode, tmode), + PerlIOUnix_refcnt_dec(fileno(s->stdio)); + stdio = PerlSIO_freopen(path, PerlIOStdio_mode(mode, tmode), s->stdio); - if (!s->stdio) - return NULL; - s->stdio = stdio; - fd = fileno(stdio); - PerlIOUnix_refcnt_inc(fd); - setfd_cloexec_or_inhexec_by_sysfdness(fd); - return f; + if (!s->stdio) + return NULL; + s->stdio = stdio; + fd = fileno(stdio); + PerlIOUnix_refcnt_inc(fd); + setfd_cloexec_or_inhexec_by_sysfdness(fd); + return f; } else { - if (narg > 0) { + if (narg > 0) { STRLEN len; - const char * const path = SvPV_const(*args, len); + const char * const path = SvPV_const(*args, len); if (!IS_SAFE_PATHNAME(path, len, "open")) return NULL; - if (*mode == IoTYPE_NUMERIC) { - mode++; - fd = PerlLIO_open3_cloexec(path, imode, perm); - } - else { - FILE *stdio; - bool appended = FALSE; + if (*mode == IoTYPE_NUMERIC) { + mode++; + fd = PerlLIO_open3_cloexec(path, imode, perm); + } + else { + FILE *stdio; + bool appended = FALSE; #ifdef __CYGWIN__ - /* Cygwin wants its 'b' early. */ - appended = TRUE; - mode = PerlIOStdio_mode(mode, tmode); + /* Cygwin wants its 'b' early. */ + appended = TRUE; + mode = PerlIOStdio_mode(mode, tmode); #endif - stdio = PerlSIO_fopen(path, mode); - if (stdio) { - if (!f) { - f = PerlIO_allocate(aTHX); - } - if (!appended) - mode = PerlIOStdio_mode(mode, tmode); - f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg); - if (f) { - PerlIOSelf(f, PerlIOStdio)->stdio = stdio; - fd = fileno(stdio); - PerlIOUnix_refcnt_inc(fd); - setfd_cloexec_or_inhexec_by_sysfdness(fd); - } else { - PerlSIO_fclose(stdio); - } - return f; - } - else { - return NULL; - } - } - } - if (fd >= 0) { - FILE *stdio = NULL; - int init = 0; - if (*mode == IoTYPE_IMPLICIT) { - init = 1; - mode++; - } - if (init) { - switch (fd) { - case 0: - stdio = PerlSIO_stdin; - break; - case 1: - stdio = PerlSIO_stdout; - break; - case 2: - stdio = PerlSIO_stderr; - break; - } - } - else { - stdio = PerlSIO_fdopen(fd, mode = - PerlIOStdio_mode(mode, tmode)); - } - if (stdio) { - if (!f) { - f = PerlIO_allocate(aTHX); - } - if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) { - PerlIOSelf(f, PerlIOStdio)->stdio = stdio; - fd = fileno(stdio); - PerlIOUnix_refcnt_inc(fd); - setfd_cloexec_or_inhexec_by_sysfdness(fd); - } - return f; - } + stdio = PerlSIO_fopen(path, mode); + if (stdio) { + if (!f) { + f = PerlIO_allocate(aTHX); + } + if (!appended) + mode = PerlIOStdio_mode(mode, tmode); + f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg); + if (f) { + PerlIOSelf(f, PerlIOStdio)->stdio = stdio; + fd = fileno(stdio); + PerlIOUnix_refcnt_inc(fd); + setfd_cloexec_or_inhexec_by_sysfdness(fd); + } else { + PerlSIO_fclose(stdio); + } + return f; + } + else { + return NULL; + } + } + } + if (fd >= 0) { + FILE *stdio = NULL; + int init = 0; + if (*mode == IoTYPE_IMPLICIT) { + init = 1; + mode++; + } + if (init) { + switch (fd) { + case 0: + stdio = PerlSIO_stdin; + break; + case 1: + stdio = PerlSIO_stdout; + break; + case 2: + stdio = PerlSIO_stderr; + break; + } + } + else { + stdio = PerlSIO_fdopen(fd, mode = + PerlIOStdio_mode(mode, tmode)); + } + if (stdio) { + if (!f) { + f = PerlIO_allocate(aTHX); + } + if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) { + PerlIOSelf(f, PerlIOStdio)->stdio = stdio; + fd = fileno(stdio); + PerlIOUnix_refcnt_inc(fd); + setfd_cloexec_or_inhexec_by_sysfdness(fd); + } + return f; + } PerlLIO_close(fd); - } + } } return NULL; } @@ -3131,29 +3131,29 @@ PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) happens, but is not how I remember it. NI-S 2001/10/16 */ if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) { - FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio; - const int fd = fileno(stdio); - char mode[8]; - if (flags & PERLIO_DUP_FD) { - const int dfd = PerlLIO_dup_cloexec(fileno(stdio)); - if (dfd >= 0) { - stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode)); - goto set_this; - } - else { - NOOP; - /* FIXME: To avoid messy error recovery if dup fails - re-use the existing stdio as though flag was not set - */ - } - } - stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode)); + FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio; + const int fd = fileno(stdio); + char mode[8]; + if (flags & PERLIO_DUP_FD) { + const int dfd = PerlLIO_dup_cloexec(fileno(stdio)); + if (dfd >= 0) { + stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode)); + goto set_this; + } + else { + NOOP; + /* FIXME: To avoid messy error recovery if dup fails + re-use the existing stdio as though flag was not set + */ + } + } + stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode)); set_this: - PerlIOSelf(f, PerlIOStdio)->stdio = stdio; + PerlIOSelf(f, PerlIOStdio)->stdio = stdio; if(stdio) { - int fd = fileno(stdio); - PerlIOUnix_refcnt_inc(fd); - setfd_cloexec_or_inhexec_by_sysfdness(fd); + int fd = fileno(stdio); + PerlIOUnix_refcnt_inc(fd); + setfd_cloexec_or_inhexec_by_sysfdness(fd); } } return f; @@ -3175,7 +3175,7 @@ PerlIOStdio_invalidate_fileno(pTHX_ FILE *f) return 1; #elif defined(__GLIBC__) /* There may be a better way for GLIBC: - - libio.h defines a flag to not close() on cleanup + - libio.h defines a flag to not close() on cleanup */ f->_fileno = -1; return 1; @@ -3197,14 +3197,14 @@ PerlIOStdio_invalidate_fileno(pTHX_ FILE *f) #elif defined(__FreeBSD__) /* There may be a better way on FreeBSD: - we could insert a dummy func in the _close function entry - f->_close = (int (*)(void *)) dummy_close; + f->_close = (int (*)(void *)) dummy_close; */ f->_file = -1; return 1; #elif defined(__OpenBSD__) /* There may be a better way on OpenBSD: - we could insert a dummy func in the _close function entry - f->_close = (int (*)(void *)) dummy_close; + f->_close = (int (*)(void *)) dummy_close; */ f->_file = -1; return 1; @@ -3215,7 +3215,7 @@ PerlIOStdio_invalidate_fileno(pTHX_ FILE *f) #elif defined(__CYGWIN__) /* There may be a better way on CYGWIN: - we could insert a dummy func in the _close function entry - f->_close = (int (*)(void *)) dummy_close; + f->_close = (int (*)(void *)) dummy_close; */ f->_file = -1; return 1; @@ -3239,40 +3239,40 @@ PerlIOStdio_close(pTHX_ PerlIO *f) { FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; if (!stdio) { - errno = EBADF; - return -1; + errno = EBADF; + return -1; } else { const int fd = fileno(stdio); - int invalidate = 0; - IV result = 0; - int dupfd = -1; - dSAVEDERRNO; + int invalidate = 0; + IV result = 0; + int dupfd = -1; + dSAVEDERRNO; #ifdef SOCKS5_VERSION_NAME - /* Socks lib overrides close() but stdio isn't linked to - that library (though we are) - so we must call close() - on sockets on stdio's behalf. - */ - int optval; - Sock_size_t optlen = sizeof(int); - if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0) - invalidate = 1; + /* Socks lib overrides close() but stdio isn't linked to + that library (though we are) - so we must call close() + on sockets on stdio's behalf. + */ + int optval; + Sock_size_t optlen = sizeof(int); + if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0) + invalidate = 1; #endif - /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such - that a subsequent fileno() on it returns -1. Don't want to croak() - from within PerlIOUnix_refcnt_dec() if some buggy caller code is - trying to close an already closed handle which somehow it still has - a reference to. (via.xs, I'm looking at you). */ - if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) { - /* File descriptor still in use */ - invalidate = 1; - } - if (invalidate) { - /* For STD* handles, don't close stdio, since we shared the FILE *, too. */ - if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */ - return 0; - if (stdio == stdout || stdio == stderr) - return PerlIO_flush(f); + /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such + that a subsequent fileno() on it returns -1. Don't want to croak() + from within PerlIOUnix_refcnt_dec() if some buggy caller code is + trying to close an already closed handle which somehow it still has + a reference to. (via.xs, I'm looking at you). */ + if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) { + /* File descriptor still in use */ + invalidate = 1; + } + if (invalidate) { + /* For STD* handles, don't close stdio, since we shared the FILE *, too. */ + if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */ + return 0; + if (stdio == stdout || stdio == stderr) + return PerlIO_flush(f); } MUTEX_LOCK(&PL_perlio_mutex); /* Right. We need a mutex here because for a brief while we @@ -3292,46 +3292,46 @@ PerlIOStdio_close(pTHX_ PerlIO *f) Except that correctness trumps speed. Advice from klortho #11912. */ - if (invalidate) { + if (invalidate) { /* Tricky - must fclose(stdio) to free memory but not close(fd) - Use Sarathy's trick from maint-5.6 to invalidate the - fileno slot of the FILE * - */ - result = PerlIO_flush(f); - SAVE_ERRNO; - invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio); - if (!invalidate) { - dupfd = PerlLIO_dup_cloexec(fd); + Use Sarathy's trick from maint-5.6 to invalidate the + fileno slot of the FILE * + */ + result = PerlIO_flush(f); + SAVE_ERRNO; + invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio); + if (!invalidate) { + dupfd = PerlLIO_dup_cloexec(fd); #ifdef USE_ITHREADS - if (dupfd < 0) { - /* Oh cXap. This isn't going to go well. Not sure if we can - recover from here, or if closing this particular FILE * - is a good idea now. */ - } + if (dupfd < 0) { + /* Oh cXap. This isn't going to go well. Not sure if we can + recover from here, or if closing this particular FILE * + is a good idea now. */ + } #endif - } - } else { - SAVE_ERRNO; /* This is here only to silence compiler warnings */ - } + } + } else { + SAVE_ERRNO; /* This is here only to silence compiler warnings */ + } result = PerlSIO_fclose(stdio); - /* We treat error from stdio as success if we invalidated - errno may NOT be expected EBADF - */ - if (invalidate && result != 0) { - RESTORE_ERRNO; - result = 0; - } + /* We treat error from stdio as success if we invalidated + errno may NOT be expected EBADF + */ + if (invalidate && result != 0) { + RESTORE_ERRNO; + result = 0; + } #ifdef SOCKS5_VERSION_NAME - /* in SOCKS' case, let close() determine return value */ - result = close(fd); + /* in SOCKS' case, let close() determine return value */ + result = close(fd); #endif - if (dupfd >= 0) { - PerlLIO_dup2_cloexec(dupfd, fd); - setfd_inhexec_for_sysfd(fd); - PerlLIO_close(dupfd); - } + if (dupfd >= 0) { + PerlLIO_dup2_cloexec(dupfd, fd); + setfd_inhexec_for_sysfd(fd); + PerlLIO_close(dupfd); + } MUTEX_UNLOCK(&PL_perlio_mutex); - return result; + return result; } } @@ -3341,30 +3341,30 @@ PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) FILE * s; SSize_t got = 0; if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ - return -1; + return -1; s = PerlIOSelf(f, PerlIOStdio)->stdio; for (;;) { - if (count == 1) { - STDCHAR *buf = (STDCHAR *) vbuf; - /* - * Perl is expecting PerlIO_getc() to fill the buffer Linux's - * stdio does not do that for fread() - */ - const int ch = PerlSIO_fgetc(s); - if (ch != EOF) { - *buf = ch; - got = 1; - } - } - else - got = PerlSIO_fread(vbuf, 1, count, s); - if (got == 0 && PerlSIO_ferror(s)) - got = -1; - if (got >= 0 || errno != EINTR) - break; - if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) - return -1; - SETERRNO(0,0); /* just in case */ + if (count == 1) { + STDCHAR *buf = (STDCHAR *) vbuf; + /* + * Perl is expecting PerlIO_getc() to fill the buffer Linux's + * stdio does not do that for fread() + */ + const int ch = PerlSIO_fgetc(s); + if (ch != EOF) { + *buf = ch; + got = 1; + } + } + else + got = PerlSIO_fread(vbuf, 1, count, s); + if (got == 0 && PerlSIO_ferror(s)) + got = -1; + if (got >= 0 || errno != EINTR) + break; + if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) + return -1; + SETERRNO(0,0); /* just in case */ } #ifdef __sgi /* Under some circumstances IRIX stdio fgetc() and fread() @@ -3383,52 +3383,52 @@ PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) #ifdef STDIO_BUFFER_WRITABLE if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) { - STDCHAR *buf = ((STDCHAR *) vbuf) + count; - STDCHAR *base = PerlIO_get_base(f); - SSize_t cnt = PerlIO_get_cnt(f); - STDCHAR *ptr = PerlIO_get_ptr(f); - SSize_t avail = ptr - base; - if (avail > 0) { - if (avail > count) { - avail = count; - } - ptr -= avail; - Move(buf-avail,ptr,avail,STDCHAR); - count -= avail; - unread += avail; - PerlIO_set_ptrcnt(f,ptr,cnt+avail); - if (PerlSIO_feof(s) && unread >= 0) - PerlSIO_clearerr(s); - } + STDCHAR *buf = ((STDCHAR *) vbuf) + count; + STDCHAR *base = PerlIO_get_base(f); + SSize_t cnt = PerlIO_get_cnt(f); + STDCHAR *ptr = PerlIO_get_ptr(f); + SSize_t avail = ptr - base; + if (avail > 0) { + if (avail > count) { + avail = count; + } + ptr -= avail; + Move(buf-avail,ptr,avail,STDCHAR); + count -= avail; + unread += avail; + PerlIO_set_ptrcnt(f,ptr,cnt+avail); + if (PerlSIO_feof(s) && unread >= 0) + PerlSIO_clearerr(s); + } } else #endif if (PerlIO_has_cntptr(f)) { - /* We can get pointer to buffer but not its base - Do ungetc() but check chars are ending up in the - buffer - */ - STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s); - STDCHAR *buf = ((STDCHAR *) vbuf) + count; - while (count > 0) { - const int ch = *--buf & 0xFF; - if (ungetc(ch,s) != ch) { - /* ungetc did not work */ - break; - } - if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) { - /* Did not change pointer as expected */ - if (fgetc(s) != EOF) /* get char back again */ + /* We can get pointer to buffer but not its base + Do ungetc() but check chars are ending up in the + buffer + */ + STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s); + STDCHAR *buf = ((STDCHAR *) vbuf) + count; + while (count > 0) { + const int ch = *--buf & 0xFF; + if (ungetc(ch,s) != ch) { + /* ungetc did not work */ + break; + } + if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) { + /* Did not change pointer as expected */ + if (fgetc(s) != EOF) /* get char back again */ break; - } - /* It worked ! */ - count--; - unread++; - } + } + /* It worked ! */ + count--; + unread++; + } } if (count > 0) { - unread += PerlIOBase_unread(aTHX_ f, vbuf, count); + unread += PerlIOBase_unread(aTHX_ f, vbuf, count); } return unread; } @@ -3438,15 +3438,15 @@ PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) { SSize_t got; if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ - return -1; + return -1; for (;;) { - got = PerlSIO_fwrite(vbuf, 1, count, - PerlIOSelf(f, PerlIOStdio)->stdio); - if (got >= 0 || errno != EINTR) - break; - if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) - return -1; - SETERRNO(0,0); /* just in case */ + got = PerlSIO_fwrite(vbuf, 1, count, + PerlIOSelf(f, PerlIOStdio)->stdio); + if (got >= 0 || errno != EINTR) + break; + if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) + return -1; + SETERRNO(0,0); /* just in case */ } return got; } @@ -3476,23 +3476,23 @@ PerlIOStdio_flush(pTHX_ PerlIO *f) PERL_UNUSED_CONTEXT; if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) { - return PerlSIO_fflush(stdio); + return PerlSIO_fflush(stdio); } else { - NOOP; + NOOP; #if 0 - /* - * FIXME: This discards ungetc() and pre-read stuff which is not - * right if this is just a "sync" from a layer above Suspect right - * design is to do _this_ but not have layer above flush this - * layer read-to-read - */ - /* - * Not writeable - sync by attempting a seek - */ - dSAVE_ERRNO; - if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0) - RESTORE_ERRNO; + /* + * FIXME: This discards ungetc() and pre-read stuff which is not + * right if this is just a "sync" from a layer above Suspect right + * design is to do _this_ but not have layer above flush this + * layer read-to-read + */ + /* + * Not writeable - sync by attempting a seek + */ + dSAVE_ERRNO; + if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0) + RESTORE_ERRNO; #endif } return 0; @@ -3588,19 +3588,19 @@ PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) * * So let's try silencing the warning at least for gcc. */ GCC_DIAG_IGNORE_STMT(-Wpointer-sign); - PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */ + PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */ GCC_DIAG_RESTORE_STMT; # ifdef STDIO_PTR_LVAL_SETS_CNT - assert(PerlSIO_get_cnt(stdio) == (cnt)); + assert(PerlSIO_get_cnt(stdio) == (cnt)); # endif # if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT)) - /* - * Setting ptr _does_ change cnt - we are done - */ - return; + /* + * Setting ptr _does_ change cnt - we are done + */ + return; # endif # else /* STDIO_PTR_LVALUE */ - PerlProc_abort(); + PerlProc_abort(); # endif /* STDIO_PTR_LVALUE */ } /* @@ -3610,8 +3610,8 @@ PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) PerlSIO_set_cnt(stdio, cnt); # elif (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT)) PerlSIO_set_ptr(stdio, - PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) - - cnt)); + PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) - + cnt)); # else /* STDIO_PTR_LVAL_SETS_CNT */ PerlProc_abort(); # endif /* STDIO_CNT_LVALUE */ @@ -3627,52 +3627,52 @@ PerlIOStdio_fill(pTHX_ PerlIO *f) int c; PERL_UNUSED_CONTEXT; if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ - return -1; + return -1; stdio = PerlIOSelf(f, PerlIOStdio)->stdio; /* * fflush()ing read-only streams can cause trouble on some stdio-s */ if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) { - if (PerlSIO_fflush(stdio) != 0) - return EOF; + if (PerlSIO_fflush(stdio) != 0) + return EOF; } for (;;) { - c = PerlSIO_fgetc(stdio); - if (c != EOF) - break; - if (! PerlSIO_ferror(stdio) || errno != EINTR) - return EOF; - if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) - return -1; - SETERRNO(0,0); + c = PerlSIO_fgetc(stdio); + if (c != EOF) + break; + if (! PerlSIO_ferror(stdio) || errno != EINTR) + return EOF; + if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) + return -1; + SETERRNO(0,0); } #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT))) # ifdef STDIO_BUFFER_WRITABLE if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) { - /* Fake ungetc() to the real buffer in case system's ungetc - goes elsewhere - */ - STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio); - SSize_t cnt = PerlSIO_get_cnt(stdio); - STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio); - if (ptr == base+1) { - *--ptr = (STDCHAR) c; - PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1); - if (PerlSIO_feof(stdio)) - PerlSIO_clearerr(stdio); - return 0; - } + /* Fake ungetc() to the real buffer in case system's ungetc + goes elsewhere + */ + STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio); + SSize_t cnt = PerlSIO_get_cnt(stdio); + STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio); + if (ptr == base+1) { + *--ptr = (STDCHAR) c; + PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1); + if (PerlSIO_feof(stdio)) + PerlSIO_clearerr(stdio); + return 0; + } } else # endif if (PerlIO_has_cntptr(f)) { - STDCHAR ch = c; - if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) { - return 0; - } + STDCHAR ch = c; + if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) { + return 0; + } } #endif @@ -3680,7 +3680,7 @@ PerlIOStdio_fill(pTHX_ PerlIO *f) using ungetc(). */ if (PerlSIO_ungetc(c, stdio) != c) - return EOF; + return EOF; return 0; } @@ -3741,33 +3741,33 @@ PerlIO_exportFILE(PerlIO * f, const char *mode) dTHX; FILE *stdio = NULL; if (PerlIOValid(f)) { - char buf[8]; + char buf[8]; int fd = PerlIO_fileno(f); if (fd < 0) { return NULL; } - PerlIO_flush(f); - if (!mode || !*mode) { - mode = PerlIO_modestr(f, buf); - } - stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode); - if (stdio) { - PerlIOl *l = *f; - PerlIO *f2; - /* De-link any lower layers so new :stdio sticks */ - *f = NULL; - if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) { - PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio); - s->stdio = stdio; - PerlIOUnix_refcnt_inc(fileno(stdio)); - /* Link previous lower layers under new one */ - *PerlIONext(f) = l; - } - else { - /* restore layers list */ - *f = l; - } - } + PerlIO_flush(f); + if (!mode || !*mode) { + mode = PerlIO_modestr(f, buf); + } + stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode); + if (stdio) { + PerlIOl *l = *f; + PerlIO *f2; + /* De-link any lower layers so new :stdio sticks */ + *f = NULL; + if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) { + PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio); + s->stdio = stdio; + PerlIOUnix_refcnt_inc(fileno(stdio)); + /* Link previous lower layers under new one */ + *PerlIONext(f) = l; + } + else { + /* restore layers list */ + *f = l; + } + } } return stdio; } @@ -3779,11 +3779,11 @@ PerlIO_findFILE(PerlIO *f) PerlIOl *l = *f; FILE *stdio; while (l) { - if (l->tab == &PerlIO_stdio) { - PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio); - return s->stdio; - } - l = *PerlIONext(&l); + if (l->tab == &PerlIO_stdio) { + PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio); + return s->stdio; + } + l = *PerlIONext(&l); } /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */ /* However, we're not really exporting a FILE * to someone else (who @@ -3794,9 +3794,9 @@ PerlIO_findFILE(PerlIO *f) only one way to be consistent. */ stdio = PerlIO_exportFILE(f, NULL); if (stdio) { - const int fd = fileno(stdio); - if (fd >= 0) - PerlIOUnix_refcnt_dec(fd); + const int fd = fileno(stdio); + if (fd >= 0) + PerlIOUnix_refcnt_dec(fd); } return stdio; } @@ -3807,20 +3807,20 @@ PerlIO_releaseFILE(PerlIO *p, FILE *f) { PerlIOl *l; while ((l = *p)) { - if (l->tab == &PerlIO_stdio) { - PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio); - if (s->stdio == f) { /* not in a loop */ - const int fd = fileno(f); - if (fd >= 0) - PerlIOUnix_refcnt_dec(fd); - { - dTHX; - PerlIO_pop(aTHX_ p); - } - return; - } - } - p = PerlIONext(p); + if (l->tab == &PerlIO_stdio) { + PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio); + if (s->stdio == f) { /* not in a loop */ + const int fd = fileno(f); + if (fd >= 0) + PerlIOUnix_refcnt_dec(fd); + { + dTHX; + PerlIO_pop(aTHX_ p); + } + return; + } + } + p = PerlIONext(p); } return; } @@ -3836,91 +3836,91 @@ PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); const int fd = PerlIO_fileno(f); if (fd >= 0 && PerlLIO_isatty(fd)) { - PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY; + PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY; } if (*PerlIONext(f)) { - const Off_t posn = PerlIO_tell(PerlIONext(f)); - if (posn != (Off_t) - 1) { - b->posn = posn; - } + const Off_t posn = PerlIO_tell(PerlIONext(f)); + if (posn != (Off_t) - 1) { + b->posn = posn; + } } return PerlIOBase_pushed(aTHX_ f, mode, arg, tab); } PerlIO * PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, - IV n, const char *mode, int fd, int imode, int perm, - PerlIO *f, int narg, SV **args) + IV n, const char *mode, int fd, int imode, int perm, + PerlIO *f, int narg, SV **args) { if (PerlIOValid(f)) { - PerlIO *next = PerlIONext(f); - PerlIO_funcs *tab = - PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab); - if (tab && tab->Open) - next = - (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, - next, narg, args); - if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) { - return NULL; - } + PerlIO *next = PerlIONext(f); + PerlIO_funcs *tab = + PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab); + if (tab && tab->Open) + next = + (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, + next, narg, args); + if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) { + return NULL; + } } else { - PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm()); - int init = 0; - if (*mode == IoTYPE_IMPLICIT) { - init = 1; - /* - * mode++; - */ - } - if (tab && tab->Open) - f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, - f, narg, args); - else - SETERRNO(EINVAL, LIB_INVARG); - if (f) { - if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) { - /* - * if push fails during open, open fails. close will pop us. - */ - PerlIO_close (f); - return NULL; - } else { - fd = PerlIO_fileno(f); - if (init && fd == 2) { - /* - * Initial stderr is unbuffered - */ - PerlIOBase(f)->flags |= PERLIO_F_UNBUF; - } + PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm()); + int init = 0; + if (*mode == IoTYPE_IMPLICIT) { + init = 1; + /* + * mode++; + */ + } + if (tab && tab->Open) + f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, + f, narg, args); + else + SETERRNO(EINVAL, LIB_INVARG); + if (f) { + if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) { + /* + * if push fails during open, open fails. close will pop us. + */ + PerlIO_close (f); + return NULL; + } else { + fd = PerlIO_fileno(f); + if (init && fd == 2) { + /* + * Initial stderr is unbuffered + */ + PerlIOBase(f)->flags |= PERLIO_F_UNBUF; + } #ifdef PERLIO_USING_CRLF # ifdef PERLIO_IS_BINMODE_FD - if (PERLIO_IS_BINMODE_FD(fd)) - PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL); - else + if (PERLIO_IS_BINMODE_FD(fd)) + PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL); + else # endif - /* - * do something about failing setmode()? --jhi - */ - PerlLIO_setmode(fd, O_BINARY); + /* + * do something about failing setmode()? --jhi + */ + PerlLIO_setmode(fd, O_BINARY); #endif #ifdef VMS - /* Enable line buffering with record-oriented regular files - * so we don't introduce an extraneous record boundary when - * the buffer fills up. - */ - if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) { - Stat_t st; - if (PerlLIO_fstat(fd, &st) == 0 - && S_ISREG(st.st_mode) - && (st.st_fab_rfm == FAB$C_VAR - || st.st_fab_rfm == FAB$C_VFC)) { - PerlIOBase(f)->flags |= PERLIO_F_LINEBUF; - } - } + /* Enable line buffering with record-oriented regular files + * so we don't introduce an extraneous record boundary when + * the buffer fills up. + */ + if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) { + Stat_t st; + if (PerlLIO_fstat(fd, &st) == 0 + && S_ISREG(st.st_mode) + && (st.st_fab_rfm == FAB$C_VAR + || st.st_fab_rfm == FAB$C_VFC)) { + PerlIOBase(f)->flags |= PERLIO_F_LINEBUF; + } + } #endif - } - } + } + } } return f; } @@ -3940,54 +3940,54 @@ PerlIOBuf_flush(pTHX_ PerlIO *f) int code = 0; PerlIO *n = PerlIONext(f); if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) { - /* - * write() the buffer - */ - const STDCHAR *buf = b->buf; - const STDCHAR *p = buf; - while (p < b->ptr) { - SSize_t count = PerlIO_write(n, p, b->ptr - p); - if (count > 0) { - p += count; - } - else if (count < 0 || PerlIO_error(n)) { - PerlIOBase(f)->flags |= PERLIO_F_ERROR; - PerlIO_save_errno(f); - code = -1; - break; - } - } - b->posn += (p - buf); + /* + * write() the buffer + */ + const STDCHAR *buf = b->buf; + const STDCHAR *p = buf; + while (p < b->ptr) { + SSize_t count = PerlIO_write(n, p, b->ptr - p); + if (count > 0) { + p += count; + } + else if (count < 0 || PerlIO_error(n)) { + PerlIOBase(f)->flags |= PERLIO_F_ERROR; + PerlIO_save_errno(f); + code = -1; + break; + } + } + b->posn += (p - buf); } else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { - STDCHAR *buf = PerlIO_get_base(f); - /* - * Note position change - */ - b->posn += (b->ptr - buf); - if (b->ptr < b->end) { - /* We did not consume all of it - try and seek downstream to - our logical position - */ - if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) { - /* Reload n as some layers may pop themselves on seek */ - b->posn = PerlIO_tell(n = PerlIONext(f)); - } - else { - /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read - data is lost for good - so return saying "ok" having undone - the position adjust - */ - b->posn -= (b->ptr - buf); - return code; - } - } + STDCHAR *buf = PerlIO_get_base(f); + /* + * Note position change + */ + b->posn += (b->ptr - buf); + if (b->ptr < b->end) { + /* We did not consume all of it - try and seek downstream to + our logical position + */ + if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) { + /* Reload n as some layers may pop themselves on seek */ + b->posn = PerlIO_tell(n = PerlIONext(f)); + } + else { + /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read + data is lost for good - so return saying "ok" having undone + the position adjust + */ + b->posn -= (b->ptr - buf); + return code; + } + } } b->ptr = b->end = b->buf; PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */ if (PerlIOValid(n) && PerlIO_flush(n) != 0) - code = -1; + code = -1; return code; } @@ -4006,60 +4006,60 @@ PerlIOBuf_fill(pTHX_ PerlIO *f) * we would not normally be fill'ing if there was data left in anycase. */ if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */ - return -1; + return -1; if (PerlIOBase(f)->flags & PERLIO_F_TTY) - PerlIOBase_flush_linebuf(aTHX); + PerlIOBase_flush_linebuf(aTHX); if (!b->buf) - PerlIO_get_base(f); /* allocate via vtable */ + PerlIO_get_base(f); /* allocate via vtable */ assert(b->buf); /* The b->buf does get allocated via the vtable system. */ b->ptr = b->end = b->buf; if (!PerlIOValid(n)) { - PerlIOBase(f)->flags |= PERLIO_F_EOF; - return -1; + PerlIOBase(f)->flags |= PERLIO_F_EOF; + return -1; } if (PerlIO_fast_gets(n)) { - /* - * Layer below is also buffered. We do _NOT_ want to call its - * ->Read() because that will loop till it gets what we asked for - * which may hang on a pipe etc. Instead take anything it has to - * hand, or ask it to fill _once_. - */ - avail = PerlIO_get_cnt(n); - if (avail <= 0) { - avail = PerlIO_fill(n); - if (avail == 0) - avail = PerlIO_get_cnt(n); - else { - if (!PerlIO_error(n) && PerlIO_eof(n)) - avail = 0; - } - } - if (avail > 0) { - STDCHAR *ptr = PerlIO_get_ptr(n); - const SSize_t cnt = avail; - if (avail > (SSize_t)b->bufsiz) - avail = b->bufsiz; - Copy(ptr, b->buf, avail, STDCHAR); - PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail); - } + /* + * Layer below is also buffered. We do _NOT_ want to call its + * ->Read() because that will loop till it gets what we asked for + * which may hang on a pipe etc. Instead take anything it has to + * hand, or ask it to fill _once_. + */ + avail = PerlIO_get_cnt(n); + if (avail <= 0) { + avail = PerlIO_fill(n); + if (avail == 0) + avail = PerlIO_get_cnt(n); + else { + if (!PerlIO_error(n) && PerlIO_eof(n)) + avail = 0; + } + } + if (avail > 0) { + STDCHAR *ptr = PerlIO_get_ptr(n); + const SSize_t cnt = avail; + if (avail > (SSize_t)b->bufsiz) + avail = b->bufsiz; + Copy(ptr, b->buf, avail, STDCHAR); + PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail); + } } else { - avail = PerlIO_read(n, b->ptr, b->bufsiz); + avail = PerlIO_read(n, b->ptr, b->bufsiz); } if (avail <= 0) { - if (avail == 0) - PerlIOBase(f)->flags |= PERLIO_F_EOF; - else - { - PerlIOBase(f)->flags |= PERLIO_F_ERROR; - PerlIO_save_errno(f); - } - return -1; + if (avail == 0) + PerlIOBase(f)->flags |= PERLIO_F_EOF; + else + { + PerlIOBase(f)->flags |= PERLIO_F_ERROR; + PerlIO_save_errno(f); + } + return -1; } b->end = b->buf + avail; PerlIOBase(f)->flags |= PERLIO_F_RDBUF; @@ -4071,9 +4071,9 @@ PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) { if (PerlIOValid(f)) { const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); - if (!b->ptr) - PerlIO_get_base(f); - return PerlIOBase_read(aTHX_ f, vbuf, count); + if (!b->ptr) + PerlIO_get_base(f); + return PerlIOBase_read(aTHX_ f, vbuf, count); } return 0; } @@ -4086,54 +4086,54 @@ PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) SSize_t unread = 0; SSize_t avail; if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) - PerlIO_flush(f); + PerlIO_flush(f); if (!b->buf) - PerlIO_get_base(f); + PerlIO_get_base(f); if (b->buf) { - if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { - /* - * Buffer is already a read buffer, we can overwrite any chars - * which have been read back to buffer start - */ - avail = (b->ptr - b->buf); - } - else { - /* - * Buffer is idle, set it up so whole buffer is available for - * unread - */ - avail = b->bufsiz; - b->end = b->buf + avail; - b->ptr = b->end; - PerlIOBase(f)->flags |= PERLIO_F_RDBUF; - /* - * Buffer extends _back_ from where we are now - */ - b->posn -= b->bufsiz; - } - if ((SSize_t) count >= 0 && avail > (SSize_t) count) { - /* - * If we have space for more than count, just move count - */ - avail = count; - } - if (avail > 0) { - b->ptr -= avail; - buf -= avail; - /* - * In simple stdio-like ungetc() case chars will be already - * there - */ - if (buf != b->ptr) { - Copy(buf, b->ptr, avail, STDCHAR); - } - count -= avail; - unread += avail; - PerlIOBase(f)->flags &= ~PERLIO_F_EOF; - } + if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { + /* + * Buffer is already a read buffer, we can overwrite any chars + * which have been read back to buffer start + */ + avail = (b->ptr - b->buf); + } + else { + /* + * Buffer is idle, set it up so whole buffer is available for + * unread + */ + avail = b->bufsiz; + b->end = b->buf + avail; + b->ptr = b->end; + PerlIOBase(f)->flags |= PERLIO_F_RDBUF; + /* + * Buffer extends _back_ from where we are now + */ + b->posn -= b->bufsiz; + } + if ((SSize_t) count >= 0 && avail > (SSize_t) count) { + /* + * If we have space for more than count, just move count + */ + avail = count; + } + if (avail > 0) { + b->ptr -= avail; + buf -= avail; + /* + * In simple stdio-like ungetc() case chars will be already + * there + */ + if (buf != b->ptr) { + Copy(buf, b->ptr, avail, STDCHAR); + } + count -= avail; + unread += avail; + PerlIOBase(f)->flags &= ~PERLIO_F_EOF; + } } if (count > 0) { - unread += PerlIOBase_unread(aTHX_ f, vbuf, count); + unread += PerlIOBase_unread(aTHX_ f, vbuf, count); } return unread; } @@ -4146,41 +4146,41 @@ PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) const STDCHAR *flushptr = buf; Size_t written = 0; if (!b->buf) - PerlIO_get_base(f); + PerlIO_get_base(f); if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) - return 0; + return 0; if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { - if (PerlIO_flush(f) != 0) { - return 0; - } + if (PerlIO_flush(f) != 0) { + return 0; + } } if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) { - flushptr = buf + count; - while (flushptr > buf && *(flushptr - 1) != '\n') - --flushptr; + flushptr = buf + count; + while (flushptr > buf && *(flushptr - 1) != '\n') + --flushptr; } while (count > 0) { - SSize_t avail = b->bufsiz - (b->ptr - b->buf); - if ((SSize_t) count >= 0 && (SSize_t) count < avail) - avail = count; - if (flushptr > buf && flushptr <= buf + avail) - avail = flushptr - buf; - PerlIOBase(f)->flags |= PERLIO_F_WRBUF; - if (avail) { - Copy(buf, b->ptr, avail, STDCHAR); - count -= avail; - buf += avail; - written += avail; - b->ptr += avail; - if (buf == flushptr) - PerlIO_flush(f); - } - if (b->ptr >= (b->buf + b->bufsiz)) - if (PerlIO_flush(f) == -1) - return -1; + SSize_t avail = b->bufsiz - (b->ptr - b->buf); + if ((SSize_t) count >= 0 && (SSize_t) count < avail) + avail = count; + if (flushptr > buf && flushptr <= buf + avail) + avail = flushptr - buf; + PerlIOBase(f)->flags |= PERLIO_F_WRBUF; + if (avail) { + Copy(buf, b->ptr, avail, STDCHAR); + count -= avail; + buf += avail; + written += avail; + b->ptr += avail; + if (buf == flushptr) + PerlIO_flush(f); + } + if (b->ptr >= (b->buf + b->bufsiz)) + if (PerlIO_flush(f) == -1) + return -1; } if (PerlIOBase(f)->flags & PERLIO_F_UNBUF) - PerlIO_flush(f); + PerlIO_flush(f); return written; } @@ -4189,12 +4189,12 @@ PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence) { IV code; if ((code = PerlIO_flush(f)) == 0) { - PerlIOBase(f)->flags &= ~PERLIO_F_EOF; - code = PerlIO_seek(PerlIONext(f), offset, whence); - if (code == 0) { - PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); - b->posn = PerlIO_tell(PerlIONext(f)); - } + PerlIOBase(f)->flags &= ~PERLIO_F_EOF; + code = PerlIO_seek(PerlIONext(f), offset, whence); + if (code == 0) { + PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); + b->posn = PerlIO_tell(PerlIONext(f)); + } } return code; } @@ -4210,21 +4210,21 @@ PerlIOBuf_tell(pTHX_ PerlIO *f) if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) && (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) { #if 1 - /* As O_APPEND files are normally shared in some sense it is better - to flush : - */ - PerlIO_flush(f); + /* As O_APPEND files are normally shared in some sense it is better + to flush : + */ + PerlIO_flush(f); #else /* when file is NOT shared then this is sufficient */ - PerlIO_seek(PerlIONext(f),0, SEEK_END); + PerlIO_seek(PerlIONext(f),0, SEEK_END); #endif - posn = b->posn = PerlIO_tell(PerlIONext(f)); + posn = b->posn = PerlIO_tell(PerlIONext(f)); } if (b->buf) { - /* - * If buffer is valid adjust position by amount in buffer - */ - posn += (b->ptr - b->buf); + /* + * If buffer is valid adjust position by amount in buffer + */ + posn += (b->ptr - b->buf); } return posn; } @@ -4235,7 +4235,7 @@ PerlIOBuf_popped(pTHX_ PerlIO *f) const IV code = PerlIOBase_popped(aTHX_ f); PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); if (b->buf && b->buf != (STDCHAR *) & b->oneword) { - Safefree(b->buf); + Safefree(b->buf); } b->ptr = b->end = b->buf = NULL; PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); @@ -4248,7 +4248,7 @@ PerlIOBuf_close(pTHX_ PerlIO *f) const IV code = PerlIOBase_close(aTHX_ f); PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); if (b->buf && b->buf != (STDCHAR *) & b->oneword) { - Safefree(b->buf); + Safefree(b->buf); } b->ptr = b->end = b->buf = NULL; PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); @@ -4260,7 +4260,7 @@ PerlIOBuf_get_ptr(pTHX_ PerlIO *f) { const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); if (!b->buf) - PerlIO_get_base(f); + PerlIO_get_base(f); return b->ptr; } @@ -4269,9 +4269,9 @@ PerlIOBuf_get_cnt(pTHX_ PerlIO *f) { const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); if (!b->buf) - PerlIO_get_base(f); + PerlIO_get_base(f); if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) - return (b->end - b->ptr); + return (b->end - b->ptr); return 0; } @@ -4282,14 +4282,14 @@ PerlIOBuf_get_base(pTHX_ PerlIO *f) PERL_UNUSED_CONTEXT; if (!b->buf) { - if (!b->bufsiz) - b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ; - Newx(b->buf,b->bufsiz, STDCHAR); - if (!b->buf) { - b->buf = (STDCHAR *) & b->oneword; - b->bufsiz = sizeof(b->oneword); - } - b->end = b->ptr = b->buf; + if (!b->bufsiz) + b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ; + Newx(b->buf,b->bufsiz, STDCHAR); + if (!b->buf) { + b->buf = (STDCHAR *) & b->oneword; + b->bufsiz = sizeof(b->oneword); + } + b->end = b->ptr = b->buf; } return b->buf; } @@ -4299,7 +4299,7 @@ PerlIOBuf_bufsiz(pTHX_ PerlIO *f) { const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); if (!b->buf) - PerlIO_get_base(f); + PerlIO_get_base(f); return (b->end - b->buf); } @@ -4311,7 +4311,7 @@ PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) PERL_UNUSED_ARG(cnt); #endif if (!b->buf) - PerlIO_get_base(f); + PerlIO_get_base(f); b->ptr = ptr; assert(PerlIO_get_cnt(f) == cnt); assert(b->ptr >= b->buf); @@ -4398,8 +4398,8 @@ PerlIOPending_flush(pTHX_ PerlIO *f) { PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); if (b->buf && b->buf != (STDCHAR *) & b->oneword) { - Safefree(b->buf); - b->buf = NULL; + Safefree(b->buf); + b->buf = NULL; } PerlIO_pop(aTHX_ f); return 0; @@ -4409,10 +4409,10 @@ void PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) { if (cnt <= 0) { - PerlIO_flush(f); + PerlIO_flush(f); } else { - PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt); + PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt); } } @@ -4426,8 +4426,8 @@ PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *t * etc. get muddled when it changes mid-string when we auto-pop. */ l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) | - (PerlIOBase(PerlIONext(f))-> - flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8)); + (PerlIOBase(PerlIONext(f))-> + flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8)); return code; } @@ -4437,14 +4437,14 @@ PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) SSize_t avail = PerlIO_get_cnt(f); SSize_t got = 0; if ((SSize_t) count >= 0 && (SSize_t)count < avail) - avail = count; + avail = count; if (avail > 0) - got = PerlIOBuf_read(aTHX_ f, vbuf, avail); + got = PerlIOBuf_read(aTHX_ f, vbuf, avail); if (got >= 0 && got < (SSize_t)count) { - const SSize_t more = - PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got); - if (more >= 0 || got == 0) - got += more; + const SSize_t more = + PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got); + if (more >= 0 || got == 0) + got += more; } return got; } @@ -4500,7 +4500,7 @@ PERLIO_FUNCS_DECL(PerlIO_pending) = { typedef struct { PerlIOBuf base; /* PerlIOBuf stuff */ STDCHAR *nl; /* Position of crlf we "lied" about in the - * buffer */ + * buffer */ } PerlIOCrlf; /* Inherit the PERLIO_F_UTF8 flag from previous layer. @@ -4512,9 +4512,9 @@ S_inherit_utf8_flag(PerlIO *f) { PerlIO *g = PerlIONext(f); if (PerlIOValid(g)) { - if (PerlIOBase(g)->flags & PERLIO_F_UTF8) { - PerlIOBase(f)->flags |= PERLIO_F_UTF8; - } + if (PerlIOBase(g)->flags & PERLIO_F_UTF8) { + PerlIOBase(f)->flags |= PERLIO_F_UTF8; + } } } @@ -4527,24 +4527,24 @@ PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) #if 0 DEBUG_i( PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n", - (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)", - PerlIOBase(f)->flags); + (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)", + PerlIOBase(f)->flags); ); #endif { /* If the old top layer is a CRLF layer, reactivate it (if * necessary) and remove this new layer from the stack */ - PerlIO *g = PerlIONext(f); - if (PerlIOValid(g)) { - PerlIOl *b = PerlIOBase(g); - if (b && b->tab == &PerlIO_crlf) { - if (!(b->flags & PERLIO_F_CRLF)) - b->flags |= PERLIO_F_CRLF; - S_inherit_utf8_flag(g); - PerlIO_pop(aTHX_ f); - return code; - } - } + PerlIO *g = PerlIONext(f); + if (PerlIOValid(g)) { + PerlIOl *b = PerlIOBase(g); + if (b && b->tab == &PerlIO_crlf) { + if (!(b->flags & PERLIO_F_CRLF)) + b->flags |= PERLIO_F_CRLF; + S_inherit_utf8_flag(g); + PerlIO_pop(aTHX_ f); + return code; + } + } } S_inherit_utf8_flag(f); return code; @@ -4556,52 +4556,52 @@ PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) { PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf); if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */ - *(c->nl) = NATIVE_0xd; - c->nl = NULL; + *(c->nl) = NATIVE_0xd; + c->nl = NULL; } if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) - return PerlIOBuf_unread(aTHX_ f, vbuf, count); + return PerlIOBuf_unread(aTHX_ f, vbuf, count); else { - const STDCHAR *buf = (const STDCHAR *) vbuf + count; - PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); - SSize_t unread = 0; - if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) - PerlIO_flush(f); - if (!b->buf) - PerlIO_get_base(f); - if (b->buf) { - if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) { - b->end = b->ptr = b->buf + b->bufsiz; - PerlIOBase(f)->flags |= PERLIO_F_RDBUF; - b->posn -= b->bufsiz; - } - while (count > 0 && b->ptr > b->buf) { - const int ch = *--buf; - if (ch == '\n') { - if (b->ptr - 2 >= b->buf) { - *--(b->ptr) = NATIVE_0xa; - *--(b->ptr) = NATIVE_0xd; - unread++; - count--; - } - else { - /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */ + const STDCHAR *buf = (const STDCHAR *) vbuf + count; + PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); + SSize_t unread = 0; + if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) + PerlIO_flush(f); + if (!b->buf) + PerlIO_get_base(f); + if (b->buf) { + if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) { + b->end = b->ptr = b->buf + b->bufsiz; + PerlIOBase(f)->flags |= PERLIO_F_RDBUF; + b->posn -= b->bufsiz; + } + while (count > 0 && b->ptr > b->buf) { + const int ch = *--buf; + if (ch == '\n') { + if (b->ptr - 2 >= b->buf) { + *--(b->ptr) = NATIVE_0xa; + *--(b->ptr) = NATIVE_0xd; + unread++; + count--; + } + else { + /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */ *--(b->ptr) = NATIVE_0xa; /* Works even if 0xa == '\r' */ - unread++; - count--; - } - } - else { - *--(b->ptr) = ch; - unread++; - count--; - } - } - } + unread++; + count--; + } + } + else { + *--(b->ptr) = ch; + unread++; + count--; + } + } + } if (count > 0) unread += PerlIOBase_unread(aTHX_ f, (const STDCHAR *) vbuf + unread, count); - return unread; + return unread; } } @@ -4611,69 +4611,69 @@ PerlIOCrlf_get_cnt(pTHX_ PerlIO *f) { PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); if (!b->buf) - PerlIO_get_base(f); + PerlIO_get_base(f); if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { - PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf); - if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) { - STDCHAR *nl = (c->nl) ? c->nl : b->ptr; - scan: - while (nl < b->end && *nl != NATIVE_0xd) - nl++; - if (nl < b->end && *nl == NATIVE_0xd) { - test: - if (nl + 1 < b->end) { - if (nl[1] == NATIVE_0xa) { - *nl = '\n'; - c->nl = nl; - } - else { - /* - * Not CR,LF but just CR - */ - nl++; - goto scan; - } - } - else { - /* - * Blast - found CR as last char in buffer - */ - - if (b->ptr < nl) { - /* - * They may not care, defer work as long as - * possible - */ - c->nl = nl; - return (nl - b->ptr); - } - else { - int code; - b->ptr++; /* say we have read it as far as - * flush() is concerned */ - b->buf++; /* Leave space in front of buffer */ - /* Note as we have moved buf up flush's - posn += ptr-buf - will naturally make posn point at CR - */ - b->bufsiz--; /* Buffer is thus smaller */ - code = PerlIO_fill(f); /* Fetch some more */ - b->bufsiz++; /* Restore size for next time */ - b->buf--; /* Point at space */ - b->ptr = nl = b->buf; /* Which is what we hand - * off */ - *nl = NATIVE_0xd; /* Fill in the CR */ - if (code == 0) - goto test; /* fill() call worked */ - /* - * CR at EOF - just fall through - */ - /* Should we clear EOF though ??? */ - } - } - } - } - return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr); + PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf); + if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) { + STDCHAR *nl = (c->nl) ? c->nl : b->ptr; + scan: + while (nl < b->end && *nl != NATIVE_0xd) + nl++; + if (nl < b->end && *nl == NATIVE_0xd) { + test: + if (nl + 1 < b->end) { + if (nl[1] == NATIVE_0xa) { + *nl = '\n'; + c->nl = nl; + } + else { + /* + * Not CR,LF but just CR + */ + nl++; + goto scan; + } + } + else { + /* + * Blast - found CR as last char in buffer + */ + + if (b->ptr < nl) { + /* + * They may not care, defer work as long as + * possible + */ + c->nl = nl; + return (nl - b->ptr); + } + else { + int code; + b->ptr++; /* say we have read it as far as + * flush() is concerned */ + b->buf++; /* Leave space in front of buffer */ + /* Note as we have moved buf up flush's + posn += ptr-buf + will naturally make posn point at CR + */ + b->bufsiz--; /* Buffer is thus smaller */ + code = PerlIO_fill(f); /* Fetch some more */ + b->bufsiz++; /* Restore size for next time */ + b->buf--; /* Point at space */ + b->ptr = nl = b->buf; /* Which is what we hand + * off */ + *nl = NATIVE_0xd; /* Fill in the CR */ + if (code == 0) + goto test; /* fill() call worked */ + /* + * CR at EOF - just fall through + */ + /* Should we clear EOF though ??? */ + } + } + } + } + return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr); } return 0; } @@ -4684,50 +4684,50 @@ PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf); if (!b->buf) - PerlIO_get_base(f); + PerlIO_get_base(f); if (!ptr) { - if (c->nl) { - ptr = c->nl + 1; - if (ptr == b->end && *c->nl == NATIVE_0xd) { - /* Deferred CR at end of buffer case - we lied about count */ - ptr--; - } - } - else { - ptr = b->end; - } - ptr -= cnt; + if (c->nl) { + ptr = c->nl + 1; + if (ptr == b->end && *c->nl == NATIVE_0xd) { + /* Deferred CR at end of buffer case - we lied about count */ + ptr--; + } + } + else { + ptr = b->end; + } + ptr -= cnt; } else { - NOOP; + NOOP; #if 0 - /* - * Test code - delete when it works ... - */ - IV flags = PerlIOBase(f)->flags; - STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end; - if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) { - /* Deferred CR at end of buffer case - we lied about count */ - chk--; - } - chk -= cnt; - - if (ptr != chk ) { - Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf - " nl=%p e=%p for %d", (void*)ptr, (void*)chk, - flags, c->nl, b->end, cnt); - } + /* + * Test code - delete when it works ... + */ + IV flags = PerlIOBase(f)->flags; + STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end; + if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) { + /* Deferred CR at end of buffer case - we lied about count */ + chk--; + } + chk -= cnt; + + if (ptr != chk ) { + Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf + " nl=%p e=%p for %d", (void*)ptr, (void*)chk, + flags, c->nl, b->end, cnt); + } #endif } if (c->nl) { - if (ptr > c->nl) { - /* - * They have taken what we lied about - */ - *(c->nl) = NATIVE_0xd; - c->nl = NULL; - ptr++; - } + if (ptr > c->nl) { + /* + * They have taken what we lied about + */ + *(c->nl) = NATIVE_0xd; + c->nl = NULL; + ptr++; + } } b->ptr = ptr; PerlIOBase(f)->flags |= PERLIO_F_RDBUF; @@ -4737,49 +4737,49 @@ SSize_t PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) { if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) - return PerlIOBuf_write(aTHX_ f, vbuf, count); + return PerlIOBuf_write(aTHX_ f, vbuf, count); else { - PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); - const STDCHAR *buf = (const STDCHAR *) vbuf; - const STDCHAR * const ebuf = buf + count; - if (!b->buf) - PerlIO_get_base(f); - if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) - return 0; - while (buf < ebuf) { - const STDCHAR * const eptr = b->buf + b->bufsiz; - PerlIOBase(f)->flags |= PERLIO_F_WRBUF; - while (buf < ebuf && b->ptr < eptr) { - if (*buf == '\n') { - if ((b->ptr + 2) > eptr) { - /* - * Not room for both - */ - PerlIO_flush(f); - break; - } - else { - *(b->ptr)++ = NATIVE_0xd; /* CR */ - *(b->ptr)++ = NATIVE_0xa; /* LF */ - buf++; - if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) { - PerlIO_flush(f); - break; - } - } - } - else { - *(b->ptr)++ = *buf++; - } - if (b->ptr >= eptr) { - PerlIO_flush(f); - break; - } - } - } - if (PerlIOBase(f)->flags & PERLIO_F_UNBUF) - PerlIO_flush(f); - return (buf - (STDCHAR *) vbuf); + PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); + const STDCHAR *buf = (const STDCHAR *) vbuf; + const STDCHAR * const ebuf = buf + count; + if (!b->buf) + PerlIO_get_base(f); + if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) + return 0; + while (buf < ebuf) { + const STDCHAR * const eptr = b->buf + b->bufsiz; + PerlIOBase(f)->flags |= PERLIO_F_WRBUF; + while (buf < ebuf && b->ptr < eptr) { + if (*buf == '\n') { + if ((b->ptr + 2) > eptr) { + /* + * Not room for both + */ + PerlIO_flush(f); + break; + } + else { + *(b->ptr)++ = NATIVE_0xd; /* CR */ + *(b->ptr)++ = NATIVE_0xa; /* LF */ + buf++; + if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) { + PerlIO_flush(f); + break; + } + } + } + else { + *(b->ptr)++ = *buf++; + } + if (b->ptr >= eptr) { + PerlIO_flush(f); + break; + } + } + } + if (PerlIOBase(f)->flags & PERLIO_F_UNBUF) + PerlIO_flush(f); + return (buf - (STDCHAR *) vbuf); } } @@ -4788,8 +4788,8 @@ PerlIOCrlf_flush(pTHX_ PerlIO *f) { PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf); if (c->nl) { - *(c->nl) = NATIVE_0xd; - c->nl = NULL; + *(c->nl) = NATIVE_0xd; + c->nl = NULL; } return PerlIOBuf_flush(aTHX_ f); } @@ -4798,11 +4798,11 @@ IV PerlIOCrlf_binmode(pTHX_ PerlIO *f) { if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) { - /* In text mode - flush any pending stuff and flip it */ - PerlIOBase(f)->flags &= ~PERLIO_F_CRLF; + /* In text mode - flush any pending stuff and flip it */ + PerlIOBase(f)->flags &= ~PERLIO_F_CRLF; #ifndef PERLIO_USING_CRLF - /* CRLF is unusual case - if this is just the :crlf layer pop it */ - PerlIO_pop(aTHX_ f); + /* CRLF is unusual case - if this is just the :crlf layer pop it */ + PerlIO_pop(aTHX_ f); #endif } return PerlIOBase_binmode(aTHX_ f); @@ -4843,7 +4843,7 @@ PerlIO * Perl_PerlIO_stdin(pTHX) { if (!PL_perlio) { - PerlIO_stdstreams(aTHX); + PerlIO_stdstreams(aTHX); } return (PerlIO*)&PL_perlio[1]; } @@ -4852,7 +4852,7 @@ PerlIO * Perl_PerlIO_stdout(pTHX) { if (!PL_perlio) { - PerlIO_stdstreams(aTHX); + PerlIO_stdstreams(aTHX); } return (PerlIO*)&PL_perlio[2]; } @@ -4861,7 +4861,7 @@ PerlIO * Perl_PerlIO_stderr(pTHX) { if (!PL_perlio) { - PerlIO_stdstreams(aTHX); + PerlIO_stdstreams(aTHX); } return (PerlIO*)&PL_perlio[3]; } @@ -4877,12 +4877,12 @@ PerlIO_getname(PerlIO *f, char *buf) bool exported = FALSE; FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; if (!stdio) { - stdio = PerlIO_exportFILE(f,0); - exported = TRUE; + stdio = PerlIO_exportFILE(f,0); + exported = TRUE; } if (stdio) { - name = fgetname(stdio, buf); - if (exported) PerlIO_releaseFILE(f,stdio); + name = fgetname(stdio, buf); + if (exported) PerlIO_releaseFILE(f,stdio); } return name; #else @@ -4933,7 +4933,7 @@ PerlIO_getc(PerlIO *f) dTHX; STDCHAR buf[1]; if ( 1 == PerlIO_read(f, buf, 1) ) { - return (unsigned char) buf[0]; + return (unsigned char) buf[0]; } return EOF; } @@ -4944,9 +4944,9 @@ PerlIO_ungetc(PerlIO *f, int ch) { dTHX; if (ch != EOF) { - STDCHAR buf = ch; - if (PerlIO_unread(f, &buf, 1) == 1) - return ch; + STDCHAR buf = ch; + if (PerlIO_unread(f, &buf, 1) == 1) + return ch; } return EOF; } @@ -5045,7 +5045,7 @@ PerlIO_tmpfile_flags(int imode) #ifdef WIN32 const int fd = win32_tmpfd_mode(imode); if (fd >= 0) - f = PerlIO_fdopen(fd, "w+b"); + f = PerlIO_fdopen(fd, "w+b"); #elif ! defined(OS2) int fd = -1; char tempname[] = "/tmp/PerlIO_XXXXXX"; @@ -5054,16 +5054,16 @@ PerlIO_tmpfile_flags(int imode) int old_umask = umask(0177); imode &= ~MKOSTEMP_MODE_MASK; if (tmpdir && *tmpdir) { - /* if TMPDIR is set and not empty, we try that first */ - sv = newSVpv(tmpdir, 0); - sv_catpv(sv, tempname + 4); - fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode | O_VMS_DELETEONCLOSE); + /* if TMPDIR is set and not empty, we try that first */ + sv = newSVpv(tmpdir, 0); + sv_catpv(sv, tempname + 4); + fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode | O_VMS_DELETEONCLOSE); } if (fd < 0) { - SvREFCNT_dec(sv); - sv = NULL; - /* else we try /tmp */ - fd = Perl_my_mkostemp_cloexec(tempname, imode | O_VMS_DELETEONCLOSE); + SvREFCNT_dec(sv); + sv = NULL; + /* else we try /tmp */ + fd = Perl_my_mkostemp_cloexec(tempname, imode | O_VMS_DELETEONCLOSE); } if (fd < 0) { /* Try cwd */ @@ -5078,10 +5078,10 @@ PerlIO_tmpfile_flags(int imode) int writing = 1; (void)PerlIO_intmode2str(imode | MKOSTEMP_MODES, mode, &writing); f = PerlIO_fdopen(fd, mode); - if (f) - PerlIOBase(f)->flags |= PERLIO_F_TEMP; + if (f) + PerlIOBase(f)->flags |= PERLIO_F_TEMP; # ifndef VMS - PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname); + PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname); # endif } SvREFCNT_dec(sv); @@ -5089,7 +5089,7 @@ PerlIO_tmpfile_flags(int imode) FILE * const stdio = PerlSIO_tmpfile(); if (stdio) - f = PerlIO_fdopen(fileno(stdio), "w+"); + f = PerlIO_fdopen(fileno(stdio), "w+"); #endif /* else WIN32 */ return f; @@ -5100,7 +5100,7 @@ Perl_PerlIO_save_errno(pTHX_ PerlIO *f) { PERL_UNUSED_CONTEXT; if (!PerlIOValid(f)) - return; + return; PerlIOBase(f)->err = errno; #ifdef VMS PerlIOBase(f)->os_err = vaxc$errno; @@ -5116,7 +5116,7 @@ Perl_PerlIO_restore_errno(pTHX_ PerlIO *f) { PERL_UNUSED_CONTEXT; if (!PerlIOValid(f)) - return; + return; SETERRNO(PerlIOBase(f)->err, PerlIOBase(f)->os_err); #ifdef OS2 Perl_rc = PerlIOBase(f)->os_err); @@ -5144,17 +5144,17 @@ Perl_PerlIO_context_layers(pTHX_ const char *mode) */ if (!PL_curcop) - return NULL; + return NULL; if (mode && mode[0] != 'r') { - if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT) - direction = "open>"; + if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT) + direction = "open>"; } else { - if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN) - direction = "open<"; + if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN) + direction = "open<"; } if (!direction) - return NULL; + return NULL; layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0); @@ -5169,13 +5169,13 @@ int PerlIO_setpos(PerlIO *f, SV *pos) { if (SvOK(pos)) { - if (f) { - dTHX; - STRLEN len; - const Off_t * const posn = (Off_t *) SvPV(pos, len); - if(len == sizeof(Off_t)) - return PerlIO_seek(f, *posn, SEEK_SET); - } + if (f) { + dTHX; + STRLEN len; + const Off_t * const posn = (Off_t *) SvPV(pos, len); + if(len == sizeof(Off_t)) + return PerlIO_seek(f, *posn, SEEK_SET); + } } SETERRNO(EINVAL, SS_IVCHAN); return -1; @@ -5186,17 +5186,17 @@ int PerlIO_setpos(PerlIO *f, SV *pos) { if (SvOK(pos)) { - if (f) { - dTHX; - STRLEN len; - Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len); - if(len == sizeof(Fpos_t)) + if (f) { + dTHX; + STRLEN len; + Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len); + if(len == sizeof(Fpos_t)) # if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64) - return fsetpos64(f, fpos); + return fsetpos64(f, fpos); # else - return fsetpos(f, fpos); + return fsetpos(f, fpos); # endif - } + } } SETERRNO(EINVAL, SS_IVCHAN); return -1; diff --git a/perlio.h b/perlio.h index ee16ab8774e4..f444fa86d017 100644 --- a/perlio.h +++ b/perlio.h @@ -63,22 +63,15 @@ typedef PerlIOl *PerlIO; #define PerlIO PerlIO #define PERLIO_LAYERS 1 -/* PERLIO_FUNCS_CONST is now on by default for efficiency, PERLIO_FUNCS_CONST - can be removed 1 day once stable & then PerlIO vtables are permanently RO */ -#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 PERL_CALLCONV void PerlIO_define_layer(pTHX_ PerlIO_funcs *tab); PERL_CALLCONV PerlIO_funcs *PerlIO_find_layer(pTHX_ const char *name, STRLEN len, - int load); + int load); PERL_CALLCONV PerlIO *PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), - const char *mode, SV *arg); + const char *mode, SV *arg); PERL_CALLCONV void PerlIO_pop(pTHX_ PerlIO *f); PERL_CALLCONV AV* PerlIO_get_layers(pTHX_ PerlIO *f); PERL_CALLCONV void PerlIO_clone(pTHX_ PerlInterpreter *proto, @@ -189,8 +182,8 @@ PERL_CALLCONV PerlIO *PerlIO_open(const char *, const char *); #endif #ifndef PerlIO_openn PERL_CALLCONV PerlIO *PerlIO_openn(pTHX_ const char *layers, const char *mode, - int fd, int imode, int perm, PerlIO *old, - int narg, SV **arg); + int fd, int imode, int perm, PerlIO *old, + int narg, SV **arg); #endif #ifndef PerlIO_eof PERL_CALLCONV int PerlIO_eof(PerlIO *); @@ -315,11 +308,11 @@ PERL_CALLCONV int PerlIO_isutf8(PerlIO *); #endif #ifndef PerlIO_apply_layers PERL_CALLCONV int PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, - const char *names); + const char *names); #endif #ifndef PerlIO_binmode PERL_CALLCONV int PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int omode, - const char *names); + const char *names); #endif #ifndef PerlIO_getname PERL_CALLCONV char *PerlIO_getname(PerlIO *, char *); diff --git a/perliol.h b/perliol.h index 40b4224e508a..691e09533f78 100644 --- a/perliol.h +++ b/perliol.h @@ -21,10 +21,10 @@ struct _PerlIO_funcs { IV (*Pushed) (pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab); IV (*Popped) (pTHX_ PerlIO *f); PerlIO *(*Open) (pTHX_ PerlIO_funcs *tab, - PerlIO_list_t *layers, IV n, - const char *mode, - int fd, int imode, int perm, - PerlIO *old, int narg, SV **args); + PerlIO_list_t *layers, IV n, + const char *mode, + int fd, int imode, int perm, + PerlIO *old, int narg, SV **args); IV (*Binmode)(pTHX_ PerlIO *f); SV *(*Getarg) (pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags); IV (*Fileno) (pTHX_ PerlIO *f); @@ -106,23 +106,16 @@ struct _PerlIO { #define PerlIOValid(f) ((f) && *(f)) /*--------------------------------------------------------------------------------------*/ -/* Data exports - EXTCONST rather than extern is needed for Cygwin */ -#undef EXTPERLIO -#ifdef PERLIO_FUNCS_CONST -#define EXTPERLIO EXTCONST -#else -#define EXTPERLIO EXT -#endif -EXTPERLIO PerlIO_funcs PerlIO_unix; -EXTPERLIO PerlIO_funcs PerlIO_perlio; -EXTPERLIO PerlIO_funcs PerlIO_stdio; -EXTPERLIO PerlIO_funcs PerlIO_crlf; -EXTPERLIO PerlIO_funcs PerlIO_utf8; -EXTPERLIO PerlIO_funcs PerlIO_byte; -EXTPERLIO PerlIO_funcs PerlIO_raw; -EXTPERLIO PerlIO_funcs PerlIO_pending; +EXTCONST PerlIO_funcs PerlIO_unix; +EXTCONST PerlIO_funcs PerlIO_perlio; +EXTCONST PerlIO_funcs PerlIO_stdio; +EXTCONST PerlIO_funcs PerlIO_crlf; +EXTCONST PerlIO_funcs PerlIO_utf8; +EXTCONST PerlIO_funcs PerlIO_byte; +EXTCONST PerlIO_funcs PerlIO_raw; +EXTCONST PerlIO_funcs PerlIO_pending; #ifdef WIN32 -EXTPERLIO PerlIO_funcs PerlIO_win32; +EXTCONST PerlIO_funcs PerlIO_win32; #endif PERL_CALLCONV PerlIO *PerlIO_allocate(pTHX); PERL_CALLCONV SV *PerlIO_arg_fetch(PerlIO_list_t *av, IV n); @@ -151,7 +144,7 @@ typedef struct { } PerlIOBuf; PERL_CALLCONV int PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, - PerlIO_list_t *layers, IV n, IV max); + PerlIO_list_t *layers, IV n, IV max); PERL_CALLCONV int PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names); PERL_CALLCONV PerlIO_funcs *PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def); diff --git a/perlvars.h b/perlvars.h index 760cb5c0d02d..0518c0fe4ab6 100644 --- a/perlvars.h +++ b/perlvars.h @@ -38,9 +38,9 @@ use the variable. PERLVAR(G, op_mutex, perl_mutex) /* Mutex for op refcounting */ #endif PERLVARI(G, curinterp, PerlInterpreter *, NULL) - /* currently running interpreter - * (initial parent interpreter under - * useithreads) */ + /* currently running interpreter + * (initial parent interpreter under + * useithreads) */ #if defined(USE_ITHREADS) PERLVAR(G, thr_key, perl_key) /* key to retrieve per-thread struct */ #endif @@ -57,7 +57,7 @@ PERLVARI(G, sig_handlers_initted, int, 0) #endif #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS PERLVARA(G, sig_ignoring, SIG_SIZE, int) - /* which signals we are ignoring */ + /* which signals we are ignoring */ #endif #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS PERLVARA(G, sig_defaulting, SIG_SIZE, int) @@ -104,10 +104,8 @@ PERLVARI(G, mmap_page_size, IV, 0) #if defined(USE_ITHREADS) PERLVAR(G, hints_mutex, perl_mutex) /* Mutex for refcounted he refcounting */ -PERLVAR(G, env_mutex, perl_mutex) /* Mutex for accessing ENV */ -# if ! defined(USE_THREAD_SAFE_LOCALE) || defined(TS_W32_BROKEN_LOCALECONV) -PERLVAR(G, locale_mutex, perl_mutex) /* Mutex for setlocale() changing */ -# endif +PERLVAR(G, env_mutex, perl_RnW1_mutex_t) /* Mutex for accessing ENV */ +PERLVAR(G, locale_mutex, perl_mutex) /* Mutex related to locale handling */ # ifndef USE_THREAD_SAFE_LOCALE PERLVAR(G, lc_numeric_mutex, perl_mutex) /* Mutex for switching LC_NUMERIC */ # endif @@ -192,9 +190,9 @@ PERLVARI(G, veto_cleanup, int, FALSE) /* exit without cleanup */ Function pointer, pointing at a function used to handle extended keywords. The function should be declared as - int keyword_plugin_function(pTHX_ - char *keyword_ptr, STRLEN keyword_len, - OP **op_ptr) + int keyword_plugin_function(pTHX_ + char *keyword_ptr, STRLEN keyword_len, + OP **op_ptr) The function is called from the tokeniser, whenever a possible keyword is seen. C points at the word in the parser's input @@ -307,6 +305,3 @@ PERLVARI(G, strategy_socket, int, 0) /* doio.c */ PERLVARI(G, strategy_accept, int, 0) /* doio.c */ PERLVARI(G, strategy_pipe, int, 0) /* doio.c */ PERLVARI(G, strategy_socketpair, int, 0) /* doio.c */ - -#ifdef PERL_IMPLICIT_CONTEXT -#endif diff --git a/perly.act b/perly.act index bc684e7347de..d623d04895c7 100644 --- a/perly.act +++ b/perly.act @@ -5,7 +5,7 @@ */ case 2: -#line 121 "perly.y" +#line 138 "perly.y" { parser->expect = XSTATE; (yyval.ival) = 0; @@ -14,7 +14,7 @@ case 2: break; case 3: -#line 126 "perly.y" +#line 143 "perly.y" { newPROG(block_end((ps[-1].val.ival),(ps[0].val.opval))); PL_compiling.cop_seq = 0; @@ -24,7 +24,7 @@ case 2: break; case 4: -#line 132 "perly.y" +#line 149 "perly.y" { parser->expect = XTERM; (yyval.ival) = 0; @@ -33,7 +33,7 @@ case 2: break; case 5: -#line 137 "perly.y" +#line 154 "perly.y" { PL_eval_root = (ps[0].val.opval); (yyval.ival) = 0; @@ -42,7 +42,7 @@ case 2: break; case 6: -#line 142 "perly.y" +#line 159 "perly.y" { parser->expect = XBLOCK; (yyval.ival) = 0; @@ -51,7 +51,7 @@ case 2: break; case 7: -#line 147 "perly.y" +#line 164 "perly.y" { PL_pad_reset_pending = TRUE; PL_eval_root = (ps[0].val.opval); @@ -63,7 +63,7 @@ case 2: break; case 8: -#line 155 "perly.y" +#line 172 "perly.y" { parser->expect = XSTATE; (yyval.ival) = 0; @@ -72,7 +72,7 @@ case 2: break; case 9: -#line 160 "perly.y" +#line 177 "perly.y" { PL_pad_reset_pending = TRUE; PL_eval_root = (ps[0].val.opval); @@ -84,7 +84,7 @@ case 2: break; case 10: -#line 168 "perly.y" +#line 185 "perly.y" { parser->expect = XSTATE; (yyval.ival) = 0; @@ -93,7 +93,7 @@ case 2: break; case 11: -#line 173 "perly.y" +#line 190 "perly.y" { PL_pad_reset_pending = TRUE; PL_eval_root = (ps[0].val.opval); @@ -105,7 +105,7 @@ case 2: break; case 12: -#line 181 "perly.y" +#line 198 "perly.y" { parser->expect = XSTATE; (yyval.ival) = 0; @@ -114,7 +114,7 @@ case 2: break; case 13: -#line 186 "perly.y" +#line 203 "perly.y" { PL_eval_root = (ps[0].val.opval); (yyval.ival) = 0; @@ -123,7 +123,7 @@ case 2: break; case 14: -#line 191 "perly.y" +#line 208 "perly.y" { parser->expect = XSTATE; (yyval.ival) = 0; @@ -132,7 +132,7 @@ case 2: break; case 15: -#line 196 "perly.y" +#line 213 "perly.y" { PL_eval_root = (ps[0].val.opval); (yyval.ival) = 0; @@ -141,7 +141,7 @@ case 2: break; case 16: -#line 204 "perly.y" +#line 221 "perly.y" { if (parser->copline > (line_t)(ps[-3].val.ival)) parser->copline = (line_t)(ps[-3].val.ival); (yyval.opval) = block_end((ps[-2].val.ival), (ps[-1].val.opval)); @@ -150,7 +150,7 @@ case 2: break; case 17: -#line 212 "perly.y" +#line 229 "perly.y" { if (parser->copline > (line_t)(ps[-6].val.ival)) parser->copline = (line_t)(ps[-6].val.ival); (yyval.opval) = block_end((ps[-5].val.ival), (ps[-2].val.opval)); @@ -159,14 +159,14 @@ case 2: break; case 18: -#line 219 "perly.y" +#line 236 "perly.y" { (yyval.ival) = block_start(TRUE); parser->parsed_sub = 0; } break; case 19: -#line 224 "perly.y" +#line 241 "perly.y" { if (parser->copline > (line_t)(ps[-3].val.ival)) parser->copline = (line_t)(ps[-3].val.ival); (yyval.opval) = block_end((ps[-2].val.ival), (ps[-1].val.opval)); @@ -175,20 +175,20 @@ case 2: break; case 20: -#line 231 "perly.y" +#line 248 "perly.y" { (yyval.ival) = block_start(FALSE); parser->parsed_sub = 0; } break; case 21: -#line 237 "perly.y" +#line 254 "perly.y" { (yyval.opval) = NULL; } break; case 22: -#line 239 "perly.y" +#line 256 "perly.y" { (yyval.opval) = op_append_list(OP_LINESEQ, (ps[-1].val.opval), (ps[0].val.opval)); PL_pad_reset_pending = TRUE; if ((ps[-1].val.opval) && (ps[0].val.opval)) @@ -198,13 +198,13 @@ case 2: break; case 23: -#line 248 "perly.y" +#line 265 "perly.y" { (yyval.opval) = NULL; } break; case 24: -#line 250 "perly.y" +#line 267 "perly.y" { (yyval.opval) = op_append_list(OP_LINESEQ, (ps[-1].val.opval), (ps[0].val.opval)); PL_pad_reset_pending = TRUE; if ((ps[-1].val.opval) && (ps[0].val.opval)) @@ -214,7 +214,7 @@ case 2: break; case 25: -#line 259 "perly.y" +#line 276 "perly.y" { (yyval.opval) = (ps[0].val.opval) ? newSTATEOP(0, NULL, (ps[0].val.opval)) : NULL; } @@ -222,13 +222,13 @@ case 2: break; case 26: -#line 263 "perly.y" +#line 280 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; case 27: -#line 267 "perly.y" +#line 284 "perly.y" { SV *label = cSVOPx_sv((ps[-1].val.opval)); (yyval.opval) = newSTATEOP(SvFLAGS(label) & SVf_UTF8, @@ -239,7 +239,7 @@ case 2: break; case 28: -#line 274 "perly.y" +#line 291 "perly.y" { SV *label = cSVOPx_sv((ps[-1].val.opval)); (yyval.opval) = newSTATEOP(SvFLAGS(label) & SVf_UTF8, @@ -250,13 +250,13 @@ case 2: break; case 29: -#line 284 "perly.y" +#line 301 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; case 30: -#line 286 "perly.y" +#line 303 "perly.y" { CV *fmtcv = PL_compcv; newFORM((ps[-2].val.ival), (ps[-1].val.opval), (ps[0].val.opval)); @@ -270,7 +270,7 @@ case 2: break; case 31: -#line 298 "perly.y" +#line 315 "perly.y" { init_named_cv(PL_compcv, (ps[-1].val.opval)); parser->in_my = 0; @@ -280,7 +280,7 @@ case 2: break; case 32: -#line 304 "perly.y" +#line 321 "perly.y" { SvREFCNT_inc_simple_void(PL_compcv); (ps[-5].val.opval)->op_type == OP_CONST @@ -295,7 +295,7 @@ case 2: break; case 33: -#line 319 "perly.y" +#line 336 "perly.y" { init_named_cv(PL_compcv, (ps[-1].val.opval)); parser->in_my = 0; @@ -305,7 +305,7 @@ case 2: break; case 34: -#line 325 "perly.y" +#line 342 "perly.y" { SvREFCNT_inc_simple_void(PL_compcv); (ps[-4].val.opval)->op_type == OP_CONST @@ -320,7 +320,7 @@ case 2: break; case 35: -#line 336 "perly.y" +#line 353 "perly.y" { package((ps[-1].val.opval)); if ((ps[-2].val.opval)) @@ -331,13 +331,13 @@ case 2: break; case 36: -#line 343 "perly.y" +#line 360 "perly.y" { CvSPECIAL_on(PL_compcv); /* It's a BEGIN {} */ } break; case 37: -#line 345 "perly.y" +#line 362 "perly.y" { SvREFCNT_inc_simple_void(PL_compcv); utilize((ps[-6].val.ival), (ps[-5].val.ival), (ps[-3].val.opval), (ps[-2].val.opval), (ps[-1].val.opval)); @@ -348,7 +348,7 @@ case 2: break; case 38: -#line 352 "perly.y" +#line 369 "perly.y" { (yyval.opval) = block_end((ps[-4].val.ival), newCONDOP(0, (ps[-3].val.opval), op_scope((ps[-1].val.opval)), (ps[0].val.opval))); @@ -358,7 +358,7 @@ case 2: break; case 39: -#line 358 "perly.y" +#line 375 "perly.y" { (yyval.opval) = block_end((ps[-4].val.ival), newCONDOP(0, (ps[-3].val.opval), (ps[0].val.opval), op_scope((ps[-1].val.opval)))); @@ -368,7 +368,7 @@ case 2: break; case 40: -#line 364 "perly.y" +#line 381 "perly.y" { (yyval.opval) = block_end((ps[-3].val.ival), newGIVENOP((ps[-2].val.opval), op_scope((ps[0].val.opval)), 0)); parser->copline = (line_t)(ps[-5].val.ival); @@ -377,19 +377,19 @@ case 2: break; case 41: -#line 369 "perly.y" +#line 386 "perly.y" { (yyval.opval) = block_end((ps[-3].val.ival), newWHENOP((ps[-2].val.opval), op_scope((ps[0].val.opval)))); } break; case 42: -#line 371 "perly.y" +#line 388 "perly.y" { (yyval.opval) = newWHENOP(0, op_scope((ps[0].val.opval))); } break; case 43: -#line 373 "perly.y" +#line 390 "perly.y" { (yyval.opval) = block_end((ps[-5].val.ival), newWHILEOP(0, 1, NULL, @@ -400,7 +400,7 @@ case 2: break; case 44: -#line 380 "perly.y" +#line 397 "perly.y" { (yyval.opval) = block_end((ps[-5].val.ival), newWHILEOP(0, 1, NULL, @@ -411,19 +411,19 @@ case 2: break; case 45: -#line 387 "perly.y" +#line 404 "perly.y" { parser->expect = XTERM; } break; case 46: -#line 389 "perly.y" +#line 406 "perly.y" { parser->expect = XTERM; } break; case 47: -#line 392 "perly.y" +#line 409 "perly.y" { OP *initop = (ps[-9].val.opval); OP *forop = newWHILEOP(0, 1, NULL, @@ -442,7 +442,7 @@ case 2: break; case 48: -#line 407 "perly.y" +#line 424 "perly.y" { (yyval.opval) = block_end((ps[-6].val.ival), newFOROP(0, (ps[-5].val.opval), (ps[-3].val.opval), (ps[-1].val.opval), (ps[0].val.opval))); parser->copline = (line_t)(ps[-8].val.ival); @@ -451,7 +451,7 @@ case 2: break; case 49: -#line 412 "perly.y" +#line 429 "perly.y" { (yyval.opval) = block_end((ps[-4].val.ival), newFOROP(0, op_lvalue((ps[-6].val.opval), OP_ENTERLOOP), (ps[-3].val.opval), (ps[-1].val.opval), (ps[0].val.opval))); @@ -461,13 +461,13 @@ case 2: break; case 50: -#line 418 "perly.y" +#line 435 "perly.y" { parser->in_my = 0; (yyval.opval) = my((ps[0].val.opval)); } break; case 51: -#line 420 "perly.y" +#line 437 "perly.y" { (yyval.opval) = block_end( (ps[-7].val.ival), @@ -484,7 +484,7 @@ case 2: break; case 52: -#line 433 "perly.y" +#line 450 "perly.y" { (yyval.opval) = block_end((ps[-4].val.ival), newFOROP( 0, op_lvalue(newUNOP(OP_REFGEN, 0, @@ -496,7 +496,7 @@ case 2: break; case 53: -#line 441 "perly.y" +#line 458 "perly.y" { (yyval.opval) = block_end((ps[-4].val.ival), newFOROP(0, NULL, (ps[-3].val.opval), (ps[-1].val.opval), (ps[0].val.opval))); @@ -506,7 +506,44 @@ case 2: break; case 54: -#line 447 "perly.y" +#line 464 "perly.y" + { parser->in_my = 1; } + + break; + + case 55: +#line 466 "perly.y" + { parser->in_my = 0; intro_my(); } + + break; + + case 56: +#line 468 "perly.y" + { + OP *tryblock, *catchblock; + + tryblock = newUNOP(OP_ENTERTRY, OPf_SPECIAL, (ps[-8].val.opval)); + + catchblock = newLOGOP(OP_CATCH, 0, + newOP(OP_NULL, 0), /* LOGOP always needs an op_first */ + block_end((ps[-4].val.ival), op_scope((ps[0].val.opval)))); + + /* catchblock itself is an OP_NULL; the real OP_CATCH is + * its op_first */ + assert(cUNOPx(catchblock)->op_first->op_type == OP_CATCH); + cUNOPx(catchblock)->op_first->op_targ = (ps[-3].val.opval)->op_targ; + op_free((ps[-3].val.opval)); + + (yyval.opval) = op_append_list(OP_LEAVE, + newOP(OP_ENTER, 0), + op_append_list(OP_LINESEQ, + tryblock, catchblock)); + } + + break; + + case 57: +#line 489 "perly.y" { /* a block is a loop that happens once */ (yyval.opval) = newWHILEOP(0, 1, NULL, @@ -515,8 +552,8 @@ case 2: break; - case 55: -#line 453 "perly.y" + case 58: +#line 495 "perly.y" { package((ps[-2].val.opval)); if ((ps[-3].val.opval)) { @@ -526,8 +563,8 @@ case 2: break; - case 56: -#line 460 "perly.y" + case 59: +#line 502 "perly.y" { /* a block is a loop that happens once */ (yyval.opval) = newWHILEOP(0, 1, NULL, @@ -538,16 +575,16 @@ case 2: break; - case 57: -#line 468 "perly.y" + case 60: +#line 510 "perly.y" { (yyval.opval) = (ps[-1].val.opval); } break; - case 58: -#line 472 "perly.y" + case 61: +#line 514 "perly.y" { (yyval.opval) = newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0), newSVOP(OP_CONST, 0, newSVpvs("Unimplemented"))); @@ -555,8 +592,8 @@ case 2: break; - case 59: -#line 477 "perly.y" + case 62: +#line 519 "perly.y" { (yyval.opval) = NULL; parser->copline = NOLINE; @@ -564,8 +601,8 @@ case 2: break; - case 60: -#line 485 "perly.y" + case 63: +#line 527 "perly.y" { OP *list; if ((ps[0].val.opval)) { OP *term = (ps[0].val.opval); @@ -583,75 +620,75 @@ case 2: break; - case 61: -#line 502 "perly.y" + case 64: +#line 544 "perly.y" { (yyval.opval) = NULL; } break; - case 62: -#line 504 "perly.y" + case 65: +#line 546 "perly.y" { (yyval.opval) = op_unscope((ps[-1].val.opval)); } break; - case 63: -#line 509 "perly.y" + case 67: +#line 554 "perly.y" { (yyval.opval) = NULL; } break; - case 64: -#line 511 "perly.y" + case 68: +#line 556 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; - case 65: -#line 513 "perly.y" + case 69: +#line 558 "perly.y" { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[0].val.opval), (ps[-2].val.opval)); } break; - case 66: -#line 515 "perly.y" + case 70: +#line 560 "perly.y" { (yyval.opval) = newLOGOP(OP_OR, 0, (ps[0].val.opval), (ps[-2].val.opval)); } break; - case 67: -#line 517 "perly.y" + case 71: +#line 562 "perly.y" { (yyval.opval) = newLOOPOP(OPf_PARENS, 1, scalar((ps[0].val.opval)), (ps[-2].val.opval)); } break; - case 68: -#line 519 "perly.y" + case 72: +#line 564 "perly.y" { (yyval.opval) = newLOOPOP(OPf_PARENS, 1, (ps[0].val.opval), (ps[-2].val.opval)); } break; - case 69: -#line 521 "perly.y" + case 73: +#line 566 "perly.y" { (yyval.opval) = newFOROP(0, NULL, (ps[0].val.opval), (ps[-2].val.opval), NULL); parser->copline = (line_t)(ps[-1].val.ival); } break; - case 70: -#line 524 "perly.y" + case 74: +#line 569 "perly.y" { (yyval.opval) = newWHENOP((ps[0].val.opval), op_scope((ps[-2].val.opval))); } break; - case 71: -#line 529 "perly.y" + case 75: +#line 574 "perly.y" { (yyval.opval) = NULL; } break; - case 72: -#line 531 "perly.y" + case 76: +#line 576 "perly.y" { ((ps[0].val.opval))->op_flags |= OPf_PARENS; (yyval.opval) = op_scope((ps[0].val.opval)); @@ -659,8 +696,8 @@ case 2: break; - case 73: -#line 536 "perly.y" + case 77: +#line 581 "perly.y" { parser->copline = (line_t)(ps[-5].val.ival); (yyval.opval) = newCONDOP(0, newSTATEOP(OPf_SPECIAL,NULL,(ps[-3].val.opval)), @@ -670,153 +707,153 @@ case 2: break; - case 74: -#line 546 "perly.y" + case 78: +#line 591 "perly.y" { (yyval.opval) = NULL; } break; - case 75: -#line 548 "perly.y" + case 79: +#line 593 "perly.y" { (yyval.opval) = op_scope((ps[0].val.opval)); } break; - case 76: -#line 553 "perly.y" + case 80: +#line 598 "perly.y" { (yyval.ival) = (PL_min_intro_pending && PL_max_intro_pending >= PL_min_intro_pending); intro_my(); } break; - case 77: -#line 559 "perly.y" + case 81: +#line 604 "perly.y" { (yyval.opval) = NULL; } break; - case 79: -#line 565 "perly.y" + case 83: +#line 610 "perly.y" { YYSTYPE tmplval; (void)scan_num("1", &tmplval); (yyval.opval) = tmplval.opval; } break; - case 81: -#line 573 "perly.y" + case 85: +#line 618 "perly.y" { (yyval.opval) = invert(scalar((ps[0].val.opval))); } break; - case 82: -#line 578 "perly.y" + case 86: +#line 623 "perly.y" { (yyval.opval) = (ps[0].val.opval); intro_my(); } break; - case 83: -#line 582 "perly.y" + case 87: +#line 627 "perly.y" { (yyval.opval) = (ps[0].val.opval); intro_my(); } break; - case 84: -#line 585 "perly.y" + case 88: +#line 630 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; - case 85: -#line 586 "perly.y" + case 89: +#line 631 "perly.y" { (yyval.opval) = NULL; } break; - case 86: -#line 590 "perly.y" + case 90: +#line 635 "perly.y" { (yyval.ival) = start_subparse(FALSE, 0); SAVEFREESV(PL_compcv); } break; - case 87: -#line 596 "perly.y" + case 91: +#line 641 "perly.y" { (yyval.ival) = start_subparse(FALSE, CVf_ANON); SAVEFREESV(PL_compcv); } break; - case 88: -#line 601 "perly.y" + case 92: +#line 646 "perly.y" { (yyval.ival) = start_subparse(TRUE, 0); SAVEFREESV(PL_compcv); } break; - case 91: -#line 612 "perly.y" + case 95: +#line 657 "perly.y" { (yyval.opval) = NULL; } break; - case 93: -#line 618 "perly.y" + case 97: +#line 663 "perly.y" { (yyval.opval) = NULL; } break; - case 94: -#line 620 "perly.y" + case 98: +#line 665 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; - case 95: -#line 622 "perly.y" + case 99: +#line 667 "perly.y" { (yyval.opval) = NULL; } break; - case 96: -#line 627 "perly.y" + case 100: +#line 672 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; - case 97: -#line 629 "perly.y" + case 101: +#line 674 "perly.y" { (yyval.opval) = NULL; } break; - case 98: -#line 640 "perly.y" + case 102: +#line 685 "perly.y" { parser->in_my = 0; (yyval.opval) = NULL; } break; - case 99: -#line 642 "perly.y" + case 103: +#line 687 "perly.y" { parser->in_my = 0; (yyval.opval) = (ps[0].val.opval); } break; - case 100: -#line 647 "perly.y" + case 104: +#line 692 "perly.y" { (yyval.ival) = '@'; } break; - case 101: -#line 649 "perly.y" + case 105: +#line 694 "perly.y" { (yyval.ival) = '%'; } break; - case 102: -#line 653 "perly.y" + case 106: +#line 698 "perly.y" { I32 sigil = (ps[-2].val.ival); OP *var = (ps[-1].val.opval); @@ -835,26 +872,26 @@ case 2: break; - case 103: -#line 672 "perly.y" + case 107: +#line 717 "perly.y" { (yyval.opval) = NULL; } break; - case 104: -#line 674 "perly.y" + case 108: +#line 719 "perly.y" { (yyval.opval) = newOP(OP_NULL, 0); } break; - case 105: -#line 676 "perly.y" + case 109: +#line 721 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; - case 106: -#line 682 "perly.y" + case 110: +#line 727 "perly.y" { OP *var = (ps[-1].val.opval); OP *defexpr = (ps[0].val.opval); @@ -918,70 +955,70 @@ case 2: break; - case 107: -#line 747 "perly.y" + case 111: +#line 792 "perly.y" { parser->in_my = KEY_sigvar; (yyval.opval) = (ps[0].val.opval); } break; - case 108: -#line 749 "perly.y" + case 112: +#line 794 "perly.y" { parser->in_my = KEY_sigvar; (yyval.opval) = (ps[0].val.opval); } break; - case 109: -#line 755 "perly.y" + case 113: +#line 800 "perly.y" { (yyval.opval) = (ps[-1].val.opval); } break; - case 110: -#line 757 "perly.y" + case 114: +#line 802 "perly.y" { (yyval.opval) = op_append_list(OP_LINESEQ, (ps[-2].val.opval), (ps[0].val.opval)); } break; - case 111: -#line 761 "perly.y" + case 115: +#line 806 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; - case 112: -#line 766 "perly.y" + case 116: +#line 811 "perly.y" { (yyval.opval) = NULL; } break; - case 113: -#line 768 "perly.y" + case 117: +#line 813 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; - case 114: -#line 772 "perly.y" + case 118: +#line 817 "perly.y" { (yyval.opval) = NULL; } break; - case 115: -#line 774 "perly.y" + case 119: +#line 819 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; - case 116: -#line 778 "perly.y" + case 120: +#line 823 "perly.y" { (yyval.opval) = (ps[-1].val.opval); } break; - case 117: -#line 781 "perly.y" + case 121: +#line 826 "perly.y" { ENTER; SAVEIV(parser->sig_elems); @@ -995,8 +1032,8 @@ case 2: break; - case 118: -#line 792 "perly.y" + case 122: +#line 837 "perly.y" { OP *sigops = (ps[0].val.opval); struct op_argcheck_aux *aux; @@ -1054,20 +1091,20 @@ case 2: break; - case 119: -#line 849 "perly.y" + case 123: +#line 894 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; - case 120: -#line 850 "perly.y" + case 124: +#line 895 "perly.y" { (yyval.opval) = NULL; } break; - case 121: -#line 856 "perly.y" + case 125: +#line 901 "perly.y" { if (parser->copline > (line_t)(ps[-2].val.ival)) parser->copline = (line_t)(ps[-2].val.ival); @@ -1076,20 +1113,20 @@ case 2: break; - case 122: -#line 866 "perly.y" + case 126: +#line 911 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; - case 123: -#line 867 "perly.y" + case 127: +#line 912 "perly.y" { (yyval.opval) = NULL; } break; - case 124: -#line 871 "perly.y" + case 128: +#line 916 "perly.y" { if (parser->copline > (line_t)(ps[-2].val.ival)) parser->copline = (line_t)(ps[-2].val.ival); @@ -1099,32 +1136,26 @@ case 2: break; - case 125: -#line 882 "perly.y" + case 129: +#line 927 "perly.y" { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[-2].val.opval), (ps[0].val.opval)); } break; - case 126: -#line 884 "perly.y" + case 130: +#line 929 "perly.y" { (yyval.opval) = newLOGOP((ps[-1].val.ival), 0, (ps[-2].val.opval), (ps[0].val.opval)); } break; - case 127: -#line 886 "perly.y" - { (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[-2].val.opval), (ps[0].val.opval)); } - - break; - - case 129: -#line 892 "perly.y" + case 132: +#line 935 "perly.y" { (yyval.opval) = (ps[-1].val.opval); } break; - case 130: -#line 894 "perly.y" + case 133: +#line 937 "perly.y" { OP* term = (ps[0].val.opval); (yyval.opval) = op_append_elem(OP_LIST, (ps[-2].val.opval), term); @@ -1132,24 +1163,24 @@ case 2: break; - case 132: -#line 903 "perly.y" + case 135: +#line 946 "perly.y" { (yyval.opval) = op_convert_list((ps[-2].val.ival), OPf_STACKED, op_prepend_elem(OP_LIST, newGVREF((ps[-2].val.ival),(ps[-1].val.opval)), (ps[0].val.opval)) ); } break; - case 133: -#line 907 "perly.y" + case 136: +#line 950 "perly.y" { (yyval.opval) = op_convert_list((ps[-4].val.ival), OPf_STACKED, op_prepend_elem(OP_LIST, newGVREF((ps[-4].val.ival),(ps[-2].val.opval)), (ps[-1].val.opval)) ); } break; - case 134: -#line 911 "perly.y" + case 137: +#line 954 "perly.y" { (yyval.opval) = op_convert_list(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, op_prepend_elem(OP_LIST, scalar((ps[-5].val.opval)), (ps[-1].val.opval)), @@ -1158,8 +1189,8 @@ case 2: break; - case 135: -#line 917 "perly.y" + case 138: +#line 960 "perly.y" { (yyval.opval) = op_convert_list(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, scalar((ps[-2].val.opval)), newMETHOP(OP_METHOD, 0, (ps[0].val.opval)))); @@ -1167,8 +1198,8 @@ case 2: break; - case 136: -#line 922 "perly.y" + case 139: +#line 965 "perly.y" { (yyval.opval) = op_convert_list(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, op_prepend_elem(OP_LIST, (ps[-1].val.opval), (ps[0].val.opval)), @@ -1177,8 +1208,8 @@ case 2: break; - case 137: -#line 928 "perly.y" + case 140: +#line 971 "perly.y" { (yyval.opval) = op_convert_list(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, op_prepend_elem(OP_LIST, (ps[-3].val.opval), (ps[-1].val.opval)), @@ -1187,33 +1218,33 @@ case 2: break; - case 138: -#line 934 "perly.y" + case 141: +#line 977 "perly.y" { (yyval.opval) = op_convert_list((ps[-1].val.ival), 0, (ps[0].val.opval)); } break; - case 139: -#line 936 "perly.y" + case 142: +#line 979 "perly.y" { (yyval.opval) = op_convert_list((ps[-3].val.ival), 0, (ps[-1].val.opval)); } break; - case 140: -#line 938 "perly.y" + case 143: +#line 981 "perly.y" { (yyval.opval) = op_convert_list((ps[-3].val.ival), 0, (ps[-1].val.opval)); } break; - case 141: -#line 940 "perly.y" + case 144: +#line 983 "perly.y" { SvREFCNT_inc_simple_void(PL_compcv); (yyval.opval) = newANONATTRSUB((ps[-1].val.ival), 0, NULL, (ps[0].val.opval)); } break; - case 142: -#line 943 "perly.y" + case 145: +#line 986 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, op_prepend_elem(OP_LIST, (ps[-1].val.opval), (ps[0].val.opval)), (ps[-4].val.opval))); @@ -1221,21 +1252,21 @@ case 2: break; - case 145: -#line 958 "perly.y" + case 148: +#line 1001 "perly.y" { (yyval.opval) = newBINOP(OP_GELEM, 0, (ps[-4].val.opval), scalar((ps[-2].val.opval))); } break; - case 146: -#line 960 "perly.y" + case 149: +#line 1003 "perly.y" { (yyval.opval) = newBINOP(OP_AELEM, 0, oopsAV((ps[-3].val.opval)), scalar((ps[-1].val.opval))); } break; - case 147: -#line 963 "perly.y" + case 150: +#line 1006 "perly.y" { (yyval.opval) = newBINOP(OP_AELEM, 0, ref(newAVREF((ps[-4].val.opval)),OP_RV2AV), scalar((ps[-1].val.opval))); @@ -1243,8 +1274,8 @@ case 2: break; - case 148: -#line 968 "perly.y" + case 151: +#line 1011 "perly.y" { (yyval.opval) = newBINOP(OP_AELEM, 0, ref(newAVREF((ps[-3].val.opval)),OP_RV2AV), scalar((ps[-1].val.opval))); @@ -1252,31 +1283,31 @@ case 2: break; - case 149: -#line 973 "perly.y" + case 152: +#line 1016 "perly.y" { (yyval.opval) = newBINOP(OP_HELEM, 0, oopsHV((ps[-4].val.opval)), jmaybe((ps[-2].val.opval))); } break; - case 150: -#line 976 "perly.y" + case 153: +#line 1019 "perly.y" { (yyval.opval) = newBINOP(OP_HELEM, 0, ref(newHVREF((ps[-5].val.opval)),OP_RV2HV), jmaybe((ps[-2].val.opval))); } break; - case 151: -#line 980 "perly.y" + case 154: +#line 1023 "perly.y" { (yyval.opval) = newBINOP(OP_HELEM, 0, ref(newHVREF((ps[-4].val.opval)),OP_RV2HV), jmaybe((ps[-2].val.opval))); } break; - case 152: -#line 984 "perly.y" + case 155: +#line 1027 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, newCVREF(0, scalar((ps[-3].val.opval)))); if (parser->expect == XBLOCK) @@ -1285,8 +1316,8 @@ case 2: break; - case 153: -#line 990 "perly.y" + case 156: +#line 1033 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, (ps[-1].val.opval), newCVREF(0, scalar((ps[-4].val.opval))))); @@ -1296,8 +1327,8 @@ case 2: break; - case 154: -#line 998 "perly.y" + case 157: +#line 1041 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, (ps[-1].val.opval), newCVREF(0, scalar((ps[-3].val.opval))))); @@ -1307,8 +1338,8 @@ case 2: break; - case 155: -#line 1005 "perly.y" + case 158: +#line 1048 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, newCVREF(0, scalar((ps[-2].val.opval)))); if (parser->expect == XBLOCK) @@ -1317,38 +1348,38 @@ case 2: break; - case 156: -#line 1011 "perly.y" + case 159: +#line 1054 "perly.y" { (yyval.opval) = newSLICEOP(0, (ps[-1].val.opval), (ps[-4].val.opval)); } break; - case 157: -#line 1013 "perly.y" + case 160: +#line 1056 "perly.y" { (yyval.opval) = newSLICEOP(0, (ps[-1].val.opval), (ps[-3].val.opval)); } break; - case 158: -#line 1015 "perly.y" + case 161: +#line 1058 "perly.y" { (yyval.opval) = newSLICEOP(0, (ps[-1].val.opval), NULL); } break; - case 159: -#line 1020 "perly.y" + case 162: +#line 1063 "perly.y" { (yyval.opval) = newASSIGNOP(OPf_STACKED, (ps[-2].val.opval), (ps[-1].val.ival), (ps[0].val.opval)); } break; - case 160: -#line 1022 "perly.y" + case 163: +#line 1065 "perly.y" { (yyval.opval) = newBINOP((ps[-1].val.ival), 0, scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); } break; - case 161: -#line 1024 "perly.y" + case 164: +#line 1067 "perly.y" { if ((ps[-1].val.ival) != OP_REPEAT) scalar((ps[-2].val.opval)); (yyval.opval) = newBINOP((ps[-1].val.ival), 0, (ps[-2].val.opval), scalar((ps[0].val.opval))); @@ -1356,184 +1387,184 @@ case 2: break; - case 162: -#line 1029 "perly.y" + case 165: +#line 1072 "perly.y" { (yyval.opval) = newBINOP((ps[-1].val.ival), 0, scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); } break; - case 163: -#line 1031 "perly.y" + case 166: +#line 1074 "perly.y" { (yyval.opval) = newBINOP((ps[-1].val.ival), 0, scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); } break; - case 164: -#line 1033 "perly.y" + case 167: +#line 1076 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; - case 165: -#line 1035 "perly.y" + case 168: +#line 1078 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; - case 166: -#line 1037 "perly.y" + case 169: +#line 1080 "perly.y" { (yyval.opval) = newBINOP((ps[-1].val.ival), 0, scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); } break; - case 167: -#line 1039 "perly.y" + case 170: +#line 1082 "perly.y" { (yyval.opval) = newBINOP((ps[-1].val.ival), 0, scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); } break; - case 168: -#line 1041 "perly.y" + case 171: +#line 1084 "perly.y" { (yyval.opval) = newRANGE((ps[-1].val.ival), scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); } break; - case 169: -#line 1043 "perly.y" + case 172: +#line 1086 "perly.y" { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[-2].val.opval), (ps[0].val.opval)); } break; - case 170: -#line 1045 "perly.y" + case 173: +#line 1088 "perly.y" { (yyval.opval) = newLOGOP(OP_OR, 0, (ps[-2].val.opval), (ps[0].val.opval)); } break; - case 171: -#line 1047 "perly.y" + case 174: +#line 1090 "perly.y" { (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[-2].val.opval), (ps[0].val.opval)); } break; - case 172: -#line 1049 "perly.y" + case 175: +#line 1092 "perly.y" { (yyval.opval) = bind_match((ps[-1].val.ival), (ps[-2].val.opval), (ps[0].val.opval)); } break; - case 173: -#line 1053 "perly.y" + case 176: +#line 1096 "perly.y" { (yyval.opval) = cmpchain_finish((ps[0].val.opval)); } break; - case 174: -#line 1055 "perly.y" + case 177: +#line 1098 "perly.y" { (yyval.opval) = newBINOP((ps[-1].val.ival), 0, scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); } break; - case 175: -#line 1057 "perly.y" + case 178: +#line 1100 "perly.y" { yyerror("syntax error"); YYERROR; } break; - case 176: -#line 1059 "perly.y" + case 179: +#line 1102 "perly.y" { yyerror("syntax error"); YYERROR; } break; - case 177: -#line 1063 "perly.y" + case 180: +#line 1106 "perly.y" { (yyval.opval) = cmpchain_start((ps[-1].val.ival), (ps[-2].val.opval), (ps[0].val.opval)); } break; - case 178: -#line 1065 "perly.y" + case 181: +#line 1108 "perly.y" { (yyval.opval) = cmpchain_extend((ps[-1].val.ival), (ps[-2].val.opval), (ps[0].val.opval)); } break; - case 179: -#line 1069 "perly.y" + case 182: +#line 1112 "perly.y" { (yyval.opval) = cmpchain_finish((ps[0].val.opval)); } break; - case 180: -#line 1071 "perly.y" + case 183: +#line 1114 "perly.y" { (yyval.opval) = newBINOP((ps[-1].val.ival), 0, scalar((ps[-2].val.opval)), scalar((ps[0].val.opval))); } break; - case 181: -#line 1073 "perly.y" + case 184: +#line 1116 "perly.y" { yyerror("syntax error"); YYERROR; } break; - case 182: -#line 1075 "perly.y" + case 185: +#line 1118 "perly.y" { yyerror("syntax error"); YYERROR; } break; - case 183: -#line 1079 "perly.y" + case 186: +#line 1122 "perly.y" { (yyval.opval) = cmpchain_start((ps[-1].val.ival), (ps[-2].val.opval), (ps[0].val.opval)); } break; - case 184: -#line 1081 "perly.y" + case 187: +#line 1124 "perly.y" { (yyval.opval) = cmpchain_extend((ps[-1].val.ival), (ps[-2].val.opval), (ps[0].val.opval)); } break; - case 185: -#line 1086 "perly.y" + case 188: +#line 1129 "perly.y" { (yyval.opval) = newUNOP(OP_NEGATE, 0, scalar((ps[0].val.opval))); } break; - case 186: -#line 1088 "perly.y" + case 189: +#line 1131 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; - case 187: -#line 1091 "perly.y" + case 190: +#line 1134 "perly.y" { (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[0].val.opval))); } break; - case 188: -#line 1093 "perly.y" + case 191: +#line 1136 "perly.y" { (yyval.opval) = newUNOP((ps[-1].val.ival), 0, scalar((ps[0].val.opval))); } break; - case 189: -#line 1095 "perly.y" + case 192: +#line 1138 "perly.y" { (yyval.opval) = newUNOP(OP_POSTINC, 0, op_lvalue(scalar((ps[-1].val.opval)), OP_POSTINC)); } break; - case 190: -#line 1098 "perly.y" + case 193: +#line 1141 "perly.y" { (yyval.opval) = newUNOP(OP_POSTDEC, 0, op_lvalue(scalar((ps[-1].val.opval)), OP_POSTDEC));} break; - case 191: -#line 1101 "perly.y" + case 194: +#line 1144 "perly.y" { (yyval.opval) = op_convert_list(OP_JOIN, 0, op_append_elem( OP_LIST, @@ -1547,156 +1578,156 @@ case 2: break; - case 192: -#line 1112 "perly.y" + case 195: +#line 1155 "perly.y" { (yyval.opval) = newUNOP(OP_PREINC, 0, op_lvalue(scalar((ps[0].val.opval)), OP_PREINC)); } break; - case 193: -#line 1115 "perly.y" + case 196: +#line 1158 "perly.y" { (yyval.opval) = newUNOP(OP_PREDEC, 0, op_lvalue(scalar((ps[0].val.opval)), OP_PREDEC)); } break; - case 194: -#line 1122 "perly.y" + case 197: +#line 1165 "perly.y" { (yyval.opval) = newANONLIST((ps[-1].val.opval)); } break; - case 195: -#line 1124 "perly.y" + case 198: +#line 1167 "perly.y" { (yyval.opval) = newANONLIST(NULL);} break; - case 196: -#line 1126 "perly.y" + case 199: +#line 1169 "perly.y" { (yyval.opval) = newANONHASH((ps[-2].val.opval)); } break; - case 197: -#line 1128 "perly.y" + case 200: +#line 1171 "perly.y" { (yyval.opval) = newANONHASH(NULL); } break; - case 198: -#line 1130 "perly.y" + case 201: +#line 1173 "perly.y" { SvREFCNT_inc_simple_void(PL_compcv); (yyval.opval) = newANONATTRSUB((ps[-3].val.ival), (ps[-2].val.opval), (ps[-1].val.opval), (ps[0].val.opval)); } break; - case 199: -#line 1133 "perly.y" + case 202: +#line 1176 "perly.y" { SvREFCNT_inc_simple_void(PL_compcv); (yyval.opval) = newANONATTRSUB((ps[-2].val.ival), NULL, (ps[-1].val.opval), (ps[0].val.opval)); } break; - case 200: -#line 1139 "perly.y" + case 203: +#line 1182 "perly.y" { (yyval.opval) = dofile((ps[0].val.opval), (ps[-1].val.ival));} break; - case 201: -#line 1141 "perly.y" + case 204: +#line 1184 "perly.y" { (yyval.opval) = newUNOP(OP_NULL, OPf_SPECIAL, op_scope((ps[0].val.opval)));} break; - case 206: -#line 1149 "perly.y" + case 209: +#line 1192 "perly.y" { (yyval.opval) = newCONDOP(0, (ps[-4].val.opval), (ps[-2].val.opval), (ps[0].val.opval)); } break; - case 207: -#line 1151 "perly.y" + case 210: +#line 1194 "perly.y" { (yyval.opval) = newUNOP(OP_REFGEN, 0, (ps[0].val.opval)); } break; - case 208: -#line 1153 "perly.y" + case 211: +#line 1196 "perly.y" { (yyval.opval) = newUNOP(OP_REFGEN, 0, localize((ps[0].val.opval),1)); } break; - case 209: -#line 1155 "perly.y" + case 212: +#line 1198 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; - case 210: -#line 1157 "perly.y" + case 213: +#line 1200 "perly.y" { (yyval.opval) = localize((ps[0].val.opval),0); } break; - case 211: -#line 1159 "perly.y" + case 214: +#line 1202 "perly.y" { (yyval.opval) = sawparens((ps[-1].val.opval)); } break; - case 212: -#line 1161 "perly.y" + case 215: +#line 1204 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; - case 213: -#line 1163 "perly.y" + case 216: +#line 1206 "perly.y" { (yyval.opval) = sawparens(newNULLLIST()); } break; - case 214: -#line 1165 "perly.y" + case 217: +#line 1208 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; - case 215: -#line 1167 "perly.y" + case 218: +#line 1210 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; - case 216: -#line 1169 "perly.y" + case 219: +#line 1212 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; - case 217: -#line 1171 "perly.y" + case 220: +#line 1214 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; - case 218: -#line 1173 "perly.y" + case 221: +#line 1216 "perly.y" { (yyval.opval) = newUNOP(OP_AV2ARYLEN, 0, ref((ps[0].val.opval), OP_AV2ARYLEN));} break; - case 219: -#line 1175 "perly.y" + case 222: +#line 1218 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; - case 220: -#line 1177 "perly.y" + case 223: +#line 1220 "perly.y" { (yyval.opval) = op_prepend_elem(OP_ASLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_ASLICE, 0, @@ -1709,8 +1740,8 @@ case 2: break; - case 221: -#line 1187 "perly.y" + case 224: +#line 1230 "perly.y" { (yyval.opval) = op_prepend_elem(OP_KVASLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_KVASLICE, 0, @@ -1723,8 +1754,8 @@ case 2: break; - case 222: -#line 1197 "perly.y" + case 225: +#line 1240 "perly.y" { (yyval.opval) = op_prepend_elem(OP_HSLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_HSLICE, 0, @@ -1737,8 +1768,8 @@ case 2: break; - case 223: -#line 1207 "perly.y" + case 226: +#line 1250 "perly.y" { (yyval.opval) = op_prepend_elem(OP_KVHSLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_KVHSLICE, 0, @@ -1751,27 +1782,27 @@ case 2: break; - case 224: -#line 1217 "perly.y" + case 227: +#line 1260 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; - case 225: -#line 1219 "perly.y" + case 228: +#line 1262 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, 0, scalar((ps[0].val.opval))); } break; - case 226: -#line 1221 "perly.y" + case 229: +#line 1264 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[-2].val.opval))); } break; - case 227: -#line 1224 "perly.y" + case 230: +#line 1267 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, (ps[-1].val.opval), scalar((ps[-3].val.opval)))); @@ -1779,153 +1810,153 @@ case 2: break; - case 228: -#line 1229 "perly.y" + case 231: +#line 1272 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, (ps[0].val.opval), scalar((ps[-1].val.opval)))); } break; - case 229: -#line 1233 "perly.y" + case 232: +#line 1276 "perly.y" { (yyval.opval) = newSVREF((ps[-3].val.opval)); } break; - case 230: -#line 1235 "perly.y" + case 233: +#line 1278 "perly.y" { (yyval.opval) = newAVREF((ps[-3].val.opval)); } break; - case 231: -#line 1237 "perly.y" + case 234: +#line 1280 "perly.y" { (yyval.opval) = newHVREF((ps[-3].val.opval)); } break; - case 232: -#line 1239 "perly.y" + case 235: +#line 1282 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, 0, scalar(newCVREF((ps[-1].val.ival),(ps[-3].val.opval)))); } break; - case 233: -#line 1242 "perly.y" + case 236: +#line 1285 "perly.y" { (yyval.opval) = newGVREF(0,(ps[-3].val.opval)); } break; - case 234: -#line 1244 "perly.y" + case 237: +#line 1287 "perly.y" { (yyval.opval) = newOP((ps[0].val.ival), OPf_SPECIAL); PL_hints |= HINT_BLOCK_SCOPE; } break; - case 235: -#line 1247 "perly.y" + case 238: +#line 1290 "perly.y" { (yyval.opval) = newLOOPEX((ps[-1].val.ival),(ps[0].val.opval)); } break; - case 236: -#line 1249 "perly.y" + case 239: +#line 1292 "perly.y" { (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[0].val.opval))); } break; - case 237: -#line 1251 "perly.y" + case 240: +#line 1294 "perly.y" { (yyval.opval) = newOP((ps[0].val.ival), 0); } break; - case 238: -#line 1253 "perly.y" + case 241: +#line 1296 "perly.y" { (yyval.opval) = newUNOP((ps[-1].val.ival), 0, (ps[0].val.opval)); } break; - case 239: -#line 1255 "perly.y" + case 242: +#line 1298 "perly.y" { (yyval.opval) = newUNOP((ps[-1].val.ival), 0, (ps[0].val.opval)); } break; - case 240: -#line 1257 "perly.y" + case 243: +#line 1300 "perly.y" { (yyval.opval) = newOP(OP_REQUIRE, (ps[0].val.ival) ? OPf_SPECIAL : 0); } break; - case 241: -#line 1259 "perly.y" + case 244: +#line 1302 "perly.y" { (yyval.opval) = newUNOP(OP_REQUIRE, (ps[-1].val.ival) ? OPf_SPECIAL : 0, (ps[0].val.opval)); } break; - case 242: -#line 1261 "perly.y" + case 245: +#line 1304 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[0].val.opval))); } break; - case 243: -#line 1263 "perly.y" + case 246: +#line 1306 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, (ps[0].val.opval), scalar((ps[-1].val.opval)))); } break; - case 244: -#line 1266 "perly.y" + case 247: +#line 1309 "perly.y" { (yyval.opval) = newOP((ps[0].val.ival), 0); } break; - case 245: -#line 1268 "perly.y" + case 248: +#line 1311 "perly.y" { (yyval.opval) = newOP((ps[-2].val.ival), 0);} break; - case 246: -#line 1270 "perly.y" + case 249: +#line 1313 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; - case 247: -#line 1272 "perly.y" + case 250: +#line 1315 "perly.y" { (yyval.opval) = (ps[-2].val.opval); } break; - case 248: -#line 1274 "perly.y" + case 251: +#line 1317 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[0].val.opval))); } break; - case 249: -#line 1276 "perly.y" + case 252: +#line 1319 "perly.y" { (yyval.opval) = ((ps[-2].val.ival) == OP_NOT) ? newUNOP((ps[-2].val.ival), 0, newSVOP(OP_CONST, 0, newSViv(0))) : newOP((ps[-2].val.ival), OPf_SPECIAL); } break; - case 250: -#line 1280 "perly.y" + case 253: +#line 1323 "perly.y" { (yyval.opval) = newUNOP((ps[-3].val.ival), 0, (ps[-1].val.opval)); } break; - case 251: -#line 1282 "perly.y" + case 254: +#line 1325 "perly.y" { if ( (ps[0].val.opval)->op_type != OP_TRANS && (ps[0].val.opval)->op_type != OP_TRANSR @@ -1939,186 +1970,186 @@ case 2: break; - case 252: -#line 1293 "perly.y" + case 255: +#line 1336 "perly.y" { (yyval.opval) = pmruntime((ps[-5].val.opval), (ps[-2].val.opval), (ps[-1].val.opval), 1, (ps[-4].val.ival)); } break; - case 256: -#line 1301 "perly.y" + case 259: +#line 1344 "perly.y" { (yyval.opval) = my_attrs((ps[-1].val.opval),(ps[0].val.opval)); } break; - case 257: -#line 1303 "perly.y" + case 260: +#line 1346 "perly.y" { (yyval.opval) = localize((ps[0].val.opval),1); } break; - case 258: -#line 1305 "perly.y" + case 261: +#line 1348 "perly.y" { (yyval.opval) = newUNOP(OP_REFGEN, 0, my_attrs((ps[-1].val.opval),(ps[0].val.opval))); } break; - case 259: -#line 1310 "perly.y" + case 262: +#line 1353 "perly.y" { (yyval.opval) = sawparens((ps[-1].val.opval)); } break; - case 260: -#line 1312 "perly.y" + case 263: +#line 1355 "perly.y" { (yyval.opval) = sawparens(newNULLLIST()); } break; - case 261: -#line 1315 "perly.y" + case 264: +#line 1358 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; - case 262: -#line 1317 "perly.y" + case 265: +#line 1360 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; - case 263: -#line 1319 "perly.y" + case 266: +#line 1362 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; - case 264: -#line 1324 "perly.y" + case 267: +#line 1367 "perly.y" { (yyval.opval) = NULL; } break; - case 265: -#line 1326 "perly.y" + case 268: +#line 1369 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; - case 266: -#line 1330 "perly.y" + case 269: +#line 1373 "perly.y" { (yyval.opval) = NULL; } break; - case 267: -#line 1332 "perly.y" + case 270: +#line 1375 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; - case 268: -#line 1336 "perly.y" + case 271: +#line 1379 "perly.y" { (yyval.opval) = NULL; } break; - case 269: -#line 1338 "perly.y" + case 272: +#line 1381 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; - case 270: -#line 1344 "perly.y" + case 273: +#line 1387 "perly.y" { parser->in_my = 0; (yyval.opval) = my((ps[0].val.opval)); } break; - case 278: -#line 1361 "perly.y" + case 281: +#line 1404 "perly.y" { (yyval.opval) = newCVREF((ps[-1].val.ival),(ps[0].val.opval)); } break; - case 279: -#line 1365 "perly.y" + case 282: +#line 1408 "perly.y" { (yyval.opval) = newSVREF((ps[0].val.opval)); } break; - case 280: -#line 1369 "perly.y" + case 283: +#line 1412 "perly.y" { (yyval.opval) = newAVREF((ps[0].val.opval)); if ((yyval.opval)) (yyval.opval)->op_private |= (ps[-1].val.ival); } break; - case 281: -#line 1375 "perly.y" + case 284: +#line 1418 "perly.y" { (yyval.opval) = newHVREF((ps[0].val.opval)); if ((yyval.opval)) (yyval.opval)->op_private |= (ps[-1].val.ival); } break; - case 282: -#line 1381 "perly.y" + case 285: +#line 1424 "perly.y" { (yyval.opval) = newAVREF((ps[0].val.opval)); } break; - case 283: -#line 1383 "perly.y" + case 286: +#line 1426 "perly.y" { (yyval.opval) = newAVREF((ps[-3].val.opval)); } break; - case 284: -#line 1387 "perly.y" + case 287: +#line 1430 "perly.y" { (yyval.opval) = newGVREF(0,(ps[0].val.opval)); } break; - case 286: -#line 1392 "perly.y" + case 289: +#line 1435 "perly.y" { (yyval.opval) = newAVREF((ps[-2].val.opval)); } break; - case 288: -#line 1397 "perly.y" + case 291: +#line 1440 "perly.y" { (yyval.opval) = newHVREF((ps[-2].val.opval)); } break; - case 290: -#line 1402 "perly.y" + case 293: +#line 1445 "perly.y" { (yyval.opval) = newGVREF(0,(ps[-2].val.opval)); } break; - case 291: -#line 1407 "perly.y" + case 294: +#line 1450 "perly.y" { (yyval.opval) = scalar((ps[0].val.opval)); } break; - case 292: -#line 1409 "perly.y" + case 295: +#line 1452 "perly.y" { (yyval.opval) = scalar((ps[0].val.opval)); } break; - case 293: -#line 1411 "perly.y" + case 296: +#line 1454 "perly.y" { (yyval.opval) = op_scope((ps[0].val.opval)); } break; - case 294: -#line 1414 "perly.y" + case 297: +#line 1457 "perly.y" { (yyval.opval) = (ps[0].val.opval); } break; @@ -2129,6 +2160,6 @@ case 2: /* Generated from: - * f83d884147747f2d8f5a62eebc4ccd07d71b6b34e5ba1a8d7559526ad864dc97 perly.y - * 01ce33b49f9f04b8d3112b7f042cde113a7d29763a846e870f9766072a5bc614 regen_perly.pl + * 672539c523be1568df09c599b38a828c80473c60e1fddd63764d66f74e4e7b11 perly.y + * acf1cbfd2545faeaaa58b1cf0cf9d7f98b5be0752eb7a54528ef904a9e2e1ca7 regen_perly.pl * ex: set ro: */ diff --git a/perly.c b/perly.c index 091371937ddf..20854ae542b3 100644 --- a/perly.c +++ b/perly.c @@ -93,15 +93,15 @@ typedef signed char yysigned_char; # define YYDPRINTF(Args) \ do { \ if (yydebug) \ - YYFPRINTF Args; \ + YYFPRINTF Args; \ } while (0) # define YYDSYMPRINTF(Title, Token, Value) \ do { \ if (yydebug) { \ - YYFPRINTF (Perl_debug_log, "%s ", Title); \ - yysymprint (aTHX_ Perl_debug_log, Token, Value); \ - YYFPRINTF (Perl_debug_log, "\n"); \ + YYFPRINTF (Perl_debug_log, "%s ", Title); \ + yysymprint (aTHX_ Perl_debug_log, Token, Value); \ + YYFPRINTF (Perl_debug_log, "\n"); \ } \ } while (0) @@ -114,15 +114,15 @@ yysymprint(pTHX_ PerlIO * const yyoutput, int yytype, const YYSTYPE * const yyva { PERL_UNUSED_CONTEXT; if (yytype < YYNTOKENS) { - YYFPRINTF (yyoutput, "token %s (", yytname[yytype]); + YYFPRINTF (yyoutput, "token %s (", yytname[yytype]); # ifdef YYPRINT - YYPRINT (yyoutput, yytoknum[yytype], *yyvaluep); + YYPRINT (yyoutput, yytoknum[yytype], *yyvaluep); # else - YYFPRINTF (yyoutput, "0x%" UVxf, (UV)yyvaluep->ival); + YYFPRINTF (yyoutput, "0x%" UVxf, (UV)yyvaluep->ival); # endif } else - YYFPRINTF (yyoutput, "nterm %s (", yytname[yytype]); + YYFPRINTF (yyoutput, "nterm %s (", yytname[yytype]); YYFPRINTF (yyoutput, ")"); } @@ -139,36 +139,36 @@ yy_stack_print (pTHX_ const yy_parser *parser) min = parser->ps - 8 + 1; if (min <= parser->stack) - min = parser->stack + 1; + min = parser->stack + 1; PerlIO_printf(Perl_debug_log, "\nindex:"); for (ps = min; ps <= parser->ps; ps++) - PerlIO_printf(Perl_debug_log, " %8d", (int)(ps - parser->stack)); + PerlIO_printf(Perl_debug_log, " %8d", (int)(ps - parser->stack)); PerlIO_printf(Perl_debug_log, "\nstate:"); for (ps = min; ps <= parser->ps; ps++) - PerlIO_printf(Perl_debug_log, " %8d", ps->state); + PerlIO_printf(Perl_debug_log, " %8d", ps->state); PerlIO_printf(Perl_debug_log, "\ntoken:"); for (ps = min; ps <= parser->ps; ps++) - PerlIO_printf(Perl_debug_log, " %8.8s", ps->name); + PerlIO_printf(Perl_debug_log, " %8.8s", ps->name); PerlIO_printf(Perl_debug_log, "\nvalue:"); for (ps = min; ps <= parser->ps; ps++) { - switch (yy_type_tab[yystos[ps->state]]) { - case toketype_opval: - PerlIO_printf(Perl_debug_log, " %8.8s", - ps->val.opval - ? PL_op_name[ps->val.opval->op_type] - : "(Nullop)" - ); - break; - case toketype_ival: - PerlIO_printf(Perl_debug_log, " %8" IVdf, (IV)ps->val.ival); - break; - default: - PerlIO_printf(Perl_debug_log, " %8" UVxf, (UV)ps->val.ival); - } + switch (yy_type_tab[yystos[ps->state]]) { + case toketype_opval: + PerlIO_printf(Perl_debug_log, " %8.8s", + ps->val.opval + ? PL_op_name[ps->val.opval->op_type] + : "(Nullop)" + ); + break; + case toketype_ival: + PerlIO_printf(Perl_debug_log, " %8" IVdf, (IV)ps->val.ival); + break; + default: + PerlIO_printf(Perl_debug_log, " %8" UVxf, (UV)ps->val.ival); + } } PerlIO_printf(Perl_debug_log, "\n\n"); } @@ -176,7 +176,7 @@ yy_stack_print (pTHX_ const yy_parser *parser) # define YY_STACK_PRINT(parser) \ do { \ if (yydebug && DEBUG_v_TEST) \ - yy_stack_print (aTHX_ parser); \ + yy_stack_print (aTHX_ parser); \ } while (0) @@ -190,15 +190,15 @@ yy_reduce_print (pTHX_ int yyrule) int yyi; const unsigned int yylineno = yyrline[yyrule]; YYFPRINTF (Perl_debug_log, "Reducing stack by rule %d (line %u), ", - yyrule - 1, yylineno); + yyrule - 1, yylineno); /* Print the symbols being reduced, and their result. */ #if PERL_BISON_VERSION >= 30000 /* 3.0+ */ for (yyi = 0; yyi < yyr2[yyrule]; yyi++) - YYFPRINTF (Perl_debug_log, "%s ", + YYFPRINTF (Perl_debug_log, "%s ", yytname [yystos[(PL_parser->ps)[yyi + 1 - yyr2[yyrule]].state]]); #else for (yyi = yyprhs[yyrule]; 0 <= yyrhs[yyi]; yyi++) - YYFPRINTF (Perl_debug_log, "%s ", yytname [yyrhs[yyi]]); + YYFPRINTF (Perl_debug_log, "%s ", yytname [yyrhs[yyi]]); #endif YYFPRINTF (Perl_debug_log, "-> %s\n", yytname [yyr1[yyrule]]); } @@ -206,7 +206,7 @@ yy_reduce_print (pTHX_ int yyrule) # define YY_REDUCE_PRINT(Rule) \ do { \ if (yydebug) \ - yy_reduce_print (aTHX_ Rule); \ + yy_reduce_print (aTHX_ Rule); \ } while (0) #else /* !DEBUGGING */ @@ -226,32 +226,32 @@ S_clear_yystack(pTHX_ const yy_parser *parser) int i = 0; if (!parser->stack) - return; + return; YYDPRINTF ((Perl_debug_log, "clearing the parse stack\n")); for (i=0; i< parser->yylen; i++) { - SvREFCNT_dec(ps[-i].compcv); + SvREFCNT_dec(ps[-i].compcv); } ps -= parser->yylen; /* now free whole the stack, including the just-reduced ops */ while (ps > parser->stack) { - LEAVE_SCOPE(ps->savestack_ix); - if (yy_type_tab[yystos[ps->state]] == toketype_opval - && ps->val.opval) - { - if (ps->compcv && (ps->compcv != PL_compcv)) { - PL_compcv = ps->compcv; - PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1); - PL_comppad_name = PadlistNAMES(CvPADLIST(PL_compcv)); - } - YYDPRINTF ((Perl_debug_log, "(freeing op)\n")); - op_free(ps->val.opval); - } - SvREFCNT_dec(ps->compcv); - ps--; + LEAVE_SCOPE(ps->savestack_ix); + if (yy_type_tab[yystos[ps->state]] == toketype_opval + && ps->val.opval) + { + if (ps->compcv && (ps->compcv != PL_compcv)) { + PL_compcv = ps->compcv; + PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1); + PL_comppad_name = PadlistNAMES(CvPADLIST(PL_compcv)); + } + YYDPRINTF ((Perl_debug_log, "(freeing op)\n")); + op_free(ps->val.opval); + } + SvREFCNT_dec(ps->compcv); + ps--; } Safefree(parser->stack); @@ -279,7 +279,7 @@ Perl_yyparse (pTHX_ int gramtype) #define YYPUSHSTACK parser->ps = ++ps /* The variable used to return semantic value and location from the - action routines: ie $$. */ + action routines: ie $$. */ YYSTYPE yyval; YYDPRINTF ((Perl_debug_log, "Starting parse\n")); @@ -297,7 +297,7 @@ Perl_yyparse (pTHX_ int gramtype) /* initialise state for this parse */ parser->yychar = gramtype; - yytoken = YYTRANSLATE(NATIVE_TO_UNI(parser->yychar)); + yytoken = YYTRANSLATE((int)NATIVE_TO_UNI(parser->yychar)); parser->yyerrstatus = 0; parser->yylen = 0; @@ -369,11 +369,11 @@ Perl_yyparse (pTHX_ int gramtype) * characters in that range, but all tokens it returns are * either 0, or above 255. There could be a problem if NULs * weren't 0, or were ever returned as raw chars by yylex() */ - yytoken = YYTRANSLATE(NATIVE_TO_UNI(parser->yychar)); + yytoken = YYTRANSLATE((int)NATIVE_TO_UNI(parser->yychar)); } /* make sure no-one's changed yychar since the last call to yylex */ - assert(yytoken == YYTRANSLATE(NATIVE_TO_UNI(parser->yychar))); + assert(yytoken == YYTRANSLATE((int)NATIVE_TO_UNI(parser->yychar))); YYDSYMPRINTF("lookahead token is", yytoken, &parser->yylval); @@ -592,7 +592,7 @@ Perl_yyparse (pTHX_ int gramtype) yyacceptlab: yyresult = 0; for (ps=parser->ps; ps > parser->stack; ps--) { - SvREFCNT_dec(ps->compcv); + SvREFCNT_dec(ps->compcv); } parser->ps = parser->stack; /* disable cleanup */ goto yyreturn; diff --git a/perly.h b/perly.h index 0cbbf3b33618..9b09e2c53537 100644 --- a/perly.h +++ b/perly.h @@ -7,7 +7,7 @@ #define PERL_BISON_VERSION 30003 #ifdef PERL_CORE -/* A Bison parser, made by GNU Bison 3.3.2. */ +/* A Bison parser, made by GNU Bison 3.3. */ /* Bison interface for Yacc-like parsers in C @@ -63,86 +63,109 @@ extern int yydebug; GRAMFULLSTMT = 262, GRAMSTMTSEQ = 263, GRAMSUBSIGNATURE = 264, - BAREWORD = 265, - METHOD = 266, - FUNCMETH = 267, - THING = 268, - PMFUNC = 269, - PRIVATEREF = 270, - QWLIST = 271, - FUNC0OP = 272, - FUNC0SUB = 273, - UNIOPSUB = 274, - LSTOPSUB = 275, - PLUGEXPR = 276, - PLUGSTMT = 277, - LABEL = 278, - FORMAT = 279, - SUB = 280, - SIGSUB = 281, - ANONSUB = 282, - ANON_SIGSUB = 283, - PACKAGE = 284, - USE = 285, - WHILE = 286, - UNTIL = 287, - IF = 288, - UNLESS = 289, - ELSE = 290, - ELSIF = 291, - CONTINUE = 292, - FOR = 293, - GIVEN = 294, - WHEN = 295, - DEFAULT = 296, - LOOPEX = 297, - DOTDOT = 298, - YADAYADA = 299, - FUNC0 = 300, - FUNC1 = 301, - FUNC = 302, - UNIOP = 303, - LSTOP = 304, - MULOP = 305, - ADDOP = 306, - DOLSHARP = 307, - DO = 308, - HASHBRACK = 309, - NOAMP = 310, - LOCAL = 311, - MY = 312, - REQUIRE = 313, - COLONATTR = 314, - FORMLBRACK = 315, - FORMRBRACK = 316, - SUBLEXSTART = 317, - SUBLEXEND = 318, - PREC_LOW = 319, - OROP = 320, - DOROP = 321, - ANDOP = 322, - NOTOP = 323, - ASSIGNOP = 324, - OROR = 325, - DORDOR = 326, - ANDAND = 327, - BITOROP = 328, - BITANDOP = 329, - CHEQOP = 330, - NCEQOP = 331, - CHRELOP = 332, - NCRELOP = 333, - SHIFTOP = 334, - MATCHOP = 335, - UMINUS = 336, - REFGEN = 337, - POWOP = 338, - PREINC = 339, - PREDEC = 340, - POSTINC = 341, - POSTDEC = 342, - POSTJOIN = 343, - ARROW = 344 + PERLY_AMPERSAND = 265, + PERLY_BRACE_OPEN = 266, + PERLY_BRACE_CLOSE = 267, + PERLY_BRACKET_OPEN = 268, + PERLY_BRACKET_CLOSE = 269, + PERLY_COMMA = 270, + PERLY_DOLLAR = 271, + PERLY_DOT = 272, + PERLY_EQUAL_SIGN = 273, + PERLY_MINUS = 274, + PERLY_PERCENT_SIGN = 275, + PERLY_PLUS = 276, + PERLY_SEMICOLON = 277, + PERLY_SLASH = 278, + PERLY_SNAIL = 279, + PERLY_STAR = 280, + BAREWORD = 281, + METHOD = 282, + FUNCMETH = 283, + THING = 284, + PMFUNC = 285, + PRIVATEREF = 286, + QWLIST = 287, + FUNC0OP = 288, + FUNC0SUB = 289, + UNIOPSUB = 290, + LSTOPSUB = 291, + PLUGEXPR = 292, + PLUGSTMT = 293, + LABEL = 294, + FORMAT = 295, + SUB = 296, + SIGSUB = 297, + ANONSUB = 298, + ANON_SIGSUB = 299, + PACKAGE = 300, + USE = 301, + WHILE = 302, + UNTIL = 303, + IF = 304, + UNLESS = 305, + ELSE = 306, + ELSIF = 307, + CONTINUE = 308, + FOR = 309, + GIVEN = 310, + WHEN = 311, + DEFAULT = 312, + TRY = 313, + CATCH = 314, + LOOPEX = 315, + DOTDOT = 316, + YADAYADA = 317, + FUNC0 = 318, + FUNC1 = 319, + FUNC = 320, + UNIOP = 321, + LSTOP = 322, + MULOP = 323, + ADDOP = 324, + DOLSHARP = 325, + DO = 326, + HASHBRACK = 327, + NOAMP = 328, + LOCAL = 329, + MY = 330, + REQUIRE = 331, + COLONATTR = 332, + FORMLBRACK = 333, + FORMRBRACK = 334, + SUBLEXSTART = 335, + SUBLEXEND = 336, + PREC_LOW = 337, + OROP = 338, + ANDOP = 339, + NOTOP = 340, + ASSIGNOP = 341, + PERLY_QUESTION_MARK = 342, + PERLY_COLON = 343, + OROR = 344, + DORDOR = 345, + ANDAND = 346, + BITOROP = 347, + BITANDOP = 348, + CHEQOP = 349, + NCEQOP = 350, + CHRELOP = 351, + NCRELOP = 352, + SHIFTOP = 353, + MATCHOP = 354, + PERLY_EXCLAMATION_MARK = 355, + PERLY_TILDE = 356, + UMINUS = 357, + REFGEN = 358, + POWOP = 359, + PREINC = 360, + PREDEC = 361, + POSTINC = 362, + POSTDEC = 363, + POSTJOIN = 364, + ARROW = 365, + PERLY_PAREN_CLOSE = 366, + PERLY_PAREN_OPEN = 367 }; #endif @@ -195,6 +218,6 @@ int yyparse (void); /* Generated from: - * f83d884147747f2d8f5a62eebc4ccd07d71b6b34e5ba1a8d7559526ad864dc97 perly.y - * 01ce33b49f9f04b8d3112b7f042cde113a7d29763a846e870f9766072a5bc614 regen_perly.pl + * 672539c523be1568df09c599b38a828c80473c60e1fddd63764d66f74e4e7b11 perly.y + * acf1cbfd2545faeaaa58b1cf0cf9d7f98b5be0752eb7a54528ef904a9e2e1ca7 regen_perly.pl * ex: set ro: */ diff --git a/perly.tab b/perly.tab index 0154f4431ac4..b5674d054207 100644 --- a/perly.tab +++ b/perly.tab @@ -6,19 +6,19 @@ #define YYFINAL 16 /* YYLAST -- Last index in YYTABLE. */ -#define YYLAST 3348 +#define YYLAST 3177 /* YYNTOKENS -- Number of terminals. */ -#define YYNTOKENS 112 +#define YYNTOKENS 113 /* YYNNTS -- Number of nonterminals. */ -#define YYNNTS 96 +#define YYNNTS 99 /* YYNRULES -- Number of rules. */ -#define YYNRULES 294 +#define YYNRULES 297 /* YYNSTATES -- Number of states. */ -#define YYNSTATES 572 +#define YYNSTATES 581 #define YYUNDEFTOK 2 -#define YYMAXUTOK 344 +#define YYMAXUTOK 367 /* YYTRANSLATE(TOKEN-NUM) -- Symbol number corresponding to TOKEN-NUM as returned by yylex, with out-of-bounds checking. */ @@ -32,16 +32,16 @@ static const yytype_uint8 yytranslate[] = 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 95, 2, 2, 109, 17, 18, 2, - 107, 106, 110, 15, 80, 14, 20, 111, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 2, 83, 108, - 2, 19, 2, 82, 16, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 12, 2, 13, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 10, 2, 11, 96, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, @@ -55,51 +55,53 @@ static const yytype_uint8 yytranslate[] = 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 1, 2, 3, 4, - 5, 6, 7, 8, 9, 21, 22, 23, 24, 25, - 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, - 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, - 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, - 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, - 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, - 76, 77, 78, 79, 81, 84, 85, 86, 87, 88, - 89, 90, 91, 92, 93, 94, 97, 98, 99, 100, - 101, 102, 103, 104, 105 + 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, + 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, + 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, + 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, + 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, + 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, + 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, + 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, + 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, + 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, + 105, 106, 107, 108, 109, 110, 111, 112 }; #if YYDEBUG /* YYRLINE[YYN] -- Source line where rule number YYN was defined. */ static const yytype_uint16 yyrline[] = { - 0, 121, 121, 120, 132, 131, 142, 141, 155, 154, - 168, 167, 181, 180, 191, 190, 203, 211, 219, 223, - 231, 237, 238, 248, 249, 258, 262, 266, 273, 283, - 285, 298, 295, 319, 314, 335, 343, 342, 351, 357, - 363, 368, 370, 372, 379, 387, 389, 386, 406, 411, - 418, 417, 432, 440, 446, 453, 452, 467, 471, 476, - 484, 502, 503, 508, 510, 512, 514, 516, 518, 520, - 523, 529, 530, 535, 546, 547, 553, 559, 560, 565, - 568, 572, 577, 581, 585, 586, 590, 596, 601, 606, - 607, 612, 613, 618, 619, 621, 626, 628, 640, 641, - 646, 648, 652, 672, 673, 675, 681, 746, 748, 754, - 756, 760, 766, 767, 772, 773, 777, 781, 781, 849, - 850, 855, 866, 867, 870, 881, 883, 885, 887, 891, - 893, 898, 902, 906, 910, 916, 921, 927, 933, 935, - 937, 940, 939, 950, 951, 955, 959, 962, 967, 972, - 975, 979, 983, 989, 997, 1004, 1010, 1012, 1014, 1019, - 1021, 1023, 1028, 1030, 1032, 1034, 1036, 1038, 1040, 1042, - 1044, 1046, 1048, 1052, 1054, 1056, 1058, 1062, 1064, 1068, - 1070, 1072, 1074, 1078, 1080, 1085, 1087, 1090, 1092, 1094, - 1097, 1100, 1111, 1114, 1121, 1123, 1125, 1127, 1129, 1132, - 1138, 1140, 1144, 1145, 1146, 1147, 1148, 1150, 1152, 1154, - 1156, 1158, 1160, 1162, 1164, 1166, 1168, 1170, 1172, 1174, - 1176, 1186, 1196, 1206, 1216, 1218, 1220, 1223, 1228, 1232, - 1234, 1236, 1238, 1241, 1243, 1246, 1248, 1250, 1252, 1254, - 1256, 1258, 1260, 1262, 1265, 1267, 1269, 1271, 1273, 1275, - 1279, 1282, 1281, 1294, 1295, 1296, 1300, 1302, 1304, 1309, - 1311, 1314, 1316, 1318, 1323, 1325, 1330, 1331, 1336, 1337, - 1343, 1347, 1348, 1349, 1352, 1353, 1356, 1357, 1360, 1364, - 1368, 1374, 1380, 1382, 1386, 1390, 1391, 1395, 1396, 1400, - 1401, 1406, 1408, 1410, 1413 + 0, 138, 138, 137, 149, 148, 159, 158, 172, 171, + 185, 184, 198, 197, 208, 207, 220, 228, 235, 240, + 247, 253, 255, 264, 266, 275, 279, 283, 290, 300, + 302, 315, 312, 336, 331, 352, 360, 359, 368, 374, + 380, 385, 387, 389, 396, 404, 406, 403, 423, 428, + 435, 434, 449, 457, 464, 466, 463, 488, 495, 494, + 509, 513, 518, 526, 543, 545, 549, 553, 555, 557, + 559, 561, 563, 565, 568, 573, 575, 580, 590, 592, + 597, 603, 605, 609, 613, 617, 622, 626, 630, 631, + 634, 640, 645, 651, 652, 656, 658, 662, 664, 666, + 671, 673, 684, 686, 691, 693, 697, 716, 718, 720, + 726, 791, 793, 799, 801, 805, 810, 812, 816, 818, + 822, 826, 826, 894, 895, 900, 911, 912, 915, 926, + 928, 930, 934, 936, 941, 945, 949, 953, 959, 964, + 970, 976, 978, 980, 983, 982, 993, 994, 998, 1002, + 1005, 1010, 1015, 1018, 1022, 1026, 1032, 1040, 1047, 1053, + 1055, 1057, 1062, 1064, 1066, 1071, 1073, 1075, 1077, 1079, + 1081, 1083, 1085, 1087, 1089, 1091, 1095, 1097, 1099, 1101, + 1105, 1107, 1111, 1113, 1115, 1117, 1121, 1123, 1128, 1130, + 1133, 1135, 1137, 1140, 1143, 1154, 1157, 1164, 1166, 1168, + 1170, 1172, 1175, 1181, 1183, 1187, 1188, 1189, 1190, 1191, + 1193, 1195, 1197, 1199, 1201, 1203, 1205, 1207, 1209, 1211, + 1213, 1215, 1217, 1219, 1229, 1239, 1249, 1259, 1261, 1263, + 1266, 1271, 1275, 1277, 1279, 1281, 1284, 1286, 1289, 1291, + 1293, 1295, 1297, 1299, 1301, 1303, 1305, 1308, 1310, 1312, + 1314, 1316, 1318, 1322, 1325, 1324, 1337, 1338, 1339, 1343, + 1345, 1347, 1352, 1354, 1357, 1359, 1361, 1366, 1368, 1372, + 1374, 1378, 1380, 1386, 1390, 1391, 1392, 1395, 1396, 1399, + 1400, 1403, 1407, 1411, 1417, 1423, 1425, 1429, 1433, 1434, + 1438, 1439, 1443, 1444, 1449, 1451, 1453, 1456 }; #endif @@ -109,37 +111,41 @@ static const yytype_uint16 yyrline[] = static const char *const yytname[] = { "$end", "error", "$undefined", "GRAMPROG", "GRAMEXPR", "GRAMBLOCK", - "GRAMBARESTMT", "GRAMFULLSTMT", "GRAMSTMTSEQ", "GRAMSUBSIGNATURE", "'{'", - "'}'", "'['", "']'", "'-'", "'+'", "'@'", "'%'", "'&'", "'='", "'.'", - "BAREWORD", "METHOD", "FUNCMETH", "THING", "PMFUNC", "PRIVATEREF", - "QWLIST", "FUNC0OP", "FUNC0SUB", "UNIOPSUB", "LSTOPSUB", "PLUGEXPR", - "PLUGSTMT", "LABEL", "FORMAT", "SUB", "SIGSUB", "ANONSUB", "ANON_SIGSUB", - "PACKAGE", "USE", "WHILE", "UNTIL", "IF", "UNLESS", "ELSE", "ELSIF", - "CONTINUE", "FOR", "GIVEN", "WHEN", "DEFAULT", "LOOPEX", "DOTDOT", - "YADAYADA", "FUNC0", "FUNC1", "FUNC", "UNIOP", "LSTOP", "MULOP", "ADDOP", - "DOLSHARP", "DO", "HASHBRACK", "NOAMP", "LOCAL", "MY", "REQUIRE", - "COLONATTR", "FORMLBRACK", "FORMRBRACK", "SUBLEXSTART", "SUBLEXEND", - "PREC_LOW", "OROP", "DOROP", "ANDOP", "NOTOP", "','", "ASSIGNOP", "'?'", - "':'", "OROR", "DORDOR", "ANDAND", "BITOROP", "BITANDOP", "CHEQOP", - "NCEQOP", "CHRELOP", "NCRELOP", "SHIFTOP", "MATCHOP", "'!'", "'~'", + "GRAMBARESTMT", "GRAMFULLSTMT", "GRAMSTMTSEQ", "GRAMSUBSIGNATURE", + "PERLY_AMPERSAND", "PERLY_BRACE_OPEN", "PERLY_BRACE_CLOSE", + "PERLY_BRACKET_OPEN", "PERLY_BRACKET_CLOSE", "PERLY_COMMA", + "PERLY_DOLLAR", "PERLY_DOT", "PERLY_EQUAL_SIGN", "PERLY_MINUS", + "PERLY_PERCENT_SIGN", "PERLY_PLUS", "PERLY_SEMICOLON", "PERLY_SLASH", + "PERLY_SNAIL", "PERLY_STAR", "BAREWORD", "METHOD", "FUNCMETH", "THING", + "PMFUNC", "PRIVATEREF", "QWLIST", "FUNC0OP", "FUNC0SUB", "UNIOPSUB", + "LSTOPSUB", "PLUGEXPR", "PLUGSTMT", "LABEL", "FORMAT", "SUB", "SIGSUB", + "ANONSUB", "ANON_SIGSUB", "PACKAGE", "USE", "WHILE", "UNTIL", "IF", + "UNLESS", "ELSE", "ELSIF", "CONTINUE", "FOR", "GIVEN", "WHEN", "DEFAULT", + "TRY", "CATCH", "LOOPEX", "DOTDOT", "YADAYADA", "FUNC0", "FUNC1", "FUNC", + "UNIOP", "LSTOP", "MULOP", "ADDOP", "DOLSHARP", "DO", "HASHBRACK", + "NOAMP", "LOCAL", "MY", "REQUIRE", "COLONATTR", "FORMLBRACK", + "FORMRBRACK", "SUBLEXSTART", "SUBLEXEND", "PREC_LOW", "OROP", "ANDOP", + "NOTOP", "ASSIGNOP", "PERLY_QUESTION_MARK", "PERLY_COLON", "OROR", + "DORDOR", "ANDAND", "BITOROP", "BITANDOP", "CHEQOP", "NCEQOP", "CHRELOP", + "NCRELOP", "SHIFTOP", "MATCHOP", "PERLY_EXCLAMATION_MARK", "PERLY_TILDE", "UMINUS", "REFGEN", "POWOP", "PREINC", "PREDEC", "POSTINC", "POSTDEC", - "POSTJOIN", "ARROW", "')'", "'('", "';'", "'$'", "'*'", "'/'", "$accept", + "POSTJOIN", "ARROW", "PERLY_PAREN_CLOSE", "PERLY_PAREN_OPEN", "$accept", "grammar", "@1", "@2", "@3", "@4", "@5", "@6", "@7", "block", "formblock", "remember", "mblock", "mremember", "stmtseq", "formstmtseq", "fullstmt", "labfullstmt", "barestmt", "$@8", "$@9", "$@10", "$@11", - "$@12", "@13", "$@14", "formline", "formarg", "sideff", "else", "cont", - "mintro", "nexpr", "texpr", "iexpr", "mexpr", "mnexpr", "formname", - "startsub", "startanonsub", "startformsub", "subname", "proto", - "subattrlist", "myattrlist", "sigvarname", "sigslurpsigil", - "sigslurpelem", "sigdefault", "sigscalarelem", "sigelem", "siglist", - "siglistornull", "optsubsignature", "subsignature", "subsigguts", "$@15", - "optsubbody", "subbody", "optsigsubbody", "sigsubbody", "expr", - "listexpr", "listop", "@16", "method", "subscripted", "termbinop", - "termrelop", "relopchain", "termeqop", "eqopchain", "termunop", - "anonymous", "termdo", "term", "@17", "myattrterm", "myterm", - "optlistexpr", "optexpr", "optrepl", "my_scalar", "my_var", - "refgen_topic", "my_refgen", "amper", "scalar", "ary", "hsh", "arylen", - "star", "sliceme", "kvslice", "gelem", "indirob", YY_NULLPTR + "$@12", "@13", "$@14", "$@15", "$@16", "formline", "formarg", + "condition", "sideff", "else", "cont", "mintro", "nexpr", "texpr", + "iexpr", "mexpr", "mnexpr", "formname", "startsub", "startanonsub", + "startformsub", "subname", "proto", "subattrlist", "myattrlist", + "sigvarname", "sigslurpsigil", "sigslurpelem", "sigdefault", + "sigscalarelem", "sigelem", "siglist", "siglistornull", + "optsubsignature", "subsignature", "subsigguts", "$@17", "optsubbody", + "subbody", "optsigsubbody", "sigsubbody", "expr", "listexpr", "listop", + "@18", "method", "subscripted", "termbinop", "termrelop", "relopchain", + "termeqop", "eqopchain", "termunop", "anonymous", "termdo", "term", + "@19", "myattrterm", "myterm", "optlistexpr", "optexpr", "optrepl", + "my_scalar", "my_var", "refgen_topic", "my_refgen", "amper", "scalar", + "ary", "hsh", "arylen", "star", "sliceme", "kvslice", "gelem", "indirob", YY_NULLPTR }; #endif @@ -149,92 +155,93 @@ static const char *const yytname[] = static const yytype_uint16 yytoknum[] = { 0, 256, 257, 258, 259, 260, 261, 262, 263, 264, - 123, 125, 91, 93, 45, 43, 64, 37, 38, 61, - 46, 265, 266, 267, 268, 269, 270, 271, 272, 273, - 274, 275, 276, 277, 278, 279, 280, 281, 282, 283, - 284, 285, 286, 287, 288, 289, 290, 291, 292, 293, - 294, 295, 296, 297, 298, 299, 300, 301, 302, 303, - 304, 305, 306, 307, 308, 309, 310, 311, 312, 313, - 314, 315, 316, 317, 318, 319, 320, 321, 322, 323, - 44, 324, 63, 58, 325, 326, 327, 328, 329, 330, - 331, 332, 333, 334, 335, 33, 126, 336, 337, 338, - 339, 340, 341, 342, 343, 344, 41, 40, 59, 36, - 42, 47 + 265, 266, 267, 268, 269, 270, 271, 272, 273, 274, + 275, 276, 277, 278, 279, 280, 281, 282, 283, 284, + 285, 286, 287, 288, 289, 290, 291, 292, 293, 294, + 295, 296, 297, 298, 299, 300, 301, 302, 303, 304, + 305, 306, 307, 308, 309, 310, 311, 312, 313, 314, + 315, 316, 317, 318, 319, 320, 321, 322, 323, 324, + 325, 326, 327, 328, 329, 330, 331, 332, 333, 334, + 335, 336, 337, 338, 339, 340, 341, 342, 343, 344, + 345, 346, 347, 348, 349, 350, 351, 352, 353, 354, + 355, 356, 357, 358, 359, 360, 361, 362, 363, 364, + 365, 366, 367 }; # endif -#define YYPACT_NINF -485 +#define YYPACT_NINF -482 #define yypact_value_is_default(Yystate) \ - (!!((Yystate) == (-485))) + (!!((Yystate) == (-482))) -#define YYTABLE_NINF -290 +#define YYTABLE_NINF -293 #define yytable_value_is_error(Yytable_value) \ - (!!((Yytable_value) == (-290))) + (!!((Yytable_value) == (-293))) /* YYPACT[STATE-NUM] -- Index in YYTABLE of the portion describing STATE-NUM. */ static const yytype_int16 yypact[] = { - 739, -485, -485, -485, -485, -485, -485, -485, 28, -485, - 2976, 32, 1582, 1481, -485, -485, -485, -485, 2085, 2976, - 2976, 6, 6, 6, -485, 6, 6, -485, -485, 50, - -31, -485, 2976, -485, -485, -485, -485, 2976, -13, 20, - -33, 1986, 1885, 6, 1986, 2184, 4, 2976, 83, 2976, - 2976, 2976, 2976, 2976, 2976, 2976, 2283, 6, 6, 41, - -7, -485, 14, -485, -34, -1, -20, 22, -485, -485, - -485, 3151, -485, -485, 29, 56, 95, 102, -485, 153, - 247, 254, 157, -485, -485, -485, -485, -485, 4, 4, - 132, -485, 79, 100, 119, 130, 174, 146, 154, 32, - 152, -485, 217, -485, 160, 1984, 1481, -485, -485, -485, - 672, -485, 30, 774, -485, 111, 142, 142, -485, -485, - -485, -485, -485, -485, -485, 2976, 172, 207, 2976, 176, - 430, 32, 261, 216, 3151, 202, 2382, 2976, 1885, -485, - 430, 572, -7, -485, 476, 2976, -485, -485, 430, 299, - 197, -485, -485, 2976, 430, 3075, 2481, 242, -485, -485, - -485, 430, -7, 142, 142, 142, 57, 57, 306, 267, - -485, -485, 2976, 2976, 2976, 2976, 2976, 2976, 2580, -485, - -485, 2976, -485, -485, 2976, 2976, 2976, 2976, 2976, 2976, - 2976, 2976, 2976, 2976, 2976, 2976, 2976, 2976, 2976, 2976, - 2976, 2976, -485, -485, -485, 75, 2679, 2976, 2976, 2976, - 2976, 2976, 2976, 2976, -485, 307, -485, -485, 311, -485, - -485, -485, -485, -485, 224, 36, -485, -485, 226, -485, - -485, -485, -485, 32, -485, -485, 2976, 2976, 2976, 2976, - 2976, 2976, -485, -485, -485, -485, -485, 320, 320, -485, - -485, -485, 273, -485, -485, -485, 2976, 2976, 118, -485, - -485, -485, 216, 330, -485, -485, -485, 331, 284, 260, - 2976, -7, -485, 348, -485, 2778, 142, 242, 33, 55, - 67, -485, 342, 344, -485, 2976, 357, 294, 294, -485, - 3151, 249, 133, -485, 433, 430, 363, 3243, 504, 329, - 3151, 3105, 1667, 1667, 1767, 1867, 538, 363, 363, 430, - 430, 301, 142, 142, 2976, 2976, 271, 272, 274, -485, - 278, 2877, 23, 279, 270, -485, -485, 470, 253, 136, - 302, 158, 364, 162, 407, 875, -485, 372, -485, -485, - 1, 375, 2976, 2976, 2976, 2976, -485, 292, -485, -485, - 305, -485, -485, -485, -485, 1683, 34, -485, 2976, 2976, - -485, 41, -485, 41, 41, 41, 41, 41, -485, 332, - 332, 30, 308, -39, -485, 2976, -485, -485, 309, -485, - -485, -485, -485, 512, -485, 5, 516, -485, -485, -485, - 178, 2976, 416, -485, -485, 2976, 418, 193, -485, -485, - -485, -485, -485, 519, -485, -485, 2976, -485, 436, -485, - 438, -485, 440, -485, 447, -485, -485, -485, 261, 216, - -485, -485, 439, 353, 41, 358, 368, 41, 369, 356, - -485, -485, -485, -485, 374, 373, 401, -485, 2976, 381, - 387, 2976, -485, -485, -485, -485, 2976, 423, -485, 489, - -485, -485, 490, -485, -485, 19, -485, 239, -485, 3197, - 492, -485, -485, 398, -485, -485, -485, -485, 397, 216, - 404, -485, 2976, -485, -485, 496, 496, 2976, 2976, 496, - -485, 406, 408, 496, 496, 3151, 41, -485, -485, 410, - -485, -485, -485, -485, 445, 414, -485, -485, -485, -485, - 420, 496, 496, -485, 37, 37, 434, 435, 217, 2976, - 2976, 496, -485, -485, 976, -485, 1077, -485, -485, -485, - -485, 1178, -485, 217, 217, -485, 496, 442, -485, -485, - 496, 496, -485, 437, 449, 217, -485, -485, -10, -485, - -485, -485, 1279, -485, 2976, 217, 217, -485, 496, -485, - 472, 531, -485, -485, 465, -485, -485, -485, 217, -485, - -485, -485, 496, 1784, -485, 1380, 37, 467, -485, -485, - 496, -485 + 533, -482, -482, -482, -482, -482, -482, -482, 32, -482, + 2902, 25, 1407, 1310, -482, -482, -482, -482, 299, 1959, + 299, 2902, 299, 2902, 299, 299, -482, 299, 299, -482, + -482, 10, -66, -482, 2902, -482, -482, -482, -482, 2902, + -63, -56, -47, 2056, 1865, 299, 2056, 2150, 67, 2902, + 60, 2902, 2902, 2902, 2902, 2902, 2902, 2902, 2244, 144, + 43, -482, 50, -482, 156, -25, 233, -11, -482, -482, + -482, 3067, -482, -482, -35, 62, 228, 250, -482, 78, + 267, 270, 92, -482, -482, -482, -482, -482, -482, 67, + 67, 83, -482, 18, 41, 52, 97, -1, 108, 135, + 25, 203, 173, 207, -482, 243, 330, 1310, -482, -482, + -482, 534, -482, 220, 631, -482, -482, -482, -482, -482, + -482, 12, -482, 992, -482, 992, -482, -482, 2902, 172, + 176, 2902, 193, 808, 25, 285, 246, 3067, 218, 2338, + 2902, 1865, -482, 808, 1763, 43, -482, 1663, 2902, -482, + -482, 808, 329, 124, -482, -482, 2902, 808, 2996, 2432, + 269, -482, -482, -482, 808, 43, 992, 992, 992, 338, + 338, 337, 23, 2902, 2902, 2902, 2902, 2902, 2526, -482, + -482, 2902, -482, -482, 2902, 2902, 2902, 2902, 2902, 2902, + 2902, 2902, 2902, 2902, 2902, 2902, 2902, 2902, 2902, 2902, + 2902, 2902, -482, -482, -482, 27, 2620, 2902, 2902, 2902, + 2902, 2902, 2902, 2902, -482, 335, -482, -482, 340, -482, + -482, -482, -482, -482, 278, 151, -482, -482, 261, -482, + -482, -482, -482, 326, -482, 25, -482, -482, 2902, 2902, + 2902, 2902, 2902, 2902, -482, -482, -482, 370, -482, -482, + 370, -482, -482, -482, 390, -482, -482, -482, 2902, 2902, + 34, -482, -482, -482, 246, 378, -482, -482, -482, 159, + 327, 298, 2902, 43, -482, 400, -482, 2714, 992, 269, + 44, 168, 169, -482, 223, 389, -482, 2902, 407, 339, + -482, 3067, 165, 45, -482, 234, 808, 711, 423, 395, + 289, 3067, 3023, 1696, 1696, 1850, 518, 614, 711, 711, + 808, 808, 905, 992, 992, 397, 2902, 2902, 410, 399, + 404, 415, -482, 424, 2808, 357, -482, -482, 236, 171, + 54, 184, 65, 189, 90, 191, 728, -482, 452, -482, + -482, 79, 451, 2902, 2902, 2902, 2902, -482, 462, -482, + -482, 368, -482, -482, -482, -482, 1501, 242, -482, 2902, + 2902, -482, 371, -482, -482, 144, -482, 144, -482, -482, + -482, -482, -482, 396, 396, 220, 374, 76, -482, 2902, + -482, -482, 376, -482, -482, -482, -482, 238, -482, 59, + 248, -482, -482, -482, 94, 2902, 474, -482, -482, 2902, + -482, 229, 102, -482, -482, -482, -482, -482, -482, 281, + 2902, -482, 477, -482, 481, -482, 483, -482, 484, -482, + -482, -482, 285, 246, -482, -482, 471, 412, 144, 413, + 414, 144, 417, 398, -482, -482, -482, -482, 418, 479, + 320, -482, 2902, 435, 438, 825, -482, 2902, -482, -482, + -482, -482, 2902, 426, -482, 500, -482, -482, 515, -482, + -482, 68, -482, 105, -482, 364, 540, -482, -482, 446, + -482, -482, -482, -482, 543, 246, 563, -482, 2902, -482, + -482, 203, 203, 2902, 2902, 203, -482, 490, 482, 203, + 203, -482, -482, 3067, 144, -482, -482, 492, -482, -482, + -482, -482, 516, 596, -482, -482, -482, -482, 598, 203, + 203, 288, 288, 510, 512, 207, 2902, 2902, 203, -482, + -482, 462, 922, -482, 1019, -482, -482, -482, -482, 1116, + -482, 207, 207, 203, 517, -482, -482, 203, 203, -482, + 602, 519, 207, -482, -482, -482, 162, -482, -482, -482, + -482, 2902, 207, 207, -482, 203, -482, 522, 619, 560, + -482, 532, -482, -482, -482, 207, 203, -482, -482, -482, + 203, 1595, -482, -482, 1213, 288, 537, -482, -482, 203, + -482 }; /* YYDEFACT[STATE-NUM] -- Default reduction number in state STATE-NUM. @@ -243,93 +250,94 @@ static const yytype_int16 yypact[] = static const yytype_uint16 yydefact[] = { 0, 2, 4, 6, 8, 10, 12, 14, 0, 18, - 266, 0, 0, 0, 21, 117, 1, 21, 0, 0, - 0, 0, 0, 0, 253, 0, 0, 224, 251, 212, - 246, 248, 242, 87, 255, 87, 87, 234, 244, 0, - 0, 237, 264, 0, 0, 0, 0, 0, 0, 240, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 267, - 128, 254, 219, 202, 164, 173, 165, 179, 203, 204, - 205, 131, 209, 5, 225, 214, 217, 216, 218, 215, - 0, 0, 0, 18, 7, 63, 29, 88, 0, 0, - 0, 86, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 59, 74, 9, 0, 64, 0, 11, 26, 25, - 0, 15, 112, 0, 195, 0, 185, 186, 291, 294, - 293, 292, 280, 281, 278, 264, 0, 0, 0, 0, - 243, 0, 91, 93, 235, 0, 0, 266, 266, 238, - 239, 291, 265, 138, 292, 0, 282, 201, 200, 0, - 0, 89, 90, 264, 210, 0, 0, 257, 261, 263, - 262, 241, 236, 187, 188, 207, 192, 193, 213, 0, - 279, 284, 0, 0, 0, 129, 0, 0, 0, 176, - 175, 0, 182, 181, 0, 0, 0, 0, 0, 0, + 269, 0, 0, 0, 21, 121, 1, 21, 0, 0, + 0, 0, 0, 0, 0, 0, 256, 0, 0, 227, + 254, 215, 249, 251, 245, 91, 258, 91, 91, 237, + 247, 0, 0, 240, 267, 0, 0, 0, 0, 0, + 0, 243, 0, 0, 0, 0, 0, 0, 0, 270, + 131, 257, 222, 205, 167, 176, 168, 182, 206, 207, + 208, 134, 212, 5, 228, 217, 220, 219, 221, 218, + 0, 0, 0, 18, 7, 67, 62, 29, 92, 0, + 0, 0, 90, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 78, 9, 0, 68, 0, 11, 26, + 25, 0, 15, 116, 0, 294, 297, 296, 295, 281, + 198, 0, 282, 188, 284, 189, 283, 287, 267, 0, + 0, 0, 0, 246, 0, 95, 97, 238, 0, 0, + 269, 269, 241, 242, 294, 268, 141, 295, 0, 285, + 204, 203, 0, 0, 93, 94, 267, 213, 0, 0, + 260, 264, 266, 265, 244, 239, 190, 191, 210, 195, + 196, 216, 0, 0, 0, 132, 0, 0, 0, 179, + 178, 0, 185, 184, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 189, 190, 191, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 21, 85, 86, 86, 0, 36, + 0, 0, 192, 193, 194, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 21, 89, 90, 90, 0, 36, 18, 18, 18, 18, 18, 0, 18, 18, 0, 18, - 18, 42, 58, 0, 54, 57, 0, 0, 0, 0, - 0, 0, 28, 27, 22, 100, 101, 98, 98, 108, - 107, 111, 113, 118, 194, 136, 266, 0, 0, 247, - 141, 92, 93, 95, 18, 245, 249, 0, 0, 0, - 0, 132, 197, 0, 228, 0, 208, 0, 214, 217, - 216, 260, 0, 97, 256, 0, 211, 126, 127, 125, - 130, 0, 0, 155, 0, 178, 184, 168, 161, 162, - 159, 0, 170, 171, 169, 167, 166, 183, 180, 177, - 174, 163, 172, 160, 0, 0, 286, 288, 0, 143, - 0, 0, 0, 290, 135, 144, 226, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 84, 0, 31, 33, - 0, 0, 79, 0, 0, 0, 276, 0, 277, 274, - 0, 275, 271, 272, 273, 0, 0, 18, 0, 0, - 75, 67, 68, 81, 65, 66, 69, 70, 99, 103, - 103, 109, 0, 268, 157, 264, 18, 94, 114, 199, - 250, 140, 139, 0, 196, 213, 0, 258, 259, 96, - 0, 0, 0, 148, 154, 0, 0, 0, 230, 231, - 232, 283, 152, 0, 229, 233, 266, 227, 0, 146, - 0, 220, 0, 221, 0, 16, 18, 30, 91, 93, - 18, 35, 0, 0, 80, 0, 0, 82, 0, 0, - 270, 18, 78, 83, 0, 0, 64, 50, 0, 0, - 0, 104, 106, 102, 110, 137, 0, 0, 142, 0, - 198, 117, 0, 115, 133, 211, 158, 0, 151, 206, - 0, 147, 153, 0, 149, 222, 223, 145, 0, 93, - 18, 55, 264, 76, 76, 0, 0, 0, 0, 0, - 45, 0, 0, 0, 0, 105, 269, 252, 21, 0, - 21, 156, 150, 134, 0, 18, 123, 34, 122, 21, - 0, 0, 0, 20, 71, 71, 0, 0, 74, 79, - 0, 0, 40, 41, 0, 116, 0, 23, 120, 32, - 119, 0, 37, 74, 74, 21, 0, 0, 38, 39, - 0, 0, 53, 0, 0, 74, 121, 124, 0, 56, - 43, 44, 0, 72, 0, 74, 74, 46, 0, 49, - 61, 0, 24, 19, 0, 48, 52, 76, 74, 21, - 60, 17, 0, 0, 51, 0, 71, 0, 62, 73, - 0, 47 + 18, 42, 20, 0, 61, 0, 57, 60, 0, 0, + 0, 0, 0, 0, 28, 27, 22, 102, 105, 104, + 102, 112, 111, 115, 117, 122, 197, 139, 269, 0, + 0, 250, 144, 96, 97, 99, 18, 248, 252, 0, + 0, 0, 0, 135, 200, 0, 231, 0, 211, 0, + 217, 220, 219, 263, 0, 101, 259, 0, 214, 130, + 129, 133, 0, 0, 158, 0, 181, 187, 171, 164, + 165, 162, 0, 173, 174, 172, 170, 169, 186, 183, + 180, 177, 166, 175, 163, 0, 0, 0, 0, 291, + 289, 293, 146, 0, 0, 138, 147, 229, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 88, 0, 31, + 33, 0, 0, 83, 0, 0, 0, 279, 0, 280, + 277, 0, 278, 274, 275, 276, 0, 0, 18, 0, + 0, 21, 0, 79, 71, 66, 72, 85, 69, 70, + 73, 74, 103, 107, 107, 113, 0, 271, 160, 267, + 18, 98, 118, 202, 253, 143, 142, 0, 199, 216, + 0, 261, 262, 100, 0, 0, 0, 151, 157, 0, + 235, 0, 0, 232, 234, 233, 236, 286, 155, 0, + 269, 230, 0, 149, 0, 223, 0, 224, 0, 16, + 18, 30, 95, 97, 18, 35, 0, 0, 84, 0, + 0, 86, 0, 0, 273, 18, 82, 87, 0, 0, + 68, 50, 0, 0, 0, 0, 54, 108, 110, 106, + 114, 140, 0, 0, 145, 0, 201, 121, 0, 119, + 136, 214, 161, 0, 154, 209, 0, 150, 156, 0, + 152, 225, 226, 148, 0, 97, 18, 58, 267, 80, + 80, 0, 0, 0, 0, 0, 45, 0, 0, 0, + 0, 19, 18, 109, 272, 255, 21, 0, 21, 159, + 153, 137, 0, 18, 127, 34, 126, 21, 0, 0, + 0, 75, 75, 0, 0, 78, 83, 0, 0, 40, + 41, 0, 0, 120, 0, 23, 124, 32, 123, 0, + 37, 78, 78, 0, 0, 38, 39, 0, 0, 53, + 0, 0, 78, 55, 125, 128, 0, 59, 43, 44, + 76, 0, 78, 78, 46, 0, 49, 0, 0, 64, + 24, 0, 48, 52, 80, 78, 0, 17, 21, 63, + 0, 0, 51, 56, 0, 75, 0, 65, 77, 0, + 47 }; /* YYPGOTO[NTERM-NUM]. */ static const yytype_int16 yypgoto[] = { - -485, -485, -485, -485, -485, -485, -485, -485, -485, 298, - -485, -5, -109, -485, -17, -485, 561, 471, 0, -485, - -485, -485, -485, -485, -485, -485, -485, -485, -340, -484, - -159, -456, -485, 74, 243, -336, 39, -485, -44, 143, - -485, 161, 173, -242, 324, 362, -485, -485, 234, -485, - 240, -485, -485, -485, -485, 168, -485, -485, 110, -485, - 165, -8, -37, -485, -485, -485, -485, -485, -485, -485, - -485, -485, -485, -485, -485, 103, -485, -485, 457, -124, - -130, -485, -485, 257, -485, -485, 399, 38, -45, -42, - -485, -485, -485, -485, -485, 13 + -482, -482, -482, -482, -482, -482, -482, -482, -482, 42, + -482, -5, -127, -482, -17, -482, 632, 542, 8, -482, + -482, -482, -482, -482, -482, -482, -482, -482, -482, -482, + 224, -342, -481, -115, -459, -482, 138, 318, -246, 113, + -482, 155, 352, -482, 305, 268, -263, 420, 442, -482, + -482, 341, -482, 325, -482, -482, -482, -482, 257, -482, + -482, 214, -482, 244, -8, -36, -482, -482, -482, -482, + -482, -482, -482, -482, -482, -482, -482, -482, 101, -482, + -482, 561, -122, -99, -482, -482, 369, -482, -482, 502, + -15, -33, -31, -482, -482, -482, -482, -482, 0 }; /* YYDEFGOTO[NTERM-NUM]. */ static const yytype_int16 yydefgoto[] = { - -1, 8, 9, 10, 11, 12, 13, 14, 15, 102, - 417, 378, 504, 525, 110, 538, 244, 108, 109, 418, - 419, 341, 509, 557, 481, 499, 552, 560, 104, 528, - 234, 501, 433, 423, 362, 426, 435, 337, 219, 131, - 215, 153, 262, 264, 284, 369, 248, 249, 442, 250, - 251, 252, 253, 452, 453, 111, 112, 519, 450, 497, - 379, 105, 60, 61, 375, 324, 62, 63, 64, 65, - 66, 67, 68, 69, 70, 71, 127, 72, 157, 143, - 73, 447, 429, 349, 350, 227, 74, 75, 76, 77, - 78, 79, 80, 81, 82, 170 + -1, 8, 9, 10, 11, 12, 13, 14, 15, 103, + 421, 382, 233, 361, 111, 546, 246, 109, 110, 422, + 423, 342, 516, 564, 487, 492, 557, 507, 560, 569, + 364, 105, 535, 236, 509, 437, 427, 366, 430, 439, + 338, 219, 134, 215, 156, 264, 266, 286, 373, 250, + 251, 448, 252, 253, 254, 255, 458, 459, 112, 113, + 527, 456, 505, 383, 106, 60, 61, 379, 325, 62, + 63, 64, 65, 66, 67, 68, 69, 70, 71, 130, + 72, 160, 146, 73, 453, 433, 350, 351, 227, 74, + 75, 76, 77, 78, 79, 80, 81, 82, 122 }; /* YYTABLE[YYPACT[STATE-NUM]] -- What to do in state STATE-NUM. If @@ -337,779 +345,746 @@ static const yytype_int16 yydefgoto[] = number is the opposite. If YYTABLE_NINF, syntax error. */ static const yytype_int16 yytable[] = { - 113, 255, 59, 159, 17, 142, 160, 268, 269, 428, - 115, 420, 103, 162, 550, 432, 83, 285, 502, 434, - 376, 529, 439, 440, 176, 151, 177, 118, 16, 274, - 152, 391, 119, 83, 122, 123, 124, 150, 125, 126, - 137, 175, 83, 207, 118, 208, 245, 246, 169, 119, - 21, 22, 21, 22, 23, 145, 146, 179, 180, 121, - 121, 121, 128, 121, 121, -285, 207, -285, 208, 182, - 183, 171, 446, 175, 138, -260, 129, -287, 214, -287, - 144, 121, 569, 526, 527, 314, 158, 315, 142, -259, - 181, 316, 317, 318, 135, 121, 121, 319, 551, 21, - 22, 563, 482, -261, 348, -285, 243, -285, 271, 421, - 279, 184, -287, 280, -287, 57, 142, 172, 173, 174, - 258, 178, 116, 117, 254, -263, 372, 136, 267, 59, - 59, 374, 57, 404, 228, 130, 206, -262, 320, 247, - 134, 506, 507, 57, 140, 57, 393, 148, 282, 409, - 154, 270, 161, 218, 163, 164, 165, 166, 167, -290, - -290, -290, 205, -289, 287, 288, 289, 213, 291, 292, - 294, 411, 338, 339, 534, 413, 144, 470, 132, 133, - 353, 155, 321, 354, 322, 323, 220, 172, 173, 174, - 156, 456, 57, 278, 172, 173, 174, 335, 327, 328, - 329, 330, 331, 332, 333, 334, 461, 221, 554, 172, - 173, 174, 172, 173, 174, 342, 343, 344, 345, 347, - 373, 355, 356, 432, 358, 359, 222, 495, 361, 363, - 364, 365, 366, 367, 172, 173, 174, 223, 172, 173, - 174, 201, 224, 325, 202, 203, 204, 205, 59, 216, - 217, 448, 491, 229, 172, 173, 174, 209, 276, 210, - 232, 230, 383, 352, 211, 233, 212, 386, 235, 172, - 173, 174, 225, 172, 173, 174, 463, 390, 290, 256, - 257, 226, 259, 57, 295, 261, 263, 296, 297, 298, - 299, 300, 301, 302, 303, 304, 305, 306, 307, 308, - 309, 310, 311, 312, 313, 273, 396, 397, 265, 84, - 272, 353, 283, 403, 354, 172, 173, 174, 285, 120, - 120, 120, 346, 120, 120, 172, 173, 174, 336, 172, - 173, 174, 340, 357, 424, 363, 427, 427, 142, 139, - 120, 120, 147, 172, 173, 174, 368, 436, 500, 532, - 427, 427, 438, 371, 377, 120, 120, 392, 381, 384, - 121, 408, 186, 187, 540, 541, 382, 505, 389, 391, - 508, 449, 174, 286, 512, 513, 549, 406, 172, 173, - 174, 398, 399, 457, 400, 430, 555, 556, 401, 405, - 186, 416, 523, 524, 352, 200, 422, 231, 59, 564, - 201, 57, 535, 202, 203, 204, 205, 172, 173, 174, - 410, 468, 431, 441, 445, 471, 451, 543, 172, 173, - 174, 545, 546, 200, 186, 187, 478, 458, 201, 260, - 427, 202, 203, 204, 205, 142, 120, 380, 486, 558, - 172, 173, 174, 236, 237, 238, 239, 464, 388, 465, - 240, 466, 241, 566, 197, 198, 199, 200, 467, 473, - 472, 571, 201, 477, 474, 202, 203, 204, 205, 427, - 427, 514, 412, 516, 475, 476, -214, 172, 173, 174, - 479, 480, 521, 172, 173, 174, 207, 483, 208, -214, - 449, 186, 187, 484, 172, 173, 174, 487, 459, 488, - 490, 424, 427, 492, 493, 494, 503, -82, 542, 172, - 173, 174, 496, 510, 511, 414, 515, 517, -214, -214, - -214, -214, 518, 199, 200, -214, 460, -214, 522, 201, - -214, 360, 202, 203, 204, 205, 427, -214, -214, 394, - 530, 531, 565, 559, 485, 547, 172, 173, 174, 544, - -214, 561, -214, -214, -214, 548, -214, -214, -214, -214, - -214, -214, -214, -214, -214, -214, -214, -214, -214, -214, - -214, 562, -253, 570, 107, -214, 407, 242, -214, -214, - -214, -214, -214, 533, -214, -253, 425, -214, 172, 173, - 174, 469, 172, 173, 174, 172, 173, 174, 200, 186, - 187, 387, 567, 201, 443, 520, 202, 203, 204, 205, - 370, 444, 277, 437, -253, -253, -253, -253, 454, 489, - 120, -253, 455, -253, 351, 462, -253, 195, 196, 197, - 198, 199, 200, -253, -253, 498, 0, 201, 0, 0, - 202, 203, 204, 205, 0, 0, -253, 0, -253, -253, - -253, 0, -253, -253, -253, -253, -253, -253, -253, -253, - -253, -253, -253, -253, -253, -253, -253, 0, 0, 0, - 0, -253, -13, 85, -253, -253, -253, -253, -253, 0, - -253, 0, 83, -253, 18, 0, 19, 20, 21, 22, - 23, 0, 0, 24, 25, 26, 27, 28, 0, 29, - 30, 31, 32, 33, 34, 86, 106, 87, 88, 89, - 35, 36, 90, 91, 92, 93, 94, 95, 0, 0, - 0, 96, 97, 98, 99, 37, 0, 100, 38, 39, - 40, 41, 42, 0, 0, 43, 44, 45, 46, 47, - 48, 49, 1, 2, 3, 4, 5, 6, 7, 0, - 0, 50, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 51, 52, 0, - 53, 0, 54, 55, -3, 85, 0, 0, 0, 56, - 101, 57, 58, 0, 83, 0, 18, 0, 19, 20, - 21, 22, 23, 0, 0, 24, 25, 26, 27, 28, - 0, 29, 30, 31, 32, 33, 34, 86, 106, 87, - 88, 89, 35, 36, 90, 91, 92, 93, 94, 95, - 0, 0, 0, 96, 97, 98, 99, 37, 0, 100, - 38, 39, 40, 41, 42, 0, 0, 43, 44, 45, - 46, 47, 48, 49, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 50, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 51, - 52, 0, 53, 0, 54, 55, 85, 0, 0, 0, - 0, 56, 101, 57, 58, 83, 415, 18, 0, 19, - 20, 21, 22, 23, 0, 0, 24, 25, 26, 27, - 28, 0, 29, 30, 31, 32, 33, 34, 86, 106, - 87, 88, 89, 35, 36, 90, 91, 92, 93, 94, - 95, 0, 0, 0, 96, 97, 98, 99, 37, 0, - 100, 38, 39, 40, 41, 42, 0, 0, 43, 44, - 45, 46, 47, 48, 49, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 50, 0, 0, 0, 0, 0, + 114, 380, 59, 118, 17, 118, 257, 118, 145, 118, + 118, 121, 118, 118, 436, 20, 165, 162, 119, 163, + 104, 510, 124, 131, 126, 127, 256, 128, 129, 147, + 118, 536, 16, 140, 276, 161, 83, 315, 316, 153, + 317, 270, 271, 318, 148, 149, 132, 319, 378, 138, + 172, 320, 321, 84, 322, 207, 139, 208, 175, 397, + 117, 176, 117, 177, 117, 141, 117, 117, 413, 117, + 117, 181, 287, 207, 224, 208, 20, 206, 214, 415, + 22, 395, 228, 184, 24, 142, 117, 117, 150, -292, + 424, 175, 145, 154, 578, 173, 174, 323, 155, 452, + 432, 425, 225, 213, 417, 571, 173, 174, 462, 218, + 438, 226, 273, 443, 444, 245, 467, 173, 174, 499, + 145, -264, 123, 260, 125, 281, 147, 282, 173, 174, + 220, 269, 59, 59, 288, 133, -263, 173, 174, 324, + 137, 272, 231, 280, 143, -262, 275, 151, 173, 174, + 157, 284, 164, 221, 166, 167, 168, 169, 170, 376, + 476, 18, 178, 158, 222, 289, 290, 20, 292, 293, + 295, 22, 159, 173, 174, 24, 262, 173, 174, -288, + -290, -288, -290, 117, 558, 173, 174, 396, 173, 174, + 326, 559, 354, 412, 355, 234, 488, 336, 328, 329, + 330, 331, 332, 333, 334, 335, 414, 173, 174, 223, + 353, 416, 503, 418, 232, 343, 344, 345, 346, 348, + 229, 356, 357, 377, 359, 360, 349, 173, 174, 436, + 365, 367, 365, 365, 365, 365, 247, 513, 514, -288, + 248, -288, 173, 174, 249, -266, -265, 230, 173, 174, + 59, 466, 179, 180, 173, 174, 259, 454, 20, 278, + 235, -290, 22, -290, 387, 237, 24, 173, 174, 390, + 384, 541, 173, 174, 173, 174, 291, 363, 209, 394, + 210, 211, 296, 212, 258, 297, 298, 299, 300, 301, + 302, 303, 304, 305, 306, 307, 308, 309, 310, 311, + 312, 313, 314, 118, 261, 561, 173, 174, 401, 402, + 83, 469, 173, 174, 263, 20, 409, 173, 174, 173, + 174, 173, 174, 265, 354, 115, 355, 182, 183, 267, + 116, 173, 174, 434, 392, 428, 367, 431, 431, 533, + 534, 274, 353, 145, 445, 398, 285, 411, 440, 460, + 287, 431, 431, 442, 511, 512, 508, 186, 515, 461, + 117, 337, 519, 520, 173, 174, 341, 238, 239, 240, + 241, 339, 340, 358, 242, 455, 243, 238, 239, 240, + 241, 347, 531, 532, 242, 362, 243, 463, 200, 135, + 136, 542, 468, 201, 216, 217, 202, 203, 204, 205, + 539, 372, 59, 173, 174, 375, 550, 381, 385, 386, + 552, 553, 388, 173, 174, 474, 548, 549, 393, 477, + 395, 83, 400, 174, 404, 185, 20, 556, 565, 405, + 484, -86, 186, 187, 431, 403, 115, 562, 563, 573, + 406, 116, 145, 575, 494, -293, -293, -293, 205, 407, + 572, 189, 580, 190, 191, 192, 193, 194, 195, 196, + 197, 198, 199, 200, 368, 369, 370, 371, 201, 410, + 420, 202, 203, 204, 205, 431, 431, 426, 20, 522, + 435, 524, 447, 446, -293, 451, 464, 521, 457, 470, + 529, 186, 187, 471, 200, 472, 473, 478, 455, 201, + 465, 486, 202, 203, 204, 205, 543, 495, 428, 431, + 483, 496, 190, 191, 192, 193, 194, 195, 196, 197, + 198, 199, 200, 479, 480, 481, 498, 201, 482, 485, + 202, 203, 204, 205, -13, 85, 1, 2, 3, 4, + 5, 6, 7, 431, 18, 83, 489, 19, 493, 490, + 20, 574, 500, 21, 22, 23, 86, 501, 24, 25, + 26, 27, 28, 29, 30, 502, 31, 32, 33, 34, + 35, 36, 87, 107, 88, 89, 90, 37, 38, 91, + 92, 93, 94, 95, 96, 504, 186, 187, 97, 98, + 99, 100, 101, 518, 39, 525, 102, 40, 41, 42, + 43, 44, 517, 523, 45, 46, 47, 48, 49, 50, + 51, 194, 195, 196, 197, 198, 199, 200, 526, 52, + 530, 537, 201, 538, 554, 202, 203, 204, 205, 551, + 555, -3, 85, 566, 53, 54, 567, 55, 568, 56, + 57, 18, 83, 570, 19, 108, 58, 20, 579, 244, + 21, 22, 23, 86, 540, 24, 25, 26, 27, 28, + 29, 30, 429, 31, 32, 33, 34, 35, 36, 87, + 107, 88, 89, 90, 37, 38, 91, 92, 93, 94, + 95, 96, 186, 187, 576, 97, 98, 99, 100, 101, + 475, 39, 374, 102, 40, 41, 42, 43, 44, 391, + 450, 45, 46, 47, 48, 49, 50, 51, 195, 196, + 197, 198, 199, 200, 497, 449, 52, 528, 201, 279, + 506, 202, 203, 204, 205, 0, 441, 352, 0, 85, + 0, 53, 54, 0, 55, 0, 56, 57, 18, 83, + 419, 19, 0, 58, 20, 0, 0, 21, 22, 23, + 86, 0, 24, 25, 26, 27, 28, 29, 30, 0, + 31, 32, 33, 34, 35, 36, 87, 107, 88, 89, + 90, 37, 38, 91, 92, 93, 94, 95, 96, 186, + 187, 0, 97, 98, 99, 100, 101, 0, 39, 0, + 102, 40, 41, 42, 43, 44, 0, 0, 45, 46, + 47, 48, 49, 50, 51, 0, 0, 197, 198, 199, + 200, 0, 0, 52, 0, 201, 0, 0, 202, 203, + 204, 205, 0, 0, 0, 0, 85, 0, 53, 54, + 0, 55, 0, 56, 57, 18, 83, 491, 19, 0, + 58, 20, 0, 0, 21, 22, 23, 86, 0, 24, + 25, 26, 27, 28, 29, 30, 0, 31, 32, 33, + 34, 35, 36, 87, 107, 88, 89, 90, 37, 38, + 91, 92, 93, 94, 95, 96, 186, 187, 0, 97, + 98, 99, 100, 101, 0, 39, 0, 102, 40, 41, + 42, 43, 44, 0, 0, 45, 46, 47, 48, 49, + 50, 51, 0, 0, 0, 0, 199, 200, 0, 0, + 52, 0, 201, 0, 0, 202, 203, 204, 205, 0, + 0, 0, 0, 85, 0, 53, 54, 0, 55, 0, + 56, 57, 18, 83, 544, 19, 0, 58, 20, 0, + 0, 21, 22, 23, 86, 0, 24, 25, 26, 27, + 28, 29, 30, 0, 31, 32, 33, 34, 35, 36, + 87, 107, 88, 89, 90, 37, 38, 91, 92, 93, + 94, 95, 96, 186, 187, 0, 97, 98, 99, 100, + 101, 0, 39, 0, 102, 40, 41, 42, 43, 44, + 0, 0, 45, 46, 47, 48, 49, 50, 51, 0, + 0, 0, 0, 0, 200, 0, 0, 52, 0, 201, + 0, 0, 202, 203, 204, 205, 0, 0, 0, 0, + 85, 0, 53, 54, 0, 55, 0, 56, 57, 18, + 83, 545, 19, 0, 58, 20, 0, 0, 21, 22, + 23, 86, 0, 24, 25, 26, 27, 28, 29, 30, + 0, 31, 32, 33, 34, 35, 36, 87, 107, 88, + 89, 90, 37, 38, 91, 92, 93, 94, 95, 96, + 0, 0, 0, 97, 98, 99, 100, 101, 0, 39, + 0, 102, 40, 41, 42, 43, 44, 0, 0, 45, + 46, 47, 48, 49, 50, 51, 201, 0, 0, 202, + 203, 204, 205, 0, 52, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 85, 0, 53, + 54, 0, 55, 0, 56, 57, 18, 83, 547, 19, + 0, 58, 20, 0, 0, 21, 22, 23, 86, 0, + 24, 25, 26, 27, 28, 29, 30, 0, 31, 32, + 33, 34, 35, 36, 87, 107, 88, 89, 90, 37, + 38, 91, 92, 93, 94, 95, 96, 0, 0, 0, + 97, 98, 99, 100, 101, 0, 39, 0, 102, 40, + 41, 42, 43, 44, 0, 0, 45, 46, 47, 48, + 49, 50, 51, 0, 0, 0, 0, 0, 0, 0, + 0, 52, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 85, 0, 53, 54, 0, 55, + 0, 56, 57, 18, 83, 0, 19, 0, 58, 20, + 0, 0, 21, 22, 23, 86, 0, 24, 25, 26, + 27, 28, 29, 30, 0, 31, 32, 33, 34, 35, + 36, 87, 107, 88, 89, 90, 37, 38, 91, 92, + 93, 94, 95, 96, 0, 0, 0, 97, 98, 99, + 100, 101, 0, 39, 0, 102, 40, 41, 42, 43, + 44, 0, 0, 45, 46, 47, 48, 49, 50, 51, + 0, 0, 577, 0, 0, 0, 0, 0, 52, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 51, 52, 0, 53, 0, 54, 55, 85, 0, 0, - 0, 0, 56, 101, 57, 58, 83, 536, 18, 0, - 19, 20, 21, 22, 23, 0, 0, 24, 25, 26, - 27, 28, 0, 29, 30, 31, 32, 33, 34, 86, - 106, 87, 88, 89, 35, 36, 90, 91, 92, 93, - 94, 95, 0, 0, 0, 96, 97, 98, 99, 37, - 0, 100, 38, 39, 40, 41, 42, 0, 0, 43, - 44, 45, 46, 47, 48, 49, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 50, 0, 0, 0, 0, + 0, 85, 0, 53, 54, 0, 55, 0, 56, 57, + 18, 83, 0, 19, 0, 58, 20, 0, 0, 21, + 22, 23, 86, 0, 24, 25, 26, 27, 28, 29, + 30, 0, 31, 32, 33, 34, 35, 36, 87, 107, + 88, 89, 90, 37, 38, 91, 92, 93, 94, 95, + 96, 0, 0, 0, 97, 98, 99, 100, 101, 0, + 39, 0, 102, 40, 41, 42, 43, 44, 0, 0, + 45, 46, 47, 48, 49, 50, 51, 0, 0, 0, + 0, 0, 0, 0, 0, 52, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 85, 0, + 53, 54, 0, 55, 0, 56, 57, 18, 83, 0, + 19, 0, 58, 20, 0, 0, 21, 22, 23, 86, + 0, 24, 25, 26, 27, 28, 29, 30, 0, 31, + 32, 33, 34, 35, 36, 87, 0, 88, 89, 90, + 37, 38, 91, 92, 93, 94, 95, 96, 0, 0, + 0, 97, 98, 99, 100, 101, 0, 39, 0, 102, + 40, 41, 42, 43, 44, 0, 0, 45, 46, 47, + 48, 49, 50, 51, 0, 0, 0, 0, 0, 0, + 0, 0, 52, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 85, 0, 0, 0, 0, 53, 54, 0, + 55, 18, 56, 57, 19, 0, 0, 20, 0, 58, + 21, 22, 23, -81, 0, 24, 25, 26, 27, 28, + 29, 30, 0, 31, 32, 33, 34, 35, 36, 0, + 0, 0, 0, 0, 37, 38, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 51, 52, 0, 53, 0, 54, 55, 85, 0, - 0, 0, 0, 56, 101, 57, 58, 83, 537, 18, - 0, 19, 20, 21, 22, 23, 0, 0, 24, 25, - 26, 27, 28, 0, 29, 30, 31, 32, 33, 34, - 86, 106, 87, 88, 89, 35, 36, 90, 91, 92, - 93, 94, 95, 0, 0, 0, 96, 97, 98, 99, - 37, 0, 100, 38, 39, 40, 41, 42, 0, 0, - 43, 44, 45, 46, 47, 48, 49, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 50, 0, 0, 0, + 0, 39, 0, 0, 40, 41, 42, 43, 44, 0, + 0, 45, 46, 47, 48, 49, 50, 51, 0, 0, + 0, 0, 0, 0, 0, 0, 52, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 85, 0, 0, 0, + 0, 53, 54, 0, 55, 18, 56, 57, 19, 0, + 0, 20, 0, 58, 21, 22, 23, 0, 0, 24, + 25, 26, 27, 28, 29, 30, 0, 31, 32, 33, + 34, 35, 36, 0, 0, 0, 0, 0, 37, 38, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 51, 52, 0, 53, 0, 54, 55, 85, - 0, 0, 0, 0, 56, 101, 57, 58, 83, 539, - 18, 0, 19, 20, 21, 22, 23, 0, 0, 24, - 25, 26, 27, 28, 0, 29, 30, 31, 32, 33, - 34, 86, 106, 87, 88, 89, 35, 36, 90, 91, - 92, 93, 94, 95, 0, 0, 0, 96, 97, 98, - 99, 37, 0, 100, 38, 39, 40, 41, 42, 0, - 0, 43, 44, 45, 46, 47, 48, 49, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 50, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 51, 52, 0, 53, 0, 54, 55, - 85, 0, 0, 0, 0, 56, 101, 57, 58, 83, - 553, 18, 0, 19, 20, 21, 22, 23, 0, 0, - 24, 25, 26, 27, 28, 0, 29, 30, 31, 32, - 33, 34, 86, 106, 87, 88, 89, 35, 36, 90, - 91, 92, 93, 94, 95, 0, 0, 0, 96, 97, - 98, 99, 37, 0, 100, 38, 39, 40, 41, 42, - 0, 0, 43, 44, 45, 46, 47, 48, 49, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 50, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 51, 52, 0, 53, 0, 54, - 55, 85, 0, 0, 0, 0, 56, 101, 57, 58, - 83, 0, 18, 0, 19, 20, 21, 22, 23, 0, - 0, 24, 25, 26, 27, 28, 0, 29, 30, 31, - 32, 33, 34, 86, 106, 87, 88, 89, 35, 36, - 90, 91, 92, 93, 94, 95, 0, 0, 0, 96, - 97, 98, 99, 37, 0, 100, 38, 39, 40, 41, - 42, 0, 0, 43, 44, 45, 46, 47, 48, 49, - 0, 0, 568, 0, 0, 0, 0, 0, 0, 50, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 51, 52, 0, 53, 0, - 54, 55, 85, 0, 0, 0, 0, 56, 101, 57, - 58, 83, 0, 18, 0, 19, 20, 21, 22, 23, - 0, 0, 24, 25, 26, 27, 28, 0, 29, 30, - 31, 32, 33, 34, 86, 106, 87, 88, 89, 35, - 36, 90, 91, 92, 93, 94, 95, 0, 0, 0, - 96, 97, 98, 99, 37, 0, 100, 38, 39, 40, - 41, 42, 0, 0, 43, 44, 45, 46, 47, 48, - 49, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 50, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 51, 52, 0, 53, - 0, 54, 55, 85, 0, 0, 0, 0, 56, 101, - 57, 58, 83, 0, 18, 0, 19, 20, 21, 22, - 23, 0, 0, 24, 25, 26, 27, 28, 0, 29, - 30, 31, 32, 33, 34, 86, 0, 87, 88, 89, - 35, 36, 90, 91, 92, 93, 94, 95, 0, 0, - 0, 96, 97, 98, 99, 37, 0, 100, 38, 39, - 40, 41, 42, 0, 0, 43, 44, 45, 46, 47, - 48, 49, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 50, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 51, 52, 0, - 53, 0, 54, 55, 85, 0, 0, 0, 0, 56, - 101, 57, 58, 0, 0, 18, 0, 19, 20, 21, - 22, 23, 0, 0, 24, 25, 26, 27, 28, 0, - 29, 30, 31, 32, 33, 34, 0, 0, 0, 0, - 0, 35, 36, 0, 0, 0, 0, 0, 186, 187, - 0, 0, 0, 0, 0, 0, 37, 0, 0, 38, - 39, 40, 41, 42, 0, 0, 43, 44, 45, 46, - 47, 48, 49, 192, 193, 194, 195, 196, 197, 198, - 199, 200, 50, 0, 0, 0, 201, 0, 0, 202, - 203, 204, 205, 0, 0, 0, 0, 0, 51, 52, - 0, 53, 0, 54, 55, 85, 0, 0, 0, 0, - 56, -77, 57, 58, 0, 0, 18, 0, 19, 20, - 21, 22, 23, 0, 0, 24, 25, 26, 27, 28, - 0, 29, 30, 31, 32, 33, 34, 0, 0, 0, - 0, 0, 35, 36, 0, 0, 0, 0, 186, 187, - 0, 0, 0, 0, 0, 0, 0, 37, 0, 0, - 38, 39, 40, 41, 42, 0, 0, 43, 44, 45, - 46, 47, 48, 49, 193, 194, 195, 196, 197, 198, - 199, 200, 0, 50, 0, 0, 201, 0, 0, 202, - 203, 204, 205, 0, 0, 0, 0, 0, 0, 51, - 52, 0, 53, 0, 54, 55, 0, 0, 0, 0, - -77, 56, 0, 57, 58, 83, 0, 18, 0, 19, - 20, 21, 22, 23, 0, 0, 141, 25, 26, 27, - 28, 119, 29, 30, 31, 32, 33, 34, 0, 0, - 0, 0, 0, 35, 36, 0, 0, 0, 186, 187, - 0, 0, 0, 0, 0, 0, 0, 0, 37, 0, - 0, 38, 39, 40, 41, 42, 0, 0, 43, 44, - 45, 46, 47, 48, 49, 194, 195, 196, 197, 198, - 199, 200, 0, 0, 50, 0, 201, 0, 0, 202, - 203, 204, 205, 0, 0, 0, 0, 0, 0, 0, - 51, 52, 0, 53, 0, 54, 55, 0, 0, 0, - 0, 0, 56, 0, 57, 58, 83, 0, 18, 0, - 19, 20, 21, 22, 23, 0, 0, 24, 25, 26, - 27, 28, 0, 29, 30, 31, 32, 33, 34, 0, - 0, 0, 0, 0, 35, 36, 236, 237, 238, 239, - 0, 0, 0, 240, 0, 241, 0, 0, 0, 37, - 0, 0, 38, 39, 40, 41, 42, 0, 0, 43, - 44, 45, 46, 47, 48, 49, 0, 0, 0, 0, - 172, 173, 174, 0, 0, 50, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 51, 52, 0, 53, 0, 54, 55, 0, 0, - 0, 0, 0, 56, 0, 57, 58, 18, 114, 19, - 20, 21, 22, 23, 0, 0, 24, 25, 26, 27, - 28, 0, 29, 30, 31, 32, 33, 34, 0, 0, - 0, 0, 0, 35, 36, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 37, 0, - 0, 38, 39, 40, 41, 42, 0, 0, 43, 44, - 45, 46, 47, 48, 49, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 50, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 39, 0, 0, 40, 41, + 42, 43, 44, -217, 0, 45, 46, 47, 48, 49, + 50, 51, 0, 0, 207, 0, 208, -217, -217, 0, + 52, 0, 0, 0, 0, -217, -217, 0, 0, 0, + 0, 0, 0, 0, 0, 53, 54, 0, 55, 0, + 56, 57, 0, 0, 0, 0, -81, 58, 0, 0, + -217, -217, -217, -217, 0, 0, 0, -217, 0, -217, + 0, 0, 0, 0, -217, 0, 0, 0, 0, 0, + 0, -217, -217, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, -217, 0, -217, -217, 0, -217, + -217, -217, -217, -217, -217, -217, -217, -217, -217, -217, + -217, -217, -217, -256, 186, 187, 0, -217, 0, 0, + -217, -217, -217, -217, -217, 0, 0, -256, -256, 0, + 0, 0, 0, 0, 0, -256, -256, 192, 193, 194, + 195, 196, 197, 198, 199, 200, 0, 0, 0, 0, + 201, 0, 0, 202, 203, 204, 205, 0, 0, 0, + -256, -256, -256, -256, 0, 0, 0, -256, 0, -256, + 0, 0, 0, 0, -256, 0, 0, 0, 0, 0, + 0, -256, -256, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, -256, 0, -256, -256, 0, -256, + -256, -256, -256, -256, -256, -256, -256, -256, -256, -256, + -256, -256, -256, 0, 0, 0, 0, -256, 0, 0, + -256, -256, -256, -256, -256, 18, 83, 0, 19, 0, + 0, 20, 0, 0, 21, 22, 23, 0, 0, 24, + 25, 144, 27, 28, 29, 30, 116, 31, 32, 33, + 34, 35, 36, 0, 0, 0, 0, 0, 37, 38, + 0, 0, 0, 0, 0, 0, 0, 0, 186, 187, + 0, 0, 0, 0, 0, 39, 0, 0, 40, 41, + 42, 43, 44, 0, 0, 45, 46, 47, 48, 49, + 50, 51, 193, 194, 195, 196, 197, 198, 199, 200, + 52, 0, 0, 0, 201, 0, 0, 202, 203, 204, + 205, 0, 0, 0, 0, 53, 54, 0, 55, 18, + 56, 57, 19, 120, 0, 20, 0, 58, 21, 22, + 23, 0, 0, 24, 25, 26, 27, 28, 29, 30, + 0, 31, 32, 33, 34, 35, 36, 0, 0, 0, + 0, 0, 37, 38, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 39, + 0, 0, 40, 41, 42, 43, 44, 0, 0, 45, + 46, 47, 48, 49, 50, 51, 0, 0, 0, 0, + 0, 0, 0, 0, 52, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 53, + 54, 0, 55, 0, 56, 57, 18, 83, 0, 19, + 0, 58, 20, 0, 0, 21, 22, 23, 0, 0, + 24, 25, 26, 27, 28, 29, 30, 0, 31, 32, + 33, 34, 35, 36, 0, 0, 0, 0, 0, 37, + 38, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 39, 0, 0, 40, + 41, 42, 43, 44, 0, 0, 45, 46, 47, 48, + 49, 50, 51, 0, 0, 0, 0, 0, 0, 0, + 0, 52, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 53, 54, 0, 55, + 18, 56, 57, 19, 0, 0, 20, 0, 58, 21, + 22, 23, 152, 0, 24, 25, 26, 27, 28, 29, + 30, 0, 31, 32, 33, 34, 35, 36, 0, 0, + 0, 0, 0, 37, 38, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 51, 52, 0, 53, 0, 54, 55, 0, 0, 0, - 0, 0, 56, 0, 57, 58, 18, 0, 19, 20, - 21, 22, 23, 0, 0, 24, 25, 26, 27, 28, - 0, 29, 30, 31, 32, 33, 34, 0, 0, 0, - 0, 0, 35, 36, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 37, 0, 0, - 38, 39, 40, 41, 42, 0, 0, 43, 44, 45, - 46, 47, 48, 49, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 50, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 51, - 52, 0, 53, 0, 54, 55, 0, 0, 0, 0, - 0, 56, 149, 57, 58, 18, 0, 19, 20, 21, - 22, 23, 0, 0, 24, 25, 26, 27, 28, 0, - 29, 30, 31, 32, 33, 34, 0, 0, 0, 0, - 0, 35, 36, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 37, 0, 0, 38, - 39, 40, 41, 42, 0, 0, 43, 44, 45, 46, - 47, 48, 49, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 50, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 51, 52, - 0, 53, 0, 54, 55, 0, 0, 0, 0, 168, - 56, 0, 57, 58, 18, 0, 19, 20, 21, 22, - 23, 0, 0, 24, 25, 26, 27, 28, 0, 29, - 30, 31, 32, 33, 34, 0, 0, 0, 0, 0, - 35, 36, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 37, 0, 0, 38, 39, - 40, 41, 42, 0, 0, 43, 44, 45, 46, 47, - 48, 49, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 50, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 51, 52, 0, - 53, 0, 54, 55, 0, 0, 0, 0, 266, 56, - 0, 57, 58, 18, 0, 19, 20, 21, 22, 23, - 0, 0, 24, 25, 26, 27, 28, 0, 29, 30, - 31, 32, 33, 34, 0, 0, 0, 0, 0, 35, - 36, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 37, 0, 0, 38, 39, 40, - 41, 42, 0, 0, 43, 44, 45, 46, 47, 48, - 49, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 50, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 51, 52, 0, 53, - 0, 54, 55, 0, 0, 0, 0, 281, 56, 0, - 57, 58, 18, 0, 19, 20, 21, 22, 23, 0, - 0, 24, 25, 26, 27, 28, 0, 29, 30, 31, - 32, 33, 34, 0, 0, 0, 0, 0, 35, 36, + 39, 0, 0, 40, 41, 42, 43, 44, 0, 0, + 45, 46, 47, 48, 49, 50, 51, 0, 0, 0, + 0, 0, 0, 0, 0, 52, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 37, 0, 0, 38, 39, 40, 41, - 42, 0, 0, 43, 44, 45, 46, 47, 48, 49, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 50, + 53, 54, 0, 55, 18, 56, 57, 19, 0, 0, + 20, 0, 58, 21, 22, 23, 0, 0, 24, 25, + 26, 27, 28, 29, 30, 0, 31, 32, 33, 34, + 35, 36, 0, 0, 0, 0, 0, 37, 38, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 51, 52, 0, 53, 0, - 54, 55, 0, 0, 0, 0, 293, 56, 0, 57, - 58, 18, 0, 19, 20, 21, 22, 23, 0, 0, - 24, 25, 26, 27, 28, 0, 29, 30, 31, 32, - 33, 34, 0, 0, 0, 0, 0, 35, 36, 0, + 0, 0, 0, 0, 39, 0, 0, 40, 41, 42, + 43, 44, 0, 0, 45, 46, 47, 48, 49, 50, + 51, 0, 0, 0, 0, 0, 0, 0, 0, 52, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 37, 0, 0, 38, 39, 40, 41, 42, - 0, 0, 43, 44, 45, 46, 47, 48, 49, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 50, 0, + 0, 0, 0, 0, 53, 54, 0, 55, 18, 56, + 57, 19, 0, 0, 20, 171, 58, 21, 22, 23, + 0, 0, 24, 25, 26, 27, 28, 29, 30, 0, + 31, 32, 33, 34, 35, 36, 0, 0, 0, 0, + 0, 37, 38, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 39, 0, + 0, 40, 41, 42, 43, 44, 0, 0, 45, 46, + 47, 48, 49, 50, 51, 0, 0, 0, 0, 0, + 0, 0, 0, 52, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 53, 54, + 0, 55, 18, 56, 57, 19, 0, 0, 20, 268, + 58, 21, 22, 23, 0, 0, 24, 25, 26, 27, + 28, 29, 30, 0, 31, 32, 33, 34, 35, 36, + 0, 0, 0, 0, 0, 37, 38, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 51, 52, 0, 53, 0, 54, - 55, 0, 0, 0, 0, 326, 56, 0, 57, 58, - 18, 0, 19, 20, 21, 22, 23, 0, 0, 24, - 25, 26, 27, 28, 0, 29, 30, 31, 32, 33, - 34, 0, 0, 0, 0, 0, 35, 36, 0, 0, + 0, 0, 39, 0, 0, 40, 41, 42, 43, 44, + 0, 0, 45, 46, 47, 48, 49, 50, 51, 0, + 0, 0, 0, 0, 0, 0, 0, 52, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 37, 0, 0, 38, 39, 40, 41, 42, 0, - 0, 43, 44, 45, 46, 47, 48, 49, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 50, 0, 0, + 0, 0, 53, 54, 0, 55, 18, 56, 57, 19, + 0, 0, 20, 283, 58, 21, 22, 23, 0, 0, + 24, 25, 26, 27, 28, 29, 30, 0, 31, 32, + 33, 34, 35, 36, 0, 0, 0, 0, 0, 37, + 38, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 39, 0, 0, 40, + 41, 42, 43, 44, 0, 0, 45, 46, 47, 48, + 49, 50, 51, 0, 0, 0, 0, 0, 0, 0, + 0, 52, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 53, 54, 0, 55, + 18, 56, 57, 19, 0, 0, 20, 294, 58, 21, + 22, 23, 0, 0, 24, 25, 26, 27, 28, 29, + 30, 0, 31, 32, 33, 34, 35, 36, 0, 0, + 0, 0, 0, 37, 38, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 51, 52, 0, 53, 0, 54, 55, - 0, 0, 0, 0, 385, 56, 0, 57, 58, 18, - 0, 19, 20, 21, 22, 23, 0, 0, 24, 25, - 26, 27, 28, 0, 29, 30, 31, 32, 33, 34, - 0, 0, 0, 0, 0, 35, 36, 0, 0, 0, + 39, 0, 0, 40, 41, 42, 43, 44, 0, 0, + 45, 46, 47, 48, 49, 50, 51, 0, 0, 0, + 0, 0, 0, 0, 0, 52, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 37, 0, 0, 38, 39, 40, 41, 42, 0, 0, - 43, 44, 45, 46, 47, 48, 49, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 50, 0, 0, 0, + 53, 54, 0, 55, 18, 56, 57, 19, 0, 0, + 20, 327, 58, 21, 22, 23, 0, 0, 24, 25, + 26, 27, 28, 29, 30, 0, 31, 32, 33, 34, + 35, 36, 0, 0, 0, 0, 0, 37, 38, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 51, 52, 0, 53, 0, 54, 55, 0, - 0, 0, 0, 402, 56, 0, 57, 58, 18, 0, - 19, 20, 21, 22, 23, 0, 0, 24, 25, 26, - 27, 28, 0, 29, 30, 31, 32, 33, 34, 0, - 0, 0, 0, 0, 35, 36, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 37, - 0, 0, 38, 39, 40, 41, 42, 0, 0, 43, - 44, 45, 46, 47, 48, 49, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 50, 0, 0, 0, 0, + 0, 0, 0, 0, 39, 0, 0, 40, 41, 42, + 43, 44, 0, 0, 45, 46, 47, 48, 49, 50, + 51, 0, 0, 0, 0, 0, 0, 0, 0, 52, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 51, 52, 0, 53, 0, 54, 55, 0, 0, - 0, 0, 0, 56, 0, 57, 58, 18, 0, 19, - 20, 21, 22, 23, 0, 0, 24, 25, 26, 27, - 28, 0, 29, 30, 31, 32, 33, 34, 0, 0, - 0, 0, 0, 35, 36, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 37, 0, - 0, 38, 39, 40, 41, 42, 0, 0, 43, 44, - 45, 46, 47, 48, 49, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 50, 0, 0, 0, 0, 185, - 0, 0, 0, 0, 0, 0, 186, 187, 0, 0, - 51, 52, 0, 53, 0, 54, 55, 0, 0, 0, - 0, 0, 275, 0, 57, 58, 188, 189, 395, 190, - 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, - 0, 0, 0, 0, 201, 185, 0, 202, 203, 204, - 205, 0, 186, 187, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 53, 54, 0, 55, 18, 56, + 57, 19, 0, 0, 20, 389, 58, 21, 22, 23, + 0, 0, 24, 25, 26, 27, 28, 29, 30, 0, + 31, 32, 33, 34, 35, 36, 0, 0, 0, 0, + 0, 37, 38, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 39, 0, + 0, 40, 41, 42, 43, 44, 0, 0, 45, 46, + 47, 48, 49, 50, 51, 0, 0, 0, 0, 0, + 0, 0, 0, 52, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 53, 54, + 0, 55, 18, 56, 57, 19, 0, 0, 20, 408, + 58, 21, 22, 23, 0, 0, 24, 25, 26, 27, + 28, 29, 30, 0, 31, 32, 33, 34, 35, 36, + 0, 0, 0, 0, 0, 37, 38, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 188, 189, 0, 190, 191, 192, 193, 194, - 195, 196, 197, 198, 199, 200, 0, 0, 0, 0, - 201, 185, 0, 202, 203, 204, 205, 0, 186, 187, + 0, 0, 39, 0, 0, 40, 41, 42, 43, 44, + 0, 0, 45, 46, 47, 48, 49, 50, 51, 0, + 0, 0, 0, 0, 0, 0, 0, 52, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 189, - 0, 190, 191, 192, 193, 194, 195, 196, 197, 198, - 199, 200, 0, 0, 0, 0, 201, -290, 0, 202, - 203, 204, 205, 0, 186, 187, 0, 0, 0, 0, + 0, 0, 53, 54, 0, 55, 18, 56, 57, 19, + 0, 0, 20, 0, 58, 21, 22, 23, 0, 0, + 24, 25, 26, 27, 28, 29, 30, 0, 31, 32, + 33, 34, 35, 36, 0, 0, 0, 0, 0, 37, + 38, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 39, 0, 0, 40, + 41, 42, 43, 44, 0, 0, 45, 46, 47, 48, + 49, 50, 51, 0, 0, 0, 0, 0, 0, 0, + 0, 52, 0, 0, 185, 0, 0, 0, 0, 0, + 0, 186, 187, 0, 0, 0, 53, 54, 0, 55, + 0, 56, 57, 0, 0, 0, 0, 0, 277, 188, + 189, 399, 190, 191, 192, 193, 194, 195, 196, 197, + 198, 199, 200, 0, 0, 0, 0, 201, 185, 0, + 202, 203, 204, 205, 0, 186, 187, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 190, 191, 192, - 193, 194, 195, 196, 197, 198, 199, 200, 0, 0, - 0, 0, 201, 0, 0, 202, 203, 204, 205 + 0, 0, 0, 188, 189, 0, 190, 191, 192, 193, + 194, 195, 196, 197, 198, 199, 200, 0, 0, 0, + 0, 201, 0, 0, 202, 203, 204, 205 }; static const yytype_int16 yycheck[] = { - 17, 125, 10, 48, 9, 42, 48, 137, 138, 345, - 18, 10, 12, 50, 24, 355, 10, 12, 474, 355, - 262, 505, 358, 359, 10, 21, 12, 21, 0, 153, - 26, 12, 26, 10, 21, 22, 23, 45, 25, 26, - 73, 80, 10, 10, 21, 12, 16, 17, 56, 26, - 16, 17, 16, 17, 18, 42, 43, 91, 92, 21, - 22, 23, 12, 25, 26, 10, 10, 12, 12, 89, - 90, 58, 111, 80, 107, 70, 107, 10, 83, 12, - 42, 43, 566, 46, 47, 10, 48, 12, 125, 70, - 91, 16, 17, 18, 107, 57, 58, 22, 108, 16, - 17, 557, 438, 70, 68, 10, 106, 12, 145, 108, - 155, 89, 10, 155, 12, 109, 153, 76, 77, 78, - 128, 107, 19, 20, 13, 70, 256, 107, 136, 137, - 138, 13, 109, 110, 96, 32, 107, 70, 63, 109, - 37, 477, 478, 109, 41, 109, 13, 44, 156, 13, - 47, 138, 49, 21, 51, 52, 53, 54, 55, 102, - 103, 104, 105, 10, 172, 173, 174, 10, 176, 177, - 178, 13, 216, 217, 510, 13, 138, 419, 35, 36, - 225, 98, 107, 225, 109, 110, 107, 76, 77, 78, - 107, 13, 109, 155, 76, 77, 78, 214, 206, 207, - 208, 209, 210, 211, 212, 213, 13, 107, 544, 76, - 77, 78, 76, 77, 78, 220, 221, 222, 223, 224, - 257, 226, 227, 563, 229, 230, 107, 469, 236, 237, - 238, 239, 240, 241, 76, 77, 78, 107, 76, 77, - 78, 99, 68, 205, 102, 103, 104, 105, 256, 88, - 89, 375, 13, 107, 76, 77, 78, 10, 155, 12, - 108, 107, 270, 225, 10, 48, 12, 275, 108, 76, - 77, 78, 98, 76, 77, 78, 406, 285, 175, 107, - 73, 107, 106, 109, 181, 24, 70, 184, 185, 186, - 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, - 197, 198, 199, 200, 201, 108, 314, 315, 106, 11, - 11, 356, 70, 321, 356, 76, 77, 78, 12, 21, - 22, 23, 98, 25, 26, 76, 77, 78, 21, 76, - 77, 78, 21, 107, 342, 343, 344, 345, 375, 41, - 42, 43, 44, 76, 77, 78, 26, 355, 472, 508, - 358, 359, 357, 80, 24, 57, 58, 108, 74, 11, - 322, 108, 61, 62, 523, 524, 106, 476, 24, 12, - 479, 376, 78, 106, 483, 484, 535, 107, 76, 77, - 78, 110, 110, 391, 110, 347, 545, 546, 110, 110, - 61, 19, 501, 502, 356, 94, 21, 99, 406, 558, - 99, 109, 511, 102, 103, 104, 105, 76, 77, 78, - 108, 416, 107, 81, 106, 420, 107, 526, 76, 77, - 78, 530, 531, 94, 61, 62, 431, 11, 99, 131, - 438, 102, 103, 104, 105, 472, 138, 106, 446, 548, - 76, 77, 78, 42, 43, 44, 45, 11, 106, 11, - 49, 11, 51, 562, 91, 92, 93, 94, 11, 106, - 21, 570, 99, 107, 106, 102, 103, 104, 105, 477, - 478, 488, 108, 490, 106, 106, 0, 76, 77, 78, - 106, 108, 499, 76, 77, 78, 10, 106, 12, 13, - 495, 61, 62, 106, 76, 77, 78, 74, 395, 10, - 10, 509, 510, 11, 106, 108, 10, 106, 525, 76, - 77, 78, 108, 107, 106, 108, 106, 72, 42, 43, - 44, 45, 108, 93, 94, 49, 108, 51, 108, 99, - 54, 233, 102, 103, 104, 105, 544, 61, 62, 106, - 106, 106, 559, 71, 441, 108, 76, 77, 78, 107, - 74, 20, 76, 77, 78, 106, 80, 81, 82, 83, - 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, - 94, 106, 0, 106, 13, 99, 106, 106, 102, 103, - 104, 105, 106, 509, 108, 13, 343, 111, 76, 77, - 78, 418, 76, 77, 78, 76, 77, 78, 94, 61, - 62, 277, 563, 99, 370, 495, 102, 103, 104, 105, - 248, 371, 155, 356, 42, 43, 44, 45, 106, 451, - 322, 49, 106, 51, 225, 106, 54, 89, 90, 91, - 92, 93, 94, 61, 62, 470, -1, 99, -1, -1, - 102, 103, 104, 105, -1, -1, 74, -1, 76, 77, - 78, -1, 80, 81, 82, 83, 84, 85, 86, 87, - 88, 89, 90, 91, 92, 93, 94, -1, -1, -1, - -1, 99, 0, 1, 102, 103, 104, 105, 106, -1, - 108, -1, 10, 111, 12, -1, 14, 15, 16, 17, - 18, -1, -1, 21, 22, 23, 24, 25, -1, 27, - 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, - 38, 39, 40, 41, 42, 43, 44, 45, -1, -1, - -1, 49, 50, 51, 52, 53, -1, 55, 56, 57, - 58, 59, 60, -1, -1, 63, 64, 65, 66, 67, - 68, 69, 3, 4, 5, 6, 7, 8, 9, -1, - -1, 79, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 95, 96, -1, - 98, -1, 100, 101, 0, 1, -1, -1, -1, 107, - 108, 109, 110, -1, 10, -1, 12, -1, 14, 15, - 16, 17, 18, -1, -1, 21, 22, 23, 24, 25, - -1, 27, 28, 29, 30, 31, 32, 33, 34, 35, + 17, 264, 10, 18, 9, 20, 128, 22, 44, 24, + 25, 19, 27, 28, 356, 16, 52, 50, 18, 50, + 12, 480, 22, 13, 24, 25, 14, 27, 28, 44, + 45, 512, 0, 80, 156, 50, 11, 10, 11, 47, + 13, 140, 141, 16, 44, 45, 112, 20, 14, 112, + 58, 24, 25, 11, 27, 11, 112, 13, 15, 14, + 18, 11, 20, 13, 22, 112, 24, 25, 14, 27, + 28, 96, 13, 11, 75, 13, 16, 112, 83, 14, + 20, 13, 97, 94, 24, 43, 44, 45, 46, 11, + 11, 15, 128, 26, 575, 83, 84, 70, 31, 23, + 346, 22, 103, 11, 14, 564, 83, 84, 14, 26, + 356, 112, 148, 359, 360, 107, 14, 83, 84, 14, + 156, 77, 21, 131, 23, 158, 141, 158, 83, 84, + 112, 139, 140, 141, 111, 34, 77, 83, 84, 112, + 39, 141, 100, 158, 43, 77, 22, 46, 83, 84, + 49, 159, 51, 112, 53, 54, 55, 56, 57, 258, + 423, 10, 112, 103, 112, 173, 174, 16, 176, 177, + 178, 20, 112, 83, 84, 24, 134, 83, 84, 11, + 11, 13, 13, 141, 22, 83, 84, 22, 83, 84, + 205, 29, 225, 22, 225, 22, 442, 214, 206, 207, + 208, 209, 210, 211, 212, 213, 22, 83, 84, 112, + 225, 22, 475, 22, 11, 220, 221, 222, 223, 224, + 112, 226, 227, 259, 229, 230, 75, 83, 84, 571, + 238, 239, 240, 241, 242, 243, 16, 483, 484, 11, + 20, 13, 83, 84, 24, 77, 77, 112, 83, 84, + 258, 22, 96, 97, 83, 84, 80, 379, 16, 158, + 53, 11, 20, 13, 272, 22, 24, 83, 84, 277, + 111, 517, 83, 84, 83, 84, 175, 235, 11, 287, + 13, 11, 181, 13, 112, 184, 185, 186, 187, 188, + 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, + 199, 200, 201, 318, 111, 551, 83, 84, 316, 317, + 11, 410, 83, 84, 29, 16, 324, 83, 84, 83, + 84, 83, 84, 77, 357, 26, 357, 94, 95, 111, + 31, 83, 84, 348, 111, 343, 344, 345, 346, 51, + 52, 12, 357, 379, 361, 111, 77, 111, 356, 111, + 13, 359, 360, 358, 481, 482, 478, 68, 485, 111, + 318, 26, 489, 490, 83, 84, 26, 47, 48, 49, + 50, 216, 217, 112, 54, 380, 56, 47, 48, 49, + 50, 103, 509, 510, 54, 59, 56, 395, 99, 37, + 38, 518, 111, 104, 89, 90, 107, 108, 109, 110, + 515, 31, 410, 83, 84, 15, 533, 29, 81, 111, + 537, 538, 12, 83, 84, 420, 531, 532, 29, 424, + 13, 11, 25, 84, 25, 61, 16, 542, 555, 25, + 435, 111, 68, 69, 442, 25, 26, 552, 553, 566, + 25, 31, 478, 570, 452, 107, 108, 109, 110, 25, + 565, 87, 579, 89, 90, 91, 92, 93, 94, 95, + 96, 97, 98, 99, 240, 241, 242, 243, 104, 112, + 18, 107, 108, 109, 110, 483, 484, 26, 16, 496, + 112, 498, 86, 112, 61, 111, 12, 492, 112, 12, + 507, 68, 69, 12, 99, 12, 12, 26, 503, 104, + 399, 22, 107, 108, 109, 110, 521, 81, 516, 517, + 112, 11, 89, 90, 91, 92, 93, 94, 95, 96, + 97, 98, 99, 111, 111, 111, 11, 104, 111, 111, + 107, 108, 109, 110, 0, 1, 3, 4, 5, 6, + 7, 8, 9, 551, 10, 11, 111, 13, 447, 111, + 16, 568, 12, 19, 20, 21, 22, 111, 24, 25, + 26, 27, 28, 29, 30, 22, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, - -1, -1, -1, 49, 50, 51, 52, 53, -1, 55, - 56, 57, 58, 59, 60, -1, -1, 63, 64, 65, - 66, 67, 68, 69, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 79, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 95, - 96, -1, 98, -1, 100, 101, 1, -1, -1, -1, - -1, 107, 108, 109, 110, 10, 11, 12, -1, 14, - 15, 16, 17, 18, -1, -1, 21, 22, 23, 24, - 25, -1, 27, 28, 29, 30, 31, 32, 33, 34, + 46, 47, 48, 49, 50, 22, 68, 69, 54, 55, + 56, 57, 58, 111, 60, 79, 62, 63, 64, 65, + 66, 67, 112, 111, 70, 71, 72, 73, 74, 75, + 76, 93, 94, 95, 96, 97, 98, 99, 22, 85, + 22, 111, 104, 111, 22, 107, 108, 109, 110, 112, + 111, 0, 1, 111, 100, 101, 17, 103, 78, 105, + 106, 10, 11, 111, 13, 13, 112, 16, 111, 107, + 19, 20, 21, 22, 516, 24, 25, 26, 27, 28, + 29, 30, 344, 32, 33, 34, 35, 36, 37, 38, + 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, + 49, 50, 68, 69, 571, 54, 55, 56, 57, 58, + 422, 60, 250, 62, 63, 64, 65, 66, 67, 279, + 375, 70, 71, 72, 73, 74, 75, 76, 94, 95, + 96, 97, 98, 99, 457, 374, 85, 503, 104, 158, + 476, 107, 108, 109, 110, -1, 357, 225, -1, 1, + -1, 100, 101, -1, 103, -1, 105, 106, 10, 11, + 12, 13, -1, 112, 16, -1, -1, 19, 20, 21, + 22, -1, 24, 25, 26, 27, 28, 29, 30, -1, + 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, + 42, 43, 44, 45, 46, 47, 48, 49, 50, 68, + 69, -1, 54, 55, 56, 57, 58, -1, 60, -1, + 62, 63, 64, 65, 66, 67, -1, -1, 70, 71, + 72, 73, 74, 75, 76, -1, -1, 96, 97, 98, + 99, -1, -1, 85, -1, 104, -1, -1, 107, 108, + 109, 110, -1, -1, -1, -1, 1, -1, 100, 101, + -1, 103, -1, 105, 106, 10, 11, 12, 13, -1, + 112, 16, -1, -1, 19, 20, 21, 22, -1, 24, + 25, 26, 27, 28, 29, 30, -1, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, - 45, -1, -1, -1, 49, 50, 51, 52, 53, -1, - 55, 56, 57, 58, 59, 60, -1, -1, 63, 64, - 65, 66, 67, 68, 69, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 79, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 95, 96, -1, 98, -1, 100, 101, 1, -1, -1, - -1, -1, 107, 108, 109, 110, 10, 11, 12, -1, - 14, 15, 16, 17, 18, -1, -1, 21, 22, 23, - 24, 25, -1, 27, 28, 29, 30, 31, 32, 33, + 45, 46, 47, 48, 49, 50, 68, 69, -1, 54, + 55, 56, 57, 58, -1, 60, -1, 62, 63, 64, + 65, 66, 67, -1, -1, 70, 71, 72, 73, 74, + 75, 76, -1, -1, -1, -1, 98, 99, -1, -1, + 85, -1, 104, -1, -1, 107, 108, 109, 110, -1, + -1, -1, -1, 1, -1, 100, 101, -1, 103, -1, + 105, 106, 10, 11, 12, 13, -1, 112, 16, -1, + -1, 19, 20, 21, 22, -1, 24, 25, 26, 27, + 28, 29, 30, -1, 32, 33, 34, 35, 36, 37, + 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, + 48, 49, 50, 68, 69, -1, 54, 55, 56, 57, + 58, -1, 60, -1, 62, 63, 64, 65, 66, 67, + -1, -1, 70, 71, 72, 73, 74, 75, 76, -1, + -1, -1, -1, -1, 99, -1, -1, 85, -1, 104, + -1, -1, 107, 108, 109, 110, -1, -1, -1, -1, + 1, -1, 100, 101, -1, 103, -1, 105, 106, 10, + 11, 12, 13, -1, 112, 16, -1, -1, 19, 20, + 21, 22, -1, 24, 25, 26, 27, 28, 29, 30, + -1, 32, 33, 34, 35, 36, 37, 38, 39, 40, + 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, + -1, -1, -1, 54, 55, 56, 57, 58, -1, 60, + -1, 62, 63, 64, 65, 66, 67, -1, -1, 70, + 71, 72, 73, 74, 75, 76, 104, -1, -1, 107, + 108, 109, 110, -1, 85, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 1, -1, 100, + 101, -1, 103, -1, 105, 106, 10, 11, 12, 13, + -1, 112, 16, -1, -1, 19, 20, 21, 22, -1, + 24, 25, 26, 27, 28, 29, 30, -1, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, - 44, 45, -1, -1, -1, 49, 50, 51, 52, 53, - -1, 55, 56, 57, 58, 59, 60, -1, -1, 63, - 64, 65, 66, 67, 68, 69, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 79, -1, -1, -1, -1, + 44, 45, 46, 47, 48, 49, 50, -1, -1, -1, + 54, 55, 56, 57, 58, -1, 60, -1, 62, 63, + 64, 65, 66, 67, -1, -1, 70, 71, 72, 73, + 74, 75, 76, -1, -1, -1, -1, -1, -1, -1, + -1, 85, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 1, -1, 100, 101, -1, 103, + -1, 105, 106, 10, 11, -1, 13, -1, 112, 16, + -1, -1, 19, 20, 21, 22, -1, 24, 25, 26, + 27, 28, 29, 30, -1, 32, 33, 34, 35, 36, + 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, + 47, 48, 49, 50, -1, -1, -1, 54, 55, 56, + 57, 58, -1, 60, -1, 62, 63, 64, 65, 66, + 67, -1, -1, 70, 71, 72, 73, 74, 75, 76, + -1, -1, 79, -1, -1, -1, -1, -1, 85, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 95, 96, -1, 98, -1, 100, 101, 1, -1, - -1, -1, -1, 107, 108, 109, 110, 10, 11, 12, - -1, 14, 15, 16, 17, 18, -1, -1, 21, 22, - 23, 24, 25, -1, 27, 28, 29, 30, 31, 32, - 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, - 43, 44, 45, -1, -1, -1, 49, 50, 51, 52, - 53, -1, 55, 56, 57, 58, 59, 60, -1, -1, - 63, 64, 65, 66, 67, 68, 69, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 79, -1, -1, -1, + -1, 1, -1, 100, 101, -1, 103, -1, 105, 106, + 10, 11, -1, 13, -1, 112, 16, -1, -1, 19, + 20, 21, 22, -1, 24, 25, 26, 27, 28, 29, + 30, -1, 32, 33, 34, 35, 36, 37, 38, 39, + 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, + 50, -1, -1, -1, 54, 55, 56, 57, 58, -1, + 60, -1, 62, 63, 64, 65, 66, 67, -1, -1, + 70, 71, 72, 73, 74, 75, 76, -1, -1, -1, + -1, -1, -1, -1, -1, 85, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 1, -1, + 100, 101, -1, 103, -1, 105, 106, 10, 11, -1, + 13, -1, 112, 16, -1, -1, 19, 20, 21, 22, + -1, 24, 25, 26, 27, 28, 29, 30, -1, 32, + 33, 34, 35, 36, 37, 38, -1, 40, 41, 42, + 43, 44, 45, 46, 47, 48, 49, 50, -1, -1, + -1, 54, 55, 56, 57, 58, -1, 60, -1, 62, + 63, 64, 65, 66, 67, -1, -1, 70, 71, 72, + 73, 74, 75, 76, -1, -1, -1, -1, -1, -1, + -1, -1, 85, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 1, -1, -1, -1, -1, 100, 101, -1, + 103, 10, 105, 106, 13, -1, -1, 16, -1, 112, + 19, 20, 21, 22, -1, 24, 25, 26, 27, 28, + 29, 30, -1, 32, 33, 34, 35, 36, 37, -1, + -1, -1, -1, -1, 43, 44, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 95, 96, -1, 98, -1, 100, 101, 1, - -1, -1, -1, -1, 107, 108, 109, 110, 10, 11, - 12, -1, 14, 15, 16, 17, 18, -1, -1, 21, - 22, 23, 24, 25, -1, 27, 28, 29, 30, 31, - 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, - 42, 43, 44, 45, -1, -1, -1, 49, 50, 51, - 52, 53, -1, 55, 56, 57, 58, 59, 60, -1, - -1, 63, 64, 65, 66, 67, 68, 69, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 79, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 95, 96, -1, 98, -1, 100, 101, - 1, -1, -1, -1, -1, 107, 108, 109, 110, 10, - 11, 12, -1, 14, 15, 16, 17, 18, -1, -1, - 21, 22, 23, 24, 25, -1, 27, 28, 29, 30, - 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, - 41, 42, 43, 44, 45, -1, -1, -1, 49, 50, - 51, 52, 53, -1, 55, 56, 57, 58, 59, 60, - -1, -1, 63, 64, 65, 66, 67, 68, 69, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 79, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 95, 96, -1, 98, -1, 100, - 101, 1, -1, -1, -1, -1, 107, 108, 109, 110, - 10, -1, 12, -1, 14, 15, 16, 17, 18, -1, - -1, 21, 22, 23, 24, 25, -1, 27, 28, 29, - 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, - 40, 41, 42, 43, 44, 45, -1, -1, -1, 49, - 50, 51, 52, 53, -1, 55, 56, 57, 58, 59, - 60, -1, -1, 63, 64, 65, 66, 67, 68, 69, - -1, -1, 72, -1, -1, -1, -1, -1, -1, 79, + -1, 60, -1, -1, 63, 64, 65, 66, 67, -1, + -1, 70, 71, 72, 73, 74, 75, 76, -1, -1, + -1, -1, -1, -1, -1, -1, 85, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 1, -1, -1, -1, + -1, 100, 101, -1, 103, 10, 105, 106, 13, -1, + -1, 16, -1, 112, 19, 20, 21, -1, -1, 24, + 25, 26, 27, 28, 29, 30, -1, 32, 33, 34, + 35, 36, 37, -1, -1, -1, -1, -1, 43, 44, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 95, 96, -1, 98, -1, - 100, 101, 1, -1, -1, -1, -1, 107, 108, 109, - 110, 10, -1, 12, -1, 14, 15, 16, 17, 18, - -1, -1, 21, 22, 23, 24, 25, -1, 27, 28, - 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, - 39, 40, 41, 42, 43, 44, 45, -1, -1, -1, - 49, 50, 51, 52, 53, -1, 55, 56, 57, 58, - 59, 60, -1, -1, 63, 64, 65, 66, 67, 68, - 69, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 79, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 95, 96, -1, 98, - -1, 100, 101, 1, -1, -1, -1, -1, 107, 108, - 109, 110, 10, -1, 12, -1, 14, 15, 16, 17, - 18, -1, -1, 21, 22, 23, 24, 25, -1, 27, - 28, 29, 30, 31, 32, 33, -1, 35, 36, 37, - 38, 39, 40, 41, 42, 43, 44, 45, -1, -1, - -1, 49, 50, 51, 52, 53, -1, 55, 56, 57, - 58, 59, 60, -1, -1, 63, 64, 65, 66, 67, - 68, 69, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 79, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 95, 96, -1, - 98, -1, 100, 101, 1, -1, -1, -1, -1, 107, - 108, 109, 110, -1, -1, 12, -1, 14, 15, 16, - 17, 18, -1, -1, 21, 22, 23, 24, 25, -1, - 27, 28, 29, 30, 31, 32, -1, -1, -1, -1, - -1, 38, 39, -1, -1, -1, -1, -1, 61, 62, - -1, -1, -1, -1, -1, -1, 53, -1, -1, 56, - 57, 58, 59, 60, -1, -1, 63, 64, 65, 66, - 67, 68, 69, 86, 87, 88, 89, 90, 91, 92, - 93, 94, 79, -1, -1, -1, 99, -1, -1, 102, - 103, 104, 105, -1, -1, -1, -1, -1, 95, 96, - -1, 98, -1, 100, 101, 1, -1, -1, -1, -1, - 107, 108, 109, 110, -1, -1, 12, -1, 14, 15, - 16, 17, 18, -1, -1, 21, 22, 23, 24, 25, - -1, 27, 28, 29, 30, 31, 32, -1, -1, -1, - -1, -1, 38, 39, -1, -1, -1, -1, 61, 62, - -1, -1, -1, -1, -1, -1, -1, 53, -1, -1, - 56, 57, 58, 59, 60, -1, -1, 63, 64, 65, - 66, 67, 68, 69, 87, 88, 89, 90, 91, 92, - 93, 94, -1, 79, -1, -1, 99, -1, -1, 102, - 103, 104, 105, -1, -1, -1, -1, -1, -1, 95, - 96, -1, 98, -1, 100, 101, -1, -1, -1, -1, - 106, 107, -1, 109, 110, 10, -1, 12, -1, 14, - 15, 16, 17, 18, -1, -1, 21, 22, 23, 24, - 25, 26, 27, 28, 29, 30, 31, 32, -1, -1, - -1, -1, -1, 38, 39, -1, -1, -1, 61, 62, - -1, -1, -1, -1, -1, -1, -1, -1, 53, -1, - -1, 56, 57, 58, 59, 60, -1, -1, 63, 64, - 65, 66, 67, 68, 69, 88, 89, 90, 91, 92, - 93, 94, -1, -1, 79, -1, 99, -1, -1, 102, - 103, 104, 105, -1, -1, -1, -1, -1, -1, -1, - 95, 96, -1, 98, -1, 100, 101, -1, -1, -1, - -1, -1, 107, -1, 109, 110, 10, -1, 12, -1, - 14, 15, 16, 17, 18, -1, -1, 21, 22, 23, - 24, 25, -1, 27, 28, 29, 30, 31, 32, -1, - -1, -1, -1, -1, 38, 39, 42, 43, 44, 45, - -1, -1, -1, 49, -1, 51, -1, -1, -1, 53, - -1, -1, 56, 57, 58, 59, 60, -1, -1, 63, - 64, 65, 66, 67, 68, 69, -1, -1, -1, -1, - 76, 77, 78, -1, -1, 79, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 60, -1, -1, 63, 64, + 65, 66, 67, 0, -1, 70, 71, 72, 73, 74, + 75, 76, -1, -1, 11, -1, 13, 14, 15, -1, + 85, -1, -1, -1, -1, 22, 23, -1, -1, -1, + -1, -1, -1, -1, -1, 100, 101, -1, 103, -1, + 105, 106, -1, -1, -1, -1, 111, 112, -1, -1, + 47, 48, 49, 50, -1, -1, -1, 54, -1, 56, + -1, -1, -1, -1, 61, -1, -1, -1, -1, -1, + -1, 68, 69, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 81, -1, 83, 84, -1, 86, + 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, + 97, 98, 99, 0, 68, 69, -1, 104, -1, -1, + 107, 108, 109, 110, 111, -1, -1, 14, 15, -1, + -1, -1, -1, -1, -1, 22, 23, 91, 92, 93, + 94, 95, 96, 97, 98, 99, -1, -1, -1, -1, + 104, -1, -1, 107, 108, 109, 110, -1, -1, -1, + 47, 48, 49, 50, -1, -1, -1, 54, -1, 56, + -1, -1, -1, -1, 61, -1, -1, -1, -1, -1, + -1, 68, 69, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 81, -1, 83, 84, -1, 86, + 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, + 97, 98, 99, -1, -1, -1, -1, 104, -1, -1, + 107, 108, 109, 110, 111, 10, 11, -1, 13, -1, + -1, 16, -1, -1, 19, 20, 21, -1, -1, 24, + 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, + 35, 36, 37, -1, -1, -1, -1, -1, 43, 44, + -1, -1, -1, -1, -1, -1, -1, -1, 68, 69, + -1, -1, -1, -1, -1, 60, -1, -1, 63, 64, + 65, 66, 67, -1, -1, 70, 71, 72, 73, 74, + 75, 76, 92, 93, 94, 95, 96, 97, 98, 99, + 85, -1, -1, -1, 104, -1, -1, 107, 108, 109, + 110, -1, -1, -1, -1, 100, 101, -1, 103, 10, + 105, 106, 13, 14, -1, 16, -1, 112, 19, 20, + 21, -1, -1, 24, 25, 26, 27, 28, 29, 30, + -1, 32, 33, 34, 35, 36, 37, -1, -1, -1, + -1, -1, 43, 44, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 60, + -1, -1, 63, 64, 65, 66, 67, -1, -1, 70, + 71, 72, 73, 74, 75, 76, -1, -1, -1, -1, + -1, -1, -1, -1, 85, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 100, + 101, -1, 103, -1, 105, 106, 10, 11, -1, 13, + -1, 112, 16, -1, -1, 19, 20, 21, -1, -1, + 24, 25, 26, 27, 28, 29, 30, -1, 32, 33, + 34, 35, 36, 37, -1, -1, -1, -1, -1, 43, + 44, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 60, -1, -1, 63, + 64, 65, 66, 67, -1, -1, 70, 71, 72, 73, + 74, 75, 76, -1, -1, -1, -1, -1, -1, -1, + -1, 85, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 100, 101, -1, 103, + 10, 105, 106, 13, -1, -1, 16, -1, 112, 19, + 20, 21, 22, -1, 24, 25, 26, 27, 28, 29, + 30, -1, 32, 33, 34, 35, 36, 37, -1, -1, + -1, -1, -1, 43, 44, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 95, 96, -1, 98, -1, 100, 101, -1, -1, - -1, -1, -1, 107, -1, 109, 110, 12, 13, 14, - 15, 16, 17, 18, -1, -1, 21, 22, 23, 24, - 25, -1, 27, 28, 29, 30, 31, 32, -1, -1, - -1, -1, -1, 38, 39, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 53, -1, - -1, 56, 57, 58, 59, 60, -1, -1, 63, 64, - 65, 66, 67, 68, 69, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 79, -1, -1, -1, -1, -1, + 60, -1, -1, 63, 64, 65, 66, 67, -1, -1, + 70, 71, 72, 73, 74, 75, 76, -1, -1, -1, + -1, -1, -1, -1, -1, 85, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 95, 96, -1, 98, -1, 100, 101, -1, -1, -1, - -1, -1, 107, -1, 109, 110, 12, -1, 14, 15, - 16, 17, 18, -1, -1, 21, 22, 23, 24, 25, - -1, 27, 28, 29, 30, 31, 32, -1, -1, -1, - -1, -1, 38, 39, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 53, -1, -1, - 56, 57, 58, 59, 60, -1, -1, 63, 64, 65, - 66, 67, 68, 69, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 79, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 95, - 96, -1, 98, -1, 100, 101, -1, -1, -1, -1, - -1, 107, 108, 109, 110, 12, -1, 14, 15, 16, - 17, 18, -1, -1, 21, 22, 23, 24, 25, -1, - 27, 28, 29, 30, 31, 32, -1, -1, -1, -1, - -1, 38, 39, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 53, -1, -1, 56, - 57, 58, 59, 60, -1, -1, 63, 64, 65, 66, - 67, 68, 69, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 79, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 95, 96, - -1, 98, -1, 100, 101, -1, -1, -1, -1, 106, - 107, -1, 109, 110, 12, -1, 14, 15, 16, 17, - 18, -1, -1, 21, 22, 23, 24, 25, -1, 27, - 28, 29, 30, 31, 32, -1, -1, -1, -1, -1, - 38, 39, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 53, -1, -1, 56, 57, - 58, 59, 60, -1, -1, 63, 64, 65, 66, 67, - 68, 69, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 79, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 95, 96, -1, - 98, -1, 100, 101, -1, -1, -1, -1, 106, 107, - -1, 109, 110, 12, -1, 14, 15, 16, 17, 18, - -1, -1, 21, 22, 23, 24, 25, -1, 27, 28, - 29, 30, 31, 32, -1, -1, -1, -1, -1, 38, - 39, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 53, -1, -1, 56, 57, 58, - 59, 60, -1, -1, 63, 64, 65, 66, 67, 68, - 69, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 79, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 95, 96, -1, 98, - -1, 100, 101, -1, -1, -1, -1, 106, 107, -1, - 109, 110, 12, -1, 14, 15, 16, 17, 18, -1, - -1, 21, 22, 23, 24, 25, -1, 27, 28, 29, - 30, 31, 32, -1, -1, -1, -1, -1, 38, 39, + 100, 101, -1, 103, 10, 105, 106, 13, -1, -1, + 16, -1, 112, 19, 20, 21, -1, -1, 24, 25, + 26, 27, 28, 29, 30, -1, 32, 33, 34, 35, + 36, 37, -1, -1, -1, -1, -1, 43, 44, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 53, -1, -1, 56, 57, 58, 59, - 60, -1, -1, 63, 64, 65, 66, 67, 68, 69, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 79, + -1, -1, -1, -1, 60, -1, -1, 63, 64, 65, + 66, 67, -1, -1, 70, 71, 72, 73, 74, 75, + 76, -1, -1, -1, -1, -1, -1, -1, -1, 85, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 95, 96, -1, 98, -1, - 100, 101, -1, -1, -1, -1, 106, 107, -1, 109, - 110, 12, -1, 14, 15, 16, 17, 18, -1, -1, - 21, 22, 23, 24, 25, -1, 27, 28, 29, 30, - 31, 32, -1, -1, -1, -1, -1, 38, 39, -1, + -1, -1, -1, -1, 100, 101, -1, 103, 10, 105, + 106, 13, -1, -1, 16, 111, 112, 19, 20, 21, + -1, -1, 24, 25, 26, 27, 28, 29, 30, -1, + 32, 33, 34, 35, 36, 37, -1, -1, -1, -1, + -1, 43, 44, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 60, -1, + -1, 63, 64, 65, 66, 67, -1, -1, 70, 71, + 72, 73, 74, 75, 76, -1, -1, -1, -1, -1, + -1, -1, -1, 85, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 100, 101, + -1, 103, 10, 105, 106, 13, -1, -1, 16, 111, + 112, 19, 20, 21, -1, -1, 24, 25, 26, 27, + 28, 29, 30, -1, 32, 33, 34, 35, 36, 37, + -1, -1, -1, -1, -1, 43, 44, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 53, -1, -1, 56, 57, 58, 59, 60, - -1, -1, 63, 64, 65, 66, 67, 68, 69, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 79, -1, + -1, -1, 60, -1, -1, 63, 64, 65, 66, 67, + -1, -1, 70, 71, 72, 73, 74, 75, 76, -1, + -1, -1, -1, -1, -1, -1, -1, 85, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 95, 96, -1, 98, -1, 100, - 101, -1, -1, -1, -1, 106, 107, -1, 109, 110, - 12, -1, 14, 15, 16, 17, 18, -1, -1, 21, - 22, 23, 24, 25, -1, 27, 28, 29, 30, 31, - 32, -1, -1, -1, -1, -1, 38, 39, -1, -1, + -1, -1, 100, 101, -1, 103, 10, 105, 106, 13, + -1, -1, 16, 111, 112, 19, 20, 21, -1, -1, + 24, 25, 26, 27, 28, 29, 30, -1, 32, 33, + 34, 35, 36, 37, -1, -1, -1, -1, -1, 43, + 44, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 60, -1, -1, 63, + 64, 65, 66, 67, -1, -1, 70, 71, 72, 73, + 74, 75, 76, -1, -1, -1, -1, -1, -1, -1, + -1, 85, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 100, 101, -1, 103, + 10, 105, 106, 13, -1, -1, 16, 111, 112, 19, + 20, 21, -1, -1, 24, 25, 26, 27, 28, 29, + 30, -1, 32, 33, 34, 35, 36, 37, -1, -1, + -1, -1, -1, 43, 44, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 53, -1, -1, 56, 57, 58, 59, 60, -1, - -1, 63, 64, 65, 66, 67, 68, 69, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 79, -1, -1, + 60, -1, -1, 63, 64, 65, 66, 67, -1, -1, + 70, 71, 72, 73, 74, 75, 76, -1, -1, -1, + -1, -1, -1, -1, -1, 85, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, 95, 96, -1, 98, -1, 100, 101, - -1, -1, -1, -1, 106, 107, -1, 109, 110, 12, - -1, 14, 15, 16, 17, 18, -1, -1, 21, 22, - 23, 24, 25, -1, 27, 28, 29, 30, 31, 32, - -1, -1, -1, -1, -1, 38, 39, -1, -1, -1, + 100, 101, -1, 103, 10, 105, 106, 13, -1, -1, + 16, 111, 112, 19, 20, 21, -1, -1, 24, 25, + 26, 27, 28, 29, 30, -1, 32, 33, 34, 35, + 36, 37, -1, -1, -1, -1, -1, 43, 44, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - 53, -1, -1, 56, 57, 58, 59, 60, -1, -1, - 63, 64, 65, 66, 67, 68, 69, -1, -1, -1, - -1, -1, -1, -1, -1, -1, 79, -1, -1, -1, + -1, -1, -1, -1, 60, -1, -1, 63, 64, 65, + 66, 67, -1, -1, 70, 71, 72, 73, 74, 75, + 76, -1, -1, -1, -1, -1, -1, -1, -1, 85, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 95, 96, -1, 98, -1, 100, 101, -1, - -1, -1, -1, 106, 107, -1, 109, 110, 12, -1, - 14, 15, 16, 17, 18, -1, -1, 21, 22, 23, - 24, 25, -1, 27, 28, 29, 30, 31, 32, -1, - -1, -1, -1, -1, 38, 39, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 53, - -1, -1, 56, 57, 58, 59, 60, -1, -1, 63, - 64, 65, 66, 67, 68, 69, -1, -1, -1, -1, - -1, -1, -1, -1, -1, 79, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, 95, 96, -1, 98, -1, 100, 101, -1, -1, - -1, -1, -1, 107, -1, 109, 110, 12, -1, 14, - 15, 16, 17, 18, -1, -1, 21, 22, 23, 24, - 25, -1, 27, 28, 29, 30, 31, 32, -1, -1, - -1, -1, -1, 38, 39, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, 53, -1, - -1, 56, 57, 58, 59, 60, -1, -1, 63, 64, - 65, 66, 67, 68, 69, -1, -1, -1, -1, -1, - -1, -1, -1, -1, 79, -1, -1, -1, -1, 54, - -1, -1, -1, -1, -1, -1, 61, 62, -1, -1, - 95, 96, -1, 98, -1, 100, 101, -1, -1, -1, - -1, -1, 107, -1, 109, 110, 81, 82, 83, 84, - 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, - -1, -1, -1, -1, 99, 54, -1, 102, 103, 104, - 105, -1, 61, 62, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 100, 101, -1, 103, 10, 105, + 106, 13, -1, -1, 16, 111, 112, 19, 20, 21, + -1, -1, 24, 25, 26, 27, 28, 29, 30, -1, + 32, 33, 34, 35, 36, 37, -1, -1, -1, -1, + -1, 43, 44, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 60, -1, + -1, 63, 64, 65, 66, 67, -1, -1, 70, 71, + 72, 73, 74, 75, 76, -1, -1, -1, -1, -1, + -1, -1, -1, 85, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 100, 101, + -1, 103, 10, 105, 106, 13, -1, -1, 16, 111, + 112, 19, 20, 21, -1, -1, 24, 25, 26, 27, + 28, 29, 30, -1, 32, 33, 34, 35, 36, 37, + -1, -1, -1, -1, -1, 43, 44, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, 81, 82, -1, 84, 85, 86, 87, 88, - 89, 90, 91, 92, 93, 94, -1, -1, -1, -1, - 99, 54, -1, 102, 103, 104, 105, -1, 61, 62, + -1, -1, 60, -1, -1, 63, 64, 65, 66, 67, + -1, -1, 70, 71, 72, 73, 74, 75, 76, -1, + -1, -1, -1, -1, -1, -1, -1, 85, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, 82, - -1, 84, 85, 86, 87, 88, 89, 90, 91, 92, - 93, 94, -1, -1, -1, -1, 99, 54, -1, 102, - 103, 104, 105, -1, 61, 62, -1, -1, -1, -1, + -1, -1, 100, 101, -1, 103, 10, 105, 106, 13, + -1, -1, 16, -1, 112, 19, 20, 21, -1, -1, + 24, 25, 26, 27, 28, 29, 30, -1, 32, 33, + 34, 35, 36, 37, -1, -1, -1, -1, -1, 43, + 44, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 60, -1, -1, 63, + 64, 65, 66, 67, -1, -1, 70, 71, 72, 73, + 74, 75, 76, -1, -1, -1, -1, -1, -1, -1, + -1, 85, -1, -1, 61, -1, -1, -1, -1, -1, + -1, 68, 69, -1, -1, -1, 100, 101, -1, 103, + -1, 105, 106, -1, -1, -1, -1, -1, 112, 86, + 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, + 97, 98, 99, -1, -1, -1, -1, 104, 61, -1, + 107, 108, 109, 110, -1, 68, 69, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, - -1, -1, -1, -1, -1, -1, -1, 84, 85, 86, - 87, 88, 89, 90, 91, 92, 93, 94, -1, -1, - -1, -1, 99, -1, -1, 102, 103, 104, 105 + -1, -1, -1, 86, 87, -1, 89, 90, 91, 92, + 93, 94, 95, 96, 97, 98, 99, -1, -1, -1, + -1, 104, -1, -1, 107, 108, 109, 110 }; /* YYSTOS[STATE-NUM] -- The (internal number of the) accessing symbol of state STATE-NUM. */ static const yytype_uint8 yystos[] = { - 0, 3, 4, 5, 6, 7, 8, 9, 113, 114, - 115, 116, 117, 118, 119, 120, 0, 123, 12, 14, - 15, 16, 17, 18, 21, 22, 23, 24, 25, 27, - 28, 29, 30, 31, 32, 38, 39, 53, 56, 57, - 58, 59, 60, 63, 64, 65, 66, 67, 68, 69, - 79, 95, 96, 98, 100, 101, 107, 109, 110, 173, - 174, 175, 178, 179, 180, 181, 182, 183, 184, 185, - 186, 187, 189, 192, 198, 199, 200, 201, 202, 203, - 204, 205, 206, 10, 121, 1, 33, 35, 36, 37, - 40, 41, 42, 43, 44, 45, 49, 50, 51, 52, - 55, 108, 121, 130, 140, 173, 34, 128, 129, 130, - 126, 167, 168, 126, 13, 173, 187, 187, 21, 26, - 121, 199, 207, 207, 207, 207, 207, 188, 12, 107, - 187, 151, 151, 151, 187, 107, 107, 73, 107, 121, - 187, 21, 174, 191, 199, 207, 207, 121, 187, 108, - 173, 21, 26, 153, 187, 98, 107, 190, 199, 200, - 201, 187, 174, 187, 187, 187, 187, 187, 106, 173, - 207, 207, 76, 77, 78, 80, 10, 12, 107, 91, - 92, 91, 89, 90, 89, 54, 61, 62, 81, 82, - 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, - 94, 99, 102, 103, 104, 105, 107, 10, 12, 10, - 12, 10, 12, 10, 123, 152, 153, 153, 21, 150, - 107, 107, 107, 107, 68, 98, 107, 197, 199, 107, - 107, 121, 108, 48, 142, 108, 42, 43, 44, 45, - 49, 51, 129, 130, 128, 16, 17, 109, 158, 159, - 161, 162, 163, 164, 13, 191, 107, 73, 173, 106, - 121, 24, 154, 70, 155, 106, 106, 173, 192, 192, - 207, 174, 11, 108, 191, 107, 187, 190, 199, 200, - 201, 106, 173, 70, 156, 12, 106, 173, 173, 173, - 187, 173, 173, 106, 173, 187, 187, 187, 187, 187, - 187, 187, 187, 187, 187, 187, 187, 187, 187, 187, - 187, 187, 187, 187, 10, 12, 16, 17, 18, 22, - 63, 107, 109, 110, 177, 199, 106, 173, 173, 173, - 173, 173, 173, 173, 173, 126, 21, 149, 150, 150, - 21, 133, 123, 123, 123, 123, 98, 123, 68, 195, - 196, 198, 199, 200, 201, 123, 123, 107, 123, 123, - 121, 173, 146, 173, 173, 173, 173, 173, 26, 157, - 157, 80, 192, 174, 13, 176, 155, 24, 123, 172, - 106, 74, 106, 173, 11, 106, 173, 156, 106, 24, - 173, 12, 108, 13, 106, 83, 173, 173, 110, 110, - 110, 110, 106, 173, 110, 110, 107, 106, 108, 13, - 108, 13, 108, 13, 108, 11, 19, 122, 131, 132, - 10, 108, 21, 145, 173, 146, 147, 173, 147, 194, - 199, 107, 140, 144, 147, 148, 173, 195, 123, 147, - 147, 81, 160, 160, 162, 106, 111, 193, 191, 123, - 170, 107, 165, 166, 106, 106, 13, 173, 11, 187, - 108, 13, 106, 192, 11, 11, 11, 11, 123, 154, - 155, 123, 21, 106, 106, 106, 106, 107, 123, 106, - 108, 136, 147, 106, 106, 187, 173, 74, 10, 167, - 10, 13, 11, 106, 108, 155, 108, 171, 172, 137, - 191, 143, 143, 10, 124, 124, 147, 147, 124, 134, - 107, 106, 124, 124, 126, 106, 126, 72, 108, 169, - 170, 126, 108, 124, 124, 125, 46, 47, 141, 141, - 106, 106, 142, 145, 147, 124, 11, 11, 127, 11, - 142, 142, 126, 124, 107, 124, 124, 108, 106, 142, - 24, 108, 138, 11, 147, 142, 142, 135, 124, 71, - 139, 20, 106, 143, 142, 126, 124, 148, 72, 141, - 106, 124 + 0, 3, 4, 5, 6, 7, 8, 9, 114, 115, + 116, 117, 118, 119, 120, 121, 0, 124, 10, 13, + 16, 19, 20, 21, 24, 25, 26, 27, 28, 29, + 30, 32, 33, 34, 35, 36, 37, 43, 44, 60, + 63, 64, 65, 66, 67, 70, 71, 72, 73, 74, + 75, 76, 85, 100, 101, 103, 105, 106, 112, 177, + 178, 179, 182, 183, 184, 185, 186, 187, 188, 189, + 190, 191, 193, 196, 202, 203, 204, 205, 206, 207, + 208, 209, 210, 11, 122, 1, 22, 38, 40, 41, + 42, 45, 46, 47, 48, 49, 50, 54, 55, 56, + 57, 58, 62, 122, 131, 144, 177, 39, 129, 130, + 131, 127, 171, 172, 127, 26, 31, 122, 203, 211, + 14, 177, 211, 191, 211, 191, 211, 211, 211, 211, + 192, 13, 112, 191, 155, 155, 155, 191, 112, 112, + 80, 112, 122, 191, 26, 178, 195, 203, 211, 211, + 122, 191, 22, 177, 26, 31, 157, 191, 103, 112, + 194, 203, 204, 205, 191, 178, 191, 191, 191, 191, + 191, 111, 177, 83, 84, 15, 11, 13, 112, 96, + 97, 96, 94, 95, 94, 61, 68, 69, 86, 87, + 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, + 99, 104, 107, 108, 109, 110, 112, 11, 13, 11, + 13, 11, 13, 11, 124, 156, 157, 157, 26, 154, + 112, 112, 112, 112, 75, 103, 112, 201, 203, 112, + 112, 122, 11, 125, 22, 53, 146, 22, 47, 48, + 49, 50, 54, 56, 130, 131, 129, 16, 20, 24, + 162, 163, 165, 166, 167, 168, 14, 195, 112, 80, + 177, 111, 122, 29, 158, 77, 159, 111, 111, 177, + 196, 196, 211, 178, 12, 22, 195, 112, 191, 194, + 203, 204, 205, 111, 177, 77, 160, 13, 111, 177, + 177, 191, 177, 177, 111, 177, 191, 191, 191, 191, + 191, 191, 191, 191, 191, 191, 191, 191, 191, 191, + 191, 191, 191, 191, 191, 10, 11, 13, 16, 20, + 24, 25, 27, 70, 112, 181, 203, 111, 177, 177, + 177, 177, 177, 177, 177, 177, 127, 26, 153, 154, + 154, 26, 134, 124, 124, 124, 124, 103, 124, 75, + 199, 200, 202, 203, 204, 205, 124, 124, 112, 124, + 124, 126, 59, 122, 143, 177, 150, 177, 143, 143, + 143, 143, 31, 161, 161, 15, 196, 178, 14, 180, + 159, 29, 124, 176, 111, 81, 111, 177, 12, 111, + 177, 160, 111, 29, 177, 13, 22, 14, 111, 88, + 25, 177, 177, 25, 25, 25, 25, 25, 111, 177, + 112, 111, 22, 14, 22, 14, 22, 14, 22, 12, + 18, 123, 132, 133, 11, 22, 26, 149, 177, 150, + 151, 177, 151, 198, 203, 112, 144, 148, 151, 152, + 177, 199, 124, 151, 151, 127, 112, 86, 164, 164, + 166, 111, 23, 197, 195, 124, 174, 112, 169, 170, + 111, 111, 14, 177, 12, 191, 22, 14, 111, 196, + 12, 12, 12, 12, 124, 158, 159, 124, 26, 111, + 111, 111, 111, 112, 124, 111, 22, 137, 151, 111, + 111, 12, 138, 191, 177, 81, 11, 171, 11, 14, + 12, 111, 22, 159, 22, 175, 176, 140, 195, 147, + 147, 125, 125, 151, 151, 125, 135, 112, 111, 125, + 125, 124, 127, 111, 127, 79, 22, 173, 174, 127, + 22, 125, 125, 51, 52, 145, 145, 111, 111, 146, + 149, 151, 125, 203, 12, 12, 128, 12, 146, 146, + 125, 112, 125, 125, 22, 111, 146, 139, 22, 29, + 141, 151, 146, 146, 136, 125, 111, 17, 78, 142, + 111, 147, 146, 125, 127, 125, 152, 79, 145, 111, + 125 }; /* YYR1[YYN] -- Symbol number of symbol that rule YYN derives. */ static const yytype_uint8 yyr1[] = { - 0, 112, 114, 113, 115, 113, 116, 113, 117, 113, - 118, 113, 119, 113, 120, 113, 121, 122, 123, 124, - 125, 126, 126, 127, 127, 128, 128, 129, 129, 130, - 130, 131, 130, 132, 130, 130, 133, 130, 130, 130, - 130, 130, 130, 130, 130, 134, 135, 130, 130, 130, - 136, 130, 130, 130, 130, 137, 130, 130, 130, 130, - 138, 139, 139, 140, 140, 140, 140, 140, 140, 140, - 140, 141, 141, 141, 142, 142, 143, 144, 144, 145, - 145, 146, 147, 148, 149, 149, 150, 151, 152, 153, - 153, 154, 154, 155, 155, 155, 156, 156, 157, 157, - 158, 158, 159, 160, 160, 160, 161, 162, 162, 163, - 163, 163, 164, 164, 165, 165, 166, 168, 167, 169, - 169, 170, 171, 171, 172, 173, 173, 173, 173, 174, - 174, 174, 175, 175, 175, 175, 175, 175, 175, 175, - 175, 176, 175, 177, 177, 178, 178, 178, 178, 178, - 178, 178, 178, 178, 178, 178, 178, 178, 178, 179, - 179, 179, 179, 179, 179, 179, 179, 179, 179, 179, - 179, 179, 179, 180, 180, 180, 180, 181, 181, 182, - 182, 182, 182, 183, 183, 184, 184, 184, 184, 184, - 184, 184, 184, 184, 185, 185, 185, 185, 185, 185, - 186, 186, 187, 187, 187, 187, 187, 187, 187, 187, - 187, 187, 187, 187, 187, 187, 187, 187, 187, 187, - 187, 187, 187, 187, 187, 187, 187, 187, 187, 187, - 187, 187, 187, 187, 187, 187, 187, 187, 187, 187, - 187, 187, 187, 187, 187, 187, 187, 187, 187, 187, - 187, 188, 187, 187, 187, 187, 189, 189, 189, 190, - 190, 190, 190, 190, 191, 191, 192, 192, 193, 193, - 194, 195, 195, 195, 196, 196, 197, 197, 198, 199, - 200, 201, 202, 202, 203, 204, 204, 205, 205, 206, - 206, 207, 207, 207, 207 + 0, 113, 115, 114, 116, 114, 117, 114, 118, 114, + 119, 114, 120, 114, 121, 114, 122, 123, 124, 125, + 126, 127, 127, 128, 128, 129, 129, 130, 130, 131, + 131, 132, 131, 133, 131, 131, 134, 131, 131, 131, + 131, 131, 131, 131, 131, 135, 136, 131, 131, 131, + 137, 131, 131, 131, 138, 139, 131, 131, 140, 131, + 131, 131, 131, 141, 142, 142, 143, 144, 144, 144, + 144, 144, 144, 144, 144, 145, 145, 145, 146, 146, + 147, 148, 148, 149, 149, 150, 151, 152, 153, 153, + 154, 155, 156, 157, 157, 158, 158, 159, 159, 159, + 160, 160, 161, 161, 162, 162, 163, 164, 164, 164, + 165, 166, 166, 167, 167, 167, 168, 168, 169, 169, + 170, 172, 171, 173, 173, 174, 175, 175, 176, 177, + 177, 177, 178, 178, 178, 179, 179, 179, 179, 179, + 179, 179, 179, 179, 180, 179, 181, 181, 182, 182, + 182, 182, 182, 182, 182, 182, 182, 182, 182, 182, + 182, 182, 183, 183, 183, 183, 183, 183, 183, 183, + 183, 183, 183, 183, 183, 183, 184, 184, 184, 184, + 185, 185, 186, 186, 186, 186, 187, 187, 188, 188, + 188, 188, 188, 188, 188, 188, 188, 189, 189, 189, + 189, 189, 189, 190, 190, 191, 191, 191, 191, 191, + 191, 191, 191, 191, 191, 191, 191, 191, 191, 191, + 191, 191, 191, 191, 191, 191, 191, 191, 191, 191, + 191, 191, 191, 191, 191, 191, 191, 191, 191, 191, + 191, 191, 191, 191, 191, 191, 191, 191, 191, 191, + 191, 191, 191, 191, 192, 191, 191, 191, 191, 193, + 193, 193, 194, 194, 194, 194, 194, 195, 195, 196, + 196, 197, 197, 198, 199, 199, 199, 200, 200, 201, + 201, 202, 203, 204, 205, 206, 206, 207, 208, 208, + 209, 209, 210, 210, 211, 211, 211, 211 }; /* YYR2[YYN] -- Number of symbols on the right hand side of rule YYN. */ @@ -1120,31 +1095,31 @@ static const yytype_uint8 yyr2[] = 0, 0, 2, 0, 2, 1, 1, 2, 2, 1, 4, 0, 7, 0, 6, 4, 0, 7, 7, 7, 6, 6, 2, 8, 8, 0, 0, 13, 9, 8, - 0, 10, 9, 7, 2, 0, 8, 2, 2, 1, - 2, 0, 3, 1, 1, 3, 3, 3, 3, 3, - 3, 0, 2, 6, 0, 2, 0, 0, 1, 0, - 1, 1, 1, 1, 1, 0, 0, 0, 0, 1, - 1, 0, 1, 0, 2, 1, 2, 1, 0, 1, - 1, 1, 3, 0, 1, 2, 3, 1, 1, 2, - 3, 1, 0, 1, 0, 1, 3, 0, 2, 1, - 1, 4, 1, 1, 5, 3, 3, 3, 1, 2, - 3, 1, 3, 5, 6, 3, 3, 5, 2, 4, - 4, 0, 5, 1, 1, 5, 4, 5, 4, 5, - 6, 5, 4, 5, 4, 3, 6, 4, 5, 3, - 3, 3, 3, 3, 1, 1, 3, 3, 3, 3, - 3, 3, 3, 1, 3, 2, 2, 3, 3, 1, - 3, 2, 2, 3, 3, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 3, 2, 4, 3, 5, 4, - 2, 2, 1, 1, 1, 1, 5, 2, 3, 1, - 2, 3, 1, 2, 1, 1, 1, 1, 1, 1, - 4, 4, 5, 5, 1, 1, 3, 4, 3, 4, - 4, 4, 4, 4, 1, 2, 2, 1, 2, 2, - 1, 2, 1, 2, 1, 3, 1, 3, 1, 3, - 4, 0, 6, 1, 1, 1, 3, 2, 4, 3, - 2, 1, 1, 1, 0, 1, 0, 1, 0, 2, - 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, - 2, 2, 2, 4, 2, 1, 3, 1, 3, 1, - 3, 1, 1, 1, 1 + 0, 10, 9, 7, 0, 0, 10, 2, 0, 8, + 2, 2, 1, 2, 0, 3, 1, 1, 1, 3, + 3, 3, 3, 3, 3, 0, 2, 6, 0, 2, + 0, 0, 1, 0, 1, 1, 1, 1, 1, 0, + 0, 0, 0, 1, 1, 0, 1, 0, 2, 1, + 2, 1, 0, 1, 1, 1, 3, 0, 1, 2, + 3, 1, 1, 2, 3, 1, 0, 1, 0, 1, + 3, 0, 2, 1, 1, 4, 1, 1, 5, 3, + 3, 1, 2, 3, 1, 3, 5, 6, 3, 3, + 5, 2, 4, 4, 0, 5, 1, 1, 5, 4, + 5, 4, 5, 6, 5, 4, 5, 4, 3, 6, + 4, 5, 3, 3, 3, 3, 3, 1, 1, 3, + 3, 3, 3, 3, 3, 3, 1, 3, 2, 2, + 3, 3, 1, 3, 2, 2, 3, 3, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 3, 2, 4, + 3, 5, 4, 2, 2, 1, 1, 1, 1, 5, + 2, 3, 1, 2, 3, 1, 2, 1, 1, 1, + 1, 1, 1, 4, 4, 5, 5, 1, 1, 3, + 4, 3, 4, 4, 4, 4, 4, 1, 2, 2, + 1, 2, 2, 1, 2, 1, 2, 1, 3, 1, + 3, 1, 3, 4, 0, 6, 1, 1, 1, 3, + 2, 4, 3, 2, 1, 1, 1, 0, 1, 0, + 1, 0, 2, 1, 1, 1, 1, 1, 1, 2, + 2, 2, 2, 2, 2, 2, 4, 2, 1, 3, + 1, 3, 1, 3, 1, 1, 1, 1 }; typedef enum { @@ -1155,40 +1130,44 @@ typedef enum { static const toketypes yy_type_tab[] = { toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, - toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, - toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, - toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, + toketype_ival, toketype_ival, toketype_ival, toketype_ival, + toketype_ival, toketype_ival, toketype_ival, + toketype_ival, toketype_ival, toketype_ival, + toketype_ival, toketype_ival, toketype_ival, toketype_ival, + toketype_ival, toketype_ival, toketype_ival, toketype_ival, + toketype_ival, toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, - toketype_opval, toketype_opval, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, - toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, + toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, - toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, - toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, + toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, + toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, + toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, + toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, - toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, + toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_opval, toketype_opval, toketype_ival, toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_ival, toketype_ival, toketype_ival, toketype_ival, - toketype_ival, toketype_ival, toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, - toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, - toketype_ival, toketype_ival, toketype_ival, toketype_opval, toketype_opval, - toketype_opval, toketype_opval, toketype_opval, toketype_ival, - toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, - toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_ival, - toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, - toketype_opval, toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval, - toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, + toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_opval, toketype_opval, + toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_ival, toketype_opval, toketype_opval, + toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_ival, toketype_ival, + toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval, + toketype_opval, toketype_ival, toketype_opval, toketype_opval, + toketype_opval, toketype_opval, toketype_opval, toketype_opval, + toketype_opval, toketype_opval, toketype_opval, toketype_ival, toketype_opval, + toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, + toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, + toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, + toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_ival, toketype_opval, toketype_opval, - toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, - toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, - toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval + toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval }; /* Generated from: - * f83d884147747f2d8f5a62eebc4ccd07d71b6b34e5ba1a8d7559526ad864dc97 perly.y - * 01ce33b49f9f04b8d3112b7f042cde113a7d29763a846e870f9766072a5bc614 regen_perly.pl + * 672539c523be1568df09c599b38a828c80473c60e1fddd63764d66f74e4e7b11 perly.y + * acf1cbfd2545faeaaa58b1cf0cf9d7f98b5be0752eb7a54528ef904a9e2e1ca7 regen_perly.pl * ex: set ro: */ diff --git a/perly.y b/perly.y index 843a3b18bb3b..42156e3a42ec 100644 --- a/perly.y +++ b/perly.y @@ -45,7 +45,22 @@ %token GRAMPROG GRAMEXPR GRAMBLOCK GRAMBARESTMT GRAMFULLSTMT GRAMSTMTSEQ GRAMSUBSIGNATURE -%token '{' '}' '[' ']' '-' '+' '@' '%' '&' '=' '.' +%token PERLY_AMPERSAND +%token PERLY_BRACE_OPEN +%token PERLY_BRACE_CLOSE +%token PERLY_BRACKET_OPEN +%token PERLY_BRACKET_CLOSE +%token PERLY_COMMA +%token PERLY_DOLLAR +%token PERLY_DOT +%token PERLY_EQUAL_SIGN +%token PERLY_MINUS +%token PERLY_PERCENT_SIGN +%token PERLY_PLUS +%token PERLY_SEMICOLON +%token PERLY_SLASH +%token PERLY_SNAIL +%token PERLY_STAR %token BAREWORD METHOD FUNCMETH THING PMFUNC PRIVATEREF QWLIST %token FUNC0OP FUNC0SUB UNIOPSUB LSTOPSUB @@ -54,6 +69,7 @@ %token FORMAT SUB SIGSUB ANONSUB ANON_SIGSUB PACKAGE USE %token WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE FOR %token GIVEN WHEN DEFAULT +%token TRY CATCH %token LOOPEX DOTDOT YADAYADA %token FUNC0 FUNC1 FUNC UNIOP LSTOP %token MULOP ADDOP @@ -69,6 +85,7 @@ %type stmtseq fullstmt labfullstmt barestmt block mblock else %type expr term subscripted scalar ary hsh arylen star amper sideff +%type condition %type sliceme kvslice gelem %type listexpr nexpr texpr iexpr mexpr mnexpr %type optlistexpr optexpr optrepl indirob listop method @@ -86,13 +103,13 @@ %nonassoc PREC_LOW %nonassoc LOOPEX -%left OROP DOROP +%left OROP %left ANDOP %right NOTOP %nonassoc LSTOP LSTOPSUB -%left ',' +%left PERLY_COMMA %right ASSIGNOP -%right '?' ':' +%right PERLY_QUESTION_MARK PERLY_COLON %nonassoc DOTDOT %left OROR DORDOR %left ANDAND @@ -106,13 +123,13 @@ %left ADDOP %left MULOP %left MATCHOP -%right '!' '~' UMINUS REFGEN +%right PERLY_EXCLAMATION_MARK PERLY_TILDE UMINUS REFGEN %right POWOP %nonassoc PREINC PREDEC POSTINC POSTDEC POSTJOIN %left ARROW -%nonassoc ')' -%left '(' -%left '[' '{' +%nonassoc PERLY_PAREN_CLOSE +%left PERLY_PAREN_OPEN +%left PERLY_BRACKET_OPEN PERLY_BRACE_OPEN %% /* RULES */ @@ -124,7 +141,7 @@ grammar : GRAMPROG } remember stmtseq { - newPROG(block_end($3,$4)); + newPROG(block_end($remember,$stmtseq)); PL_compiling.cop_seq = 0; $$ = 0; } @@ -135,7 +152,7 @@ grammar : GRAMPROG } optexpr { - PL_eval_root = $3; + PL_eval_root = $optexpr; $$ = 0; } | GRAMBLOCK @@ -146,7 +163,7 @@ grammar : GRAMPROG block { PL_pad_reset_pending = TRUE; - PL_eval_root = $3; + PL_eval_root = $block; $$ = 0; yyunlex(); parser->yychar = yytoken = YYEOF; @@ -159,7 +176,7 @@ grammar : GRAMPROG barestmt { PL_pad_reset_pending = TRUE; - PL_eval_root = $3; + PL_eval_root = $barestmt; $$ = 0; yyunlex(); parser->yychar = yytoken = YYEOF; @@ -172,7 +189,7 @@ grammar : GRAMPROG fullstmt { PL_pad_reset_pending = TRUE; - PL_eval_root = $3; + PL_eval_root = $fullstmt; $$ = 0; yyunlex(); parser->yychar = yytoken = YYEOF; @@ -184,7 +201,7 @@ grammar : GRAMPROG } stmtseq { - PL_eval_root = $3; + PL_eval_root = $stmtseq; $$ = 0; } | GRAMSUBSIGNATURE @@ -194,62 +211,62 @@ grammar : GRAMPROG } subsigguts { - PL_eval_root = $3; + PL_eval_root = $subsigguts; $$ = 0; } ; /* An ordinary block */ -block : '{' remember stmtseq '}' - { if (parser->copline > (line_t)$1) - parser->copline = (line_t)$1; - $$ = block_end($2, $3); +block : PERLY_BRACE_OPEN remember stmtseq PERLY_BRACE_CLOSE + { if (parser->copline > (line_t)$PERLY_BRACE_OPEN) + parser->copline = (line_t)$PERLY_BRACE_OPEN; + $$ = block_end($remember, $stmtseq); } ; /* format body */ -formblock: '=' remember ';' FORMRBRACK formstmtseq ';' '.' - { if (parser->copline > (line_t)$1) - parser->copline = (line_t)$1; - $$ = block_end($2, $5); +formblock: PERLY_EQUAL_SIGN remember PERLY_SEMICOLON FORMRBRACK formstmtseq PERLY_SEMICOLON PERLY_DOT + { if (parser->copline > (line_t)$PERLY_EQUAL_SIGN) + parser->copline = (line_t)$PERLY_EQUAL_SIGN; + $$ = block_end($remember, $formstmtseq); } ; -remember: /* NULL */ /* start a full lexical scope */ +remember: %empty /* start a full lexical scope */ { $$ = block_start(TRUE); parser->parsed_sub = 0; } ; -mblock : '{' mremember stmtseq '}' - { if (parser->copline > (line_t)$1) - parser->copline = (line_t)$1; - $$ = block_end($2, $3); +mblock : PERLY_BRACE_OPEN mremember stmtseq PERLY_BRACE_CLOSE + { if (parser->copline > (line_t)$PERLY_BRACE_OPEN) + parser->copline = (line_t)$PERLY_BRACE_OPEN; + $$ = block_end($mremember, $stmtseq); } ; -mremember: /* NULL */ /* start a partial lexical scope */ +mremember: %empty /* start a partial lexical scope */ { $$ = block_start(FALSE); parser->parsed_sub = 0; } ; /* A sequence of statements in the program */ -stmtseq : /* NULL */ +stmtseq : %empty { $$ = NULL; } - | stmtseq fullstmt - { $$ = op_append_list(OP_LINESEQ, $1, $2); + | stmtseq[list] fullstmt + { $$ = op_append_list(OP_LINESEQ, $list, $fullstmt); PL_pad_reset_pending = TRUE; - if ($1 && $2) + if ($list && $fullstmt) PL_hints |= HINT_BLOCK_SCOPE; } ; /* A sequence of format lines */ -formstmtseq: /* NULL */ +formstmtseq: %empty { $$ = NULL; } - | formstmtseq formline - { $$ = op_append_list(OP_LINESEQ, $1, $2); + | formstmtseq[list] formline + { $$ = op_append_list(OP_LINESEQ, $list, $formline); PL_pad_reset_pending = TRUE; - if ($1 && $2) + if ($list && $formline) PL_hints |= HINT_BLOCK_SCOPE; } ; @@ -257,35 +274,35 @@ formstmtseq: /* NULL */ /* A statement in the program, including optional labels */ fullstmt: barestmt { - $$ = $1 ? newSTATEOP(0, NULL, $1) : NULL; + $$ = $barestmt ? newSTATEOP(0, NULL, $barestmt) : NULL; } | labfullstmt - { $$ = $1; } + { $$ = $labfullstmt; } ; labfullstmt: LABEL barestmt { - SV *label = cSVOPx_sv($1); + SV *label = cSVOPx_sv($LABEL); $$ = newSTATEOP(SvFLAGS(label) & SVf_UTF8, - savepv(SvPVX_const(label)), $2); - op_free($1); + savepv(SvPVX_const(label)), $barestmt); + op_free($LABEL); } - | LABEL labfullstmt + | LABEL labfullstmt[list] { - SV *label = cSVOPx_sv($1); + SV *label = cSVOPx_sv($LABEL); $$ = newSTATEOP(SvFLAGS(label) & SVf_UTF8, - savepv(SvPVX_const(label)), $2); - op_free($1); + savepv(SvPVX_const(label)), $list); + op_free($LABEL); } ; /* A bare statement, lacking label and other aspects of state op */ barestmt: PLUGSTMT - { $$ = $1; } + { $$ = $PLUGSTMT; } | FORMAT startformsub formname formblock { CV *fmtcv = PL_compcv; - newFORM($2, $3, $4); + newFORM($startformsub, $formname, $formblock); $$ = NULL; if (CvOUTSIDE(fmtcv) && !CvEVAL(CvOUTSIDE(fmtcv))) { pad_add_weakref(fmtcv); @@ -296,16 +313,16 @@ barestmt: PLUGSTMT /* sub declaration or definition not within scope of 'use feature "signatures"'*/ { - init_named_cv(PL_compcv, $2); + init_named_cv(PL_compcv, $subname); parser->in_my = 0; parser->in_my_stash = NULL; } proto subattrlist optsubbody { SvREFCNT_inc_simple_void(PL_compcv); - $2->op_type == OP_CONST - ? newATTRSUB($3, $2, $5, $6, $7) - : newMYSUB($3, $2, $5, $6, $7) + $subname->op_type == OP_CONST + ? newATTRSUB($startsub, $subname, $proto, $subattrlist, $optsubbody) + : newMYSUB($startsub, $subname, $proto, $subattrlist, $optsubbody) ; $$ = NULL; intro_my(); @@ -317,82 +334,82 @@ barestmt: PLUGSTMT * allowed in a declaration) */ { - init_named_cv(PL_compcv, $2); + init_named_cv(PL_compcv, $subname); parser->in_my = 0; parser->in_my_stash = NULL; } subattrlist optsigsubbody { SvREFCNT_inc_simple_void(PL_compcv); - $2->op_type == OP_CONST - ? newATTRSUB($3, $2, NULL, $5, $6) - : newMYSUB( $3, $2, NULL, $5, $6) + $subname->op_type == OP_CONST + ? newATTRSUB($startsub, $subname, NULL, $subattrlist, $optsigsubbody) + : newMYSUB( $startsub, $subname, NULL, $subattrlist, $optsigsubbody) ; $$ = NULL; intro_my(); parser->parsed_sub = 1; } - | PACKAGE BAREWORD BAREWORD ';' + | PACKAGE BAREWORD[version] BAREWORD[package] PERLY_SEMICOLON { - package($3); - if ($2) - package_version($2); + package($package); + if ($version) + package_version($version); $$ = NULL; } | USE startsub { CvSPECIAL_on(PL_compcv); /* It's a BEGIN {} */ } - BAREWORD BAREWORD optlistexpr ';' + BAREWORD[version] BAREWORD[module] optlistexpr PERLY_SEMICOLON { SvREFCNT_inc_simple_void(PL_compcv); - utilize($1, $2, $4, $5, $6); + utilize($USE, $startsub, $version, $module, $optlistexpr); parser->parsed_sub = 1; $$ = NULL; } - | IF '(' remember mexpr ')' mblock else + | IF PERLY_PAREN_OPEN remember mexpr PERLY_PAREN_CLOSE mblock else { - $$ = block_end($3, - newCONDOP(0, $4, op_scope($6), $7)); - parser->copline = (line_t)$1; + $$ = block_end($remember, + newCONDOP(0, $mexpr, op_scope($mblock), $else)); + parser->copline = (line_t)$IF; } - | UNLESS '(' remember mexpr ')' mblock else + | UNLESS PERLY_PAREN_OPEN remember mexpr PERLY_PAREN_CLOSE mblock else { - $$ = block_end($3, - newCONDOP(0, $4, $7, op_scope($6))); - parser->copline = (line_t)$1; + $$ = block_end($remember, + newCONDOP(0, $mexpr, $else, op_scope($mblock))); + parser->copline = (line_t)$UNLESS; } - | GIVEN '(' remember mexpr ')' mblock + | GIVEN PERLY_PAREN_OPEN remember mexpr PERLY_PAREN_CLOSE mblock { - $$ = block_end($3, newGIVENOP($4, op_scope($6), 0)); - parser->copline = (line_t)$1; + $$ = block_end($remember, newGIVENOP($mexpr, op_scope($mblock), 0)); + parser->copline = (line_t)$GIVEN; } - | WHEN '(' remember mexpr ')' mblock - { $$ = block_end($3, newWHENOP($4, op_scope($6))); } + | WHEN PERLY_PAREN_OPEN remember mexpr PERLY_PAREN_CLOSE mblock + { $$ = block_end($remember, newWHENOP($mexpr, op_scope($mblock))); } | DEFAULT block - { $$ = newWHENOP(0, op_scope($2)); } - | WHILE '(' remember texpr ')' mintro mblock cont + { $$ = newWHENOP(0, op_scope($block)); } + | WHILE PERLY_PAREN_OPEN remember texpr PERLY_PAREN_CLOSE mintro mblock cont { - $$ = block_end($3, + $$ = block_end($remember, newWHILEOP(0, 1, NULL, - $4, $7, $8, $6)); - parser->copline = (line_t)$1; + $texpr, $mblock, $cont, $mintro)); + parser->copline = (line_t)$WHILE; } - | UNTIL '(' remember iexpr ')' mintro mblock cont + | UNTIL PERLY_PAREN_OPEN remember iexpr PERLY_PAREN_CLOSE mintro mblock cont { - $$ = block_end($3, + $$ = block_end($remember, newWHILEOP(0, 1, NULL, - $4, $7, $8, $6)); - parser->copline = (line_t)$1; + $iexpr, $mblock, $cont, $mintro)); + parser->copline = (line_t)$UNTIL; } - | FOR '(' remember mnexpr ';' + | FOR PERLY_PAREN_OPEN remember mnexpr[init_mnexpr] PERLY_SEMICOLON { parser->expect = XTERM; } - texpr ';' + texpr PERLY_SEMICOLON { parser->expect = XTERM; } - mintro mnexpr ')' + mintro mnexpr[iterate_mnexpr] PERLY_PAREN_CLOSE mblock { - OP *initop = $4; + OP *initop = $init_mnexpr; OP *forop = newWHILEOP(0, 1, NULL, - scalar($7), $13, $11, $10); + scalar($texpr), $mblock, $iterate_mnexpr, $mintro); if (initop) { forop = op_prepend_elem(OP_LINESEQ, initop, op_append_elem(OP_LINESEQ, @@ -400,80 +417,105 @@ barestmt: PLUGSTMT forop)); } PL_hints |= HINT_BLOCK_SCOPE; - $$ = block_end($3, forop); - parser->copline = (line_t)$1; + $$ = block_end($remember, forop); + parser->copline = (line_t)$FOR; } - | FOR MY remember my_scalar '(' mexpr ')' mblock cont + | FOR MY remember my_scalar PERLY_PAREN_OPEN mexpr PERLY_PAREN_CLOSE mblock cont { - $$ = block_end($3, newFOROP(0, $4, $6, $8, $9)); - parser->copline = (line_t)$1; + $$ = block_end($remember, newFOROP(0, $my_scalar, $mexpr, $mblock, $cont)); + parser->copline = (line_t)$FOR; } - | FOR scalar '(' remember mexpr ')' mblock cont + | FOR scalar PERLY_PAREN_OPEN remember mexpr PERLY_PAREN_CLOSE mblock cont { - $$ = block_end($4, newFOROP(0, - op_lvalue($2, OP_ENTERLOOP), $5, $7, $8)); - parser->copline = (line_t)$1; + $$ = block_end($remember, newFOROP(0, + op_lvalue($scalar, OP_ENTERLOOP), $mexpr, $mblock, $cont)); + parser->copline = (line_t)$FOR; } | FOR my_refgen remember my_var - { parser->in_my = 0; $$ = my($4); } - '(' mexpr ')' mblock cont + { parser->in_my = 0; $$ = my($my_var); }[variable] + PERLY_PAREN_OPEN mexpr PERLY_PAREN_CLOSE mblock cont { $$ = block_end( - $3, + $remember, newFOROP(0, op_lvalue( newUNOP(OP_REFGEN, 0, - $5), + $variable), OP_ENTERLOOP), - $7, $9, $10) + $mexpr, $mblock, $cont) ); - parser->copline = (line_t)$1; + parser->copline = (line_t)$FOR; } - | FOR REFGEN refgen_topic '(' remember mexpr ')' mblock cont + | FOR REFGEN refgen_topic PERLY_PAREN_OPEN remember mexpr PERLY_PAREN_CLOSE mblock cont { - $$ = block_end($5, newFOROP( + $$ = block_end($remember, newFOROP( 0, op_lvalue(newUNOP(OP_REFGEN, 0, - $3), - OP_ENTERLOOP), $6, $8, $9)); - parser->copline = (line_t)$1; + $refgen_topic), + OP_ENTERLOOP), $mexpr, $mblock, $cont)); + parser->copline = (line_t)$FOR; } - | FOR '(' remember mexpr ')' mblock cont + | FOR PERLY_PAREN_OPEN remember mexpr PERLY_PAREN_CLOSE mblock cont { - $$ = block_end($3, - newFOROP(0, NULL, $4, $6, $7)); - parser->copline = (line_t)$1; + $$ = block_end($remember, + newFOROP(0, NULL, $mexpr, $mblock, $cont)); + parser->copline = (line_t)$FOR; + } + | TRY mblock[try] CATCH PERLY_PAREN_OPEN + { parser->in_my = 1; } + remember scalar + { parser->in_my = 0; intro_my(); } + PERLY_PAREN_CLOSE mblock[catch] + { + OP *tryblock, *catchblock; + + tryblock = newUNOP(OP_ENTERTRY, OPf_SPECIAL, $try); + + catchblock = newLOGOP(OP_CATCH, 0, + newOP(OP_NULL, 0), /* LOGOP always needs an op_first */ + block_end($remember, op_scope($catch))); + + /* catchblock itself is an OP_NULL; the real OP_CATCH is + * its op_first */ + assert(cUNOPx(catchblock)->op_first->op_type == OP_CATCH); + cUNOPx(catchblock)->op_first->op_targ = $scalar->op_targ; + op_free($scalar); + + $$ = op_append_list(OP_LEAVE, + newOP(OP_ENTER, 0), + op_append_list(OP_LINESEQ, + tryblock, catchblock)); } | block cont { /* a block is a loop that happens once */ $$ = newWHILEOP(0, 1, NULL, - NULL, $1, $2, 0); + NULL, $block, $cont, 0); } - | PACKAGE BAREWORD BAREWORD '{' remember + | PACKAGE BAREWORD[version] BAREWORD[package] PERLY_BRACE_OPEN remember { - package($3); - if ($2) { - package_version($2); + package($package); + if ($version) { + package_version($version); } } - stmtseq '}' + stmtseq PERLY_BRACE_CLOSE { /* a block is a loop that happens once */ $$ = newWHILEOP(0, 1, NULL, - NULL, block_end($5, $7), NULL, 0); - if (parser->copline > (line_t)$4) - parser->copline = (line_t)$4; + NULL, block_end($remember, $stmtseq), NULL, 0); + if (parser->copline > (line_t)$PERLY_BRACE_OPEN) + parser->copline = (line_t)$PERLY_BRACE_OPEN; } - | sideff ';' + | sideff PERLY_SEMICOLON { - $$ = $1; + $$ = $sideff; } - | YADAYADA ';' + | YADAYADA PERLY_SEMICOLON { $$ = newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0), newSVOP(OP_CONST, 0, newSVpvs("Unimplemented"))); } - | ';' + | PERLY_SEMICOLON { $$ = NULL; parser->copline = NOLINE; @@ -483,12 +525,12 @@ barestmt: PLUGSTMT /* Format line */ formline: THING formarg { OP *list; - if ($2) { - OP *term = $2; - list = op_append_elem(OP_LIST, $1, term); + if ($formarg) { + OP *term = $formarg; + list = op_append_elem(OP_LIST, $THING, term); } else { - list = $1; + list = $THING; } if (parser->copline == NOLINE) parser->copline = CopLINE(PL_curcop)-1; @@ -498,70 +540,73 @@ formline: THING formarg } ; -formarg : /* NULL */ +formarg : %empty { $$ = NULL; } | FORMLBRACK stmtseq FORMRBRACK - { $$ = op_unscope($2); } + { $$ = op_unscope($stmtseq); } ; +condition: expr +; + /* An expression which may have a side-effect */ sideff : error { $$ = NULL; } - | expr - { $$ = $1; } - | expr IF expr - { $$ = newLOGOP(OP_AND, 0, $3, $1); } - | expr UNLESS expr - { $$ = newLOGOP(OP_OR, 0, $3, $1); } - | expr WHILE expr - { $$ = newLOOPOP(OPf_PARENS, 1, scalar($3), $1); } - | expr UNTIL iexpr - { $$ = newLOOPOP(OPf_PARENS, 1, $3, $1); } - | expr FOR expr - { $$ = newFOROP(0, NULL, $3, $1, NULL); - parser->copline = (line_t)$2; } - | expr WHEN expr - { $$ = newWHENOP($3, op_scope($1)); } + | expr[body] + { $$ = $body; } + | expr[body] IF condition + { $$ = newLOGOP(OP_AND, 0, $condition, $body); } + | expr[body] UNLESS condition + { $$ = newLOGOP(OP_OR, 0, $condition, $body); } + | expr[body] WHILE condition + { $$ = newLOOPOP(OPf_PARENS, 1, scalar($condition), $body); } + | expr[body] UNTIL iexpr + { $$ = newLOOPOP(OPf_PARENS, 1, $iexpr, $body); } + | expr[body] FOR condition + { $$ = newFOROP(0, NULL, $condition, $body, NULL); + parser->copline = (line_t)$FOR; } + | expr[body] WHEN condition + { $$ = newWHENOP($condition, op_scope($body)); } ; /* else and elsif blocks */ -else : /* NULL */ +else : %empty { $$ = NULL; } | ELSE mblock { - ($2)->op_flags |= OPf_PARENS; - $$ = op_scope($2); + ($mblock)->op_flags |= OPf_PARENS; + $$ = op_scope($mblock); } - | ELSIF '(' mexpr ')' mblock else - { parser->copline = (line_t)$1; + | ELSIF PERLY_PAREN_OPEN mexpr PERLY_PAREN_CLOSE mblock else[else.recurse] + { parser->copline = (line_t)$ELSIF; $$ = newCONDOP(0, - newSTATEOP(OPf_SPECIAL,NULL,$3), - op_scope($5), $6); + newSTATEOP(OPf_SPECIAL,NULL,$mexpr), + op_scope($mblock), $[else.recurse]); PL_hints |= HINT_BLOCK_SCOPE; } ; /* Continue blocks */ -cont : /* NULL */ +cont : %empty { $$ = NULL; } | CONTINUE block - { $$ = op_scope($2); } + { $$ = op_scope($block); } ; /* determine whether there are any new my declarations */ -mintro : /* NULL */ +mintro : %empty { $$ = (PL_min_intro_pending && PL_max_intro_pending >= PL_min_intro_pending); intro_my(); } /* Normal expression */ -nexpr : /* NULL */ +nexpr : %empty { $$ = NULL; } | sideff ; /* Boolean expression */ -texpr : /* NULL means true */ +texpr : %empty /* NULL means true */ { YYSTYPE tmplval; (void)scan_num("1", &tmplval); $$ = tmplval.opval; } @@ -570,34 +615,34 @@ texpr : /* NULL means true */ /* Inverted boolean expression */ iexpr : expr - { $$ = invert(scalar($1)); } + { $$ = invert(scalar($expr)); } ; /* Expression with its own lexical scope */ mexpr : expr - { $$ = $1; intro_my(); } + { $$ = $expr; intro_my(); } ; mnexpr : nexpr - { $$ = $1; intro_my(); } + { $$ = $nexpr; intro_my(); } ; -formname: BAREWORD { $$ = $1; } - | /* NULL */ { $$ = NULL; } +formname: BAREWORD { $$ = $BAREWORD; } + | %empty { $$ = NULL; } ; -startsub: /* NULL */ /* start a regular subroutine scope */ +startsub: %empty /* start a regular subroutine scope */ { $$ = start_subparse(FALSE, 0); SAVEFREESV(PL_compcv); } ; -startanonsub: /* NULL */ /* start an anonymous subroutine scope */ +startanonsub: %empty /* start an anonymous subroutine scope */ { $$ = start_subparse(FALSE, CVf_ANON); SAVEFREESV(PL_compcv); } ; -startformsub: /* NULL */ /* start a format subroutine scope */ +startformsub: %empty /* start a format subroutine scope */ { $$ = start_subparse(TRUE, 0); SAVEFREESV(PL_compcv); } ; @@ -608,23 +653,23 @@ subname : BAREWORD ; /* Subroutine prototype */ -proto : /* NULL */ +proto : %empty { $$ = NULL; } | THING ; /* Optional list of subroutine attributes */ -subattrlist: /* NULL */ +subattrlist: %empty { $$ = NULL; } | COLONATTR THING - { $$ = $2; } + { $$ = $THING; } | COLONATTR { $$ = NULL; } ; /* List of attributes for a "my" variable declaration */ myattrlist: COLONATTR THING - { $$ = $2; } + { $$ = $THING; } | COLONATTR { $$ = NULL; } ; @@ -636,24 +681,24 @@ myattrlist: COLONATTR THING */ /* the '' or 'foo' part of a '$' or '@foo' etc signature variable */ -sigvarname: /* NULL */ +sigvarname: %empty { parser->in_my = 0; $$ = NULL; } | PRIVATEREF - { parser->in_my = 0; $$ = $1; } + { parser->in_my = 0; $$ = $PRIVATEREF; } ; sigslurpsigil: - '@' + PERLY_SNAIL { $$ = '@'; } - | '%' + | PERLY_PERCENT_SIGN { $$ = '%'; } /* @, %, @foo, %foo */ sigslurpelem: sigslurpsigil sigvarname sigdefault/* def only to catch errors */ { - I32 sigil = $1; - OP *var = $2; - OP *defexpr = $3; + I32 sigil = $sigslurpsigil; + OP *var = $sigvarname; + OP *defexpr = $sigdefault; if (parser->sig_slurpy) yyerror("Multiple slurpy parameters not allowed"); @@ -668,20 +713,20 @@ sigslurpelem: sigslurpsigil sigvarname sigdefault/* def only to catch errors */ ; /* default part of sub signature scalar element: i.e. '= default_expr' */ -sigdefault: /* NULL */ +sigdefault: %empty { $$ = NULL; } | ASSIGNOP { $$ = newOP(OP_NULL, 0); } | ASSIGNOP term - { $$ = $2; } + { $$ = $term; } /* subroutine signature scalar element: e.g. '$x', '$=', '$x = $default' */ sigscalarelem: - '$' sigvarname sigdefault + PERLY_DOLLAR sigvarname sigdefault { - OP *var = $2; - OP *defexpr = $3; + OP *var = $sigvarname; + OP *defexpr = $sigdefault; if (parser->sig_slurpy) yyerror("Slurpy parameter not last"); @@ -744,38 +789,38 @@ sigscalarelem: /* subroutine signature element: e.g. '$x = $default' or '%h' */ sigelem: sigscalarelem - { parser->in_my = KEY_sigvar; $$ = $1; } + { parser->in_my = KEY_sigvar; $$ = $sigscalarelem; } | sigslurpelem - { parser->in_my = KEY_sigvar; $$ = $1; } + { parser->in_my = KEY_sigvar; $$ = $sigslurpelem; } ; /* list of subroutine signature elements */ siglist: - siglist ',' - { $$ = $1; } - | siglist ',' sigelem + siglist[list] PERLY_COMMA + { $$ = $list; } + | siglist[list] PERLY_COMMA sigelem[element] { - $$ = op_append_list(OP_LINESEQ, $1, $3); + $$ = op_append_list(OP_LINESEQ, $list, $element); } - | sigelem %prec PREC_LOW - { $$ = $1; } + | sigelem[element] %prec PREC_LOW + { $$ = $element; } ; /* () or (....) */ -siglistornull: /* NULL */ +siglistornull: %empty { $$ = NULL; } | siglist - { $$ = $1; } + { $$ = $siglist; } /* optional subroutine signature */ -optsubsignature: /* NULL */ +optsubsignature: %empty { $$ = NULL; } | subsignature - { $$ = $1; } + { $$ = $subsignature; } /* Subroutine signature */ -subsignature: '(' subsigguts ')' - { $$ = $2; } +subsignature: PERLY_PAREN_OPEN subsigguts PERLY_PAREN_CLOSE + { $$ = $subsigguts; } subsigguts: { @@ -790,7 +835,7 @@ subsigguts: } siglistornull { - OP *sigops = $2; + OP *sigops = $siglistornull; struct op_argcheck_aux *aux; OP *check; @@ -846,103 +891,101 @@ subsigguts: ; /* Optional subroutine body (for named subroutine declaration) */ -optsubbody: subbody { $$ = $1; } - | ';' { $$ = NULL; } +optsubbody: subbody { $$ = $subbody; } + | PERLY_SEMICOLON { $$ = NULL; } ; /* Subroutine body (without signature) */ -subbody: remember '{' stmtseq '}' +subbody: remember PERLY_BRACE_OPEN stmtseq PERLY_BRACE_CLOSE { - if (parser->copline > (line_t)$2) - parser->copline = (line_t)$2; - $$ = block_end($1, $3); + if (parser->copline > (line_t)$PERLY_BRACE_OPEN) + parser->copline = (line_t)$PERLY_BRACE_OPEN; + $$ = block_end($remember, $stmtseq); } ; /* optional [ Subroutine body with optional signature ] (for named * subroutine declaration) */ -optsigsubbody: sigsubbody { $$ = $1; } - | ';' { $$ = NULL; } +optsigsubbody: sigsubbody { $$ = $sigsubbody; } + | PERLY_SEMICOLON { $$ = NULL; } /* Subroutine body with optional signature */ -sigsubbody: remember optsubsignature '{' stmtseq '}' +sigsubbody: remember optsubsignature PERLY_BRACE_OPEN stmtseq PERLY_BRACE_CLOSE { - if (parser->copline > (line_t)$3) - parser->copline = (line_t)$3; - $$ = block_end($1, - op_append_list(OP_LINESEQ, $2, $4)); + if (parser->copline > (line_t)$PERLY_BRACE_OPEN) + parser->copline = (line_t)$PERLY_BRACE_OPEN; + $$ = block_end($remember, + op_append_list(OP_LINESEQ, $optsubsignature, $stmtseq)); } ; /* Ordinary expressions; logical combinations */ -expr : expr ANDOP expr - { $$ = newLOGOP(OP_AND, 0, $1, $3); } - | expr OROP expr - { $$ = newLOGOP($2, 0, $1, $3); } - | expr DOROP expr - { $$ = newLOGOP(OP_DOR, 0, $1, $3); } +expr : expr[lhs] ANDOP expr[rhs] + { $$ = newLOGOP(OP_AND, 0, $lhs, $rhs); } + | expr[lhs] OROP[operator] expr[rhs] + { $$ = newLOGOP($operator, 0, $lhs, $rhs); } | listexpr %prec PREC_LOW ; /* Expressions are a list of terms joined by commas */ -listexpr: listexpr ',' - { $$ = $1; } - | listexpr ',' term +listexpr: listexpr[list] PERLY_COMMA + { $$ = $list; } + | listexpr[list] PERLY_COMMA term { - OP* term = $3; - $$ = op_append_elem(OP_LIST, $1, term); + OP* term = $term; + $$ = op_append_elem(OP_LIST, $list, term); } | term %prec PREC_LOW ; /* List operators */ listop : LSTOP indirob listexpr /* map {...} @args or print $fh @args */ - { $$ = op_convert_list($1, OPf_STACKED, - op_prepend_elem(OP_LIST, newGVREF($1,$2), $3) ); + { $$ = op_convert_list($LSTOP, OPf_STACKED, + op_prepend_elem(OP_LIST, newGVREF($LSTOP,$indirob), $listexpr) ); } - | FUNC '(' indirob expr ')' /* print ($fh @args */ - { $$ = op_convert_list($1, OPf_STACKED, - op_prepend_elem(OP_LIST, newGVREF($1,$3), $4) ); + | FUNC PERLY_PAREN_OPEN indirob expr PERLY_PAREN_CLOSE /* print ($fh @args */ + { $$ = op_convert_list($FUNC, OPf_STACKED, + op_prepend_elem(OP_LIST, newGVREF($FUNC,$indirob), $expr) ); } - | term ARROW method '(' optexpr ')' /* $foo->bar(list) */ + | term ARROW method PERLY_PAREN_OPEN optexpr PERLY_PAREN_CLOSE /* $foo->bar(list) */ { $$ = op_convert_list(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, - op_prepend_elem(OP_LIST, scalar($1), $5), - newMETHOP(OP_METHOD, 0, $3))); + op_prepend_elem(OP_LIST, scalar($term), $optexpr), + newMETHOP(OP_METHOD, 0, $method))); } | term ARROW method /* $foo->bar */ { $$ = op_convert_list(OP_ENTERSUB, OPf_STACKED, - op_append_elem(OP_LIST, scalar($1), - newMETHOP(OP_METHOD, 0, $3))); + op_append_elem(OP_LIST, scalar($term), + newMETHOP(OP_METHOD, 0, $method))); } | METHOD indirob optlistexpr /* new Class @args */ { $$ = op_convert_list(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, - op_prepend_elem(OP_LIST, $2, $3), - newMETHOP(OP_METHOD, 0, $1))); + op_prepend_elem(OP_LIST, $indirob, $optlistexpr), + newMETHOP(OP_METHOD, 0, $METHOD))); } - | FUNCMETH indirob '(' optexpr ')' /* method $object (@args) */ + | FUNCMETH indirob PERLY_PAREN_OPEN optexpr PERLY_PAREN_CLOSE /* method $object (@args) */ { $$ = op_convert_list(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, - op_prepend_elem(OP_LIST, $2, $4), - newMETHOP(OP_METHOD, 0, $1))); + op_prepend_elem(OP_LIST, $indirob, $optexpr), + newMETHOP(OP_METHOD, 0, $FUNCMETH))); } | LSTOP optlistexpr /* print @args */ - { $$ = op_convert_list($1, 0, $2); } - | FUNC '(' optexpr ')' /* print (@args) */ - { $$ = op_convert_list($1, 0, $3); } + { $$ = op_convert_list($LSTOP, 0, $optlistexpr); } + | FUNC PERLY_PAREN_OPEN optexpr PERLY_PAREN_CLOSE /* print (@args) */ + { $$ = op_convert_list($FUNC, 0, $optexpr); } | FUNC SUBLEXSTART optexpr SUBLEXEND /* uc($arg) from "\U..." */ - { $$ = op_convert_list($1, 0, $3); } + { $$ = op_convert_list($FUNC, 0, $optexpr); } | LSTOPSUB startanonsub block /* sub f(&@); f { foo } ... */ { SvREFCNT_inc_simple_void(PL_compcv); - $$ = newANONATTRSUB($2, 0, NULL, $3); } + $$ = newANONATTRSUB($startanonsub, 0, NULL, $block); }[anonattrsub] optlistexpr %prec LSTOP /* ... @bar */ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, - op_prepend_elem(OP_LIST, $4, $5), $1)); + op_prepend_elem(OP_LIST, $anonattrsub, $optlistexpr), $LSTOPSUB)); } ; @@ -952,151 +995,151 @@ method : METHOD ; /* Some kind of subscripted expression */ -subscripted: gelem '{' expr ';' '}' /* *main::{something} */ - /* In this and all the hash accessors, ';' is +subscripted: gelem PERLY_BRACE_OPEN expr PERLY_SEMICOLON PERLY_BRACE_CLOSE /* *main::{something} */ + /* In this and all the hash accessors, PERLY_SEMICOLON is * provided by the tokeniser */ - { $$ = newBINOP(OP_GELEM, 0, $1, scalar($3)); } - | scalar '[' expr ']' /* $array[$element] */ - { $$ = newBINOP(OP_AELEM, 0, oopsAV($1), scalar($3)); + { $$ = newBINOP(OP_GELEM, 0, $gelem, scalar($expr)); } + | scalar[array] PERLY_BRACKET_OPEN expr PERLY_BRACKET_CLOSE /* $array[$element] */ + { $$ = newBINOP(OP_AELEM, 0, oopsAV($array), scalar($expr)); } - | term ARROW '[' expr ']' /* somearef->[$element] */ + | term[array_reference] ARROW PERLY_BRACKET_OPEN expr PERLY_BRACKET_CLOSE /* somearef->[$element] */ { $$ = newBINOP(OP_AELEM, 0, - ref(newAVREF($1),OP_RV2AV), - scalar($4)); + ref(newAVREF($array_reference),OP_RV2AV), + scalar($expr)); } - | subscripted '[' expr ']' /* $foo->[$bar]->[$baz] */ + | subscripted[array_reference] PERLY_BRACKET_OPEN expr PERLY_BRACKET_CLOSE /* $foo->[$bar]->[$baz] */ { $$ = newBINOP(OP_AELEM, 0, - ref(newAVREF($1),OP_RV2AV), - scalar($3)); + ref(newAVREF($array_reference),OP_RV2AV), + scalar($expr)); } - | scalar '{' expr ';' '}' /* $foo{bar();} */ - { $$ = newBINOP(OP_HELEM, 0, oopsHV($1), jmaybe($3)); + | scalar[hash] PERLY_BRACE_OPEN expr PERLY_SEMICOLON PERLY_BRACE_CLOSE /* $foo{bar();} */ + { $$ = newBINOP(OP_HELEM, 0, oopsHV($hash), jmaybe($expr)); } - | term ARROW '{' expr ';' '}' /* somehref->{bar();} */ + | term[hash_reference] ARROW PERLY_BRACE_OPEN expr PERLY_SEMICOLON PERLY_BRACE_CLOSE /* somehref->{bar();} */ { $$ = newBINOP(OP_HELEM, 0, - ref(newHVREF($1),OP_RV2HV), - jmaybe($4)); } - | subscripted '{' expr ';' '}' /* $foo->[bar]->{baz;} */ + ref(newHVREF($hash_reference),OP_RV2HV), + jmaybe($expr)); } + | subscripted[hash_reference] PERLY_BRACE_OPEN expr PERLY_SEMICOLON PERLY_BRACE_CLOSE /* $foo->[bar]->{baz;} */ { $$ = newBINOP(OP_HELEM, 0, - ref(newHVREF($1),OP_RV2HV), - jmaybe($3)); } - | term ARROW '(' ')' /* $subref->() */ + ref(newHVREF($hash_reference),OP_RV2HV), + jmaybe($expr)); } + | term[code_reference] ARROW PERLY_PAREN_OPEN PERLY_PAREN_CLOSE /* $subref->() */ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, - newCVREF(0, scalar($1))); + newCVREF(0, scalar($code_reference))); if (parser->expect == XBLOCK) parser->expect = XOPERATOR; } - | term ARROW '(' expr ')' /* $subref->(@args) */ + | term[code_reference] ARROW PERLY_PAREN_OPEN expr PERLY_PAREN_CLOSE /* $subref->(@args) */ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, - op_append_elem(OP_LIST, $4, - newCVREF(0, scalar($1)))); + op_append_elem(OP_LIST, $expr, + newCVREF(0, scalar($code_reference)))); if (parser->expect == XBLOCK) parser->expect = XOPERATOR; } - | subscripted '(' expr ')' /* $foo->{bar}->(@args) */ + | subscripted[code_reference] PERLY_PAREN_OPEN expr PERLY_PAREN_CLOSE /* $foo->{bar}->(@args) */ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, - op_append_elem(OP_LIST, $3, - newCVREF(0, scalar($1)))); + op_append_elem(OP_LIST, $expr, + newCVREF(0, scalar($code_reference)))); if (parser->expect == XBLOCK) parser->expect = XOPERATOR; } - | subscripted '(' ')' /* $foo->{bar}->() */ + | subscripted[code_reference] PERLY_PAREN_OPEN PERLY_PAREN_CLOSE /* $foo->{bar}->() */ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, - newCVREF(0, scalar($1))); + newCVREF(0, scalar($code_reference))); if (parser->expect == XBLOCK) parser->expect = XOPERATOR; } - | '(' expr ')' '[' expr ']' /* list slice */ - { $$ = newSLICEOP(0, $5, $2); } - | QWLIST '[' expr ']' /* list literal slice */ - { $$ = newSLICEOP(0, $3, $1); } - | '(' ')' '[' expr ']' /* empty list slice! */ - { $$ = newSLICEOP(0, $4, NULL); } + | PERLY_PAREN_OPEN expr[list] PERLY_PAREN_CLOSE PERLY_BRACKET_OPEN expr[slice] PERLY_BRACKET_CLOSE /* list slice */ + { $$ = newSLICEOP(0, $slice, $list); } + | QWLIST PERLY_BRACKET_OPEN expr PERLY_BRACKET_CLOSE /* list literal slice */ + { $$ = newSLICEOP(0, $expr, $QWLIST); } + | PERLY_PAREN_OPEN PERLY_PAREN_CLOSE PERLY_BRACKET_OPEN expr PERLY_BRACKET_CLOSE /* empty list slice! */ + { $$ = newSLICEOP(0, $expr, NULL); } ; /* Binary operators between terms */ -termbinop: term ASSIGNOP term /* $x = $y, $x += $y */ - { $$ = newASSIGNOP(OPf_STACKED, $1, $2, $3); } - | term POWOP term /* $x ** $y */ - { $$ = newBINOP($2, 0, scalar($1), scalar($3)); } - | term MULOP term /* $x * $y, $x x $y */ - { if ($2 != OP_REPEAT) - scalar($1); - $$ = newBINOP($2, 0, $1, scalar($3)); - } - | term ADDOP term /* $x + $y */ - { $$ = newBINOP($2, 0, scalar($1), scalar($3)); } - | term SHIFTOP term /* $x >> $y, $x << $y */ - { $$ = newBINOP($2, 0, scalar($1), scalar($3)); } +termbinop: term[lhs] ASSIGNOP term[rhs] /* $x = $y, $x += $y */ + { $$ = newASSIGNOP(OPf_STACKED, $lhs, $ASSIGNOP, $rhs); } + | term[lhs] POWOP term[rhs] /* $x ** $y */ + { $$ = newBINOP($POWOP, 0, scalar($lhs), scalar($rhs)); } + | term[lhs] MULOP term[rhs] /* $x * $y, $x x $y */ + { if ($MULOP != OP_REPEAT) + scalar($lhs); + $$ = newBINOP($MULOP, 0, $lhs, scalar($rhs)); + } + | term[lhs] ADDOP term[rhs] /* $x + $y */ + { $$ = newBINOP($ADDOP, 0, scalar($lhs), scalar($rhs)); } + | term[lhs] SHIFTOP term[rhs] /* $x >> $y, $x << $y */ + { $$ = newBINOP($SHIFTOP, 0, scalar($lhs), scalar($rhs)); } | termrelop %prec PREC_LOW /* $x > $y, etc. */ - { $$ = $1; } + { $$ = $termrelop; } | termeqop %prec PREC_LOW /* $x == $y, $x cmp $y */ - { $$ = $1; } - | term BITANDOP term /* $x & $y */ - { $$ = newBINOP($2, 0, scalar($1), scalar($3)); } - | term BITOROP term /* $x | $y */ - { $$ = newBINOP($2, 0, scalar($1), scalar($3)); } - | term DOTDOT term /* $x..$y, $x...$y */ - { $$ = newRANGE($2, scalar($1), scalar($3)); } - | term ANDAND term /* $x && $y */ - { $$ = newLOGOP(OP_AND, 0, $1, $3); } - | term OROR term /* $x || $y */ - { $$ = newLOGOP(OP_OR, 0, $1, $3); } - | term DORDOR term /* $x // $y */ - { $$ = newLOGOP(OP_DOR, 0, $1, $3); } - | term MATCHOP term /* $x =~ /$y/ */ - { $$ = bind_match($2, $1, $3); } + { $$ = $termeqop; } + | term[lhs] BITANDOP term[rhs] /* $x & $y */ + { $$ = newBINOP($BITANDOP, 0, scalar($lhs), scalar($rhs)); } + | term[lhs] BITOROP term[rhs] /* $x | $y */ + { $$ = newBINOP($BITOROP, 0, scalar($lhs), scalar($rhs)); } + | term[lhs] DOTDOT term[rhs] /* $x..$y, $x...$y */ + { $$ = newRANGE($DOTDOT, scalar($lhs), scalar($rhs)); } + | term[lhs] ANDAND term[rhs] /* $x && $y */ + { $$ = newLOGOP(OP_AND, 0, $lhs, $rhs); } + | term[lhs] OROR term[rhs] /* $x || $y */ + { $$ = newLOGOP(OP_OR, 0, $lhs, $rhs); } + | term[lhs] DORDOR term[rhs] /* $x // $y */ + { $$ = newLOGOP(OP_DOR, 0, $lhs, $rhs); } + | term[lhs] MATCHOP term[rhs] /* $x =~ /$y/ */ + { $$ = bind_match($MATCHOP, $lhs, $rhs); } ; termrelop: relopchain %prec PREC_LOW - { $$ = cmpchain_finish($1); } - | term NCRELOP term - { $$ = newBINOP($2, 0, scalar($1), scalar($3)); } + { $$ = cmpchain_finish($relopchain); } + | term[lhs] NCRELOP term[rhs] + { $$ = newBINOP($NCRELOP, 0, scalar($lhs), scalar($rhs)); } | termrelop NCRELOP { yyerror("syntax error"); YYERROR; } | termrelop CHRELOP { yyerror("syntax error"); YYERROR; } ; -relopchain: term CHRELOP term - { $$ = cmpchain_start($2, $1, $3); } - | relopchain CHRELOP term - { $$ = cmpchain_extend($2, $1, $3); } +relopchain: term[lhs] CHRELOP term[rhs] + { $$ = cmpchain_start($CHRELOP, $lhs, $rhs); } + | relopchain[lhs] CHRELOP term[rhs] + { $$ = cmpchain_extend($CHRELOP, $lhs, $rhs); } ; termeqop: eqopchain %prec PREC_LOW - { $$ = cmpchain_finish($1); } - | term NCEQOP term - { $$ = newBINOP($2, 0, scalar($1), scalar($3)); } + { $$ = cmpchain_finish($eqopchain); } + | term[lhs] NCEQOP term[rhs] + { $$ = newBINOP($NCEQOP, 0, scalar($lhs), scalar($rhs)); } | termeqop NCEQOP { yyerror("syntax error"); YYERROR; } | termeqop CHEQOP { yyerror("syntax error"); YYERROR; } ; -eqopchain: term CHEQOP term - { $$ = cmpchain_start($2, $1, $3); } - | eqopchain CHEQOP term - { $$ = cmpchain_extend($2, $1, $3); } +eqopchain: term[lhs] CHEQOP term[rhs] + { $$ = cmpchain_start($CHEQOP, $lhs, $rhs); } + | eqopchain[lhs] CHEQOP term[rhs] + { $$ = cmpchain_extend($CHEQOP, $lhs, $rhs); } ; /* Unary operators and terms */ -termunop : '-' term %prec UMINUS /* -$x */ - { $$ = newUNOP(OP_NEGATE, 0, scalar($2)); } - | '+' term %prec UMINUS /* +$x */ - { $$ = $2; } - - | '!' term /* !$x */ - { $$ = newUNOP(OP_NOT, 0, scalar($2)); } - | '~' term /* ~$x */ - { $$ = newUNOP($1, 0, scalar($2)); } +termunop : PERLY_MINUS term %prec UMINUS /* -$x */ + { $$ = newUNOP(OP_NEGATE, 0, scalar($term)); } + | PERLY_PLUS term %prec UMINUS /* +$x */ + { $$ = $term; } + + | PERLY_EXCLAMATION_MARK term /* !$x */ + { $$ = newUNOP(OP_NOT, 0, scalar($term)); } + | PERLY_TILDE term /* ~$x */ + { $$ = newUNOP($PERLY_TILDE, 0, scalar($term)); } | term POSTINC /* $x++ */ { $$ = newUNOP(OP_POSTINC, 0, - op_lvalue(scalar($1), OP_POSTINC)); } + op_lvalue(scalar($term), OP_POSTINC)); } | term POSTDEC /* $x-- */ { $$ = newUNOP(OP_POSTDEC, 0, - op_lvalue(scalar($1), OP_POSTDEC));} + op_lvalue(scalar($term), OP_POSTDEC));} | term POSTJOIN /* implicit join after interpolated ->@ */ { $$ = op_convert_list(OP_JOIN, 0, op_append_elem( @@ -1105,184 +1148,184 @@ termunop : '-' term %prec UMINUS /* -$x */ newSVOP(OP_CONST,0, newSVpvs("\"")) )), - $1 + $term )); } | PREINC term /* ++$x */ { $$ = newUNOP(OP_PREINC, 0, - op_lvalue(scalar($2), OP_PREINC)); } + op_lvalue(scalar($term), OP_PREINC)); } | PREDEC term /* --$x */ { $$ = newUNOP(OP_PREDEC, 0, - op_lvalue(scalar($2), OP_PREDEC)); } + op_lvalue(scalar($term), OP_PREDEC)); } ; /* Constructors for anonymous data */ -anonymous: '[' expr ']' - { $$ = newANONLIST($2); } - | '[' ']' +anonymous: PERLY_BRACKET_OPEN expr PERLY_BRACKET_CLOSE + { $$ = newANONLIST($expr); } + | PERLY_BRACKET_OPEN PERLY_BRACKET_CLOSE { $$ = newANONLIST(NULL);} - | HASHBRACK expr ';' '}' %prec '(' /* { foo => "Bar" } */ - { $$ = newANONHASH($2); } - | HASHBRACK ';' '}' %prec '(' /* { } (';' by tokener) */ + | HASHBRACK expr PERLY_SEMICOLON PERLY_BRACE_CLOSE %prec PERLY_PAREN_OPEN /* { foo => "Bar" } */ + { $$ = newANONHASH($expr); } + | HASHBRACK PERLY_SEMICOLON PERLY_BRACE_CLOSE %prec PERLY_PAREN_OPEN /* { } (PERLY_SEMICOLON by tokener) */ { $$ = newANONHASH(NULL); } - | ANONSUB startanonsub proto subattrlist subbody %prec '(' + | ANONSUB startanonsub proto subattrlist subbody %prec PERLY_PAREN_OPEN { SvREFCNT_inc_simple_void(PL_compcv); - $$ = newANONATTRSUB($2, $3, $4, $5); } - | ANON_SIGSUB startanonsub subattrlist sigsubbody %prec '(' + $$ = newANONATTRSUB($startanonsub, $proto, $subattrlist, $subbody); } + | ANON_SIGSUB startanonsub subattrlist sigsubbody %prec PERLY_PAREN_OPEN { SvREFCNT_inc_simple_void(PL_compcv); - $$ = newANONATTRSUB($2, NULL, $3, $4); } + $$ = newANONATTRSUB($startanonsub, NULL, $subattrlist, $sigsubbody); } ; /* Things called with "do" */ termdo : DO term %prec UNIOP /* do $filename */ - { $$ = dofile($2, $1);} - | DO block %prec '(' /* do { code */ - { $$ = newUNOP(OP_NULL, OPf_SPECIAL, op_scope($2));} + { $$ = dofile($term, $DO);} + | DO block %prec PERLY_PAREN_OPEN /* do { code */ + { $$ = newUNOP(OP_NULL, OPf_SPECIAL, op_scope($block));} ; -term : termbinop +term[product] : termbinop | termunop | anonymous | termdo - | term '?' term ':' term - { $$ = newCONDOP(0, $1, $3, $5); } - | REFGEN term /* \$x, \@y, \%z */ - { $$ = newUNOP(OP_REFGEN, 0, $2); } - | MY REFGEN term - { $$ = newUNOP(OP_REFGEN, 0, localize($3,1)); } + | term[condition] PERLY_QUESTION_MARK term[then] PERLY_COLON term[else] + { $$ = newCONDOP(0, $condition, $then, $else); } + | REFGEN term[operand] /* \$x, \@y, \%z */ + { $$ = newUNOP(OP_REFGEN, 0, $operand); } + | MY REFGEN term[operand] + { $$ = newUNOP(OP_REFGEN, 0, localize($operand,1)); } | myattrterm %prec UNIOP - { $$ = $1; } - | LOCAL term %prec UNIOP - { $$ = localize($2,0); } - | '(' expr ')' - { $$ = sawparens($2); } + { $$ = $myattrterm; } + | LOCAL term[operand] %prec UNIOP + { $$ = localize($operand,0); } + | PERLY_PAREN_OPEN expr PERLY_PAREN_CLOSE + { $$ = sawparens($expr); } | QWLIST - { $$ = $1; } - | '(' ')' + { $$ = $QWLIST; } + | PERLY_PAREN_OPEN PERLY_PAREN_CLOSE { $$ = sawparens(newNULLLIST()); } - | scalar %prec '(' - { $$ = $1; } - | star %prec '(' - { $$ = $1; } - | hsh %prec '(' - { $$ = $1; } - | ary %prec '(' - { $$ = $1; } - | arylen %prec '(' /* $#x, $#{ something } */ - { $$ = newUNOP(OP_AV2ARYLEN, 0, ref($1, OP_AV2ARYLEN));} + | scalar %prec PERLY_PAREN_OPEN + { $$ = $scalar; } + | star %prec PERLY_PAREN_OPEN + { $$ = $star; } + | hsh %prec PERLY_PAREN_OPEN + { $$ = $hsh; } + | ary %prec PERLY_PAREN_OPEN + { $$ = $ary; } + | arylen %prec PERLY_PAREN_OPEN /* $#x, $#{ something } */ + { $$ = newUNOP(OP_AV2ARYLEN, 0, ref($arylen, OP_AV2ARYLEN));} | subscripted - { $$ = $1; } - | sliceme '[' expr ']' /* array slice */ + { $$ = $subscripted; } + | sliceme PERLY_BRACKET_OPEN expr PERLY_BRACKET_CLOSE /* array slice */ { $$ = op_prepend_elem(OP_ASLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_ASLICE, 0, - list($3), - ref($1, OP_ASLICE))); - if ($$ && $1) + list($expr), + ref($sliceme, OP_ASLICE))); + if ($$ && $sliceme) $$->op_private |= - $1->op_private & OPpSLICEWARNING; + $sliceme->op_private & OPpSLICEWARNING; } - | kvslice '[' expr ']' /* array key/value slice */ + | kvslice PERLY_BRACKET_OPEN expr PERLY_BRACKET_CLOSE /* array key/value slice */ { $$ = op_prepend_elem(OP_KVASLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_KVASLICE, 0, - list($3), - ref(oopsAV($1), OP_KVASLICE))); - if ($$ && $1) + list($expr), + ref(oopsAV($kvslice), OP_KVASLICE))); + if ($$ && $kvslice) $$->op_private |= - $1->op_private & OPpSLICEWARNING; + $kvslice->op_private & OPpSLICEWARNING; } - | sliceme '{' expr ';' '}' /* @hash{@keys} */ + | sliceme PERLY_BRACE_OPEN expr PERLY_SEMICOLON PERLY_BRACE_CLOSE /* @hash{@keys} */ { $$ = op_prepend_elem(OP_HSLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_HSLICE, 0, - list($3), - ref(oopsHV($1), OP_HSLICE))); - if ($$ && $1) + list($expr), + ref(oopsHV($sliceme), OP_HSLICE))); + if ($$ && $sliceme) $$->op_private |= - $1->op_private & OPpSLICEWARNING; + $sliceme->op_private & OPpSLICEWARNING; } - | kvslice '{' expr ';' '}' /* %hash{@keys} */ + | kvslice PERLY_BRACE_OPEN expr PERLY_SEMICOLON PERLY_BRACE_CLOSE /* %hash{@keys} */ { $$ = op_prepend_elem(OP_KVHSLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_KVHSLICE, 0, - list($3), - ref($1, OP_KVHSLICE))); - if ($$ && $1) + list($expr), + ref($kvslice, OP_KVHSLICE))); + if ($$ && $kvslice) $$->op_private |= - $1->op_private & OPpSLICEWARNING; + $kvslice->op_private & OPpSLICEWARNING; } - | THING %prec '(' - { $$ = $1; } + | THING %prec PERLY_PAREN_OPEN + { $$ = $THING; } | amper /* &foo; */ - { $$ = newUNOP(OP_ENTERSUB, 0, scalar($1)); } - | amper '(' ')' /* &foo() or foo() */ - { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar($1)); + { $$ = newUNOP(OP_ENTERSUB, 0, scalar($amper)); } + | amper PERLY_PAREN_OPEN PERLY_PAREN_CLOSE /* &foo() or foo() */ + { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar($amper)); } - | amper '(' expr ')' /* &foo(@args) or foo(@args) */ + | amper PERLY_PAREN_OPEN expr PERLY_PAREN_CLOSE /* &foo(@args) or foo(@args) */ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, - op_append_elem(OP_LIST, $3, scalar($1))); + op_append_elem(OP_LIST, $expr, scalar($amper))); } | NOAMP subname optlistexpr /* foo @args (no parens) */ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, - op_append_elem(OP_LIST, $3, scalar($2))); - } - | term ARROW '$' '*' - { $$ = newSVREF($1); } - | term ARROW '@' '*' - { $$ = newAVREF($1); } - | term ARROW '%' '*' - { $$ = newHVREF($1); } - | term ARROW '&' '*' + op_append_elem(OP_LIST, $optlistexpr, scalar($subname))); + } + | term[operand] ARROW PERLY_DOLLAR PERLY_STAR + { $$ = newSVREF($operand); } + | term[operand] ARROW PERLY_SNAIL PERLY_STAR + { $$ = newAVREF($operand); } + | term[operand] ARROW PERLY_PERCENT_SIGN PERLY_STAR + { $$ = newHVREF($operand); } + | term[operand] ARROW PERLY_AMPERSAND PERLY_STAR { $$ = newUNOP(OP_ENTERSUB, 0, - scalar(newCVREF($3,$1))); } - | term ARROW '*' '*' %prec '(' - { $$ = newGVREF(0,$1); } + scalar(newCVREF($PERLY_AMPERSAND,$operand))); } + | term[operand] ARROW PERLY_STAR PERLY_STAR %prec PERLY_PAREN_OPEN + { $$ = newGVREF(0,$operand); } | LOOPEX /* loop exiting command (goto, last, dump, etc) */ - { $$ = newOP($1, OPf_SPECIAL); + { $$ = newOP($LOOPEX, OPf_SPECIAL); PL_hints |= HINT_BLOCK_SCOPE; } - | LOOPEX term - { $$ = newLOOPEX($1,$2); } + | LOOPEX term[operand] + { $$ = newLOOPEX($LOOPEX,$operand); } | NOTOP listexpr /* not $foo */ - { $$ = newUNOP(OP_NOT, 0, scalar($2)); } + { $$ = newUNOP(OP_NOT, 0, scalar($listexpr)); } | UNIOP /* Unary op, $_ implied */ - { $$ = newOP($1, 0); } + { $$ = newOP($UNIOP, 0); } | UNIOP block /* eval { foo }* */ - { $$ = newUNOP($1, 0, $2); } - | UNIOP term /* Unary op */ - { $$ = newUNOP($1, 0, $2); } + { $$ = newUNOP($UNIOP, 0, $block); } + | UNIOP term[operand] /* Unary op */ + { $$ = newUNOP($UNIOP, 0, $operand); } | REQUIRE /* require, $_ implied */ - { $$ = newOP(OP_REQUIRE, $1 ? OPf_SPECIAL : 0); } - | REQUIRE term /* require Foo */ - { $$ = newUNOP(OP_REQUIRE, $1 ? OPf_SPECIAL : 0, $2); } + { $$ = newOP(OP_REQUIRE, $REQUIRE ? OPf_SPECIAL : 0); } + | REQUIRE term[operand] /* require Foo */ + { $$ = newUNOP(OP_REQUIRE, $REQUIRE ? OPf_SPECIAL : 0, $operand); } | UNIOPSUB - { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar($1)); } - | UNIOPSUB term /* Sub treated as unop */ + { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar($UNIOPSUB)); } + | UNIOPSUB term[operand] /* Sub treated as unop */ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, - op_append_elem(OP_LIST, $2, scalar($1))); } + op_append_elem(OP_LIST, $operand, scalar($UNIOPSUB))); } | FUNC0 /* Nullary operator */ - { $$ = newOP($1, 0); } - | FUNC0 '(' ')' - { $$ = newOP($1, 0);} + { $$ = newOP($FUNC0, 0); } + | FUNC0 PERLY_PAREN_OPEN PERLY_PAREN_CLOSE + { $$ = newOP($FUNC0, 0);} | FUNC0OP /* Same as above, but op created in toke.c */ - { $$ = $1; } - | FUNC0OP '(' ')' - { $$ = $1; } + { $$ = $FUNC0OP; } + | FUNC0OP PERLY_PAREN_OPEN PERLY_PAREN_CLOSE + { $$ = $FUNC0OP; } | FUNC0SUB /* Sub treated as nullop */ - { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar($1)); } - | FUNC1 '(' ')' /* not () */ - { $$ = ($1 == OP_NOT) - ? newUNOP($1, 0, newSVOP(OP_CONST, 0, newSViv(0))) - : newOP($1, OPf_SPECIAL); } - | FUNC1 '(' expr ')' /* not($foo) */ - { $$ = newUNOP($1, 0, $3); } + { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar($FUNC0SUB)); } + | FUNC1 PERLY_PAREN_OPEN PERLY_PAREN_CLOSE /* not () */ + { $$ = ($FUNC1 == OP_NOT) + ? newUNOP($FUNC1, 0, newSVOP(OP_CONST, 0, newSViv(0))) + : newOP($FUNC1, OPf_SPECIAL); } + | FUNC1 PERLY_PAREN_OPEN expr PERLY_PAREN_CLOSE /* not($foo) */ + { $$ = newUNOP($FUNC1, 0, $expr); } | PMFUNC /* m//, s///, qr//, tr/// */ { - if ( $1->op_type != OP_TRANS - && $1->op_type != OP_TRANSR - && (((PMOP*)$1)->op_pmflags & PMf_HAS_CV)) + if ( $PMFUNC->op_type != OP_TRANS + && $PMFUNC->op_type != OP_TRANSR + && (((PMOP*)$PMFUNC)->op_pmflags & PMf_HAS_CV)) { $$ = start_subparse(FALSE, CVf_ANON); SAVEFREESV(PL_compcv); @@ -1290,7 +1333,7 @@ term : termbinop $$ = 0; } SUBLEXSTART listexpr optrepl SUBLEXEND - { $$ = pmruntime($1, $4, $5, 1, $2); } + { $$ = pmruntime($PMFUNC, $listexpr, $optrepl, 1, $2); } | BAREWORD | listop | PLUGEXPR @@ -1298,50 +1341,50 @@ term : termbinop /* "my" declarations, with optional attributes */ myattrterm: MY myterm myattrlist - { $$ = my_attrs($2,$3); } + { $$ = my_attrs($myterm,$myattrlist); } | MY myterm - { $$ = localize($2,1); } + { $$ = localize($myterm,1); } | MY REFGEN myterm myattrlist - { $$ = newUNOP(OP_REFGEN, 0, my_attrs($3,$4)); } + { $$ = newUNOP(OP_REFGEN, 0, my_attrs($myterm,$myattrlist)); } ; /* Things that can be "my"'d */ -myterm : '(' expr ')' - { $$ = sawparens($2); } - | '(' ')' +myterm : PERLY_PAREN_OPEN expr PERLY_PAREN_CLOSE + { $$ = sawparens($expr); } + | PERLY_PAREN_OPEN PERLY_PAREN_CLOSE { $$ = sawparens(newNULLLIST()); } - | scalar %prec '(' - { $$ = $1; } - | hsh %prec '(' - { $$ = $1; } - | ary %prec '(' - { $$ = $1; } + | scalar %prec PERLY_PAREN_OPEN + { $$ = $scalar; } + | hsh %prec PERLY_PAREN_OPEN + { $$ = $hsh; } + | ary %prec PERLY_PAREN_OPEN + { $$ = $ary; } ; /* Basic list expressions */ -optlistexpr: /* NULL */ %prec PREC_LOW +optlistexpr: %empty %prec PREC_LOW { $$ = NULL; } | listexpr %prec PREC_LOW - { $$ = $1; } + { $$ = $listexpr; } ; -optexpr: /* NULL */ +optexpr: %empty { $$ = NULL; } | expr - { $$ = $1; } + { $$ = $expr; } ; -optrepl: /* NULL */ +optrepl: %empty { $$ = NULL; } - | '/' expr - { $$ = $2; } + | PERLY_SLASH expr + { $$ = $expr; } ; /* A little bit of trickery to make "for my $foo (@bar)" actually be lexical */ my_scalar: scalar - { parser->in_my = 0; $$ = my($1); } + { parser->in_my = 0; $$ = my($scalar); } ; my_var : scalar @@ -1357,59 +1400,59 @@ my_refgen: MY REFGEN | REFGEN MY ; -amper : '&' indirob - { $$ = newCVREF($1,$2); } +amper : PERLY_AMPERSAND indirob + { $$ = newCVREF($PERLY_AMPERSAND,$indirob); } ; -scalar : '$' indirob - { $$ = newSVREF($2); } +scalar : PERLY_DOLLAR indirob + { $$ = newSVREF($indirob); } ; -ary : '@' indirob - { $$ = newAVREF($2); - if ($$) $$->op_private |= $1; +ary : PERLY_SNAIL indirob + { $$ = newAVREF($indirob); + if ($$) $$->op_private |= $PERLY_SNAIL; } ; -hsh : '%' indirob - { $$ = newHVREF($2); - if ($$) $$->op_private |= $1; +hsh : PERLY_PERCENT_SIGN indirob + { $$ = newHVREF($indirob); + if ($$) $$->op_private |= $PERLY_PERCENT_SIGN; } ; arylen : DOLSHARP indirob - { $$ = newAVREF($2); } - | term ARROW DOLSHARP '*' - { $$ = newAVREF($1); } + { $$ = newAVREF($indirob); } + | term ARROW DOLSHARP PERLY_STAR + { $$ = newAVREF($term); } ; -star : '*' indirob - { $$ = newGVREF(0,$2); } +star : PERLY_STAR indirob + { $$ = newGVREF(0,$indirob); } ; sliceme : ary - | term ARROW '@' - { $$ = newAVREF($1); } + | term ARROW PERLY_SNAIL + { $$ = newAVREF($term); } ; kvslice : hsh - | term ARROW '%' - { $$ = newHVREF($1); } + | term ARROW PERLY_PERCENT_SIGN + { $$ = newHVREF($term); } ; gelem : star - | term ARROW '*' - { $$ = newGVREF(0,$1); } + | term ARROW PERLY_STAR + { $$ = newGVREF(0,$term); } ; /* Indirect objects */ indirob : BAREWORD - { $$ = scalar($1); } + { $$ = scalar($BAREWORD); } | scalar %prec PREC_LOW - { $$ = scalar($1); } + { $$ = scalar($scalar); } | block - { $$ = op_scope($1); } + { $$ = op_scope($block); } | PRIVATEREF - { $$ = $1; } + { $$ = $PRIVATEREF; } ; diff --git a/plan9/config_sh.sample b/plan9/config_sh.sample index e817912c3988..d2e89cab2eb1 100644 --- a/plan9/config_sh.sample +++ b/plan9/config_sh.sample @@ -31,12 +31,12 @@ afsroot='/afs' alignbytes='4' aphostname='/bin/uname -n' api_revision='5' -api_subversion='4' +api_subversion='7' api_version='33' -api_versionstring='5.33.4' +api_versionstring='5.33.7' ar='ar' -archlib='/sys/lib/perl5/5.33.4/386' -archlibexp='/sys/lib/perl5/5.33.4/386' +archlib='/sys/lib/perl5/5.33.7/386' +archlibexp='/sys/lib/perl5/5.33.7/386' archname64='' archname='386' archobjs='' @@ -248,6 +248,7 @@ d_gdbm_ndbm_h_uses_prototypes='undef' d_gdbmndbm_h_uses_prototypes='undef' d_getaddrinfo='undef' d_getcwd='define' +d_getenv_preserves_other_thread='define' d_getespwnam='undef' d_getfsstat='undef' d_getgrent='define' @@ -818,17 +819,17 @@ inc_version_list=' ' inc_version_list_init='0' incpath='' inews='' -installarchlib='/sys/lib/perl/5.33.4/386' +installarchlib='/sys/lib/perl/5.33.7/386' installbin='/usr/bin' installman1dir='/sys/man/1pub' installman3dir='/sys/man/2pub' installprefix='/usr' installprefixexp='/usr' -installprivlib='/sys/lib/perl/5.33.4' +installprivlib='/sys/lib/perl/5.33.7' installscript='/usr/bin' -installsitearch='/sys/lib/perl/5.33.4/site_perl/386' +installsitearch='/sys/lib/perl/5.33.7/site_perl/386' installsitebin='/usr/bin' -installsitelib='/sys/lib/perl/5.33.4/site_perl' +installsitelib='/sys/lib/perl/5.33.7/site_perl' installstyle='lib/perl5' installusrbinperl='undef' installvendorarch='' @@ -953,8 +954,8 @@ pmake='' pr='' prefix='/usr' prefixexp='/usr' -privlib='/sys/lib/perl/5.33.4' -privlibexp='/sys/lib/perl/5.33.4' +privlib='/sys/lib/perl/5.33.7' +privlibexp='/sys/lib/perl/5.33.7' procselfexe='' prototype='define' ptrsize='4' @@ -1019,13 +1020,13 @@ sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 0' sig_size='50' signal_t='void' -sitearch='/sys/lib/perl/5.33.4/site_perl/386' +sitearch='/sys/lib/perl/5.33.7/site_perl/386' sitearchexp='/sys/lib/perl/site_perl/386' sitebin='/usr/bin' sitebinexp='/usr/bin' -sitelib='/sys/lib/perl/5.33.4/site_perl' -sitelib_stem='/sys/lib/perl/5.33.4/site_perl' -sitelibexp='/sys/lib/perl/5.33.4/site_perl' +sitelib='/sys/lib/perl/5.33.7/site_perl' +sitelib_stem='/sys/lib/perl/5.33.7/site_perl' +sitelibexp='/sys/lib/perl/5.33.7/site_perl' siteprefix='/usr' siteprefixexp='/usr' sizesize='4' @@ -1058,7 +1059,7 @@ stdio_stream_array='' strerror_r_proto='0' strings='/sys/include/ape/string.h' submit='' -subversion='4' +subversion='7' sysman='/sys/man/1pub' tail='' tar='' @@ -1139,8 +1140,8 @@ vendorlib_stem='' vendorlibexp='' vendorprefix='' vendorprefixexp='' -version='5.33.4' -version_patchlevel_string='version 33 subversion 4' +version='5.33.7' +version_patchlevel_string='version 33 subversion 7' versiononly='undef' vi='' xlibpth='' @@ -1154,9 +1155,9 @@ config_args='' config_argc=0 PERL_REVISION=5 PERL_VERSION=33 -PERL_SUBVERSION=4 +PERL_SUBVERSION=7 PERL_API_REVISION=5 PERL_API_VERSION=33 -PERL_API_SUBVERSION=4 +PERL_API_SUBVERSION=7 PERL_PATCHLEVEL= PERL_CONFIG_SH=true diff --git a/plan9/plan9.c b/plan9/plan9.c index 02ef76c97bbb..9872306d7e82 100644 --- a/plan9/plan9.c +++ b/plan9/plan9.c @@ -11,18 +11,18 @@ #define SHIFT 20 int fpclassify(double d) { - FPdbleword x; - - /* order matters: only isNaN can operate on NaN */ - if ( isNaN(d) ) - return FP_NAN; - else if ( isInf(d, 0) ) - return FP_INFINITE; - else if ( d == 0 ) - return FP_ZERO; - - x.x = fabs(d); - return (x.hi >> SHIFT) ? FP_NORMAL : FP_SUBNORMAL; + FPdbleword x; + + /* order matters: only isNaN can operate on NaN */ + if ( isNaN(d) ) + return FP_NAN; + else if ( isInf(d, 0) ) + return FP_INFINITE; + else if ( d == 0 ) + return FP_ZERO; + + x.x = fabs(d); + return (x.hi >> SHIFT) ? FP_NORMAL : FP_SUBNORMAL; } /* Functions mentioned in /sys/include/ape/sys/socket.h but not implemented */ diff --git a/plan9/plan9ish.h b/plan9/plan9ish.h index 7fd8c7e5dbff..a5a318e70423 100644 --- a/plan9/plan9ish.h +++ b/plan9/plan9ish.h @@ -105,7 +105,7 @@ #define BIT_BUCKET "/dev/null" #define PERL_SYS_INIT_BODY(c,v) \ - MALLOC_CHECK_TAINT2(*c,*v) PERLIO_INIT; MALLOC_INIT + MALLOC_CHECK_TAINT2(*c,*v) PERLIO_INIT; MALLOC_INIT #define dXSUB_SYS dNOOP #define PERL_SYS_TERM_BODY() PERLIO_TERM; MALLOC_TERM diff --git a/pod/.gitignore b/pod/.gitignore index 089fe5a4dcfd..c8d7ad839d4a 100644 --- a/pod/.gitignore +++ b/pod/.gitignore @@ -29,7 +29,6 @@ /perlsynology.pod /perltru64.pod /perltw.pod -/perlvms.pod /perlvos.pod /perlwin32.pod @@ -49,7 +48,7 @@ /roffitall # generated -/perl5334delta.pod +/perl5337delta.pod /perlapi.pod /perlintern.pod /perlmodlib.pod diff --git a/pod/buildtoc b/pod/buildtoc index 004a726a0fb0..c846d994b3ff 100644 --- a/pod/buildtoc +++ b/pod/buildtoc @@ -275,4 +275,42 @@ sub unitem { $initem = 0; } +=head1 NAME + +pod/buildtoc - Generate table of contents + +=head1 DESCRIPTION + +This program generates a table of contents for the documentation included in the Perl core distribution. This table of contents takes two forms: + +=over 4 + +=item 1 F + +A file in Perl's Plain Old Documentation (POD) format found in the F directory in the core distribution. Once Perl is installed, this file becomes accessible system-wide via C. + +=item 2 F + +A shell script originally written by Tom Christiansen and Raphael Manfredi, also found in the F directory, which can be used to translate Perl documentation into F pages. + +=back + +=head1 USAGE + +This program will typically B need to be called directly by a user. Rather, it is one of the last commands invoked during C: + + ./perl -Ilib -I. -f pod/buildtoc -q + +The only command-line switch is C<-q|--quiet>, which quiets some non-critical warnings. + +=head2 Diagnosing Problems + +This program Cs F and makes use of several subroutines found in that file: C and C in particular. Consequently, any warnings or exceptions you see when this program is running may be being passed through from those subroutines. You may have to (a) examine those subroutines and/or (b) run that program from the command-line to fully understand what is causing such warnings or exceptions. + +=head2 AUTHORS and MAINTENANCE + +This program was introduced into the Perl 5 core distribution by Andy Dougherty, based on earlier work by Tom Christiansen. It is maintained by the Perl 5 Porters. + +=cut + # ex: set ts=8 sts=4 sw=4 et: diff --git a/pod/perl.pod b/pod/perl.pod index 557c5dbe8970..101b84252808 100644 --- a/pod/perl.pod +++ b/pod/perl.pod @@ -96,6 +96,7 @@ aux h2ph h2xs perlbug pl2pm pod2html pod2man splain xsubpp perlpacktut Perl pack() and unpack() tutorial perlpod Perl plain old documentation perlpodspec Perl plain old documentation format specification + perldocstyle Perl style guide for core docs perlpodstyle Perl POD style guide perldiag Perl diagnostic messages perldeprecation Perl deprecations @@ -171,6 +172,7 @@ aux h2ph h2xs perlbug pl2pm pod2html pod2man splain xsubpp perlhacktut Walk through the creation of a simple C code patch perlhacktips Tips for Perl core C code hacking perlpolicy Perl development policies + perlgov Perl Rules of Governance perlgit Using git with the Perl repository =head2 Miscellaneous @@ -182,10 +184,14 @@ aux h2ph h2xs perlbug pl2pm pod2html pod2man splain xsubpp perlhist Perl history records perldelta Perl changes since previous version + perl5336delta Perl changes in version 5.33.6 + perl5335delta Perl changes in version 5.33.5 + perl5334delta Perl changes in version 5.33.4 perl5333delta Perl changes in version 5.33.3 perl5332delta Perl changes in version 5.33.2 perl5331delta Perl changes in version 5.33.1 perl5330delta Perl changes in version 5.33.0 + perl5321delta Perl changes in version 5.32.1 perl5320delta Perl changes in version 5.32.0 perl5303delta Perl changes in version 5.30.3 perl5302delta Perl changes in version 5.30.2 diff --git a/pod/perl5260delta.pod b/pod/perl5260delta.pod index 69c62ee6994c..a1a4bbd03cfc 100644 --- a/pod/perl5260delta.pod +++ b/pod/perl5260delta.pod @@ -2630,7 +2630,7 @@ L<[perl #126697]|https://rt.perl.org/Public/Bug/Display.html?id=126697> Using C to modify a magic variable could access freed memory in some cases. -L<[perl #129340]|https://rt.perl.org/Public/Bug/Display.html?id=129340> +L<[perl #130766]|https://rt.perl.org/Public/Bug/Display.html?id=130766> =item * diff --git a/pod/perl5321delta.pod b/pod/perl5321delta.pod new file mode 100644 index 000000000000..94e294ecf83d --- /dev/null +++ b/pod/perl5321delta.pod @@ -0,0 +1,266 @@ +=encoding utf8 + +=head1 NAME + +perl5321delta - what is new for perl v5.32.1 + +=head1 DESCRIPTION + +This document describes differences between the 5.32.0 release and the 5.32.1 +release. + +If you are upgrading from an earlier release such as 5.31.0, first read +L, which describes differences between 5.31.0 and 5.32.0. + +=head1 Incompatible Changes + +There are no changes intentionally incompatible with Perl 5.32.0. If any +exist, they are bugs, and we request that you submit a report. See +L below. + +=head1 Modules and Pragmata + +=head2 Updated Modules and Pragmata + +=over 4 + +=item * + +L has been upgraded from version 2.174 to 2.174_01. + +A number of memory leaks have been fixed. + +=item * + +L has been upgraded from version 1.47 to 1.47_01. + +=item * + +L has been upgraded from version 5.20200620 to 5.20210123. + +=item * + +L has been upgraded from version 1.47 to 1.48. + +A warning has been added about evaluating untrusted code with the perl +interpreter. + +=item * + +L has been upgraded from version 2.41 to 2.41_01. + +A warning has been added about evaluating untrusted code with the perl +interpreter. + +=back + +=head1 Documentation + +=head2 New Documentation + +=head3 L + +Documentation of the newly formed rules of governance for Perl. + +=head3 L + +Documentation of how the Perl security team operates and how the team evaluates +new security reports. + +=head2 Changes to Existing Documentation + +We have attempted to update the documentation to reflect the changes listed in +this document. If you find any we have missed, open an issue at +L. + +Additionally, the following selected changes have been made: + +=head3 L + +=over 4 + +=item * + +Document range op behaviour change. + +=back + +=head1 Diagnostics + +The following additions or changes have been made to diagnostic output, +including warnings and fatal error messages. For the complete list of +diagnostic messages, see L. + +=head2 Changes to Existing Diagnostics + +=over 4 + +=item * + +L<\K not permitted in lookahead/lookbehind in regex; marked by <-- HERE in mE%sE|perldiag/"\K not permitted in lookahead/lookbehind in regex; marked by <-- HERE in m/%s/"> + +This error was incorrectly produced in some cases involving nested lookarounds. +This has been fixed. + +[L] + +=back + +=head1 Configuration and Compilation + +=over 4 + +=item * + +Newer 64-bit versions of the Intel C/C++ compiler are now recognized and have +the correct flags set. + +=item * + +We now trap SIGBUS when F checks for C. + +On several systems the attempt to determine if we need C or similar +results in a SIGBUS instead of the expected SIGSEGV, which previously caused a +core dump. + +[L] + +=back + +=head1 Testing + +Tests were added and changed to reflect the other additions and changes in this +release. + +=head1 Platform Support + +=head2 Platform-Specific Notes + +=over 4 + +=item MacOS (Darwin) + +The hints file for darwin has been updated to handle future macOS versions +beyond 10. Perl can now be built on macOS Big Sur. + +[L, +L] + +=item Minix + +Build errors on Minix have been fixed. + +[L] + +=back + +=head1 Selected Bug Fixes + +=over 4 + +=item * + +Some list assignments involving C on the left-hand side were +over-optimized and produced incorrect results. + +[L, +L] + +=item * + +Fixed a bug in which some regexps with recursive subpatterns matched +incorrectly. + +[L] + +=item * + +Fixed a deadlock that hung the build when Perl is compiled for debugging memory +problems and has PERL_MEM_LOG enabled. + +[L] + +=item * + +Fixed a crash in the use of chained comparison operators when run under "no +warnings 'uninitialized'". + +[L, +L] + +=item * + +Exceptions thrown from destructors during global destruction are no longer +swallowed. + +[L] + +=back + +=head1 Acknowledgements + +Perl 5.32.1 represents approximately 7 months of development since Perl 5.32.0 +and contains approximately 7,000 lines of changes across 80 files from 23 +authors. + +Excluding auto-generated files, documentation and release tools, there were +approximately 1,300 lines of changes to 23 .pm, .t, .c and .h files. + +Perl continues to flourish into its fourth decade thanks to a vibrant community +of users and developers. The following people are known to have contributed +the improvements that became Perl 5.32.1: + +Adam Hartley, Andy Dougherty, Dagfinn Ilmari Mannsåker, Dan Book, David +Mitchell, Graham Knop, Graham Ollis, Hauke D, H.Merijn Brand, Hugo van der +Sanden, John Lightsey, Karen Etheridge, Karl Williamson, Leon Timmermans, Max +Maischein, Nicolas R., Ricardo Signes, Richard Leach, Sawyer X, Sevan Janiyan, +Steve Hay, Tom Hukins, Tony Cook. + +The list above is almost certainly incomplete as it is automatically generated +from version control history. In particular, it does not include the names of +the (very much appreciated) contributors who reported issues to the Perl bug +tracker. + +Many of the changes included in this version originated in the CPAN modules +included in Perl's core. We're grateful to the entire CPAN community for +helping Perl to flourish. + +For a more complete list of all of Perl's historical contributors, please see +the F file in the Perl source distribution. + +=head1 Reporting Bugs + +If you find what you think is a bug, you might check the perl bug database at +L. There may also be information at +L, the Perl Home Page. + +If you believe you have an unreported bug, please open an issue at +L. Be sure to trim your bug down to a +tiny but sufficient test case. + +If the bug you are reporting has security implications which make it +inappropriate to send to a public issue tracker, then see +L for details of how to +report the issue. + +=head1 Give Thanks + +If you wish to thank the Perl 5 Porters for the work we had done in Perl 5, you +can do so by running the C program: + + perlthanks + +This will send an email to the Perl 5 Porters list with your show of thanks. + +=head1 SEE ALSO + +The F file for an explanation of how to view exhaustive details on +what changed. + +The F file for how to build Perl. + +The F file for general stuff. + +The F and F files for copyright information. + +=cut diff --git a/pod/perl5334delta.pod b/pod/perl5334delta.pod new file mode 100644 index 000000000000..c1fc77dba232 --- /dev/null +++ b/pod/perl5334delta.pod @@ -0,0 +1,223 @@ +=encoding utf8 + +=head1 NAME + +perl5334delta - what is new for perl v5.33.4 + +=head1 DESCRIPTION + +This document describes differences between the 5.33.3 release and the 5.33.4 +release. + +If you are upgrading from an earlier release such as 5.33.2, first read +L, which describes differences between 5.33.2 and 5.33.3. + +=head1 Modules and Pragmata + +=head2 Updated Modules and Pragmata + +=over 4 + +=item * + +L has been upgraded from version 1.81 to 1.82. + +=item * + +L has been upgraded from version 0.280234 to 0.280235. + +=item * + +L has been upgraded from version 7.48 to 7.56. + +=item * + +L has been upgraded from version 0.56 to 1.00. + +=item * + +L has been upgraded from version 2.17 to 2.18. + +=item * + +L has been upgraded from version 3.78 to 3.79. + +=item * + +L has been upgraded from version 2.08 to 2.09. + +=item * + +L has been upgraded from version 5.20201020 to 5.20201120. + +=item * + +L has been upgraded from version 2.73_01 to 2.74. + +=item * + +L has been upgraded from version 5.20200523 to 5.20201107. + +=item * + +L has been upgraded from version 1.25 to 1.26. + +=item * + +L has been upgraded from version 3.41 to 3.42. + +=item * + +L has been upgraded from version 1.302182 to 1.302183. + +=item * + +L has been upgraded from version 1.12 to 1.13. + +=back + +=head1 Documentation + +=head2 Changes to Existing Documentation + +We have attempted to update the documentation to reflect the changes +listed in this document. If you find any we have missed, open an issue +at L. + +=head3 L + +=over 4 + +=item * + +The Perl FAQ was updated to CPAN version 5.20201107 with minor +improvements. + +=back + +=head3 L + +=over 4 + +=item * + +Efforts continue in improving the presentation of this document, and to +document more API elements. + +=back + +=head1 Diagnostics + +The following additions or changes have been made to diagnostic output, +including warnings and fatal error messages. For the complete list of +diagnostic messages, see L. + +=head2 Changes to Existing Diagnostics + +=over 4 + +=item * + +L<\K not permitted in lookahead/lookbehind in regex; marked by <-- HERE in mE%sE|perldiag/"\K not permitted in lookahead/lookbehind in regex; marked by <-- HERE in m/%s/"> + +This error was incorrectly produced in some cases involving nested +lookarounds. This has been fixed. [L] + +=back + +=head1 Platform Support + +=head2 Platform-Specific Notes + +=over 4 + +=item DragonFlyBSD + +Tests were updated to workaround DragonFlyBSD bugs in L and L. + +=back + +=head1 Selected Bug Fixes + +=over 4 + +=item * + +Magic is now called correctly for stacked file test operators. [L] + +=item * + +The C<@ary = split(...)> optimization no longer switches in the target +array as the value stack. [L] Also see discussion at +L. + +=back + +=head1 Acknowledgements + +Perl 5.33.4 represents approximately 4 weeks of development since Perl +5.33.3 and contains approximately 6,900 lines of changes across 340 files +from 16 authors. + +Excluding auto-generated files, documentation and release tools, there were +approximately 4,200 lines of changes to 260 .pm, .t, .c and .h files. + +Perl continues to flourish into its fourth decade thanks to a vibrant +community of users and developers. The following people are known to have +contributed the improvements that became Perl 5.33.4: + +Ben Cornett, Chris 'BinGOs' Williams, Dan Book, David Mitchell, Giovanni +Tataranni, James E Keenan, Karen Etheridge, Karl Williamson, Marcus +Holland-Moritz, Nicolas R., Richard Leach, Scott Baker, Steve Hay, TAKAI +Kousuke, Tom Hukins, Tony Cook. + +The list above is almost certainly incomplete as it is automatically +generated from version control history. In particular, it does not include +the names of the (very much appreciated) contributors who reported issues to +the Perl bug tracker. + +Many of the changes included in this version originated in the CPAN modules +included in Perl's core. We're grateful to the entire CPAN community for +helping Perl to flourish. + +For a more complete list of all of Perl's historical contributors, please +see the F file in the Perl source distribution. + +=head1 Reporting Bugs + +If you find what you think is a bug, you might check the perl bug database +at L. There may also be information at +L, the Perl Home Page. + +If you believe you have an unreported bug, please open an issue at +L. Be sure to trim your bug down to a +tiny but sufficient test case. + +If the bug you are reporting has security implications which make it +inappropriate to send to a public issue tracker, then see +L +for details of how to report the issue. + +=head1 Give Thanks + +If you wish to thank the Perl 5 Porters for the work we had done in Perl 5, +you can do so by running the C program: + + perlthanks + +This will send an email to the Perl 5 Porters list with your show of thanks. + +=head1 SEE ALSO + +The F file for an explanation of how to view exhaustive details on +what changed. + +The F file for how to build Perl. + +The F file for general stuff. + +The F and F files for copyright information. + +=cut diff --git a/pod/perl5335delta.pod b/pod/perl5335delta.pod new file mode 100644 index 000000000000..eea2ba0f8c9d --- /dev/null +++ b/pod/perl5335delta.pod @@ -0,0 +1,341 @@ +=encoding utf8 + +=head1 NAME + +perl5335delta - what is new for perl v5.33.5 + +=head1 DESCRIPTION + +This document describes differences between the 5.33.4 release and the 5.33.5 +release. + +If you are upgrading from an earlier release such as 5.33.3, first read +L, which describes differences between 5.33.3 and 5.33.4. + +=head1 Core Enhancements + +=head2 New octal syntax C<0oI> + +It is now possible to specify octal literals with C<0o> prefixes, +as in C<0o123_456>, parallel to the existing construct to specify +hexadecimal literal C<0xI> and binary literal C<0bI>. +Also, the builtin C function now accepts this new syntax. + +See L and L. + +=head1 Modules and Pragmata + +=head2 Updated Modules and Pragmata + +=over 4 + +=item * + +L has been upgraded from version 1.50 to 1.51. + +=item * + +L has been upgraded from version 0.32 to 0.33. + +=item * + +L has been upgraded from version 1.48 to 1.49. + +=item * + +L has been upgraded from version 3.07 to 3.08. + +=item * + +L has been upgraded from version 2.18 to 2.20. + +=item * + +L has been upgraded from version 3.41 to 3.42. + +=item * + +L has been upgraded from version 2.34 to 2.35. + +=item * + +L has been upgraded from version 1.37 to 1.38. + +=item * + +L has been upgraded from version 3.79 to 3.80. + +=item * + +The libnet distribution has been upgraded from version 3.11 to 3.12. + +=item * + +L has been upgraded from version 5.20201120 to 5.20201220. + +=item * + +L has been upgraded from version 1.16 to 1.17. + +=item * + +L has been upgraded from version 1.48 to 1.49. + +=item * + +L has been upgraded from version 0.08 to 0.09. + +=item * + +L has been upgraded from version 1.95 to 1.96. + +=item * + +L has been upgraded from version 3.42 to 3.43. + +=item * + +L has been upgraded from version 2.03 to 2.04. + +=item * + +L has been upgraded from version 1.9765 to 1.9766. + +=item * + +L has been upgraded from version 1.48 to 1.49. + +=item * + +L has been upgraded from version 1.13 to 1.14. + +=back + +=head1 Documentation + +=head2 New Documentation + +=head3 L has been added to F. + +This document is a guide for the authorship and maintenance of the +documentation that ships with Perl. + +=head2 Changes to Existing Documentation + +We have attempted to update the documentation to reflect the changes +listed in this document. If you find any we have missed, open an issue +at L. + +Additionally, the following selected changes have been made: + +=head3 L + +=over 4 + +=item * + +L documented a length field included in the +packed C parameter to msgsnd(), but there was no such field. +C contains only the type and the message content. + +=back + +=head1 Testing + +Tests were added and changed to reflect the other additions and +changes in this release. Furthermore, these significant changes were +made: + +=over 4 + +=item * + +When testing in parallel on many-core platforms, you can now cause the +test suite to finish somewhat earlier, but with less logical ordering of +the tests, by setting + + PERL_TEST_HARNESS_ASAP=1 + +while running the test suite. + +=back + +=head2 Platform-Specific Notes + +=over 4 + +=item Windows + +Windows now supports L and +L, and L is no +longer an alias for L. +L<[#18005]|https://github.com/Perl/perl5/issues/18005>. + +Unlike POSIX systems, creating a symbolic link on Windows requires +either elevated privileges or Windows 10 1703 or later with Developer +Mode enabled. + +stat(), including C, and lstat() now uses our own +implementation that populates the device C and inode numbers +C returned rather than always returning zero. The number of +links C field is now always populated. + +L<< C<${^WIN32_SLOPPY_STAT}> |perlvar/${^WIN32_SLOPPY_STAT} >> previously +controlled whether the C field was populated requiring a +separate Windows API call to fetch, since nlink and the other +information required for stat() is now retrieved in a single API call. + +The C<-r> and C<-w> operators now return true for the C, +C and C handles. Unfortunately it still won't return +true for duplicates of those handles. +L<[#8502]|https://github.com/Perl/perl5/issues/8502>. + +The times returned by stat() and lstat() are no longer incorrect +across Daylight Savings Time adjustments. +L<[#6080]|https://github.com/Perl/perl5/issues/6080>. + +C<-x> on a filehandle should now match C<-x> on the corresponding +filename on Vista or later. +L<[#4145]|https://github.com/Perl/perl5/issues/4145>. + +C<-e '"'> no longer incorrectly returns true. +L<[#12431]|https://github.com/Perl/perl5/issues/12431>. + +=back + +=head1 Internal Changes + +=over 4 + +=item * + +All C-ish functions now evaluate their arguments exactly once. +In 5.32, plain L> was changed to do that; now the rest +do as well. + +=item * + +Unicode is now a first class citizen when considering the pattern /A*B/ where +A and B are arbitrary. The pattern matching code tries to make a tight loop +to match the span of A's. The logic of this was now really updated with +support for UTF-8. + +=back + +=head1 Selected Bug Fixes + +=over 4 + +=item * + +L, L, and +L now properly reset the UTF-8 flag on the +C parameter if it's modified for C or C +operations. + +=item * + +semctl(), msgctl(), and shmctl() now attempt to downgrade the C +parameter if its value is being used as input to C or +C calls. A failed downgrade will thrown an exception. + +=item * + +In cases where semctl(), msgctl() or shmctl() would treat the C +parameter as a pointer, an undefined value no longer generates a +warning. In most such calls the pointer isn't used anyway and this +allows you to supply C for a value not used by the underlying +function. + +=item * + +L now downgrades the C parameter, +L now downgrades the C parameter and +L now downgrades the C parameter +to treat them as bytes. Previously they would be left upgraded, +providing a corrupted structure to the underlying function call. + +=item * + +L now properly resets the UTF-8 flag the +C parameter when it is modified. Previusly the UTF-8 flag could +be left on, resulting in a possibly corrupt result in C. + +=back + +=head1 Known Problems + +None + +=head1 Errata From Previous Releases + +None + +=head1 Acknowledgements + +Perl 5.33.5 represents approximately 4 weeks of development since Perl +5.33.4 and contains approximately 22,000 lines of changes across 370 files +from 27 authors. + +Excluding auto-generated files, documentation and release tools, there were +approximately 15,000 lines of changes to 220 .pm, .t, .c and .h files. + +Perl continues to flourish into its fourth decade thanks to a vibrant +community of users and developers. The following people are known to have +contributed the improvements that became Perl 5.33.5: + +Branislav Zahradník, Chris 'BinGOs' Williams, Dan Book, Dan Kogai, David +Cantrell, David Mitchell, Graham Knop, H.Merijn Brand, Jae Bradley, James E +Keenan, Jason McIntosh, jkahrman, John Karr, Karen Etheridge, Karl +Williamson, Leon Timmermans, Max Maischein, Paul Evans, Sawyer X, Sevan +Janiyan, Shlomi Fish, Steve Hay, TAKAI Kousuke, Thibault Duponchelle, Tomasz +Konojacki, Tom Hukins, Tony Cook. + +The list above is almost certainly incomplete as it is automatically +generated from version control history. In particular, it does not include +the names of the (very much appreciated) contributors who reported issues to +the Perl bug tracker. + +Many of the changes included in this version originated in the CPAN modules +included in Perl's core. We're grateful to the entire CPAN community for +helping Perl to flourish. + +For a more complete list of all of Perl's historical contributors, please +see the F file in the Perl source distribution. + +=head1 Reporting Bugs + +If you find what you think is a bug, you might check the perl bug database +at L. There may also be information at +L, the Perl Home Page. + +If you believe you have an unreported bug, please open an issue at +L. Be sure to trim your bug down to a +tiny but sufficient test case. + +If the bug you are reporting has security implications which make it +inappropriate to send to a public issue tracker, then see +L +for details of how to report the issue. + +=head1 Give Thanks + +If you wish to thank the Perl 5 Porters for the work we had done in Perl 5, +you can do so by running the C program: + + perlthanks + +This will send an email to the Perl 5 Porters list with your show of thanks. + +=head1 SEE ALSO + +The F file for an explanation of how to view exhaustive details on +what changed. + +The F file for how to build Perl. + +The F file for general stuff. + +The F and F files for copyright information. + +=cut diff --git a/pod/perl5336delta.pod b/pod/perl5336delta.pod new file mode 100644 index 000000000000..9d5a2f9f79d5 --- /dev/null +++ b/pod/perl5336delta.pod @@ -0,0 +1,400 @@ +=encoding utf8 + +=head1 NAME + +perl5336delta - what is new for perl v5.33.6 + +=head1 DESCRIPTION + +This document describes differences between the 5.33.5 release and the +5.33.6 release. + +If you are upgrading from an earlier release such as 5.33.4, first read +L, which describes differences between 5.33.4 and 5.33.5. + +=head1 Core Enhancements + +=head2 C is now accepted + +An empty lower bound is now accepted for regular expression quantifiers, +like C<{,3}>. + +=head2 Blanks freely allowed within but adjacent to curly braces + +(in double-quotish contexts and regular expression patterns) + +This means you can write things like S> if you like. This +applies to all such constructs, namely C<\b{}>, C<\g{}>, C<\k{}>, +C<\N{}>, C<\o{}>, and C<\x{}>; as well as the regular expression +quantifier C<{I,I}>. C<\p{}> and C<\P{}> retain their +already-existing, even looser, rules mandated by the Unicode standard +(see L). + +This ability is in effect regardless of the presence of the C +regular expression pattern modifier. + +Additionally, the comma in a regular expression braced quantifier may +have blanks (tabs or spaces) before and/or after the comma, like +S>. + +=head1 Modules and Pragmata + +=head2 Updated Modules and Pragmata + +=over 4 + +=item * + +L has been upgraded from version 1.51 to 1.52. + +=item * + +L has been upgraded from version 2.096 to 2.100. + +=item * + +L has been upgraded from version 2.096 to 2.100. + +=item * + +L has been upgraded from version 1.49 to 1.50. + +=item * + +L has been upgraded from version 7.56 to 7.58. + +=item * + +L has been upgraded from version 1.72 to 1.73. + +=item * + +L has been upgraded from version 1.61 to 1.62. + +Added the default enabled C feature. + +=item * + +L has been upgraded from version 1.18 to 1.19. + +New functions and compatibility for newer versions of GDBM. +[L] + +=item * + +L has been upgraded from version 1.44 to 1.45. + +IO::Socket now stores error messages in C<$IO::Socket::errstr>, in +addition to in C<$@>. + +=item * + +IO-Compress has been upgraded from version 2.096 to 2.100. + +=item * + +libnet has been upgraded from version 3.12 to 3.13. + +=item * + +L has been upgraded from version 5.20201220 to 5.20210120. + +=item * + +L has been upgraded from version 1.96 to 1.97. + +POSIX::signbit() behaviour has been improved. +[L] + +Documentation for C clarifies that the result is always in English. +(Use C for a localized result.) + +=item * + +L has been upgraded from version 2.030 to 2.031. + +=item * + +L has been upgraded from version 1.49 to 1.50. + +=item * + +L has been upgraded from version 1.14 to 1.15. + +=back + +=head1 Documentation + +=head2 New Documentation + +=head3 L + +This document describes the goals, scope, system, and rules for Perl's new +governance model. + +Other pod files, most notably L, were amended to reflect +its adoption. + +=head2 Changes to Existing Documentation + +We have attempted to update the documentation to reflect the changes +listed in this document. If you find any we have missed, open an issue +at L. + +Additionally, the following selected changes have been made: + +=head3 L + +=over 4 + +=item * + +The freenode IRC URL has been updated. + +=back + +=head3 L + +=over 4 + +=item * + +The L entry has been improved and now +also states that the result of the function is always in English. + +=back + +=head3 L + +=over 4 + +=item * + +A new example shows how a lexical C variable can be declared +during the initialization of a C loop. + +=back + +=head1 Diagnostics + +The following additions or changes have been made to diagnostic output, +including warnings and fatal error messages. For the complete list of +diagnostic messages, see L. + +=head2 New Diagnostics + +=head3 New Errors + +=over 4 + +=item * + +L + +This accompanies the new L feature. + +=back + +=head2 Changes to Existing Diagnostics + +=over 4 + +=item * + +L + +Subroutine argument-count mismatch errors now include the number of +given and expected arguments. + +=item * + +L + +Subroutine argument-count mismatch errors now include the number of +given and expected arguments. + +=item * + +L + +This warning was only issued for positive too-large values when +incrementing, and only for negative ones when decrementing. +It is now issued for both positive or negative too-large values. +[L] + +=back + +=head1 Configuration and Compilation + +=over 4 + +=item * Configure + +A new probe checks for buggy libc implementations of the C/C +functions. +[L] + +=back + +=head1 Testing + +Tests were added and changed to reflect the other additions and +changes in this release. Furthermore, these significant changes were +made: + +=over 4 + +=item * + +F was added, providing a test harness for regexp optimization. +[L] + +=item * + +A workaround for CPAN distributions needing dot in C<@INC> has been removed +[L]. +All distributions that previously required the workaround have now been +adapted. + +=back + +=head1 Platform Support + +=head2 Platform-Specific Notes + +=over 4 + +=item Mac OS X + +A number of system libraries no longer exist as actual files on Big Sur, +even though C will pretend they do, so now we fall back to C +if a library file can not be found. +[L] + +=item MS Windows + +perl can now be built with C on MS Windows using +(32-bit and 64-bit) mingw-w64 ports of gcc. +[L] + +The F utility now needs to C. This could +cause failures in parallel builds. + +=back + +=head1 Selected Bug Fixes + +=over 4 + +=item * + +Skip trying to constant fold an incomplete op tree +[L] + +Constant folding of chained comparison op trees could fail under certain +conditions, causing perl to crash. As a quick fix, constant folding is +now skipped for such op trees. This also addresses +[L]. + +=item * + +%g formatting broken on Ubuntu-18.04, NVSIZE == 8 +[L] + +Buggy libc implementations of the C and C functions +caused C<(s)printf> to incorrectly truncate C<%g> formatted numbers. +A new Configure probe now checks for this, with the result that the libc +C will be used in place of C and C. + +Tests added as part of this fix also revealed related problems in +some Windows builds. The makefiles for MINGW builds on Windows have +thus been adjusted to use USE_MINGW_ANSI_STDIO by default, ensuring +that they also provide correct C<(s)printf> formatting of numbers. + +=item * + +op.c: croak on "my $_" when "use utf8" is in effect +[L] + +The lexical topic feature experiment was removed in Perl v5.24 and +declaring C became a compile time error. However, it was previously +still possible to make this declaration if C was in effect. + +=item * + +regexec.c: Fix assertion failure +[L] + +Fuzzing triggered an assertion failure in the regexp engine when too many +characters were copied into a buffer. + +=back + +=head1 Acknowledgements + +Perl 5.33.6 represents approximately 4 weeks of development since Perl +5.33.5 and contains approximately 96,000 lines of changes across 450 files +from 26 authors. + +Excluding auto-generated files, documentation and release tools, there were +approximately 85,000 lines of changes to 320 .pm, .t, .c and .h files. + +Perl continues to flourish into its fourth decade thanks to a vibrant +community of users and developers. The following people are known to have +contributed the improvements that became Perl 5.33.6: + +Branislav Zahradník, Chris 'BinGOs' Williams, Craig A. Berry, Dan Book, +Daniel Böhmer, Daniel Laügt, Felipe Gasper, Hugo van der Sanden, James E +Keenan, Kang-min Liu, Karen Etheridge, Karl Williamson, Leon Timmermans, Max +Maischein, Michael G Schwern, Paul Evans, Ricardo Signes, Richard Leach, +Sawyer X, Sergey Poznyakoff, Sisyphus, Steve Hay, TAKAI Kousuke, Tomasz +Konojacki, Tom Hukins, Tony Cook. + +The list above is almost certainly incomplete as it is automatically +generated from version control history. In particular, it does not include +the names of the (very much appreciated) contributors who reported issues to +the Perl bug tracker. + +Many of the changes included in this version originated in the CPAN modules +included in Perl's core. We're grateful to the entire CPAN community for +helping Perl to flourish. + +For a more complete list of all of Perl's historical contributors, please +see the F file in the Perl source distribution. + +=head1 Reporting Bugs + +If you find what you think is a bug, you might check the perl bug database +at L. There may also be information at +L, the Perl Home Page. + +If you believe you have an unreported bug, please open an issue at +L. Be sure to trim your bug down to a +tiny but sufficient test case. + +If the bug you are reporting has security implications which make it +inappropriate to send to a public issue tracker, then see +L +for details of how to report the issue. + +=head1 Give Thanks + +If you wish to thank the Perl 5 Porters for the work we had done in Perl 5, +you can do so by running the C program: + + perlthanks + +This will send an email to the Perl 5 Porters list with your show of thanks. + +=head1 SEE ALSO + +The F file for an explanation of how to view exhaustive details on +what changed. + +The F file for how to build Perl. + +The F file for general stuff. + +The F and F files for copyright information. + +=cut diff --git a/pod/perlcommunity.pod b/pod/perlcommunity.pod index 9084047270a9..7f1cc0c1b150 100644 --- a/pod/perlcommunity.pod +++ b/pod/perlcommunity.pod @@ -44,7 +44,7 @@ own IRC network, L. General (not help-oriented) chat can be found at L. Many other more specific chats are also hosted on the network. Information about irc.perl.org is located on the network's website: L. For a more help-oriented #perl, -check out L. Most Perl-related channels +check out L. Most Perl-related channels will be kind enough to point you in the right direction if you ask nicely. Any large IRC network (Dalnet, EFnet) is also likely to have a #perl channel, diff --git a/pod/perldata.pod b/pod/perldata.pod index dc9dc6d034bb..7cae8b260945 100644 --- a/pod/perldata.pod +++ b/pod/perldata.pod @@ -444,6 +444,7 @@ integer formats: 0xff # hex 0xdead_beef # more hex 0377 # octal (only numbers, begins with 0) + 0o12_345 # alternative octal (introduced in Perl 5.33.5) 0b011011 # binary 0x1.999ap-4 # hexadecimal floating point (the 'p' is required) diff --git a/pod/perldelta.pod b/pod/perldelta.pod index dfdd7825985c..b021aeac35ee 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -5,15 +5,15 @@ [ this is a template for a new perldelta file. Any text flagged as XXX needs to be processed before release. ] -perldelta - what is new for perl v5.33.4 +perldelta - what is new for perl v5.33.7 =head1 DESCRIPTION -This document describes differences between the 5.33.3 release and the 5.33.4 +This document describes differences between the 5.33.6 release and the 5.33.7 release. -If you are upgrading from an earlier release such as 5.33.2, first read -L, which describes differences between 5.33.2 and 5.33.3. +If you are upgrading from an earlier release such as 5.33.5, first read +L, which describes differences between 5.33.5 and 5.33.6. =head1 Notice @@ -21,9 +21,21 @@ XXX Any important notices here =head1 Core Enhancements -XXX New core language features go here. Summarize user-visible core language -enhancements. Particularly prominent performance optimisations could go -here, but most should go in the L section. +=head2 Experimental Try/Catch Syntax + +An initial experimental attempt at providing C/C notation has +been added. + + use feature 'try'; + + try { + a_function(); + } + catch ($e) { + warn "An error occurred: $e"; + } + +For more information, see L. [ List each enhancement as a =head2 entry ] @@ -330,9 +342,17 @@ L section. =over 4 -=item XXX-some-platform +=item Windows -XXX +Building with mingw.org compilers (version 3.4.5 or later) using mingw runtime +versions < 3.22 now works again. This was broken in Perl 5.31.4. + +Building with mingw.org compilers (version 3.4.5 or later) using mingw runtime +versions >= 3.21 now works (for compilers up to version 5.3.0). + +Makefile.mk, and thus support for dmake, has been removed. It is still possible +to build Perl on Windows using nmake (Makefile) and GNU make (GNUmakefile). +[L] =back @@ -403,7 +423,7 @@ died, add a short obituary here. XXX Generate this with: - perl Porting/acknowledgements.pl v5.33.3..HEAD + perl Porting/acknowledgements.pl v5.33.6..HEAD =head1 Reporting Bugs diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 46e86a1a5ddb..98d159dc2165 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -563,6 +563,15 @@ symbol. Perhaps you need to predeclare a subroutine? compiler saw no other uses of that namespace before that point. Perhaps you need to predeclare a package? +=item Bareword filehandle "%s" not allowed under 'no feature "bareword_filehandles"' + +(F) You attempted to use a bareword filehandle with the +C feature disabled. + +Only the built-in handles C, C, C, C, +C and C can be used with the C +feature disabled. + =item BEGIN failed--compilation aborted (F) An untrapped exception was raised while executing a BEGIN @@ -1675,15 +1684,6 @@ defined in the C<:alias> import argument to C, but they could be defined by a translator installed into C<$^H{charnames}>. See L. -=item charnames alias definitions may not contain trailing white-space; -marked by S<<-- HERE> in %s - -(F) You defined a character name which ended in a space -character. Remove the trailing space(s). Usually these names are -defined in the C<:alias> import argument to C, but they -could be defined by a translator installed into C<$^H{charnames}>. -See L. - =item chdir() on unopened filehandle %s (W unopened) You tried chdir() on a filehandle that was never opened. @@ -2195,6 +2195,20 @@ single form when it must operate on them directly. Either you've passed an invalid file specification to Perl, or you've found a case the conversion routines don't handle. Drat. +=item Error %s in expansion of %s + +(F) An error was encountered in handling a user-defined property +(L). These are +programmer written subroutines, hence subject to errors that may +prevent them from compiling or running. The calls to these subs are +C'd, and if there is a failure, this message is raised, using the +contents of C<$@> from the failed C. + +Another possibility is that tainted data was encountered somewhere in +the chain of expanding the property. If so, the message wording will +indicate that this is the problem. See L. + =item Eval-group in insecure regular expression (F) Perl detected tainted data when trying to compile a regular @@ -2836,6 +2850,16 @@ not match 8 spaces. text. You should check the pattern to ensure that recursive patterns either consume text or fail. +=item Infinite recursion in user-defined property + +(F) A user-defined property (L) can depend on the definitions of other user-defined +properties. If the chain of dependencies leads back to this property, +infinite recursion would occur, were it not for the check that raised +this error. + +Restructure your property definitions to avoid this. + =item Infinite recursion via empty pattern (F) You tried to use the empty pattern inside of a regex code block, @@ -3288,7 +3312,7 @@ line. See L for more details. =item \K not permitted in lookahead/lookbehind in regex; marked by <-- HERE in m/%s/ -(F) Your regular expression used C<\K> in a lookhead or lookbehind +(F) Your regular expression used C<\K> in a lookahead or lookbehind assertion, which currently isn't permitted. This may change in the future, see L or C<--> is unchanged. Perl issues this +(W imprecision) You attempted to increment or decrement a value by one, +but the result is too large for the underlying floating point +representation to store accurately. Hence, the target of C<++> or C<--> +is increased or decreased by quite different value than one, such as +zero (I the target is unchanged) or two, due to rounding. +Perl issues this warning because it has already switched from integers to floating point when values are too large for integers, and now even floating point is insufficient. You may wish to switch to using L explicitly. @@ -6270,6 +6297,20 @@ lexicals that are initialized only once (see L): This use of C in a false conditional was deprecated beginning in Perl 5.10 and became a fatal error in Perl 5.30. +=item Timeout waiting for another thread to define \p{%s} + +(F) The first time a user-defined property +(L) is used, its +definition is looked up and converted into an internal form for more +efficient handling in subsequent uses. There could be a race if two or +more threads tried to do this processing nearly simultaneously. +Instead, a critical section is created around this task, locking out all +but one thread from doing it. This message indicates that the thread +that is doing the conversion is taking an unexpectedly long time. The +timeout exists solely to prevent deadlock; it's long enough that the +system was likely thrashing and about to crash. There is no real remedy but +rebooting. + =item times not implemented (F) Your version of the C library apparently doesn't do times(). I @@ -6307,14 +6348,20 @@ See L. (F) There has to be at least one argument to syscall() to specify the system call to call, silly dilly. -=item Too few arguments for subroutine '%s' +=item Too few arguments for subroutine '%s' (got %d; expected %d) (F) A subroutine using a signature fewer arguments than required by the signature. The caller of the subroutine is presumably at fault. The message attempts to include the name of the called subroutine. If the subroutine has been aliased, the subroutine's original name will be -shown, regardless of what name the caller used. +shown, regardless of what name the caller used. It will also indicate the +number of arguments given and the number expected. + +=item Too few arguments for subroutine '%s' (got %d; expected at least %d) + +Similar to the previous message but for subroutines that accept a variable +number of arguments. =item Too late for "-%s" option @@ -6346,14 +6393,20 @@ BEGIN block. (F) The function requires fewer arguments than you specified. -=item Too many arguments for subroutine '%s' +=item Too many arguments for subroutine '%s' (got %d; expected %d) (F) A subroutine using a signature received more arguments than permitted by the signature. The caller of the subroutine is presumably at fault. The message attempts to include the name of the called subroutine. If the subroutine has been aliased, the subroutine's original name will be shown, -regardless of what name the caller used. +regardless of what name the caller used. It will also indicate the number +of arguments given and the number expected. + +=item Too many arguments for subroutine '%s' (got %d; expected at most %d) + +Similar to the previous message but for subroutines that accept a variable +number of arguments. =item Too many nested open parens in regex; marked by <-- HERE in m/%s/ @@ -6400,6 +6453,12 @@ disallowed. See L. (F) Your machine doesn't implement a file truncation mechanism that Configure knows about. +=item try/catch is experimental + +(S experimental::try) This warning is emitted if you use the C and +C syntax. This syntax is currently experimental and its behaviour may +change in future releases of Perl. + =item Type of arg %d to &CORE::%s must be %s (F) The subroutine in question in the CORE package requires its argument @@ -6831,6 +6890,13 @@ for the list of known options. Llist]> documentation of the C<-C> switch for the list of known options. +=item Unknown user-defined property name \p{%s} + +(F) You specified to use a property within the C<\p{...}> which was a +syntactically valid user-defined property, but no definition was found +for it by the time one was required to proceed. Check your spelling. +See L. + =item Unknown verb pattern '%s' in regex; marked by S<<-- HERE> in m/%s/ (F) You either made a typo or have incorrectly put a C<*> quantifier diff --git a/pod/perldocstyle.pod b/pod/perldocstyle.pod new file mode 100644 index 000000000000..f239ba166ea9 --- /dev/null +++ b/pod/perldocstyle.pod @@ -0,0 +1,1118 @@ +=encoding utf8 + +=head1 NAME + +perldocstyle - A style guide for writing Perl's documentation + +=head1 DESCRIPTION + +This document is a guide for the authorship and maintenance of the +documentation that ships with Perl. This includes the following: + +=over + +=item * + +The several dozen manual sections whose filenames begin with "C", +such as C, C, and C. (And, yes, C.) + +=item * + +The documentation for all the modules included with Perl (as listed by +L|perlmodlib>). + +=item * + +The hundreds of individually presented reference sections derived from +the L|perlfunc> file. + +=back + +This guide will hereafter refer to user-manual section files as I, per Unix convention. + +=head2 Purpose of this guide + +This style guide aims to establish standards, procedures, and philosophies +applicable to Perl's core documentation. + +Adherence to these standards will help ensure that any one part of +Perl's manual has a tone and style consistent with that of any other. As +with the rest of the Perl project, the language's documentation +collection is an open-source project authored over a long period of time +by many people. Maintaining consistency across such a wide swath of work +presents a challenge; this guide provides a foundation to help mitigate +this difficulty. + +This will help its readers--especially those new to Perl--to feel +more welcome and engaged with Perl's documentation, and this in turn +will help the Perl project itself grow stronger through having a larger, +more diverse, and more confident population of knowledgeable users. + +=head2 Intended audience + +Anyone interested in contributing to Perl's core documentation should +familiarize themselves with the standards outlined by this guide. + +Programmers documenting their own work apart from the Perl project +itself may also find this guide worthwhile, especially if they wish +their work to extend the tone and style of Perl's own manual. + +=head2 Status of this document + +This guide was initially drafted in late 2020, drawing from the +documentation style guides of several open-source technologies +contemporary with Perl. This has included Python, Raku, Rust, and the +Linux kernel. + +The author intends to see this guide used as starting place from +which to launch a review of Perl's reams of extant documentation, with +the expectation that those conducting this review should grow and modify +this guide as needed to account for the requirements and quirks +particular to Perl's programming manual. + +=head1 FUNDAMENTALS + +=head2 Choice of markup: Pod + +All of Perl's core documentation uses Pod ("Plain Old Documentation"), a +simple markup language, to format its source text. Pod is similar in +spirit to other contemporary lightweight markup technologies, such as +Markdown and reStructuredText, and has a decades-long shared history +with Perl itself. + +For a comprehensive reference to Pod syntax, see L|perlpod>. +For the sake of reading this guide, familiarity with the Pod syntax for +section headers (C<=head2>, et cetera) and for inline text formatting +(Clike thisE>) should suffice. + +Perl programmers also use Pod to document their own scripts, libraries, +and modules. This use of Pod has its own style guide, outlined by +L|perlpodstyle>. + +=head2 Choice of language: American English + +Perl's core documentation is written in English, with a preference for +American spelling of words and expression of phrases. That means "color" +over "colour", "math" versus "maths", "the team has decided" and not +"the team have decided", and so on. + +We name one style of English for the sake of consistency across Perl's +documentation, much as a software project might declare a four-space +indentation standard--even when that doesn't affect how well the code +compiles. Both efforts result in an easier read by avoiding jarring, +mid-document changes in format or style. + +Contributors to Perl's documentation should note that this rule +describes the ultimate, published output of the project, and does not +prescribe the dialect used within community contributions. The +documentation team enthusiastically welcomes any English-language +contributions, and will actively assist in Americanizing spelling and +style when warranted. + +=head3 Other languages and translations + +Community-authored translations of Perl's documentation do exist, +covering a variety of languages. While the Perl project appreciates +these translation efforts and promotes them when applicable, it does not +officially support or maintain any of them. + +That said, keeping Perl's documentation clear, simple, and short has a +welcome side effect of aiding any such translation project. + +(Note that the Chinese, Japanese, and Korean-language README files +included with Perl's source distributions provide an exception to this +choice of language--but these documents fall outside the scope of this +guide.) + +=head2 Choice of encoding: UTF-8 + +Perl's core documentation files are encoded in UTF-8, and can make use +of the full range of characters this encoding allows. + +As such, every core doc file (or the Pod section of every core module) +should commence with an C<=encoding utf8> declaration. + +=head2 Choice of underlying style guide: CMOS + +Perl's documentation uses the L (CMOS), 17th Edition, as +its baseline guide for style and grammar. While the document you are +currently reading endeavors to serve as an adequate stand-alone style guide +for the purposes of documenting Perl, authors should consider CMOS the +fallback authority for any pertinent topics not covered here. + +Because CMOS is not a free resource, access to it is not a prerequisite +for contributing to Perl's documentation; the doc team will help +contributors learn about and apply its guidelines as needed. However, we +do encourage anyone interested in significant doc contributions to +obtain or at least read through CMOS. (Copies are likely available +through most public libraries, and CMOS-derived fundamentals can be +found online as well.) + +=head2 Contributing to Perl's documentation + +Perl, like any programming language, is only as good as its +documentation. Perl depends upon clear, friendly, and thorough +documentation in order to welcome brand-new users, teach and explain the +language's various concepts and components, and serve as a lifelong +reference for experienced Perl programmers. As such, the Perl project +welcomes and values all community efforts to improve the language's +documentation. + +Perl accepts documentation contributions through the same open-source +project pipeline as code contributions. See L|perlhack> for +more information. + +=head1 FORMATTING AND STRUCTURE + +This section details specific Pod syntax and style that all core Perl +documentation should adhere to, in the interest of consistency and +readability. + +=head2 Document structure + +Each individual work of core Perl documentation, whether contained +within a C<.pod> file or in the Pod section of a standard code module, +patterns its structure after a number of long-time Unix man page +conventions. (Hence this guide's use of "man page" to refer to any one +self-contained part of Perl's documentation.) + +Adhering to these conventions helps Pod formatters present a Perl man +page's content in different contexts--whether a terminal, the web, or +even print. Many of the following requirements originate with +L|perlpodstyle>, which derives its recommendations in +turn from these well-established practices. + +=head3 Name + +After its L declaration|/Choice of encoding: UTF-8>, a +Perl man page I present a level-one header named "NAME" (literally), +followed by a paragraph containing the page's name and a very brief +description. + +The first few lines of a notional page named C: + + =encoding utf8 + + =head1 NAME + + perlpodexample - An example of formatting a manual page's title line + +=head3 Description and synopsis + +Most Perl man pages also contain a DESCRIPTION section featuring a +summary of, or introduction to, the document's content and purpose. + +This section should also, one way or another, clearly identify the +audience that the page addresses, especially if it has expectations +about the reader's prior knowledge. For example, a man page that dives +deep into the inner workings of Perl's regular expression engine should +state its assumptions up front--and quickly redirect readers who are +instead looking for a more basic reference or tutorial. + +Reference pages, when appropriate, can precede the DESCRIPTION with a +SYNOPSIS section that lists, within one or more code blocks, some very +brief examples of the referenced feature's use. This section should show +a handful of common-case and best-practice examples, rather than an +exhaustive list of every obscure method or alternate syntax available. + +=head3 Other sections and subsections + +Pages should conclude, when appropriate, with a SEE ALSO section +containing hyperlinks to relevant sections of Perl's manual, other Unix +man pages, or appropriate web pages. Hyperlink each such cross-reference via +C...E>. + +What other sections to include depends entirely upon the topic at hand. +Authors should feel free to include further C<=head1>-level sections, +whether other standard ones listed by C, or ones specific +to the page's topic; in either case, render these top-level headings in +all-capital letters. + +You may then include as many subsections beneath them as needed to meet +the standards of clarity, accessibility, and cross-reference affinity +L. + +=head3 Author and copyright + +In most circumstances, Perl's stand-alone man pages--those contained +within C<.pod> files--do not need to include any copyright or license +information about themselves. Their source Pod files are part of Perl's +own core software repository, and that already covers them under the +same copyright and license terms as Perl itself. You do not need to +include additional "LICENSE" or "COPYRIGHT" sections of your own. + +These man pages may optionally credit their primary author, or include a +list of significant contributors, under "AUTHOR" or "CONTRIBUTORS" +headings. Note that the presence of authors' names does not preclude a +given page from L. + +Note that these guidelines do not apply to the core software modules +that ship with Perl. These have their own standards for authorship and +copyright statements, as found in C. + +=head2 Formatting rules + +=head3 Line length and line wrap + +Each line within a Perl man page's Pod source file should measure 72 +characters or fewer in length. + +Please break paragraphs up into blocks of short lines, rather than +"soft wrapping" paragraphs across hundreds of characters with no line +breaks. + +=head3 Code blocks + +Just like the text around them, all code examples should be as short and +readable as possible, displaying no more complexity than absolutely +necessary to illustrate the concept at hand. + +For the sake of consistency within and across Perl's man pages, all +examples must adhere to the code-layout principles set out by +L|perlstyle>. + +Sample code should deviate from these standards only when necessary: +during a demonstration of how Perl disregards whitespace, for example, +or to temporarily switch to two-column indentation for an unavoidably +verbose illustration. + +You may include comments within example code to further clarify or label +the code's behavior in-line. You may also use comments as placeholder +for code normally present but not relevant to the current topic, like +so: + + while (my $line = <$fh>) { + # + # (Do something interesting with $line here.) + # + } + +Even the simplest code blocks often require the use of example +variables and subroutines, L. + +=head3 Inline code and literals + +Within a paragraph of text, use C...E> when quoting or +referring to any bit of Perl code--even if it is only one character +long. + +For instance, when referring within an explanatory paragraph to Perl's +operator for adding two numbers together, you'd write "C+E>". + +=head3 Function names + +Use C...E> to render all Perl function names in monospace, +whenever they appear in text. + +Unless you need to specifically quote a function call with a list of +arguments, do not follow a function's name in text with a pair of empty +parentheses. That is, when referring in general to Perl's C +function, write it as "C", not "C". + +=head3 Function arguments + +Represent functions' expected arguments in all-caps, with no sigils, and +using C...E> to render them in monospace. These arguments +should have short names making their nature and purpose clear. +Convention specifies a few ones commonly seen throughout Perl's +documentation: + +=over + +=item * + +EXPR + +The "generic" argument: any scalar value, or a Perl expression that +evaluates to one. + +=item * + +ARRAY + +An array, stored in a named variable. + +=item * + +HASH + +A hash, stored in a named variable. + +=item * + +BLOCK + +A curly-braced code block, or a subroutine reference. + +=item * + +LIST + +Any number of values, stored across any number of variables or +expressions, which the function will "flatten" and treat as a single +list. (And because it can contain any number of variables, it must be +the I argument, when present.) + +=back + +When possible, give scalar arguments names that suggest their purpose +among the arguments. See, for example, L's +documentation|perlfunc/substr>, whose +listed arguments include C, C, C, and C. + +=head3 Apostrophes, quotes, and dashes + +In Pod source, use straight quotes, and not "curly quotes": "Like + this", not “like this”. The same goes for apostrophes: Here's a + positive example, and here’s a negative one. + +Render em dashes as two hyphens--like this: + + Render em dashes as two hyphens--like this. + +Leave it up to formatters to reformat and reshape these punctuation +marks as best fits their respective target media. + +=head3 Unix programs and C functions + +When referring to a Unix program or C function with its own man page +(outside of Perl's documentation), include its manual section number in +parentheses. For example: C, or C. + +If mentioning this program for the first time within a man page or +section, make it a cross reference, e.g. Cmalloc(3)E>. + +Do not otherwise style this text. + +=head3 Cross-references and hyperlinks + +Make generous use of Pod's C...E> syntax to create hyperlinks +to other parts of the current man page, or to other documents entirely +-- whether elsewhere on the reader's computer, or somewhere on the +internet, via URL. + +Use C...E> to link to another section of the current man page +when mentioning it, and make use of its page-and-section syntax to link to +the most specific section of a separate page within Perl's +documentation. Generally, the first time you refer to a specific +function, program, or concept within a certain page or section, consider +linking to its full documentation. + +Hyperlinks do not supersede other formatting required by this guide; Pod +allows nested text formats, and you should use this feature as needed. + +Here is an example sentence that mentions Perl's C function, with a +link to its documentation section within the C man page: + + In version 5.10, Perl added support for the + L|perlfunc/say FILEHANDLE LIST> function. + +Note the use of the vertical pipe ("C<|>") to separate how the link will +appear to readers ("CsayE>") from the full page-and-section specifier +that the formatter links to. + +=head3 Tables and diagrams + +Pod does not officially support tables. To best present tabular data, +include the table as both HTML and plain-text representations--the +latter as an indented code block. Use C<=begin> / C<=end> directives to +target these tables at C and C Pod formatters, respectively. +For example: + + =head2 Table of fruits + + =begin text + + Name Shape Color + ===================================== + Apple Round Red + Banana Long Yellow + Pear Pear-shaped Green + + =end text + + =begin html + + + + + + +
NameShapeColor
AppleRoundRed
BananaLongYellow
PearPear-shapedGreen
+ + =end html + +The same holds true for figures and graphical illustrations. Pod does +not natively support inline graphics, but you can mix HTML C<<< >>> tags +with monospaced text-art representations of those images' content. + +Due in part to these limitations, most Perl man pages use neither tables +nor diagrams. Like any other tool in your documentation toolkit, +however, you may consider their inclusion when they would improve an +explanation's clarity without adding to its complexity. + +=head2 Adding comments + +Like any other kind of source code, Pod lets you insert comments visible +only to other people reading the source directly, and ignored by the +formatting programs that transform Pod into various human-friendly +output formats (such as HTML or PDF). + +To comment Pod text, use the C<=for> and C<=begin> / C<=end> Pod +directives, aiming them at a (notional) formatter called "C". A +couple of examples: + + =for comment Using "=for comment" like this is good for short, + single-paragraph comments. + + =begin comment + + If you need to comment out more than one paragraph, use a + =begin/=end block, like this. + + None of the text or markup in this whole example would be visible to + someone reading the documentation through normal means, so it's + great for leaving notes, explanations, or suggestions for your + fellow documentation writers. + + =end comment + +In the tradition of any good open-source project, you should make free +but judicious use of comments to leave in-line "meta-documentation" as +needed for other Perl documentation writers (including your future +self). + +=head2 Perlfunc has special rules + +The L man page|perlfunc>, an exhaustive reference of every +Perl built-in function, has a handful of formatting rules not seen +elsewhere in Perl's documentation. + +Software used during Perl's build process +(L) parses this page according to certain +rules, in order to build separate man pages for each of Perl's +functions, as well as achieve other indexing effects. As such, +contributors to perlfunc must know about and adhere to its particular +rules. + +Most of the perfunc man page comprises a single list, found under the +header L<"Alphabetical Listing of Perl Functions"|perlfunc/Alphabetical +Listing of Perl Functions>. Each function reference is an entry on that +list, made of three parts, in order: + +=over + +=item 1. + +A list of C<=item> lines which each demonstrate, in template format, a +way to call this function. One line should exist for every combination +of arguments that the function accepts (including no arguments at all, +if applicable). + +If modern best practices prefer certain ways to invoke the function +over others, then those ways should lead the list. + +The first item of the list should be immediately followed by one or +more C...E> terms listing index-worthy topics; if nothing +else, then the name of the function, with no arguments. + +=item 2. + +A C<=for> line, directed at C, containing a one-line +description of what the function does. This is written as a phrase, led +with an imperative verb, with neither leading capitalization nor ending +punctuation. Examples include "quote a list of words" and "change a +filename". + +=item 3. + +The function's definition and reference material, including all +explanatory text and code examples. + +=back + +Complex functions that need their text divided into subsections (under +the principles of L<"Apply section-breaks and examples +generously"|/Apply section-breaks and examples generously>) may do so by +using sublists, with C<=item> elements as header text. + +A fictional function "C", which takes a list as an optional +argument, might have an entry in perlfunc shaped like this: + + =item myfunc LIST + X + + =item myfunc + + =for Pod::Functions demonstrate a function's perlfunc section + + [ Main part of function definition goes here, with examples ] + + =over + + =item Legacy uses + + [ Examples of deprecated syntax still worth documenting ] + + =item Security considerations + + [ And so on... ] + + =back + +=head1 TONE AND STYLE + +=head2 Apply one of the four documentation modes + +Aside from "meta" documentation such as C or C, +each of Perl's man pages should conform to one of the four documentation +"modes" suggested by L by Daniele +Procida|https://documentation.divio.com>. These include tutorials, +cookbooks, explainers, and references--terms that we define in further +detail below. + +Each mode of documentation speaks to a different audience--not just +people of different backgrounds and skill levels, but individual readers +whose needs from language documentation can shift depending upon +context. For example, a programmer with plenty of time to learn a new +concept about Perl can ease into a tutorial about it, and later expand +their knowledge further by studying an explainer. Later, that same +programmer, wading knee-deep in live code and needing only to look up +some function's exact syntax, will want to reach for a reference page +instead. + +Perl's documentation must strive to meet these different situational +expectations by limiting each man page to a single mode. This helps +writers ensure they provide readers with the documentation needed or +expected, despite ever-evolving situations. + +=head3 Tutorial + +A tutorial man page focuses on B, ideally by I. It +presents the reader with small, interesting examples that allow them to +follow along themselves using their own Perl interpreter. The tutorial +inspires comprehension by letting its readers immediately experience +(and experiment on) the concept in question. Examples include +C, C, and +C. + +Tutorial man pages must strive for a welcoming and reassuring tone from +their outset; they may very well be the first things that a newcomer to +Perl reads, playing a significant role in whether they choose +to stick around. Even an experienced programmer can benefit from the +sense of courage imparted by a strong tutorial about a more advanced +topic. After completing a tutorial, a reader should feel like they've +been led from zero knowledge of its topic to having an invigorating +spark of basic understanding, excited to learn more and experiment +further. + +Tutorials can certainly use real-world examples when that helps make for +clear, relatable demonstrations, so long as they keep the focus on +teaching--more practical problem-solving should be left to the realm +of cookbooks (as described below). Tutorials also needn't concern +themselves with explanations into why or how things work beneath the +surface, or explorations of alternate syntaxes and solutions; these are +better handled by explainers and reference pages. + +=head3 Cookbook + +A cookbook man page focuses on B. Just like its name suggests, +it presents succinct, step-by-step solutions to a variety of real-world +problems around some topic. A cookbook's code examples serve less to +enlighten and more to provide quick, paste-ready solutions that the +reader can apply immediately to the situation facing them. + +A Perl cookbook demonstrates ways that all the tools and techniques +explained elsewhere can work together in order to achieve practical +results. Any explanation deeper than that belongs in explainers and +reference pages, instead. (Certainly, a cookbook can cross-reference +other man pages in order to satisfy the curiosity of readers who, with +their immediate problems solved, wish to learn more.) + +The most prominent cookbook pages that ship with Perl itself are its +many FAQ pages, in particular C and up, which provide short +solutions to practical questions in question-and-answer style. +C shows another example, containing a bevy of practical code +snippets for a variety of internationally minded text manipulations. + +(An aside: I calls this mode "how-to", but +Perl's history of creative cuisine prefers the more kitchen-ready term +that we employ here.) + +=head3 Reference + +A reference page focuses on B. Austere, uniform, and +succinct, reference pages--often arranged into a whole section of +mutually similar subpages--lend themselves well to "random access" by +a reader who knows precisely what knowledge they need, requiring only +the minimum amount of information before returning to the task at hand. + +Perl's own best example of a reference work is C, the +sprawling man page that details the operation of every function built +into Perl, with each function's documentation presenting the same kinds +of information in the same order as every other. For an example of a +shorter reference on a single topic, look at C. + +Module documentation--including that of all the modules listed in +L|perlmodlib>--also counts as reference. They follow +precepts similar to those laid down by the C man page, such +as opening with an example-laden "SYNOPSIS" section, or featuring a +"METHODS" section that succinctly lists and defines an object-oriented +module's public interface. + +=head3 Explainer + +Explainer pages focus on B. Each explainer dives as deep as +needed into some Perl-relevant topic, taking all the time and space +needed to give the reader a thorough understanding of it. Explainers +mean to impart knowledge through study. They don't assume that the +student has a Perl interpreter fired up and hungry for immediate examples +(as with a tutorial), or specific Perl problems that they need quick +answers for (which cookbooks and reference pages can help with). + +Outside of its reference pages, most of Perl's manual belongs to this +mode. This includes the majority of the man pages whose names start with +"C". A fine example is C, the Perl Syntax page, which +explores the whys and wherefores of Perl's unique syntax in a +wide-ranging discussion laden with many references to the language's +history, culture, and driving philosophies. + +Perl's explainer pages give authors a chance to explore Perl's penchant +for L, illustrating alternate and even +obscure ways to use the language feature under discussion. However, as +the remainder of this guide discusses, the ideal Perl documentation +manages to deliver its message clearly and concisely, and not confuse +mere wordiness for completeness. + +=head3 Further notes on documentation modes + +Keep in mind that the purpose of this categorization is not to dictate +content--a very thorough explainer might contain short reference +sections of its own, for example, or a reference page about a very +complex function might resemble an explainer in places (e.g. +L|perlfunc/open FILEHANDLE,MODE,EXPR>). Rather, it makes sure +that the authors and contributors of any given man page agree on what +sort of audience that page addresses. + +If a new or otherwise uncategorized man page presents itself as +resistant to fitting into only one of the four modes, consider breaking +it up into separate pages. That may mean creating a new "C" +man page, or (in the case of module documentation) making new packages +underneath that module's namespace that serve only to hold additional +documentation. For instance, C's reference documentation +might include a see-also link to C. + +Perl's several man pages about Unicode--comprising a short tutorial, a +thorough explainer, a cookbook, and a FAQ--provide a fine example of +spreading a complicated topic across several man pages with different +and clearly indicated purposes. + +=head2 Assume readers' intelligence, but not their knowledge + +Perl has grown a great deal from its humble beginnings as a tool for +people already well versed in C programming and various Unix utilities. +Today, a person learning Perl might come from any social or +technological background, with a range of possible motivations +stretching far beyond system administration. + +Perl's core documentation must recognize this by making as few +assumptions as possible about the reader's prior knowledge. While you +should assume that readers of Perl's documentation are smart, curious, +and eager to learn, you should not confuse this for pre-existing +knowledge about any other technology, or even programming in +general--especially in tutorial or introductory material. + +=head3 Keep Perl's documentation about Perl + +Outside of pages tasked specifically with exploring Perl's relationship +with other programming languages, the documentation should keep the +focus on Perl. Avoid drawing analogies to other technologies that the +reader may not have familiarity with. + +For example, when documenting one of Perl's built-in functions, write as +if the reader is now learning about that function for the first time, in +any programming language. + +Choosing to instead compare it to an equivalent or underlying C function +will probably not illuminate much understanding in a contemporary +reader. Worse, this can risk leaving readers unfamiliar with C feeling +locked out from fully understanding of the topic--to say nothing of +readers new to computer programming altogether. + +If, however, that function's ties to its C roots can lead to deeper +understanding with practical applications for a Perl programmer, you may +mention that link after its more immediately useful documentation. +Otherwise, omit this information entirely, leaving it for other +documentation or external articles more concerned with examining Perl's +underlying implementation details. + +=head3 Deploy jargon when needed, but define it as well + +Domain-specific jargon has its place, especially within documentation. +However, if a man page makes use of jargon that a typical reader might +not already know, then that page should make an effort to define the +term in question early-on--either explicitly, or via cross reference. + +For example, Perl loves working with filehandles, and as such that word +appears throughout its documentation. A new Perl programmer arriving at +a man page for the first time is quite likely to have no idea what a +"filehandle" is, though. Any Perl man page mentioning filehandles +should, at the very least, hyperlink that term to an explanation +elsewhere in Perl's documentation. If appropriate--for example, in the +lead-in to L function's detailed reference|perlfunc/open +FILEHANDLE,MODE,EXPR>--it can also include a very short in-place +definition of the concept for the reader's convenience. + +=head2 Use meaningful variable and symbol names in examples + +When quickly sketching out examples, English-speaking programmers have a +long tradition of using short nonsense words as placeholders for +variables and other symbols--such as the venerable C, C, and +C. Example code found in a programming language's official, +permanent documentation, however, can and should make an effort to +provide a little more clarity through specificity. + +Whenever possible, code examples should give variables, classes, and +other programmer-defined symbols names that clearly demonstrate their +function and their relationship to one another. For example, if an +example requires that one class show an "is-a" relationship with +another, consider naming them something like C and C, rather +than C and C. Similarly, sample code creating an instance of +that class would do better to name it C<$apple>, rather than C<$baz>. + +Even the simplest examples benefit from clear language using concrete +words. Prefer a construct like C over +C. + +=head2 Write in English, but not just for English-speakers + +While this style guide does specify American English as the +documentation's language for the sake of internal consistency, authors +should avoid cultural or idiomatic references available only to +English-speaking Americans (or any other specific culture or society). +As much as possible, the language employed by Perl's core documentation +should strive towards cultural universality, if not neutrality. Regional +turns of phrase, examples drawing on popular-culture knowledge, and +other rhetorical techniques of that nature should appear sparingly, if +at all. + +Authors should feel free to let more freewheeling language flourish in +"second-order" documentation about Perl, like books, blog entries, and +magazine articles, published elsewhere and with a narrower readership in +mind. But Perl's own docs should use language as accessible and +welcoming to as wide an audience as possible. + +=head2 Omit placeholder text or commentary + +Placeholder text does not belong in the documentation that ships with +Perl. No section header should be followed by text reading only "Watch +this space", "To be included later", or the like. While Perl's source +files may shift and alter as much as any other actively maintained +technology, each released iteration of its technology should feel +complete and self-contained, with no such future promises or other loose +ends visible. + +Take advantage of Perl's regular release cycle. Instead of cluttering +the docs with flags promising more information later--the presence of +which do not help readers at all today--the documentation's +maintenance team should treat any known documentation absences as an +issue to address like any other in the Perl project. Let Perl's +contributors, testers, and release engineers address that need, and +resist the temptation to insert apologies, which have all the utility in +documentation as undeleted debug messages do in production code. + +=head2 Apply section-breaks and examples generously + +No matter how accessible their tone, the sight of monolithic blocks of +text in technical documentation can present a will-weakening challenge +for the reader. Authors can improve this situation through breaking long +passages up into subsections with short, meaningful headers. + +Since every section-header in Pod also acts as a potential end-point for +a cross-reference (made via Pod's C...E> syntax), putting +plenty of subsections in your documentation lets other man pages more +precisely link to a particular topic. This creates hyperlinks directly +to the most appropriate section rather than to the whole page in +general, and helps create a more cohesive sense of a rich, consistent, +and interrelated manual for readers. + +Among the four documentation modes, sections belong more naturally in +tutorials and explainers. The step-by-step instructions of cookbooks, or +the austere definitions of reference pages, usually have no room for +them. But authors can always make exceptions for unusually complex +concepts that require further breakdown for clarity's sake. + +Example code, on the other hand, can be a welcome addition to any mode +of documentation. Code blocks help break up a man page visually, +reassuring the reader that no matter how deep the textual explanation +gets, they are never far from another practical example showing how it +all comes together using a small, easy-to-read snippet of tested Perl +code. + +=head2 Lead with common cases and best practices + +Perl famously gives programmers more than one way to do things. Like any +other long-lived programming language, Perl has also built up a large, +community-held notion of best practices, blessing some ways to do things +as better than others, usually for the sake of more maintainable code. + +=head3 Show the better ways first + +Whenever it needs to show the rules for a technique which Perl provides +many avenues for, the documentation should always lead with best +practices. And when discussing some part of the Perl toolkit with many +applications, the docs should begin with a demonstration of its +application to the most common cases. + +The C function, for example, has myriad potential uses within Perl +programs, but I programmers--and especially those new +to Perl--turn to this reference because they simply wish to open a +file for reading or writing. For this reason, C's documentation +begins there, and only descends into the function's more obscure uses +after thoroughly documenting and demonstrating how it works in the +common case. Furthermore, while engaging in this demonstration, the +C documentation does not burden the reader right away with detailed +explanations about calling C via any route other than the +best-practice, three-argument style. + +=head3 Show the lesser ways when needed + +Sometimes, thoroughness demands documentation of deprecated techniques. +For example, a certain Perl function might have an alternate syntax now +considered outmoded and no longer best-practice, but which a maintainer +of a legacy project might quite reasonably encounter when exploring old +code. In this case, these features deserve documentation, but couched in +clarity that modern Perl avoids such structures, and does not recommend +their use in new projects. + +Another way to look at this philosophy (and one L on +Python's documentation team) involves writing while sympathizing with a +programmer new to Perl, who may feel uncertain about learning a complex +concept. By leading that concept's main documentation with clear, +positive examples, we can immediately give these readers a simple and +true picture of how it works in Perl, and boost their own confidence to +start making use of this new knowledge. Certainly we should include +alternate routes and admonitions as reasonably required, but we needn't +emphasize them. Trust the reader to understand the basics quickly, and +to keep reading for a deeper understanding if they feel so driven. + +=head2 Document Perl's present + +Perl's documentation should stay focused on Perl's present behavior, +with a nod to future directions. + +=head3 Recount the past only when necessary + +=for comment +The principles of this section caused a lot of lively discussion and +debate among p5p when first proposed in October 2020. I am keeping the +recommendations nonspecific, and expect this section to receive a lot of +further refinement as we start to apply it to core docs. + +When some Perl feature changes its behavior, documentation about +that feature should change too, and just as definitively. The docs have +no obligation to keep descriptions of past behavior hanging around, even if +attaching clauses like "Prior to version 5.10, [...]". + +Since Perl's core documentation is part of Perl's source distribution, +it enjoys the same benefits of versioning and version-control as the +source code of Perl itself. Take advantage of this, and update the text +boldly when needed. Perl's history remains safe, even when you delete or +replace outdated information from the current version's docs. + +Perl's docs can acknowledge or discuss former behavior when warranted, +including notes that some feature appeared in the language as of some +specific version number. Authors should consider applying principles +similar to those for deprecated techniques, L: make the information present, but not +prominent. + +Otherwise, keep the past in the past. A manual uncluttered with +outdated instruction stays more succinct and relevant. + +=head3 Describe the uncertain future with care + +Perl features marked as "experimental"--those that generate warnings +when used in code not invoking the L|experimental> +pragma--deserve documentation, but only in certain contexts, and even +then with caveats. These features represent possible new directions for +Perl, but they have unstable interfaces and uncertain future presence. + +The documentation should take both implications of "experimental" +literally. It should not discourage these features' use by programmers +who wish to try out new features in projects that can risk their +inherent instability; this experimentation can help Perl grow and +improve. By the same token, the docs should downplay these features' use +in just about every other context. + +Introductory or overview material should omit coverage of experimental +features altogether. + +More thorough reference materials or explanatory articles can include +experimental features, but needs to clearly mark them as such, and not +treat them with the same prominence as Perl's stable features. Using +unstable features seldom coincides with best practices, and +documentation that L should reflect this. + +=head2 The documentation speaks with one voice + +Even though it comes from many hands and minds, criss-crossing through +the many years of Perl's lifetime, the language's documentation should +speak with a single, consistent voice. With few exceptions, the docs +should avoid explicit first-person-singular statements, or similar +self-reference to any individual's contributor's philosophies or +experiences. + +Perl did begin life as a deeply personal expression by a single +individual, and this famously carried through the first revisions of its +documentation as well. Today, Perl's community understands that the +language's continued development and support comes from many people +working in concert, rather than any one person's vision or effort. Its +documentation should not pretend otherwise. + +The documentation should, however, carry forward the best tradition that +Larry Wall set forth in the language's earliest days: Write both +economically and with a humble, subtle wit, resulting in a technical +manual that mixes concision with a friendly approachability. It avoids +the dryness that one might expect from technical documentation, while +not leaning so hard into overt comedy as to distract and confuse from +the nonetheless-technical topics at hand. + +Like the best written works, Perl's documentation has a soul. Get +familiar with it as a reader to internalize its voice, and then find +your own way to express it in your own contributions. Writing clearly, +succinctly, and with knowledge of your audience's expectations will get +you most of the way there, in the meantime. + +Every line in the docs--whether English sentence or Perl +statement--should serve the purpose of bringing understanding to the +reader. Should a sentence exist mainly to make a wry joke that doesn't +further the reader's knowledge of Perl, set it aside, and consider +recasting it into a personal blog post or other article instead. + +Write with a light heart, and a miserly hand. + +=head1 INDEX OF PREFERRED TERMS + +L, this guide +"inherits" all the preferred terms listed in the Chicago Manual of +Style, 17th edition, and adds the following terms of particular interest +to Perl documentation. + +=over + +=item built-in function + +Not "builtin". + +=item Darwin + +See L. + +=item macOS + +Use this term for Apple's operating system instead of "Mac OS X" or +variants thereof. + +This term is also preferable to "Darwin", unless one needs to refer +to macOS's Unix layer specifically. + +=item man page + +One unit of Unix-style documentation. Not "manpage". Preferable to "manual page". + +=item Perl; perl + +The name of the programming language is Perl, with a leading capital +"P", and the remainder in lowercase. (Never "PERL".) + +The interpreter program that reads and executes Perl code is named +"C", in lowercase and in monospace (as with any other command +name). + +Generally, unless you are specifically writing about the +command-line C progam (as, for example, L|perlrun> +does), use "Perl" instead. + +=item Perl 5 + +Documentation need not follow Perl's name with a "5", or any other +number, except during discussions of Perl's history, future plans, +or explicit comparisons between major Perl versions. + +Before 2019, specifying "Perl 5" was sometimes needed to distinguish +the language from Perl 6. With the latter's renaming to "Raku", this +practice became unnecessary. + +=item Perl 6 + +See L. + +=item Perl 5 Porters, the; porters, the; p5p + +The full name of the team responsible for Perl's ongoing maintenance +and development is "the Perl 5 Porters", and this sobriquet should +be spelled out in the first mention within any one document. It may +thereafter call the team "the porters" or "p5p". + +Not "Perl5 Porters". + +=item program + +The most general descriptor for a stand-alone work made out of +executable Perl code. Synonymous with, and preferable to, "script". + +=item Raku + +Perl's "sister language", whose homepage is L. + +Previously known as "Perl 6". In 2019, its design team renamed the +language to better reflect its identity as a project independent from +Perl. As such, Perl's documentation should always refer to this language +as "Raku" and not "Perl 6". + +=item script + +See L. + +=item semicolon + +Perl code's frequently overlooked punctuation mark. Not "semi-colon". + +=item Unix + +Not "UNIX", "*nix", or "Un*x". Applicable to both the original operating +system from the 1970s as well as all its conceptual descendants. You may +simply write "Unix" and not "a Unix-like operating system" when +referring to a Unix-like operating system. + +=back + +=head1 SEE ALSO + +=over + +=item * + +L + +=item * + +L + +=back + +=head1 AUTHOR + +This guide was initially drafted by Jason McIntosh +(jmac@jmac.org), under a grant from The Perl Foundation. + +=for comment Additional contributors can get listed here (and this +comment deleted), when there are some. diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index b2ebeb797ad6..927d3740bfea 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -3419,7 +3419,7 @@ X X X =for Pod::Functions convert UNIX time into record or string using Greenwich time -Works just like L|/localtime EXPR> but the returned values +Works just like L|/localtime EXPR>, but the returned values are localized for the standard Greenwich time zone. Note: When called in list context, $isdst, the last value @@ -4055,8 +4055,8 @@ C<$wday> is the day of the week, with 0 indicating Sunday and 3 indicating Wednesday. C<$yday> is the day of the year, in the range C<0..364> (or C<0..365> in leap years.) -C<$isdst> is true if the specified time occurs during Daylight Saving -Time, false otherwise. +C<$isdst> is true if the specified time occurs when Daylight Saving +Time is in effect, false otherwise. If EXPR is omitted, L|/localtime EXPR> uses the current time (as returned by L|/time>). @@ -4064,27 +4064,21 @@ time (as returned by L|/time>). In scalar context, L|/localtime EXPR> returns the L value: - my $now_string = localtime; # e.g., "Thu Oct 13 04:54:34 1994" + my $now_string = localtime; # e.g., "Thu Oct 13 04:54:34 1994" -The format of this scalar value is B locale-dependent but built -into Perl. For GMT instead of local time use the -L|/gmtime EXPR> builtin. See also the -L|Time::Local> module (for converting seconds, minutes, -hours, and such back to the integer value returned by L|/time>), -and the L module's L|POSIX/C> and -L|POSIX/C> functions. +This scalar value is always in English, and is B locale-dependent. +To get similar but locale-dependent date strings, try for example: -To get somewhat similar but locale-dependent date strings, set up your -locale environment variables appropriately (please see L) and -try for example: + use POSIX qw(strftime); + my $now_string = strftime "%a %b %e %H:%M:%S %Y", localtime; + # or for GMT formatted appropriately for your locale: + my $now_string = strftime "%a %b %e %H:%M:%S %Y", gmtime; - use POSIX qw(strftime); - my $now_string = strftime "%a %b %e %H:%M:%S %Y", localtime; - # or for GMT formatted appropriately for your locale: - my $now_string = strftime "%a %b %e %H:%M:%S %Y", gmtime; - -Note that C<%a> and C<%b>, the short forms of the day of the week -and the month of the year, may not necessarily be three characters wide. +C$now_string> will be formatted according to the current LC_TIME locale +the program or thread is running in. See L for how to set +up and change that locale. Note that C<%a> and C<%b>, the short forms +of the day of the week and the month of the year, may not necessarily be +three characters wide. The L and L modules provide a convenient, by-name access mechanism to the L|/gmtime EXPR> and @@ -4093,6 +4087,13 @@ L|/localtime EXPR> functions, respectively. For a comprehensive date and time representation look at the L module on CPAN. +For GMT instead of local time use the L|/gmtime EXPR> builtin. + +See also the L|Time::Local> module (for converting +seconds, minutes, hours, and such back to the integer value returned by +L|/time>), and the L module's +L|POSIX/C> function. + Portability issues: L. =item lock THING @@ -4326,9 +4327,8 @@ X Calls the System V IPC function msgsnd to send the message MSG to the message queue ID. MSG must begin with the native long integer message -type, be followed by the length of the actual message, and then finally -the message itself. This kind of packing can be achieved with -C. Returns true if successful, +type, followed by the message itself. This kind of packing can be achieved +with C. Returns true if successful, false on error. See also L and the documentation for L|IPC::SysV> and L|IPC::Msg>. @@ -4433,7 +4433,10 @@ X X X X X X =for Pod::Functions convert a string to an octal number Interprets EXPR as an octal string and returns the corresponding -value. (If EXPR happens to start off with C<0x> or C, interprets it as a +value. An octal string consists of octal digits and, as of Perl 5.33.5, +an optional C<0o> or C prefix. Each octal digit may be preceded by +a single underscore, which will be ignored. +(If EXPR happens to start off with C<0x> or C, interprets it as a hex string. If EXPR starts off with C<0b> or C, it is interpreted as a binary string. Leading whitespace is ignored in all three cases.) The following will handle decimal, binary, octal, and hex in standard @@ -5856,7 +5859,7 @@ symbol table the compiler uses for the rest of that block. You can refer to identifiers in other packages than the current one by prefixing the identifier with the package name and a double colon, as in C<$SomePack::var> or C. If package name is omitted, the C
-package as assumed. That is, C<$::sail> is equivalent to +package is assumed. That is, C<$::sail> is equivalent to C<$main::sail> (as well as to C<$main'sail>, still seen in ancient code, mostly from Perl 4). @@ -6150,6 +6153,18 @@ Will both leave the sentence as is. Normally, when accepting literal string input from the user, L|/quotemeta EXPR> or C<\Q> must be used. +Beware that if you put literal backslashes (those not inside +interpolated variables) between C<\Q> and C<\E>, double-quotish +backslash interpolation may lead to confusing results. If you +I to use literal backslashes within C<\Q...\E>, +consult L. + +Because the result of S \E">> has all metacharacters +quoted, there is no way to insert a literal C<$> or C<@> inside a +C<\Q\E> pair. If protected by C<\>, C<$> will be quoted to become +C<"\\\$">; if not, it is interpreted as the start of an interpolated +scalar. + In Perl v5.14, all non-ASCII characters are quoted in non-UTF-8-encoded strings, but not quoted in UTF-8 strings. @@ -7840,7 +7855,7 @@ pattern argument to split; in Perl 5.18.0 and later this special case is triggered by any expression which evaluates to the simple string S>. As of Perl 5.28, this special-cased whitespace splitting works as expected in -the scope of L<< S>|feature/The +the scope of L<< S>|feature/The 'unicode_strings' feature >>. In previous versions, and outside the scope of that feature, it exhibits L: characters that are whitespace according to Unicode rules but not according to ASCII rules can be @@ -8223,6 +8238,11 @@ as supported by the compiler used to build Perl: z interpret integer as C types "size_t" or "ssize_t" on Perl 5.14 or later +Note that, in general, using the C modifier (for example, when writing +C<"%ld"> or C<"%lu"> instead of C<"%d"> and C<"%u">) is unnecessary +when used from Perl code. Moreover, it may be harmful, for example on +Windows 64-bit where a long is 32-bits. + As of 5.14, none of these raises an exception if they are not supported on your platform. However, if warnings are enabled, a warning of the L|warnings> warning class is issued on an unsupported diff --git a/pod/perlgov.pod b/pod/perlgov.pod new file mode 100644 index 000000000000..e6367714f1e8 --- /dev/null +++ b/pod/perlgov.pod @@ -0,0 +1,531 @@ +=encoding utf-8 + +=head1 NAME + +perlgov - Perl Rules of Governance + +=head1 PREAMBLE + +We are forming a system of governance for development of the Perl programming +language. + +The scope of governance includes the language definition, its +implementation, its test suite, its documentation, and the policies and +procedures by which it is developed and maintained. + +The system of governance includes definitions of the groups that will make +decisions, the rules by which these groups are formed and changed, and the +enumerated powers and constraints on the activities of these governing +groups. + +In forming a system of governance, we seek to achieve the following goals: + +=over + +=item * + +We want a system that is functional. That means the governing groups may +decide to undertake large changes, or they may decide to act conservatively, +but they will act with intent and clear communication rather than fail to reach +decisions when needed. + +=item * + +We want a system that is trusted. That means that a reasonable contributor to +Perl might disagree with decisions made by the governing groups, but will +accept that they were made in good faith in consultation with relevant +communities outside the governing groups. + +=item * + +We want a system that is sustainable. That means it has provisions to +self-modify, including ways of adding new members to the governing groups, ways +to survive members becoming inactive, and ways of amending the rules of +governance themselves if needed. + +=item * + +We want a system that is transparent. That means that it will prefer policies +that manage ordinary matters in public, and it will prefer secrecy in a limited +number of situations. + +=item * + +We want a system that is respectful. That means that it will establish +standards of civil discourse that allow for healthy disagreement but avoid +rancor and hostility in the community for which it is responsible. + +=back + +=head1 Mandate + +Perl language governance shall work to: + +=over + +=item * + +Maintain the quality, stability, and continuity of the Perl language and +interpreter + +=item * + +Guide the evolution of the Perl language and interpreter + +=item * + +Establish and oversee the policies, procedures, systems, and mechanisms that +enable a community of contributors to the Perl language and interpreter + +=item * + +Encourage discussion and consensus among contributors as preferential to formal +decision making by governance groups + +=item * + +Facilitate communication between contributors and external stakeholders in the +broader Perl ecosystem + +=back + +=head1 Definitions + +This document describes three roles involved in governance: + +=over + +=item "Core Team" + +=item "Steering Council" + +=item "Vote Administrator" + +=back + +A section on each follows. + +=head2 The Core Team + +The Core Team are a group of trusted volunteers involved in the ongoing +development of the Perl language and interpreter. They are not required to be +language developers or committers. + +References to specific votes are explained in the "Rules for Voting" section. + +=head3 Powers + +In addition to their contributions to the Perl language, the Core Team sets +the rules of Perl governance, decides who participates in what role in +governance, and delegates substantial decision making power to the Steering +Council. + +Specifically: + +=over + +=item * + +They elect the Steering Council and have the power to remove Steering +Council members. + +=item * + +In concert with the Steering Council, they manage Core Team membership. + +=item * + +In concert with the Steering Council, they have the power to modify the Perl +Rules of Governance. + +=back + +The Core Team do not have any authority over parts of the Perl ecosystem +unrelated to developing and releasing the language itself. These include, but +are not limited to: + +=over + +=item * + +The Perl Foundation + +=item * + +CPAN administration and CPAN authors + +=item * + +perl.org, metacpan.org, and other community-maintained websites and services + +=item * + +Perl conferences and events, except those organized directly by the Core Team + +=item * + +Perl-related intellectual property legally owned by third-parties, except as +allowed by applicable licenses or agreements + +=back + +=head3 Membership + +The initial Core Team members will be specified when this document is +first ratified. + +Any Core Team member may nominate someone to be added to the Core Team by +sending the nomination to the Steering Council. The Steering Council must +approve or reject the nomination. If approved, the Steering Council will +organize a Membership Change Vote to ratify the addition. + +Core Team members should demonstrate: + +=over + +=item * + +A solid track record of being constructive and helpful + +=item * + +Significant contributions to the project's goals, in any form + +=item * + +Willingness to dedicate some time to improving Perl + +=back + +Contributions are not limited to code. Here is an incomplete list of areas +where contributions may be considered for joining the Core Team: + +=over + +=item * + +Working on community management and outreach + +=item * + +Providing support on mailing lists, IRC, or other forums + +=item * + +Triaging tickets + +=item * + +Writing patches (code, docs, or tests) + +=item * + +Reviewing patches (code, docs, or tests) + +=item * + +Participating in design discussions + +=item * + +Providing expertise in a particular domain (security, i18n, etc.) + +=item * + +Managing Perl infrastructure (websites, CI, documentation, etc.) + +=item * + +Maintaining significant projects in the Perl ecosystem + +=item * + +Creating visual designs + +=back + +Core Team membership acknowledges sustained and valuable efforts that align +well with the philosophy and the goals of the Perl project. + +Core Team members are expected to act as role models for the community and +custodians of the project, on behalf of the community and all those who rely +on Perl. + +=head3 Term + +Core Team members serve until they are removed. + +=head3 Removal + +Core Team Members may resign their position at any time. + +In exceptional circumstances, it may be necessary to remove someone from the +Core Team against their will, such as for flagrant or repeated violations of a +Code of Conduct. Any Core Team member may send a recall request to the +Steering Council naming the individual to be removed. The Steering Council +must approve or reject the recall request. If approved, the Steering Council +will organize a Membership Change vote to ratify the removal. + +If the removed member is also on the Steering Council, then they are removed +from the Steering Council as well. + +=head3 Inactivity + +Core Team members who have stopped contributing are encouraged to declare +themselves "inactive". Inactive members do not nominate or vote. Inactive +members may declare themselves active at any time, except when a vote has been +proposed and is not concluded. Eligibility to nominate or vote will be +determined by the Vote Administrator. + +To record and honor their contributions, inactive Core Team members will +continue to be listed alongside active members. + +=head3 No Confidence in the Steering Council + +The Core Team may remove either a single Steering Council member or the entire +Steering Council via a No Confidence Vote. + +A No Confidence Vote is triggered when a Core Team member calls for one +publicly on an appropriate project communication channel, and another Core +Team member seconds the proposal. + +If a No Confidence Vote removes all Steering Council members, the Vote +Administrator of the No Confidence Vote will then administer an election +to select a new Steering Council. + +=head3 Amending Perl Rules of Governance + +Any Core Team member may propose amending the Perl Rules of Governance by +sending a proposal to the Steering Council. The Steering Council must decide +to approve or reject the proposal. If approved, the Steering Council will +administer an Amendment Vote. + +=head3 Rules for Voting + +Membership Change, Amendment, and No Confidence Votes require 2/3 of +participating votes from Core Team members to pass. + +A Vote Administrator must be selected following the rules in the "Vote +Administrator" section. + +The vote occurs in two steps: + +=over + +=item 1 + +The Vote Administrator describes the proposal being voted upon. The Core Team +then may discuss the matter in advance of voting. + +=item 2 + +Active Core Team members vote in favor or against the proposal. Voting is +performed anonymously. + +=back + +For a Membership Change Vote, each phase will last one week. For Amendment and +No Confidence Votes, each phase will last two weeks. + +=head2 The Steering Council + +The Steering Council is a 3-person committee, elected by the Core +Team. Candidates are not required to be members of the Core Team. Non-member +candidates are added to the Core Team if elected as if by a Membership Change +Vote. + +References to specific elections are explained in the "Rules for Elections" section. + +=head3 Powers + +The Steering Council has broad authority to make decisions about the +development of the Perl language, the interpreter, and all other components, +systems and processes that result in new releases of the language interpreter. + +For example, it can: + +=over + +=item * + +Manage the schedule and process for shipping new releases + +=item * + +Establish procedures for proposing, discussing and deciding upon changes to the +language + +=item * + +Delegate power to individuals on or outside the Steering Council + +=back + +Decisions of the Steering Council will be made by majority vote of non-vacant +seats on the council. + +The Steering Council should look for ways to use these powers as little as +possible. Instead of voting, it's better to seek consensus. Instead of ruling +on individual cases, it's better to define standards and processes that apply +to all cases. + +As with the Core Team, the Steering Council does not have any authority over +parts of the Perl ecosystem unrelated to developing and releasing the language +itself. + +The Steering Council does not have the power to modify the Perl Rules of +Governance, except as provided in the section "Amending Perl Rules of +Governance". + +=head3 Term + +A new Steering Council will be chosen by a Term Election within two weeks after +each stable feature release (that is, change to C or +C) or after two years, whichever comes first. The council members +will serve until the completion of the next Term Election unless they are +removed. + +=head3 Removal + +Steering Council members may resign their position at any time. + +Whenever there are vacancies on the Steering Council, the council will +organize a Special Election within one week after the vacancy occurs. If the +entire Steering Council is ever vacant, a Term Election will be held instead. + +If a Steering Council member is deceased, or drops out of touch and cannot be +contacted for a month or longer, then the rest of the council may vote to +declare their seat vacant. If an absent member returns after such a +declaration is made, they are not reinstated automatically, but may run in the +Special Election to fill the vacancy. + +Otherwise, Steering Council members may only be removed before the end of +their term through a No Confidence Vote by the Core Team. + +=head3 Rules for Elections + +Term and Special Election are ranked-choice votes to construct an ordered list +of candidates to fill vacancies in the Steering Council. + +A Vote Administrator must be selected following the rules in the "Vote +Administrator" section. + +Both Term and Special Elections occur in two stages: + +=over + +=item 1 + +Candidates advertise their interest in serving. Candidates must be nominated by +an active Core Team member. Self-nominations are allowed. Nominated candidates +may share a statement about their candidacy with the Core Team. + +=item 2 + +Active Core Team Members vote by ranking all candidates. Voting is performed +anonymously. After voting is complete, candidates are ranked using the +Condorcet Internet Voting Service's proportional representation mode. If a tie +occurs, it may be resolved by mutual agreement among the tied candidates, or +else the tie will be resolved through random selection by the Vote +Administrator. + +=back + +Anyone voted off the Core Team is not eligible to be a candidate for Steering +Council unless re-instated to the Core Team. + +For a Term Election, each phase will last two weeks. At the end of the second +phase, the top three ranked candidates are elected as the new Steering Council. + +For a Special Election, each phase will last one week. At the end of the +second phase, vacancies are filled from the ordered list of candidates until +no vacancies remain. + +The election of the first Steering Council will be a Term Election. Ricardo +Signes will be the Vote Administrator for the initial Term Election unless he +is a candidate, in which case he will select a non-candidate administrator to +replace him. + +=head2 The Vote Administrator + +Every election or vote requires a Vote Administrator who manages +communication, collection of secret ballots, and all other necessary +activities to complete the voting process. + +Unless otherwise specified, the Steering Council selects the Vote +Administrator. + +A Vote Administrator must not be a member of the Steering Council nor a +candidate or subject of the vote. A Vote Administrator may be a member of the +Core Team and, if so, may cast a vote while also serving as administrator. If +the Vote Administrator becomes a candidate during an election vote, they will +appoint a non-candidate replacement. + +If the entire Steering Council is vacant or is the subject of a No Confidence +Vote, then the Core Team will select a Vote Administrator by consensus. If +consensus cannot be reached within one week, the President of The Perl +Foundation will select a Vote Administrator. + +=head1 Core Team Members + +The current members of the Perl Core Team are: + +=over + +=item * Abhijit Menon-Sen (inactive) + +=item * Andy Dougherty (inactive) + +=item * Chad Granum + +=item * Chris 'BinGOs' Williams + +=item * Craig Berry + +=item * Dagfinn Ilmari Mannsåker + +=item * Dave Mitchell + +=item * David Golden + +=item * H. Merijn Brand + +=item * Hugo van der Sanden + +=item * James E Keenan + +=item * Jan Dubois (inactive) + +=item * Jesse Vincent (inactive) + +=item * Karen Etheridge + +=item * Karl Williamson + +=item * Leon Timmermans + +=item * Matthew Horsfall + +=item * Max Maischein + +=item * Nicholas Clark + +=item * Nicolas R. + +=item * Paul "LeoNerd" Evans + +=item * Philippe "BooK" Bruhat + +=item * Ricardo Signes + +=item * Sawyer X + +=item * Steve Hay + +=item * Stuart Mackintosh + +=item * Todd Rinaldo + +=item * Tony Cook + +=back diff --git a/pod/perlguts.pod b/pod/perlguts.pod index 1575619caf5b..8d0b7894f07a 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -1023,6 +1023,63 @@ as any other SV. For more information on references and blessings, consult L. +=head2 I/O Handles + +Like AVs and HVs, IO objects are another type of non-scalar SV which +may contain input and output L objects or a C +from opendir(). + +You can create a new IO object: + + IO* newIO(); + +Unlike other SVs, a new IO object is automatically blessed into the +L class. + +The IO object contains an input and output PerlIO handle: + + PerlIO *IoIFP(IO *io); + PerlIO *IoOFP(IO *io); + +Typically if the IO object has been opened on a file, the input handle +is always present, but the output handle is only present if the file +is open for output. For a file, if both are present they will be the +same PerlIO object. + +Distinct input and output PerlIO objects are created for sockets and +character devices. + +The IO object also contains other data associated with Perl I/O +handles: + + IV IoLINES(io); /* $. */ + IV IoPAGE(io); /* $% */ + IV IoPAGE_LEN(io); /* $= */ + IV IoLINES_LEFT(io); /* $- */ + char *IoTOP_NAME(io); /* $^ */ + GV *IoTOP_GV(io); /* $^ */ + char *IoFMT_NAME(io); /* $~ */ + GV *IoFMT_GV(io); /* $~ */ + char *IoBOTTOM_NAME(io); + GV *IoBOTTOM_GV(io); + char IoTYPE(io); + U8 IoFLAGS(io); + +Most of these are involved with L. + +IoFLAGs() may contain a combination of flags, the most interesting of +which are C (C<$|>) for autoflush and C, +settable with L<< IO::Handle's untaint() method|IO::Handle/"$io->untaint" >>. + +The IO object may also contains a directory handle: + + DIR *IoDIRP(io); + +suitable for use with PerlDir_read() etc. + +All of these accessors macros are lvalues, there are no distinct +C<_set()> macros to modify the members of the IO object. + =head2 Double-Typed SVs Scalar variables normally contain only one type of value, an integer, @@ -2786,7 +2843,7 @@ with PTR2UV(). The contents of SVs may be printed using the C format, like so: - Perl_croak(aTHX_ "This croaked because: %" SVf "\n", SvfARG(err_msg)) + Perl_croak(aTHX_ "This croaked because: %" SVf "\n", SVfARG(err_msg)) where C is an SV. @@ -3513,7 +3570,7 @@ the API function C is used to mortalize an xV, adding its address to the temporaries stack. Likewise, there is no public API to read values from the temporaries stack. -Instead. the macros C and C are used. The C +Instead, the macros C and C are used. The C macro establishes the base levels of the temporaries stack, by capturing the current value of C into C and saving the previous value to the save stack. Thereafter, whenever C is invoked all of diff --git a/pod/perlhack.pod b/pod/perlhack.pod index 1f668634852d..c76008228802 100644 --- a/pod/perlhack.pod +++ b/pod/perlhack.pod @@ -691,7 +691,7 @@ still options for the future of prototypes that haven't been addressed. Good patches (tight code, complete, correct) stand more chance of going in. Sloppy or incorrect patches might be placed on the back burner -until the pumpking has time to fix, or might be discarded altogether +until fixes can be made, or they might be discarded altogether without further notice. =head3 Is the implementation generic enough to be portable? @@ -728,7 +728,7 @@ man's pointless cruft. =head3 Does it create too much work? -Work for the pumpking, work for Perl programmers, work for module +Work for the committers, work for Perl programmers, work for module authors, ... Perl is supposed to be easy. =head3 Patches speak louder than words @@ -910,9 +910,10 @@ Sets PERL_SKIP_TTY_TEST to true before running normal test. =head2 Parallel tests The core distribution can now run its regression tests in parallel on -Unix-like platforms. Instead of running C, set C -in your environment to the number of tests to run in parallel, and run -C. On a Bourne-like shell, this can be done as +Unix-like and Windows platforms. On Unix, instead of running C, set C in your environment to the number of tests to +run in parallel, and run C. On a Bourne-like shell, +this can be done as TEST_JOBS=3 make test_harness # Run 3 tests in parallel @@ -921,9 +922,23 @@ because L needs to be able to schedule individual non-conflicting test scripts itself, and there is no standard interface to C utilities to interact with their job schedulers. -Note that currently some test scripts may fail when run in parallel -(most notably F). If necessary, run just the -failing scripts again sequentially and see if the failures go away. +Tests are normally run in a logical order, with the sanity tests first, +then the main tests of the Perl core functionality, then the tests for +the non-core modules. On many-core systems, this may not use the +hardware as effectively as possible. By also specifying + + TEST_JOBS=19 PERL_TEST_HARNESS_ASAP=1 make -j19 test_harness + +you signal that you want the tests to finish in wall-clock time as short +as possible. After the sanity tests are completed, this causes the +remaining ones to be packed into the available cores as tightly as +we know how. This has its greatest effect on slower, many-core systems. +Throughput was sped up by 20% on an outmoded 24-core system; less on +more recent faster ones with fewer cores. + +Note that the command line above added a C<-j> parameter to make, so as +to cause parallel compilation. This may or may not work on your +platform. =head2 Running tests by hand @@ -1169,7 +1184,7 @@ functions do, as well as the many macros used in the source. =item * F This is a collection of words of wisdom for a Perl porter; some of it -is only useful to the pumpkin holder, but most of it applies to anyone +is only useful to the pumpkin holders, but most of it applies to anyone wanting to go about Perl development. =back diff --git a/pod/perlhist.pod b/pod/perlhist.pod index 8d4ce988e033..6d689e2ee9b4 100644 --- a/pod/perlhist.pod +++ b/pod/perlhist.pod @@ -34,7 +34,8 @@ Chris C Williams, Zefram, Ævar Arnfjörð Bjarmason, Stevan Little, Dave Rolsky, Max Maischein, Abigail, Jesse Luehrs, Tony Cook, Dominic Hargreaves, Aaron Crane, Aristotle Pagaltzis, Matthew Horsfall, Peter Martini, Sawyer X, Chad 'Exodist' Granum, Renee Bäcker, Eric Herman, -John SJ Anderson, Karen Etheridge, Zak B. Elep, and Tom Hukins. +John SJ Anderson, Karen Etheridge, Zak B. Elep, Tom Hukins, and Richard +Leach. =head2 PUMPKIN? @@ -65,8 +66,8 @@ the strings?). =head1 THE RECORDS Pump- Release Date Notes - king (by no means - comprehensive, + kin (by no means + Holder comprehensive, see Changes* for details) ====================================================================== @@ -694,11 +695,16 @@ the strings?). Sawyer X 5.32.0-RC0 2020-May-30 The 5.32 maintenance track Sawyer X 5.32.0-RC1 2020-Jun-07 Sawyer X 5.32.0 2020-Jun-20 + Steve 5.32.1-RC1 2021-Jan-09 + Steve 5.32.1 2021-Jan-23 Sawyer X 5.33.0 2020-Jul-17 The 5.33 development track Ether 5.33.1 2020-Aug-20 Sawyer X 5.33.2 2020-Sep-20 Steve 5.33.3 2020-Oct-20 + Tom H 5.33.4 2020-Nov-20 + Max M 5.33.5 2020-Dec-20 + Richard L 5.33.6 2021-Jan-20 =head2 SELECTED RELEASE SIZES diff --git a/pod/perllocale.pod b/pod/perllocale.pod index f2c5206fc3a2..8354fe222a11 100644 --- a/pod/perllocale.pod +++ b/pod/perllocale.pod @@ -543,7 +543,7 @@ C<-Accflags='-DUSE_THREAD_SAFE_LOCALE'> to F. The initial program is started up using the locale specified from the environment, as currently, described in L. All newly -created threads start with C set to C<"C">>. Each thread may +created threads start with C set to C<"C">. Each thread may use C to query or switch its locale at any time, without affecting any other thread. All locale-dependent operations automatically use their thread's locale. diff --git a/pod/perlmodinstall.pod b/pod/perlmodinstall.pod index aba1ab995ff0..b07ef71ecc4b 100644 --- a/pod/perlmodinstall.pod +++ b/pod/perlmodinstall.pod @@ -139,10 +139,7 @@ If you used WinZip, this was already done for you. C. BUILD -You'll need the C utility, available at -L -or dmake, available on CPAN. -L +You'll need either C or C. Does the module require compilation (i.e. does it have files that end in .xs, .c, .h, .y, .cc, .cxx, or .C)? If it does, life is now diff --git a/pod/perlmroapi.pod b/pod/perlmroapi.pod index e0a4f704dca9..ad6d1e3eb127 100644 --- a/pod/perlmroapi.pod +++ b/pod/perlmroapi.pod @@ -79,7 +79,7 @@ stash, and a pointer to your C structure: meta = HvMROMETA(stash); private_sv = MRO_GET_PRIVATE_DATA(meta, &my_mro_alg); -=for apidoc mro_get_private_data +=for apidoc Amh|struct mro_meta *|HvMROMETA|HV *hv =for apidoc Amh|SV*|MRO_GET_PRIVATE_DATA|struct mro_meta *const smeta|const struct mro_alg *const which To set your private value, call C: diff --git a/pod/perlop.pod b/pod/perlop.pod index ddaf430b8b60..33e558aa7014 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -1594,6 +1594,8 @@ is a word character (meaning it matches C): The following escape sequences are available in constructs that interpolate, and in transliterations whose delimiters aren't single quotes (C<"'">). +In all the ones with braces, any number of blanks and/or tabs adjoining +and within the braces are allowed (and ignored). X<\t> X<\n> X<\r> X<\f> X<\b> X<\a> X<\e> X<\x> X<\0> X<\c> X<\N> X<\N{}> X<\o{}> @@ -1606,6 +1608,8 @@ X<\o{}> \a alarm (bell) (BEL) \e escape (ESC) \x{263A} [1,8] hex char (example shown: SMILEY) + \x{ 263A } Same, but shows optional blanks inside and + adjoining the braces \x1b [2,8] restricted range hex char (example: ESC) \N{name} [3] named Unicode character or character sequence \N{U+263D} [4,8] Unicode character (example: FIRST QUARTER MOON) @@ -1613,6 +1617,11 @@ X<\o{}> \o{23072} [6,8] octal char (example: SMILEY) \033 [7,8] restricted range octal char (example: ESC) +Note that any escape sequence using braces inside interpolated +constructs may have optional blanks (tab or space characters) adjoining +with and inside of the braces, as illustrated above by the second +S> example. + =over 4 =item [1] @@ -1620,10 +1629,13 @@ X<\o{}> The result is the character specified by the hexadecimal number between the braces. See L below for details on which character. -Only hexadecimal digits are valid between the braces. If an invalid -character is encountered, a warning will be issued and the invalid -character and all subsequent characters (valid or invalid) within the -braces will be discarded. +Blanks (tab or space characters) may separate the number from either or +both of the braces. + +Otherwise, only hexadecimal digits are valid between the braces. If an +invalid character is encountered, a warning will be issued and the +invalid character and all subsequent characters (valid or invalid) +within the braces will be discarded. If there are no valid digits between the braces, the generated character is the NULL character (C<\x{00}>). However, an explicit empty brace (C<\x{}>) @@ -1709,10 +1721,13 @@ To get platform independent controls, you can use C<\N{...}>. The result is the character specified by the octal number between the braces. See L below for details on which character. -If a character that isn't an octal digit is encountered, a warning is raised, -and the value is based on the octal digits before it, discarding it and all -following characters up to the closing brace. It is a fatal error if there are -no octal digits at all. +Blanks (tab or space characters) may separate the number from either or +both of the braces. + +Otherwise, if a character that isn't an octal digit is encountered, a +warning is raised, and the value is based on the octal digits before it, +discarding it and all following characters up to the closing brace. It +is a fatal error if there are no octal digits at all. =item [7] @@ -2584,7 +2599,8 @@ Unless the C option is used, the string specified with C<=~> must be a scalar variable, an array element, a hash element, or an assignment to one of those; in other words, an lvalue. -If the characters delimiting I and I +The characters delimitting I and I +can be any printable character, not just forward slashes. If they are single quotes (C'I'>), the only interpolation is removal of C<\> from pairs of C<\\>. @@ -2670,8 +2686,8 @@ If the C modifier is specified, sequences of characters, all in a row, that were transliterated to the same character are squashed down to a single instance of that character. - my $a = "aaaba" - $a =~ tr/a/a/s # $a now is "aba" + my $a = "aaabbbca"; + $a =~ tr/ab/dd/s; # $a now is "dcd" If the C modifier is used, the I is always interpreted exactly as specified. Otherwise, if the I is shorter diff --git a/pod/perlpolicy.pod b/pod/perlpolicy.pod index 35f2a9a63055..ba54b9259886 100644 --- a/pod/perlpolicy.pod +++ b/pod/perlpolicy.pod @@ -24,22 +24,26 @@ some are actively patching their pet area (threads, Win32, the regexp -engine), while others seem to do nothing but complain. In other words, it's your usual mix of technical people. +Among these people are the core Perl team. These are trusted volunteers +involved in the ongoing development of the Perl language and interpreter. +They are not required to be language developers or committers. + Over this group of porters presides Larry Wall. He has the final word in what does and does not change in any of the Perl programming languages. These days, Larry spends most of his time on Raku, while Perl 5 is -shepherded by a "pumpking", a porter responsible for deciding what +shepherded by a steering council of porters responsible for deciding what goes into each release and ensuring that releases happen on a regular basis. Larry sees Perl development along the lines of the US government: -there's the Legislature (the porters), the Executive branch (the --pumpking), and the Supreme Court (Larry). The legislature can -discuss and submit patches to the executive branch all they like, but -the executive branch is free to veto them. Rarely, the Supreme Court -will side with the executive branch over the legislature, or the -legislature over the executive branch. Mostly, however, the -legislature and the executive branch are supposed to get along and -work out their differences without impeachment or court cases. +there's the Legislature (the porters, represented by the core team), the +Executive branch (the steering council), and the Supreme Court (Larry). +The legislature can discuss and submit patches to the executive branch +all they like, but the executive branch is free to veto them. Rarely, +the Supreme Court will side with the executive branch over the +legislature, or the legislature over the executive branch. Mostly, +however, the legislature and the executive branch are supposed to get +along and work out their differences without impeachment or court cases. You might sometimes see reference to Rule 1 and Rule 2. Larry's power as Supreme Court is expressed in The Rules: @@ -61,6 +65,10 @@ regardless of whether he previously invoked Rule 1. Got that? Larry is always right, even when he was wrong. It's rare to see either Rule exercised, but they are often alluded to. +For the specifics on how the members of the core team and steering +council are elected or rotated, consult L, which spells it all +out in detail. + =head1 MAINTENANCE AND SUPPORT Perl 5 is developed by a community, not a corporate entity. Every change @@ -168,7 +176,7 @@ Using a lexical pragma to enable or disable legacy behavior should be considered when appropriate, and in the absence of any pragma legacy behavior should be enabled. Which backward-incompatible changes are controlled implicitly by a 'use v5.x.y' is a decision which should be -made by the pumpking in consultation with the community. +made by the steering council in consultation with the community. Historically, we've held ourselves to a far higher standard than backward-compatibility -- bugward-compatibility. Any accident of @@ -263,8 +271,9 @@ perl (e.g. spelling corrections in documentation) should be resisted in order to reduce the overall risk of overlooking something. The intention is to create maintenance releases which are both worthwhile and which users can have full confidence in the stability of. (A secondary concern is to avoid burning -out the maint-pumpking or overwhelming other committers voting on changes to be -included (see L below).) +out the maint-release manager or overwhelming other committers voting on +changes to be included (see L +below).) The following types of change may be considered acceptable, as long as they do not also fall into any of the "unacceptable" categories set out below: @@ -328,7 +337,8 @@ The following types of change are NOT acceptable: =item * -Patches that break binary compatibility. (Please talk to a pumpking.) +Patches that break binary compatibility. (Please talk to the steering +council.) =item * @@ -356,11 +366,11 @@ be included. =head2 Getting changes into a maint branch -Historically, only the pumpking cherry-picked changes from bleadperl -into maintperl. This has scaling problems. At the same time, -maintenance branches of stable versions of Perl need to be treated with -great care. To that end, as of Perl 5.12, we have a new process for -maint branches. +Historically, only the single-person project manager cherry-picked +changes from bleadperl into maintperl. This has scaling problems. At +the same time, maintenance branches of stable versions of Perl need to +be treated with great care. To that end, as of Perl 5.12, we have a new +process for maint branches. Any committer may cherry-pick any commit from blead to a maint branch by first adding an entry to the relevant voting file in the maint-votes branch @@ -383,7 +393,7 @@ interested may be heard. It is not necessary for voting to be held on cherry-picking perldelta entries associated with changes that have already been cherry-picked, nor -for the maint-pumpking to obtain votes on changes required by the +for the maint-release manager to obtain votes on changes required by the F where such changes can be applied by the means of cherry-picking from blead. @@ -436,7 +446,7 @@ should be respected whenever possible. =item * -Patches may be applied by the pumpkin holder without the explicit +Patches may be applied by the steering council without the explicit cooperation of the module author if and only if they are very minor, time-critical in some fashion (such as urgent security fixes), or if the module author cannot be reached. Those patches must still be @@ -451,7 +461,7 @@ of the change acknowledged. The version of the module distributed with Perl should, whenever possible, be the latest version of the module as distributed by the author (the latest non-beta version in the case of public Perl -releases), although the pumpkin holder may hold off on upgrading the +releases), although the steering council may hold off on upgrading the version of the module distributed with Perl to the latest version until the latest version has had sufficient testing. @@ -464,10 +474,9 @@ reasonable compromises when there are disagreements). As a last resort, however: - If the author's vision of the future of their module is sufficiently -different from the vision of the pumpkin holder and perl5-porters as a -whole so as to cause serious problems for Perl, the pumpkin holder may +different from the vision of the steering council and perl5-porters as a +whole so as to cause serious problems for Perl, the steering council may choose to formally fork the version of the module in the Perl core from the one maintained by the author. This should not be done lightly and should B if at all possible be done only after direct input diff --git a/pod/perlport.pod b/pod/perlport.pod index a9809802fdb7..63869d53e3d2 100644 --- a/pod/perlport.pod +++ b/pod/perlport.pod @@ -1526,6 +1526,9 @@ C<-x>, C<-o>. (Win32, VMS, S) C<-g>, C<-k>, C<-l>, C<-u>, C<-A> are not particularly meaningful. +(Win32) +C<-l> returns true for both symlinks and directory junctions. + (VMS, S) C<-p> is not particularly meaningful. @@ -1571,6 +1574,12 @@ filehandle may be closed, or pointer may be in a different position. The value returned by L|perlfunc/tell FILEHANDLE> may be affected after the call, and the filehandle may be flushed. +=item chdir + +(Win32) +The current directory reported by the system may include any symbolic +links specified to chdir(). + =item chmod (Win32) @@ -1946,7 +1955,7 @@ but usually by no more than an hour. Not implemented. (Win32) -Return values (especially for device and inode) may be bogus. +Treats directory junctions as symlinks. =item msgctl @@ -1976,9 +1985,13 @@ implications for your code. =item readlink -(Win32, VMS, S) +(VMS, S) Not implemented. +(Win32) +readlink() on a directory junction returns the object name, not a +simple path. + =item rename (Win32) @@ -2074,9 +2087,6 @@ C not supported on UFS. (Win32) C is creation time instead of inode change time. -(Win32) -C and C are not meaningful. - (VMS) C and C are not necessarily reliable. @@ -2092,17 +2102,18 @@ meaningful and will differ between stat calls on the same file. Some versions of cygwin when doing a C and not finding it may then attempt to C. -(Win32) -C needs to open the file to determine the link count -and update attributes that may have been changed through hard links. -Setting L|perlvar/${^WIN32_SLOPPY_STAT}> to a -true value speeds up C by not performing this operation. - =item symlink -(Win32, S) +(S) Not implemented. +(Win32) +Requires either elevated permissions or developer mode and a +sufficiently recent version of Windows 10. Since Windows needs to +know whether the target is a directory or not when creating the link +the target Perl will only create the link as a directory link when the +target exists and is a directory. + (VMS) Implemented on 64 bit VMS 8.3. VMS requires the symbolic link to be in Unix syntax if it is intended to resolve to a valid path. diff --git a/pod/perlre.pod b/pod/perlre.pod index bc475ec27a4a..bd49ac7e9eba 100644 --- a/pod/perlre.pod +++ b/pod/perlre.pod @@ -313,7 +313,8 @@ The default behavior for matching can be changed, using various modifiers. Modifiers that relate to the interpretation of the pattern are listed just below. Modifiers that alter the way a pattern is used by Perl are detailed in L and -L. +L. Modifiers can be added +dynamically; see L below. =over 4 @@ -504,14 +505,13 @@ making Perl's regular expressions more readable. Here's an example: Note that anything inside a C<\Q...\E> stays unaffected by C. And note that C doesn't affect space interpretation within a single multi-character construct. For -example in C<\x{...}>, regardless of the C modifier, there can be no -spaces. Same for a L such as C<{3}> or -C<{5,}>. Similarly, C<(?:...)> can't have a space between the C<"(">, -C<"?">, and C<":">. Within any delimiters for such a -construct, allowed spaces are not affected by C, and depend on the -construct. For example, C<\x{...}> can't have spaces because hexadecimal -numbers don't have spaces in them. But, Unicode properties can have spaces, so -in C<\p{...}> there can be spaces that follow the Unicode rules, for which see +example C<(?:...)> can't have a space between the C<"(">, +C<"?">, and C<":">. Within any delimiters for such a construct, allowed +spaces are not affected by C, and depend on the construct. For +example, all constructs using curly braces as delimiters, such as +C<\x{...}> can have blanks within but adjacent to the braces, but not +elsewhere, and no non-blank space characters. An exception are Unicode +properties which follow Unicode rules, for which see L. X @@ -721,8 +721,8 @@ the pattern uses L|/Script Runs> Another mnemonic for this modifier is "Depends", as the rules actually used depend on various things, and as a result you can get unexpected results. See L. The Unicode Bug has -become rather infamous, leading to yet another (without swearing) name -for this modifier, "Dodgy". +become rather infamous, leading to yet other (without swearing) names +for this modifier, "Dicey" and "Dodgy". Unless the pattern or string are encoded in UTF-8, only ASCII characters can match positively. @@ -865,6 +865,7 @@ X X X<*> X<+> X X<{n}> X<{n,}> X<{n,m}> ? Match 1 or 0 times {n} Match exactly n times {n,} Match at least n times + {,n} Match at most n times {n,m} Match at least n but not more than m times (If a non-escaped curly bracket occurs in a context other than one of @@ -880,7 +881,7 @@ quantifiers). The C<"*"> quantifier is equivalent to C<{0,}>, the C<"+"> quantifier to C<{1,}>, and the C<"?"> quantifier to C<{0,1}>. I and I are limited to non-negative integral values less than a preset limit defined when perl is built. -This is usually 32766 on the most common platforms. The actual limit can +This is usually 65534 on the most common platforms. The actual limit can be seen in the error message generated by code such as this: $_ **= $_ , / {$_} / for 2 .. 42; @@ -891,13 +892,14 @@ allowing the rest of the pattern to match. If you want it to match the minimum number of times possible, follow the quantifier with a C<"?">. Note that the meanings don't change, just the "greediness": X X X -X X<*?> X<+?> X X<{n}?> X<{n,}?> X<{n,m}?> +X X<*?> X<+?> X X<{n}?> X<{n,}?> X<{,n}?> X<{n,m}?> *? Match 0 or more times, not greedily +? Match 1 or more times, not greedily ?? Match 0 or 1 time, not greedily {n}? Match exactly n times, not greedily (redundant) {n,}? Match at least n times, not greedily + {,n}? Match at most n times, not greedily {n,m}? Match at least n but not more than m times, not greedily Normally when a quantified subpattern does not allow the rest of the @@ -910,6 +912,7 @@ as well. ?+ Match 0 or 1 time and give nothing back {n}+ Match exactly n times and give nothing back (redundant) {n,}+ Match at least n times and give nothing back + {,n}+ Match at most n times and give nothing back {n,m}+ Match at least n but not more than m times and give nothing back For instance, @@ -1000,6 +1003,8 @@ X<\g> X<\k> X<\K> X curly brackets for safer parsing. \g{name} [5] Named backreference \k [5] Named backreference + \k'name' [5] Named backreference + \k{name} [5] Named backreference \K [6] Keep the stuff left of the \K, don't include it in $& \N [7] Any character but \n. Not affected by /s modifier \v [3] Vertical whitespace @@ -1188,6 +1193,10 @@ concatenating smaller strings. For example if you have C, and C<$a> contained C<"\g1">, and C<$b> contained C<"37">, you would get C which is probably not what you intended. +If you use braces, you may also optionally add any number of blank +(space or tab) characters within but adjacent to the braces, like +S>, or S }>>. + The C<\g> and C<\k> notations were introduced in Perl 5.10.0. Prior to that there were no named nor relative numbered capture groups. Absolute numbered groups were referred to using C<\1>, @@ -1760,6 +1769,8 @@ support the use of single quotes as a delimiter for the name. =item C<< \k'I' >> +=item C<< \k{I} >> + Named backreference. Similar to numeric backreferences, except that the group is designated by name and not number. If multiple groups have the same name then it refers to the leftmost defined group in @@ -1768,7 +1779,9 @@ the current match. It is an error to refer to a name not defined by a C<< (?>) >> earlier in the pattern. -Both forms are equivalent. +All three forms are equivalent, although with C<< \k{ I } >>, +you may optionally have blanks within but adjacent to the braces, as +shown. B In order to make things easier for programmers with experience with the Python or PCRE regex engines, the pattern C<< (?P=I) >> @@ -2334,9 +2347,9 @@ see L. A fundamental feature of regular expression matching involves the notion called I, which is currently used (when needed) -by all regular non-possessive expression quantifiers, namely C<"*">, C<*?>, C<"+">, -C<+?>, C<{n,m}>, and C<{n,m}?>. Backtracking is often optimized -internally, but the general principle outlined here is valid. +by all regular non-possessive expression quantifiers, namely C<"*">, +C<*?>, C<"+">, C<+?>, C<{n,m}>, and C<{n,m}?>. Backtracking is often +optimized internally, but the general principle outlined here is valid. For a regular expression to match, the I regular expression must match, not just part of it. So if the beginning of a pattern containing a diff --git a/pod/perlrebackslash.pod b/pod/perlrebackslash.pod index 94fb99d96e44..d6539ad99df3 100644 --- a/pod/perlrebackslash.pod +++ b/pod/perlrebackslash.pod @@ -186,6 +186,10 @@ digits. Thus C<\N{U+0041}> means C, and you will rarely see it written without the two leading zeros. C<\N{U+0041}> means "A" even on EBCDIC machines (where the ordinal value of "A" is not 0x41). +Blanks may freely be inserted adjacent to but within the braces +enclosing the name or code point. So S> is perfectly +legal. + It is even possible to give your own names to characters and character sequences by using the L module. These custom names are lexically scoped, and so a given code point may have different names @@ -218,7 +222,7 @@ meaning by the regex engine, and will match "as is". =head3 Octal escapes There are two forms of octal escapes. Each is used to specify a character by -its code point specified in octal notation. +its code point specified in base 8. One form, available starting in Perl 5.14 looks like C<\o{...}>, where the dots represent one or more octal digits. It can be used for any Unicode character. @@ -260,6 +264,9 @@ Mnemonic: I<0>ctal or Ictal. $str =~ /P\053/; # No match, "\053" is "+" and taken literally. /\o{23073}/ # Black foreground, white background smiling face. /\o{4801234567}/ # Raises a warning, and yields chr(4). + /\o{ 400}/ # LATIN CAPITAL LETTER A WITH MACRON + /\o{ 400 }/ # Same. These show blanks are allowed adjacent to + # the braces =head4 Disambiguation rules between old-style octal escapes and backreferences @@ -326,6 +333,8 @@ Mnemonic: heIadecimal. # the Unicode character 2602 is an umbrella. /\x{263B}/ # Black smiling face. /\x{263b}/ # Same, the hex digits A - F are case insensitive. + /\x{ 263b }/ # Same, showing optional blanks adjacent to the + # braces =head2 Modifiers @@ -440,7 +449,9 @@ Mnemonic: Iroup. /(\w+) \g1/; # Finds a duplicated word, (e.g. "cat cat"). /(\w+) \1/; # Same thing; written old-style. - /(.)(.)\g2\g1/; # Match a four letter palindrome (e.g. "ABBA"). + /(\w+) \g{1}/; # Same, using the safer braced notation + /(\w+) \g{ 1 }/;# Same, showing optional blanks adjacent to the braces + /(.)(.)\g2\g1/; # Match a four letter palindrome (e.g. "ABBA"). =head3 Relative referencing @@ -460,6 +471,7 @@ even if the larger pattern also contains capture groups. (B) # Group 3 \g{-1} # Refers to group 3 (B) \g{-3} # Refers to group 1 (A) + \g{ -3 } # Same, showing optional blanks adjacent to the braces ) /x; # Matches "ABBA". @@ -480,11 +492,16 @@ hyphen. =head4 Examples - /(?\w+) \g{word}/ # Finds duplicated word, (e.g. "cat cat") - /(?\w+) \k{word}/ # Same. - /(?\w+) \k/ # Same. + /(?\w+) \g{word}/ # Finds duplicated word, (e.g. "cat cat") + /(?\w+) \k{word}/ # Same. + /(?\w+) \g{ word }/ # Same, showing optional blanks adjacent to + # the braces + /(?\w+) \k{ word }/ # Same. + /(?\w+) \k/ # Same. There are no braces, so no blanks + # are permitted /(?.)(?.)\g{letter2}\g{letter1}/ - # Match a four letter palindrome (e.g. "ABBA") + # Match a four letter palindrome (e.g. + # "ABBA") =head2 Assertions @@ -540,7 +557,8 @@ boundary type specified inside the braces. The boundary types are given a few paragraphs below. C<\B{...}> matches at any place between characters where C<\b{...}> of the same type doesn't match. -C<\b> when not immediately followed by a C<"{"> matches at any place +C<\b> when not immediately followed by a C<"{"> is available in all +Perls. It matches at any place between a word (something matched by C<\w>) and a non-word character (C<\W>); C<\B> when not immediately followed by a C<"{"> matches at any place between characters where C<\b> doesn't match. To get better diff --git a/pod/perlrequick.pod b/pod/perlrequick.pod index 5c5030c24cea..38970dd70a08 100644 --- a/pod/perlrequick.pod +++ b/pod/perlrequick.pod @@ -363,6 +363,10 @@ C = match at least C or more times =item * +C = match C times or fewer + +=item * + C = match exactly C times =back @@ -374,7 +378,7 @@ Here are some examples: /(\w+)\s+\g1/; # match doubled words of arbitrary length $year =~ /^\d{2,4}$/; # make sure year is at least 2 but not more # than 4 digits - $year =~ /^\d{4}$|^\d{2}$/; # better match; throw out 3 digit dates + $year =~ /^\d{ 4 }$|^\d{2}$/; # better match; throw out 3 digit dates These quantifiers will try to match as much of the string as possible, while still allowing the regex to match. So we have diff --git a/pod/perlreref.pod b/pod/perlreref.pod index e54093ccf112..4074e01b8a83 100644 --- a/pod/perlreref.pod +++ b/pod/perlreref.pod @@ -217,6 +217,7 @@ Quantifiers are greedy by default and match the B leftmost. {n,m} {n,m}? {n,m}+ Must occur at least n times but no more than m times {n,} {n,}? {n,}+ Must occur at least n times + {,n} {,n}? {,n}+ Must occur at most n times {n} {n}? {n}+ Must occur exactly n times * *? *+ 0 or more times (same as {0,}) + +? ++ 1 or more times (same as {1,}) @@ -226,8 +227,6 @@ The possessive forms (new in Perl 5.10) prevent backtracking: what gets matched by a pattern with a possessive quantifier will not be backtracked into, even if that causes the whole match to fail. -There is no quantifier C<{,n}>. That's currently illegal. - =head2 EXTENDED CONSTRUCTS (?#text) A comment diff --git a/pod/perlretut.pod b/pod/perlretut.pod index cb4654f552b6..6e9342a5f9c5 100644 --- a/pod/perlretut.pod +++ b/pod/perlretut.pod @@ -20,8 +20,10 @@ expressions will allow you to manipulate text with surprising ease. What is a regular expression? At its most basic, a regular expression is a template that is used to determine if a string has certain characteristics. The string is most often some text, such as a line, -sentence, web page, or even a whole book, but less commonly it could be -some binary data as well. +sentence, web page, or even a whole book, but it doesn't have to be. It +could be binary data, for example. Biologists often use Perl to look +for patterns in long DNA sequences. + Suppose we want to determine if the text in variable, C<$var> contains the sequence of characters S> (blanks added for legibility). We can write in Perl @@ -29,8 +31,9 @@ the sequence of characters S> $var =~ m/mushroom/ The value of this expression will be TRUE if C<$var> contains that -sequence of characters, and FALSE otherwise. The portion enclosed in -C<'E'> characters denotes the characteristic we are looking for. +sequence of characters anywhere within it, and FALSE otherwise. The +portion enclosed in C<'E'> characters denotes the characteristic we +are looking for. We use the term I for it. The process of looking to see if the pattern occurs in the string is called I, and the C<"=~"> operator along with the C tell Perl to try to match the pattern @@ -135,7 +138,7 @@ And finally, the C default delimiters for a match can be changed to arbitrary delimiters by putting an C<'m'> out front: "Hello World" =~ m!World!; # matches, delimited by '!' - "Hello World" =~ m{World}; # matches, note the matching '{}' + "Hello World" =~ m{World}; # matches, note the paired '{}' "/usr/bin/perl" =~ m"/perl"; # matches after '/usr/bin', # '/' becomes an ordinary char @@ -151,7 +154,7 @@ Let's consider how different regexps would match C<"Hello World">: "Hello World" =~ /oW/; # doesn't match "Hello World" =~ /World /; # doesn't match -The first regexp C doesn't match because regexps are +The first regexp C doesn't match because regexps are by default case-sensitive. The second regexp matches because the substring S> occurs in the string S>. The space character C<' '> is treated like any other character in a regexp and is @@ -169,8 +172,8 @@ always match at the earliest possible point in the string: "That hat is red" =~ /hat/; # matches 'hat' in 'That' With respect to character matching, there are a few more points you -need to know about. First of all, not all characters can be used "as -is" in a match. Some characters, called I, are +need to know about. First of all, not all characters can be used +"as-is" in a match. Some characters, called I, are generally reserved for use in regexp notation. The metacharacters are {}[]()^$.|*+?-#\ @@ -832,8 +835,8 @@ Counting the opening parentheses to get the correct number for a backreference is error-prone as soon as there is more than one capturing group. A more convenient technique became available with Perl 5.10: relative backreferences. To refer to the immediately -preceding capture group one now may write C<\g{-1}>, the next but -last is available via C<\g{-2}>, and so on. +preceding capture group one now may write C<\g-1> or C<\g{-1}>, the next but +last is available via C<\g-2> or C<\g{-2}>, and so on. Another good reason in addition to readability and maintainability for using relative backreferences is illustrated by the following example, @@ -1048,10 +1051,17 @@ C means: match at least C or more times =item * +C means: match at most C times, or fewer + +=item * + C means: match exactly C times =back +If you like, you can add blanks (tab or space characters) within the +braces, but adjacent to them, and/or next to the comma (if any). + Here are some examples: /[a-z]+\s+\d*/; # match a lowercase word, at least one space, and @@ -1060,6 +1070,9 @@ Here are some examples: /y(es)?/i; # matches 'y', 'Y', or a case-insensitive 'yes' $year =~ /^\d{2,4}$/; # make sure year is at least 2 but not more # than 4 digits + $year =~ /^\d{ 2, 4 }$/; # Same; for those who like wide open + # spaces. + $year =~ /^\d{2, 4}$/; # Same. $year =~ /^\d{4}$|^\d{2}$/; # better match; throw out 3-digit dates $year =~ /^\d{2}(\d{2})?$/; # same thing written differently. # However, this captures the last two @@ -1223,6 +1236,11 @@ possible =item * +C means: match at most C times, but as few times as +possible + +=item * + C means: match exactly C times. Because we match exactly C times, C is equivalent to C and is just there for notational consistency. @@ -1390,8 +1408,12 @@ for C =item * C means: match at least C times, but as many times as possible, -and don't give anything up. C is short for C and C is -short for C. +and don't give anything up. C is short for C. + +=item * + +C means: match as many times as possible up to at most C +times, and don't give anything up. C is short for C. =item * @@ -1970,10 +1992,11 @@ C<\x>I (without curly braces and I are two hex digits) doesn't go further than 255. (Starting in Perl 5.14, if you're an octal fan, you can also use C<\o{oct}>.) - /\x{263a}/; # match a Unicode smiley face :) + /\x{263a}/; # match a Unicode smiley face :) + /\x{ 263a }/; # Same B: In Perl 5.6.0 it used to be that one needed to say C to use any Unicode features. This is no more the case: for +utf8> to use any Unicode features. This is no longer the case: for almost all Unicode processing, the explicit C pragma is not needed. (The only case where it matters is if your Perl script is in Unicode and encoded in UTF-8, then an explicit C is needed.) @@ -1989,6 +2012,7 @@ could use $x = "abc\N{MERCURY}def"; $x =~ /\N{MERCURY}/; # matches + $x =~ /\N{ MERCURY }/; # Also matches One can also use "short" names: @@ -2050,16 +2074,16 @@ C<\p{Mark}>, meaning things like accent marks. The Unicode C<\p{Script}> and C<\p{Script_Extensions}> properties are used to categorize every Unicode character into the language script it -is written in. (C is an improved version of -C