[PATCH] speed up building with less disk IO pod moves+__END__+misc

p5pRT commented 10 years ago

Migrated from rt.perl.org#122955 (status was 'resolved')

Searchable as RT122955$

p5pRT commented 10 years ago

From @bulk88

Created by @bulk88

See attached patch.

Before after Process Monon logs

BEFORE 6:17:59.5589413 AM nmake.exe 9464 11924 CreateFile
C:\perl521\srcnewb4opt SUCCESS Desired Access: Read Data/List Directory\, Synchronize\, Disposition: Open\, Options: Directory\, Synchronous IO Non-Alert\, Attributes: n/a\, ShareMode: Read\, Write\, AllocationSize: n/a\, OpenResult: Opened 6:17:59.5589644 AM nmake.exe 9464 11924 QueryDirectory
C:\perl521\srcnewb4opt\miniperl.exe SUCCESS Filter: miniperl.exe\, 1: miniperl.exe 6:17:59.5590318 AM nmake.exe 9464 11924 CloseFile
C:\perl521\srcnewb4opt SUCCESS
6:17:59.5591530 AM nmake.exe 9464 11924 CreateFile
C:\perl521\srcnewb4opt SUCCESS Desired Access: Read Data/List Directory\, Synchronize\, Disposition: Open\, Options: Directory\, Synchronous IO Non-Alert\, Attributes: n/a\, ShareMode: Read\, Write\, AllocationSize: n/a\, OpenResult: Opened 6:17:59.5591703 AM nmake.exe 9464 11924 QueryDirectory
C:\perl521\srcnewb4opt\miniperl.asm NO SUCH FILE Filter: miniperl.asm 6:17:59.5592553 AM nmake.exe 9464 11924 CloseFile
C:\perl521\srcnewb4opt SUCCESS
6:17:59.5593366 AM nmake.exe 9464 11924 CreateFile
C:\perl521\srcnewb4opt SUCCESS Desired Access: Read Data/List Directory\, Synchronize\, Disposition: Open\, Options: Directory\, Synchronous IO Non-Alert\, Attributes: n/a\, ShareMode: Read\, Write\, AllocationSize: n/a\, OpenResult: Opened 6:17:59.5593533 AM nmake.exe 9464 11924 QueryDirectory
C:\perl521\srcnewb4opt\miniperl.c NO SUCH FILE Filter: miniperl.c 6:17:59.5593863 AM nmake.exe 9464 11924 CloseFile
C:\perl521\srcnewb4opt SUCCESS
6:17:59.5594665 AM nmake.exe 9464 11924 CreateFile
C:\perl521\srcnewb4opt SUCCESS Desired Access: Read Data/List Directory\, Synchronize\, Disposition: Open\, Options: Directory\, Synchronous IO Non-Alert\, Attributes: n/a\, ShareMode: Read\, Write\, AllocationSize: n/a\, OpenResult: Opened 6:17:59.5594827 AM nmake.exe 9464 11924 QueryDirectory
C:\perl521\srcnewb4opt\miniperl.cpp NO SUCH FILE Filter: miniperl.cpp 6:17:59.5595025 AM nmake.exe 9464 11924 CloseFile
C:\perl521\srcnewb4opt SUCCESS
6:17:59.5596087 AM nmake.exe 9464 11924 CreateFile
C:\perl521\srcnewb4opt SUCCESS Desired Access: Read Data/List Directory\, Synchronize\, Disposition: Open\, Options: Directory\, Synchronous IO Non-Alert\, Attributes: n/a\, ShareMode: Read\, Write\, AllocationSize: n/a\, OpenResult: Opened 6:17:59.5596277 AM nmake.exe 9464 11924 QueryDirectory
C:\perl521\srcnewb4opt\miniperl.cxx NO SUCH FILE Filter: miniperl.cxx 6:17:59.5596472 AM nmake.exe 9464 11924 CloseFile
C:\perl521\srcnewb4opt SUCCESS
6:17:59.5597335 AM nmake.exe 9464 11924 CreateFile
C:\perl521\srcnewb4opt SUCCESS Desired Access: Read Data/List Directory\, Synchronize\, Disposition: Open\, Options: Directory\, Synchronous IO Non-Alert\, Attributes: n/a\, ShareMode: Read\, Write\, AllocationSize: n/a\, OpenResult: Opened 6:17:59.5597511 AM nmake.exe 9464 11924 QueryDirectory
C:\perl521\srcnewb4opt\miniperl.cbl NO SUCH FILE Filter: miniperl.cbl 6:17:59.5597699 AM nmake.exe 9464 11924 CloseFile
C:\perl521\srcnewb4opt SUCCESS
6:17:59.5598601 AM nmake.exe 9464 11924 CreateFile
C:\perl521\srcnewb4opt SUCCESS Desired Access: Read Data/List Directory\, Synchronize\, Disposition: Open\, Options: Directory\, Synchronous IO Non-Alert\, Attributes: n/a\, ShareMode: Read\, Write\, AllocationSize: n/a\, OpenResult: Opened 6:17:59.5598805 AM nmake.exe 9464 11924 QueryDirectory
C:\perl521\srcnewb4opt\miniperl.f NO SUCH FILE Filter: miniperl.f 6:17:59.5598989 AM nmake.exe 9464 11924 CloseFile
C:\perl521\srcnewb4opt SUCCESS
6:17:59.5599950 AM nmake.exe 9464 11924 CreateFile
C:\perl521\srcnewb4opt SUCCESS Desired Access: Read Data/List Directory\, Synchronize\, Disposition: Open\, Options: Directory\, Synchronous IO Non-Alert\, Attributes: n/a\, ShareMode: Read\, Write\, AllocationSize: n/a\, OpenResult: Opened 6:17:59.5600149 AM nmake.exe 9464 11924 QueryDirectory
C:\perl521\srcnewb4opt\miniperl.f90 NO SUCH FILE Filter: miniperl.f90 6:17:59.5600448 AM nmake.exe 9464 11924 CloseFile
C:\perl521\srcnewb4opt SUCCESS
6:17:59.5601258 AM nmake.exe 9464 11924 CreateFile
C:\perl521\srcnewb4opt SUCCESS Desired Access: Read Data/List Directory\, Synchronize\, Disposition: Open\, Options: Directory\, Synchronous IO Non-Alert\, Attributes: n/a\, ShareMode: Read\, Write\, AllocationSize: n/a\, OpenResult: Opened 6:17:59.5601431 AM nmake.exe 9464 11924 QueryDirectory
C:\perl521\srcnewb4opt\miniperl.for NO SUCH FILE Filter: miniperl.for 6:17:59.5601621 AM nmake.exe 9464 11924 CloseFile
C:\perl521\srcnewb4opt SUCCESS
6:17:59.5602442 AM nmake.exe 9464 11924 CreateFile
C:\perl521\srcnewb4opt SUCCESS Desired Access: Read Data/List Directory\, Synchronize\, Disposition: Open\, Options: Directory\, Synchronous IO Non-Alert\, Attributes: n/a\, ShareMode: Read\, Write\, AllocationSize: n/a\, OpenResult: Opened 6:17:59.5602615 AM nmake.exe 9464 11924 QueryDirectory
C:\perl521\srcnewb4opt\miniperl.pas NO SUCH FILE Filter: miniperl.pas 6:17:59.5602803 AM nmake.exe 9464 11924 CloseFile
C:\perl521\srcnewb4opt SUCCESS
6:17:59.5603590 AM nmake.exe 9464 11924 CreateFile
C:\perl521\srcnewb4opt SUCCESS Desired Access: Read Data/List Directory\, Synchronize\, Disposition: Open\, Options: Directory\, Synchronous IO Non-Alert\, Attributes: n/a\, ShareMode: Read\, Write\, AllocationSize: n/a\, OpenResult: Opened

NO AFTER

BEFORE 6:39:03.3043084 AM miniperl.exe 11460 10280 CreateFile
C:\perl521\srcnewb4opt\lib\File\Find.pm SUCCESS Desired Access: Generic Read\, Disposition: Open\, Options: Synchronous IO Non-Alert\, Non-Directory File\, Attributes: N\, ShareMode: Read\, Write\, AllocationSize: n/a\, OpenResult: Opened 6:39:03.3044844 AM miniperl.exe 11460 10280 ReadFile
C:\perl521\srcnewb4opt\lib\File\Find.pm SUCCESS Offset: 0\, Length: 4\,096 6:39:03.3050004 AM miniperl.exe 11460 10280 ReadFile
C:\perl521\srcnewb4opt\lib\File\Find.pm SUCCESS Offset: 4\,096\, Length: 4\,096 6:39:03.3050859 AM miniperl.exe 11460 10280 ReadFile
C:\perl521\srcnewb4opt\lib\File\Find.pm SUCCESS Offset: 8\,192\, Length: 4\,096 6:39:03.3053066 AM miniperl.exe 11460 10280 ReadFile
C:\perl521\srcnewb4opt\lib\File\Find.pm SUCCESS Offset: 12\,288\, Length: 4\,096 6:39:03.3063271 AM miniperl.exe 11460 10280 ReadFile
C:\perl521\srcnewb4opt\lib\File\Find.pm SUCCESS Offset: 16\,384\, Length: 4\,096 6:39:03.3075775 AM miniperl.exe 11460 10280 ReadFile
C:\perl521\srcnewb4opt\lib\File\Find.pm SUCCESS Offset: 20\,480\, Length: 4\,096 6:39:03.3099239 AM miniperl.exe 11460 10280 ReadFile
C:\perl521\srcnewb4opt\lib\File\Find.pm SUCCESS Offset: 24\,576\, Length: 4\,096 6:39:03.3108564 AM miniperl.exe 11460 10280 ReadFile
C:\perl521\srcnewb4opt\lib\File\Find.pm SUCCESS Offset: 28\,672\, Length: 4\,096 6:39:03.3120488 AM miniperl.exe 11460 10280 ReadFile
C:\perl521\srcnewb4opt\lib\File\Find.pm SUCCESS Offset: 32\,768\, Length: 1\,153 6:39:03.3130749 AM miniperl.exe 11460 10280 ReadFile
C:\perl521\srcnewb4opt\lib\File\Find.pm END OF FILE Offset: 33\,921\, Length: 4\,096 6:39:03.3131034 AM miniperl.exe 11460 10280 CloseFile
C:\perl521\srcnewb4opt\lib\File\Find.pm SUCCESS

