diff options
author | Brad Smith <brad@cvs.openbsd.org> | 2006-01-02 23:37:11 +0000 |
---|---|---|
committer | Brad Smith <brad@cvs.openbsd.org> | 2006-01-02 23:37:11 +0000 |
commit | f2f6b14bfb5bc9ad0276efe011c3d186010ce1a2 (patch) | |
tree | ccf9420b7c08b836cb10bd2bef4f4dec39840d37 | |
parent | de6ef642291f1509f690956bd6424b6739b0fd03 (diff) |
The official fix for the Perl sprintf buffer overflow.
ok millert@
-rw-r--r-- | gnu/usr.bin/perl/globvar.sym | 1 | ||||
-rw-r--r-- | gnu/usr.bin/perl/makedef.pl | 936 | ||||
-rw-r--r-- | gnu/usr.bin/perl/op.c | 1 | ||||
-rw-r--r-- | gnu/usr.bin/perl/opcode.h | 2 | ||||
-rw-r--r-- | gnu/usr.bin/perl/opcode.pl | 2 | ||||
-rw-r--r-- | gnu/usr.bin/perl/patchlevel.h | 1 | ||||
-rw-r--r-- | gnu/usr.bin/perl/perl.h | 2 | ||||
-rw-r--r-- | gnu/usr.bin/perl/sv.c | 32 | ||||
-rw-r--r-- | gnu/usr.bin/perl/t/lib/warnings/sv | 45 | ||||
-rw-r--r-- | gnu/usr.bin/perl/t/op/sprintf.t | 5 | ||||
-rwxr-xr-x | gnu/usr.bin/perl/t/op/sprintf2.t | 52 |
11 files changed, 921 insertions, 158 deletions
diff --git a/gnu/usr.bin/perl/globvar.sym b/gnu/usr.bin/perl/globvar.sym index 0d768889a85..5a3a6843f6d 100644 --- a/gnu/usr.bin/perl/globvar.sym +++ b/gnu/usr.bin/perl/globvar.sym @@ -66,3 +66,4 @@ vtbl_regdatum vtbl_collxfrm vtbl_amagic vtbl_amagicelem +memory_wrap diff --git a/gnu/usr.bin/perl/makedef.pl b/gnu/usr.bin/perl/makedef.pl index e63034beb01..af8f81ec036 100644 --- a/gnu/usr.bin/perl/makedef.pl +++ b/gnu/usr.bin/perl/makedef.pl @@ -1,62 +1,50 @@ # # Create the export list for perl. # -# Needed by WIN32 and OS/2 for creating perl.dll -# and by AIX for creating libperl.a when -Dusershrplib is in effect. +# Needed by WIN32 and OS/2 for creating perl.dll, +# and by AIX for creating libperl.a when -Dusershrplib is in effect, +# and by MacOS Classic. # # reads global.sym, pp.sym, perlvars.h, intrpvar.h, thrdvar.h, config.h -# On OS/2 reads miniperl.map as well +# On OS/2 reads miniperl.map and the previous version of perl5.def as well my $PLATFORM; my $CCTYPE; -my %bincompat5005 = - ( - Perl_call_atexit => "perl_atexit", - Perl_eval_sv => "perl_eval_sv", - Perl_eval_pv => "perl_eval_pv", - Perl_call_argv => "perl_call_argv", - Perl_call_method => "perl_call_method", - Perl_call_pv => "perl_call_pv", - Perl_call_sv => "perl_call_sv", - Perl_get_av => "perl_get_av", - Perl_get_cv => "perl_get_cv", - Perl_get_hv => "perl_get_hv", - Perl_get_sv => "perl_get_sv", - Perl_init_i18nl10n => "perl_init_i18nl10n", - Perl_init_i18nl14n => "perl_init_i18nl14n", - Perl_new_collate => "perl_new_collate", - Perl_new_ctype => "perl_new_ctype", - Perl_new_numeric => "perl_new_numeric", - Perl_require_pv => "perl_require_pv", - Perl_safesyscalloc => "Perl_safecalloc", - Perl_safesysfree => "Perl_safefree", - Perl_safesysmalloc => "Perl_safemalloc", - Perl_safesysrealloc => "Perl_saferealloc", - Perl_set_numeric_local => "perl_set_numeric_local", - Perl_set_numeric_standard => "perl_set_numeric_standard", - Perl_malloc => "malloc", - Perl_mfree => "free", - Perl_realloc => "realloc", - Perl_calloc => "calloc", - ); - -my $bincompat5005 = join("|", keys %bincompat5005); - while (@ARGV) { my $flag = shift; + if ($flag =~ s/^CC_FLAGS=/ /) { + for my $fflag ($flag =~ /(?:^|\s)-D(\S+)/g) { + $fflag .= '=1' unless $fflag =~ /^(\w+)=/; + $define{$1} = $2 if $fflag =~ /^(\w+)=(.+)$/; + } + next; + } $define{$1} = 1 if ($flag =~ /^-D(\w+)$/); $define{$1} = $2 if ($flag =~ /^-D(\w+)=(.+)$/); $CCTYPE = $1 if ($flag =~ /^CCTYPE=(\w+)$/); $PLATFORM = $1 if ($flag =~ /^PLATFORM=(\w+)$/); + if ($PLATFORM eq 'netware') { + $FILETYPE = $1 if ($flag =~ /^FILETYPE=(\w+)$/); + } } -my @PLATFORM = qw(aix win32 os2); +my @PLATFORM = qw(aix win32 wince os2 MacOS netware); my %PLATFORM; @PLATFORM{@PLATFORM} = (); defined $PLATFORM || die "PLATFORM undefined, must be one of: @PLATFORM\n"; -exists $PLATFORM{$PLATFORM} || die "PLATFORM must be one of: @PLATFORM\n"; +exists $PLATFORM{$PLATFORM} || die "PLATFORM must be one of: @PLATFORM\n"; + +my %exportperlmalloc = + ( + Perl_malloc => "malloc", + Perl_mfree => "free", + Perl_realloc => "realloc", + Perl_calloc => "calloc", + ); + +my $exportperlmalloc = $PLATFORM eq 'os2'; my $config_sh = "config.sh"; my $config_h = "config.h"; @@ -67,18 +55,26 @@ my $global_sym = "global.sym"; my $pp_sym = "pp.sym"; my $globvar_sym = "globvar.sym"; my $perlio_sym = "perlio.sym"; +my $static_ext = ""; -if ($PLATFORM eq 'aix') { +if ($PLATFORM eq 'aix') { # Nothing for now. } -elsif ($PLATFORM eq 'win32') { +elsif ($PLATFORM =~ /^win(?:32|ce)$/ || $PLATFORM eq 'netware') { $CCTYPE = "MSVC" unless defined $CCTYPE; - foreach ($thrdvar_h, $intrpvar_h, $perlvars_h, $global_sym, $pp_sym, $globvar_sym) { + foreach ($thrdvar_h, $intrpvar_h, $perlvars_h, $global_sym, + $pp_sym, $globvar_sym, $perlio_sym) { s!^!..\\!; } } +elsif ($PLATFORM eq 'MacOS') { + foreach ($thrdvar_h, $intrpvar_h, $perlvars_h, $global_sym, + $pp_sym, $globvar_sym, $perlio_sym) { + s!^!::!; + } +} -unless ($PLATFORM eq 'win32') { +unless ($PLATFORM eq 'win32' || $PLATFORM eq 'wince' || $PLATFORM eq 'MacOS' || $PLATFORM eq 'netware') { open(CFG,$config_sh) || die "Cannot open $config_sh: $!\n"; while (<CFG>) { if (/^(?:ccflags|optimize)='(.+)'$/) { @@ -86,29 +82,38 @@ unless ($PLATFORM eq 'win32') { $define{$1} = 1 while /-D(\w+)/g; } if ($PLATFORM eq 'os2') { - $CONFIG_ARGS = $1 if /^(?:config_args)='(.+)'$/; - $ARCHNAME = $1 if /^(?:archname)='(.+)'$/; + $CONFIG_ARGS = $1 if /^config_args='(.+)'$/; + $ARCHNAME = $1 if /^archname='(.+)'$/; + $PATCHLEVEL = $1 if /^perl_patchlevel='(.+)'$/; } } close(CFG); } +if ($PLATFORM eq 'win32' || $PLATFORM eq 'wince') { + open(CFG,"<..\\$config_sh") || die "Cannot open ..\\$config_sh: $!\n"; + if ((join '', <CFG>) =~ /^static_ext='(.*)'$/m) { + $static_ext = $1; + } + close(CFG); +} open(CFG,$config_h) || die "Cannot open $config_h: $!\n"; while (<CFG>) { $define{$1} = 1 if /^\s*#\s*define\s+(MYMALLOC)\b/; - $define{$1} = 1 if /^\s*#\s*define\s+(USE_5005THREADS)\b/; - $define{$1} = 1 if /^\s*#\s*define\s+(USE_ITHREADS)\b/; - $define{$1} = 1 if /^\s*#\s*define\s+(USE_PERLIO)\b/; $define{$1} = 1 if /^\s*#\s*define\s+(MULTIPLICITY)\b/; - $define{$1} = 1 if /^\s*#\s*define\s+(PERL_IMPLICIT_SYS)\b/; - $define{$1} = 1 if /^\s*#\s*define\s+(PERL_BINCOMPAT_5005)\b/; + $define{$1} = 1 if /^\s*#\s*define\s+(PERL_\w+)\b/; + $define{$1} = 1 if /^\s*#\s*define\s+(USE_\w+)\b/; } close(CFG); # perl.h logic duplication begins +if ($define{PERL_IMPLICIT_SYS}) { + $define{PL_OP_SLAB_ALLOC} = 1; +} + if ($define{USE_ITHREADS}) { - if (!$define{MULTIPLICITY} && !$define{PERL_OBJECT}) { + if (!$define{MULTIPLICITY}) { $define{MULTIPLICITY} = 1; } } @@ -118,46 +123,49 @@ $define{PERL_IMPLICIT_CONTEXT} ||= $define{USE_5005THREADS} || $define{MULTIPLICITY} ; -if ($define{PERL_CAPI}) { - delete $define{PERL_OBJECT}; - $define{MULTIPLICITY} = 1; - $define{PERL_IMPLICIT_CONTEXT} = 1; - $define{PERL_IMPLICIT_SYS} = 1; -} - -if ($define{PERL_OBJECT}) { - $define{PERL_IMPLICIT_CONTEXT} = 1; - $define{PERL_IMPLICIT_SYS} = 1; +if ($define{USE_ITHREADS} && $PLATFORM ne 'win32' && $^O ne 'darwin') { + $define{USE_REENTRANT_API} = 1; } # perl.h logic duplication ends -if ($PLATFORM eq 'win32') { +my $sym_ord = 0; + +if ($PLATFORM =~ /^win(?:32|ce)$/) { warn join(' ',keys %define)."\n"; - print "LIBRARY Perl56\n"; + ($dll = ($define{PERL_DLL} || "perl58")) =~ s/\.dll$//i; + print "LIBRARY $dll\n"; print "DESCRIPTION 'Perl interpreter'\n"; print "EXPORTS\n"; if ($define{PERL_IMPLICIT_SYS}) { output_symbol("perl_get_host_info"); output_symbol("perl_alloc_override"); } + if ($define{USE_ITHREADS} and $define{PERL_IMPLICIT_SYS}) { + output_symbol("perl_clone_host"); + } } elsif ($PLATFORM eq 'os2') { + if (open my $fh, '<', 'perl5.def') { + while (<$fh>) { + last if /^\s*EXPORTS\b/; + } + while (<$fh>) { + $ordinal{$1} = $2 if /^\s*"(\w+)"\s*(?:=\s*"\w+"\s*)?\@(\d+)\s*$/; + # This allows skipping ordinals which were used in older versions + $sym_ord = $1 if /^\s*;\s*LAST_ORDINAL\s*=\s*(\d+)\s*$/; + } + $sym_ord < $_ and $sym_ord = $_ for values %ordinal; # Take the max + } ($v = $]) =~ s/(\d\.\d\d\d)(\d\d)$/$1_$2/; $v .= '-thread' if $ARCHNAME =~ /-thread/; - #$sum = 0; - #for (split //, $v) { - # $sum = ($sum * 33) + ord; - # $sum &= 0xffffff; - #} - #$sum += $sum >> 5; - #$sum &= 0xffff; - #$sum = printf '%X', $sum; ($dll = $define{PERL_DLL}) =~ s/\.dll$//i; - # print STDERR "'$dll' <= '$define{PERL_DLL}'\n"; + $v .= "\@$PATCHLEVEL" if $PATCHLEVEL; + $d = "DESCRIPTION '\@#perl5-porters\@perl.org:$v#\@ Perl interpreter, configured as $CONFIG_ARGS'"; + $d = substr($d, 0, 249) . "...'" if length $d > 253; print <<"---EOP---"; LIBRARY '$dll' INITINSTANCE TERMINSTANCE -DESCRIPTION '\@#perl5-porters\@perl.org:$v#\@ Perl interpreter, configured as $CONFIG_ARGS' +$d STACKSIZE 32768 CODE LOADONCALL DATA LOADONCALL NONSHARED MULTIPLE @@ -165,7 +173,27 @@ EXPORTS ---EOP--- } elsif ($PLATFORM eq 'aix') { - print "#!\n"; + $OSVER = `uname -v`; + chop $OSVER; + $OSREL = `uname -r`; + chop $OSREL; + if ($OSVER > 4 || ($OSVER == 4 && $OSREL >= 3)) { + print "#! ..\n"; + } else { + print "#!\n"; + } +} +elsif ($PLATFORM eq 'netware') { + if ($FILETYPE eq 'def') { + print "LIBRARY perl58\n"; + print "DESCRIPTION 'Perl interpreter for NetWare'\n"; + print "EXPORTS\n"; + } + if ($define{PERL_IMPLICIT_SYS}) { + output_symbol("perl_get_host_info"); + output_symbol("perl_alloc_override"); + output_symbol("perl_clone_host"); + } } my %skip; @@ -183,7 +211,7 @@ sub emit_symbols { foreach my $symbol (@$list) { my $skipsym = $symbol; # XXX hack - if ($define{PERL_OBJECT} || $define{MULTIPLICITY}) { + if ($define{MULTIPLICITY}) { $skipsym =~ s/^Perl_[GIT](\w+)_ptr$/PL_$1/; } emit_symbol($symbol) unless exists $skip{$skipsym}; @@ -217,6 +245,84 @@ if ($PLATFORM eq 'win32') { Perl_dump_fds Perl_init_thread_intern Perl_my_bzero + Perl_my_bcopy + Perl_my_htonl + Perl_my_ntohl + Perl_my_swap + Perl_my_chsize + Perl_same_dirent + Perl_setenv_getix + Perl_unlnk + Perl_watch + Perl_safexcalloc + Perl_safexmalloc + Perl_safexfree + Perl_safexrealloc + Perl_my_memcmp + Perl_my_memset + PL_cshlen + PL_cshname + PL_opsave + Perl_do_exec + Perl_getenv_len + Perl_my_pclose + Perl_my_popen + )]; +} +else { + skip_symbols [qw( + Perl_do_spawn + Perl_do_spawn_nowait + Perl_do_aspawn + )]; +} +if ($PLATFORM eq 'wince') { + skip_symbols [qw( + PL_statusvalue_vms + PL_archpat_auto + PL_cryptseen + PL_DBcv + PL_generation + PL_lastgotoprobe + PL_linestart + PL_modcount + PL_pending_ident + PL_sortcxix + PL_sublex_info + PL_timesbuf + PL_collation_ix + PL_collation_name + PL_collation_standard + PL_collxfrm_base + PL_collxfrm_mult + PL_numeric_compat1 + PL_numeric_local + PL_numeric_name + PL_numeric_radix_sv + PL_numeric_standard + PL_vtbl_collxfrm + Perl_sv_collxfrm + setgid + setuid + win32_free_childdir + win32_free_childenv + win32_get_childdir + win32_get_childenv + win32_spawnvp + main + Perl_ErrorNo + Perl_GetVars + Perl_do_exec3 + Perl_do_ipcctl + Perl_do_ipcget + Perl_do_msgrcv + Perl_do_msgsnd + Perl_do_semop + Perl_do_shmio + Perl_dump_fds + Perl_init_thread_intern + Perl_my_bzero + Perl_my_bcopy Perl_my_htonl Perl_my_ntohl Perl_my_swap @@ -259,7 +365,9 @@ elsif ($PLATFORM eq 'aix') { Perl_safexrealloc Perl_same_dirent Perl_unlnk + Perl_sys_intern_clear Perl_sys_intern_dup + Perl_sys_intern_init PL_cryptseen PL_opsave PL_statusvalue_vms @@ -271,20 +379,40 @@ elsif ($PLATFORM eq 'os2') { ctermid get_sysinfo Perl_OS2_init + Perl_OS2_init3 + Perl_OS2_term OS2_Perl_data dlopen dlsym dlerror dlclose + dup2 + dup my_tmpfile my_tmpnam my_flock + my_rmdir + my_mkdir + my_getpwuid + my_getpwnam + my_getpwent + my_setpwent + my_endpwent + fork_with_resources + croak_with_os2error + setgrent + endgrent + getgrent malloc_mutex threads_mutex nthreads nthreads_cond os2_cond_wait os2_stat + os2_execname + async_mssleep + msCounter + InfoTable pthread_join pthread_create pthread_detach @@ -307,18 +435,133 @@ elsif ($PLATFORM eq 'os2') { init_PMWIN_entries PMWIN_entries Perl_hab_GET + loadByOrdinal + pExtFCN + os2error + ResetWinError + CroakWinError + PL_do_undump )]); + emit_symbols([qw(os2_cond_wait + pthread_join + pthread_create + pthread_detach + )]) + if $define{'USE_5005THREADS'} or $define{'USE_ITHREADS'}; +} +elsif ($PLATFORM eq 'MacOS') { + skip_symbols [qw( + Perl_GetVars + PL_cryptseen + PL_cshlen + PL_cshname + PL_statusvalue_vms + PL_sys_intern + PL_opsave + PL_timesbuf + Perl_dump_fds + Perl_my_bcopy + Perl_my_bzero + Perl_my_chsize + Perl_my_htonl + Perl_my_memcmp + Perl_my_memset + Perl_my_ntohl + Perl_my_swap + Perl_safexcalloc + Perl_safexfree + Perl_safexmalloc + Perl_safexrealloc + Perl_unlnk + Perl_sys_intern_clear + Perl_sys_intern_init + )]; +} +elsif ($PLATFORM eq 'netware') { + skip_symbols [qw( + PL_statusvalue_vms + PL_archpat_auto + PL_cryptseen + PL_DBcv + PL_generation + PL_lastgotoprobe + PL_linestart + PL_modcount + PL_pending_ident + PL_sortcxix + PL_sublex_info + PL_timesbuf + main + Perl_ErrorNo + Perl_GetVars + Perl_do_exec3 + Perl_do_ipcctl + Perl_do_ipcget + Perl_do_msgrcv + Perl_do_msgsnd + Perl_do_semop + Perl_do_shmio + Perl_dump_fds + Perl_init_thread_intern + Perl_my_bzero + Perl_my_htonl + Perl_my_ntohl + Perl_my_swap + Perl_my_chsize + Perl_same_dirent + Perl_setenv_getix + Perl_unlnk + Perl_watch + Perl_safexcalloc + Perl_safexmalloc + Perl_safexfree + Perl_safexrealloc + Perl_my_memcmp + Perl_my_memset + PL_cshlen + PL_cshname + PL_opsave + Perl_do_exec + Perl_getenv_len + Perl_my_pclose + Perl_my_popen + Perl_sys_intern_init + Perl_sys_intern_dup + Perl_sys_intern_clear + Perl_my_bcopy + Perl_PerlIO_write + Perl_PerlIO_unread + Perl_PerlIO_tell + Perl_PerlIO_stdout + Perl_PerlIO_stdin + Perl_PerlIO_stderr + Perl_PerlIO_setlinebuf + Perl_PerlIO_set_ptrcnt + Perl_PerlIO_set_cnt + Perl_PerlIO_seek + Perl_PerlIO_read + Perl_PerlIO_get_ptr + Perl_PerlIO_get_cnt + Perl_PerlIO_get_bufsiz + Perl_PerlIO_get_base + Perl_PerlIO_flush + Perl_PerlIO_fill + Perl_PerlIO_fileno + Perl_PerlIO_error + Perl_PerlIO_eof + Perl_PerlIO_close + Perl_PerlIO_clearerr + PerlIO_perlio + )]; } unless ($define{'DEBUGGING'}) { skip_symbols [qw( - Perl_deb Perl_deb_growlevel Perl_debop Perl_debprofdump Perl_debstack Perl_debstackptrs - Perl_runops_debug Perl_sv_peek PL_block_type PL_watchaddr @@ -355,14 +598,20 @@ unless ($define{'PERL_FLEXIBLE_EXCEPTIONS'}) { )]; } +unless ($define{'USE_REENTRANT_API'}) { + skip_symbols [qw( + PL_reentrant_buffer + )]; +} + if ($define{'MYMALLOC'}) { emit_symbols [qw( Perl_dump_mstats Perl_get_mstats - Perl_malloc - Perl_mfree - Perl_realloc - Perl_calloc + Perl_strdup + Perl_putenv + MallocCfg_ptr + MallocCfgP_ptr )]; if ($define{'USE_5005THREADS'} || $define{'USE_ITHREADS'}) { emit_symbols [qw( @@ -380,11 +629,9 @@ else { PL_malloc_mutex Perl_dump_mstats Perl_get_mstats - Perl_malloc - Perl_mfree - Perl_realloc - Perl_calloc Perl_malloced_size + MallocCfg_ptr + MallocCfgP_ptr )]; } @@ -401,6 +648,8 @@ unless ($define{'USE_5005THREADS'}) { PL_svref_mutex PL_cred_mutex PL_eval_mutex + PL_fdpid_mutex + PL_sv_lock_mutex PL_eval_cond PL_eval_owner PL_threads_mutex @@ -417,6 +666,7 @@ unless ($define{'USE_5005THREADS'}) { Perl_find_threadsv Perl_unlock_condpair Perl_magic_mutexfree + Perl_sv_lock )]; } @@ -424,6 +674,11 @@ unless ($define{'USE_ITHREADS'}) { skip_symbols [qw( PL_ptr_table PL_op_mutex + PL_regex_pad + PL_regex_padav + PL_sharedsv_space + PL_sharedsv_space_mutex + PL_dollarzero_mutex Perl_dirp_dup Perl_cx_dup Perl_si_dup @@ -436,12 +691,23 @@ unless ($define{'USE_ITHREADS'}) { Perl_re_dup Perl_sv_dup Perl_sys_intern_dup + Perl_ptr_table_clear Perl_ptr_table_fetch + Perl_ptr_table_free Perl_ptr_table_new + Perl_ptr_table_clear + Perl_ptr_table_free Perl_ptr_table_split Perl_ptr_table_store perl_clone perl_clone_using + Perl_sharedsv_find + Perl_sharedsv_init + Perl_sharedsv_lock + Perl_sharedsv_new + Perl_sharedsv_thrcnt_dec + Perl_sharedsv_thrcnt_inc + Perl_sharedsv_unlock )]; } @@ -474,6 +740,20 @@ unless ($define{'FAKE_THREADS'}) { skip_symbols [qw(PL_curthr)]; } +unless ($define{'PL_OP_SLAB_ALLOC'}) { + skip_symbols [qw( + PL_OpPtr + PL_OpSlab + PL_OpSpace + Perl_Slab_Alloc + Perl_Slab_Free + )]; +} + +unless ($define{'THREADS_HAVE_PIDS'}) { + skip_symbols [qw(PL_ppid)]; +} + sub readvar { my $file = shift; my $proc = shift || sub { "PL_$_[2]" }; @@ -483,8 +763,8 @@ sub readvar { # All symbols have a Perl_ prefix because that's what embed.h # sticks in front of them. push(@syms, &$proc($1,$2,$3)) if (/\bPERLVAR(A?I?C?)\(([IGT])(\w+)/); - } - close(VARS); + } + close(VARS); return \@syms; } @@ -504,8 +784,182 @@ if ($define{'PERL_GLOBAL_STRUCT'}) { my @syms = ($global_sym, $globvar_sym); # $pp_sym is not part of the API +# Symbols that are the public face of the PerlIO layers implementation +# These are in _addition to_ the public face of the abstraction +# and need to be exported to allow XS modules to implement layers +my @layer_syms = qw( + PerlIOBase_binmode + PerlIOBase_clearerr + PerlIOBase_close + PerlIOBase_dup + PerlIOBase_eof + PerlIOBase_error + PerlIOBase_fileno + PerlIOBase_noop_fail + PerlIOBase_noop_ok + PerlIOBase_popped + PerlIOBase_pushed + PerlIOBase_read + PerlIOBase_setlinebuf + PerlIOBase_unread + PerlIOBuf_bufsiz + PerlIOBuf_close + PerlIOBuf_dup + PerlIOBuf_fill + PerlIOBuf_flush + PerlIOBuf_get_base + PerlIOBuf_get_cnt + PerlIOBuf_get_ptr + PerlIOBuf_open + PerlIOBuf_popped + PerlIOBuf_pushed + PerlIOBuf_read + PerlIOBuf_seek + PerlIOBuf_set_ptrcnt + PerlIOBuf_tell + PerlIOBuf_unread + PerlIOBuf_write + PerlIO_allocate + PerlIO_apply_layera + PerlIO_apply_layers + PerlIO_arg_fetch + PerlIO_debug + PerlIO_define_layer + PerlIO_isutf8 + PerlIO_layer_fetch + PerlIO_list_free + PerlIO_modestr + PerlIO_parse_layers + PerlIO_pending + PerlIO_perlio + PerlIO_pop + PerlIO_push + PerlIO_sv_dup + Perl_PerlIO_clearerr + Perl_PerlIO_close + Perl_PerlIO_eof + Perl_PerlIO_error + Perl_PerlIO_fileno + Perl_PerlIO_fill + Perl_PerlIO_flush + Perl_PerlIO_get_base + Perl_PerlIO_get_bufsiz + Perl_PerlIO_get_cnt + Perl_PerlIO_get_ptr + Perl_PerlIO_read + Perl_PerlIO_seek + Perl_PerlIO_set_cnt + Perl_PerlIO_set_ptrcnt + Perl_PerlIO_setlinebuf + Perl_PerlIO_stderr + Perl_PerlIO_stdin + Perl_PerlIO_stdout + Perl_PerlIO_tell + Perl_PerlIO_unread + Perl_PerlIO_write +); +if ($PLATFORM eq 'netware') { + push(@layer_syms,'PL_def_layerlist','PL_known_layers','PL_perlio'); +} + if ($define{'USE_PERLIO'}) { - push @syms, $perlio_sym; + # Export the symols that make up the PerlIO abstraction, regardless + # of its implementation - read from a file + push @syms, $perlio_sym; + + # This part is then dependent on how the abstraction is implemented + if ($define{'USE_SFIO'}) { + # Old legacy non-stdio "PerlIO" + skip_symbols \@layer_syms; + # SFIO defines most of the PerlIO routines as macros + # So undo most of what $perlio_sym has just done - d'oh ! + # Perhaps it would be better to list the ones which do exist + # And emit them + skip_symbols [qw( + PerlIO_canset_cnt + PerlIO_clearerr + PerlIO_close + PerlIO_eof + PerlIO_error + PerlIO_exportFILE + PerlIO_fast_gets + PerlIO_fdopen + PerlIO_fileno + PerlIO_findFILE + PerlIO_flush + PerlIO_get_base + PerlIO_get_bufsiz + PerlIO_get_cnt + PerlIO_get_ptr + PerlIO_getc + PerlIO_getname + PerlIO_has_base + PerlIO_has_cntptr + PerlIO_importFILE + PerlIO_open + PerlIO_printf + PerlIO_putc + PerlIO_puts + PerlIO_read + PerlIO_releaseFILE + PerlIO_reopen + PerlIO_rewind + PerlIO_seek + PerlIO_set_cnt + PerlIO_set_ptrcnt + PerlIO_setlinebuf + PerlIO_sprintf + PerlIO_stderr + PerlIO_stdin + PerlIO_stdout + PerlIO_stdoutf + PerlIO_tell + PerlIO_ungetc + PerlIO_vprintf + PerlIO_write + PerlIO_perlio + Perl_PerlIO_clearerr + Perl_PerlIO_close + Perl_PerlIO_eof + Perl_PerlIO_error + Perl_PerlIO_fileno + Perl_PerlIO_fill + Perl_PerlIO_flush + Perl_PerlIO_get_base + Perl_PerlIO_get_bufsiz + Perl_PerlIO_get_cnt + Perl_PerlIO_get_ptr + Perl_PerlIO_read + Perl_PerlIO_seek + Perl_PerlIO_set_cnt + Perl_PerlIO_set_ptrcnt + Perl_PerlIO_setlinebuf + Perl_PerlIO_stderr + Perl_PerlIO_stdin + Perl_PerlIO_stdout + Perl_PerlIO_tell + Perl_PerlIO_unread + Perl_PerlIO_write + PL_def_layerlist + PL_known_layers + PL_perlio + )]; + } + else { + # PerlIO with layers - export implementation + emit_symbols \@layer_syms; + } +} else { + # -Uuseperlio + # Skip the PerlIO layer symbols - although + # nothing should have exported them any way + skip_symbols \@layer_syms; + skip_symbols [qw(PL_def_layerlist PL_known_layers PL_perlio)]; + + # Also do NOT add abstraction symbols from $perlio_sym + # abstraction is done as #define to stdio + # Remaining remnants that _may_ be functions + # are handled in <DATA> } for my $syms (@syms) { @@ -524,13 +978,13 @@ for my $syms (@syms) { # variables -if ($define{'PERL_OBJECT'} || $define{'MULTIPLICITY'}) { +if ($define{'MULTIPLICITY'}) { for my $f ($perlvars_h, $intrpvar_h, $thrdvar_h) { my $glob = readvar($f, sub { "Perl_" . $_[1] . $_[2] . "_ptr" }); emit_symbols $glob; } # XXX AIX seems to want the perlvars.h symbols, for some reason - if ($PLATFORM eq 'aix') { + if ($PLATFORM eq 'aix' or $PLATFORM eq 'os2') { # OS/2 needs PL_thr_key my $glob = readvar($perlvars_h); emit_symbols $glob; } @@ -539,21 +993,21 @@ else { unless ($define{'PERL_GLOBAL_STRUCT'}) { my $glob = readvar($perlvars_h); emit_symbols $glob; - } + } unless ($define{'MULTIPLICITY'}) { my $glob = readvar($intrpvar_h); emit_symbols $glob; - } + } unless ($define{'MULTIPLICITY'} || $define{'USE_5005THREADS'}) { my $glob = readvar($thrdvar_h); emit_symbols $glob; - } + } } sub try_symbol { my $symbol = shift; - return if $symbol !~ /^[A-Za-z]/; + return if $symbol !~ /^[A-Za-z_]/; return if $symbol =~ /^\#/; $symbol =~s/\r//g; chomp($symbol); @@ -565,44 +1019,19 @@ while (<DATA>) { try_symbol($_); } -if ($PLATFORM eq 'win32') { +if ($PLATFORM =~ /^win(?:32|ce)$/) { foreach my $symbol (qw( + setuid + setgid boot_DynaLoader Perl_init_os_extras Perl_thread_create Perl_win32_init + Perl_win32_term RunPerl + win32_async_check win32_errno win32_environ - win32_stdin - win32_stdout - win32_stderr - win32_ferror - win32_feof - win32_strerror - win32_fprintf - win32_printf - win32_vfprintf - win32_vprintf - win32_fread - win32_fwrite - win32_fopen - win32_fdopen - win32_freopen - win32_fclose - win32_fputs - win32_fputc - win32_ungetc - win32_getc - win32_fileno - win32_clearerr - win32_fflush - win32_ftell - win32_fseek - win32_fgetpos - win32_fsetpos - win32_rewind - win32_tmpfile win32_abort win32_fstat win32_stat @@ -611,6 +1040,7 @@ if ($PLATFORM eq 'win32') { win32_pclose win32_rename win32_setmode + win32_chsize win32_lseek win32_tell win32_dup @@ -673,17 +1103,6 @@ if ($PLATFORM eq 'win32') { win32_getenv win32_putenv win32_perror - win32_setbuf - win32_setvbuf - win32_flushall - win32_fcloseall - win32_fgets - win32_gets - win32_fgetc - win32_putc - win32_puts - win32_getchar - win32_putchar win32_malloc win32_calloc win32_realloc @@ -699,6 +1118,7 @@ if ($PLATFORM eq 'win32') { win32_link win32_unlink win32_utime + win32_gettimeofday win32_uname win32_wait win32_waitpid @@ -715,6 +1135,51 @@ if ($PLATFORM eq 'win32') { win32_getpid win32_crypt win32_dynaload + win32_get_childenv + win32_free_childenv + win32_clearenv + win32_get_childdir + win32_free_childdir + win32_stdin + win32_stdout + win32_stderr + win32_ferror + win32_feof + win32_strerror + win32_fprintf + win32_printf + win32_vfprintf + win32_vprintf + win32_fread + win32_fwrite + win32_fopen + win32_fdopen + win32_freopen + win32_fclose + win32_fputs + win32_fputc + win32_ungetc + win32_getc + win32_fileno + win32_clearerr + win32_fflush + win32_ftell + win32_fseek + win32_fgetpos + win32_fsetpos + win32_rewind + win32_tmpfile + win32_setbuf + win32_setvbuf + win32_flushall + win32_fcloseall + win32_fgets + win32_gets + win32_fgetc + win32_putc + win32_puts + win32_getchar + win32_putchar )) { try_symbol($symbol); @@ -725,10 +1190,171 @@ elsif ($PLATFORM eq 'os2') { /^\s*[\da-f:]+\s+(\w+)/i and $mapped{$1}++ foreach <MAP>; close MAP or die 'Cannot close miniperl.map'; - @missing = grep { !exists $mapped{$_} and !exists $bincompat5005{$_} } + @missing = grep { !exists $mapped{$_} } keys %export; + @missing = grep { !exists $exportperlmalloc{$_} } @missing; delete $export{$_} foreach @missing; } +elsif ($PLATFORM eq 'MacOS') { + open MACSYMS, 'macperl.sym' or die 'Cannot read macperl.sym'; + + while (<MACSYMS>) { + try_symbol($_); + } + + close MACSYMS; +} +elsif ($PLATFORM eq 'netware') { +foreach my $symbol (qw( + boot_DynaLoader + Perl_init_os_extras + Perl_thread_create + Perl_nw5_init + RunPerl + AllocStdPerl + FreeStdPerl + do_spawn2 + do_aspawn + nw_uname + nw_stdin + nw_stdout + nw_stderr + nw_feof + nw_ferror + nw_fopen + nw_fclose + nw_clearerr + nw_getc + nw_fgets + nw_fputc + nw_fputs + nw_fflush + nw_ungetc + nw_fileno + nw_fdopen + nw_freopen + nw_fread + nw_fwrite + nw_setbuf + nw_setvbuf + nw_vfprintf + nw_ftell + nw_fseek + nw_rewind + nw_tmpfile + nw_fgetpos + nw_fsetpos + nw_dup + nw_access + nw_chmod + nw_chsize + nw_close + nw_dup2 + nw_flock + nw_isatty + nw_link + nw_lseek + nw_stat + nw_mktemp + nw_open + nw_read + nw_rename + nw_setmode + nw_unlink + nw_utime + nw_write + nw_chdir + nw_rmdir + nw_closedir + nw_opendir + nw_readdir + nw_rewinddir + nw_seekdir + nw_telldir + nw_htonl + nw_htons + nw_ntohl + nw_ntohs + nw_accept + nw_bind + nw_connect + nw_endhostent + nw_endnetent + nw_endprotoent + nw_endservent + nw_gethostbyaddr + nw_gethostbyname + nw_gethostent + nw_gethostname + nw_getnetbyaddr + nw_getnetbyname + nw_getnetent + nw_getpeername + nw_getprotobyname + nw_getprotobynumber + nw_getprotoent + nw_getservbyname + nw_getservbyport + nw_getservent + nw_getsockname + nw_getsockopt + nw_inet_addr + nw_listen + nw_socket + nw_recv + nw_recvfrom + nw_select + nw_send + nw_sendto + nw_sethostent + nw_setnetent + nw_setprotoent + nw_setservent + nw_setsockopt + nw_inet_ntoa + nw_shutdown + nw_crypt + nw_execvp + nw_kill + nw_Popen + nw_Pclose + nw_Pipe + nw_times + nw_waitpid + nw_getpid + nw_spawnvp + nw_os_id + nw_open_osfhandle + nw_get_osfhandle + nw_abort + nw_sleep + nw_wait + nw_dynaload + nw_strerror + fnFpSetMode + fnInsertHashListAddrs + fnGetHashListAddrs + Perl_deb + Perl_sv_setsv + Perl_sv_catsv + Perl_sv_catpvn + Perl_sv_2pv + nw_freeenviron + Remove_Thread_Ctx + )) + { + try_symbol($symbol); + } +} + +# records of type boot_module for statically linked modules (except Dynaloader) +$static_ext =~ s/\//__/g; +$static_ext =~ s/\bDynaLoader\b//; +my @stat_mods = map {"boot_$_"} grep {/\S/} split /\s+/, $static_ext; +foreach my $symbol (@stat_mods) + { + try_symbol($symbol); + } # Now all symbols should be defined because # next we are going to output them. @@ -737,17 +1363,26 @@ foreach my $symbol (sort keys %export) { output_symbol($symbol); } +if ($PLATFORM eq 'os2') { + print <<EOP; + dll_perlmain=main + fill_extLibpath + dir_subst + Perl_OS2_handler_install + +; LAST_ORDINAL=$sym_ord +EOP +} + sub emit_symbol { my $symbol = shift; - chomp($symbol); + chomp($symbol); $export{$symbol} = 1; } sub output_symbol { my $symbol = shift; - $symbol = $bincompat5005{$symbol} - if $define{PERL_BINCOMPAT_5005} and $symbol =~ /^($bincompat5005)$/; - if ($PLATFORM eq 'win32') { + if ($PLATFORM =~ /^win(?:32|ce)$/) { $symbol = "_$symbol" if $CCTYPE eq 'BORLAND'; print "\t$symbol\n"; # XXX: binary compatibility between compilers is an exercise @@ -773,16 +1408,25 @@ sub output_symbol { # } } elsif ($PLATFORM eq 'os2') { - print qq( "$symbol"\n); + printf qq( %-31s \@%s\n), + qq("$symbol"), $ordinal{$symbol} || ++$sym_ord; + printf qq( %-31s \@%s\n), + qq("$exportperlmalloc{$symbol}" = "$symbol"), + $ordinal{$exportperlmalloc{$symbol}} || ++$sym_ord + if $exportperlmalloc and exists $exportperlmalloc{$symbol}; } - elsif ($PLATFORM eq 'aix') { + elsif ($PLATFORM eq 'aix' || $PLATFORM eq 'MacOS') { print "$symbol\n"; } + elsif ($PLATFORM eq 'netware') { + print "\t$symbol,\n"; + } } 1; __DATA__ # extra globals not included above. +Perl_cxinc perl_alloc perl_alloc_using perl_clone @@ -792,3 +1436,13 @@ perl_destruct perl_free perl_parse perl_run +# Oddities from PerlIO +PerlIO_binmode +PerlIO_getpos +PerlIO_init +PerlIO_setpos +PerlIO_sprintf +PerlIO_sv_dup +PerlIO_tmpfile +PerlIO_vsprintf +perlsio_binmode diff --git a/gnu/usr.bin/perl/op.c b/gnu/usr.bin/perl/op.c index 1c6452ef0a0..d59ab1f177e 100644 --- a/gnu/usr.bin/perl/op.c +++ b/gnu/usr.bin/perl/op.c @@ -2064,7 +2064,6 @@ Perl_fold_constants(pTHX_ register OP *o) /* XXX might want a ck_negate() for this */ cUNOPo->op_first->op_private &= ~OPpCONST_STRICT; break; - case OP_SPRINTF: case OP_UCFIRST: case OP_LCFIRST: case OP_UC: diff --git a/gnu/usr.bin/perl/opcode.h b/gnu/usr.bin/perl/opcode.h index 6a7fc088918..168b39e2b58 100644 --- a/gnu/usr.bin/perl/opcode.h +++ b/gnu/usr.bin/perl/opcode.h @@ -1585,7 +1585,7 @@ EXT U32 PL_opargs[] = { 0x0022281c, /* vec */ 0x0122291c, /* index */ 0x0122291c, /* rindex */ - 0x0004280f, /* sprintf */ + 0x0004280d, /* sprintf */ 0x00042805, /* formline */ 0x0001379e, /* ord */ 0x0001378e, /* chr */ diff --git a/gnu/usr.bin/perl/opcode.pl b/gnu/usr.bin/perl/opcode.pl index d59ac0391e5..b9f76c3693f 100644 --- a/gnu/usr.bin/perl/opcode.pl +++ b/gnu/usr.bin/perl/opcode.pl @@ -602,7 +602,7 @@ vec vec ck_fun ist@ S S S index index ck_index isT@ S S S? rindex rindex ck_index isT@ S S S? -sprintf sprintf ck_fun mfst@ S L +sprintf sprintf ck_fun mst@ S L formline formline ck_fun ms@ S L ord ord ck_fun ifsTu% S? chr chr ck_fun fsTu% S? diff --git a/gnu/usr.bin/perl/patchlevel.h b/gnu/usr.bin/perl/patchlevel.h index dec0581c621..83bf774d886 100644 --- a/gnu/usr.bin/perl/patchlevel.h +++ b/gnu/usr.bin/perl/patchlevel.h @@ -121,6 +121,7 @@ hunk. static char *local_patches[] = { NULL ,"SUIDPERLIO1 - fix PERLIO_DEBUG buffer overflow (CAN-2005-0156)" + ,"SPRINTF0 - fixes for sprintf formatting issues - CVE-2005-3962" ,NULL }; diff --git a/gnu/usr.bin/perl/perl.h b/gnu/usr.bin/perl/perl.h index f33d66e40f6..1b2304df9ba 100644 --- a/gnu/usr.bin/perl/perl.h +++ b/gnu/usr.bin/perl/perl.h @@ -3071,10 +3071,8 @@ EXTCONST char PL_no_myglob[] INIT("\"my\" variable %s can't be in a package"); EXTCONST char PL_no_localize_ref[] INIT("Can't localize through a reference"); -#ifdef PERL_MALLOC_WRAP EXTCONST char PL_memory_wrap[] INIT("panic: memory wrap"); -#endif EXTCONST char PL_uuemap[65] INIT("`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_"); diff --git a/gnu/usr.bin/perl/sv.c b/gnu/usr.bin/perl/sv.c index 1a0da2525c3..d8a510854c1 100644 --- a/gnu/usr.bin/perl/sv.c +++ b/gnu/usr.bin/perl/sv.c @@ -8541,7 +8541,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (EXPECT_NUMBER(q, width)) { if (*q == '$') { ++q; - efix = width > PERL_INT_MAX ? PERL_INT_MAX : width; + efix = width; } else { goto gotwidth; } @@ -8606,9 +8606,12 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (vectorarg) { if (args) vecsv = va_arg(*args, SV*); - else - vecsv = (evix ? evix <= svmax : svix < svmax) ? - svargs[evix ? evix-1 : svix++] : &PL_sv_undef; + else if (evix) { + vecsv = (evix > 0 && evix <= svmax) + ? svargs[evix-1] : &PL_sv_undef; + } else { + vecsv = svix < svmax ? svargs[svix++] : &PL_sv_undef; + } dotstr = SvPVx(vecsv, dotstrlen); if (DO_UTF8(vecsv)) is_utf8 = TRUE; @@ -8618,12 +8621,13 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV vecstr = (U8*)SvPVx(vecsv,veclen); vec_utf8 = DO_UTF8(vecsv); } - else if (efix ? efix <= svmax : svix < svmax) { + else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) { vecsv = svargs[efix ? efix-1 : svix++]; vecstr = (U8*)SvPVx(vecsv,veclen); vec_utf8 = DO_UTF8(vecsv); } else { + vecsv = &PL_sv_undef; vecstr = (U8*)""; veclen = 0; } @@ -8724,9 +8728,15 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (vectorize) argsv = vecsv; - else if (!args) - argsv = (efix ? efix <= svmax : svix < svmax) ? - svargs[efix ? efix-1 : svix++] : &PL_sv_undef; + else if (!args) { + if (efix) { + const I32 i = efix-1; + argsv = (i >= 0 && i < svmax) ? svargs[i] : &PL_sv_undef; + } else { + argsv = (svix >= 0 && svix < svmax) + ? svargs[svix++] : &PL_sv_undef; + } + } switch (c = *q++) { @@ -8968,6 +8978,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV *--eptr = '0'; break; case 2: + if (!uv) + alt = FALSE; do { dig = uv & 1; *--eptr = '0' + dig; @@ -9270,6 +9282,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* calculate width before utf8_upgrade changes it */ have = esignlen + zeros + elen; + if (have < zeros) + Perl_croak_nocontext(PL_memory_wrap); if (is_utf8 != has_utf8) { if (is_utf8) { @@ -9297,6 +9311,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV need = (have > width ? have : width); gap = need - have; + if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1)) + Perl_croak_nocontext(PL_memory_wrap); SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1); p = SvEND(sv); if (esignlen && fill == '0') { diff --git a/gnu/usr.bin/perl/t/lib/warnings/sv b/gnu/usr.bin/perl/t/lib/warnings/sv index d9aa827fc8a..91398de3e83 100644 --- a/gnu/usr.bin/perl/t/lib/warnings/sv +++ b/gnu/usr.bin/perl/t/lib/warnings/sv @@ -112,6 +112,26 @@ Use of uninitialized value in bitwise or (|) at - line 4. ######## # sv.c use warnings 'uninitialized' ; +my $Y = 1 ; +my $x = 1 & $a[$Y] ; +no warnings 'uninitialized' ; +my $Y = 1 ; +$x = 1 & $b[$Y] ; +EXPECT +Use of uninitialized value in bitwise and (&) at - line 4. +######## +# sv.c +use warnings 'uninitialized' ; +my $Y = 1 ; +my $x = ~$a[$Y] ; +no warnings 'uninitialized' ; +my $Y = 1 ; +$x = ~$b[$Y] ; +EXPECT +Use of uninitialized value in 1's complement (~) at - line 4. +######## +# sv.c +use warnings 'uninitialized' ; my $x *= 1 ; # d no warnings 'uninitialized' ; my $y *= 1 ; # d @@ -281,12 +301,12 @@ $a = sprintf "%" ; printf F "%\x02" ; $a = sprintf "%\x02" ; EXPECT -Invalid conversion in sprintf: "%z" at - line 5. -Invalid conversion in sprintf: end of string at - line 7. -Invalid conversion in sprintf: "%\002" at - line 9. Invalid conversion in printf: "%z" at - line 4. +Invalid conversion in sprintf: "%z" at - line 5. Invalid conversion in printf: end of string at - line 6. +Invalid conversion in sprintf: end of string at - line 7. Invalid conversion in printf: "%\002" at - line 8. +Invalid conversion in sprintf: "%\002" at - line 9. ######## # sv.c use warnings 'misc' ; @@ -345,3 +365,22 @@ no warnings 'numeric' ; $a = "\x{100}\x{200}"; $a = -$a; EXPECT Argument "\x{100}\x{200}" isn't numeric in negation (-) at - line 3. +######## +# sv.c +open F, ">".($^O eq 'VMS'? 'NL:' : '/dev/null') ; +use warnings 'printf'; +$a = "a\nb"; +$s = sprintf "%4s", $a; +printf F "%4s", $a; +$s = sprintf "%-4s", $a; +printf F "%-4s", $a; +$s = sprintf "%*s", -4, $a; +no warnings 'printf'; +$s = sprintf "%4s", $a; +printf F "%4s", $a; +$s = sprintf "%-4s", $a; +printf F "%-4s", $a; +EXPECT +Newline in left-justified string for sprintf at - line 7. +Newline in left-justified string for printf at - line 8. +Newline in left-justified string for sprintf at - line 9. diff --git a/gnu/usr.bin/perl/t/op/sprintf.t b/gnu/usr.bin/perl/t/op/sprintf.t index c854588ce23..91a8877111d 100644 --- a/gnu/usr.bin/perl/t/op/sprintf.t +++ b/gnu/usr.bin/perl/t/op/sprintf.t @@ -385,3 +385,8 @@ __END__ >%4$K %d< >[45, 67]< >%4$K 45 INVALID< >%d %K %d< >[23, 45]< >23 %K 45 INVALID< >%*v*999\$d %d %d< >[11, 22, 33]< >%*v*999\$d 11 22 INVALID< +>%#b< >0< >0< +>%#o< >0< >0< +>%#x< >0< >0< +>%2918905856$v2d< >''< >< +>%*2918905856$v2d< >''< > UNINIT< diff --git a/gnu/usr.bin/perl/t/op/sprintf2.t b/gnu/usr.bin/perl/t/op/sprintf2.t index fef25f197ae..fc79707a0f7 100755 --- a/gnu/usr.bin/perl/t/op/sprintf2.t +++ b/gnu/usr.bin/perl/t/op/sprintf2.t @@ -6,7 +6,7 @@ BEGIN { require './test.pl'; } -plan tests => 2; +plan tests => 7 + 256; is( sprintf("%.40g ",0.01), @@ -18,3 +18,53 @@ is( sprintf("%.40f", 0.01)." ", q(the sprintf "%.<number>f" optimization) ); +{ + chop(my $utf8_format = "%-3s\x{100}"); + is( + sprintf($utf8_format, "\xe4"), + "\xe4 ", + q(width calculation under utf8 upgrade) + ); +} + +# Used to mangle PL_sv_undef +fresh_perl_is( + 'print sprintf "xxx%n\n"; print undef', + 'Modification of a read-only value attempted at - line 1.', + { switches => [ '-w' ] }, + q(%n should not be able to modify read-only constants), +); + +# check %NNN$ for range bounds, especially negative 2's complement + +{ + my ($warn, $bad) = (0,0); + local $SIG{__WARN__} = sub { + if ($_[0] =~ /uninitialized/) { + $warn++ + } + else { + $bad++ + } + }; + my $result = sprintf join('', map("%$_\$s%" . ~$_ . '$s', 1..20)), + qw(a b c d); + is($result, "abcd", "only four valid values"); + is($warn, 36, "expected warnings"); + is($bad, 0, "unexpected warnings"); +} + +{ + foreach my $ord (0 .. 255) { + my $bad = 0; + local $SIG{__WARN__} = sub { + unless ($_[0] =~ /^Invalid conversion in sprintf/ || + $_[0] =~ /^Use of uninitialized value in sprintf/) { + warn $_[0]; + $bad++; + } + }; + my $r = eval {sprintf '%v' . chr $ord}; + is ($bad, 0, "pattern '%v' . chr $ord"); + } +} |