In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/19fc2965b60669d7bc25548edb32e3cdd86a68de?hp=ec35cd4c022dea519712ce60efb24e281b048471>
- Log ----------------------------------------------------------------- commit 19fc2965b60669d7bc25548edb32e3cdd86a68de Author: Jarkko Hietaniemi <[email protected]> Date: Tue May 10 08:56:13 2016 -0400 Croak on unimplemented already at import time For example perl -MPOSIX=atexit -e 1 is never going to work in runtime, so why should it work in compile time. This will probably break a lot of CPAN code, that have "good reasons" for their strange imports. Also the error messages change format, which will no doubt break another set of equally righteous CPAN modules. M ext/POSIX/lib/POSIX.pm M ext/POSIX/t/posix.t M ext/POSIX/t/unimplemented.t commit f914a2ba4b8f428b4efbe6b125d07f221f107a40 Author: Jarkko Hietaniemi <[email protected]> Date: Tue May 10 08:42:37 2016 -0400 Remove the deprecated POSIX::tmpnam as unsafe M ext/POSIX/POSIX.xs M ext/POSIX/lib/POSIX.pm M ext/POSIX/lib/POSIX.pod M ext/POSIX/t/posix.t commit c60f3449d2166487bf605f16fd7f6537dfffc5e4 Author: Jarkko Hietaniemi <[email protected]> Date: Tue May 10 08:41:37 2016 -0400 Sort the %replacement and %reimpl M ext/POSIX/lib/POSIX.pm ----------------------------------------------------------------------- Summary of changes: ext/POSIX/POSIX.xs | 26 --------- ext/POSIX/lib/POSIX.pm | 139 ++++++++++++++++++++++++-------------------- ext/POSIX/lib/POSIX.pod | 6 +- ext/POSIX/t/posix.t | 23 +++----- ext/POSIX/t/unimplemented.t | 5 +- 5 files changed, 88 insertions(+), 111 deletions(-) diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index 281bea8..f825e29 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -3241,32 +3241,6 @@ write(fd, buffer, nbytes) char * buffer size_t nbytes -SV * -tmpnam() - PREINIT: - STRLEN i; - int len; - CODE: - RETVAL = newSVpvs(""); - SvGROW(RETVAL, L_tmpnam); - /* Yes, we know tmpnam() is bad. So bad that some compilers - * and linkers warn against using it. But it is here for - * completeness. POSIX.pod warns against using it. - * - * Then again, maybe this should be removed at some point. - * No point in enabling dangerous interfaces. */ - if (ckWARN_d(WARN_DEPRECATED)) { - HV *warned = get_hv("POSIX::_warned", GV_ADD | GV_ADDMULTI); - if (! hv_exists(warned, (const char *)&PL_op, sizeof(PL_op))) { - Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Calling POSIX::tmpnam() is deprecated"); - (void)hv_store(warned, (const char *)&PL_op, sizeof(PL_op), &PL_sv_yes, 0); - } - } - len = strlen(tmpnam(SvPV(RETVAL, i))); - SvCUR_set(RETVAL, len); - OUTPUT: - RETVAL - void abort() diff --git a/ext/POSIX/lib/POSIX.pm b/ext/POSIX/lib/POSIX.pm index 05bdbbe..fcaf298 100644 --- a/ext/POSIX/lib/POSIX.pm +++ b/ext/POSIX/lib/POSIX.pm @@ -4,7 +4,7 @@ use warnings; our ($AUTOLOAD, %SIGRT); -our $VERSION = '1.65'; +our $VERSION = '1.68'; require XSLoader; @@ -18,18 +18,6 @@ use Fcntl qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK F_SETFD my $loaded; -sub import { - my $pkg = shift; - - load_imports() unless $loaded++; - - # Grandfather old foo_h form to new :foo_h form - s/^(?=\w+_h$)/:/ for my @list = @_; - - local $Exporter::ExportLevel = 1; - Exporter::import($pkg,@list); -} - sub croak { require Carp; goto &Carp::croak } sub usage { croak "Usage: POSIX::$_[0]" } @@ -110,6 +98,7 @@ my %replacement = ( strspn => undef, strtok => undef, tmpfile => 'IO::File::new_tmpfile', + tmpnam => 'use File::Temp', ungetc => 'IO::Handle::ungetc', vfprintf => undef, vprintf => undef, @@ -117,74 +106,105 @@ my %replacement = ( ); my %reimpl = ( + abs => 'x => CORE::abs($_[0])', + alarm => 'seconds => CORE::alarm($_[0])', assert => 'expr => croak "Assertion failed" if !$_[0]', - tolower => 'string => lc($_[0])', - toupper => 'string => uc($_[0])', - closedir => 'dirhandle => CORE::closedir($_[0])', - opendir => 'directory => my $dh; CORE::opendir($dh, $_[0]) ? $dh : undef', - readdir => 'dirhandle => CORE::readdir($_[0])', - rewinddir => 'dirhandle => CORE::rewinddir($_[0])', - errno => '$! + 0', - creat => 'filename, mode => &open($_[0], &O_WRONLY | &O_CREAT | &O_TRUNC, $_[1])', - fcntl => 'filehandle, cmd, arg => CORE::fcntl($_[0], $_[1], $_[2])', - getgrgid => 'gid => CORE::getgrgid($_[0])', - getgrnam => 'name => CORE::getgrnam($_[0])', atan2 => 'x, y => CORE::atan2($_[0], $_[1])', + chdir => 'directory => CORE::chdir($_[0])', + chmod => 'mode, filename => CORE::chmod($_[0], $_[1])', + chown => 'uid, gid, filename => CORE::chown($_[0], $_[1], $_[2])', + closedir => 'dirhandle => CORE::closedir($_[0])', cos => 'x => CORE::cos($_[0])', + creat => 'filename, mode => &open($_[0], &O_WRONLY | &O_CREAT | &O_TRUNC, $_[1])', + errno => '$! + 0', + exit => 'status => CORE::exit($_[0])', exp => 'x => CORE::exp($_[0])', fabs => 'x => CORE::abs($_[0])', - log => 'x => CORE::log($_[0])', - pow => 'x, exponent => $_[0] ** $_[1]', - sin => 'x => CORE::sin($_[0])', - sqrt => 'x => CORE::sqrt($_[0])', - getpwnam => 'name => CORE::getpwnam($_[0])', - getpwuid => 'uid => CORE::getpwuid($_[0])', - kill => 'pid, sig => CORE::kill $_[1], $_[0]', - raise => 'sig => CORE::kill $_[0], $$; # Is this good enough', + fcntl => 'filehandle, cmd, arg => CORE::fcntl($_[0], $_[1], $_[2])', + fork => 'CORE::fork', + fstat => 'fd => CORE::open my $dup, "<&", $_[0]; CORE::stat($dup)', # Gross. getc => 'handle => CORE::getc($_[0])', getchar => 'CORE::getc(STDIN)', - gets => 'scalar <STDIN>', - remove => 'filename => (-d $_[0]) ? CORE::rmdir($_[0]) : CORE::unlink($_[0])', - rename => 'oldfilename, newfilename => CORE::rename($_[0], $_[1])', - rewind => 'filehandle => CORE::seek($_[0],0,0)', - abs => 'x => CORE::abs($_[0])', - exit => 'status => CORE::exit($_[0])', - getenv => 'name => $ENV{$_[0]}', - system => 'command => CORE::system($_[0])', - strerror => 'errno => BEGIN { local $!; require locale; locale->import} my $e = $_[0] + 0; local $!; $! = $e; "$!"', - strstr => 'big, little => CORE::index($_[0], $_[1])', - chmod => 'mode, filename => CORE::chmod($_[0], $_[1])', - fstat => 'fd => CORE::open my $dup, "<&", $_[0]; CORE::stat($dup)', # Gross. - mkdir => 'directoryname, mode => CORE::mkdir($_[0], $_[1])', - stat => 'filename => CORE::stat($_[0])', - umask => 'mask => CORE::umask($_[0])', - wait => 'CORE::wait()', - waitpid => 'pid, options => CORE::waitpid($_[0], $_[1])', - gmtime => 'time => CORE::gmtime($_[0])', - localtime => 'time => CORE::localtime($_[0])', - time => 'CORE::time', - alarm => 'seconds => CORE::alarm($_[0])', - chdir => 'directory => CORE::chdir($_[0])', - chown => 'uid, gid, filename => CORE::chown($_[0], $_[1], $_[2])', - fork => 'CORE::fork', getegid => '$) + 0', + getenv => 'name => $ENV{$_[0]}', geteuid => '$> + 0', getgid => '$( + 0', + getgrgid => 'gid => CORE::getgrgid($_[0])', + getgrnam => 'name => CORE::getgrnam($_[0])', getgroups => 'my %seen; grep !$seen{$_}++, split " ", $)', getlogin => 'CORE::getlogin()', getpgrp => 'CORE::getpgrp', getpid => '$$', getppid => 'CORE::getppid', + getpwnam => 'name => CORE::getpwnam($_[0])', + getpwuid => 'uid => CORE::getpwuid($_[0])', + gets => 'scalar <STDIN>', getuid => '$<', + gmtime => 'time => CORE::gmtime($_[0])', isatty => 'filehandle => -t $_[0]', + kill => 'pid, sig => CORE::kill $_[1], $_[0]', link => 'oldfilename, newfilename => CORE::link($_[0], $_[1])', + localtime => 'time => CORE::localtime($_[0])', + log => 'x => CORE::log($_[0])', + mkdir => 'directoryname, mode => CORE::mkdir($_[0], $_[1])', + opendir => 'directory => my $dh; CORE::opendir($dh, $_[0]) ? $dh : undef', + pow => 'x, exponent => $_[0] ** $_[1]', + raise => 'sig => CORE::kill $_[0], $$; # Is this good enough', + readdir => 'dirhandle => CORE::readdir($_[0])', + remove => 'filename => (-d $_[0]) ? CORE::rmdir($_[0]) : CORE::unlink($_[0])', + rename => 'oldfilename, newfilename => CORE::rename($_[0], $_[1])', + rewind => 'filehandle => CORE::seek($_[0],0,0)', + rewinddir => 'dirhandle => CORE::rewinddir($_[0])', rmdir => 'directoryname => CORE::rmdir($_[0])', + sin => 'x => CORE::sin($_[0])', + sqrt => 'x => CORE::sqrt($_[0])', + stat => 'filename => CORE::stat($_[0])', + strerror => 'errno => BEGIN { local $!; require locale; locale->import} my $e = $_[0] + 0; local $!; $! = $e; "$!"', + strstr => 'big, little => CORE::index($_[0], $_[1])', + system => 'command => CORE::system($_[0])', + time => 'CORE::time', + tolower => 'string => lc($_[0])', + toupper => 'string => uc($_[0])', + umask => 'mask => CORE::umask($_[0])', unlink => 'filename => CORE::unlink($_[0])', utime => 'filename, atime, mtime => CORE::utime($_[1], $_[2], $_[0])', + wait => 'CORE::wait()', + waitpid => 'pid, options => CORE::waitpid($_[0], $_[1])', ); +sub import { + my $pkg = shift; + + load_imports() unless $loaded++; + + # Grandfather old foo_h form to new :foo_h form + s/^(?=\w+_h$)/:/ for my @list = @_; + + my @unimpl = sort grep { exists $replacement{$_} } @list; + if (@unimpl) { + for my $u (@unimpl) { + warn "Unimplemented: POSIX::$u(): ", unimplemented_message($u); + } + croak(sprintf("Unimplemented: %s", + join(" ", map { "POSIX::$_()" } @unimpl))); + } + + local $Exporter::ExportLevel = 1; + Exporter::import($pkg,@list); +} + eval join ';', map "sub $_", keys %replacement, keys %reimpl; +sub unimplemented_message { + my $func = shift; + my $how = $replacement{$func}; + return "C-specific, stopped" unless defined $how; + return "$$how" if ref $how; + return "$how instead" if $how =~ /^use /; + return "Use method $how() instead" if $how =~ /::/; + return "C-specific: use $how instead"; +} + sub AUTOLOAD { my ($func) = ($AUTOLOAD =~ /.*::(.*)/); @@ -207,12 +227,7 @@ sub AUTOLOAD { goto &$AUTOLOAD; } if (exists $replacement{$func}) { - my $how = $replacement{$func}; - croak "Unimplemented: POSIX::$func() is C-specific, stopped" - unless defined $how; - croak "Unimplemented: POSIX::$func() is $$how" if ref $how; - croak "Use method $how() instead of POSIX::$func()" if $how =~ /::/; - croak "Unimplemented: POSIX::$func() is C-specific: use $how instead"; + croak "Unimplemented: POSIX::$func(): ", unimplemented_message($func); } constant($func); diff --git a/ext/POSIX/lib/POSIX.pod b/ext/POSIX/lib/POSIX.pod index 840f04b..e903acc 100644 --- a/ext/POSIX/lib/POSIX.pod +++ b/ext/POSIX/lib/POSIX.pod @@ -1949,13 +1949,9 @@ Not implemented. Use method C<IO::File::new_tmpfile()> instead, or see L<File:: =item C<tmpnam> -Returns a name for a temporary file. - - $tmpfile = POSIX::tmpnam(); - For security reasons, which are probably detailed in your system's documentation for the C library C<tmpnam()> function, this interface -should not be used; instead see L<File::Temp>. +is no more available; instead use L<File::Temp>. =item C<tolower> diff --git a/ext/POSIX/t/posix.t b/ext/POSIX/t/posix.t index bd5c300..ea43bc0 100644 --- a/ext/POSIX/t/posix.t +++ b/ext/POSIX/t/posix.t @@ -10,7 +10,7 @@ BEGIN { require 'loc_tools.pl'; } -use Test::More tests => 94; +use Test::More tests => 93; use POSIX qw(fcntl_h signal_h limits_h _exit getcwd open read strftime write errno localeconv dup dup2 lseek access); @@ -299,13 +299,13 @@ like ($@, qr/^Usage: POSIX::kill\(pid, sig\)/, "check its usage message"); # Check unimplemented. $result = eval {POSIX::offsetof}; is ($result, undef, "offsetof should fail"); -like ($@, qr/^Unimplemented: POSIX::offsetof\(\) is C-specific/, +like ($@, qr/^Unimplemented: POSIX::offsetof\(\): C-specific/, "check its unimplemented message"); # Check reimplemented. $result = eval {POSIX::fgets}; is ($result, undef, "fgets should fail"); -like ($@, qr/^Use method IO::Handle::gets\(\) instead/, +like ($@, qr/^Unimplemented: POSIX::fgets\(\): Use method IO::Handle::gets\(\) instead/, "check its redef message"); eval { use strict; POSIX->import("S_ISBLK"); my $x = S_ISBLK }; @@ -402,19 +402,10 @@ SKIP: { cmp_ok($!, '==', POSIX::ENOTDIR); } -{ # tmpnam() is deprecated - my @warn; - local $SIG{__WARN__} = sub { push @warn, "@_"; note "@_"; }; - my $x = sub { POSIX::tmpnam() }; - my $foo = $x->(); - $foo = $x->(); - is(@warn, 1, "POSIX::tmpnam() should warn only once per location"); - like($warn[0], qr!^Calling POSIX::tmpnam\(\) is deprecated at t/posix.t line \d+\.$!, - "check POSIX::tmpnam warns by default"); - no warnings "deprecated"; - undef $warn; - my $foo = POSIX::tmpnam(); - is($warn, undef, "... but the warning can be disabled"); +{ # tmpnam() has been removed as unsafe + my $x = eval { POSIX::tmpnam() }; + is($x, undef, 'tmpnam has been removed'); + like($@, qr/use File::Temp/, 'tmpnam advises File::Temp'); } # Check that output is not flushed by _exit. This test should be last diff --git a/ext/POSIX/t/unimplemented.t b/ext/POSIX/t/unimplemented.t index 2d8f819..9a03a75 100644 --- a/ext/POSIX/t/unimplemented.t +++ b/ext/POSIX/t/unimplemented.t @@ -83,6 +83,7 @@ foreach ([atexit => 'C-specific: use END {} instead'], [strspn => 'C-specific, stopped'], [strtok => 'C-specific, stopped'], [tmpfile => \'IO::File::new_tmpfile'], + [tmpnam => \'use File::Temp'], [ungetc => \'IO::Handle::ungetc'], [vfprintf => 'C-specific, stopped'], [vprintf => 'C-specific, stopped'], @@ -90,8 +91,8 @@ foreach ([atexit => 'C-specific: use END {} instead'], ) { my ($func, $action) = @$_; my $expect = ref $action - ? qr/Use method $$action\(\) instead of POSIX::$func\(\) at \(eval/ - : qr/Unimplemented: POSIX::$func\(\) is \Q$action\E at \(eval/; + ? qr/Unimplemented: POSIX::$func\(\): .*$$action(?:\(\))? instead at \(eval/ + : qr/Unimplemented: POSIX::$func\(\): \Q$action\E at \(eval/; is(eval "POSIX::$func(); 1", undef, "POSIX::$func fails as expected"); like($@, $expect, "POSIX::$func gives expected error message"); } -- Perl5 Master Repository