AFTER 7:15:09.0981100 AM miniperl.exe 5000 11044 CreateFile
C:\perl521\srcnewb4opt\ext\File-Find\lib\File\Find.pm SUCCESS
Desired Access: Generic Read\, Disposition: Open\, Options: Synchronous IO Non-Alert\, Non-Directory File\, Attributes: N\, ShareMode: Read\, Write\, AllocationSize: n/a\, OpenResult: Opened 7:15:09.0982710 AM miniperl.exe 5000 11044 ReadFile
C:\perl521\srcnewb4opt\ext\File-Find\lib\File\Find.pm SUCCESS
Offset: 0\, Length: 4\,096 7:15:09.0999058 AM miniperl.exe 5000 11044 ReadFile
C:\perl521\srcnewb4opt\ext\File-Find\lib\File\Find.pm SUCCESS
Offset: 4\,096\, Length: 4\,096 7:15:09.1011521 AM miniperl.exe 5000 11044 ReadFile
C:\perl521\srcnewb4opt\ext\File-Find\lib\File\Find.pm SUCCESS
Offset: 8\,192\, Length: 4\,096 7:15:09.1020913 AM miniperl.exe 5000 11044 ReadFile
C:\perl521\srcnewb4opt\ext\File-Find\lib\File\Find.pm SUCCESS
Offset: 12\,288\, Length: 4\,096 7:15:09.1032518 AM miniperl.exe 5000 11044 ReadFile
C:\perl521\srcnewb4opt\ext\File-Find\lib\File\Find.pm SUCCESS
Offset: 16\,384\, Length: 4\,096 7:15:09.1044751 AM miniperl.exe 5000 11044 ReadFile
C:\perl521\srcnewb4opt\ext\File-Find\lib\File\Find.pm SUCCESS
Offset: 20\,480\, Length: 4\,096 7:15:09.1057786 AM miniperl.exe 5000 11044 CloseFile
C:\perl521\srcnewb4opt\ext\File-Find\lib\File\Find.pm SUCCESS

BEFORE 6:39:03.7949895 AM miniperl.exe 11048 11848 CreateFile
C:\perl521\srcnewb4opt\lib\Carp.pm SUCCESS Desired Access: Generic Read\, Disposition: Open\, Options: Synchronous IO Non-Alert\, Non-Directory File\, Attributes: N\, ShareMode: Read\, Write\, AllocationSize: n/a\, OpenResult: Opened 6:39:03.7950247 AM miniperl.exe 11048 11848 ReadFile
C:\perl521\srcnewb4opt\lib\Carp.pm SUCCESS Offset: 0\, Length: 4\,096 6:39:03.7952468 AM miniperl.exe 11048 11848 CreateFile
C:\perl521\srcnewb4opt\lib SUCCESS Desired Access: Read Data/List Directory\, Synchronize\, Disposition: Open\, Options: Directory\, Synchronous IO Non-Alert\, Attributes: n/a\, ShareMode: Read\, Write\, AllocationSize: n/a\, OpenResult: Opened 6:39:03.7952700 AM miniperl.exe 11048 11848 QueryDirectory
C:\perl521\srcnewb4opt\lib\warnings.pm SUCCESS Filter: warnings.pm\, 1: warnings.pm 6:39:03.7952971 AM miniperl.exe 11048 11848 CloseFile
C:\perl521\srcnewb4opt\lib SUCCESS
6:39:03.7954222 AM miniperl.exe 11048 11848 CreateFile
C:\perl521\srcnewb4opt\lib\warnings.pm SUCCESS Desired Access: Generic Read\, Disposition: Open\, Options: Synchronous IO Non-Alert\, Non-Directory File\, Attributes: N\, ShareMode: Read\, Write\, AllocationSize: n/a\, OpenResult: Opened 6:39:03.7954582 AM miniperl.exe 11048 11848 ReadFile
C:\perl521\srcnewb4opt\lib\warnings.pm SUCCESS Offset: 0\, Length: 4\,096 6:39:03.7956197 AM miniperl.exe 11048 11848 ReadFile
C:\perl521\srcnewb4opt\lib\warnings.pm SUCCESS Offset: 4\,096\, Length: 4\,096 6:39:03.7956932 AM miniperl.exe 11048 11848 ReadFile
C:\perl521\srcnewb4opt\lib\warnings.pm SUCCESS Offset: 8\,192\, Length: 4\,096 6:39:03.7957463 AM miniperl.exe 11048 11848 ReadFile
C:\perl521\srcnewb4opt\lib\warnings.pm SUCCESS Offset: 12\,288\, Length: 4\,096 6:39:03.7958016 AM miniperl.exe 11048 11848 ReadFile
C:\perl521\srcnewb4opt\lib\warnings.pm SUCCESS Offset: 16\,384\, Length: 4\,096 6:39:03.7958915 AM miniperl.exe 11048 11848 ReadFile
C:\perl521\srcnewb4opt\lib\warnings.pm SUCCESS Offset: 20\,480\, Length: 4\,096 6:39:03.7962631 AM miniperl.exe 11048 11848 ReadFile
C:\perl521\srcnewb4opt\lib\warnings.pm SUCCESS Offset: 24\,576\, Length: 4\,096 6:39:03.7965707 AM miniperl.exe 11048 11848 ReadFile
C:\perl521\srcnewb4opt\lib\warnings.pm SUCCESS Offset: 28\,672\, Length: 4\,096 6:39:03.7968945 AM miniperl.exe 11048 11848 ReadFile
C:\perl521\srcnewb4opt\lib\warnings.pm SUCCESS Offset: 32\,768\, Length: 4\,096 6:39:03.7974848 AM miniperl.exe 11048 11848 ReadFile
C:\perl521\srcnewb4opt\lib\warnings.pm SUCCESS Offset: 36\,864\, Length: 4\,096 6:39:03.7986019 AM miniperl.exe 11048 11848 ReadFile
C:\perl521\srcnewb4opt\lib\warnings.pm SUCCESS Offset: 40\,960\, Length: 26 6:39:03.7986276 AM miniperl.exe 11048 11848 ReadFile
C:\perl521\srcnewb4opt\lib\warnings.pm END OF FILE Offset: 40\,986\, Length: 4\,096 6:39:03.7986422 AM miniperl.exe 11048 11848 CloseFile
C:\perl521\srcnewb4opt\lib\warnings.pm SUCCESS
6:39:03.7998568 AM miniperl.exe 11048 11848 ReadFile
C:\perl521\srcnewb4opt\lib\Carp.pm SUCCESS Offset: 4\,096\, Length: 4\,096 6:39:03.8009056 AM miniperl.exe 11048 11848 ReadFile
C:\perl521\srcnewb4opt\lib\Carp.pm SUCCESS Offset: 8\,192\, Length: 4\,096 6:39:03.8020627 AM miniperl.exe 11048 11848 ReadFile
C:\perl521\srcnewb4opt\lib\Carp.pm SUCCESS Offset: 12\,288\, Length: 4\,096 6:39:03.8029003 AM miniperl.exe 11048 11848 ReadFile
C:\perl521\srcnewb4opt\lib\Carp.pm SUCCESS Offset: 16\,384\, Length: 4\,096 6:39:03.8032746 AM miniperl.exe 11048 11848 CloseFile
C:\perl521\srcnewb4opt\lib\Carp.pm SUCCESS

AFTER- no change since POD is about ~4KB itselk 7:15:09.2287026 AM miniperl.exe 5000 11044 CreateFile
C:\perl521\srcnewb4opt\dist\Carp\lib\Carp.pm SUCCESS Desired Access: Generic Read\, Disposition: Open\, Options: Synchronous IO Non-Alert\, Non-Directory File\, Attributes: N\, ShareMode: Read\, Write\, AllocationSize: n/a\, OpenResult: Opened 7:15:09.2288557 AM miniperl.exe 5000 11044 ReadFile
C:\perl521\srcnewb4opt\dist\Carp\lib\Carp.pm SUCCESS Offset: 0\, Length: 4\,096 7:15:09.2301212 AM miniperl.exe 5000 11044 ReadFile
C:\perl521\srcnewb4opt\dist\Carp\lib\Carp.pm SUCCESS Offset: 4\,096\, Length: 4\,096 7:15:09.2314094 AM miniperl.exe 5000 11044 ReadFile
C:\perl521\srcnewb4opt\dist\Carp\lib\Carp.pm SUCCESS Offset: 8\,192\, Length: 4\,096 7:15:09.2327023 AM miniperl.exe 5000 11044 ReadFile
C:\perl521\srcnewb4opt\dist\Carp\lib\Carp.pm SUCCESS Offset: 12\,288\, Length: 4\,096 7:15:09.2337058 AM miniperl.exe 5000 11044 ReadFile
C:\perl521\srcnewb4opt\dist\Carp\lib\Carp.pm SUCCESS Offset: 16\,384\, Length: 4\,096 7:15:09.2342248 AM miniperl.exe 5000 11044 CloseFile
C:\perl521\srcnewb4opt\dist\Carp\lib\Carp.pm SUCCESS

AFTER 7:14:58.9272313 AM miniperl.exe 11096 10024 CreateFile
C:\perl521\srcnewb4opt\lib\warnings.pm SUCCESS Desired Access: Generic Read\, Disposition: Open\, Options: Synchronous IO Non-Alert\, Non-Directory File\, Attributes: N\, ShareMode: Read\, Write\, AllocationSize: n/a\, OpenResult: Opened 7:14:58.9273520 AM miniperl.exe 11096 10024 ReadFile
C:\perl521\srcnewb4opt\lib\warnings.pm SUCCESS Offset: 0\, Length: 4\,096 7:14:58.9279954 AM miniperl.exe 11096 10024 ReadFile
C:\perl521\srcnewb4opt\lib\warnings.pm SUCCESS Offset: 4\,096\, Length: 4\,096 7:14:58.9284052 AM miniperl.exe 11096 10024 ReadFile
C:\perl521\srcnewb4opt\lib\warnings.pm SUCCESS Offset: 8\,192\, Length: 4\,096 7:14:58.9288218 AM miniperl.exe 11096 10024 ReadFile
C:\perl521\srcnewb4opt\lib\warnings.pm SUCCESS Offset: 12\,288\, Length: 4\,096 7:14:58.9296560 AM miniperl.exe 11096 10024 ReadFile
C:\perl521\srcnewb4opt\lib\warnings.pm SUCCESS Offset: 16\,384\, Length: 4\,096 7:14:58.9306907 AM miniperl.exe 11096 10024 CloseFile
C:\perl521\srcnewb4opt\lib\warnings.pm SUCCESS

BEFORE 6:39:03.9224568 AM miniperl.exe 11984 11744 CreateFile
C:\perl521\srcnewb4opt\dist\PathTools\Cwd.pm SUCCESS Desired Access: Generic Read\, Disposition: Open\, Options: Synchronous IO Non-Alert\, Non-Directory File\, Attributes: N\, ShareMode: Read\, Write\, AllocationSize: n/a\, OpenResult: Opened 6:39:03.9224981 AM miniperl.exe 11984 11744 ReadFile
C:\perl521\srcnewb4opt\dist\PathTools\Cwd.pm SUCCESS Offset: 0\, Length: 4\,096 6:39:03.9226174 AM miniperl.exe 11984 11744 ReadFile
C:\perl521\srcnewb4opt\dist\PathTools\Cwd.pm SUCCESS Offset: 4\,096\, Length: 4\,096 6:39:03.9233130 AM miniperl.exe 11984 11744 ReadFile
C:\perl521\srcnewb4opt\dist\PathTools\Cwd.pm SUCCESS Offset: 8\,192\, Length: 4\,096 6:39:03.9239181 AM miniperl.exe 11984 11744 ReadFile
C:\perl521\srcnewb4opt\dist\PathTools\Cwd.pm SUCCESS Offset: 12\,288\, Length: 4\,096 6:39:03.9250661 AM miniperl.exe 11984 11744 ReadFile
C:\perl521\srcnewb4opt\dist\PathTools\Cwd.pm SUCCESS Offset: 16\,384\, Length: 4\,096 6:39:03.9259762 AM miniperl.exe 11984 11744 ReadFile
C:\perl521\srcnewb4opt\dist\PathTools\Cwd.pm SUCCESS Offset: 20\,480\, Length: 2\,228 6:39:03.9265227 AM miniperl.exe 11984 11744 ReadFile
C:\perl521\srcnewb4opt\dist\PathTools\Cwd.pm END OF FILE Offset: 22\,708\, Length: 4\,096 6:39:03.9265380 AM miniperl.exe 11984 11744 CloseFile
C:\perl521\srcnewb4opt\dist\PathTools\Cwd.pm SUCCESS

AFTER 7:14:58.9773969 AM miniperl.exe 11096 10024 CreateFile
C:\perl521\srcnewb4opt\dist\PathTools\Cwd.pm SUCCESS Desired Access: Generic Read\, Disposition: Open\, Options: Synchronous IO Non-Alert\, Non-Directory File\, Attributes: N\, ShareMode: Read\, Write\, AllocationSize: n/a\, OpenResult: Opened 7:14:58.9774992 AM miniperl.exe 11096 10024 ReadFile
C:\perl521\srcnewb4opt\dist\PathTools\Cwd.pm SUCCESS Offset: 0\, Length: 4\,096 7:14:58.9783392 AM miniperl.exe 11096 10024 ReadFile
C:\perl521\srcnewb4opt\dist\PathTools\Cwd.pm SUCCESS Offset: 4\,096\, Length: 4\,096 7:14:58.9790779 AM miniperl.exe 11096 10024 ReadFile
C:\perl521\srcnewb4opt\dist\PathTools\Cwd.pm SUCCESS Offset: 8\,192\, Length: 4\,096 7:14:58.9802981 AM miniperl.exe 11096 10024 ReadFile
C:\perl521\srcnewb4opt\dist\PathTools\Cwd.pm SUCCESS Offset: 12\,288\, Length: 4\,096 7:14:58.9813379 AM miniperl.exe 11096 10024 ReadFile
C:\perl521\srcnewb4opt\dist\PathTools\Cwd.pm SUCCESS Offset: 16\,384\, Length: 4\,096 7:14:58.9822146 AM miniperl.exe 11096 10024 CloseFile
C:\perl521\srcnewb4opt\dist\PathTools\Cwd.pm SUCCESS

Perl Info

``` Flags: category=core severity=low Site configuration information for perl 5.21.4: Configured by Owner at Thu Sep 18 12:08:58 2014. Summary of my perl5 (revision 5 version 21 subversion 4) configuration: Derived from: 7d2b2edb94ab56333b9049a3e26d15ea18445512 Ancestor: 19be3be6968e2337bcdfe480693fff795ecd1304 Platform: osname=MSWin32, osvers=5.1, archname=MSWin32-x86-multi-thread uname='' config_args='undef' hint=recommended, useposix=true, d_sigaction=undef useithreads=define, usemultiplicity=define use64bitint=undef, use64bitall=undef, uselongdouble=undef usemymalloc=n, bincompat5005=undef Compiler: cc='cl', ccflags ='-nologo -GF -W3 -O1 -MD -Zi -DNDEBUG -DWIN32 -D_CONSOLE -DNO_STRICT -DPERL_TEXTMODE_SCRIPTS -DPERL_HASH_FUNC_ONE_AT_A_TIME -DPERL_IMPLICIT_CONTEXT -DPERL_IMPLICIT_SYS -DUSE_PERLIO -D_USE_32BIT_TIME_T', optimize='-O1 -MD -Zi -DNDEBUG', cppflags='-DWIN32' ccversion='12.00.8168', gccversion='', gccosandvers='' intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=1234 d_longlong=undef, longlongsize=8, d_longdbl=define, longdblsize=8, longdblkind=0 ivtype='long', ivsize=4, nvtype='double', nvsize=8, Off_t='__int64', lseeksize=8 alignbytes=8, prototype=define Linker and Libraries: ld='link', ldflags ='-nologo -nodefaultlib -debug -opt:ref,icf -libpath:"c:\perl521\lib\CORE" -machine:x86' libpth=C:\PROGRA~1\MIAF9D~1\VC98\lib libs=oldnames.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib netapi32.lib uuid.lib ws2_32.lib mpr.lib winmm.lib version.lib odbc32.lib odbccp32.lib comctl32.lib msvcrt.lib perllibs=oldnames.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib netapi32.lib uuid.lib ws2_32.lib mpr.lib winmm.lib version.lib odbc32.lib odbccp32.lib comctl32.lib msvcrt.lib libc=msvcrt.lib, so=dll, useshrplib=true, libperl=perl521.lib gnulibc_version='' Dynamic Linking: dlsrc=dl_win32.xs, dlext=dll, d_dlsymun=undef, ccdlflags=' ' cccdlflags=' ', lddlflags='-dll -nologo -nodefaultlib -debug -opt:ref,icf -libpath:"c:\perl521\lib\CORE" -machine:x86' Locally applied patches: uncommitted-changes a0fe7a7e75de29e59f1da0d6822dc06e5be658fe a261faffee83d0145642ab5d1d046c9f813bc497 6506ab86ad1602a9ca720fcd30446dce1461d23d 7d2b2edb94ab56333b9049a3e26d15ea18445512 @INC for perl 5.21.4: lib C:/perl521/srcnew/lib . Environment for perl 5.21.4: HOME (unset) LANG (unset) LANGUAGE (unset) LD_LIBRARY_PATH (unset) LOGDIR (unset) PATH= PERL_BADLANG (unset) PERL_JSON_BACKEND=Cpanel::JSON::XS PERL_YAML_BACKEND=YAML SHELL (unset) ```

p5pRT commented 10 years ago

From @bulk88

0001-speed-up-building-with-less-disk-IO-pod-moves-_END.patch

p5pRT commented 10 years ago

From @cpansprout

On Sat Oct 11 18:55:25 2014\, bulk88 wrote:

This is a bug report for perl from bulk88@hotmail.com\, generated with the help of perlbug 1.40 running under perl 5.21.4.

----------------------------------------------------------------- [Please describe your issue here]

See attached patch.

You’ve accidentally blown away the hierarchy tree in warnings.pm and instead left the placeholder that warnings.pl usually replaces with the tree:

+=for warnings.pl tree-goes-here

--

Father Chrysostomos

p5pRT commented 10 years ago

The RT System itself - Status changed from 'new' to 'open'

p5pRT commented 10 years ago

From @bulk88

On Sat Oct 11 23:44:52 2014\, sprout wrote:

On Sat Oct 11 18:55:25 2014\, bulk88 wrote:

This is a bug report for perl from bulk88@hotmail.com\, generated with the help of perlbug 1.40 running under perl 5.21.4.

----------------------------------------------------------------- [Please describe your issue here]

See attached patch.

You’ve accidentally blown away the hierarchy tree in warnings.pm and instead left the placeholder that warnings.pl usually replaces with the tree:

+=for warnings.pl tree-goes-here

Revised patch attached. warnings.pl had code moved around so that tree is after KEYWORDS sentinel.

-- bulk88 ~ bulk88 at hotmail.com

p5pRT commented 10 years ago

From @bulk88

0001-speed-up-building-with-less-disk-IO-pod-moves-_END.patch

p5pRT commented 10 years ago

From @bulk88

After making this patch I did some analysis of a capture of all ReadFile calls by any miniperl.exe process during a "nmake all". I've attached a CSV file with the hottest by number of read calls (and all of them are in 4096 bytes or less if EOF at a time chunks). I cut it off after 10 since otherwise almost (maybe thats an exaggeration) every .pm file in the repo will be in the list. This list is basically a list of which .pm files to make as short as possible for the perl compiler/parser\, or to refactor into heavy and light versions\, or remove whitespace from them or remove excessive source code comments. If the perl code section of the .pm is below 4096\, there is nothing to optimize obviously\, except by removing the dependency on that module completely from some invocations/loads of that module.

-- bulk88 ~ bulk88 at hotmail.com

p5pRT commented 10 years ago

From @bulk88

[miniperl_read()_calls_by_file.csv](https://rt-archive.perl.org/perl5/Ticket/Attachment/1313006/697938/miniperl_read()_calls_by_file.csv)

p5pRT commented 10 years ago

From @cpansprout

On Sun Oct 12 00:45:02 2014\, bulk88 wrote:

On Sat Oct 11 23:44:52 2014\, sprout wrote:

On Sat Oct 11 18:55:25 2014\, bulk88 wrote:

This is a bug report for perl from bulk88@hotmail.com\, generated with the help of perlbug 1.40 running under perl 5.21.4.

----------------------------------------------------------------- [Please describe your issue here]

See attached patch.

You’ve accidentally blown away the hierarchy tree in warnings.pm and instead left the placeholder that warnings.pl usually replaces with the tree:

+=for warnings.pl tree-goes-here

Revised patch attached. warnings.pl had code moved around so that tree is after KEYWORDS sentinel.

It did not apply cleanly\, so I pushed it to the sprout/122955 branch\, since I am notorious for screwing up things like this. Please review it.

--

Father Chrysostomos

p5pRT commented 10 years ago

From @bulk88

On Sun Oct 12 07:56:16 2014\, sprout wrote:

It did not apply cleanly\, so I pushed it to the sprout/122955 branch\, since I am notorious for screwing up things like this. Please review it.

Since the risk is high of screwing up is high since a new warnings flag was added recently and the first patch was broken\, I've removed the warnings.pl/warnings.pl stuff\, and it will be in a future patch on a more recent blead. Attached is a simpler patch with warnings.pm stuff removed. There should be no conflicts.

-- bulk88 ~ bulk88 at hotmail.com

p5pRT commented 10 years ago

From @bulk88

0001-speed-up-building-with-less-disk-IO-pod-moves-_END.patch

p5pRT commented 10 years ago

From @tonycoz

On Sun Oct 12 01:43:46 2014\, bulk88 wrote:

After making this patch I did some analysis of a capture of all ReadFile calls by any miniperl.exe process during a "nmake all". I've attached a CSV file with the hottest by number of read calls (and all of them are in 4096 bytes or less if EOF at a time chunks).

I'd considered reading perl source with a buffer size of 4096 to be a bug in itself.

Tony

p5pRT commented 10 years ago

From @cpansprout

On Sun Oct 12 17:04:09 2014\, tonyc wrote:

On Sun Oct 12 01:43:46 2014\, bulk88 wrote:

After making this patch I did some analysis of a capture of all ReadFile calls by any miniperl.exe process during a "nmake all". I've attached a CSV file with the hottest by number of read calls (and all of them are in 4096 bytes or less if EOF at a time chunks).

I'd considered reading perl source with a buffer size of 4096 to be a bug in itself.

Could you clarify?

--

Father Chrysostomos

p5pRT commented 10 years ago

From @bulk88

On Sun Oct 12 16:08:10 2014\, bulk88 wrote:

On Sun Oct 12 07:56:16 2014\, sprout wrote:

It did not apply cleanly\, so I pushed it to the sprout/122955 branch\, since I am notorious for screwing up things like this. Please review it.

Since the risk is high of screwing up is high since a new warnings flag was added recently and the first patch was broken\, I've removed the warnings.pl/warnings.pl stuff\, and it will be in a future patch on a more recent blead. Attached is a simpler patch with warnings.pm stuff removed. There should be no conflicts.

Fixed a comment in win32/Makefile in the last patch + rebased to latest blead.

-- bulk88 ~ bulk88 at hotmail.com

p5pRT commented 10 years ago

From @bulk88

0001-speed-up-building-with-less-disk-IO-pod-moves-_END.patch

p5pRT commented 10 years ago

From @craigberry

On Sun\, Oct 12\, 2014 at 7:53 PM\, Father Chrysostomos via RT \perlbug\-followup@perl\.org wrote:

I'd considered reading perl source with a buffer size of 4096 to be a bug in itself.

Could you clarify?

Reading 4K at a time off disk is going to be inefficient compared to reading larger chunks\, especially if we're stopping to expand memory and/or percolate up through the perlio layers each time. When using perlio\, the perlio buffer should be the larger of 8192 and BUFSIZ\, which increased speed dramatically compare to 4K buffers. See

http://perl5.git.perl.org/perl.git/commitdiff/b83080de5c42543809ce9004bcdbcd3162a00e70

Of course 8K is pretty small by today's standards so that could probably be revisited. One of the problems is that the buffer is the same size regardless of whether we're reading off disk or through a pipe. And what's optimal for reading files in general may or may not be optimal for reading Perl source.

p5pRT commented 9 years ago

From @bulk88

On Sun Oct 12 07:56:16 2014\, sprout wrote:

It did not apply cleanly\, so I pushed it to the sprout/122955 branch\, since I am notorious for screwing up things like this. Please review it.

Since I didn't feel comfortable in reviewing sprout/122955 and merge conflicts. I redid the warnings.pm stuff from scratch using the latest blead. 2 patches attaches. Whitespace patch is new.

-- bulk88 ~ bulk88 at hotmail.com

p5pRT commented 9 years ago

From @bulk88

0001-move-POD-in-warnings.pm-to-end-of-file-to-reduce-mod.patch

```diff From 9954ec6ca1c23d7873b84a0222bfdf87f99a0613 Mon Sep 17 00:00:00 2001 From: Daniel Dragan Date: Sun, 12 Oct 2014 21:57:01 -0400 Subject: [PATCH 1/2] move POD in warnings.pm to end of file to reduce module load I/O calls warnings.pm is the hottest file/takes the most read() calls of any module during a make all. By moving POD to the end, ~40KB of OS read() IO was reduced to ~16KB of OS read() IO calls. Also the parser doesn't need to search for Perl code in the POD further lessining load time because of the __END__ token. Filed as [perl #122955]. --- lib/warnings.pm | 1138 ++++++++++++++++++++++++++-------------------------- regen/warnings.pl | 480 +++++++++++----------- 2 files changed, 809 insertions(+), 809 deletions(-) diff --git a/lib/warnings.pm b/lib/warnings.pm index 5f7a20d..882ce5c 100644 --- a/lib/warnings.pm +++ b/lib/warnings.pm @@ -5,7 +5,7 @@ package warnings; -our $VERSION = '1.27'; +our $VERSION = '1.28'; # Verify that we're called correctly so that warnings will work. # see also strict.pm. @@ -14,6 +14,463 @@ unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) { die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n"); } +our %Offsets = ( + + # Warnings Categories added in Perl 5.008 + + 'all' => 0, + 'closure' => 2, + 'deprecated' => 4, + 'exiting' => 6, + 'glob' => 8, + 'io' => 10, + 'closed' => 12, + 'exec' => 14, + 'layer' => 16, + 'newline' => 18, + 'pipe' => 20, + 'unopened' => 22, + 'misc' => 24, + 'numeric' => 26, + 'once' => 28, + 'overflow' => 30, + 'pack' => 32, + 'portable' => 34, + 'recursion' => 36, + 'redefine' => 38, + 'regexp' => 40, + 'severe' => 42, + 'debugging' => 44, + 'inplace' => 46, + 'internal' => 48, + 'malloc' => 50, + 'signal' => 52, + 'substr' => 54, + 'syntax' => 56, + 'ambiguous' => 58, + 'bareword' => 60, + 'digit' => 62, + 'parenthesis' => 64, + 'precedence' => 66, + 'printf' => 68, + 'prototype' => 70, + 'qw' => 72, + 'reserved' => 74, + 'semicolon' => 76, + 'taint' => 78, + 'threads' => 80, + 'uninitialized' => 82, + 'unpack' => 84, + 'untie' => 86, + 'utf8' => 88, + 'void' => 90, + + # Warnings Categories added in Perl 5.011 + + 'imprecision' => 92, + 'illegalproto' => 94, + + # Warnings Categories added in Perl 5.013 + + 'non_unicode' => 96, + 'nonchar' => 98, + 'surrogate' => 100, + + # Warnings Categories added in Perl 5.017 + + 'experimental' => 102, + 'experimental::lexical_subs'=> 104, + 'experimental::lexical_topic'=> 106, + 'experimental::regex_sets'=> 108, + 'experimental::smartmatch'=> 110, + + # Warnings Categories added in Perl 5.019 + + 'experimental::autoderef'=> 112, + 'experimental::postderef'=> 114, + 'experimental::signatures'=> 116, + 'syscalls' => 118, + + # Warnings Categories added in Perl 5.021 + + 'experimental::lvalue_refs'=> 120, + 'experimental::win32_perlio'=> 122, + 'missing' => 124, + 'redundant' => 126, + ); + +our %Bits = ( + 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..63] + 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [29] + 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [30] + 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6] + 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1] + 'debugging' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [22] + 'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2] + 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\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", # [7] + 'exiting' => "\x40\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\x15\x05", # [51..58,60,61] + 'experimental::autoderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [56] + 'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [52] + 'experimental::lexical_topic'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [53] + 'experimental::lvalue_refs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [60] + 'experimental::postderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [57] + 'experimental::regex_sets'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [54] + 'experimental::signatures'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [58] + 'experimental::smartmatch'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [55] + 'experimental::win32_perlio'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [61] + 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4] + 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [47] + 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [46] + 'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [23] + 'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [24] + 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [5..11,59] + 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8] + 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [25] + 'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12] + 'missing' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [62] + 'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9] + 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [48] + 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [49] + 'numeric' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13] + 'once' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14] + 'overflow' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15] + 'pack' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16] + 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [32] + 'pipe' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10] + 'portable' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17] + 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [33] + 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [34] + 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [35] + 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [36] + 'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18] + 'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19] + 'redundant' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40", # [63] + 'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [20] + 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [37] + 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [38] + 'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [21..25] + 'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [26] + 'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [27] + 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [50] + 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x40\x00\x00\x00\x00", # [28..38,47] + 'syscalls' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [59] + 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [39] + 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [40] + 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [41] + 'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11] + 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [42] + 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [43] + 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x15\x00\x00\x00", # [44,48..50] + 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [45] + ); + +our %DeadBits = ( + 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..63] + 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [29] + 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [30] + 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6] + 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1] + 'debugging' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [22] + 'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2] + 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\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", # [7] + 'exiting' => "\x80\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\x2a\x0a", # [51..58,60,61] + 'experimental::autoderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [56] + 'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [52] + 'experimental::lexical_topic'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [53] + 'experimental::lvalue_refs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [60] + 'experimental::postderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [57] + 'experimental::regex_sets'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [54] + 'experimental::signatures'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [58] + 'experimental::smartmatch'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [55] + 'experimental::win32_perlio'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [61] + 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4] + 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [47] + 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [46] + 'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [23] + 'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [24] + 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [5..11,59] + 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8] + 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [25] + 'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12] + 'missing' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [62] + 'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9] + 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [48] + 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [49] + 'numeric' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13] + 'once' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14] + 'overflow' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15] + 'pack' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16] + 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [32] + 'pipe' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10] + 'portable' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17] + 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [33] + 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [34] + 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [35] + 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [36] + 'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18] + 'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19] + 'redundant' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80", # [63] + 'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [20] + 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [37] + 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [38] + 'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [21..25] + 'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [26] + 'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [27] + 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [50] + 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x80\x00\x00\x00\x00", # [28..38,47] + 'syscalls' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [59] + 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [39] + 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [40] + 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [41] + 'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11] + 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [42] + 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [43] + 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x2a\x00\x00\x00", # [44,48..50] + 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [45] + ); + +$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"; +$DEFAULT = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x55\x15\x05", # [2,56,52,53,60,57,54,58,55,61,4,22,23,25] +$LAST_BIT = 128 ; +$BYTES = 16 ; + +$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ; + +sub Croaker +{ + require Carp; # this initializes %CarpInternal + local $Carp::CarpInternal{'warnings'}; + delete $Carp::CarpInternal{'warnings'}; + Carp::croak(@_); +} + +sub _bits { + my $mask = shift ; + my $catmask ; + my $fatal = 0 ; + my $no_fatal = 0 ; + + 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 &= ~($DeadBits{$word}|$All) if $no_fatal ; + } + else + { Croaker("Unknown warnings category '$word'")} + } + + return $mask ; +} + +sub bits +{ + # called from B::Deparse.pm + push @_, 'all' unless @_ ; + return _bits(undef, @_) ; +} + +sub import +{ + shift; + + my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ; + + if (vec($mask, $Offsets{'all'}, 1)) { + $mask |= $Bits{'all'} ; + $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); + } + + # append 'all' when implied (after a lone "FATAL" or "NONFATAL") + push @_, 'all' if @_==1 && ( $_[0] eq 'FATAL' || $_[0] eq 'NONFATAL' ); + + # Empty @_ is equivalent to @_ = 'all' ; + ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ; +} + +sub unimport +{ + shift; + + my $catmask ; + my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ; + + if (vec($mask, $Offsets{'all'}, 1)) { + $mask |= $Bits{'all'} ; + $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); + } + + # append 'all' when implied (empty import list or after a lone "FATAL") + push @_, 'all' if !@_ || @_==1 && $_[0] eq 'FATAL'; + + foreach my $word ( @_ ) { + if ($word eq 'FATAL') { + next; + } + elsif ($catmask = $Bits{$word}) { + $mask &= ~($catmask | $DeadBits{$word} | $All); + } + else + { Croaker("Unknown warnings category '$word'")} + } + + ${^WARNING_BITS} = $mask ; +} + +my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = (); + +sub MESSAGE () { 4 }; +sub FATAL () { 2 }; +sub NORMAL () { 1 }; + +sub __chk +{ + my $category ; + my $offset ; + my $isobj = 0 ; + my $wanted = shift; + my $has_message = $wanted & MESSAGE; + + unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) { + 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; + } + else { + $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 ; + } + else { + $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 ; + + my @results; + foreach my $type (FATAL, NORMAL) { + next unless $wanted & $type; + + push @results, (vec($callers_bitmask, $offset + $type - 1, 1) || + vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1)); + } + + # &enabled and &fatal_enabled + return $results[0] unless $has_message; + + # &warnif, and the category is neither enabled as warning nor as fatal + return if $wanted == (NORMAL | FATAL | MESSAGE) + && !($results[0] || $results[1]); + + require Carp; + Carp::croak($message) if $results[0]; + # will always get here for &warn. will only get here for &warnif if the + # category is enabled + Carp::carp($message); +} + +sub _mkMask +{ + my ($bit) = @_; + my $mask = ""; + + vec($mask, $bit, 1) = 1; + return $mask; +} + +sub register_categories +{ + my @names = @_; + + for my $name (@names) { + if (! defined $Bits{$name}) { + $Bits{$name} = _mkMask($LAST_BIT); + vec($Bits{'all'}, $LAST_BIT, 1) = 1; + $Offsets{$name} = $LAST_BIT ++; + foreach my $k (keys %Bits) { + vec($Bits{$k}, $LAST_BIT, 1) = 0; + } + $DeadBits{$name} = _mkMask($LAST_BIT); + vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1; + } + } +} + +sub _error_loc { + require Carp; + goto &Carp::short_error_loc; # don't introduce another stack frame +} + +sub enabled +{ + return __chk(NORMAL, @_); +} + +sub fatal_enabled +{ + return __chk(FATAL, @_); +} + +sub warn +{ + return __chk(FATAL | MESSAGE, @_); +} + +sub warnif +{ + return __chk(NORMAL | FATAL | MESSAGE, @_); +} + +# These are not part of any public interface, so we can delete them to save +# space. +delete @warnings::{qw(NORMAL FATAL MESSAGE)}; + +1; +__END__ =head1 NAME warnings - Perl pragma to control optional warnings @@ -576,633 +1033,176 @@ Consider this example: } sub check - { - my $self = shift; - my $value = shift; - - if ($value % 2 && warnings::enabled($self)) - { warnings::warn($self, "Odd numbers are unsafe") } - } - - sub doit - { - my $self = shift; - my $value = shift; - $self->check($value); - # ... - } - - 1; - - package Derived; - - use warnings::register; - use Original; - our @ISA = qw( Original ); - sub new - { - my $class = shift; - bless [], $class; - } - - - 1; - -The code below makes use of both modules, but it only enables warnings from -C. - - use Original; - use Derived; - use warnings 'Derived'; - my $a = Original->new(); - $a->doit(1); - my $b = Derived->new(); - $a->doit(1); - -When this code is run only the C object, C<$b>, will generate -a warning. - - Odd numbers are unsafe at main.pl line 7 - -Notice also that the warning is reported at the line where the object is first -used. - -When registering new categories of warning, you can supply more names to -warnings::register like this: - - package MyModule; - use warnings::register qw(format precision); - - ... - - warnings::warnif('MyModule::format', '...'); - -=head1 FUNCTIONS - -=over 4 - -=item use warnings::register - -Creates a new warnings category with the same name as the package where -the call to the pragma is used. - -=item warnings::enabled() - -Use the warnings category with the same name as the current package. - -Return TRUE if that warnings category is enabled in the calling module. -Otherwise returns FALSE. - -=item warnings::enabled($category) - -Return TRUE if the warnings category, C<$category>, is enabled in the -calling module. -Otherwise returns FALSE. - -=item warnings::enabled($object) - -Use the name of the class for the object reference, C<$object>, as the -warnings category. - -Return TRUE if that warnings category is enabled in the first scope -where the object is used. -Otherwise returns FALSE. - -=item warnings::fatal_enabled() - -Return TRUE if the warnings category with the same name as the current -package has been set to FATAL in the calling module. -Otherwise returns FALSE. - -=item warnings::fatal_enabled($category) - -Return TRUE if the warnings category C<$category> has been set to FATAL in -the calling module. -Otherwise returns FALSE. - -=item warnings::fatal_enabled($object) - -Use the name of the class for the object reference, C<$object>, as the -warnings category. - -Return TRUE if that warnings category has been set to FATAL in the first -scope where the object is used. -Otherwise returns FALSE. - -=item warnings::warn($message) - -Print C<$message> to STDERR. - -Use the warnings category with the same name as the current package. - -If that warnings category has been set to "FATAL" in the calling module -then die. Otherwise return. - -=item warnings::warn($category, $message) - -Print C<$message> to STDERR. - -If the warnings category, C<$category>, has been set to "FATAL" in the -calling module then die. Otherwise return. - -=item warnings::warn($object, $message) - -Print C<$message> to STDERR. - -Use the name of the class for the object reference, C<$object>, as the -warnings category. - -If that warnings category has been set to "FATAL" in the scope where C<$object> -is first used then die. Otherwise return. - - -=item warnings::warnif($message) - -Equivalent to: - - if (warnings::enabled()) - { warnings::warn($message) } - -=item warnings::warnif($category, $message) - -Equivalent to: - - if (warnings::enabled($category)) - { warnings::warn($category, $message) } - -=item warnings::warnif($object, $message) - -Equivalent to: - - if (warnings::enabled($object)) - { warnings::warn($object, $message) } - -=item warnings::register_categories(@names) - -This registers warning categories for the given names and is primarily for -use by the warnings::register pragma. - -=back + { + my $self = shift; + my $value = shift; -See also L and L. + if ($value % 2 && warnings::enabled($self)) + { warnings::warn($self, "Odd numbers are unsafe") } + } -=cut + sub doit + { + my $self = shift; + my $value = shift; + $self->check($value); + # ... + } -our %Offsets = ( + 1; - # Warnings Categories added in Perl 5.008 + package Derived; - 'all' => 0, - 'closure' => 2, - 'deprecated' => 4, - 'exiting' => 6, - 'glob' => 8, - 'io' => 10, - 'closed' => 12, - 'exec' => 14, - 'layer' => 16, - 'newline' => 18, - 'pipe' => 20, - 'unopened' => 22, - 'misc' => 24, - 'numeric' => 26, - 'once' => 28, - 'overflow' => 30, - 'pack' => 32, - 'portable' => 34, - 'recursion' => 36, - 'redefine' => 38, - 'regexp' => 40, - 'severe' => 42, - 'debugging' => 44, - 'inplace' => 46, - 'internal' => 48, - 'malloc' => 50, - 'signal' => 52, - 'substr' => 54, - 'syntax' => 56, - 'ambiguous' => 58, - 'bareword' => 60, - 'digit' => 62, - 'parenthesis' => 64, - 'precedence' => 66, - 'printf' => 68, - 'prototype' => 70, - 'qw' => 72, - 'reserved' => 74, - 'semicolon' => 76, - 'taint' => 78, - 'threads' => 80, - 'uninitialized' => 82, - 'unpack' => 84, - 'untie' => 86, - 'utf8' => 88, - 'void' => 90, + use warnings::register; + use Original; + our @ISA = qw( Original ); + sub new + { + my $class = shift; + bless [], $class; + } - # Warnings Categories added in Perl 5.011 - 'imprecision' => 92, - 'illegalproto' => 94, + 1; - # Warnings Categories added in Perl 5.013 +The code below makes use of both modules, but it only enables warnings from +C. - 'non_unicode' => 96, - 'nonchar' => 98, - 'surrogate' => 100, + use Original; + use Derived; + use warnings 'Derived'; + my $a = Original->new(); + $a->doit(1); + my $b = Derived->new(); + $a->doit(1); - # Warnings Categories added in Perl 5.017 +When this code is run only the C object, C<$b>, will generate +a warning. - 'experimental' => 102, - 'experimental::lexical_subs'=> 104, - 'experimental::lexical_topic'=> 106, - 'experimental::regex_sets'=> 108, - 'experimental::smartmatch'=> 110, + Odd numbers are unsafe at main.pl line 7 - # Warnings Categories added in Perl 5.019 +Notice also that the warning is reported at the line where the object is first +used. - 'experimental::autoderef'=> 112, - 'experimental::postderef'=> 114, - 'experimental::signatures'=> 116, - 'syscalls' => 118, +When registering new categories of warning, you can supply more names to +warnings::register like this: - # Warnings Categories added in Perl 5.021 + package MyModule; + use warnings::register qw(format precision); - 'experimental::lvalue_refs'=> 120, - 'experimental::win32_perlio'=> 122, - 'missing' => 124, - 'redundant' => 126, - ); + ... -our %Bits = ( - 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..63] - 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [29] - 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [30] - 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6] - 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1] - 'debugging' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [22] - 'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2] - 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\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", # [7] - 'exiting' => "\x40\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\x15\x05", # [51..58,60,61] - 'experimental::autoderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [56] - 'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [52] - 'experimental::lexical_topic'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [53] - 'experimental::lvalue_refs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [60] - 'experimental::postderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [57] - 'experimental::regex_sets'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [54] - 'experimental::signatures'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [58] - 'experimental::smartmatch'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [55] - 'experimental::win32_perlio'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [61] - 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4] - 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [47] - 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [46] - 'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [23] - 'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [24] - 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [5..11,59] - 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8] - 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [25] - 'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12] - 'missing' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [62] - 'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9] - 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [48] - 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [49] - 'numeric' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13] - 'once' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14] - 'overflow' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15] - 'pack' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16] - 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [32] - 'pipe' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10] - 'portable' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17] - 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [33] - 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [34] - 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [35] - 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [36] - 'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18] - 'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19] - 'redundant' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40", # [63] - 'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [20] - 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [37] - 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [38] - 'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [21..25] - 'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [26] - 'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [27] - 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [50] - 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x40\x00\x00\x00\x00", # [28..38,47] - 'syscalls' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [59] - 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [39] - 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [40] - 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [41] - 'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11] - 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [42] - 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [43] - 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x15\x00\x00\x00", # [44,48..50] - 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [45] - ); + warnings::warnif('MyModule::format', '...'); -our %DeadBits = ( - 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..63] - 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [29] - 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [30] - 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6] - 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1] - 'debugging' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [22] - 'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2] - 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\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", # [7] - 'exiting' => "\x80\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\x2a\x0a", # [51..58,60,61] - 'experimental::autoderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [56] - 'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [52] - 'experimental::lexical_topic'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [53] - 'experimental::lvalue_refs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [60] - 'experimental::postderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [57] - 'experimental::regex_sets'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [54] - 'experimental::signatures'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [58] - 'experimental::smartmatch'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [55] - 'experimental::win32_perlio'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [61] - 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4] - 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [47] - 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [46] - 'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [23] - 'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [24] - 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [5..11,59] - 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8] - 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [25] - 'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12] - 'missing' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [62] - 'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9] - 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [48] - 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [49] - 'numeric' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13] - 'once' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14] - 'overflow' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15] - 'pack' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16] - 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [32] - 'pipe' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10] - 'portable' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17] - 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [33] - 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [34] - 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [35] - 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [36] - 'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18] - 'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19] - 'redundant' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80", # [63] - 'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [20] - 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [37] - 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [38] - 'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [21..25] - 'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [26] - 'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [27] - 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [50] - 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x80\x00\x00\x00\x00", # [28..38,47] - 'syscalls' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [59] - 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [39] - 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [40] - 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [41] - 'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11] - 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [42] - 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [43] - 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x2a\x00\x00\x00", # [44,48..50] - 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [45] - ); +=head1 FUNCTIONS -$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"; -$DEFAULT = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x55\x15\x05", # [2,56,52,53,60,57,54,58,55,61,4,22,23,25] -$LAST_BIT = 128 ; -$BYTES = 16 ; +=over 4 -$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ; +=item use warnings::register -sub Croaker -{ - require Carp; # this initializes %CarpInternal - local $Carp::CarpInternal{'warnings'}; - delete $Carp::CarpInternal{'warnings'}; - Carp::croak(@_); -} +Creates a new warnings category with the same name as the package where +the call to the pragma is used. -sub _bits { - my $mask = shift ; - my $catmask ; - my $fatal = 0 ; - my $no_fatal = 0 ; +=item warnings::enabled() - 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 &= ~($DeadBits{$word}|$All) if $no_fatal ; - } - else - { Croaker("Unknown warnings category '$word'")} - } +Use the warnings category with the same name as the current package. - return $mask ; -} +Return TRUE if that warnings category is enabled in the calling module. +Otherwise returns FALSE. -sub bits -{ - # called from B::Deparse.pm - push @_, 'all' unless @_ ; - return _bits(undef, @_) ; -} +=item warnings::enabled($category) -sub import -{ - shift; +Return TRUE if the warnings category, C<$category>, is enabled in the +calling module. +Otherwise returns FALSE. - my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ; +=item warnings::enabled($object) - if (vec($mask, $Offsets{'all'}, 1)) { - $mask |= $Bits{'all'} ; - $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); - } +Use the name of the class for the object reference, C<$object>, as the +warnings category. - # append 'all' when implied (after a lone "FATAL" or "NONFATAL") - push @_, 'all' if @_==1 && ( $_[0] eq 'FATAL' || $_[0] eq 'NONFATAL' ); +Return TRUE if that warnings category is enabled in the first scope +where the object is used. +Otherwise returns FALSE. - # Empty @_ is equivalent to @_ = 'all' ; - ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ; -} +=item warnings::fatal_enabled() -sub unimport -{ - shift; +Return TRUE if the warnings category with the same name as the current +package has been set to FATAL in the calling module. +Otherwise returns FALSE. - my $catmask ; - my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ; +=item warnings::fatal_enabled($category) - if (vec($mask, $Offsets{'all'}, 1)) { - $mask |= $Bits{'all'} ; - $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); - } +Return TRUE if the warnings category C<$category> has been set to FATAL in +the calling module. +Otherwise returns FALSE. - # append 'all' when implied (empty import list or after a lone "FATAL") - push @_, 'all' if !@_ || @_==1 && $_[0] eq 'FATAL'; +=item warnings::fatal_enabled($object) - foreach my $word ( @_ ) { - if ($word eq 'FATAL') { - next; - } - elsif ($catmask = $Bits{$word}) { - $mask &= ~($catmask | $DeadBits{$word} | $All); - } - else - { Croaker("Unknown warnings category '$word'")} - } +Use the name of the class for the object reference, C<$object>, as the +warnings category. - ${^WARNING_BITS} = $mask ; -} +Return TRUE if that warnings category has been set to FATAL in the first +scope where the object is used. +Otherwise returns FALSE. -my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = (); +=item warnings::warn($message) -sub MESSAGE () { 4 }; -sub FATAL () { 2 }; -sub NORMAL () { 1 }; +Print C<$message> to STDERR. -sub __chk -{ - my $category ; - my $offset ; - my $isobj = 0 ; - my $wanted = shift; - my $has_message = $wanted & MESSAGE; +Use the warnings category with the same name as the current package. - unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) { - my $sub = (caller 1)[3]; - my $syntax = $has_message ? "[category,] 'message'" : '[category]'; - Croaker("Usage: $sub($syntax)"); - } +If that warnings category has been set to "FATAL" in the calling module +then die. Otherwise return. - my $message = pop if $has_message; +=item warnings::warn($category, $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; - } - else { - $category = (caller(1))[0] ; - $offset = $Offsets{$category}; - Croaker("package '$category' not registered for warnings") - unless defined $offset ; - } +Print C<$message> to STDERR. - my $i; +If the warnings category, C<$category>, has been set to "FATAL" in the +calling module then die. Otherwise return. - if ($isobj) { - my $pkg; - $i = 2; - while (do { { package DB; $pkg = (caller($i++))[0] } } ) { - last unless @DB::args && $DB::args[0] =~ /^$category=/ ; - } - $i -= 2 ; - } - else { - $i = _error_loc(); # see where Carp will allocate the error - } +=item warnings::warn($object, $message) - # 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 ; +Print C<$message> to STDERR. - my @results; - foreach my $type (FATAL, NORMAL) { - next unless $wanted & $type; +Use the name of the class for the object reference, C<$object>, as the +warnings category. - push @results, (vec($callers_bitmask, $offset + $type - 1, 1) || - vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1)); - } +If that warnings category has been set to "FATAL" in the scope where C<$object> +is first used then die. Otherwise return. - # &enabled and &fatal_enabled - return $results[0] unless $has_message; - # &warnif, and the category is neither enabled as warning nor as fatal - return if $wanted == (NORMAL | FATAL | MESSAGE) - && !($results[0] || $results[1]); +=item warnings::warnif($message) - require Carp; - Carp::croak($message) if $results[0]; - # will always get here for &warn. will only get here for &warnif if the - # category is enabled - Carp::carp($message); -} +Equivalent to: -sub _mkMask -{ - my ($bit) = @_; - my $mask = ""; + if (warnings::enabled()) + { warnings::warn($message) } - vec($mask, $bit, 1) = 1; - return $mask; -} +=item warnings::warnif($category, $message) -sub register_categories -{ - my @names = @_; +Equivalent to: - for my $name (@names) { - if (! defined $Bits{$name}) { - $Bits{$name} = _mkMask($LAST_BIT); - vec($Bits{'all'}, $LAST_BIT, 1) = 1; - $Offsets{$name} = $LAST_BIT ++; - foreach my $k (keys %Bits) { - vec($Bits{$k}, $LAST_BIT, 1) = 0; - } - $DeadBits{$name} = _mkMask($LAST_BIT); - vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1; - } - } -} + if (warnings::enabled($category)) + { warnings::warn($category, $message) } -sub _error_loc { - require Carp; - goto &Carp::short_error_loc; # don't introduce another stack frame -} +=item warnings::warnif($object, $message) -sub enabled -{ - return __chk(NORMAL, @_); -} +Equivalent to: -sub fatal_enabled -{ - return __chk(FATAL, @_); -} + if (warnings::enabled($object)) + { warnings::warn($object, $message) } -sub warn -{ - return __chk(FATAL | MESSAGE, @_); -} +=item warnings::register_categories(@names) -sub warnif -{ - return __chk(NORMAL | FATAL | MESSAGE, @_); -} +This registers warning categories for the given names and is primarily for +use by the warnings::register pragma. -# These are not part of any public interface, so we can delete them to save -# space. -delete @warnings::{qw(NORMAL FATAL MESSAGE)}; +=back -1; +See also L and L. + +=cut # ex: set ro: diff --git a/regen/warnings.pl b/regen/warnings.pl index 156154a..79be71f 100644 --- a/regen/warnings.pl +++ b/regen/warnings.pl @@ -414,10 +414,6 @@ EOM while () { last if /^KEYWORDS$/ ; - if ($_ eq "=for warnings.pl tree-goes-here\n") { - print $pm warningsTree($tree, " "); - next; - } print $pm $_ ; } @@ -469,6 +465,10 @@ print $pm '$DEFAULT = "', mkHex($warn_size, map $_ * 2, @def), print $pm '$LAST_BIT = ' . "$index ;\n" ; print $pm '$BYTES = ' . "$warn_size ;\n" ; while () { + if ($_ eq "=for warnings.pl tree-goes-here\n") { + print $pm warningsTree($tree, " "); + next; + } print $pm $_ ; } @@ -477,7 +477,7 @@ read_only_bottom_close_and_rename($pm); __END__ package warnings; -our $VERSION = '1.27'; +our $VERSION = '1.28'; # Verify that we're called correctly so that warnings will work. # see also strict.pm. @@ -486,6 +486,241 @@ unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) { die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n"); } +KEYWORDS + +$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ; + +sub Croaker +{ + require Carp; # this initializes %CarpInternal + local $Carp::CarpInternal{'warnings'}; + delete $Carp::CarpInternal{'warnings'}; + Carp::croak(@_); +} + +sub _bits { + my $mask = shift ; + my $catmask ; + my $fatal = 0 ; + my $no_fatal = 0 ; + + 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 &= ~($DeadBits{$word}|$All) if $no_fatal ; + } + else + { Croaker("Unknown warnings category '$word'")} + } + + return $mask ; +} + +sub bits +{ + # called from B::Deparse.pm + push @_, 'all' unless @_ ; + return _bits(undef, @_) ; +} + +sub import +{ + shift; + + my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ; + + if (vec($mask, $Offsets{'all'}, 1)) { + $mask |= $Bits{'all'} ; + $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); + } + + # append 'all' when implied (after a lone "FATAL" or "NONFATAL") + push @_, 'all' if @_==1 && ( $_[0] eq 'FATAL' || $_[0] eq 'NONFATAL' ); + + # Empty @_ is equivalent to @_ = 'all' ; + ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ; +} + +sub unimport +{ + shift; + + my $catmask ; + my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ; + + if (vec($mask, $Offsets{'all'}, 1)) { + $mask |= $Bits{'all'} ; + $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); + } + + # append 'all' when implied (empty import list or after a lone "FATAL") + push @_, 'all' if !@_ || @_==1 && $_[0] eq 'FATAL'; + + foreach my $word ( @_ ) { + if ($word eq 'FATAL') { + next; + } + elsif ($catmask = $Bits{$word}) { + $mask &= ~($catmask | $DeadBits{$word} | $All); + } + else + { Croaker("Unknown warnings category '$word'")} + } + + ${^WARNING_BITS} = $mask ; +} + +my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = (); + +sub MESSAGE () { 4 }; +sub FATAL () { 2 }; +sub NORMAL () { 1 }; + +sub __chk +{ + my $category ; + my $offset ; + my $isobj = 0 ; + my $wanted = shift; + my $has_message = $wanted & MESSAGE; + + unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) { + 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; + } + else { + $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 ; + } + else { + $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 ; + + my @results; + foreach my $type (FATAL, NORMAL) { + next unless $wanted & $type; + + push @results, (vec($callers_bitmask, $offset + $type - 1, 1) || + vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1)); + } + + # &enabled and &fatal_enabled + return $results[0] unless $has_message; + + # &warnif, and the category is neither enabled as warning nor as fatal + return if $wanted == (NORMAL | FATAL | MESSAGE) + && !($results[0] || $results[1]); + + require Carp; + Carp::croak($message) if $results[0]; + # will always get here for &warn. will only get here for &warnif if the + # category is enabled + Carp::carp($message); +} + +sub _mkMask +{ + my ($bit) = @_; + my $mask = ""; + + vec($mask, $bit, 1) = 1; + return $mask; +} + +sub register_categories +{ + my @names = @_; + + for my $name (@names) { + if (! defined $Bits{$name}) { + $Bits{$name} = _mkMask($LAST_BIT); + vec($Bits{'all'}, $LAST_BIT, 1) = 1; + $Offsets{$name} = $LAST_BIT ++; + foreach my $k (keys %Bits) { + vec($Bits{$k}, $LAST_BIT, 1) = 0; + } + $DeadBits{$name} = _mkMask($LAST_BIT); + vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1; + } + } +} + +sub _error_loc { + require Carp; + goto &Carp::short_error_loc; # don't introduce another stack frame +} + +sub enabled +{ + return __chk(NORMAL, @_); +} + +sub fatal_enabled +{ + return __chk(FATAL, @_); +} + +sub warn +{ + return __chk(FATAL | MESSAGE, @_); +} + +sub warnif +{ + return __chk(NORMAL | FATAL | MESSAGE, @_); +} + +# These are not part of any public interface, so we can delete them to save +# space. +delete @warnings::{qw(NORMAL FATAL MESSAGE)}; + +1; +__END__ =head1 NAME warnings - Perl pragma to control optional warnings @@ -1093,238 +1328,3 @@ use by the warnings::register pragma. See also L and L. =cut - -KEYWORDS - -$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ; - -sub Croaker -{ - require Carp; # this initializes %CarpInternal - local $Carp::CarpInternal{'warnings'}; - delete $Carp::CarpInternal{'warnings'}; - Carp::croak(@_); -} - -sub _bits { - my $mask = shift ; - my $catmask ; - my $fatal = 0 ; - my $no_fatal = 0 ; - - 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 &= ~($DeadBits{$word}|$All) if $no_fatal ; - } - else - { Croaker("Unknown warnings category '$word'")} - } - - return $mask ; -} - -sub bits -{ - # called from B::Deparse.pm - push @_, 'all' unless @_ ; - return _bits(undef, @_) ; -} - -sub import -{ - shift; - - my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ; - - if (vec($mask, $Offsets{'all'}, 1)) { - $mask |= $Bits{'all'} ; - $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); - } - - # append 'all' when implied (after a lone "FATAL" or "NONFATAL") - push @_, 'all' if @_==1 && ( $_[0] eq 'FATAL' || $_[0] eq 'NONFATAL' ); - - # Empty @_ is equivalent to @_ = 'all' ; - ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ; -} - -sub unimport -{ - shift; - - my $catmask ; - my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ; - - if (vec($mask, $Offsets{'all'}, 1)) { - $mask |= $Bits{'all'} ; - $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); - } - - # append 'all' when implied (empty import list or after a lone "FATAL") - push @_, 'all' if !@_ || @_==1 && $_[0] eq 'FATAL'; - - foreach my $word ( @_ ) { - if ($word eq 'FATAL') { - next; - } - elsif ($catmask = $Bits{$word}) { - $mask &= ~($catmask | $DeadBits{$word} | $All); - } - else - { Croaker("Unknown warnings category '$word'")} - } - - ${^WARNING_BITS} = $mask ; -} - -my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = (); - -sub MESSAGE () { 4 }; -sub FATAL () { 2 }; -sub NORMAL () { 1 }; - -sub __chk -{ - my $category ; - my $offset ; - my $isobj = 0 ; - my $wanted = shift; - my $has_message = $wanted & MESSAGE; - - unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) { - 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; - } - else { - $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 ; - } - else { - $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 ; - - my @results; - foreach my $type (FATAL, NORMAL) { - next unless $wanted & $type; - - push @results, (vec($callers_bitmask, $offset + $type - 1, 1) || - vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1)); - } - - # &enabled and &fatal_enabled - return $results[0] unless $has_message; - - # &warnif, and the category is neither enabled as warning nor as fatal - return if $wanted == (NORMAL | FATAL | MESSAGE) - && !($results[0] || $results[1]); - - require Carp; - Carp::croak($message) if $results[0]; - # will always get here for &warn. will only get here for &warnif if the - # category is enabled - Carp::carp($message); -} - -sub _mkMask -{ - my ($bit) = @_; - my $mask = ""; - - vec($mask, $bit, 1) = 1; - return $mask; -} - -sub register_categories -{ - my @names = @_; - - for my $name (@names) { - if (! defined $Bits{$name}) { - $Bits{$name} = _mkMask($LAST_BIT); - vec($Bits{'all'}, $LAST_BIT, 1) = 1; - $Offsets{$name} = $LAST_BIT ++; - foreach my $k (keys %Bits) { - vec($Bits{$k}, $LAST_BIT, 1) = 0; - } - $DeadBits{$name} = _mkMask($LAST_BIT); - vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1; - } - } -} - -sub _error_loc { - require Carp; - goto &Carp::short_error_loc; # don't introduce another stack frame -} - -sub enabled -{ - return __chk(NORMAL, @_); -} - -sub fatal_enabled -{ - return __chk(FATAL, @_); -} - -sub warn -{ - return __chk(FATAL | MESSAGE, @_); -} - -sub warnif -{ - return __chk(NORMAL | FATAL | MESSAGE, @_); -} - -# These are not part of any public interface, so we can delete them to save -# space. -delete @warnings::{qw(NORMAL FATAL MESSAGE)}; - -1; -- 1.7.9.msysgit.0 ```

p5pRT commented 9 years ago

From @bulk88

0002-remove-excess-whitespace-from-warnings.pm.patch

```diff From e82d07b3acf93eee8166c3d2f4db97122d7cb24b Mon Sep 17 00:00:00 2001 From: Daniel Dragan Date: Sun, 12 Oct 2014 22:42:15 -0400 Subject: [PATCH 2/2] remove excess whitespace from warnings.pm Some lines end with spaces, remove that, use tabs instead of spaces in code so the perl code is less bytes to read from disk. This patch saved 183 bytes. Part of [perl #122955]. --- lib/warnings.pm | 62 ++++++++++++++++++++++++++-------------------------- regen/warnings.pl | 62 ++++++++++++++++++++++++++-------------------------- 2 files changed, 62 insertions(+), 62 deletions(-) diff --git a/lib/warnings.pm b/lib/warnings.pm index 882ce5c..b206291 100644 --- a/lib/warnings.pm +++ b/lib/warnings.pm @@ -269,7 +269,7 @@ sub _bits { $mask &= ~($DeadBits{$word}|$All) if $no_fatal ; } else - { Croaker("Unknown warnings category '$word'")} + { Croaker("Unknown warnings category '$word'")} } return $mask ; @@ -289,8 +289,8 @@ sub import my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ; if (vec($mask, $Offsets{'all'}, 1)) { - $mask |= $Bits{'all'} ; - $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); + $mask |= $Bits{'all'} ; + $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); } # append 'all' when implied (after a lone "FATAL" or "NONFATAL") @@ -308,8 +308,8 @@ sub unimport my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ; if (vec($mask, $Offsets{'all'}, 1)) { - $mask |= $Bits{'all'} ; - $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); + $mask |= $Bits{'all'} ; + $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); } # append 'all' when implied (empty import list or after a lone "FATAL") @@ -323,7 +323,7 @@ sub unimport $mask &= ~($catmask | $DeadBits{$word} | $All); } else - { Croaker("Unknown warnings category '$word'")} + { Croaker("Unknown warnings category '$word'")} } ${^WARNING_BITS} = $mask ; @@ -352,37 +352,37 @@ sub __chk 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}; + # 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'") + $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") + $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=/ ; - } + my $pkg; + $i = 2; + while (do { { package DB; $pkg = (caller($i++))[0] } } ) { + last unless @DB::args && $DB::args[0] =~ /^$category=/ ; + } $i -= 2 ; } 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 @@ -545,7 +545,7 @@ warning, but the assignment to the scalar C<$b> will not. =head2 Default Warnings and Optional Warnings Before the introduction of lexical warnings, Perl had two classes of -warnings: mandatory and optional. +warnings: mandatory and optional. As its name suggests, if your code tripped a mandatory warning, you would get a warning whether you wanted it or not. @@ -677,7 +677,7 @@ will work unchanged. The B<-w> flag just sets the global C<$^W> variable as in 5.005. This means that any legacy code that currently relies on manipulating C<$^W> -to control warning behavior will still work as is. +to control warning behavior will still work as is. =item 3. @@ -844,7 +844,7 @@ Just like the "strict" pragma any of these categories can be combined no warnings qw(io syntax untie); Also like the "strict" pragma, if there is more than one instance of the -C pragma in a given scope the cumulative effect is additive. +C pragma in a given scope the cumulative effect is additive. use warnings qw(void); # only "void" warnings enabled ... @@ -888,7 +888,7 @@ warning. When run it produces this output Useless use of time in void context at fatal line 3. - Useless use of length in void context at fatal line 7. + Useless use of length in void context at fatal line 7. The scope where C is used has escalated the C warnings category into a fatal error, so the program terminates immediately when it @@ -983,7 +983,7 @@ this snippet of code: package MyMod::Abc; sub open { - warnings::warnif("deprecated", + warnings::warnif("deprecated", "open is deprecated, use new instead"); new(@_); } @@ -1065,7 +1065,7 @@ Consider this example: 1; -The code below makes use of both modules, but it only enables warnings from +The code below makes use of both modules, but it only enables warnings from C. use Original; @@ -1077,7 +1077,7 @@ C. $a->doit(1); When this code is run only the C object, C<$b>, will generate -a warning. +a warning. Odd numbers are unsafe at main.pl line 7 diff --git a/regen/warnings.pl b/regen/warnings.pl index 79be71f..6c27a16 100644 --- a/regen/warnings.pl +++ b/regen/warnings.pl @@ -519,7 +519,7 @@ sub _bits { $mask &= ~($DeadBits{$word}|$All) if $no_fatal ; } else - { Croaker("Unknown warnings category '$word'")} + { Croaker("Unknown warnings category '$word'")} } return $mask ; @@ -539,8 +539,8 @@ sub import my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ; if (vec($mask, $Offsets{'all'}, 1)) { - $mask |= $Bits{'all'} ; - $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); + $mask |= $Bits{'all'} ; + $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); } # append 'all' when implied (after a lone "FATAL" or "NONFATAL") @@ -558,8 +558,8 @@ sub unimport my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ; if (vec($mask, $Offsets{'all'}, 1)) { - $mask |= $Bits{'all'} ; - $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); + $mask |= $Bits{'all'} ; + $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); } # append 'all' when implied (empty import list or after a lone "FATAL") @@ -573,7 +573,7 @@ sub unimport $mask &= ~($catmask | $DeadBits{$word} | $All); } else - { Croaker("Unknown warnings category '$word'")} + { Croaker("Unknown warnings category '$word'")} } ${^WARNING_BITS} = $mask ; @@ -602,37 +602,37 @@ sub __chk 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}; + # 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'") + $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") + $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=/ ; - } + my $pkg; + $i = 2; + while (do { { package DB; $pkg = (caller($i++))[0] } } ) { + last unless @DB::args && $DB::args[0] =~ /^$category=/ ; + } $i -= 2 ; } 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 @@ -795,7 +795,7 @@ warning, but the assignment to the scalar C<$b> will not. =head2 Default Warnings and Optional Warnings Before the introduction of lexical warnings, Perl had two classes of -warnings: mandatory and optional. +warnings: mandatory and optional. As its name suggests, if your code tripped a mandatory warning, you would get a warning whether you wanted it or not. @@ -927,7 +927,7 @@ will work unchanged. The B<-w> flag just sets the global C<$^W> variable as in 5.005. This means that any legacy code that currently relies on manipulating C<$^W> -to control warning behavior will still work as is. +to control warning behavior will still work as is. =item 3. @@ -968,7 +968,7 @@ Just like the "strict" pragma any of these categories can be combined no warnings qw(io syntax untie); Also like the "strict" pragma, if there is more than one instance of the -C pragma in a given scope the cumulative effect is additive. +C pragma in a given scope the cumulative effect is additive. use warnings qw(void); # only "void" warnings enabled ... @@ -1012,7 +1012,7 @@ warning. When run it produces this output Useless use of time in void context at fatal line 3. - Useless use of length in void context at fatal line 7. + Useless use of length in void context at fatal line 7. The scope where C is used has escalated the C warnings category into a fatal error, so the program terminates immediately when it @@ -1107,7 +1107,7 @@ this snippet of code: package MyMod::Abc; sub open { - warnings::warnif("deprecated", + warnings::warnif("deprecated", "open is deprecated, use new instead"); new(@_); } @@ -1189,7 +1189,7 @@ Consider this example: 1; -The code below makes use of both modules, but it only enables warnings from +The code below makes use of both modules, but it only enables warnings from C. use Original; @@ -1201,7 +1201,7 @@ C. $a->doit(1); When this code is run only the C object, C<$b>, will generate -a warning. +a warning. Odd numbers are unsafe at main.pl line 7 -- 1.7.9.msysgit.0 ```

p5pRT commented 9 years ago

From @tux

On Sun\, 12 Oct 2014 20:30:34 -0500\, "Craig A. Berry" \craig\.a\.berry@gmail\.com wrote:

On Sun\, Oct 12\, 2014 at 7:53 PM\, Father Chrysostomos via RT \perlbug\-followup@perl\.org wrote:

I'd considered reading perl source with a buffer size of 4096 to be a bug in itself.

Could you clarify?

Reading 4K at a time off disk is going to be inefficient compared to reading larger chunks\, especially if we're stopping to expand memory and/or percolate up through the perlio layers each time. When using perlio\, the perlio buffer should be the larger of 8192 and BUFSIZ\, which increased speed dramatically compare to 4K buffers. See

http://perl5.git.perl.org/perl.git/commitdiff/b83080de5c42543809ce9004bcdbcd3162a00e70

Of course 8K is pretty small by today's standards so that could probably be revisited. One of the problems is that the buffer is the same size regardless of whether we're reading off disk or through a pipe. And what's optimal for reading files in general may or may not be optimal for reading Perl source.

I did a quick inventory of all local mounted file systems on HP-UX I explicitly excluded /stand (linux-talk /boot) as that seems to have a larger block-size than the other FS's

All HP-UX versions have 1024 as BUFSIZE in /usr/include/stdio.h

bsize /stand 10.20: 1024 8192 (PA2) 11.00: 8192 65536 (PA2) 11.11: 8192 65536 (PA2) 11.23: 8192 65536 (PA2) 11.23: 8192 8192 (IPF) 11.31: 8192 8192 (IPF)

# di -l | perl -ne'm{^(/dev\S+)\s+(\S+)} and print "$1\t$2\t"\, grep /bsize/ => `fstyp -v $1\n`' /dev/vg00/lvol3 / f_bsize: 8192 /dev/vg00/data /data f_bsize: 8192 /dev/vg00/home /home f_bsize: 8192 /dev/vg00/opt /opt f_bsize: 8192 /dev/vg00/pro /pro f_bsize: 8192 /dev/vg00/prodb /prodb f_bsize: 8192 /dev/vg00/lvol1 /stand f_bsize: 8192 /dev/vg00/tmp /tmp f_bsize: 8192 /dev/vg00/usr /usr f_bsize: 8192 /dev/vg00/lvol8 /var f_bsize: 8192 /dev/vg00/wrk /wrk f_bsize: 8192

-- H.Merijn Brand http://tux.nl Perl Monger http://amsterdam.pm.org/ using perl5.00307 .. 5.19 porting perl5 on HP-UX\, AIX\, and openSUSE http://mirrors.develooper.com/hpux/ http://www.test-smoke.org/ http://qa.perl.org http://www.goldmark.org/jeff/stupid-disclaimers/

p5pRT commented 9 years ago

From @cpansprout

On Sun Oct 12 19:47:57 2014\, bulk88 wrote:

On Sun Oct 12 07:56:16 2014\, sprout wrote:

It did not apply cleanly\, so I pushed it to the sprout/122955 branch\, since I am notorious for screwing up things like this. Please review it.

Since I didn't feel comfortable in reviewing sprout/122955 and merge conflicts. I redid the warnings.pm stuff from scratch using the latest blead. 2 patches attaches. Whitespace patch is new.

Thank you. I have applied these two as effd17dc01 and 56873d4238 and your original patch\, minus the warnings changes\, as f4eedc6b8.

--

Father Chrysostomos

p5pRT commented 9 years ago

@cpansprout - Status changed from 'open' to 'resolved'

p5pRT commented 9 years ago

From @craigberry

On Mon\, Oct 13\, 2014 at 1:16 AM\, H.Merijn Brand \h\.m\.brand@xs4all\.nl wrote:

On Sun\, 12 Oct 2014 20:30:34 -0500\, "Craig A. Berry" \craig\.a\.berry@gmail\.com wrote:

On Sun\, Oct 12\, 2014 at 7:53 PM\, Father Chrysostomos via RT \perlbug\-followup@perl\.org wrote:

I'd considered reading perl source with a buffer size of 4096 to be a bug in itself.

It seems not to be perlio's fault. Using the -DP debug option shows that an 8K perlio buffer (or I guess really it's a crlf buffer not perlio since this is Windows) gets filled and depleted 5 times when reading in the 40\,986-byte warnings.pm\, which sounds about right:

c:\perlgit>.\perl -Ilib -DP -e "use warnings;" 2>sv_gets_debug.txt

c:\perlgit>find "cnt=8191" sv_gets_debug.txt

---------- SV_GETS_DEBUG.TXT Screamer: after getc\, ptr=2856305\, cnt=8191 Screamer: after getc\, ptr=2856305\, cnt=8191 Screamer: after getc\, ptr=2856305\, cnt=8191 Screamer: after getc\, ptr=2856305\, cnt=8191 Screamer: after getc\, ptr=2856305\, cnt=8191

I assume here that 8192 bytes are read and the getc consumes one so the 8191 is how many bytes are left.

I could be missing something as sv_gets() and add_filter() and friends are pretty hairy\, but it looks as though the 4K ReadFile operations that bulk88 originally reported are something the CRT does with read() rather than anything that happens within Perl. Don't know if a setvbuf() or something could improve on that. To be clear\, I'm speculating on what could be sub-optimal about fundamental read operations and am not talking about the patches in the ticket\, which seem like reasonable workarounds.

Perl / perl5