diff options
Diffstat (limited to 'gnu/usr.bin/perl/ext')
218 files changed, 11530 insertions, 4085 deletions
diff --git a/gnu/usr.bin/perl/ext/Amiga-ARexx/ARexx.pm b/gnu/usr.bin/perl/ext/Amiga-ARexx/ARexx.pm new file mode 100644 index 00000000000..44057680f30 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Amiga-ARexx/ARexx.pm @@ -0,0 +1,355 @@ +package Amiga::ARexx; + +use 5.016000; +use strict; +use warnings; +use Carp; + +require Exporter; +#use AutoLoader; + +our @ISA = qw(Exporter); + +# Items to export into callers namespace by default. Note: do not export +# names by default without a very good reason. Use EXPORT_OK instead. +# Do not simply export all your public functions/methods/constants. + +# This allows declaration use Amiga::Classes::ARexx ':all'; +# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK +# will save memory. +our %EXPORT_TAGS = ( 'all' => [ qw( +DoRexx +) ] ); + +our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); + +our @EXPORT = qw( +); + +our $VERSION = '0.04'; + +require XSLoader; +XSLoader::load('Amiga::ARexx', $VERSION); + +sub new +{ + my $class = shift; + my $self = bless {}, $class; + return $self->__init(@_); +} + +sub __init +{ + my $self = shift; + my %params = @_; + my @tags = (); + + if(exists $params{'HostName'}) + { + $self->{'__hostname'} = $params{'HostName'}; + } else { croak "HostName required";} + + $self->{'__host'} = Amiga::ARexx::Host_init($self->{'__hostname'}); + if (defined $self->{'__host'} && $self->{'__host'} != 0) + { + } + else + { + croak "Unabel to initialise Arexx Host"; + } + return $self; +} + +sub wait +{ + my $self = shift; + my %params = @_; + my $timeout = -1; + if ((exists $params{'TimeOut'}) && (defined $params{'TimeOut'})) + { + $timeout = $params{'TimeOut'}; + $timeout += 0; # force number + } + Amiga::ARexx::Host_wait($self->{'__host'},$timeout); + +} + +sub signal +{ + my $self = shift; + return Amiga::ARexx::Host_signal($self->{'__host'}); +} + +sub getmsg +{ + my $self = shift; + my $msg; + my $msgobj; + + if(defined $self->{'__host'}) + { + $msg = Amiga::ARexx::Host_getmsg($self->{'__host'}); + if($msg) + { + $msgobj = Amiga::ARexx::Msg->new('Message' => $msg); + } + } + return $msgobj; +} + +sub DESTROY +{ + my $self = shift; + if(exists $self->{'__host'} && defined $self->{'__host'}) + { + Amiga::ARexx::Host_delete($self->{'__host'}); + delete $self->{'__host'}; + } +} + +sub DoRexx($$) +{ + my ($port,$command) = @_; + my $rc = 0; + my $rc2 = 0; + my $result = Amiga::ARexx::_DoRexx($port,$command,$rc,$rc2); + return ($rc,$rc2,$result); +} + +package Amiga::ARexx::Msg; + +use strict; +use warnings; +use Carp; + +sub new +{ + my $class = shift; + my $self = bless {}, $class; + return $self->__init(@_); +} + +sub __init +{ + my $self = shift; + my %params = @_; + + if(exists $params{'Message'}) + { + $self->{'__msg'} = $params{'Message'}; + } else { croak "Message required";} + + $self->{'__message'} = Amiga::ARexx::Msg_argstr($self->{'__msg'}); + return $self; +} + +sub message +{ + my $self = shift; + return $self->{'__message'}; +} + +sub reply($$$$) +{ + my ($self,$rc,$rc2,$result) = @_; + if(exists $self->{'__msg'} && defined $self->{'__msg'}) + { + Amiga::ARexx::Msg_reply($self->{'__msg'},$rc,$rc2,$result); + } +} + +sub setvar($$$) +{ + my ($self,$varname,$value) = @_; + if(exists $self->{'__msg'} && defined $self->{'__msg'}) + { + Amiga::ARexx::Msg_setvar($self->{'__msg'},$varname,$value); + } +} + +sub getvar($$) +{ + my ($self,$varname) = @_; + if(exists $self->{'__msg'} && defined $self->{'__msg'}) + { + return Amiga::ARexx::Msg_getvar($self->{'__msg'},$varname); + } +} + +sub DESTROY +{ + my $self = shift; + if(exists $self->{'__msg'} && defined $self->{'__msg'}) + { + Amiga::ARexx::Msg_delete($self->{'__msg'}); + delete $self->{'__msg'}; + } +} + +# Preloaded methods go here. + +# Autoload methods go after =cut, and are processed by the autosplit program. + +1; +__END__ +# Below is stub documentation for your module. You'd better edit it! + +=head1 NAME + +Amiga::ARexx - Perl extension for ARexx support + +=head1 ABSTRACT + +This a perl class / module to enable you to use ARexx with +your perlscript. Creating a function host or executing scripts in other hosts. +The API is loosley modeled on the python arexx module supplied by with AmigaOS4.1 + +=head1 SYNOPSIS + + # Create a new host + + use Amiga::ARexx; + my $host = Amiga::ARexx->new('HostName' => "PERLREXX" ); + + # Wait for and process rexxcommands + + my $alive = 1; + + while ($alive) + { + $host->wait(); + my $msg = $host->getmsg(); + while($msg) + { + my $rc = 0; + my $rc2 = 0; + my $result = ""; + + print $msg->message . "\n"; + given($msg->message) + { + when ("QUIT") + { + $alive = 0; + $result = "quitting!"; + } + default { + $rc = 10; + $rc2 = 22; + } + } + $msg->reply($rc,$rc2,$result); + + $msg = $host->getmsg(); + } + + } + + # Send a command to a host + + my $port = "SOMEHOST"; + my $command = "SOMECOMMAND"; + my ($rc,$rc2,$result) = Amiga::ARexx->DoRexx($port,$command); + + + +=head1 DESCRIPTION + +The interface to the arexx.class in entirely encapsulated within the perl class, there +is no need to access the low level methods directly and they are not exported by default. + +=head1 Amiga::ARexx METHODS + +=head2 new + + my $host = Amiga::ARexx->new( HostName => "PERLREXX"); + + +Create an ARexx host for your script / program. + +=head3 HostName + +The HostName for the hosts command port. This is madatory, the program will fail if not +provided. + + +=head2 wait + + $host->wait('TimeOut' => $timeoutinusecs ); + +Wait for a message to arive at the port. + +=head3 TimeOut + +optional time out in microseconds. + + +=head2 getmsg + + $msg = $host->getmsg(); + + +Fetch an ARexx message from the host port. Returns an objrct of class Amiga::ARexx::Msg + +=head2 signal + + $signal = $host->signal() + +Retrieve the signal mask for the host port for use with Amiga::Exec Wait() + +=head2 DoRexx + + ($rc,$rc2,$result) = DoRexx("desthost","commandstring"); + +Send the "commandstring" to host "desthost" for execution. Commandstring might be a specific command or scriptname. + +=head1 Amiga::ARexx::Msg METHODS + +=head2 message + + $m = $msg->message(); + +Retreive the message "command" as a string; + + +=head2 reply + + $msg->reply($rc,$rc2,$result) + +Reply the message returning the results of any command. Set $rc = 0 for success and $result to the result string if appropriate. + +Set $rc to non zero for error and $rc2 for an additional error code if appropriate. + +=head2 setvar + + $msg->setvar($varname,$value) + +Set a variable in the language context sending this message. + +=head2 getvar + + $value = $msg->getvar($varname) + +Get the value of a variable in the language context sending this message. + + +=head2 EXPORT + +None by default. + +=head2 Exportable constants + +None + +=head1 AUTHOR + +Andy Broad <andy@broad.ology.org.uk> + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2013 by Andy Broad. + +=cut + + + diff --git a/gnu/usr.bin/perl/ext/Amiga-ARexx/ARexx.xs b/gnu/usr.bin/perl/ext/Amiga-ARexx/ARexx.xs new file mode 100644 index 00000000000..5854b27e1a8 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Amiga-ARexx/ARexx.xs @@ -0,0 +1,540 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#undef __USE_INLINE__ +#include <exec/types.h> +#include <utility/tagitem.h> +#include <proto/exec.h> +#include <proto/intuition.h> +#include <proto/rexxsyslib.h> +#include <proto/utility.h> + +#include <rexx/rxslib.h> +#include <rexx/errors.h> +//#include "rexxmsgext.h" // this should change depening on the ultimate location of the structures + +/* utils */ + +/* + * Structure for the rexx host. Most of the code is inspired from Olaf + * Barthel's sample ARexx code from the developer CD 2.1 + */ + + +struct RexxHost +{ + struct MsgPort *Port; + TEXT PortName[81]; +} ; + +struct ARexxMsg +{ + struct RexxMsg *rexxMsg; + BOOL isReplied; + struct RexxHost *rexxHost; +}; + +STRPTR dupstr(STRPTR src) +{ + STRPTR dest = NULL; + ULONG len; + if(src) + { + len = strlen(src); + if((dest = IExec->AllocVec(len + 1, MEMF_ANY))) + { + strcpy(dest,src); + } + } + return dest; +} + + +struct TimeRequest * +OpenTimer(void) +{ + struct MsgPort *port = IExec->AllocSysObjectTags(ASOT_PORT, TAG_END); + if (port == NULL) + { + return NULL; + } + + struct TimeRequest *req = IExec->AllocSysObjectTags(ASOT_IOREQUEST, + ASOIOR_Size, sizeof(struct TimeRequest), + ASOIOR_ReplyPort, port, + TAG_END); + + if (req == NULL) + { + IExec->FreeSysObject(ASOT_PORT, port); + return NULL; + } + + int8 deverr = IExec->OpenDevice("timer.device", UNIT_MICROHZ, + &req->Request, 0); + + if (deverr != IOERR_SUCCESS) + { + IExec->FreeSysObject(ASOT_IOREQUEST, req); + IExec->FreeSysObject(ASOT_PORT, port); + return NULL; + } + + return req; +} + + +void +CloseTimer(struct TimeRequest *req) +{ + if (req != NULL) + { + struct MsgPort *port = req->Request.io_Message.mn_ReplyPort; + + IExec->CloseDevice(&req->Request); + IExec->FreeSysObject(ASOT_IOREQUEST, req); + IExec->FreeSysObject(ASOT_PORT, port); + } +} + +LONG +ReturnRexxMsg(struct RexxMsg * Message, CONST_STRPTR Result) +{ + STRPTR ResultString = NULL; + + /* No error has occured yet. */ + int32 ErrorCode = 0; + + /* Set up the RexxMsg to return no error. */ + Message->rm_Result1 = RC_OK; + Message->rm_Result2 = 0; + + /* Check if the command should return a result. */ + if((Message->rm_Action & RXFF_RESULT) && Result != NULL) + { + /* To return the result string we need to make + * a copy for ARexx to use. + */ + if((ResultString = IRexxSys->CreateArgstring(Result, strlen(Result)))) + { + /* Put the string into the secondary + * result field. + */ + Message->rm_Result2 = (LONG)ResultString; + } + else + { + /* No memory available. */ + ErrorCode = ERR10_003; + } + } + + /* Reply the message, regardless of the error code. */ + IExec->ReplyMsg((struct Message *)Message); + + return(ErrorCode); +} + + +void +ReturnErrorMsg(struct RexxMsg *msg, CONST_STRPTR port, int32 rc, int32 rc2) +{ + /* To signal an error the rc_Result1 + * entry of the RexxMsg needs to be set to + * RC_ERROR. Unfortunately, we cannot convey + * the more meaningful error code through + * this interface which is why we set a + * Rexx variable to the error number. The + * Rexx script can then take a look at this + * variable and decide which further steps + * it should take. + */ + msg->rm_Result1 = rc; + msg->rm_Result2 = rc2; + + /* Turn the error number into a string as + * ARexx only deals with strings. + */ + char value[12]; + IUtility->SNPrintf(value, sizeof(value), "%ld", rc2); + + /* Build the name of the variable to set to + * the error number. We will use the name of + * the host name and append ".LASTERROR". + */ + IRexxSys->SetRexxVarFromMsg("RC2", value, msg); + + IExec->ReplyMsg(&msg->rm_Node); +} + +BOOL +PutMsgTo(CONST_STRPTR name, struct Message *msg) +{ + BOOL done = FALSE; + + IExec->Forbid(); + + struct MsgPort *port = IExec->FindPort(name); + if (port != NULL) + { + IExec->PutMsg(port, msg); + done = TRUE; + } + + IExec->Permit(); + + return done; +} + + +STRPTR DoRexx(STRPTR port, STRPTR command, int32 *rc, int32 *rc2) +{ + *rc = 0; + *rc2 = 0; + STRPTR result = NULL; + STRPTR dup = NULL; + + struct MsgPort *replyPort = IExec->AllocSysObjectTags(ASOT_PORT, TAG_END); + if (replyPort == NULL) + { + return NULL; + } + + struct RexxMsg *rexxMsg = IRexxSys->CreateRexxMsg(replyPort, NULL, NULL); + ((struct Node *)rexxMsg)->ln_Name = "REXX"; + if (rexxMsg == NULL) + { + IExec->FreeSysObject(ASOT_PORT, replyPort); + return NULL; + } + BOOL sent = FALSE; + + + rexxMsg->rm_Args[0] = IRexxSys->CreateArgstring(command, strlen(command)); + + if (rexxMsg->rm_Args[0] != NULL) + { + rexxMsg->rm_Action = RXCOMM | RXFF_RESULT | RXFF_STRING; + + sent = PutMsgTo(port, (struct Message*)rexxMsg); + + if (sent) + { + IExec->WaitPort(replyPort); + (void)IExec->GetMsg(replyPort); + } + else + { + + } + + *rc = rexxMsg->rm_Result1; + + if (*rc == RC_OK) + { + if (rexxMsg->rm_Result2 != 0) + { + result = (STRPTR)rexxMsg->rm_Result2; + } + } + else + { + *rc2 = rexxMsg->rm_Result2; + } + + IRexxSys->DeleteArgstring(rexxMsg->rm_Args[0]); + rexxMsg->rm_Args[0] = NULL; + } + + IRexxSys->DeleteRexxMsg(rexxMsg); + rexxMsg = NULL; + + IExec->FreeSysObject(ASOT_PORT, replyPort); + replyPort = NULL; + + if (result != NULL) + { + dup = dupstr(result); + + IRexxSys->DeleteArgstring(result); + result = NULL; + } + + return dup; +} + + +struct RexxHost *CreateRexxHost(CONST_STRPTR PortName) +{ + struct RexxHost *newHost = IExec->AllocVecTags(sizeof(struct RexxHost), + AVT_Type, MEMF_PRIVATE, AVT_ClearWithValue, 0, TAG_DONE); + + if (newHost == NULL) + { + return NULL; + } + + IUtility->Strlcpy(newHost->PortName, PortName, sizeof(newHost->PortName)); + + IExec->Forbid(); + + /* Check if the name already exists */ + if (IExec->FindPort(PortName) != NULL) + { + int32 index = 1; + do + { + IUtility->SNPrintf(newHost->PortName, sizeof(newHost->PortName), "%s.%ld", PortName, index); + index++; + + if (IExec->FindPort(newHost->PortName) == NULL) + { + break; + } + } while (1); + } + + newHost->Port = IExec->AllocSysObjectTags(ASOT_PORT, + ASOPORT_Name, newHost->PortName, + ASOPORT_Public, TRUE, + TAG_DONE); + + IExec->Permit(); + + if (newHost->Port == NULL) + { + IExec->FreeVec(newHost); + return NULL; + } + + return newHost; +} + + +void DeleteRexxHost(struct RexxHost *host) +{ + if (host) + { + if (host->Port) + { + struct RexxMsg *msg; + + IExec->Forbid(); + while ((msg = (struct RexxMsg *)IExec->GetMsg(host->Port)) != NULL) + { + msg->rm_Result1 = RC_FATAL; + IExec->ReplyMsg((struct Message *)msg); + } + + IExec->FreeSysObject(ASOT_PORT, host->Port); + IExec->Permit(); + } + + IExec->FreeVec(host); + } +} + +void WaitRexxHost(struct RexxHost *rexxHost, int timeout) +{ + + struct TimeRequest *req = NULL; + uint32 timermask = 0; + + if (timeout > 0) + { + req = OpenTimer(); + + if (req != NULL) + { + timermask = 1L << req->Request.io_Message.mn_ReplyPort->mp_SigBit; + + req->Request.io_Command = TR_ADDREQUEST; + req->Time.Seconds = 0; + req->Time.Microseconds = timeout; + + IExec->SendIO(&req->Request); + } + } + + uint32 hostmask = 1L << rexxHost->Port->mp_SigBit; + uint32 waitmask = timermask | hostmask | SIGBREAKF_CTRL_C; + + uint32 sigmask = IExec->Wait(waitmask); + + if (req != NULL) + { + IExec->AbortIO(&req->Request); + IExec->WaitIO(&req->Request); + CloseTimer(req); + } + + if (sigmask & SIGBREAKF_CTRL_C) + { + return; + } + + +} + +struct ARexxMsg *GetMsgRexxHost(struct RexxHost *rexxHost) +{ + struct ARexxMsg *am = NULL; + + struct RexxMsg *rexxMsg = NULL; + + rexxMsg = (struct RexxMsg *)IExec->GetMsg(rexxHost->Port); + if (rexxMsg != NULL) + { + if((am = IExec->AllocVecTags(sizeof(struct ARexxMsg),AVT_Type, MEMF_PRIVATE, AVT_ClearWithValue, 0, TAG_DONE))) + { + am->rexxMsg = rexxMsg; + am->rexxHost = rexxHost; + am->isReplied = FALSE; + } + + } + return am; +} + +uint32 GetSignalRexxHost(struct RexxHost *rexxHost) +{ + return rexxHost->Port->mp_SigBit; +} + + +void ReplyARexxMsg(struct ARexxMsg *am, int rc, int rc2, STRPTR result) +{ + if(am) + { + if(!am->isReplied) + { + if(rc == 0) + { + ReturnRexxMsg(am->rexxMsg, result); + } + else + { + ReturnErrorMsg(am->rexxMsg, am->rexxHost->PortName,rc,rc2); + } + am->isReplied = TRUE; + } + } +} + +STRPTR GetVarARexxMsg(struct ARexxMsg *am, STRPTR varname) +{ + STRPTR result = IExec->AllocVecTags(256,AVT_Type, MEMF_PRIVATE, AVT_ClearWithValue, 0, TAG_DONE); + if(result) + { + IRexxSys->GetRexxVarFromMsg(varname, result, am->rexxMsg); + } + return result; +} + +void SetVarARexxMsg(struct ARexxMsg *am, STRPTR varname, STRPTR value) +{ + IRexxSys->SetRexxVarFromMsg(varname, value, am->rexxMsg); +} + +void DeleteARexxMsg(struct ARexxMsg *am) +{ + if(!am->isReplied) + { + IExec->ReplyMsg(&am->rexxMsg->rm_Node); + am->isReplied = TRUE; + } + IExec->FreeVec(am); +} + +STRPTR GetArgsARexxMsg(struct ARexxMsg *am) +{ + return am->rexxMsg->rm_Args[0]; +} + +MODULE = Amiga::ARexx PACKAGE = Amiga::ARexx + +PROTOTYPES: DISABLE + + +APTR Host_init(name) + STRPTR name; + CODE: + RETVAL = CreateRexxHost(name); + OUTPUT: + RETVAL + +void Host_delete(rexxhost) + APTR rexxhost; + CODE: + DeleteRexxHost(rexxhost); + +void Host_wait(rexxhost,timeout) + APTR rexxhost + int timeout + CODE: + WaitRexxHost(rexxhost,timeout); + +uint32 Host_signal(rexxhost) + APTR rexxhost + CODE: + RETVAL = GetSignalRexxHost(rexxhost); + OUTPUT: + RETVAL + +APTR Host_getmsg(rexxhost) + APTR rexxhost + CODE: + RETVAL = GetMsgRexxHost(rexxhost); + OUTPUT: + RETVAL + +void Msg_reply(rexxmsg,rc,rc2,result) + APTR rexxmsg + int rc + int rc2 + STRPTR result + CODE: + ReplyARexxMsg(rexxmsg,rc,rc2,result); + +void Msg_delete(rexxmsg) + APTR rexxmsg + CODE: + DeleteARexxMsg(rexxmsg); + +STRPTR Msg_argstr(rexxmsg) + APTR rexxmsg + CODE: + RETVAL = GetArgsARexxMsg(rexxmsg); + OUTPUT: + RETVAL + +STRPTR Msg_getvar(rexxmsg,varname) + APTR rexxmsg + STRPTR varname + PPCODE: + RETVAL = GetVarARexxMsg(rexxmsg,varname); + sv_setpv(TARG, RETVAL); XSprePUSH; PUSHTARG; + if (RETVAL) IExec->FreeVec(RETVAL); + +void Msg_setvar(rexxmsg,varname,value) + APTR rexxmsg + STRPTR varname + STRPTR value + CODE: + SetVarARexxMsg(rexxmsg,varname,value); + +STRPTR _DoRexx(port,command,rc,rc2) + STRPTR port + STRPTR command + int32 &rc + int32 &rc2 + PPCODE: + RETVAL = DoRexx(port,command,&rc,&rc2); + sv_setiv(ST(2), (IV)rc); + SvSETMAGIC(ST(2)); + sv_setiv(ST(3), (IV)rc2); + SvSETMAGIC(ST(3)); + sv_setpv(TARG, RETVAL); XSprePUSH; PUSHTARG; + IExec->FreeVec(RETVAL); + diff --git a/gnu/usr.bin/perl/ext/Amiga-ARexx/Makefile.PL b/gnu/usr.bin/perl/ext/Amiga-ARexx/Makefile.PL new file mode 100644 index 00000000000..0d55bb31bab --- /dev/null +++ b/gnu/usr.bin/perl/ext/Amiga-ARexx/Makefile.PL @@ -0,0 +1,17 @@ +use 5.008005; +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. +WriteMakefile( + NAME => 'Amiga::ARexx', + VERSION_FROM => 'ARexx.pm', # finds $VERSION + PREREQ_PM => {}, # e.g., Module::Name => 1.1 + ($] >= 5.005 ? ## Add these new keywords supported since 5.005 + (ABSTRACT_FROM => 'ARexx.pm', # retrieve abstract from module + AUTHOR => 'A R Broad <andy@broad.ology.org.uk>') : ()), + LIBS => ['-lauto -lraauto'], # e.g., '-lm' + DEFINE => '', # e.g., '-DHAVE_SOMETHING' + INC => '-I.', # e.g., '-I. -I/usr/include/other' + # Un-comment this if you add C files to link with later: + # OBJECT => '$(O_FILES)', # link all the C files too +); diff --git a/gnu/usr.bin/perl/ext/Amiga-ARexx/__examples/simplecommand.pl b/gnu/usr.bin/perl/ext/Amiga-ARexx/__examples/simplecommand.pl new file mode 100644 index 00000000000..85d447bb8ab --- /dev/null +++ b/gnu/usr.bin/perl/ext/Amiga-ARexx/__examples/simplecommand.pl @@ -0,0 +1,14 @@ +#!perl + +use strict; +use warnings; + +use Amiga::ARexx qw(DoRexx); + +my ($result,$rc,$rc2) = DoRexx("WORKBENCH","HELP"); + +print $result , "\n" , $rc, "\n", $rc2 , "\n"; + +($result,$rc,$rc2) = DoRexx("WORKBENCH","NOHELP"); + +print $result , "\n" , $rc, "\n", $rc2 , "\n"; diff --git a/gnu/usr.bin/perl/ext/Amiga-ARexx/__examples/simplehost.pl b/gnu/usr.bin/perl/ext/Amiga-ARexx/__examples/simplehost.pl new file mode 100644 index 00000000000..df5ecd2ff4e --- /dev/null +++ b/gnu/usr.bin/perl/ext/Amiga-ARexx/__examples/simplehost.pl @@ -0,0 +1,46 @@ +#!perl + +# Simple ARExx Host + +use strict; +use Amiga::ARexx; +use feature "switch"; + +my $host = Amiga::ARexx->new('HostName' => "TESTSCRIPT"); + +my $alive = 1; + +while ($alive) +{ + $host->wait(); + my $msg = $host->getmsg(); + while($msg) + { + my $rc = 0; + my $rc2 = 0; + my $result = ""; + + print $msg->message . "\n"; + given($msg->message) + { + when ("QUIT") + { + $alive = 0; + $result = "quitting!"; + } + when ("SHOUT") + { + $result = "HEEELLLLOOOO!"; + } + default { + $rc = 10; + $rc2 = 22; + } + } + $msg->reply($rc,$rc2,$result); + + $msg = $host->getmsg(); + } + +} + diff --git a/gnu/usr.bin/perl/ext/Amiga-ARexx/tagtypes.h b/gnu/usr.bin/perl/ext/Amiga-ARexx/tagtypes.h new file mode 100644 index 00000000000..24a6218e758 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Amiga-ARexx/tagtypes.h @@ -0,0 +1,25 @@ +/* defines types for tags */ +#ifndef _TAGTYPES_H +#define _TAGTYPES_H + +#define TT_APTR 1 +#define TT_WORD 2 +#define TT_UWORD 3 +#define TT_LONG 4 +#define TT_ULONG 5 +#define TT_STRPTR 6 +#define TT_UBYTE 7 + +typedef union TagReturn +{ + WORD tr_word; + UWORD tr_uword; + LONG tr_long; + ULONG tr_ulong; + STRPTR tr_strptr; + APTR tr_aptr; + UBYTE * tr_ubyte; +} +TAGRET; + +#endif diff --git a/gnu/usr.bin/perl/ext/Amiga-ARexx/typemap b/gnu/usr.bin/perl/ext/Amiga-ARexx/typemap new file mode 100644 index 00000000000..644c1a5dd99 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Amiga-ARexx/typemap @@ -0,0 +1,118 @@ +APTR T_PTR +intArray * T_ARRAY +UWORD T_UV +ULONG T_UV +WORD T_IV +LONG T_IV +BOOL T_IV +TagList * T_TAGLIST +TAGRET T_TAGRET +STRPTR T_PV +int32 T_IV +uint32 T_UV + +############################################################################# +INPUT +T_TAGLIST + U32 ix_$var = $argoff; + U32 _tag_type; + /* allocate taglist struct, +2 as tags lists end in a TAG_DONE by tradition */ + /* if by some chance someone adds something after the TAG_DONE it will just*/ + /* result in harmless empty space */ + $var = $ntype((items -= $argoff) +2); + while(items > 0) + { + int __index = (ix_$var - $argoff)/3; + $var\[__index\].ti_Tag = (ULONG)SvUV(ST(ix_$var)); + ix_$var++; + items--; + /* the last is a tag_done and usualy has no followers so check for > 1 */ + if(items > 1 && ($var\[__index\].ti_Tag != TAG_DONE)) + { + _tag_type = (ULONG)SvUV(ST(ix_$var)); + ix_$var++; + switch(_tag_type) + { + case TT_APTR: + $var\[__index\].ti_Data = (ULONG)INT2PTR(APTR,SvIV(ST(ix_$var))); + break; + case TT_WORD: + $var\[__index\].ti_Data = (WORD)SvIV(ST(ix_$var)); + break; + case TT_LONG: + $var\[__index\].ti_Data = (LONG)SvIV(ST(ix_$var)); + break; + case TT_UWORD: + $var\[__index\].ti_Data = (UWORD)SvUV(ST(ix_$var)); + break; + case TT_ULONG: + $var\[__index\].ti_Data = (ULONG)SvUV(ST(ix_$var)); + break; + case TT_STRPTR: + case TT_UBYTE: + $var\[__index\].ti_Data = (ULONG)(STRPTR)SvPV_nolen(ST(ix_$var)); + break; + default: + Perl_croak(aTHX_ \"Unknown TAGTYPE \%d\",_tag_type); + } + ix_$var++; + items -=2; + } + } + +T_TAGRET + /* Allocate variable type according to preceding var tagtype */ + switch(tagtype) + { + case TT_APTR: + $var.tr_aptr = INT2PTR(APTR,SvIV($arg)); + break; + case TT_WORD: + $var.tr_word = (WORD)SvIV($arg); + break; + case TT_LONG: + $var.tr_long = (LONG)SvIV($arg); + case TT_UWORD: + $var.tr_uword = (UWORD)SvUV($arg); + break; + case TT_ULONG: + $var.tr_ulong = (ULONG)SvUV($arg); + break; + case TT_STRPTR: + case TT_UBYTE: + $var.tr_strptr = (STRPTR)SvPV_nolen($arg); + break; + default: + Perl_croak(aTHX_ \"Unknown TAGTYPE \%d\",tagtype); + } + +#################################################################################### +OUTPUT +T_TAGRET + /* Allocate variable type according to preceding var tagtype */ + switch(tagtype) + { + case TT_APTR: + sv_setiv($arg, PTR2IV($var.tr_aptr)); + break; + case TT_WORD: + sv_setiv($arg, (IV)$var.tr_word); + break; + case TT_LONG: + sv_setiv($arg, (IV)$var.tr_long); + break; + case TT_UWORD: + sv_setuv($arg, (UV)$var.tr_uword); + break; + case TT_ULONG: + sv_setuv($arg, (UV)$var.tr_ulong); + break; + case TT_STRPTR: + case TT_UBYTE: + sv_setpv((SV*)$arg, $var.tr_strptr); + break; + default: + Perl_croak(aTHX_ \"Unknown TAGTYPE \%d\",tagtype); + } + + diff --git a/gnu/usr.bin/perl/ext/Amiga-Exec/Exec.pm b/gnu/usr.bin/perl/ext/Amiga-Exec/Exec.pm new file mode 100644 index 00000000000..03ecaff6023 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Amiga-Exec/Exec.pm @@ -0,0 +1,123 @@ +package Amiga::Exec; + +use 5.016000; +use strict; +use warnings; +use Carp; + +require Exporter; +#use AutoLoader; + +our @ISA = qw(Exporter); + +# Items to export into callers namespace by default. Note: do not export +# names by default without a very good reason. Use EXPORT_OK instead. +# Do not simply export all your public functions/methods/constants. + +# This allows declaration use Amiga::Exec ':all'; +# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK +# will save memory. +our %EXPORT_TAGS = ( 'all' => [ qw( +Wait +) ] ); + +our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); + +our @EXPORT = qw( +); + +our $VERSION = '0.02'; + +require XSLoader; +XSLoader::load('Amiga::Exec', $VERSION); + + +sub Wait +{ + my %params = @_; + my $signalmask = 0; + my $timeout = 0; + + if(exists $params{'SignalMask'}) + { + $signalmask = $params{'SignalMask'}; + } + if(exists $params{'TimeOut'}) + { + $timeout = $params{'TimeOut'}; + } + + my $result = Amiga::Exec::_Wait($signalmask,$timeout); + return $result; +} + + + +# Preloaded methods go here. + +# Autoload methods go after =cut, and are processed by the autosplit program. + +1; +__END__ +# Below is stub documentation for your module. You'd better edit it! + +=head1 NAME + +Amiga::Exec - Perl extension for low level amiga support + +=head1 ABSTRACT + +This a perl class / module to enables you to use various low level Amiga features such as waiting on an Exec signal + +=head1 SYNOPSIS + + # Wait for signla + + use Amiga::Exec; + my $result = Amiga::ARexx->Wait('SignalMask' => $signalmask, 'TimeOut' => $timeoutinusecs); ); + + +=head1 DESCRIPTION + +The interface to Exec in entirely encapsulated within the perl class, there +is no need to access the low level methods directly and they are not exported by default. + +=head1 Amiga::ARexx METHODS + +=head2 Wait + + $signals = Amiga::Exec->Wait('SignalMask' => $signalmask, + 'TimeOut' => $timeoutinusecs ); + +Wait on a signal set with optional timeout. The result ($signals) should be checked to +determine which signal was raised. It will be 0 for timeout. + +=head3 Signal + +The signal Exec signal mask + +=head3 TimeOut + +optional time out in microseconds. + +=head2 EXPORT + +None by default. + +=head2 Exportable constants + +None + +=head1 AUTHOR + +Andy Broad <andy@broad.ology.org.uk> + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2013 by Andy Broad. + + +=cut + + + diff --git a/gnu/usr.bin/perl/ext/Amiga-Exec/Exec.xs b/gnu/usr.bin/perl/ext/Amiga-Exec/Exec.xs new file mode 100644 index 00000000000..6c3a6940335 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Amiga-Exec/Exec.xs @@ -0,0 +1,116 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#undef __USE_INLINE__ +#include <exec/types.h> +#include <utility/tagitem.h> +#include <dos/dos.h> +#include <proto/exec.h> +#include <proto/intuition.h> +#include <proto/utility.h> + + + +struct TimeRequest * +OpenTimer(void) +{ + struct MsgPort *port = IExec->AllocSysObjectTags(ASOT_PORT, TAG_END); + if (port == NULL) + { + return NULL; + } + + struct TimeRequest *req = IExec->AllocSysObjectTags(ASOT_IOREQUEST, + ASOIOR_Size, sizeof(struct TimeRequest), + ASOIOR_ReplyPort, port, + TAG_END); + + if (req == NULL) + { + IExec->FreeSysObject(ASOT_PORT, port); + return NULL; + } + + int8 deverr = IExec->OpenDevice("timer.device", UNIT_MICROHZ, + &req->Request, 0); + + if (deverr != IOERR_SUCCESS) + { + IExec->FreeSysObject(ASOT_IOREQUEST, req); + IExec->FreeSysObject(ASOT_PORT, port); + return NULL; + } + + return req; +} + + +void +CloseTimer(struct TimeRequest *req) +{ + if (req != NULL) + { + struct MsgPort *port = req->Request.io_Message.mn_ReplyPort; + + IExec->CloseDevice(&req->Request); + IExec->FreeSysObject(ASOT_IOREQUEST, req); + IExec->FreeSysObject(ASOT_PORT, port); + } +} + + + +uint32 WaitTimeout(uint32 signalmask , int timeout) +{ + + struct TimeRequest *req = NULL; + uint32 timermask = 0; + + if (timeout > 0) + { + req = OpenTimer(); + + if (req != NULL) + { + timermask = 1L << req->Request.io_Message.mn_ReplyPort->mp_SigBit; + + req->Request.io_Command = TR_ADDREQUEST; + req->Time.Seconds = 0; + req->Time.Microseconds = timeout; + + IExec->SendIO(&req->Request); + } + } + + uint32 waitmask = timermask | signalmask | SIGBREAKF_CTRL_C; + + uint32 sigmask = IExec->Wait(waitmask); + + if (req != NULL) + { + IExec->AbortIO(&req->Request); + IExec->WaitIO(&req->Request); + CloseTimer(req); + } + + /* remove the timer mask bit */ + + return sigmask & (~timermask ); +} + + + +MODULE = Amiga::Exec PACKAGE = Amiga::Exec + +PROTOTYPES: DISABLE + + +uint32 _Wait(signalmask,timeout) + uint32 signalmask; + uint32 timeout; + CODE: + RETVAL = WaitTimeout(signalmask,timeout); + OUTPUT: + RETVAL + diff --git a/gnu/usr.bin/perl/ext/Amiga-Exec/Makefile.PL b/gnu/usr.bin/perl/ext/Amiga-Exec/Makefile.PL new file mode 100644 index 00000000000..a432995a9c6 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Amiga-Exec/Makefile.PL @@ -0,0 +1,17 @@ +use 5.008005; +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. +WriteMakefile( + NAME => 'Amiga::Exec', + VERSION_FROM => 'Exec.pm', # finds $VERSION + PREREQ_PM => {}, # e.g., Module::Name => 1.1 + ($] >= 5.005 ? ## Add these new keywords supported since 5.005 + (ABSTRACT_FROM => 'Exec.pm', # retrieve abstract from module + AUTHOR => 'A R Broad <andy@broad.ology.org.uk>') : ()), + LIBS => ['-lauto'], # e.g., '-lm' + DEFINE => '', # e.g., '-DHAVE_SOMETHING' + INC => '-I.', # e.g., '-I. -I/usr/include/other' + # Un-comment this if you add C files to link with later: + # OBJECT => '$(O_FILES)', # link all the C files too +); diff --git a/gnu/usr.bin/perl/ext/Amiga-Exec/__examples/simplecommand.pl b/gnu/usr.bin/perl/ext/Amiga-Exec/__examples/simplecommand.pl new file mode 100644 index 00000000000..85d447bb8ab --- /dev/null +++ b/gnu/usr.bin/perl/ext/Amiga-Exec/__examples/simplecommand.pl @@ -0,0 +1,14 @@ +#!perl + +use strict; +use warnings; + +use Amiga::ARexx qw(DoRexx); + +my ($result,$rc,$rc2) = DoRexx("WORKBENCH","HELP"); + +print $result , "\n" , $rc, "\n", $rc2 , "\n"; + +($result,$rc,$rc2) = DoRexx("WORKBENCH","NOHELP"); + +print $result , "\n" , $rc, "\n", $rc2 , "\n"; diff --git a/gnu/usr.bin/perl/ext/Amiga-Exec/__examples/simplehost.pl b/gnu/usr.bin/perl/ext/Amiga-Exec/__examples/simplehost.pl new file mode 100644 index 00000000000..df5ecd2ff4e --- /dev/null +++ b/gnu/usr.bin/perl/ext/Amiga-Exec/__examples/simplehost.pl @@ -0,0 +1,46 @@ +#!perl + +# Simple ARExx Host + +use strict; +use Amiga::ARexx; +use feature "switch"; + +my $host = Amiga::ARexx->new('HostName' => "TESTSCRIPT"); + +my $alive = 1; + +while ($alive) +{ + $host->wait(); + my $msg = $host->getmsg(); + while($msg) + { + my $rc = 0; + my $rc2 = 0; + my $result = ""; + + print $msg->message . "\n"; + given($msg->message) + { + when ("QUIT") + { + $alive = 0; + $result = "quitting!"; + } + when ("SHOUT") + { + $result = "HEEELLLLOOOO!"; + } + default { + $rc = 10; + $rc2 = 22; + } + } + $msg->reply($rc,$rc2,$result); + + $msg = $host->getmsg(); + } + +} + diff --git a/gnu/usr.bin/perl/ext/Amiga-Exec/tagtypes.h b/gnu/usr.bin/perl/ext/Amiga-Exec/tagtypes.h new file mode 100644 index 00000000000..24a6218e758 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Amiga-Exec/tagtypes.h @@ -0,0 +1,25 @@ +/* defines types for tags */ +#ifndef _TAGTYPES_H +#define _TAGTYPES_H + +#define TT_APTR 1 +#define TT_WORD 2 +#define TT_UWORD 3 +#define TT_LONG 4 +#define TT_ULONG 5 +#define TT_STRPTR 6 +#define TT_UBYTE 7 + +typedef union TagReturn +{ + WORD tr_word; + UWORD tr_uword; + LONG tr_long; + ULONG tr_ulong; + STRPTR tr_strptr; + APTR tr_aptr; + UBYTE * tr_ubyte; +} +TAGRET; + +#endif diff --git a/gnu/usr.bin/perl/ext/Amiga-Exec/typemap b/gnu/usr.bin/perl/ext/Amiga-Exec/typemap new file mode 100644 index 00000000000..644c1a5dd99 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Amiga-Exec/typemap @@ -0,0 +1,118 @@ +APTR T_PTR +intArray * T_ARRAY +UWORD T_UV +ULONG T_UV +WORD T_IV +LONG T_IV +BOOL T_IV +TagList * T_TAGLIST +TAGRET T_TAGRET +STRPTR T_PV +int32 T_IV +uint32 T_UV + +############################################################################# +INPUT +T_TAGLIST + U32 ix_$var = $argoff; + U32 _tag_type; + /* allocate taglist struct, +2 as tags lists end in a TAG_DONE by tradition */ + /* if by some chance someone adds something after the TAG_DONE it will just*/ + /* result in harmless empty space */ + $var = $ntype((items -= $argoff) +2); + while(items > 0) + { + int __index = (ix_$var - $argoff)/3; + $var\[__index\].ti_Tag = (ULONG)SvUV(ST(ix_$var)); + ix_$var++; + items--; + /* the last is a tag_done and usualy has no followers so check for > 1 */ + if(items > 1 && ($var\[__index\].ti_Tag != TAG_DONE)) + { + _tag_type = (ULONG)SvUV(ST(ix_$var)); + ix_$var++; + switch(_tag_type) + { + case TT_APTR: + $var\[__index\].ti_Data = (ULONG)INT2PTR(APTR,SvIV(ST(ix_$var))); + break; + case TT_WORD: + $var\[__index\].ti_Data = (WORD)SvIV(ST(ix_$var)); + break; + case TT_LONG: + $var\[__index\].ti_Data = (LONG)SvIV(ST(ix_$var)); + break; + case TT_UWORD: + $var\[__index\].ti_Data = (UWORD)SvUV(ST(ix_$var)); + break; + case TT_ULONG: + $var\[__index\].ti_Data = (ULONG)SvUV(ST(ix_$var)); + break; + case TT_STRPTR: + case TT_UBYTE: + $var\[__index\].ti_Data = (ULONG)(STRPTR)SvPV_nolen(ST(ix_$var)); + break; + default: + Perl_croak(aTHX_ \"Unknown TAGTYPE \%d\",_tag_type); + } + ix_$var++; + items -=2; + } + } + +T_TAGRET + /* Allocate variable type according to preceding var tagtype */ + switch(tagtype) + { + case TT_APTR: + $var.tr_aptr = INT2PTR(APTR,SvIV($arg)); + break; + case TT_WORD: + $var.tr_word = (WORD)SvIV($arg); + break; + case TT_LONG: + $var.tr_long = (LONG)SvIV($arg); + case TT_UWORD: + $var.tr_uword = (UWORD)SvUV($arg); + break; + case TT_ULONG: + $var.tr_ulong = (ULONG)SvUV($arg); + break; + case TT_STRPTR: + case TT_UBYTE: + $var.tr_strptr = (STRPTR)SvPV_nolen($arg); + break; + default: + Perl_croak(aTHX_ \"Unknown TAGTYPE \%d\",tagtype); + } + +#################################################################################### +OUTPUT +T_TAGRET + /* Allocate variable type according to preceding var tagtype */ + switch(tagtype) + { + case TT_APTR: + sv_setiv($arg, PTR2IV($var.tr_aptr)); + break; + case TT_WORD: + sv_setiv($arg, (IV)$var.tr_word); + break; + case TT_LONG: + sv_setiv($arg, (IV)$var.tr_long); + break; + case TT_UWORD: + sv_setuv($arg, (UV)$var.tr_uword); + break; + case TT_ULONG: + sv_setuv($arg, (UV)$var.tr_ulong); + break; + case TT_STRPTR: + case TT_UBYTE: + sv_setpv((SV*)$arg, $var.tr_strptr); + break; + default: + Perl_croak(aTHX_ \"Unknown TAGTYPE \%d\",tagtype); + } + + diff --git a/gnu/usr.bin/perl/ext/B/B.pm b/gnu/usr.bin/perl/ext/B/B.pm index 952475db2c2..5c1e5997b83 100644 --- a/gnu/usr.bin/perl/ext/B/B.pm +++ b/gnu/usr.bin/perl/ext/B/B.pm @@ -15,7 +15,7 @@ require Exporter; # walkoptree comes from B.xs BEGIN { - $B::VERSION = '1.48'; + $B::VERSION = '1.62'; @B::EXPORT_OK = (); # Our BOOT code needs $VERSION set, and will append to @EXPORT_OK. @@ -35,7 +35,7 @@ push @B::EXPORT_OK, (qw(minus_c ppname save_BEGINs parents comppadlist sv_undef compile_stats timing_info begin_av init_av check_av end_av regex_padav dowarn defstash curstash warnhook diehook inc_gv @optype - @specialsv_name unitcheck_av)); + @specialsv_name unitcheck_av safename)); @B::SV::ISA = 'B::OBJECT'; @B::NULL::ISA = 'B::SV'; @@ -60,6 +60,7 @@ push @B::EXPORT_OK, (qw(minus_c ppname save_BEGINs @B::OP::ISA = 'B::OBJECT'; @B::UNOP::ISA = 'B::OP'; +@B::UNOP_AUX::ISA = 'B::UNOP'; @B::BINOP::ISA = 'B::UNOP'; @B::LOGOP::ISA = 'B::UNOP'; @B::LISTOP::ISA = 'B::BINOP'; @@ -69,10 +70,12 @@ push @B::EXPORT_OK, (qw(minus_c ppname save_BEGINs @B::LOOP::ISA = 'B::LISTOP'; @B::PMOP::ISA = 'B::LISTOP'; @B::COP::ISA = 'B::OP'; +@B::METHOP::ISA = 'B::OP'; @B::SPECIAL::ISA = 'B::OBJECT'; -@B::optype = qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP); +@B::optype = qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP + METHOP UNOP_AUX); # bytecode.pl contained the following comment: # Nullsv *must* come first in the following so that the condition # ($$sv == 0) can continue to be used to test (sv == Nullsv). @@ -85,7 +88,11 @@ push @B::EXPORT_OK, (qw(minus_c ppname save_BEGINs } sub B::GV::SAFENAME { - my $name = (shift())->NAME; + safename(shift()->NAME); +} + +sub safename { + my $name = shift; # The regex below corresponds to the isCONTROLVAR macro # from toke.c @@ -267,72 +274,6 @@ sub walksymtable { } } -{ - package B::Section; - my $output_fh; - my %sections; - - sub new { - my ($class, $section, $symtable, $default) = @_; - $output_fh ||= FileHandle->new_tmpfile; - my $obj = bless [-1, $section, $symtable, $default], $class; - $sections{$section} = $obj; - return $obj; - } - - sub get { - my ($class, $section) = @_; - return $sections{$section}; - } - - sub add { - my $section = shift; - while (defined($_ = shift)) { - print $output_fh "$section->[1]\t$_\n"; - $section->[0]++; - } - } - - sub index { - my $section = shift; - return $section->[0]; - } - - sub name { - my $section = shift; - return $section->[1]; - } - - sub symtable { - my $section = shift; - return $section->[2]; - } - - sub default { - my $section = shift; - return $section->[3]; - } - - sub output { - my ($section, $fh, $format) = @_; - my $name = $section->name; - my $sym = $section->symtable || {}; - my $default = $section->default; - - seek($output_fh, 0, 0); - while (<$output_fh>) { - chomp; - s/^(.*?)\t//; - if ($1 eq $name) { - s{(s\\_[0-9a-f]+)} { - exists($sym->{$1}) ? $sym->{$1} : $default; - }ge; - printf $fh $format, $_; - } - } - } -} - 1; __END__ @@ -537,6 +478,13 @@ be used as a string in C source code. Returns a double-quote-surrounded escaped version of STR which can be used as a string in Perl source code. +=item safename(STR) + +This function returns the string with the first character modified if it +is a control character. It converts it to ^X format first, so that "\cG" +becomes "^G". This is used internally by L<B::GV::SAFENAME|/SAFENAME>, but +you can call it directly. + =item class(OBJ) Returns the class of an object without the part of the classname @@ -545,8 +493,8 @@ C<"UNOP"> for example. =item threadsv_names -In a perl compiled for threads, this returns a list of the special -per-thread threadsv variables. +This used to provide support for the old 5.005 threading module. It now +does nothing. =back @@ -725,6 +673,14 @@ unsigned. =item NVX +=item COP_SEQ_RANGE_LOW + +=item COP_SEQ_RANGE_HIGH + +These last two are only valid for pad name SVs. They only existed in the +B::NV class before Perl 5.22. In 5.22 they were moved to the B::PADNAME +class. + =back =head2 B::RV Methods @@ -841,6 +797,22 @@ in the MAGIC. =back +=head2 B::REGEXP Methods + +=over 4 + +=item REGEX + +=item precomp + +=item qr_anoncv + +=item compflags + +The last two were added in Perl 5.22. + +=back + =head2 B::GV Methods =over 4 @@ -894,6 +866,10 @@ If you're working with globs at runtime, and need to disambiguate =item FLAGS +=item GPFLAGS + +This last one is present only in perl 5.22.0 and higher. + =back =head2 B::IO Methods @@ -1053,8 +1029,9 @@ information is no longer stored directly in the hash. =head2 OP-RELATED CLASSES -C<B::OP>, C<B::UNOP>, C<B::BINOP>, C<B::LOGOP>, C<B::LISTOP>, C<B::PMOP>, -C<B::SVOP>, C<B::PADOP>, C<B::PVOP>, C<B::LOOP>, C<B::COP>. +C<B::OP>, C<B::UNOP>, C<B::UNOP_AUX>, C<B::BINOP>, C<B::LOGOP>, +C<B::LISTOP>, C<B::PMOP>, C<B::SVOP>, C<B::PADOP>, C<B::PVOP>, C<B::LOOP>, +C<B::COP>, C<B::METHOP>. These classes correspond in the obvious way to the underlying C structures of similar names. The inheritance hierarchy mimics the @@ -1062,18 +1039,20 @@ underlying C "inheritance": B::OP | - +---------------+--------+--------+-------+ - | | | | | - B::UNOP B::SVOP B::PADOP B::COP B::PVOP - ,' `-. - / `--. - B::BINOP B::LOGOP + +----------+---------+--------+-------+---------+ + | | | | | | + B::UNOP B::SVOP B::PADOP B::COP B::PVOP B::METHOP + | + +---+---+---------+ + | | | + B::BINOP B::LOGOP B::UNOP_AUX | | B::LISTOP - ,' `. - / \ - B::LOOP B::PMOP + | + +---+---+ + | | + B::LOOP B::PMOP Access methods correspond to the underlying C structure field names, with the leading "class indication" prefix (C<"op_">) removed. @@ -1089,6 +1068,16 @@ data structure. See top of C<op.h> for more info. =item sibling +=item parent + +Returns the OP's parent. If it has no parent, or if your perl wasn't built +with C<-DPERL_OP_PARENT>, returns NULL. + +Note that the global variable C<$B::OP::does_parent> is undefined on older +perls that don't support the C<parent> method, is defined but false on +perls that support the method but were built without C<-DPERL_OP_PARENT>, +and is true otherwise. + =item name This returns the op name as a string (e.g. "add", "rv2av"). @@ -1117,7 +1106,7 @@ This returns the op description from the global C PL_op_desc array =back -=head2 B::UNOP METHOD +=head2 B::UNOP Method =over 4 @@ -1125,7 +1114,28 @@ This returns the op description from the global C PL_op_desc array =back -=head2 B::BINOP METHOD +=head2 B::UNOP_AUX Methods (since 5.22) + +=over 4 + +=item aux_list(cv) + +This returns a list of the elements of the op's aux data structure, +or a null list if there is no aux. What will be returned depends on the +object's type, but will typically be a collection of C<B::IV>, C<B::GV>, +etc. objects. C<cv> is the C<B::CV> object representing the sub that the +op is contained within. + +=item string(cv) + +This returns a textual representation of the object (likely to b useful +for deparsing and debugging), or an empty string if the op type doesn't +support this. C<cv> is the C<B::CV> object representing the sub that the +op is contained within. + +=back + +=head2 B::BINOP Method =over 4 @@ -1133,7 +1143,7 @@ This returns the op description from the global C PL_op_desc array =back -=head2 B::LOGOP METHOD +=head2 B::LOGOP Method =over 4 @@ -1141,7 +1151,7 @@ This returns the op description from the global C PL_op_desc array =back -=head2 B::LISTOP METHOD +=head2 B::LISTOP Method =over 4 @@ -1177,9 +1187,16 @@ Only when perl was compiled with ithreads. Since perl 5.17.1 +=item pmregexp + +Added in perl 5.22, this method returns the B::REGEXP associated with the +op. While PMOPs do not actually have C<pmregexp> fields under threaded +builds, this method returns the regexp under threads nonetheless, for +convenience. + =back -=head2 B::SVOP METHOD +=head2 B::SVOP Methods =over 4 @@ -1189,7 +1206,7 @@ Since perl 5.17.1 =back -=head2 B::PADOP METHOD +=head2 B::PADOP Method =over 4 @@ -1197,7 +1214,7 @@ Since perl 5.17.1 =back -=head2 B::PVOP METHOD +=head2 B::PVOP Method =over 4 @@ -1219,6 +1236,9 @@ Since perl 5.17.1 =head2 B::COP Methods +The C<B::COP> class is used for "nextstate" and "dbstate" ops. As of Perl +5.22, it is also used for "null" ops that started out as COPs. + =over 4 =item label @@ -1247,11 +1267,23 @@ Since perl 5.17.1 =back -=head2 OTHER CLASSES +=head2 B::METHOP Methods (Since Perl 5.22) -Perl 5.18 introduces a new class, B::PADLIST, returned by B::CV's +=over 4 + +=item first + +=item meth_sv + +=back + +=head2 PAD-RELATED CLASSES + +Perl 5.18 introduced a new class, B::PADLIST, returned by B::CV's C<PADLIST> method. +Perl 5.22 introduced the B::PADNAMELIST and B::PADNAME classes. + =head2 B::PADLIST Methods =over 4 @@ -1260,16 +1292,100 @@ C<PADLIST> method. =item ARRAY -A list of pads. The first one contains the names. These are currently -B::AV objects, but that is likely to change in future versions. +A list of pads. The first one contains the names. + +The first one is a B::PADNAMELIST under Perl 5.22, and a B::AV under +earlier versions. The rest are currently B::AV objects, but that could +change in future versions. =item ARRAYelt Like C<ARRAY>, but takes an index as an argument to get only one element, rather than a list of all of them. +=item NAMES + +This method, introduced in 5.22, returns the B::PADNAMELIST. It is +equivalent to C<ARRAYelt> with a 0 argument. + +=item REFCNT + +=item id + +This method, introduced in 5.22, returns an ID shared by clones of the same +padlist. + +=item outid + +This method, also added in 5.22, returns the ID of the outer padlist. + +=back + +=head2 B::PADNAMELIST Methods + +=over 4 + +=item MAX + +=item ARRAY + +=item ARRAYelt + +These two methods return the pad names, using B::SPECIAL objects for null +pointers and B::PADNAME objects otherwise. + +=item REFCNT + +=back + +=head2 B::PADNAME Methods + +=over 4 + +=item PV + +=item PVX + +=item LEN + =item REFCNT +=item FLAGS + +For backward-compatibility, if the PADNAMEt_OUTER flag is set, the FLAGS +method adds the SVf_FAKE flag, too. + +=item TYPE + +A B::HV object representing the stash for a typed lexical. + +=item SvSTASH + +A backward-compatibility alias for TYPE. + +=item OURSTASH + +A B::HV object representing the stash for 'our' variables. + +=item PROTOCV + +The prototype CV for a 'my' sub. + +=item COP_SEQ_RANGE_LOW + +=item COP_SEQ_RANGE_HIGH + +Sequence numbers representing the scope within which a lexical is visible. +Meaningless if PADNAMEt_OUTER is set. + +=item PARENT_PAD_INDEX + +Only meaningful if PADNAMEt_OUTER is set. + +=item PARENT_FAKELEX_FLAGS + +Only meaningful if PADNAMEt_OUTER is set. + =back =head2 $B::overlay diff --git a/gnu/usr.bin/perl/ext/B/B.xs b/gnu/usr.bin/perl/ext/B/B.xs index 1c44857219e..b4b6a40ac53 100644 --- a/gnu/usr.bin/perl/ext/B/B.xs +++ b/gnu/usr.bin/perl/ext/B/B.xs @@ -8,6 +8,7 @@ */ #define PERL_NO_GET_CONTEXT +#define PERL_EXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" @@ -21,24 +22,14 @@ typedef FILE * InputStream; static const char* const svclassnames[] = { "B::NULL", -#if PERL_VERSION < 19 - "B::BIND", -#endif "B::IV", "B::NV", -#if PERL_VERSION <= 10 - "B::RV", -#endif "B::PV", -#if PERL_VERSION >= 19 "B::INVLIST", -#endif "B::PVIV", "B::PVNV", "B::PVMG", -#if PERL_VERSION >= 11 "B::REGEXP", -#endif "B::GV", "B::PVLV", "B::AV", @@ -60,7 +51,9 @@ typedef enum { OPc_PADOP, /* 8 */ OPc_PVOP, /* 9 */ OPc_LOOP, /* 10 */ - OPc_COP /* 11 */ + OPc_COP, /* 11 */ + OPc_METHOP, /* 12 */ + OPc_UNOP_AUX /* 13 */ } opclass; static const char* const opclassnames[] = { @@ -75,7 +68,9 @@ static const char* const opclassnames[] = { "B::PADOP", "B::PVOP", "B::LOOP", - "B::COP" + "B::COP", + "B::METHOP", + "B::UNOP_AUX" }; static const size_t opsizes[] = { @@ -90,14 +85,16 @@ static const size_t opsizes[] = { sizeof(PADOP), sizeof(PVOP), sizeof(LOOP), - sizeof(COP) + sizeof(COP), + sizeof(METHOP), + sizeof(UNOP_AUX), }; #define MY_CXT_KEY "B::_guts" XS_VERSION typedef struct { - int x_walkoptree_debug; /* Flag for walkoptree debug hook */ SV * x_specialsv_list[7]; + int x_walkoptree_debug; /* Flag for walkoptree debug hook */ } my_cxt_t; START_MY_CXT @@ -105,6 +102,17 @@ START_MY_CXT #define walkoptree_debug (MY_CXT.x_walkoptree_debug) #define specialsv_list (MY_CXT.x_specialsv_list) + +static void B_init_my_cxt(pTHX_ my_cxt_t * cxt) { + cxt->x_specialsv_list[0] = Nullsv; + cxt->x_specialsv_list[1] = &PL_sv_undef; + cxt->x_specialsv_list[2] = &PL_sv_yes; + cxt->x_specialsv_list[3] = &PL_sv_no; + cxt->x_specialsv_list[4] = (SV *) pWARN_ALL; + cxt->x_specialsv_list[5] = (SV *) pWARN_NONE; + cxt->x_specialsv_list[6] = (SV *) pWARN_STD; +} + static opclass cc_opclass(pTHX_ const OP *o) { @@ -113,18 +121,16 @@ cc_opclass(pTHX_ const OP *o) if (!o) return OPc_NULL; - if (o->op_type == 0) + if (o->op_type == 0) { + if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE) + return OPc_COP; return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP; + } if (o->op_type == OP_SASSIGN) return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP); if (o->op_type == OP_AELEMFAST) { -#if PERL_VERSION <= 14 - if (o->op_flags & OPf_SPECIAL) - return OPc_BASEOP; - else -#endif #ifdef USE_ITHREADS return OPc_PADOP; #else @@ -232,6 +238,10 @@ cc_opclass(pTHX_ const OP *o) return OPc_BASEOP; else return OPc_PVOP; + case OA_METHOP: + return OPc_METHOP; + case OA_UNOP_AUX: + return OPc_UNOP_AUX; } warn("can't determine class of operator %s, assuming BASEOP\n", OP_NAME(o)); @@ -528,7 +538,7 @@ walkoptree(pTHX_ OP *o, const char *method, SV *ref) PUTBACK; perl_call_method(method, G_DISCARD); if (o && (o->op_flags & OPf_KIDS)) { - for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) { + for (kid = ((UNOP*)o)->op_first; kid; kid = OpSIBLING(kid)) { ref = walkoptree(aTHX_ kid, method, ref); } } @@ -554,7 +564,7 @@ oplist(pTHX_ OP *o, SV **SP) continue; case OP_SORT: if (o->op_flags & OPf_STACKED && o->op_flags & OPf_SPECIAL) { - OP *kid = cLISTOPo->op_first->op_sibling; /* pass pushmark */ + OP *kid = OpSIBLING(cLISTOPo->op_first); /* pass pushmark */ kid = kUNOP->op_first; /* pass rv2gv */ kid = kUNOP->op_first; /* pass leave */ SP = oplist(aTHX_ kid->op_next, SP); @@ -586,15 +596,14 @@ typedef PADOP *B__PADOP; typedef PVOP *B__PVOP; typedef LOOP *B__LOOP; typedef COP *B__COP; +typedef METHOP *B__METHOP; typedef SV *B__SV; typedef SV *B__IV; typedef SV *B__PV; typedef SV *B__NV; typedef SV *B__PVMG; -#if PERL_VERSION >= 11 typedef SV *B__REGEXP; -#endif typedef SV *B__PVLV; typedef SV *B__BM; typedef SV *B__RV; @@ -611,10 +620,13 @@ typedef struct refcounted_he *B__RHE; #ifdef PadlistARRAY typedef PADLIST *B__PADLIST; #endif +typedef PADNAMELIST *B__PADNAMELIST; +typedef PADNAME *B__PADNAME; + #ifdef MULTIPLICITY # define ASSIGN_COMMON_ALIAS(prefix, var) \ - STMT_START { XSANY.any_i32 = offsetof(struct interpreter, prefix##var); } STMT_END + STMT_START { XSANY.any_i32 = STRUCT_OFFSET(struct interpreter, prefix##var); } STMT_END #else # define ASSIGN_COMMON_ALIAS(prefix, var) \ STMT_START { XSANY.any_ptr = (void *)&PL_##var; } STMT_END @@ -654,53 +666,44 @@ static XSPROTO(intrpvar_sv_common) /* table that drives most of the B::*OP methods */ -struct OP_methods { +static const struct OP_methods { const char *name; U8 namelen; U8 type; /* if op_offset_special, access is handled on a case-by-case basis */ U16 offset; } op_methods[] = { - { STR_WITH_LEN("next"), OPp, offsetof(struct op, op_next), },/* 0*/ - { STR_WITH_LEN("sibling"), OPp, offsetof(struct op, op_sibling), },/* 1*/ - { STR_WITH_LEN("targ"), PADOFFSETp, offsetof(struct op, op_targ), },/* 2*/ - { STR_WITH_LEN("flags"), U8p, offsetof(struct op, op_flags), },/* 3*/ - { STR_WITH_LEN("private"), U8p, offsetof(struct op, op_private), },/* 4*/ - { STR_WITH_LEN("first"), OPp, offsetof(struct unop, op_first), },/* 5*/ - { STR_WITH_LEN("last"), OPp, offsetof(struct binop, op_last), },/* 6*/ - { STR_WITH_LEN("other"), OPp, offsetof(struct logop, op_other), },/* 7*/ + { STR_WITH_LEN("next"), OPp, STRUCT_OFFSET(struct op, op_next), },/* 0*/ + { STR_WITH_LEN("sibling"), op_offset_special, 0, },/* 1*/ + { STR_WITH_LEN("targ"), PADOFFSETp, STRUCT_OFFSET(struct op, op_targ), },/* 2*/ + { STR_WITH_LEN("flags"), U8p, STRUCT_OFFSET(struct op, op_flags), },/* 3*/ + { STR_WITH_LEN("private"), U8p, STRUCT_OFFSET(struct op, op_private), },/* 4*/ + { STR_WITH_LEN("first"), OPp, STRUCT_OFFSET(struct unop, op_first), },/* 5*/ + { STR_WITH_LEN("last"), OPp, STRUCT_OFFSET(struct binop, op_last), },/* 6*/ + { STR_WITH_LEN("other"), OPp, STRUCT_OFFSET(struct logop, op_other), },/* 7*/ { STR_WITH_LEN("pmreplstart"), op_offset_special, 0, },/* 8*/ - { STR_WITH_LEN("redoop"), OPp, offsetof(struct loop, op_redoop), },/* 9*/ - { STR_WITH_LEN("nextop"), OPp, offsetof(struct loop, op_nextop), },/*10*/ - { STR_WITH_LEN("lastop"), OPp, offsetof(struct loop, op_lastop), },/*11*/ - { STR_WITH_LEN("pmflags"), U32p, offsetof(struct pmop, op_pmflags),},/*12*/ -#if PERL_VERSION >= 17 - { STR_WITH_LEN("code_list"),OPp, offsetof(struct pmop, op_code_list),},/*13*/ -#else - { STR_WITH_LEN("code_list"),op_offset_special, 0, -#endif - { STR_WITH_LEN("sv"), SVp, offsetof(struct svop, op_sv), },/*14*/ - { STR_WITH_LEN("gv"), SVp, offsetof(struct svop, op_sv), },/*15*/ - { STR_WITH_LEN("padix"), PADOFFSETp,offsetof(struct padop, op_padix),},/*16*/ - { STR_WITH_LEN("cop_seq"), U32p, offsetof(struct cop, cop_seq), },/*17*/ - { STR_WITH_LEN("line"), line_tp, offsetof(struct cop, cop_line), },/*18*/ - { STR_WITH_LEN("hints"), U32p, offsetof(struct cop, cop_hints), },/*19*/ + { STR_WITH_LEN("redoop"), OPp, STRUCT_OFFSET(struct loop, op_redoop), },/* 9*/ + { STR_WITH_LEN("nextop"), OPp, STRUCT_OFFSET(struct loop, op_nextop), },/*10*/ + { STR_WITH_LEN("lastop"), OPp, STRUCT_OFFSET(struct loop, op_lastop), },/*11*/ + { STR_WITH_LEN("pmflags"), U32p, STRUCT_OFFSET(struct pmop, op_pmflags),},/*12*/ + { STR_WITH_LEN("code_list"),OPp, STRUCT_OFFSET(struct pmop, op_code_list),},/*13*/ + { STR_WITH_LEN("sv"), SVp, STRUCT_OFFSET(struct svop, op_sv), },/*14*/ + { STR_WITH_LEN("gv"), SVp, STRUCT_OFFSET(struct svop, op_sv), },/*15*/ + { STR_WITH_LEN("padix"), PADOFFSETp,STRUCT_OFFSET(struct padop, op_padix),},/*16*/ + { STR_WITH_LEN("cop_seq"), U32p, STRUCT_OFFSET(struct cop, cop_seq), },/*17*/ + { STR_WITH_LEN("line"), line_tp, STRUCT_OFFSET(struct cop, cop_line), },/*18*/ + { STR_WITH_LEN("hints"), U32p, STRUCT_OFFSET(struct cop, cop_hints), },/*19*/ #ifdef USE_ITHREADS - { STR_WITH_LEN("pmoffset"),IVp, offsetof(struct pmop, op_pmoffset),},/*20*/ + { STR_WITH_LEN("pmoffset"),IVp, STRUCT_OFFSET(struct pmop, op_pmoffset),},/*20*/ { STR_WITH_LEN("filegv"), op_offset_special, 0, },/*21*/ - { STR_WITH_LEN("file"), char_pp, offsetof(struct cop, cop_file), },/*22*/ + { STR_WITH_LEN("file"), char_pp, STRUCT_OFFSET(struct cop, cop_file), },/*22*/ { STR_WITH_LEN("stash"), op_offset_special, 0, },/*23*/ -# if PERL_VERSION < 17 - { STR_WITH_LEN("stashpv"), char_pp, offsetof(struct cop, cop_stashpv),}, /*24*/ - { STR_WITH_LEN("stashoff"),op_offset_special, 0, },/*25*/ -# else { STR_WITH_LEN("stashpv"), op_offset_special, 0, },/*24*/ - { STR_WITH_LEN("stashoff"),PADOFFSETp,offsetof(struct cop,cop_stashoff),},/*25*/ -# endif + { STR_WITH_LEN("stashoff"),PADOFFSETp,STRUCT_OFFSET(struct cop,cop_stashoff),},/*25*/ #else { STR_WITH_LEN("pmoffset"),op_offset_special, 0, },/*20*/ - { STR_WITH_LEN("filegv"), SVp, offsetof(struct cop, cop_filegv),},/*21*/ + { STR_WITH_LEN("filegv"), SVp, STRUCT_OFFSET(struct cop, cop_filegv),},/*21*/ { STR_WITH_LEN("file"), op_offset_special, 0, },/*22*/ - { STR_WITH_LEN("stash"), SVp, offsetof(struct cop, cop_stash), },/*23*/ + { STR_WITH_LEN("stash"), SVp, STRUCT_OFFSET(struct cop, cop_stash), },/*23*/ { STR_WITH_LEN("stashpv"), op_offset_special, 0, },/*24*/ { STR_WITH_LEN("stashoff"),op_offset_special, 0, },/*25*/ #endif @@ -725,14 +728,20 @@ struct OP_methods { { STR_WITH_LEN("warnings"),op_offset_special, 0, },/*44*/ { STR_WITH_LEN("io"), op_offset_special, 0, },/*45*/ { STR_WITH_LEN("hints_hash"),op_offset_special, 0, },/*46*/ -#if PERL_VERSION >= 17 { STR_WITH_LEN("slabbed"), op_offset_special, 0, },/*47*/ { STR_WITH_LEN("savefree"),op_offset_special, 0, },/*48*/ { STR_WITH_LEN("static"), op_offset_special, 0, },/*49*/ -# if PERL_VERSION >= 19 { STR_WITH_LEN("folded"), op_offset_special, 0, },/*50*/ + { STR_WITH_LEN("moresib"), op_offset_special, 0, },/*51*/ + { STR_WITH_LEN("parent"), op_offset_special, 0, },/*52*/ + { STR_WITH_LEN("first"), op_offset_special, 0, },/*53*/ + { STR_WITH_LEN("meth_sv"), op_offset_special, 0, },/*54*/ + { STR_WITH_LEN("pmregexp"),op_offset_special, 0, },/*55*/ +# ifdef USE_ITHREADS + { STR_WITH_LEN("rclass"), op_offset_special, 0, },/*56*/ +# else + { STR_WITH_LEN("rclass"), op_offset_special, 0, },/*56*/ # endif -#endif }; #include "const-c.inc" @@ -747,15 +756,9 @@ BOOT: { CV *cv; const char *file = __FILE__; + SV *sv; MY_CXT_INIT; - specialsv_list[0] = Nullsv; - specialsv_list[1] = &PL_sv_undef; - specialsv_list[2] = &PL_sv_yes; - specialsv_list[3] = &PL_sv_no; - specialsv_list[4] = (SV *) pWARN_ALL; - specialsv_list[5] = (SV *) pWARN_NONE; - specialsv_list[6] = (SV *) pWARN_STD; - + B_init_my_cxt(aTHX_ &(MY_CXT)); cv = newXS("B::init_av", intrpvar_sv_common, file); ASSIGN_COMMON_ALIAS(I, initav); cv = newXS("B::check_av", intrpvar_sv_common, file); @@ -786,6 +789,12 @@ BOOT: ASSIGN_COMMON_ALIAS(I, warnhook); cv = newXS("B::diehook", intrpvar_sv_common, file); ASSIGN_COMMON_ALIAS(I, diehook); + sv = get_sv("B::OP::does_parent", GV_ADDMULTI); +#ifdef PERL_OP_PARENT + sv_setsv(sv, &PL_sv_yes); +#else + sv_setsv(sv, &PL_sv_no); +#endif } #ifndef PL_formfeed @@ -945,7 +954,18 @@ threadsv_names() PPCODE: +#ifdef USE_ITHREADS +void +CLONE(...) +PPCODE: + PUTBACK; /* some vars go out of scope now in machine code */ + { + MY_CXT_CLONE; + B_init_my_cxt(aTHX_ &(MY_CXT)); + } + return; /* dont execute another implied XSPP PUTBACK */ +#endif MODULE = B PACKAGE = B::OP @@ -1008,6 +1028,12 @@ next(o) B::OP::savefree = 48 B::OP::static = 49 B::OP::folded = 50 + B::OP::moresib = 51 + B::OP::parent = 52 + B::METHOP::first = 53 + B::METHOP::meth_sv = 54 + B::PMOP::pmregexp = 55 + B::METHOP::rclass = 56 PREINIT: SV *ret; PPCODE: @@ -1024,7 +1050,11 @@ next(o) if (op_methods[ix].type == op_offset_special) switch (ix) { - case 8: /* pmreplstart */ + case 1: /* B::OP::op_sibling */ + ret = make_op_object(aTHX_ OpSIBLING(o)); + break; + + case 8: /* B::PMOP::pmreplstart */ ret = make_op_object(aTHX_ cPMOPo->op_type == OP_SUBST ? cPMOPo->op_pmstashstartu.op_pmreplstart @@ -1032,41 +1062,35 @@ next(o) ); break; #ifdef USE_ITHREADS - case 21: /* filegv */ + case 21: /* B::COP::filegv */ ret = make_sv_object(aTHX_ (SV *)CopFILEGV((COP*)o)); break; #endif #ifndef USE_ITHREADS - case 22: /* file */ + case 22: /* B::COP::file */ ret = sv_2mortal(newSVpv(CopFILE((COP*)o), 0)); break; #endif #ifdef USE_ITHREADS - case 23: /* stash */ + case 23: /* B::COP::stash */ ret = make_sv_object(aTHX_ (SV *)CopSTASH((COP*)o)); break; #endif -#if PERL_VERSION >= 17 || !defined USE_ITHREADS - case 24: /* stashpv */ -# if PERL_VERSION >= 17 + case 24: /* B::COP::stashpv */ ret = sv_2mortal(CopSTASH((COP*)o) && SvTYPE(CopSTASH((COP*)o)) == SVt_PVHV ? newSVhek(HvNAME_HEK(CopSTASH((COP*)o))) : &PL_sv_undef); -# else - ret = sv_2mortal(newSVpv(CopSTASHPV((COP*)o), 0)); -# endif break; -#endif - case 26: /* size */ + case 26: /* B::OP::size */ ret = sv_2mortal(newSVuv((UV)(opsizes[cc_opclass(aTHX_ o)]))); break; - case 27: /* name */ - case 28: /* desc */ + case 27: /* B::OP::name */ + case 28: /* B::OP::desc */ ret = sv_2mortal(newSVpv( (char *)(ix == 28 ? OP_DESC(o) : OP_NAME(o)), 0)); break; - case 29: /* ppaddr */ + case 29: /* B::OP::ppaddr */ { int i; ret = sv_2mortal(Perl_newSVpvf(aTHX_ "PL_ppaddr[OP_%s]", @@ -1075,17 +1099,14 @@ next(o) SvPVX(ret)[i] = toUPPER(SvPVX(ret)[i]); } break; - case 30: /* type */ - case 31: /* opt */ - case 32: /* spare */ -#if PERL_VERSION >= 17 - case 47: /* slabbed */ - case 48: /* savefree */ - case 49: /* static */ -#if PERL_VERSION >= 19 - case 50: /* folded */ -#endif -#endif + case 30: /* B::OP::type */ + case 31: /* B::OP::opt */ + case 32: /* B::OP::spare */ + case 47: /* B::OP::slabbed */ + case 48: /* B::OP::savefree */ + case 49: /* B::OP::static */ + case 50: /* B::OP::folded */ + case 51: /* B::OP::moresib */ /* These are all bitfields, so we can't take their addresses */ ret = sv_2mortal(newSVuv((UV)( ix == 30 ? o->op_type @@ -1094,18 +1115,19 @@ next(o) : ix == 48 ? o->op_savefree : ix == 49 ? o->op_static : ix == 50 ? o->op_folded + : ix == 51 ? o->op_moresib : o->op_spare))); break; - case 33: /* children */ + case 33: /* B::LISTOP::children */ { OP *kid; UV i = 0; - for (kid = ((LISTOP*)o)->op_first; kid; kid = kid->op_sibling) + for (kid = ((LISTOP*)o)->op_first; kid; kid = OpSIBLING(kid)) i++; ret = sv_2mortal(newSVuv(i)); } break; - case 34: /* pmreplroot */ + case 34: /* B::PMOP::pmreplroot */ if (cPMOPo->op_type == OP_PUSHRE) { #ifdef USE_ITHREADS ret = sv_newmortal(); @@ -1124,16 +1146,16 @@ next(o) } break; #ifdef USE_ITHREADS - case 35: /* pmstashpv */ + case 35: /* B::PMOP::pmstashpv */ ret = sv_2mortal(newSVpv(PmopSTASHPV(cPMOPo),0)); break; #else - case 36: /* pmstash */ + case 36: /* B::PMOP::pmstash */ ret = make_sv_object(aTHX_ (SV *) PmopSTASH(cPMOPo)); break; #endif - case 37: /* precomp */ - case 38: /* reflags */ + case 37: /* B::PMOP::precomp */ + case 38: /* B::PMOP::reflags */ { REGEXP *rx = PM_GETRE(cPMOPo); ret = sv_newmortal(); @@ -1149,22 +1171,17 @@ next(o) } } break; - case 39: /* sv */ - case 40: /* gv */ - /* It happens that the output typemaps for B::SV and B::GV - * are identical. The "smarts" are in make_sv_object(), - * which determines which class to use based on SvTYPE(), - * rather than anything baked in at compile time. */ - if (cPADOPo->op_padix) { - ret = PAD_SVl(cPADOPo->op_padix); - if (ix == 40 && SvTYPE(ret) != SVt_PVGV) - ret = NULL; - } else { - ret = NULL; - } - ret = make_sv_object(aTHX_ ret); + case 39: /* B::PADOP::sv */ + case 40: /* B::PADOP::gv */ + /* PADOPs should only be created on threaded builds. + * They don't have an sv or gv field, just an op_padix + * field. Leave it to the caller to retrieve padix + * and look up th value in the pad. Don't do it here, + * becuase PL_curpad is the pad of the caller, not the + * pad of the sub the op is part of */ + ret = make_sv_object(aTHX_ NULL); break; - case 41: /* pv */ + case 41: /* B::PVOP::pv */ /* OP_TRANS uses op_pv to point to a table of 256 or >=258 * shorts whereas other PVOPs point to a null terminated * string. */ @@ -1183,23 +1200,67 @@ next(o) else ret = newSVpvn_flags(cPVOPo->op_pv, strlen(cPVOPo->op_pv), SVs_TEMP); break; - case 42: /* label */ + case 42: /* B::COP::label */ ret = sv_2mortal(newSVpv(CopLABEL(cCOPo),0)); break; - case 43: /* arybase */ + case 43: /* B::COP::arybase */ ret = sv_2mortal(newSVuv(0)); break; - case 44: /* warnings */ + case 44: /* B::COP::warnings */ ret = make_warnings_object(aTHX_ cCOPo); break; - case 45: /* io */ + case 45: /* B::COP::io */ ret = make_cop_io_object(aTHX_ cCOPo); break; - case 46: /* hints_hash */ + case 46: /* B::COP::hints_hash */ ret = sv_newmortal(); sv_setiv(newSVrv(ret, "B::RHE"), PTR2IV(CopHINTHASH_get(cCOPo))); break; + case 52: /* B::OP::parent */ +#ifdef PERL_OP_PARENT + ret = make_op_object(aTHX_ op_parent(o)); +#else + ret = make_op_object(aTHX_ NULL); +#endif + break; + case 53: /* B::METHOP::first */ + /* METHOP struct has an op_first/op_meth_sv union + * as its first extra field. How to interpret the + * union depends on the op type. For the purposes of + * B, we treat it as a struct with both fields present, + * where one of the fields always happens to be null + * (i.e. we return NULL in preference to croaking with + * 'method not implemented'). + */ + ret = make_op_object(aTHX_ + o->op_type == OP_METHOD + ? cMETHOPx(o)->op_u.op_first : NULL); + break; + case 54: /* B::METHOP::meth_sv */ + /* see comment above about METHOP */ + ret = make_sv_object(aTHX_ + o->op_type == OP_METHOD + ? NULL : cMETHOPx(o)->op_u.op_meth_sv); + break; + case 55: /* B::PMOP::pmregexp */ + ret = make_sv_object(aTHX_ (SV *)PM_GETRE(cPMOPo)); + break; + case 56: /* B::METHOP::rclass */ +#ifdef USE_ITHREADS + ret = sv_2mortal(newSVuv( + (o->op_type == OP_METHOD_REDIR || + o->op_type == OP_METHOD_REDIR_SUPER) ? + cMETHOPx(o)->op_rclass_targ : 0 + )); +#else + ret = make_sv_object(aTHX_ + (o->op_type == OP_METHOD_REDIR || + o->op_type == OP_METHOD_REDIR_SUPER) ? + cMETHOPx(o)->op_rclass_sv : NULL + ); +#endif + break; default: croak("method %s not implemented", op_methods[ix].name); } else { @@ -1246,6 +1307,161 @@ oplist(o) SP = oplist(aTHX_ o, SP); + +MODULE = B PACKAGE = B::UNOP_AUX + +# UNOP_AUX class ops are like UNOPs except that they have an extra +# op_aux pointer that points to an array of UNOP_AUX_item unions. +# Element -1 of the array contains the length + + +# return a string representation of op_aux where possible The op's CV is +# needed as an extra arg to allow GVs and SVs moved into the pad to be +# accessed okay. + +void +string(o, cv) + B::OP o + B::CV cv + PREINIT: + SV *ret; + PPCODE: + switch (o->op_type) { + case OP_MULTIDEREF: + ret = multideref_stringify(o, cv); + break; + default: + ret = sv_2mortal(newSVpvn("", 0)); + } + ST(0) = ret; + XSRETURN(1); + + +# Return the contents of the op_aux array as a list of IV/GV/etc objects. +# How to interpret each array element is op-dependent. The op's CV is +# needed as an extra arg to allow GVs and SVs which have been moved into +# the pad to be accessed okay. + +void +aux_list(o, cv) + B::OP o + B::CV cv + PPCODE: + PERL_UNUSED_VAR(cv); /* not needed on unthreaded builds */ + switch (o->op_type) { + default: + XSRETURN(0); /* by default, an empty list */ + + case OP_MULTIDEREF: +#ifdef USE_ITHREADS +# define ITEM_SV(item) *av_fetch(comppad, (item)->pad_offset, FALSE); +#else +# define ITEM_SV(item) UNOP_AUX_item_sv(item) +#endif + { + UNOP_AUX_item *items = cUNOP_AUXo->op_aux; + UV actions = items->uv; + UV len = items[-1].uv; + SV *sv; + bool last = 0; + bool is_hash = FALSE; +#ifdef USE_ITHREADS + PADLIST * const padlist = CvPADLIST(cv); + PAD *comppad = PadlistARRAY(padlist)[1]; +#endif + + /* len should never be big enough to truncate or wrap */ + assert(len <= SSize_t_MAX); + EXTEND(SP, (SSize_t)len); + PUSHs(sv_2mortal(newSViv(actions))); + + while (!last) { + switch (actions & MDEREF_ACTION_MASK) { + + case MDEREF_reload: + actions = (++items)->uv; + PUSHs(sv_2mortal(newSVuv(actions))); + continue; + NOT_REACHED; /* NOTREACHED */ + + case MDEREF_HV_padhv_helem: + is_hash = TRUE; + /* FALLTHROUGH */ + case MDEREF_AV_padav_aelem: + PUSHs(sv_2mortal(newSVuv((++items)->pad_offset))); + goto do_elem; + NOT_REACHED; /* NOTREACHED */ + + case MDEREF_HV_gvhv_helem: + is_hash = TRUE; + /* FALLTHROUGH */ + case MDEREF_AV_gvav_aelem: + sv = ITEM_SV(++items); + PUSHs(make_sv_object(aTHX_ sv)); + goto do_elem; + NOT_REACHED; /* NOTREACHED */ + + case MDEREF_HV_gvsv_vivify_rv2hv_helem: + is_hash = TRUE; + /* FALLTHROUGH */ + case MDEREF_AV_gvsv_vivify_rv2av_aelem: + sv = ITEM_SV(++items); + PUSHs(make_sv_object(aTHX_ sv)); + goto do_vivify_rv2xv_elem; + NOT_REACHED; /* NOTREACHED */ + + case MDEREF_HV_padsv_vivify_rv2hv_helem: + is_hash = TRUE; + /* FALLTHROUGH */ + case MDEREF_AV_padsv_vivify_rv2av_aelem: + PUSHs(sv_2mortal(newSVuv((++items)->pad_offset))); + goto do_vivify_rv2xv_elem; + NOT_REACHED; /* NOTREACHED */ + + case MDEREF_HV_pop_rv2hv_helem: + case MDEREF_HV_vivify_rv2hv_helem: + is_hash = TRUE; + /* FALLTHROUGH */ + do_vivify_rv2xv_elem: + case MDEREF_AV_pop_rv2av_aelem: + case MDEREF_AV_vivify_rv2av_aelem: + do_elem: + switch (actions & MDEREF_INDEX_MASK) { + case MDEREF_INDEX_none: + last = 1; + break; + case MDEREF_INDEX_const: + if (is_hash) { + sv = ITEM_SV(++items); + PUSHs(make_sv_object(aTHX_ sv)); + } + else + PUSHs(sv_2mortal(newSViv((++items)->iv))); + break; + case MDEREF_INDEX_padsv: + PUSHs(sv_2mortal(newSVuv((++items)->pad_offset))); + break; + case MDEREF_INDEX_gvsv: + sv = ITEM_SV(++items); + PUSHs(make_sv_object(aTHX_ sv)); + break; + } + if (actions & MDEREF_FLAG_last) + last = 1; + is_hash = FALSE; + + break; + } /* switch */ + + actions >>= MDEREF_SHIFT; + } /* while */ + XSRETURN(len); + + } /* OP_MULTIDEREF */ + } /* switch */ + + + MODULE = B PACKAGE = B::SV #define MAGICAL_FLAG_BITS (SVs_GMG|SVs_SMG|SVs_RMG) @@ -1292,73 +1508,49 @@ MODULE = B PACKAGE = B::IV #define sv_I32p 0xA0000 #define sv_U16p 0xB0000 -#define IV_ivx_ix sv_IVp | offsetof(struct xpviv, xiv_iv) -#define IV_uvx_ix sv_UVp | offsetof(struct xpvuv, xuv_uv) -#define NV_nvx_ix sv_NVp | offsetof(struct xpvnv, xnv_u.xnv_nv) +#define IV_ivx_ix sv_IVp | STRUCT_OFFSET(struct xpviv, xiv_iv) +#define IV_uvx_ix sv_UVp | STRUCT_OFFSET(struct xpvuv, xuv_uv) +#define NV_nvx_ix sv_NVp | STRUCT_OFFSET(struct xpvnv, xnv_u.xnv_nv) -#define NV_cop_seq_range_low_ix \ - sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow) -#define NV_cop_seq_range_high_ix \ - sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh) -#define NV_parent_pad_index_ix \ - sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xlow) -#define NV_parent_fakelex_flags_ix \ - sv_U32p | offsetof(struct xpvnv, xnv_u.xpad_cop_seq.xhigh) +#define PV_cur_ix sv_STRLENp | STRUCT_OFFSET(struct xpv, xpv_cur) +#define PV_len_ix sv_STRLENp | STRUCT_OFFSET(struct xpv, xpv_len) -#define PV_cur_ix sv_STRLENp | offsetof(struct xpv, xpv_cur) -#define PV_len_ix sv_STRLENp | offsetof(struct xpv, xpv_len) +#define PVMG_stash_ix sv_SVp | STRUCT_OFFSET(struct xpvmg, xmg_stash) -#define PVMG_stash_ix sv_SVp | offsetof(struct xpvmg, xmg_stash) +#define PVBM_useful_ix sv_IVp | STRUCT_OFFSET(struct xpviv, xiv_u.xivu_iv) -#if PERL_VERSION > 18 -# define PVBM_useful_ix sv_IVp | offsetof(struct xpviv, xiv_u.xivu_iv) -#elif PERL_VERSION > 14 -# define PVBM_useful_ix sv_I32p | offsetof(struct xpvgv, xnv_u.xbm_s.xbm_useful) -#else -#define PVBM_useful_ix sv_I32p | offsetof(struct xpvgv, xiv_u.xivu_i32) -#endif +#define PVLV_targoff_ix sv_U32p | STRUCT_OFFSET(struct xpvlv, xlv_targoff) +#define PVLV_targlen_ix sv_U32p | STRUCT_OFFSET(struct xpvlv, xlv_targlen) +#define PVLV_targ_ix sv_SVp | STRUCT_OFFSET(struct xpvlv, xlv_targ) +#define PVLV_type_ix sv_char_p | STRUCT_OFFSET(struct xpvlv, xlv_type) -#define PVLV_targoff_ix sv_U32p | offsetof(struct xpvlv, xlv_targoff) -#define PVLV_targlen_ix sv_U32p | offsetof(struct xpvlv, xlv_targlen) -#define PVLV_targ_ix sv_SVp | offsetof(struct xpvlv, xlv_targ) -#define PVLV_type_ix sv_char_p | offsetof(struct xpvlv, xlv_type) - -#define PVGV_stash_ix sv_SVp | offsetof(struct xpvgv, xnv_u.xgv_stash) -#define PVGV_flags_ix sv_STRLENp | offsetof(struct xpvgv, xpv_cur) -#define PVIO_lines_ix sv_IVp | offsetof(struct xpvio, xiv_iv) - -#define PVIO_page_ix sv_IVp | offsetof(struct xpvio, xio_page) -#define PVIO_page_len_ix sv_IVp | offsetof(struct xpvio, xio_page_len) -#define PVIO_lines_left_ix sv_IVp | offsetof(struct xpvio, xio_lines_left) -#define PVIO_top_name_ix sv_char_pp | offsetof(struct xpvio, xio_top_name) -#define PVIO_top_gv_ix sv_SVp | offsetof(struct xpvio, xio_top_gv) -#define PVIO_fmt_name_ix sv_char_pp | offsetof(struct xpvio, xio_fmt_name) -#define PVIO_fmt_gv_ix sv_SVp | offsetof(struct xpvio, xio_fmt_gv) -#define PVIO_bottom_name_ix sv_char_pp | offsetof(struct xpvio, xio_bottom_name) -#define PVIO_bottom_gv_ix sv_SVp | offsetof(struct xpvio, xio_bottom_gv) -#define PVIO_type_ix sv_char_p | offsetof(struct xpvio, xio_type) -#define PVIO_flags_ix sv_U8p | offsetof(struct xpvio, xio_flags) - -#define PVAV_max_ix sv_SSize_tp | offsetof(struct xpvav, xav_max) - -#define PVCV_stash_ix sv_SVp | offsetof(struct xpvcv, xcv_stash) -#if PERL_VERSION > 17 || (PERL_VERSION == 17 && PERL_SUBVERSION >= 3) -# define PVCV_gv_ix sv_SVp | offsetof(struct xpvcv, xcv_gv_u.xcv_gv) -#else -# define PVCV_gv_ix sv_SVp | offsetof(struct xpvcv, xcv_gv) -#endif -#define PVCV_file_ix sv_char_pp | offsetof(struct xpvcv, xcv_file) -#define PVCV_outside_ix sv_SVp | offsetof(struct xpvcv, xcv_outside) -#define PVCV_outside_seq_ix sv_U32p | offsetof(struct xpvcv, xcv_outside_seq) -#define PVCV_flags_ix sv_U32p | offsetof(struct xpvcv, xcv_flags) +#define PVGV_stash_ix sv_SVp | STRUCT_OFFSET(struct xpvgv, xnv_u.xgv_stash) +#define PVGV_flags_ix sv_STRLENp | STRUCT_OFFSET(struct xpvgv, xpv_cur) +#define PVIO_lines_ix sv_IVp | STRUCT_OFFSET(struct xpvio, xiv_iv) -#define PVHV_max_ix sv_STRLENp | offsetof(struct xpvhv, xhv_max) +#define PVIO_page_ix sv_IVp | STRUCT_OFFSET(struct xpvio, xio_page) +#define PVIO_page_len_ix sv_IVp | STRUCT_OFFSET(struct xpvio, xio_page_len) +#define PVIO_lines_left_ix sv_IVp | STRUCT_OFFSET(struct xpvio, xio_lines_left) +#define PVIO_top_name_ix sv_char_pp | STRUCT_OFFSET(struct xpvio, xio_top_name) +#define PVIO_top_gv_ix sv_SVp | STRUCT_OFFSET(struct xpvio, xio_top_gv) +#define PVIO_fmt_name_ix sv_char_pp | STRUCT_OFFSET(struct xpvio, xio_fmt_name) +#define PVIO_fmt_gv_ix sv_SVp | STRUCT_OFFSET(struct xpvio, xio_fmt_gv) +#define PVIO_bottom_name_ix sv_char_pp | STRUCT_OFFSET(struct xpvio, xio_bottom_name) +#define PVIO_bottom_gv_ix sv_SVp | STRUCT_OFFSET(struct xpvio, xio_bottom_gv) +#define PVIO_type_ix sv_char_p | STRUCT_OFFSET(struct xpvio, xio_type) +#define PVIO_flags_ix sv_U8p | STRUCT_OFFSET(struct xpvio, xio_flags) -#if PERL_VERSION > 12 -#define PVHV_keys_ix sv_STRLENp | offsetof(struct xpvhv, xhv_keys) -#else -#define PVHV_keys_ix sv_IVp | offsetof(struct xpvhv, xhv_keys) -#endif +#define PVAV_max_ix sv_SSize_tp | STRUCT_OFFSET(struct xpvav, xav_max) + +#define PVCV_stash_ix sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_stash) +#define PVCV_gv_ix sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_gv_u.xcv_gv) +#define PVCV_file_ix sv_char_pp | STRUCT_OFFSET(struct xpvcv, xcv_file) +#define PVCV_outside_ix sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_outside) +#define PVCV_outside_seq_ix sv_U32p | STRUCT_OFFSET(struct xpvcv, xcv_outside_seq) +#define PVCV_flags_ix sv_U32p | STRUCT_OFFSET(struct xpvcv, xcv_flags) + +#define PVHV_max_ix sv_STRLENp | STRUCT_OFFSET(struct xpvhv, xhv_max) +#define PVHV_keys_ix sv_STRLENp | STRUCT_OFFSET(struct xpvhv, xhv_keys) # The type checking code in B has always been identical for all SV types, # irrespective of whether the action is actually defined on that SV. @@ -1370,10 +1562,6 @@ IVX(sv) B::IV::IVX = IV_ivx_ix B::IV::UVX = IV_uvx_ix B::NV::NVX = NV_nvx_ix - B::NV::COP_SEQ_RANGE_LOW = NV_cop_seq_range_low_ix - B::NV::COP_SEQ_RANGE_HIGH = NV_cop_seq_range_high_ix - B::NV::PARENT_PAD_INDEX = NV_parent_pad_index_ix - B::NV::PARENT_FAKELEX_FLAGS = NV_parent_fakelex_flags_ix B::PV::CUR = PV_cur_ix B::PV::LEN = PV_len_ix B::PVMG::SvSTASH = PVMG_stash_ix @@ -1488,18 +1676,6 @@ NV SvNV(sv) B::NV sv -#if PERL_VERSION < 11 - -MODULE = B PACKAGE = B::RV PREFIX = Sv - -void -SvRV(sv) - B::RV sv - PPCODE: - PUSHs(make_sv_object(aTHX_ SvRV(sv))); - -#else - MODULE = B PACKAGE = B::REGEXP void @@ -1507,17 +1683,22 @@ REGEX(sv) B::REGEXP sv ALIAS: precomp = 1 + qr_anoncv = 2 + compflags = 3 PPCODE: - if (ix) { + if (ix == 1) { PUSHs(newSVpvn_flags(RX_PRECOMP(sv), RX_PRELEN(sv), SVs_TEMP)); + } else if (ix == 2) { + PUSHs(make_sv_object(aTHX_ (SV *)ReANY(sv)->qr_anoncv)); } else { dXSTARG; + if (ix) + PUSHu(RX_COMPFLAGS(sv)); + else /* FIXME - can we code this method more efficiently? */ - PUSHi(PTR2IV(sv)); + PUSHi(PTR2IV(sv)); } -#endif - MODULE = B PACKAGE = B::PV void @@ -1689,9 +1870,7 @@ U32 BmPREVIOUS(sv) B::BM sv CODE: -#if PERL_VERSION >= 19 PERL_UNUSED_VAR(sv); -#endif RETVAL = BmPREVIOUS(sv); OUTPUT: RETVAL @@ -1701,9 +1880,7 @@ U8 BmRARE(sv) B::BM sv CODE: -#if PERL_VERSION >= 19 PERL_UNUSED_VAR(sv); -#endif RETVAL = BmRARE(sv); OUTPUT: RETVAL @@ -1740,16 +1917,15 @@ void* GvGP(gv) B::GV gv -#define GP_sv_ix (SVp << 16) | offsetof(struct gp, gp_sv) -#define GP_io_ix (SVp << 16) | offsetof(struct gp, gp_io) -#define GP_cv_ix (SVp << 16) | offsetof(struct gp, gp_cv) -#define GP_cvgen_ix (U32p << 16) | offsetof(struct gp, gp_cvgen) -#define GP_refcnt_ix (U32p << 16) | offsetof(struct gp, gp_refcnt) -#define GP_hv_ix (SVp << 16) | offsetof(struct gp, gp_hv) -#define GP_av_ix (SVp << 16) | offsetof(struct gp, gp_av) -#define GP_form_ix (SVp << 16) | offsetof(struct gp, gp_form) -#define GP_egv_ix (SVp << 16) | offsetof(struct gp, gp_egv) -#define GP_line_ix (line_tp << 16) | offsetof(struct gp, gp_line) +#define GP_sv_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_sv) +#define GP_io_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_io) +#define GP_cv_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_cv) +#define GP_cvgen_ix (U32p << 16) | STRUCT_OFFSET(struct gp, gp_cvgen) +#define GP_refcnt_ix (U32p << 16) | STRUCT_OFFSET(struct gp, gp_refcnt) +#define GP_hv_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_hv) +#define GP_av_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_av) +#define GP_form_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_form) +#define GP_egv_ix (SVp << 16) | STRUCT_OFFSET(struct gp, gp_egv) void SV(gv) @@ -1764,7 +1940,6 @@ SV(gv) AV = GP_av_ix FORM = GP_form_ix EGV = GP_egv_ix - LINE = GP_line_ix PREINIT: GP *gp; char *ptr; @@ -1783,15 +1958,20 @@ SV(gv) case U32p: ret = sv_2mortal(newSVuv(*((U32*)ptr))); break; - case line_tp: - ret = sv_2mortal(newSVuv(*((line_t *)ptr))); - break; default: croak("Illegal alias 0x%08x for B::*SV", (unsigned)ix); } ST(0) = ret; XSRETURN(1); +U32 +GvLINE(gv) + B::GV gv + +U32 +GvGPFLAGS(gv) + B::GV gv + void FILEGV(gv) B::GV gv @@ -1888,6 +2068,10 @@ CvDEPTH(cv) B::PADLIST CvPADLIST(cv) B::CV cv + CODE: + RETVAL = CvISXSUB(cv) ? NULL : CvPADLIST(cv); + OUTPUT: + RETVAL #else @@ -1900,6 +2084,14 @@ CvPADLIST(cv) #endif +SV * +CvHSCXT(cv) + B::CV cv + CODE: + RETVAL = newSVuv(CvISXSUB(cv) ? PTR2UV(CvHSCXT(cv)) : 0); + OUTPUT: + RETVAL + void CvXSUB(cv) B::CV cv @@ -1925,8 +2117,6 @@ GV(cv) CODE: ST(0) = make_sv_object(aTHX_ (SV*)CvGV(cv)); -#if PERL_VERSION > 17 - SV * NAME_HEK(cv) B::CV cv @@ -1935,8 +2125,6 @@ NAME_HEK(cv) OUTPUT: RETVAL -#endif - MODULE = B PACKAGE = B::HV PREFIX = Hv STRLEN @@ -1953,8 +2141,12 @@ HvARRAY(hv) PPCODE: if (HvUSEDKEYS(hv) > 0) { HE *he; + SSize_t extend_size; (void)hv_iterinit(hv); - EXTEND(sp, HvUSEDKEYS(hv) * 2); + /* 2*HvUSEDKEYS() should never be big enough to truncate or wrap */ + assert(HvUSEDKEYS(hv) <= (SSize_t_MAX >> 1)); + extend_size = (SSize_t)HvUSEDKEYS(hv) * 2; + EXTEND(sp, extend_size); while ((he = hv_iternext(hv))) { if (HeSVKEY(he)) { mPUSHs(HeSVKEY(he)); @@ -1999,15 +2191,31 @@ MODULE = B PACKAGE = B::PADLIST PREFIX = Padlist SSize_t PadlistMAX(padlist) B::PADLIST padlist + ALIAS: B::PADNAMELIST::MAX = 0 + CODE: + PERL_UNUSED_VAR(ix); + RETVAL = PadlistMAX(padlist); + OUTPUT: + RETVAL + +B::PADNAMELIST +PadlistNAMES(padlist) + B::PADLIST padlist void PadlistARRAY(padlist) B::PADLIST padlist PPCODE: if (PadlistMAX(padlist) >= 0) { + dXSTARG; PAD **padp = PadlistARRAY(padlist); SSize_t i; - for (i = 0; i <= PadlistMAX(padlist); i++) + sv_setiv(newSVrv(TARG, PadlistNAMES(padlist) + ? "B::PADNAMELIST" + : "B::NULL"), + PTR2IV(PadlistNAMES(padlist))); + XPUSHTARG; + for (i = 1; i <= PadlistMAX(padlist); i++) XPUSHs(make_sv_object(aTHX_ (SV *)padp[i])); } @@ -2016,12 +2224,17 @@ PadlistARRAYelt(padlist, idx) B::PADLIST padlist SSize_t idx PPCODE: - if (PadlistMAX(padlist) >= 0 - && idx <= PadlistMAX(padlist)) + if (idx < 0 || idx > PadlistMAX(padlist)) + XPUSHs(make_sv_object(aTHX_ NULL)); + else if (!idx) { + PL_stack_sp--; + PUSHMARK(PL_stack_sp-1); + XS_B__PADLIST_NAMES(aTHX_ cv); + return; + } + else XPUSHs(make_sv_object(aTHX_ (SV *)PadlistARRAY(padlist)[idx])); - else - XPUSHs(make_sv_object(aTHX_ NULL)); U32 PadlistREFCNT(padlist) @@ -2033,3 +2246,131 @@ PadlistREFCNT(padlist) RETVAL #endif + +MODULE = B PACKAGE = B::PADNAMELIST PREFIX = Padnamelist + +void +PadnamelistARRAY(pnl) + B::PADNAMELIST pnl + PPCODE: + if (PadnamelistMAX(pnl) >= 0) { + PADNAME **padp = PadnamelistARRAY(pnl); + SSize_t i = 0; + for (; i <= PadnamelistMAX(pnl); i++) + { + SV *rv = sv_newmortal(); + sv_setiv(newSVrv(rv,padp[i] ? "B::PADNAME" : "B::SPECIAL"), + PTR2IV(padp[i])); + XPUSHs(rv); + } + } + +B::PADNAME +PadnamelistARRAYelt(pnl, idx) + B::PADNAMELIST pnl + SSize_t idx + CODE: + if (idx < 0 || idx > PadnamelistMAX(pnl)) + RETVAL = NULL; + else + RETVAL = PadnamelistARRAY(pnl)[idx]; + OUTPUT: + RETVAL + +MODULE = B PACKAGE = B::PADNAME PREFIX = Padname + +#define PN_type_ix \ + sv_SVp | STRUCT_OFFSET(struct padname,xpadn_type_u.xpadn_typestash) +#define PN_ourstash_ix \ + sv_SVp | STRUCT_OFFSET(struct padname,xpadn_ourstash) +#define PN_len_ix \ + sv_U8p | STRUCT_OFFSET(struct padname,xpadn_len) +#define PN_refcnt_ix \ + sv_U32p | STRUCT_OFFSET(struct padname, xpadn_refcnt) +#define PN_cop_seq_range_low_ix \ + sv_U32p | STRUCT_OFFSET(struct padname, xpadn_low) +#define PN_cop_seq_range_high_ix \ + sv_U32p | STRUCT_OFFSET(struct padname, xpadn_high) +#define PNL_refcnt_ix \ + sv_U32p | STRUCT_OFFSET(struct padnamelist, xpadnl_refcnt) +#define PL_id_ix \ + sv_U32p | STRUCT_OFFSET(struct padlist, xpadl_id) +#define PL_outid_ix \ + sv_U32p | STRUCT_OFFSET(struct padlist, xpadl_outid) + + +void +PadnameTYPE(pn) + B::PADNAME pn + ALIAS: + B::PADNAME::TYPE = PN_type_ix + B::PADNAME::OURSTASH = PN_ourstash_ix + B::PADNAME::LEN = PN_len_ix + B::PADNAME::REFCNT = PN_refcnt_ix + B::PADNAME::COP_SEQ_RANGE_LOW = PN_cop_seq_range_low_ix + B::PADNAME::COP_SEQ_RANGE_HIGH = PN_cop_seq_range_high_ix + B::PADNAMELIST::REFCNT = PNL_refcnt_ix + B::PADLIST::id = PL_id_ix + B::PADLIST::outid = PL_outid_ix + PREINIT: + char *ptr; + SV *ret; + PPCODE: + ptr = (ix & 0xFFFF) + (char *)pn; + switch ((U8)(ix >> 16)) { + case (U8)(sv_SVp >> 16): + ret = make_sv_object(aTHX_ *((SV **)ptr)); + break; + case (U8)(sv_U32p >> 16): + ret = sv_2mortal(newSVuv(*((U32 *)ptr))); + break; + case (U8)(sv_U8p >> 16): + ret = sv_2mortal(newSVuv(*((U8 *)ptr))); + break; + default: + NOT_REACHED; + } + ST(0) = ret; + XSRETURN(1); + +SV * +PadnamePV(pn) + B::PADNAME pn + PREINIT: + dXSTARG; + PPCODE: + PERL_UNUSED_ARG(RETVAL); + sv_setpvn(TARG, PadnamePV(pn), PadnameLEN(pn)); + SvUTF8_on(TARG); + XPUSHTARG; + +BOOT: +{ + /* Uses less memory than an ALIAS. */ + GV *gv = gv_fetchpvs("B::PADNAME::TYPE", 1, SVt_PVGV); + sv_setsv((SV *)gv_fetchpvs("B::PADNAME::SvSTASH",1,SVt_PVGV),(SV *)gv); + sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PROTOCV",1,SVt_PVGV),(SV *)gv); + sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PVX",1,SVt_PVGV), + (SV *)gv_fetchpvs("B::PADNAME::PV" ,1,SVt_PVGV)); + sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PARENT_PAD_INDEX" ,1,SVt_PVGV), + (SV *)gv_fetchpvs("B::PADNAME::COP_SEQ_RANGE_LOW",1, + SVt_PVGV)); + sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PARENT_FAKELEX_FLAGS",1, + SVt_PVGV), + (SV *)gv_fetchpvs("B::PADNAME::COP_SEQ_RANGE_HIGH" ,1, + SVt_PVGV)); +} + +U32 +PadnameFLAGS(pn) + B::PADNAME pn + CODE: + RETVAL = PadnameFLAGS(pn); + /* backward-compatibility hack, which should be removed if the + flags field becomes large enough to hold SVf_FAKE (and + PADNAMEt_OUTER should be renumbered to match SVf_FAKE) */ + STATIC_ASSERT_STMT(SVf_FAKE >= 1<<(sizeof(PadnameFLAGS((B__PADNAME)NULL)) * 8)); + if (PadnameOUTER(pn)) + RETVAL |= SVf_FAKE; + OUTPUT: + RETVAL diff --git a/gnu/usr.bin/perl/ext/B/B/Concise.pm b/gnu/usr.bin/perl/ext/B/B/Concise.pm index 6c818a4e463..311e0e738a9 100644 --- a/gnu/usr.bin/perl/ext/B/B/Concise.pm +++ b/gnu/usr.bin/perl/ext/B/B/Concise.pm @@ -14,7 +14,7 @@ use warnings; # uses #3 and #4, since warnings uses Carp use Exporter (); # use #5 -our $VERSION = "0.992"; +our $VERSION = "0.996"; our @ISA = qw(Exporter); our @EXPORT_OK = qw( set_style set_style_standard add_callback concise_subref concise_cv concise_main @@ -400,7 +400,8 @@ my $lastnext; # remembers op-chain, used to insert gotos my %opclass = ('OP' => "0", 'UNOP' => "1", 'BINOP' => "2", 'LOGOP' => "|", 'LISTOP' => "@", 'PMOP' => "/", 'SVOP' => "\$", 'GVOP' => "*", - 'PVOP' => '"', 'LOOP' => "{", 'COP' => ";", 'PADOP' => "#"); + 'PVOP' => '"', 'LOOP' => "{", 'COP' => ";", 'PADOP' => "#", + 'METHOP' => '.', UNOP_AUX => '+'); no warnings 'qw'; # "Possible attempt to put comments..."; use #7 my @linenoise = @@ -471,7 +472,12 @@ sub walk_topdown { } } if (class($op) eq "PMOP") { - my $maybe_root = $op->pmreplroot; + my $maybe_root = $op->code_list; + if ( ref($maybe_root) and $maybe_root->isa("B::OP") + and not $op->flags & OPf_KIDS) { + walk_topdown($maybe_root, $sub, $level + 1); + } + $maybe_root = $op->pmreplroot; if (ref($maybe_root) and $maybe_root->isa("B::OP")) { # It really is the root of the replacement, not something # else stored here for lack of space elsewhere @@ -527,29 +533,15 @@ sub sequence { for (; $$op; $op = $op->next) { last if exists $sequence_num{$$op}; my $name = $op->name; - if ($name =~ /^(null|scalar|lineseq|scope)$/) { - next if $oldop and $ {$op->next}; - } else { - $sequence_num{$$op} = $seq_max++; - if (class($op) eq "LOGOP") { - my $other = $op->other; - $other = $other->next while $other->name eq "null"; - sequence($other); - } elsif (class($op) eq "LOOP") { - my $redoop = $op->redoop; - $redoop = $redoop->next while $redoop->name eq "null"; - sequence($redoop); - my $nextop = $op->nextop; - $nextop = $nextop->next while $nextop->name eq "null"; - sequence($nextop); - my $lastop = $op->lastop; - $lastop = $lastop->next while $lastop->name eq "null"; - sequence($lastop); - } elsif ($name eq "subst" and $ {$op->pmreplstart}) { - my $replstart = $op->pmreplstart; - $replstart = $replstart->next while $replstart->name eq "null"; - sequence($replstart); - } + $sequence_num{$$op} = $seq_max++; + if (class($op) eq "LOGOP") { + sequence($op->other); + } elsif (class($op) eq "LOOP") { + sequence($op->redoop); + sequence( $op->nextop); + sequence($op->lastop); + } elsif ($name eq "subst" and $ {$op->pmreplstart}) { + sequence($op->pmreplstart); } $oldop = $op; } @@ -592,73 +584,13 @@ sub fmt_line { # generate text-line for op. return $text; # suppress empty lines } -our %priv; # used to display each opcode's BASEOP.op_private values - -$priv{$_}{128} = "LVINTRO" - for qw(pos substr vec threadsv gvsv rv2sv rv2hv rv2gv rv2av rv2arylen - aelem helem aslice hslice padsv padav padhv enteriter entersub - padrange pushmark); -$priv{$_}{64} = "REFC" for qw(leave leavesub leavesublv leavewrite); -$priv{$_}{128} = "LV" for qw(leave leaveloop); -@{$priv{aassign}}{32,64} = qw(STATE COMMON); -@{$priv{sassign}}{32,64,128} = qw(STATE BKWARD CV2GV); -$priv{$_}{64} = "RTIME" for qw(match subst substcont qr); -@{$priv{$_}}{1,2,4,8,16,64} = qw(<UTF >UTF IDENT SQUASH DEL COMPL GROWS) - for qw(trans transr); -$priv{repeat}{64} = "DOLIST"; -$priv{leaveloop}{64} = "CONT"; -@{$priv{$_}}{32,64,96} = qw(DREFAV DREFHV DREFSV) - for qw(rv2gv rv2sv padsv aelem helem); -$priv{$_}{16} = "STATE" for qw(padav padhv padsv); -@{$priv{rv2gv}}{4,16} = qw(NOINIT FAKE); -@{$priv{entersub}}{1,4,16,32,64} = qw(INARGS TARG DBG DEREF); -@{$priv{rv2cv}}{1,8,128} = qw(CONST AMPER NO()); -$priv{gv}{32} = "EARLYCV"; -$priv{$_}{16} = "LVDEFER" for qw(aelem helem); -$priv{$_}{16} = "OURINTR" for qw(gvsv rv2sv rv2av rv2hv r2gv enteriter); -$priv{$_}{8} = "LVSUB" - for qw(rv2av rv2gv rv2hv padav padhv aelem helem aslice hslice - av2arylen keys rkeys substr pos vec); -$priv{$_}{4} = "SLICEWARN" - for qw(rv2hv rv2av padav padhv hslice aslice); -@{$priv{$_}}{32,64} = qw(BOOL BOOL?) for qw(rv2hv padhv); -$priv{substr}{16} = "REPL1ST"; -$priv{$_}{16} = "TARGMY" - for map(($_,"s$_"), qw(chop chomp)), - map(($_,"i_$_"), qw(postinc postdec multiply divide modulo add - subtract negate)), - qw(pow concat stringify left_shift right_shift bit_and bit_xor - bit_or complement atan2 sin cos rand exp log sqrt int hex oct - abs length index rindex sprintf ord chr crypt quotemeta join - push unshift flock chdir chown chroot unlink chmod utime rename - link symlink mkdir rmdir wait waitpid system exec kill getppid - getpgrp setpgrp getpriority setpriority time sleep); -$priv{$_}{4} = "REVERSED" for qw(enteriter iter); -@{$priv{const}}{2,4,8,16,64} = qw(NOVER SHORT STRICT ENTERED BARE); -$priv{$_}{64} = "LINENUM" for qw(flip flop); -$priv{list}{64} = "GUESSED"; -$priv{delete}{64} = "SLICE"; -$priv{exists}{64} = "SUB"; -@{$priv{sort}}{1,2,4,8,16,32,64} = qw(NUM INT REV INPLACE DESC QSORT STABLE); -$priv{reverse}{8} = "INPLACE"; -$priv{threadsv}{64} = "SVREFd"; -@{$priv{$_}}{16,32,64,128} = qw(INBIN INCR OUTBIN OUTCR) - for qw(open backtick); -$priv{$_}{32} = "HUSH" for qw(nextstate dbstate); -$priv{$_}{2} = "FTACCESS" - for qw(ftrread ftrwrite ftrexec fteread ftewrite fteexec); -@{$priv{entereval}}{2,4,8,16} = qw(HAS_HH UNI BYTES COPHH); -@{$priv{$_}}{4,8,16} = qw(FTSTACKED FTSTACKING FTAFTERt) - for qw(ftrread ftrwrite ftrexec fteread ftewrite fteexec ftis fteowned - ftrowned ftzero ftsize ftmtime ftatime ftctime ftsock ftchr - ftblk ftfile ftdir ftpipe ftlink ftsuid ftsgid ftsvtx fttty - fttext ftbinary); -$priv{$_}{2} = "GREPLEX" - for qw(mapwhile mapstart grepwhile grepstart); -$priv{$_}{128} = "+1" for qw(caller wantarray runcv); -@{$priv{coreargs}}{1,2,64,128} = qw(DREF1 DREF2 $MOD MARK); -$priv{$_}{128} = "UTF" for qw(last redo next goto dump); -$priv{split}{128} = "IMPLIM"; + + +# use require rather than use here to avoid disturbing tests that dump +# BEGIN blocks +require B::Op_private; + + our %hints; # used to display each COP's op_hints values @@ -688,9 +620,61 @@ sub _flags { return join(",", @s); } +# return a string like 'LVINTRO,1' for the op $name with op_private +# value $x + sub private_flags { my($name, $x) = @_; - _flags($priv{$name}, $x); + my $entry = $B::Op_private::bits{$name}; + return $x ? "$x" : '' unless $entry; + + my @flags; + my $bit; + for ($bit = 7; $bit >= 0; $bit--) { + next unless exists $entry->{$bit}; + my $e = $entry->{$bit}; + if (ref($e) eq 'HASH') { + # bit field + + my ($bitmin, $bitmax, $bitmask, $enum, $label) = + @{$e}{qw(bitmin bitmax bitmask enum label)}; + $bit = $bitmin; + next if defined $label && $label eq '-'; # display as raw number + + my $val = $x & $bitmask; + $x &= ~$bitmask; + $val >>= $bitmin; + + if (defined $enum) { + # try to convert numeric $val into symbolic + my @enum = @$enum; + while (@enum) { + my $ix = shift @enum; + my $name = shift @enum; + my $label = shift @enum; + if ($val == $ix) { + $val = $label; + last; + } + } + } + next if $val eq '0'; # don't display anonymous zero values + push @flags, defined $label ? "$label=$val" : $val; + + } + else { + # flag bit + my $label = $B::Op_private::labels{$e}; + next if defined $label && $label eq '-'; # display as raw number + if ($x & (1<<$bit)) { + $x -= (1<<$bit); + push @flags, $label; + } + } + } + + push @flags, $x if $x; # display unknown bits numerically + return join ",", @flags; } sub hints_flags { @@ -779,23 +763,35 @@ sub concise_op { $h{class} = class($op); $h{extarg} = $h{targ} = $op->targ; $h{extarg} = "" unless $h{extarg}; - if ($h{name} eq "null" and $h{targ}) { - # targ holds the old type - $h{exname} = "ex-" . substr(ppname($h{targ}), 3); + $h{privval} = $op->private; + # for null ops, targ holds the old type + my $origname = $h{name} eq "null" && $h{targ} + ? substr(ppname($h{targ}), 3) + : $h{name}; + $h{private} = private_flags($origname, $op->private); + if ($op->folded) { + $h{private} &&= "$h{private},"; + $h{private} .= "FOLD"; + } + + if ($h{name} ne $origname) { # a null op + $h{exname} = "ex-$origname"; $h{extarg} = ""; - } elsif ($op->name =~ /^leave(sub(lv)?|write)?$/) { - # targ potentially holds a reference count - if ($op->private & 64) { - my $refs = "ref" . ($h{targ} != 1 ? "s" : ""); - $h{targarglife} = $h{targarg} = "$h{targ} $refs"; - } + } elsif ($h{private} =~ /\bREFC\b/) { + # targ holds a reference count + my $refs = "ref" . ($h{targ} != 1 ? "s" : ""); + $h{targarglife} = $h{targarg} = "$h{targ} $refs"; } elsif ($h{targ}) { - my $count = $h{name} eq 'padrange' ? ($op->private & 127) : 1; + my $count = $h{name} eq 'padrange' + ? ($op->private & $B::Op_private::defines{'OPpPADRANGE_COUNTMASK'}) + : 1; my (@targarg, @targarglife); for my $i (0..$count-1) { my ($targarg, $targarglife); my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}+$i]; - if (defined $padname and class($padname) ne "SPECIAL") { + if (defined $padname and class($padname) ne "SPECIAL" and + $padname->LEN) + { $targarg = $padname->PVX; if ($padname->FLAGS & SVf_FAKE) { # These changes relate to the jumbo closure fix. @@ -892,16 +888,37 @@ sub concise_op { elsif ($h{class} eq "SVOP" or $h{class} eq "PADOP") { unless ($h{name} eq 'aelemfast' and $op->flags & OPf_SPECIAL) { my $idx = ($h{class} eq "SVOP") ? $op->targ : $op->padix; - my $preferpv = $h{name} eq "method_named"; if ($h{class} eq "PADOP" or !${$op->sv}) { my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$idx]; - $h{arg} = "[" . concise_sv($sv, \%h, $preferpv) . "]"; + $h{arg} = "[" . concise_sv($sv, \%h, 0) . "]"; $h{targarglife} = $h{targarg} = ""; } else { - $h{arg} = "(" . concise_sv($op->sv, \%h, $preferpv) . ")"; + $h{arg} = "(" . concise_sv($op->sv, \%h, 0) . ")"; } } } + elsif ($h{class} eq "METHOP") { + my $prefix = ''; + if ($h{name} eq 'method_redir' or $h{name} eq 'method_redir_super') { + my $rclass_sv = $op->rclass; + $rclass_sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$rclass_sv] + unless ref $rclass_sv; + $prefix .= 'PACKAGE "'.$rclass_sv->PV.'", '; + } + if ($h{name} ne "method") { + if (${$op->meth_sv}) { + $h{arg} = "($prefix" . concise_sv($op->meth_sv, \%h, 1) . ")"; + } else { + my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$op->targ]; + $h{arg} = "[$prefix" . concise_sv($sv, \%h, 1) . "]"; + $h{targarglife} = $h{targarg} = ""; + } + } + } + elsif ($h{class} eq "UNOP_AUX") { + $h{arg} = "(" . $op->string($curcv) . ")"; + } + $h{seq} = $h{hyphseq} = seq($op); $h{seq} = "" if $h{seq} eq "-"; $h{opt} = $op->opt; @@ -916,12 +933,6 @@ sub concise_op { $h{classsym} = $opclass{$h{class}}; $h{flagval} = $op->flags; $h{flags} = op_flags($op->flags); - $h{privval} = $op->private; - $h{private} = private_flags($h{name}, $op->private); - if ($op->folded) { - $h{private} &&= "$h{private},"; - $h{private} .= "FOLD"; - } if ($op->can("hints")) { $h{hintsval} = $op->hints; $h{hints} = hints_flags($h{hintsval}); @@ -1046,8 +1057,7 @@ sub tree { # to update the corresponding magic number in the next line. # Remember, this needs to stay the last things in the module. -# Why is this different for MacOS? Does it matter? -my $cop_seq_mnum = $^O eq 'MacOS' ? 12 : 11; +my $cop_seq_mnum = 16; $cop_seq_base = svref_2object(eval 'sub{0;}')->START->cop_seq + $cop_seq_mnum; 1; @@ -1377,6 +1387,7 @@ B:: namespace that represents the ops in your Perl code. 0 OP (aka BASEOP) An OP with no children 1 UNOP An OP with one child + + UNOP_AUX A UNOP with auxillary fields 2 BINOP An OP with two children | LOGOP A control branch OP @ LISTOP An OP that could have lots of children @@ -1386,6 +1397,7 @@ B:: namespace that represents the ops in your Perl code. { LOOP An OP that holds pointers for a loop ; COP An OP that marks the start of a statement # PADOP An OP with a GV on the pad + . METHOP An OP with method call info =head2 OP flags abbreviations @@ -1413,10 +1425,7 @@ Private flags, if any are set for an opcode, are displayed after a '/' They're opcode specific, and occur less often than the public ones, so they're represented by short mnemonics instead of single-chars; see -F<op.h> for gory details, or try this quick 2-liner: - - $> perl -MB::Concise -de 1 - DB<1> |x \%B::Concise::priv +B::Op_private and F<regen/op_private> for more details. =head1 FORMATTING SPECIFICATIONS diff --git a/gnu/usr.bin/perl/ext/B/B/Showlex.pm b/gnu/usr.bin/perl/ext/B/B/Showlex.pm index ab684516100..1ad230e7bdf 100644 --- a/gnu/usr.bin/perl/ext/B/B/Showlex.pm +++ b/gnu/usr.bin/perl/ext/B/B/Showlex.pm @@ -1,6 +1,6 @@ package B::Showlex; -our $VERSION = '1.04'; +our $VERSION = '1.05'; use strict; use B qw(svref_2object comppadlist class); @@ -36,7 +36,8 @@ sub shownamearray { for ($i = 0; $i < $count; $i++) { my $sv = $els[$i]; if (class($sv) ne "SPECIAL") { - printf $walkHandle "$i: %s (0x%lx) %s\n", class($sv), $$sv, $sv->PVX; + printf $walkHandle "$i: (0x%lx) %s\n", + $$sv, $sv->PVX // "undef" || "const"; } else { printf $walkHandle "$i: %s\n", $sv->terse; #printf $walkHandle "$i: %s\n", B::Concise::concise_sv($sv); @@ -64,16 +65,27 @@ sub showlex { my ($newlex, $nosp1); # rendering state vars +sub padname_terse { + my $name = shift; + return $name->terse if class($name) eq 'SPECIAL'; + my $str = $name->PVX; + return sprintf "(0x%lx) %s", + $$name, + length $str ? qq'"$str"' : defined $str ? "const" : 'undef'; +} + sub newlex { # drop-in for showlex my ($objname, $names, $vals) = @_; my @names = $names->ARRAY; my @vals = $vals->ARRAY; my $count = @names; print $walkHandle "$objname Pad has $count entries\n"; - printf $walkHandle "0: %s\n", $names[0]->terse unless $nosp1; + printf $walkHandle "0: %s\n", padname_terse($names[0]) unless $nosp1; for (my $i = 1; $i < $count; $i++) { - printf $walkHandle "$i: %s = %s\n", $names[$i]->terse, $vals[$i]->terse - unless $nosp1 and $names[$i]->terse =~ /SPECIAL/; + printf $walkHandle "$i: %s = %s\n", padname_terse($names[$i]), + $vals[$i]->terse, + unless $nosp1 + and class($names[$i]) eq 'SPECIAL' || !$names[$i]->LEN; } } @@ -143,10 +155,10 @@ Traditional form: $ perl -MO=Showlex -e 'my ($i,$j,$k)=(1,"foo")' Pad of lexical names for comppadlist has 4 entries - 0: SPECIAL #1 &PL_sv_undef - 1: PVNV (0x9db0fb0) $i - 2: PVNV (0x9db0f38) $j - 3: PVNV (0x9db0f50) $k + 0: (0x8caea4) undef + 1: (0x9db0fb0) $i + 2: (0x9db0f38) $j + 3: (0x9db0f50) $k Pad of lexical values for comppadlist has 5 entries 0: SPECIAL #1 &PL_sv_undef 1: NULL (0x9da4234) @@ -159,10 +171,10 @@ New-style form: $ perl -MO=Showlex,-newlex -e 'my ($i,$j,$k)=(1,"foo")' main Pad has 4 entries - 0: SPECIAL #1 &PL_sv_undef - 1: PVNV (0xa0c4fb8) "$i" = NULL (0xa0b8234) - 2: PVNV (0xa0c4f40) "$j" = NULL (0xa0c4f34) - 3: PVNV (0xa0c4f58) "$k" = NULL (0xa0c4f4c) + 0: (0x8caea4) undef + 1: (0xa0c4fb8) "$i" = NULL (0xa0b8234) + 2: (0xa0c4f40) "$j" = NULL (0xa0c4f34) + 3: (0xa0c4f58) "$k" = NULL (0xa0c4f4c) -e syntax OK New form, no specials, outside O framework: @@ -170,9 +182,9 @@ New form, no specials, outside O framework: $ perl -MB::Showlex -e \ 'my ($i,$j,$k)=(1,"foo"); B::Showlex::compile(-newlex,-nosp)->()' main Pad has 4 entries - 1: PVNV (0x998ffb0) "$i" = IV (0x9983234) 1 - 2: PVNV (0x998ff68) "$j" = PV (0x998ff5c) "foo" - 3: PVNV (0x998ff80) "$k" = NULL (0x998ff74) + 1: (0x998ffb0) "$i" = IV (0x9983234) 1 + 2: (0x998ff68) "$j" = PV (0x998ff5c) "foo" + 3: (0x998ff80) "$k" = NULL (0x998ff74) Note that this example shows the values of the lexicals, whereas the other examples did not (as they're compile-time only). diff --git a/gnu/usr.bin/perl/ext/B/Makefile.PL b/gnu/usr.bin/perl/ext/B/Makefile.PL index 8767b5e3dd7..e34b86714f0 100644 --- a/gnu/usr.bin/perl/ext/B/Makefile.PL +++ b/gnu/usr.bin/perl/ext/B/Makefile.PL @@ -6,12 +6,6 @@ use warnings; my $core = grep { $_ eq 'PERL_CORE=1' } @ARGV; -WriteMakefile( - NAME => "B", - VERSION_FROM => "B.pm", - realclean => {FILES=> 'const-c.inc const-xs.inc'}, -); - my $headerpath; if ($core) { $headerpath = File::Spec->catdir(File::Spec->updir, File::Spec->updir); @@ -21,8 +15,10 @@ if ($core) { } my @names = ({ name => 'HEf_SVKEY', macro => 1, type => "IV" }, - qw(SVTYPEMASK SVt_PVGV SVt_PVHV PAD_FAKELEX_ANON PAD_FAKELEX_MULTI)); + qw(SVTYPEMASK SVt_PVGV SVt_PVHV PAD_FAKELEX_ANON + PAD_FAKELEX_MULTI SVpad_STATE SVpad_TYPED SVpad_OUR)); +my @depend; # First element in each tuple is the file; second is a regex snippet # giving the prefix to limit the names of symbols to define that come @@ -30,26 +26,41 @@ my @names = ({ name => 'HEf_SVKEY', macro => 1, type => "IV" }, # match the pattern below. foreach my $tuple (['cop.h'], ['cv.h', 'CVf'], - ['gv.h', 'GVf'], + ['gv.h', 'G[PV]f'], ['op.h'], + ['opcode.h', 'OPp'], ['op_reg_common.h','(?:(?:RXf_)?PMf_)'], + ['pad.h','PADNAMEt_'], ['regexp.h','RXf_'], ['sv.h', 'SV(?:[fps]|pad)_'], ) { my $file = $tuple->[0]; my $pfx = $tuple->[1] || ''; my $path = File::Spec->catfile($headerpath, $file); + push @depend, $path; open my $fh, '<', $path or die "Cannot open $path: $!"; while (<$fh>) { push @names, $1 if (/ \#define \s+ ( $pfx \w+ ) \s+ - ( [()|\dx]+ # Parens, '|', digits, 'x' - | \(? \d+ \s* << .*? # digits left shifted by anything - ) \s* (?: $| \/ \* ) # ending at comment or $ - /x); + ( [()|\dx]+ [UuLl]{0,2} # Parens, '|', digits, 'x', + # followed by optional long, + # unsigned qualifiers + | 0x[0-9a-fA-F]+ # hex values + | \(? \d+ [UuLl]{0,2} \s* << .*? # digits left shifted by anything + # followed by optional + # long, unsigned qualifiers + ) \s* (?: $| \/ \* ) # ending at comment or $ + /x); } close $fh; } +WriteMakefile( + NAME => "B", + VERSION_FROM => "B.pm", + realclean => {FILES=> 'const-c.inc const-xs.inc'}, + depend => {'Makefile' => "@depend"}, +); + # Currently only SVt_PVGV and SVt_PVHV aren't macros, but everything we name # should exist, so ensure that the C compile breaks if anything does not. WriteConstants( diff --git a/gnu/usr.bin/perl/ext/B/hints/darwin.pl b/gnu/usr.bin/perl/ext/B/hints/darwin.pl index 2f59a60ff97..554450efaf5 100644 --- a/gnu/usr.bin/perl/ext/B/hints/darwin.pl +++ b/gnu/usr.bin/perl/ext/B/hints/darwin.pl @@ -1,2 +1,6 @@ # gcc -O3 (and -O2) get overly excited over B.c in MacOS X 10.1.4. -$self->{OPTIMIZE} = '-O1'; +use Config; + +my $optimize = $Config{optimize}; +$optimize =~ s/(^| )-O[2-9]\b/$1-O1/g + and $self->{OPTIMIZE} = $optimize; diff --git a/gnu/usr.bin/perl/ext/B/hints/openbsd.pl b/gnu/usr.bin/perl/ext/B/hints/openbsd.pl index bd2149f37e2..cf030df02d3 100644 --- a/gnu/usr.bin/perl/ext/B/hints/openbsd.pl +++ b/gnu/usr.bin/perl/ext/B/hints/openbsd.pl @@ -1,2 +1,8 @@ # gcc -O3 (and -O2) get overly excited over B.c in OpenBSD 3.3/sparc 64 -$self->{OPTIMIZE} = '-O1' if $Config{ARCH} eq 'sparc64'; +use Config; + +if ($Config{ARCH} eq 'sparc64') { + my $optimize = $Config{optimize}; + $optimize =~ s/(^| )-O[2-9]\b/$1-O1/g + and $self->{OPTIMIZE} = $optimize; +} diff --git a/gnu/usr.bin/perl/ext/B/t/OptreeCheck.pm b/gnu/usr.bin/perl/ext/B/t/OptreeCheck.pm index 0537a8d7a86..a099a97ec9d 100644 --- a/gnu/usr.bin/perl/ext/B/t/OptreeCheck.pm +++ b/gnu/usr.bin/perl/ext/B/t/OptreeCheck.pm @@ -5,7 +5,7 @@ use warnings; use vars qw($TODO $Level $using_open); require "test.pl"; -our $VERSION = '0.11'; +our $VERSION = '0.13'; # now export checkOptree, and those test.pl functions used by tests our @EXPORT = qw( checkOptree plan skip skip_all pass is like unlike @@ -652,14 +652,14 @@ sub mkCheckRex { : $cmp eq '==' ? $] == $version : $cmp eq '>=' ? $] >= $version : $cmp eq '>' ? $] > $version - : die("bad comparision '$cmp' in string [$str]\n") + : die("bad comparison '$cmp' in string [$str]\n") and !$cmp2 || ( $cmp2 eq '<' ? $] < $v2 : $cmp2 eq '<=' ? $] <= $v2 : $cmp2 eq '==' ? $] == $v2 : $cmp2 eq '>=' ? $] >= $v2 : $cmp2 eq '>' ? $] > $v2 - : die("bad comparision '$cmp2' in string [$str]\n") + : die("bad comparison '$cmp2' in string [$str]\n") ) ) { $repl = "$line\n"; @@ -669,6 +669,8 @@ sub mkCheckRex { $tc->{wantstr} = $str; + # make UNOP_AUX flag type literal + $str =~ s/<\+>/<\\+>/; # make targ args wild $str =~ s/\[t\d+\]/[t\\d+]/msg; diff --git a/gnu/usr.bin/perl/ext/B/t/b.t b/gnu/usr.bin/perl/ext/B/t/b.t index 1fee1393030..4638c3e5770 100644 --- a/gnu/usr.bin/perl/ext/B/t/b.t +++ b/gnu/usr.bin/perl/ext/B/t/b.t @@ -12,6 +12,9 @@ BEGIN { $| = 1; use warnings; use strict; +BEGIN { + eval { require threads; threads->import; } +} use Test::More; BEGIN { use_ok( 'B' ); } @@ -108,6 +111,9 @@ my $obj = B::svref_2object($r); my $regexp = ($] < 5.011) ? $obj->MAGIC : $obj; ok($regexp->precomp() eq 'foo', 'Get string from qr//'); like($regexp->REGEX(), qr/\d+/, "REGEX() returns numeric value"); +like($regexp->compflags, qr/^\d+\z/, "compflags returns numeric value"); +is B::svref_2object(qr/(?{time})/)->qr_anoncv->ROOT->first->name, 'qr', + 'qr_anoncv'; my $iv = 1; my $iv_ref = B::svref_2object(\$iv); is(ref $iv_ref, "B::IV", "Test B:IV return from svref_2object"); @@ -208,6 +214,26 @@ is($gv_ref->FLAGS() & B::SVTYPEMASK, B::SVt_PVGV, "Test SVTYPEMASK"); is(ref B::sv_yes(), "B::SPECIAL", "B::sv_yes()"); is(ref B::sv_no(), "B::SPECIAL", "B::sv_no()"); is(ref B::sv_undef(), "B::SPECIAL", "B::sv_undef()"); +SKIP: { + skip('no fork', 1) + unless ($Config::Config{d_fork} or $Config::Config{d_pseudofork}); + my $pid; + pipe my $r, my $w or die "Can't pipe: $!";; + if ($pid = fork) { + close $w; + my $type = <$r>; + close $r; + waitpid($pid,0); + is($type, "B::SPECIAL", "special SV table works after pseudofork"); + } + else { + close $r; + $|++; + print $w ref B::svref_2object(\(!!0)); + close $w; + exit; + } +} # More utility functions is(B::ppname(0), "pp_null", "Testing ppname (this might break if opnames.h is changed)"); @@ -255,7 +281,7 @@ is(B::opnumber("pp_null"), 0, "Testing opnumber with opname (pp_null)"); while (my ($test, $expect) = splice @tests, 0, 2) { is(B::perlstring($test), $expect, "B::perlstring($expect)"); utf8::upgrade $test; - $expect =~ s/\\b/\\x\{8\}/g; + $expect =~ s/\\b/sprintf("\\x{%x}", utf8::unicode_to_native(8))/eg; $expect =~ s/\\([0-7]{3})/sprintf "\\x\{%x\}", oct $1/eg; is(B::perlstring($test), $expect, "B::perlstring($expect) (Unicode)"); } @@ -292,6 +318,16 @@ B::svref_2object(sub{y/\x{100}//})->ROOT->first->first->sibling->sv; ok 1, 'B knows that UTF trans is a padop in 5.8.9, not an svop'; { + my $o = B::svref_2object(sub{0;0})->ROOT->first->first; + # Make sure we are testing what we think we are testing. If these two + # fail, tweak the test to find a nulled cop a different way. + is $o->name, "null", 'first op of sub{0;0} is a null'; + is B::ppname($o->targ),'pp_nextstate','first op of sub{0;0} was a cop'; + # Test its class + is B::class($o), "COP", 'nulled cops are of class COP'; +} + +{ format FOO = foo . @@ -300,6 +336,8 @@ foo can_ok $f, 'LINES'; } +is B::safename("\cLAST_FH"), "^LAST_FH", 'basic safename test'; + my $sub1 = sub {die}; { no warnings 'once'; no strict; *Peel:: = *{"Pe\0e\x{142}::"} } my $sub2 = eval 'package Peel; sub {die}'; @@ -320,6 +358,11 @@ SKIP: { 'different COP->stashoff for different stashes'; } +my $pmop = B::svref_2object(sub{ qr/fit/ })->ROOT->first->first->sibling; +$regexp = $pmop->pmregexp; +is B::class($regexp), 'REGEXP', 'B::PMOP::pmregexp returns a regexp'; +is $regexp->precomp, 'fit', 'pmregexp returns the right regexp'; + # Test $B::overlay { @@ -404,10 +447,10 @@ SKIP: my $cv = B::svref_2object(\&bar); ok($cv, "make a B::CV from a lexical sub reference"); isa_ok($cv, "B::CV"); - my $gv = $cv->GV; - isa_ok($gv, "B::SPECIAL", "GV on a lexical sub"); my $hek = $cv->NAME_HEK; is($hek, "bar", "check the NAME_HEK"); + my $gv = $cv->GV; + isa_ok($gv, "B::GV", "GV on a lexical sub"); } 1; EOS @@ -422,4 +465,90 @@ EOS is($k, "\x{100}", "check utf8 preserved by B::HV::ARRAY"); } +# test op_parent + +SKIP: { + unless ($B::OP::does_parent) { + skip "op_parent only present with -DPERL_OP_PARENT builds", 6; + } + my $lineseq = B::svref_2object(sub{my $x = 1})->ROOT->first; + is ($lineseq->type, B::opnumber('lineseq'), + 'op_parent: top op is lineseq'); + my $first = $lineseq->first; + my $second = $first->sibling; + is(ref $second->sibling, "B::NULL", 'op_parent: second sibling is null'); + is($first->moresib, 1 , 'op_parent: first sibling: moresib'); + is($second->moresib, 0, 'op_parent: second sibling: !moresib'); + is($$lineseq, ${$first->parent}, 'op_parent: first sibling okay'); + is($$lineseq, ${$second->parent}, 'op_parent: second sibling okay'); +} + + +# make sure ->sv, -gv methods do the right thing on threaded builds +{ + + # for some reason B::walkoptree only likes a sub name, not a code ref + my ($gv, $sv); + sub gvsv_const { + # make the early pad slots something unlike a threaded const or + # gvsv + my ($dummy1, $dummy2, $dummy3, $dummy4) = qw(foo1 foo2 foo3 foo4); + my $self = shift; + if ($self->name eq 'gvsv') { + $gv = $self->gv; + } + elsif ($self->name eq 'const') { + $sv = $self->sv; + } + }; + + B::walkoptree(B::svref_2object(sub {our $x = 1})->ROOT, "::gvsv_const"); + ok(defined $gv, "gvsv->gv seen"); + ok(defined $sv, "const->sv seen"); + if ($Config::Config{useithreads}) { + # should get NULLs + is(ref($gv), "B::SPECIAL", "gvsv->gv is special"); + is(ref($sv), "B::SPECIAL", "const->sv is special"); + is($$gv, 0, "gvsv->gv special is 0 (NULL)"); + is($$sv, 0, "const->sv special is 0 (NULL)"); + } + else { + is(ref($gv), "B::GV", "gvsv->gv is GV"); + is(ref($sv), "B::IV", "const->sv is IV"); + pass(); + pass(); + } + +} + + +# Some pad tests +{ + my $sub = sub { my main $a; CORE::state @b; our %c }; + my $padlist = B::svref_2object($sub)->PADLIST; + is $padlist->MAX, 1, 'padlist MAX'; + my @array = $padlist->ARRAY; + is @array, 2, 'two items from padlist ARRAY'; + is ${$padlist->ARRAYelt(0)}, ${$array[0]}, + 'ARRAYelt(0) is first item from ARRAY'; + is ${$padlist->ARRAYelt(1)}, ${$array[1]}, + 'ARRAYelt(1) is second item from ARRAY'; + is ${$padlist->NAMES}, ${$array[0]}, + 'NAMES is first item from ARRAY'; + my @names = $array[0]->ARRAY; + cmp_ok @names, ">=", 4, 'at least 4 pad names'; + is join(" ", map($_->PV//"undef",@names[0..3])), 'undef $a @b %c', + 'pad name PVs'; + + my @closures; + for (1,2) { push @closures, sub { sub { @closures } } } + my $sub1 = B::svref_2object($closures[0]); + my $sub2 = B::svref_2object($closures[1]); + is $sub2->PADLIST->id, $sub1->PADLIST->id, 'padlist id'; + $sub1 = B::svref_2object(my $lr = $closures[0]()); + $sub2 = B::svref_2object(my $lr2= $closures[1]()); + is $sub2->PADLIST->outid, $sub1->PADLIST->outid, 'padlist outid'; +} + + done_testing(); diff --git a/gnu/usr.bin/perl/ext/B/t/concise-xs.t b/gnu/usr.bin/perl/ext/B/t/concise-xs.t index ca82cbd877f..217a44e9f4a 100755 --- a/gnu/usr.bin/perl/ext/B/t/concise-xs.t +++ b/gnu/usr.bin/perl/ext/B/t/concise-xs.t @@ -1,98 +1,7 @@ #!./perl -# 2 purpose file: 1-test 2-demonstrate (via args, -v -a options) - -=head1 SYNOPSIS - -To verify that B::Concise properly reports whether functions are XS, -perl, or optimized constant subs, we test against a few core packages -which have a stable API, and which have functions of all 3 types. - -=head1 WHAT IS TESTED - -5 core packages are tested; Digest::MD5, B, B::Deparse, Data::Dumper, -and POSIX. These have a mix of the 3 expected implementation types; -perl, XS, and constant (optimized constant subs). - -%$testpkgs specifies what packages are tested; each package is loaded, -and the stash is scanned for the function-names in that package. - -Each value in %$testpkgs is a hash-of-lists (HoL) whose keys are -implementation-types and values are lists of function-names of that type. - -To keep these HoLs smaller and more manageable, they may carry an -additional 'dflt' => $impl_Type, which means that unnamed functions -are expected to be of that default implementation type. Those unnamed -functions are known from the scan of the package stash. - -=head1 HOW THEY'RE TESTED - -Each function is 'rendered' by B::Concise, and result is matched -against regexs for each possible implementation-type. For some -packages, some functions may be unimplemented on some platforms. - -To slay this maintenance dragon, the regexs used in like() match -against renderings which indicate that there is no implementation. - -If a function is implemented differently on different platforms, the -test for that function will fail on one of those platforms. These -specific functions can be skipped by a 'skip' => [ @list ] to the HoL -mentioned previously. See usage for skip in B's HoL, which avoids -testing a function which doesn't exist on non-threaded builds. - -=head1 OPTIONS AND ARGUMENTS - -C<-v> and C<-V> trigger 2 levels of verbosity. - -C<-a> uses Module::CoreList to run all core packages through the test, which -gives some interesting results. - -C<-c> causes the expected XS/non-XS results to be marked with -corrections, which are then reported at program END, in a form that's -readily cut-and-pastable into this file. - - -C<< -r <file> >> reads a file, as written by C<-c>, and adjusts the expected -results accordingly. The file is 'required', so @INC settings apply. - -If module-names are given as args, those packages are run through the -test harness; this is handy for collecting further items to test, and -may be useful otherwise (ie just to see). - -=head1 EXAMPLES - -=over 4 - -=item ./perl -Ilib -wS ext/B/t/concise-xs.t -c Storable - -Tests Storable.pm for XS/non-XS routines, writes findings (along with -test results) to stdout. You could edit results to produce a test -file, as in next example - -=item ./perl -Ilib -wS ext/B/t/concise-xs.t -r ./storable - -Loads file, and uses it to set expectations, and run tests - -=item ./perl -Ilib -wS ext/B/t/concise-xs.t -avc > ../foo-avc 2> ../foo-avc2 - -Gets module list from Module::Corelist, and runs them all through the -test. Since -c is used, this generates corrections, which are saved -in a file, which is edited down to produce ../all-xs - -=item ./perl -Ilib -wS ext/B/t/concise-xs.t -cr ../all-xs > ../foo 2> ../foo2 - -This runs the tests specified in the file created in previous example. --c is used again, and stdout verifies that all the expected results -given by -r ../all-xs are now seen. - -Looking at ../foo2, you'll see 34 occurrences of the following error: - -# err: Can't use an undefined value as a SCALAR reference at -# lib/B/Concise.pm line 634, <DATA> line 1. - -=back - -=cut +# Verify that B::Concise properly reports whether functions are XS, +# perl, or optimized constant subs. BEGIN { unshift @INC, 't'; @@ -107,7 +16,6 @@ BEGIN { } } -use Getopt::Std; use Carp; use Test::More 'no_plan'; @@ -118,227 +26,42 @@ my %matchers = |(?-x: exists in stash, but has no START) }x, XS => qr/ is XS code/, perl => qr/ (next|db)state/, - noSTART => qr/ exists in stash, but has no START/, + core => qr/ coreargs/, # CORE:: subs have no nextstate + noSTART => qr/ has no START/, ); -my $testpkgs = { - # packages to test, with expected types for named funcs - - Digest::MD5 => { perl => [qw/ import /], - dflt => 'XS' }, - - Data::Dumper => { XS => [qw/ bootstrap Dumpxs /, - $] >= 5.015 ? qw/_vstring / : () ], - $] >= 5.015 - ? (constant => ['_bad_vsmg']) : (), - dflt => 'perl' }, - B => { - dflt => 'constant', # all but 47/297 - skip => [ 'regex_padav' ], # threaded only - perl => [qw( - walksymtable walkoptree_slow walkoptree_exec - timing_info savesym peekop parents objsym debug - compile_stats clearsym class - )], - XS => [qw( - warnhook walkoptree_debug walkoptree threadsv_names - svref_2object sv_yes sv_undef sv_no save_BEGINs - regex_padav ppname perlstring opnumber minus_c - main_start main_root main_cv init_av inc_gv hash - formfeed end_av dowarn diehook defstash curstash - cstring comppadlist check_av cchar cast_I32 bootstrap - begin_av amagic_generation sub_generation address - unitcheck_av) ], - }, - - B::Deparse => { dflt => 'perl', # 236 functions - - XS => [qw( svref_2object perlstring opnumber main_start - main_root main_cv )], - - constant => [qw/ ASSIGN CVf_LVALUE - CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV - OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL - OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR - OPf_WANT_VOID OPpCONST_BARE OPpCONST_NOVER - OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED - OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND - OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC - OPpSORT_REVERSE OPpREVERSE_INPLACE OPpTARGET_MY - OPpTRANS_COMPLEMENT OPpTRANS_DELETE OPpTRANS_SQUASH - PMf_CONTINUE PMf_EVAL PMf_EXTENDED PMf_FOLD PMf_GLOBAL - PMf_KEEP PMf_NONDESTRUCT - PMf_MULTILINE PMf_ONCE PMf_SINGLELINE - POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK - SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN OPpPAD_STATE - OPpCONST_ARYBASE RXf_SKIPWHITE/, - $] >= 5.015 ? qw( - OP_GLOB PMf_SKIPWHITE RXf_PMf_CHARSET RXf_PMf_KEEPCOPY - OPpEVAL_BYTES OPpSUBSTR_REPL_FIRST) : (), - $] >= 5.019 ? qw(OP_PUSHMARK OP_NULL) : (), - 'CVf_LOCKED', # This ends up as a constant, pre or post 5.10 - ], - }, - - POSIX => { dflt => 'constant', # all but 252/589 - skip => [qw/ _POSIX_JOB_CONTROL /, # platform varying - # Might be XS or imported from Fcntl, depending on your - # perl version: - qw / S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISREG /, - # Might be XS or AUTOLOADed, depending on your perl - # version: - qw /WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED - WSTOPSIG WTERMSIG/, - 'int_macro_int', # Removed in POSIX 1.16 - ], - perl => [qw/ import croak AUTOLOAD /, - $] >= 5.015 - ? qw/load_imports usage printf sprintf perror/ - : (), - ], - - XS => [qw/ write wctomb wcstombs uname tzset tzname - ttyname tmpnam times tcsetpgrp tcsendbreak - tcgetpgrp tcflush tcflow tcdrain tanh tan - sysconf strxfrm strtoul strtol strtod - strftime strcoll sinh sigsuspend sigprocmask - sigpending sigaction setuid setsid setpgid - setlocale setgid read pipe pause pathconf - open nice modf mktime mkfifo mbtowc mbstowcs - mblen lseek log10 localeconv ldexp lchown - isxdigit isupper isspace ispunct isprint - islower isgraph isdigit iscntrl isalpha - isalnum getcwd frexp fpathconf - fmod floor dup2 dup difftime cuserid ctime - ctermid cosh constant close clock ceil - bootstrap atan asin asctime acos access abort - _exit - /, $] >= 5.015 ? ('sleep') : () ], - }, - - IO::Socket => { dflt => 'constant', # 157/190 - - perl => [qw/ timeout socktype sockopt sockname - socketpair socket sockdomain sockaddr_un - sockaddr_in shutdown setsockopt send - register_domain recv protocol peername - new listen import getsockopt croak - connected connect configure confess close - carp bind atmark accept sockaddr_in6 - blocking/ ], - - XS => [qw/ unpack_sockaddr_un unpack_sockaddr_in - sockatmark sockaddr_family pack_sockaddr_un - pack_sockaddr_in inet_ntoa inet_aton - unpack_sockaddr_in6 pack_sockaddr_in6 - /], - # skip inet_ntop and inet_pton as they're not exported by default - }, -}; - +use constant a_constant => 3; +use constant a_list_constant => 4,5,6; + +my @subs_to_test = ( + 'a stub' => noSTART => \&baz, + 'a Perl sub' => perl => sub { foo(); bar (); }, + 'a constant Perl sub' => constant => sub () { 3 }, + 'a constant constant' => constant => \&a_constant, + 'a list constant' => constant => \&a_list_constant, + 'an XSUB' => XS => \&utf8::encode, + 'a CORE:: sub' => core => \&CORE::lc, +); + ############ B::Concise::compile('-nobanner'); # set a silent default -getopts('vaVcr:', \my %opts) or - die <<EODIE; - -usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list] - tests ability to discern XS funcs using Digest::MD5 package - -v : runs verbosely - -V : more verbosity - -a : runs all modules in CoreList - -c : writes test corrections as a Data::Dumper expression - -r <file> : reads file of tests, as written by -c - <args> : additional modules are loaded and tested - (will report failures, since no XS funcs are known apriori) - -EODIE - ; - -if (%opts) { - require Data::Dumper; - Data::Dumper->import('Dumper'); - { my $x = \*Data::Dumper::Sortkeys } # shut up 'used once' warning - $Data::Dumper::Sortkeys = 1; -} -my @argpkgs = @ARGV; -my %report; - -if ($opts{r}) { - my $refpkgs = require "$opts{r}"; - $testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs; -} - -unless ($opts{a}) { - unless (@argpkgs) { - foreach $pkg (sort keys %$testpkgs) { - test_pkg($pkg, $testpkgs->{$pkg}); - } - } else { - foreach $pkg (@argpkgs) { - test_pkg($pkg, $testpkgs->{$pkg}); - } - } -} else { - corecheck(); -} -############ - -sub test_pkg { - my ($pkg, $fntypes) = @_; - require_ok($pkg); - - # build %stash: keys are func-names, vals filled in below - my (%stash) = map - ( ($_ => 0) - => ( grep exists &{"$pkg\::$_"} # grab CODE symbols - => grep !/__ANON__/ # but not anon subs - => keys %{$pkg.'::'} # from symbol table - )); - for my $type (keys %matchers) { - foreach my $fn (@{$fntypes->{$type}}) { - carp "$fn can only be one of $type, $stash{$fn}\n" - if $stash{$fn}; - $stash{$fn} = $type; - } - } - # set default type for un-named functions - my $dflt = $fntypes->{dflt} || 'perl'; - for my $k (keys %stash) { - $stash{$k} = $dflt unless $stash{$k}; - } - $stash{$_} = 'skip' foreach @{$fntypes->{skip}}; - - if ($opts{v}) { - diag("fntypes: " => Dumper($fntypes)); - diag("$pkg stash: " => Dumper(\%stash)); - } - foreach my $fn (reverse sort keys %stash) { - next if $stash{$fn} eq 'skip'; - my $res = checkXS("${pkg}::$fn", $stash{$fn}); - if ($res ne '1') { - push @{$report{$pkg}{$res}}, $fn; - } - } -} - -sub checkXS { - my ($func_name, $want) = @_; +while (@subs_to_test) { + my ($func_name, $want, $sub) = splice @subs_to_test, 0, 3; croak "unknown type $want: $func_name\n" unless defined $matchers{$want}; - my ($buf, $err) = render($func_name); + my ($buf, $err) = render($sub); my $res = like($buf, $matchers{$want}, "$want sub:\t $func_name"); unless ($res) { - # test failed. return type that would give success + # Test failed. Report type that would give success. for my $m (keys %matchers) { - return $m if $buf =~ $matchers{$m}; + diag ("$name is of type $m"), last if $buf =~ $matchers{$m}; } } - $res; } sub render { @@ -355,35 +78,4 @@ sub render { return ($buf, $@); } -sub corecheck { - eval { require Module::CoreList }; - if ($@) { - warn "Module::CoreList not available on $]\n"; - return; - } - { my $x = \*Module::CoreList::version } # shut up 'used once' warning - my $mods = $Module::CoreList::version{'5.009002'}; - $mods = [ sort keys %$mods ]; - print Dumper($mods); - - foreach my $pkgnm (@$mods) { - test_pkg($pkgnm); - } -} - -END { - if ($opts{c}) { - { my $x = \*Data::Dumper::Indent } # shut up 'used once' warning - $Data::Dumper::Indent = 1; - print "Corrections: ", Dumper(\%report); - - foreach my $pkg (sort keys %report) { - for my $type (keys %matchers) { - print "$pkg: $type: @{$report{$pkg}{$type}}\n" - if @{$report{$pkg}{$type}}; - } - } - } -} - __END__ diff --git a/gnu/usr.bin/perl/ext/B/t/concise.t b/gnu/usr.bin/perl/ext/B/t/concise.t index d43bd977e25..bb1056fe5c2 100644 --- a/gnu/usr.bin/perl/ext/B/t/concise.t +++ b/gnu/usr.bin/perl/ext/B/t/concise.t @@ -381,9 +381,7 @@ like($out, qr/Config::AUTOLOAD exists in stash, but has no START/, "coderef properly undefined"); # test -stash and -src rendering -# todo: stderr=1 puts '-e syntax OK' into $out, -# conceivably fouling one of the lines that are tested -$out = runperl ( switches => ["-MO=Concise,-stash=B::Concise,-src"], +$out = runperl ( switches => ["-MO=-qq,Concise,-stash=B::Concise,-src"], prog => '-e 1', stderr => 1 ); like($out, qr/FUNC: \*B::Concise::concise_cv_obj/, @@ -399,7 +397,7 @@ $out = runperl ( switches => ["-MStorable", "-MO=Concise,-stash=Storable,-src"], prog => '-e 1', stderr => 1 ); like($out, qr/FUNC: \*Storable::BIN_MAJOR/, - "stash rendering includes constant sub: PAD_FAKELEX_MULTI"); + "stash rendering has constant sub: Storable::BIN_MAJOR"); like($out, qr/BIN_MAJOR is a constant sub, optimized to a IV/, "stash rendering identifies it as constant"); @@ -457,14 +455,14 @@ $out = runperl( switches => ["-MO=Concise,-nobanner,foo"], prog=>'sub foo{}', stderr => 1 ); -unlike $out, 'main::foo', '-nobanner'; +unlike $out, qr/main::foo/, '-nobanner'; # glob $out = runperl( switches => ["-MO=Concise"], prog=>'glob(q{.})', stderr => 1 ); -like $out, '\*<none>::', 'glob(q{.})'; +like $out, qr/\*<none>::/, 'glob(q{.})'; # Test op_other in -debug $out = runperl( @@ -486,7 +484,7 @@ EOF $end =~ s/\r\n/\n/g; -like $out, $end, 'OP_AND has op_other'; +like $out, qr/$end/, 'OP_AND has op_other'; # like(..) above doesn't fill in $1 $out =~ $end; @@ -502,6 +500,6 @@ EOF $end =~ s/<NEXT>/$next/; -like $out, $end, 'OP_AND->op_other points correctly'; +like $out, qr/$end/, 'OP_AND->op_other points correctly'; __END__ diff --git a/gnu/usr.bin/perl/ext/B/t/f_map.t b/gnu/usr.bin/perl/ext/B/t/f_map.t index a7a9c268805..a1cbc38c012 100755 --- a/gnu/usr.bin/perl/ext/B/t/f_map.t +++ b/gnu/usr.bin/perl/ext/B/t/f_map.t @@ -59,7 +59,7 @@ checkOptree(note => q{}, # a <0> pushmark s # b <#> gv[*chars] s # c <1> rv2av[t2] lKRM*/1 -# d <2> aassign[t9] KS/COMMON +# d <2> aassign[t9] KS/COM_AGG # e <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 559 (eval 15):1) v @@ -75,7 +75,7 @@ EOT_EOT # a <0> pushmark s # b <$> gv(*chars) s # c <1> rv2av[t1] lKRM*/1 -# d <2> aassign[t6] KS/COMMON +# d <2> aassign[t6] KS/COM_AGG # e <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -95,8 +95,7 @@ checkOptree(note => q{}, # 3 <0> pushmark s # 4 <#> gv[*array] s # 5 <1> rv2av[t8] lKM/1 -# 6 <@> mapstart lK* < 5.017002 -# 6 <@> mapstart lK >=5.017002 +# 6 <@> mapstart lK # 7 <|> mapwhile(other->8)[t9] lK # 8 <0> enter l # 9 <;> nextstate(main 475 (eval 10):1) v:{ @@ -109,9 +108,8 @@ checkOptree(note => q{}, # goto 7 # g <0> pushmark s # h <#> gv[*hash] s -# i <1> rv2hv[t2] lKRM*/1 < 5.019006 -# i <1> rv2hv lKRM*/1 >=5.019006 -# j <2> aassign[t10] KS/COMMON +# i <1> rv2hv lKRM*/1 +# j <2> aassign[t10] KS/COM_AGG # k <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 560 (eval 15):1) v:{ @@ -119,8 +117,7 @@ EOT_EOT # 3 <0> pushmark s # 4 <$> gv(*array) s # 5 <1> rv2av[t3] lKM/1 -# 6 <@> mapstart lK* < 5.017002 -# 6 <@> mapstart lK >=5.017002 +# 6 <@> mapstart lK # 7 <|> mapwhile(other->8)[t4] lK # 8 <0> enter l # 9 <;> nextstate(main 559 (eval 15):1) v:{ @@ -133,9 +130,8 @@ EOT_EOT # goto 7 # g <0> pushmark s # h <$> gv(*hash) s -# i <1> rv2hv[t1] lKRM*/1 < 5.019006 -# i <1> rv2hv lKRM*/1 >=5.019006 -# j <2> aassign[t5] KS/COMMON +# i <1> rv2hv lKRM*/1 +# j <2> aassign[t5] KS/COM_AGG # k <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -161,8 +157,7 @@ checkOptree(note => q{}, # 4 <0> pushmark s # 5 <0> pushmark s # 6 <#> gv[*hash] s -# 7 <1> rv2hv[t2] lKRM*/1 < 5.019006 -# 7 <1> rv2hv lKRM*/1 >=5.019006 +# 7 <1> rv2hv lKRM*/1 # 8 <2> aassign[t3] vKS # 9 <;> nextstate(main 476 (eval 10):1) v:{ # a <0> pushmark sM @@ -170,7 +165,7 @@ checkOptree(note => q{}, # c <1> rv2av[t6] sKRM/1 # d <#> gv[*_] s # e <1> rv2gv sKRM/1 -# f <{> enteriter(next->q last->t redo->g) lKS/8 +# f <{> enteriter(next->q last->t redo->g) KS/DEF # r <0> iter s # s <|> and(other->g) K/1 # g <;> nextstate(main 475 (eval 10):1) v:{ @@ -195,8 +190,7 @@ EOT_EOT # 4 <0> pushmark s # 5 <0> pushmark s # 6 <$> gv(*hash) s -# 7 <1> rv2hv[t1] lKRM*/1 < 5.019006 -# 7 <1> rv2hv lKRM*/1 >=5.019006 +# 7 <1> rv2hv lKRM*/1 # 8 <2> aassign[t2] vKS # 9 <;> nextstate(main 560 (eval 15):1) v:{ # a <0> pushmark sM @@ -204,7 +198,7 @@ EOT_EOT # c <1> rv2av[t3] sKRM/1 # d <$> gv(*_) s # e <1> rv2gv sKRM/1 -# f <{> enteriter(next->q last->t redo->g) lKS/8 +# f <{> enteriter(next->q last->t redo->g) KS/DEF # r <0> iter s # s <|> and(other->g) K/1 # g <;> nextstate(main 559 (eval 15):1) v:{ @@ -241,46 +235,34 @@ checkOptree(note => q{}, # 3 <0> pushmark s # 4 <#> gv[*array] s # 5 <1> rv2av[t7] lKM/1 -# 6 <@> mapstart lK* < 5.017002 -# 6 <@> mapstart lK >=5.017002 +# 6 <@> mapstart lK # 7 <|> mapwhile(other->8)[t9] lK -# 8 <0> pushmark s -# 9 <#> gvsv[*_] s -# a <1> lc[t4] sK/1 -# b <@> stringify[t5] sK/1 -# c <$> const[IV 1] s -# d <@> list lK -# - <@> scope lK < 5.017002 +# 8 <#> gvsv[*_] s +# 9 <1> lc[t4] sK/1 +# a <$> const[IV 1] s # goto 7 -# e <0> pushmark s -# f <#> gv[*hash] s -# g <1> rv2hv[t2] lKRM*/1 < 5.019006 -# g <1> rv2hv lKRM*/1 >=5.019006 -# h <2> aassign[t10] KS/COMMON -# i <1> leavesub[1 ref] K/REFC,1 +# b <0> pushmark s +# c <#> gv[*hash] s +# d <1> rv2hv lKRM*/1 +# e <2> aassign[t10] KS/COM_AGG +# f <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 560 (eval 15):1) v # 2 <0> pushmark s # 3 <0> pushmark s # 4 <$> gv(*array) s # 5 <1> rv2av[t4] lKM/1 -# 6 <@> mapstart lK* < 5.017002 -# 6 <@> mapstart lK >=5.017002 +# 6 <@> mapstart lK # 7 <|> mapwhile(other->8)[t5] lK -# 8 <0> pushmark s -# 9 <$> gvsv(*_) s -# a <1> lc[t2] sK/1 -# b <@> stringify[t3] sK/1 -# c <$> const(IV 1) s -# d <@> list lK -# - <@> scope lK < 5.017002 +# 8 <$> gvsv(*_) s +# 9 <1> lc[t2] sK/1 +# a <$> const(IV 1) s # goto 7 -# e <0> pushmark s -# f <$> gv(*hash) s -# g <1> rv2hv[t1] lKRM*/1 < 5.019006 -# g <1> rv2hv lKRM*/1 >=5.019006 -# h <2> aassign[t6] KS/COMMON -# i <1> leavesub[1 ref] K/REFC,1 +# b <0> pushmark s +# c <$> gv(*hash) s +# d <1> rv2hv lKRM*/1 +# e <2> aassign[t6] KS/COM_AGG +# f <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -299,46 +281,34 @@ checkOptree(note => q{}, # 3 <0> pushmark s # 4 <#> gv[*array] s # 5 <1> rv2av[t7] lKM/1 -# 6 <@> mapstart lK* < 5.017002 -# 6 <@> mapstart lK >=5.017002 +# 6 <@> mapstart lK # 7 <|> mapwhile(other->8)[t9] lK -# 8 <0> pushmark s -# 9 <#> gvsv[*_] s -# a <1> lc[t4] sK/1 -# b <@> stringify[t5] sK/1 -# c <$> const[IV 1] s -# d <@> list lKP -# - <@> scope lK < 5.017002 +# 8 <#> gvsv[*_] s +# 9 <1> lc[t4] sK/1 +# a <$> const[IV 1] s # goto 7 -# e <0> pushmark s -# f <#> gv[*hash] s -# g <1> rv2hv[t2] lKRM*/1 < 5.019006 -# g <1> rv2hv lKRM*/1 >=5.019006 -# h <2> aassign[t10] KS/COMMON -# i <1> leavesub[1 ref] K/REFC,1 +# b <0> pushmark s +# c <#> gv[*hash] s +# d <1> rv2hv lKRM*/1 +# e <2> aassign[t10] KS/COM_AGG +# f <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 560 (eval 15):1) v # 2 <0> pushmark s # 3 <0> pushmark s # 4 <$> gv(*array) s # 5 <1> rv2av[t4] lKM/1 -# 6 <@> mapstart lK* < 5.017002 -# 6 <@> mapstart lK >=5.017002 +# 6 <@> mapstart lK # 7 <|> mapwhile(other->8)[t5] lK -# 8 <0> pushmark s -# 9 <$> gvsv(*_) s -# a <1> lc[t2] sK/1 -# b <@> stringify[t3] sK/1 -# c <$> const(IV 1) s -# d <@> list lKP -# - <@> scope lK < 5.017002 +# 8 <$> gvsv(*_) s +# 9 <1> lc[t2] sK/1 +# a <$> const(IV 1) s # goto 7 -# e <0> pushmark s -# f <$> gv(*hash) s -# g <1> rv2hv[t1] lKRM*/1 < 5.019006 -# g <1> rv2hv lKRM*/1 >=5.019006 -# h <2> aassign[t6] KS/COMMON -# i <1> leavesub[1 ref] K/REFC,1 +# b <0> pushmark s +# c <$> gv(*hash) s +# d <1> rv2hv lKRM*/1 +# e <2> aassign[t6] KS/COM_AGG +# f <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -357,44 +327,34 @@ checkOptree(note => q{}, # 3 <0> pushmark s # 4 <#> gv[*array] s # 5 <1> rv2av[t6] lKM/1 -# 6 <@> mapstart lK* < 5.017002 -# 6 <@> mapstart lK >=5.017002 +# 6 <@> mapstart lK # 7 <|> mapwhile(other->8)[t8] lK -# 8 <0> pushmark s -# 9 <#> gvsv[*_] s -# a <1> lc[t4] sK/1 -# b <$> const[IV 1] s -# c <@> list lK -# - <@> scope lK < 5.017002 +# 8 <#> gvsv[*_] s +# 9 <1> lc[t4] sK/1 +# a <$> const[IV 1] s # goto 7 -# d <0> pushmark s -# e <#> gv[*hash] s -# f <1> rv2hv[t2] lKRM*/1 < 5.019006 -# f <1> rv2hv lKRM*/1 >=5.019006 -# g <2> aassign[t9] KS/COMMON -# h <1> leavesub[1 ref] K/REFC,1 +# b <0> pushmark s +# c <#> gv[*hash] s +# d <1> rv2hv lKRM*/1 +# e <2> aassign[t9] KS/COM_AGG +# f <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 589 (eval 26):1) v # 2 <0> pushmark s # 3 <0> pushmark s # 4 <$> gv(*array) s # 5 <1> rv2av[t3] lKM/1 -# 6 <@> mapstart lK* < 5.017002 -# 6 <@> mapstart lK >=5.017002 +# 6 <@> mapstart lK # 7 <|> mapwhile(other->8)[t4] lK -# 8 <0> pushmark s -# 9 <$> gvsv(*_) s -# a <1> lc[t2] sK/1 -# b <$> const(IV 1) s -# c <@> list lK -# - <@> scope lK < 5.017002 +# 8 <$> gvsv(*_) s +# 9 <1> lc[t2] sK/1 +# a <$> const(IV 1) s # goto 7 -# d <0> pushmark s -# e <$> gv(*hash) s -# f <1> rv2hv[t1] lKRM*/1 < 5.019006 -# f <1> rv2hv lKRM*/1 >=5.019006 -# g <2> aassign[t5] KS/COMMON -# h <1> leavesub[1 ref] K/REFC,1 +# b <0> pushmark s +# c <$> gv(*hash) s +# d <1> rv2hv lKRM*/1 +# e <2> aassign[t5] KS/COM_AGG +# f <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -415,18 +375,15 @@ checkOptree(note => q{}, # 5 <1> rv2av[t6] lKM/1 # 6 <@> mapstart lK # 7 <|> mapwhile(other->8)[t7] lK -# 8 <0> pushmark s -# 9 <#> gvsv[*_] s -# a <1> lc[t4] sK/1 -# b <$> const[IV 1] s -# c <@> list lKP +# 8 <#> gvsv[*_] s +# 9 <1> lc[t4] sK/1 +# a <$> const[IV 1] s # goto 7 -# d <0> pushmark s -# e <#> gv[*hash] s -# f <1> rv2hv[t2] lKRM*/1 < 5.019006 -# f <1> rv2hv lKRM*/1 >=5.019006 -# g <2> aassign[t8] KS/COMMON -# h <1> leavesub[1 ref] K/REFC,1 +# b <0> pushmark s +# c <#> gv[*hash] s +# d <1> rv2hv lKRM*/1 +# e <2> aassign[t8] KS/COM_AGG +# f <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 593 (eval 28):1) v # 2 <0> pushmark s @@ -435,18 +392,15 @@ EOT_EOT # 5 <1> rv2av[t3] lKM/1 # 6 <@> mapstart lK # 7 <|> mapwhile(other->8)[t4] lK -# 8 <0> pushmark s -# 9 <$> gvsv(*_) s -# a <1> lc[t2] sK/1 -# b <$> const(IV 1) s -# c <@> list lKP +# 8 <$> gvsv(*_) s +# 9 <1> lc[t2] sK/1 +# a <$> const(IV 1) s # goto 7 -# d <0> pushmark s -# e <$> gv(*hash) s -# f <1> rv2hv[t1] lKRM*/1 < 5.019006 -# f <1> rv2hv lKRM*/1 >=5.019006 -# g <2> aassign[t5] KS/COMMON -# h <1> leavesub[1 ref] K/REFC,1 +# b <0> pushmark s +# c <$> gv(*hash) s +# d <1> rv2hv lKRM*/1 +# e <2> aassign[t5] KS/COM_AGG +# f <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -472,9 +426,8 @@ checkOptree(note => q{}, # goto 7 # a <0> pushmark s # b <#> gv[*hash] s -# c <1> rv2hv[t2] lKRM*/1 < 5.019006 -# c <1> rv2hv lKRM*/1 >=5.019006 -# d <2> aassign[t6] KS/COMMON +# c <1> rv2hv lKRM*/1 +# d <2> aassign[t6] KS/COM_AGG # e <#> gv[*array] s # f <1> rv2av[t8] K/1 # g <@> list K @@ -492,9 +445,8 @@ EOT_EOT # goto 7 # a <0> pushmark s # b <$> gv(*hash) s -# c <1> rv2hv[t1] lKRM*/1 < 5.019006 -# c <1> rv2hv lKRM*/1 >=5.019006 -# d <2> aassign[t4] KS/COMMON +# c <1> rv2hv lKRM*/1 +# d <2> aassign[t4] KS/COM_AGG # e <$> gv(*array) s # f <1> rv2av[t5] K/1 # g <@> list K @@ -528,7 +480,7 @@ checkOptree(note => q{}, # d <0> pushmark s # e <#> gv[*hashes] s # f <1> rv2av[t2] lKRM*/1 -# g <2> aassign[t8] KS/COMMON +# g <2> aassign[t8] KS/COM_AGG # h <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 601 (eval 32):1) v @@ -547,6 +499,6 @@ EOT_EOT # d <0> pushmark s # e <$> gv(*hashes) s # f <1> rv2av[t1] lKRM*/1 -# g <2> aassign[t5] KS/COMMON +# g <2> aassign[t5] KS/COM_AGG # h <1> leavesub[1 ref] K/REFC,1 EONT_EONT diff --git a/gnu/usr.bin/perl/ext/B/t/f_sort.t b/gnu/usr.bin/perl/ext/B/t/f_sort.t index 65503ca4c30..eda5a21cc58 100755 --- a/gnu/usr.bin/perl/ext/B/t/f_sort.t +++ b/gnu/usr.bin/perl/ext/B/t/f_sort.t @@ -60,7 +60,7 @@ checkOptree(note => q{}, # 7 <0> pushmark s # 8 <#> gv[*articles] s # 9 <1> rv2av[t2] lKRM*/1 -# a <2> aassign[t5] KS/COMMON +# a <2> aassign[t5] KS/COM_AGG # b <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 545 (eval 15):1) v @@ -72,7 +72,7 @@ EOT_EOT # 7 <0> pushmark s # 8 <$> gv(*articles) s # 9 <1> rv2av[t1] lKRM*/1 -# a <2> aassign[t3] KS/COMMON +# a <2> aassign[t3] KS/COM_AGG # b <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -97,7 +97,7 @@ checkOptree(note => q{}, # 7 <0> pushmark s # 8 <#> gv[*articles] s # 9 <1> rv2av[t2] lKRM*/1 -# a <2> aassign[t3] KS/COMMON +# a <2> aassign[t3] KS/COM_AGG # b <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 546 (eval 15):1) v @@ -109,7 +109,7 @@ EOT_EOT # 7 <0> pushmark s # 8 <$> gv(*articles) s # 9 <1> rv2av[t1] lKRM*/1 -# a <2> aassign[t2] KS/COMMON +# a <2> aassign[t2] KS/COM_AGG # b <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -135,7 +135,7 @@ checkOptree(note => q{}, # 7 <0> pushmark s # 8 <#> gv[*articles] s # 9 <1> rv2av[t2] lKRM*/1 -# a <2> aassign[t10] KS/COMMON +# a <2> aassign[t10] KS/COM_AGG # b <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 546 (eval 15):1) v @@ -148,7 +148,7 @@ EOT_EOT # 7 <0> pushmark s # 8 <$> gv(*articles) s # 9 <1> rv2av[t1] lKRM*/1 -# a <2> aassign[t6] KS/COMMON +# a <2> aassign[t6] KS/COM_AGG # b <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -173,7 +173,7 @@ checkOptree(note => q{}, # 7 <0> pushmark s # 8 <#> gv[*articles] s # 9 <1> rv2av[t2] lKRM*/1 -# a <2> aassign[t3] KS/COMMON +# a <2> aassign[t3] KS/COM_AGG # b <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 546 (eval 15):1) v @@ -185,7 +185,7 @@ EOT_EOT # 7 <0> pushmark s # 8 <$> gv(*articles) s # 9 <1> rv2av[t1] lKRM*/1 -# a <2> aassign[t2] KS/COMMON +# a <2> aassign[t2] KS/COM_AGG # b <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -210,7 +210,7 @@ checkOptree(note => q{}, # 7 <0> pushmark s # 8 <#> gv[*articles] s # 9 <1> rv2av[t2] lKRM*/1 -# a <2> aassign[t3] KS/COMMON +# a <2> aassign[t3] KS/COM_AGG # b <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 546 (eval 15):1) v @@ -222,7 +222,7 @@ EOT_EOT # 7 <0> pushmark s # 8 <$> gv(*articles) s # 9 <1> rv2av[t1] lKRM*/1 -# a <2> aassign[t2] KS/COMMON +# a <2> aassign[t2] KS/COM_AGG # b <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -247,7 +247,7 @@ checkOptree(note => q{}, # 7 <0> pushmark s # 8 <#> gv[*articles] s # 9 <1> rv2av[t2] lKRM*/1 -# a <2> aassign[t3] KS/COMMON +# a <2> aassign[t3] KS/COM_AGG # b <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 546 (eval 15):1) v @@ -259,7 +259,7 @@ EOT_EOT # 7 <0> pushmark s # 8 <$> gv(*articles) s # 9 <1> rv2av[t1] lKRM*/1 -# a <2> aassign[t2] KS/COMMON +# a <2> aassign[t2] KS/COM_AGG # b <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -288,7 +288,7 @@ checkOptree(note => q{}, # 8 <0> pushmark s # 9 <#> gv[*eldest] s # a <1> rv2av[t2] lKRM*/1 -# b <2> aassign[t11] KS/COMMON +# b <2> aassign[t11] KS/COM_AGG # c <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 546 (eval 15):1) v @@ -303,7 +303,7 @@ EOT_EOT # 8 <0> pushmark s # 9 <$> gv(*eldest) s # a <1> rv2av[t1] lKRM*/1 -# b <2> aassign[t5] KS/COMMON +# b <2> aassign[t5] KS/COM_AGG # c <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -333,7 +333,7 @@ checkOptree(note => q{}, # 8 <0> pushmark s # 9 <#> gv[*sortedclass] s # a <1> rv2av[t2] lKRM*/1 -# b <2> aassign[t5] KS/COMMON +# b <2> aassign[t5] KS/COM_AGG # c <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 546 (eval 15):1) v @@ -347,7 +347,7 @@ EOT_EOT # 8 <0> pushmark s # 9 <$> gv(*sortedclass) s # a <1> rv2av[t1] lKRM*/1 -# b <2> aassign[t3] KS/COMMON +# b <2> aassign[t3] KS/COM_AGG # c <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -510,10 +510,8 @@ checkOptree(name => q{Compound sort/map Expression }, # 5 <0> pushmark s # 6 <#> gv[*old] s # 7 <1> rv2av[t19] lKM/1 -# 8 <@> mapstart lK* < 5.017002 -# 8 <@> mapstart lK >=5.017002 -# 9 <|> mapwhile(other->a)[t20] lK < 5.019002 -# 9 <|> mapwhile(other->a)[t20] lKM >=5.019002 +# 8 <@> mapstart lK +# 9 <|> mapwhile(other->a)[t20] lKM # a <0> enter l # b <;> nextstate(main 608 (eval 34):2) v:{ # c <0> pushmark s @@ -525,21 +523,15 @@ checkOptree(name => q{Compound sort/map Expression }, # i <@> leave lKP # goto 9 # j <@> sort lKMS* -# k <@> mapstart lK* < 5.017002 -# k <@> mapstart lK >=5.017002 +# k <@> mapstart lK # l <|> mapwhile(other->m)[t26] lK -# m <#> gv[*_] s -# n <1> rv2sv sKM/DREFAV,1 -# o <1> rv2av[t4] sKR/1 -# p <$> const[IV 0] s -# q <2> aelem sK/2 -# - <@> scope lK < 5.017002 +# m <+> multideref($_->[0]) sK # goto l -# r <0> pushmark s -# s <#> gv[*new] s -# t <1> rv2av[t2] lKRM*/1 -# u <2> aassign[t27] KS/COMMON -# v <1> leavesub[1 ref] K/REFC,1 +# n <0> pushmark s +# o <#> gv[*new] s +# p <1> rv2av[t2] lKRM*/1 +# q <2> aassign[t22] KS/COM_AGG +# r <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 609 (eval 34):3) v:{ # 2 <0> pushmark s @@ -548,10 +540,8 @@ EOT_EOT # 5 <0> pushmark s # 6 <$> gv(*old) s # 7 <1> rv2av[t10] lKM/1 -# 8 <@> mapstart lK* < 5.017002 -# 8 <@> mapstart lK >=5.017002 -# 9 <|> mapwhile(other->a)[t11] lK < 5.019002 -# 9 <|> mapwhile(other->a)[t11] lKM >=5.019002 +# 8 <@> mapstart lK +# 9 <|> mapwhile(other->a)[t11] lKM # a <0> enter l # b <;> nextstate(main 608 (eval 34):2) v:{ # c <0> pushmark s @@ -563,21 +553,15 @@ EOT_EOT # i <@> leave lKP # goto 9 # j <@> sort lKMS* -# k <@> mapstart lK* < 5.017002 -# k <@> mapstart lK >=5.017002 +# k <@> mapstart lK # l <|> mapwhile(other->m)[t12] lK -# m <$> gv(*_) s -# n <1> rv2sv sKM/DREFAV,1 -# o <1> rv2av[t2] sKR/1 -# p <$> const(IV 0) s -# q <2> aelem sK/2 -# - <@> scope lK < 5.017002 +# m <+> multideref($_->[0]) sK # goto l -# r <0> pushmark s -# s <$> gv(*new) s -# t <1> rv2av[t1] lKRM*/1 -# u <2> aassign[t13] KS/COMMON -# v <1> leavesub[1 ref] K/REFC,1 +# n <0> pushmark s +# o <$> gv(*new) s +# p <1> rv2av[t1] lKRM*/1 +# q <2> aassign[t13] KS/COM_AGG +# r <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -608,7 +592,7 @@ checkOptree(name => q{sort other::sub LIST }, # 8 <0> pushmark s # 9 <#> gv[*new] s # a <1> rv2av[t2] lKRM*/1 -# b <2> aassign[t5] KS/COMMON +# b <2> aassign[t5] KS/COM_AGG # c <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 614 (eval 36):2) v:{ @@ -622,7 +606,7 @@ EOT_EOT # 8 <0> pushmark s # 9 <$> gv(*new) s # a <1> rv2av[t1] lKRM*/1 -# b <2> aassign[t3] KS/COMMON +# b <2> aassign[t3] KS/COM_AGG # c <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -650,7 +634,7 @@ checkOptree(note => q{}, # 8 <0> pushmark s # 9 <#> gv[*new] s # a <1> rv2av[t2] lKRM*/1 -# b <2> aassign[t5] KS/COMMON +# b <2> aassign[t5] KS/COM_AGG # c <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 546 (eval 15):1) v @@ -664,7 +648,7 @@ EOT_EOT # 8 <0> pushmark s # 9 <$> gv(*new) s # a <1> rv2av[t1] lKRM*/1 -# b <2> aassign[t3] KS/COMMON +# b <2> aassign[t3] KS/COM_AGG # c <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -688,7 +672,7 @@ my ($expect, $expect_nt) = (<<'EOT_EOT', <<'EONT_EONT'); # 7 <0> pushmark s # 8 <#> gv[*new] s # 9 <1> rv2av[t2] lKRM*/1 -# a <2> aassign[t14] KS/COMMON +# a <2> aassign[t14] KS/COM_AGG # b <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 578 (eval 15):1) v:%,{ @@ -701,7 +685,7 @@ EOT_EOT # 7 <0> pushmark s # 8 <$> gv(*new) s # 9 <1> rv2av[t1] lKRM*/1 -# a <2> aassign[t6] KS/COMMON +# a <2> aassign[t6] KS/COM_AGG # b <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -733,7 +717,7 @@ checkOptree(note => q{}, # 7 <0> pushmark s # 8 <#> gv[*new] s # 9 <1> rv2av[t2] lKRM*/1 -# a <2> aassign[t14] KS/COMMON +# a <2> aassign[t14] KS/COM_AGG # b <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 578 (eval 15):1) v:%,{ @@ -746,7 +730,7 @@ EOT_EOT # 7 <0> pushmark s # 8 <$> gv(*new) s # 9 <1> rv2av[t1] lKRM*/1 -# a <2> aassign[t6] KS/COMMON +# a <2> aassign[t6] KS/COM_AGG # b <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -772,7 +756,7 @@ checkOptree(note => q{}, # 7 <0> pushmark s # 8 <#> gv[*articles] s # 9 <1> rv2av[t2] lKRM*/1 -# a <2> aassign[t8] KS/COMMON +# a <2> aassign[t8] KS/COM_AGG # b <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 546 (eval 15):1) v @@ -785,7 +769,7 @@ EOT_EOT # 7 <0> pushmark s # 8 <$> gv(*articles) s # 9 <1> rv2av[t1] lKRM*/1 -# a <2> aassign[t4] KS/COMMON +# a <2> aassign[t4] KS/COM_AGG # b <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -819,7 +803,7 @@ checkOptree(note => q{}, # d <0> pushmark s # e <#> gv[*result] s # f <1> rv2av[t2] lKRM*/1 -# g <2> aassign[t3] KS/COMMON +# g <2> aassign[t3] KS/COM_AGG # h <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 547 (eval 15):1) v @@ -840,7 +824,7 @@ EOT_EOT # d <0> pushmark s # e <$> gv(*result) s # f <1> rv2av[t1] lKRM*/1 -# g <2> aassign[t2] KS/COMMON +# g <2> aassign[t2] KS/COM_AGG # h <1> leavesub[1 ref] K/REFC,1 EONT_EONT diff --git a/gnu/usr.bin/perl/ext/B/t/optree_check.t b/gnu/usr.bin/perl/ext/B/t/optree_check.t index 38ff88b64e9..9daf5221b73 100755 --- a/gnu/usr.bin/perl/ext/B/t/optree_check.t +++ b/gnu/usr.bin/perl/ext/B/t/optree_check.t @@ -149,11 +149,11 @@ checkOptree ( name => 'fixup nextstate (in reftext)', strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); # 1 <;> nextstate( NOTE THAT THIS CAN BE ANYTHING ) v:>,<,% -# 2 <0> padsv[$a:54,55] M/LVINTRO +# 2 <0> padsv[$a:54,55] sM/LVINTRO # 3 <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 54 optree_concise.t:84) v:>,<,% -# 2 <0> padsv[$a:54,55] M/LVINTRO +# 2 <0> padsv[$a:54,55] sM/LVINTRO # 3 <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -164,11 +164,11 @@ checkOptree ( name => 'fixup opcode args', strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); # 1 <;> nextstate(main 56 optree_concise.t:96) v:>,<,% -# 2 <0> padsv[$a:56,57] M/LVINTRO +# 2 <0> padsv[$a:56,57] sM/LVINTRO # 3 <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 56 optree_concise.t:96) v:>,<,% -# 2 <0> padsv[$a:56,57] M/LVINTRO +# 2 <0> padsv[$a:56,57] sM/LVINTRO # 3 <1> leavesub[1 ref] K/REFC,1 EONT_EONT diff --git a/gnu/usr.bin/perl/ext/B/t/optree_concise.t b/gnu/usr.bin/perl/ext/B/t/optree_concise.t index aa28ebb14ca..12781acdb82 100755 --- a/gnu/usr.bin/perl/ext/B/t/optree_concise.t +++ b/gnu/usr.bin/perl/ext/B/t/optree_concise.t @@ -264,7 +264,7 @@ checkOptree ( name => 'cmdline self-strict compile err using prog', prog => 'use strict; sort @a', bcopts => [qw/ -basic -concise -exec /], - errs => 'Global symbol "@a" requires explicit package name at -e line 1.', + errs => 'Global symbol "@a" requires explicit package name (did you forget to declare "my @a"?) at -e line 1.', expect => 'nextstate', expect_nt => 'nextstate', noanchors => 1, # allow simple expectations to work @@ -274,7 +274,9 @@ checkOptree ( name => 'cmdline self-strict compile err using code', code => 'use strict; sort @a', bcopts => [qw/ -basic -concise -exec /], - errs => qr/Global symbol "\@a" requires explicit package name at .*? line 1\./, + errs => qr/Global symbol "\@a" requires explicit package (?x: + )name \(did you forget to declare "my \@a"\?\) at (?x: + ).*? line 1\./, note => 'this test relys on a kludge which copies $@ to rendering when empty', expect => 'Global symbol', expect_nt => 'Global symbol', @@ -289,26 +291,20 @@ checkOptree strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); # 1 <0> enter -# 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ -# 3 <#> gv[*a] s -# 4 <1> rv2av[t3] vK/OURINTR,1 -# 5 <;> nextstate(main 2 -e:1) v:>,<,%,{ -# 6 <0> pushmark s -# 7 <#> gv[*a] s -# 8 <1> rv2av[t5] lK/1 -# 9 <@> sort vK -# a <@> leave[1 ref] vKP/REFC +# 2 <;> nextstate(main 2 -e:1) v:>,<,%,{ +# 3 <0> pushmark s +# 4 <#> gv[*a] s +# 5 <1> rv2av[t5] lK/1 +# 6 <@> sort vK +# 7 <@> leave[1 ref] vKP/REFC EOT_EOT # 1 <0> enter -# 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ -# 3 <$> gv(*a) s -# 4 <1> rv2av[t2] vK/OURINTR,1 -# 5 <;> nextstate(main 2 -e:1) v:>,<,%,{ -# 6 <0> pushmark s -# 7 <$> gv(*a) s -# 8 <1> rv2av[t3] lK/1 -# 9 <@> sort vK -# a <@> leave[1 ref] vKP/REFC +# 2 <;> nextstate(main 2 -e:1) v:>,<,%,{ +# 3 <0> pushmark s +# 4 <$> gv(*a) s +# 5 <1> rv2av[t3] lK/1 +# 6 <@> sort vK +# 7 <@> leave[1 ref] vKP/REFC EONT_EONT diff --git a/gnu/usr.bin/perl/ext/B/t/optree_misc.t b/gnu/usr.bin/perl/ext/B/t/optree_misc.t index f327bfc036f..2d6b80f820b 100644 --- a/gnu/usr.bin/perl/ext/B/t/optree_misc.t +++ b/gnu/usr.bin/perl/ext/B/t/optree_misc.t @@ -27,38 +27,38 @@ checkOptree ( name => 'OP_AELEMFAST opclass', code => sub { my @x; our @y; $x[127] + $y[-128]}, strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); -# a <1> leavesub[1 ref] K/REFC,1 ->(end) -# - <@> lineseq KP ->a +# 7 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->7 # 1 <;> nextstate(main 634 optree_misc.t:25) v:>,<,% ->2 # 2 <0> padav[@x:634,636] vM/LVINTRO ->3 -# 3 <;> nextstate(main 635 optree_misc.t:25) v:>,<,% ->4 -# 5 <1> rv2av[t4] vK/OURINTR,1 ->6 -# 4 <#> gv[*y] s ->5 -# 6 <;> nextstate(main 636 optree_misc.t:25) v:>,<,%,{ ->7 -# 9 <2> add[t6] sK/2 ->a -# - <1> ex-aelem sK/2 ->8 -# 7 <0> aelemfast_lex[@x:634,636] sR/127 ->8 +# - <;> ex-nextstate(main 1594 optree_misc.t:27) v:>,<,% ->3 +# - <1> rv2av[t4] vK/OURINTR,1 ->3 +# - <#> gv[*y] s ->- +# 3 <;> nextstate(main 636 optree_misc.t:25) v:>,<,%,{ ->4 +# 6 <2> add[t6] sK/2 ->7 +# - <1> ex-aelem sK/2 ->5 +# 4 <0> aelemfast_lex[@x:634,636] sR/127 ->5 # - <0> ex-const s ->- -# - <1> ex-aelem sK/2 ->9 +# - <1> ex-aelem sK/2 ->6 # - <1> ex-rv2av sKR/1 ->- -# 8 <#> aelemfast[*y] s/128 ->9 +# 5 <#> aelemfast[*y] s/128 ->6 # - <0> ex-const s/FOLD ->- EOT_EOT -# a <1> leavesub[1 ref] K/REFC,1 ->(end) -# - <@> lineseq KP ->a +# 7 <1> leavesub[1 ref] K/REFC,1 ->(end) +# - <@> lineseq KP ->7 # 1 <;> nextstate(main 634 optree_misc.t:27) v:>,<,% ->2 # 2 <0> padav[@x:634,636] vM/LVINTRO ->3 -# 3 <;> nextstate(main 635 optree_misc.t:27) v:>,<,% ->4 -# 5 <1> rv2av[t3] vK/OURINTR,1 ->6 -# 4 <$> gv(*y) s ->5 -# 6 <;> nextstate(main 636 optree_misc.t:27) v:>,<,%,{ ->7 -# 9 <2> add[t4] sK/2 ->a -# - <1> ex-aelem sK/2 ->8 -# 7 <0> aelemfast_lex[@x:634,636] sR/127 ->8 +# - <;> ex-nextstate(main 1594 optree_misc.t:27) v:>,<,% ->3 +# - <1> rv2av[t3] vK/OURINTR,1 ->3 +# - <$> gv(*y) s ->- +# 3 <;> nextstate(main 636 optree_misc.t:27) v:>,<,%,{ ->4 +# 6 <2> add[t4] sK/2 ->7 +# - <1> ex-aelem sK/2 ->5 +# 4 <0> aelemfast_lex[@x:634,636] sR/127 ->5 # - <0> ex-const s ->- -# - <1> ex-aelem sK/2 ->9 +# - <1> ex-aelem sK/2 ->6 # - <1> ex-rv2av sKR/1 ->- -# 8 <$> aelemfast(*y) s/128 ->9 +# 5 <$> aelemfast(*y) s/128 ->6 # - <0> ex-const s/FOLD ->- EONT_EONT @@ -92,7 +92,7 @@ EONT_EONT16 # 5 <1> leavesub[1 ref] K/REFC,1 ->(end) # - <@> lineseq KP ->5 # 1 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->2 -# 4 </> subst(/"(a)"/) KS ->5 +# 4 </> subst(/"(a)"/) sKS ->5 # - <1> ex-rv2sv sKRM/1 ->3 # 2 <#> gvsv[*foo] s ->3 # - <1> ex-rv2sv sK/1 ->4 @@ -101,7 +101,7 @@ EOT_EOT # 5 <1> leavesub[1 ref] K/REFC,1 ->(end) # - <@> lineseq KP ->5 # 1 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->2 -# 4 </> subst(/"(a)"/) KS ->5 +# 4 </> subst(/"(a)"/) sKS ->5 # - <1> ex-rv2sv sKRM/1 ->3 # 2 <$> gvsv(*foo) s ->3 # - <1> ex-rv2sv sK/1 ->4 @@ -159,7 +159,7 @@ checkOptree ( name => 'formats', # 2 <0> pushmark s ->3 # 3 <$> const[PV "@<<<\n"] s ->4 # - <@> lineseq lK ->5 -# - <0> ex-nextstate v ->4 +# - <;> ex-nextstate(main 3 tmp35894B:3) v:>,<,% ->4 # - <1> ex-rv2sv sK/1 ->- # 4 <#> gvsv[*a] s ->5 # 6 <;> nextstate(main 1 -:6) v:>,<,% ->7 @@ -167,7 +167,7 @@ checkOptree ( name => 'formats', # 7 <0> pushmark s ->8 # 8 <$> const[PV "@>>>\n"] s ->9 # - <@> lineseq lK ->b -# - <0> ex-nextstate v ->9 +# - <;> ex-nextstate(main 3 tmp35894B:5) v:>,<,% ->9 # a <1> rv2av[t3] lK/1 ->b # 9 <#> gv[*b] s ->a EOT_EOT @@ -179,7 +179,7 @@ EOT_EOT # 2 <0> pushmark s ->3 # 3 <$> const(PV "@<<<\n") s ->4 # - <@> lineseq lK ->5 -# - <0> ex-nextstate v ->4 +# - <;> ex-nextstate(main 3 tmp35894B:3) v:>,<,% ->4 # - <1> ex-rv2sv sK/1 ->- # 4 <$> gvsv(*a) s ->5 # 6 <;> nextstate(main 1 -:6) v:>,<,% ->7 @@ -187,7 +187,7 @@ EOT_EOT # 7 <0> pushmark s ->8 # 8 <$> const(PV "@>>>\n") s ->9 # - <@> lineseq lK ->b -# - <0> ex-nextstate v ->9 +# - <;> ex-nextstate(main 3 tmp35894B:5) v:>,<,% ->9 # a <1> rv2av[t3] lK/1 ->b # 9 <$> gv(*b) s ->a EONT_EONT @@ -205,25 +205,25 @@ checkOptree ( name => 'padrange', # - <0> padsv[$x:1,2] vM/LVINTRO ->- # - <0> padsv[$y:1,2] vM/LVINTRO ->- # 3 <;> nextstate(main 2 -e:1) v:>,<,% ->4 -# 8 <2> aassign[t4] vKS ->9 +# 8 <2> aassign[t4] vKS/COM_AGG ->9 # - <1> ex-list lKP ->5 -# 4 <0> padrange[$x:1,2; $y:1,2] l/2 ->5 -# - <0> padsv[$x:1,2] l ->- -# - <0> padsv[$y:1,2] l ->- +# 4 <0> padrange[$x:1,2; $y:1,2] /2 ->5 +# - <0> padsv[$x:1,2] s ->- +# - <0> padsv[$y:1,2] s ->- # - <1> ex-list lK ->8 # 5 <0> pushmark s ->6 # 7 <1> rv2av[t3] lKRM*/1 ->8 # 6 <#> gv[*a] s ->7 # 9 <;> nextstate(main 2 -e:1) v:>,<,%,{ ->a -# e <2> aassign[t6] KS ->f +# e <2> aassign[t6] KS/COM_RC1 ->f # - <1> ex-list lK ->d # a <0> pushmark s ->b # c <1> rv2av[t5] lK/1 ->d # b <#> gv[*a] s ->c # - <1> ex-list lKPRM* ->e -# d <0> padrange[$x:1,2; $y:1,2] lRM/2 ->e -# - <0> padsv[$x:1,2] lRM* ->- -# - <0> padsv[$y:1,2] lRM* ->- +# d <0> padrange[$x:1,2; $y:1,2] RM/2 ->e +# - <0> padsv[$x:1,2] sRM* ->- +# - <0> padsv[$y:1,2] sRM* ->- EOT_EOT # f <1> leavesub[1 ref] K/REFC,1 ->(end) # - <@> lineseq KP ->f @@ -233,25 +233,25 @@ EOT_EOT # - <0> padsv[$x:1,2] vM/LVINTRO ->- # - <0> padsv[$y:1,2] vM/LVINTRO ->- # 3 <;> nextstate(main 2 -e:1) v:>,<,% ->4 -# 8 <2> aassign[t4] vKS ->9 +# 8 <2> aassign[t4] vKS/COM_AGG ->9 # - <1> ex-list lKP ->5 -# 4 <0> padrange[$x:1,2; $y:1,2] l/2 ->5 -# - <0> padsv[$x:1,2] l ->- -# - <0> padsv[$y:1,2] l ->- +# 4 <0> padrange[$x:1,2; $y:1,2] /2 ->5 +# - <0> padsv[$x:1,2] s ->- +# - <0> padsv[$y:1,2] s ->- # - <1> ex-list lK ->8 # 5 <0> pushmark s ->6 # 7 <1> rv2av[t3] lKRM*/1 ->8 # 6 <$> gv(*a) s ->7 # 9 <;> nextstate(main 2 -e:1) v:>,<,%,{ ->a -# e <2> aassign[t6] KS ->f +# e <2> aassign[t6] KS/COM_RC1 ->f # - <1> ex-list lK ->d # a <0> pushmark s ->b # c <1> rv2av[t5] lK/1 ->d # b <$> gv(*a) s ->c # - <1> ex-list lKPRM* ->e -# d <0> padrange[$x:1,2; $y:1,2] lRM/2 ->e -# - <0> padsv[$x:1,2] lRM* ->- -# - <0> padsv[$y:1,2] lRM* ->- +# d <0> padrange[$x:1,2; $y:1,2] RM/2 ->e +# - <0> padsv[$x:1,2] sRM* ->- +# - <0> padsv[$y:1,2] sRM* ->- EONT_EONT checkOptree ( name => 'padrange and @_', @@ -268,66 +268,66 @@ checkOptree ( name => 'padrange and @_', # 1 <;> nextstate(main 1 p3:1) v:>,<,% ->2 # 3 <2> aassign[t5] vKS ->4 # - <1> ex-list lK ->- -# 2 <0> padrange[$a:1,4; $b:1,4] l*/LVINTRO,2 ->3 +# 2 <0> padrange[$a:1,4; $b:1,4] */LVINTRO,2 ->3 # - <1> rv2av[t4] lK/1 ->- # - <#> gv[*_] s ->- # - <1> ex-list lKPRM* ->3 # - <0> pushmark sRM*/LVINTRO ->- -# - <0> padsv[$a:1,4] lRM*/LVINTRO ->- -# - <0> padsv[$b:1,4] lRM*/LVINTRO ->- +# - <0> padsv[$a:1,4] sRM*/LVINTRO ->- +# - <0> padsv[$b:1,4] sRM*/LVINTRO ->- # 4 <;> nextstate(main 2 p3:2) v:>,<,% ->5 -# 9 <2> aassign[t10] vKS ->a +# 9 <2> aassign[t10] vKS/COM_RC1 ->a # - <1> ex-list lK ->8 # 5 <0> pushmark s ->6 # 7 <1> rv2av[t9] lK/1 ->8 # 6 <#> gv[*X::_] s ->7 # - <1> ex-list lKPRM* ->9 -# 8 <0> padrange[$c:2,4; $d:2,4] lRM/LVINTRO,2 ->9 -# - <0> padsv[$c:2,4] lRM*/LVINTRO ->- -# - <0> padsv[$d:2,4] lRM*/LVINTRO ->- +# 8 <0> padrange[$c:2,4; $d:2,4] RM/LVINTRO,2 ->9 +# - <0> padsv[$c:2,4] sRM*/LVINTRO ->- +# - <0> padsv[$d:2,4] sRM*/LVINTRO ->- # a <;> nextstate(Y 3 p3:4) v:>,<,%,{ ->b # c <2> aassign[t15] KS ->d # - <1> ex-list lK ->- -# b <0> padrange[$e:3,4; $f:3,4] l*/LVINTRO,2 ->c +# b <0> padrange[$e:3,4; $f:3,4] */LVINTRO,2 ->c # - <1> rv2av[t14] lK/1 ->- # - <#> gv[*_] s ->- # - <1> ex-list lKPRM* ->c # - <0> pushmark sRM*/LVINTRO ->- -# - <0> padsv[$e:3,4] lRM*/LVINTRO ->- -# - <0> padsv[$f:3,4] lRM*/LVINTRO ->- +# - <0> padsv[$e:3,4] sRM*/LVINTRO ->- +# - <0> padsv[$f:3,4] sRM*/LVINTRO ->- EOT_EOT # d <1> leavesub[1 ref] K/REFC,1 ->(end) # - <@> lineseq KP ->d # 1 <;> nextstate(main 1 p3:1) v:>,<,% ->2 # 3 <2> aassign[t5] vKS ->4 # - <1> ex-list lK ->- -# 2 <0> padrange[$a:1,4; $b:1,4] l*/LVINTRO,2 ->3 +# 2 <0> padrange[$a:1,4; $b:1,4] */LVINTRO,2 ->3 # - <1> rv2av[t4] lK/1 ->- # - <$> gv(*_) s ->- # - <1> ex-list lKPRM* ->3 # - <0> pushmark sRM*/LVINTRO ->- -# - <0> padsv[$a:1,4] lRM*/LVINTRO ->- -# - <0> padsv[$b:1,4] lRM*/LVINTRO ->- +# - <0> padsv[$a:1,4] sRM*/LVINTRO ->- +# - <0> padsv[$b:1,4] sRM*/LVINTRO ->- # 4 <;> nextstate(main 2 p3:2) v:>,<,% ->5 -# 9 <2> aassign[t10] vKS ->a +# 9 <2> aassign[t10] vKS/COM_RC1 ->a # - <1> ex-list lK ->8 # 5 <0> pushmark s ->6 # 7 <1> rv2av[t9] lK/1 ->8 # 6 <$> gv(*X::_) s ->7 # - <1> ex-list lKPRM* ->9 -# 8 <0> padrange[$c:2,4; $d:2,4] lRM/LVINTRO,2 ->9 -# - <0> padsv[$c:2,4] lRM*/LVINTRO ->- -# - <0> padsv[$d:2,4] lRM*/LVINTRO ->- +# 8 <0> padrange[$c:2,4; $d:2,4] RM/LVINTRO,2 ->9 +# - <0> padsv[$c:2,4] sRM*/LVINTRO ->- +# - <0> padsv[$d:2,4] sRM*/LVINTRO ->- # a <;> nextstate(Y 3 p3:4) v:>,<,%,{ ->b # c <2> aassign[t15] KS ->d # - <1> ex-list lK ->- -# b <0> padrange[$e:3,4; $f:3,4] l*/LVINTRO,2 ->c +# b <0> padrange[$e:3,4; $f:3,4] */LVINTRO,2 ->c # - <1> rv2av[t14] lK/1 ->- # - <$> gv(*_) s ->- # - <1> ex-list lKPRM* ->c # - <0> pushmark sRM*/LVINTRO ->- -# - <0> padsv[$e:3,4] lRM*/LVINTRO ->- -# - <0> padsv[$f:3,4] lRM*/LVINTRO ->- +# - <0> padsv[$e:3,4] sRM*/LVINTRO ->- +# - <0> padsv[$f:3,4] sRM*/LVINTRO ->- EONT_EONT checkOptree ( name => 'consolidate padranges', diff --git a/gnu/usr.bin/perl/ext/B/t/optree_samples.t b/gnu/usr.bin/perl/ext/B/t/optree_samples.t index 2a9c0105427..c6288d940b7 100755 --- a/gnu/usr.bin/perl/ext/B/t/optree_samples.t +++ b/gnu/usr.bin/perl/ext/B/t/optree_samples.t @@ -34,7 +34,7 @@ checkOptree ( name => '-basic sub {if shift print then,else}', # 3 <|> cond_expr(other->4) K/1 ->8 # 2 <0> shift s* ->3 # - <@> scope K ->- -# - <0> ex-nextstate v ->4 +# - <;> ex-nextstate(main 1594 optree_samples.t:25) v:>,<,% ->4 # 6 <@> print sK ->7 # 4 <0> pushmark s ->5 # 5 <$> const[PV "then"] s ->6 @@ -52,7 +52,7 @@ EOT_EOT # 3 <|> cond_expr(other->4) K/1 ->8 # 2 <0> shift s* ->3 # - <@> scope K ->- -# - <0> ex-nextstate v ->4 +# - <;> ex-nextstate(main 1594 optree_samples.t:25) v:>,<,% ->4 # 6 <@> print sK ->7 # 4 <0> pushmark s ->5 # 5 <$> const(PV "then") s ->6 @@ -83,7 +83,7 @@ checkOptree ( name => '-basic (see above, with my $a = shift)', # 7 <|> cond_expr(other->8) K/1 ->c # 6 <0> padsv[$a:666,670] s ->7 # - <@> scope K ->- -# - <0> ex-nextstate v ->8 +# - <;> ex-nextstate(main 1603 optree_samples.t:70) v:>,<,% ->8 # a <@> print sK ->b # 8 <0> pushmark s ->9 # 9 <$> const[PV "foo"] s ->a @@ -105,7 +105,7 @@ EOT_EOT # 7 <|> cond_expr(other->8) K/1 ->c # 6 <0> padsv[$a:666,670] s ->7 # - <@> scope K ->- -# - <0> ex-nextstate v ->8 +# - <;> ex-nextstate(main 1603 optree_samples.t:70) v:>,<,% ->8 # a <@> print sK ->b # 8 <0> pushmark s ->9 # 9 <$> const(PV "foo") s ->a @@ -240,7 +240,7 @@ checkOptree ( name => '-exec sub { foreach (1..10) {print "foo $_"} }', # 3 <$> const[IV 1] s # 4 <$> const[IV 10] s # 5 <#> gv[*_] s -# 6 <{> enteriter(next->d last->g redo->7) lKS/8 +# 6 <{> enteriter(next->d last->g redo->7) KS/DEF # e <0> iter s # f <|> and(other->7) K/1 # 7 <;> nextstate(main 442 optree.t:158) v:>,<,% @@ -259,7 +259,7 @@ EOT_EOT # 3 <$> const(IV 1) s # 4 <$> const(IV 10) s # 5 <$> gv(*_) s -# 6 <{> enteriter(next->d last->g redo->7) lKS/8 +# 6 <{> enteriter(next->d last->g redo->7) KS/DEF # e <0> iter s # f <|> and(other->7) K/1 # 7 <;> nextstate(main 443 optree_samples.t:182) v:>,<,% @@ -283,7 +283,7 @@ checkOptree ( name => '-basic sub { print "foo $_" foreach (1..10) }', # - <@> lineseq KP ->g # 1 <;> nextstate(main 445 optree.t:167) v:>,<,% ->2 # f <2> leaveloop K/2 ->g -# 6 <{> enteriter(next->c last->f redo->7) lKS/8 ->d +# 6 <{> enteriter(next->c last->f redo->7) KS/DEF ->d # - <0> ex-pushmark s ->2 # - <1> ex-list lK ->5 # 2 <0> pushmark s ->3 @@ -308,7 +308,7 @@ EOT_EOT # - <@> lineseq KP ->g # 1 <;> nextstate(main 446 optree_samples.t:192) v:>,<,% ->2 # f <2> leaveloop K/2 ->g -# 6 <{> enteriter(next->c last->f redo->7) lKS/8 ->d +# 6 <{> enteriter(next->c last->f redo->7) KS/DEF ->d # - <0> ex-pushmark s ->2 # - <1> ex-list lK ->5 # 2 <0> pushmark s ->3 @@ -341,7 +341,7 @@ checkOptree ( name => '-exec -e foreach (1..10) {print qq{foo $_}}', # 4 <$> const[IV 1] s # 5 <$> const[IV 10] s # 6 <#> gv[*_] s -# 7 <{> enteriter(next->e last->h redo->8) lKS/8 +# 7 <{> enteriter(next->e last->h redo->8) vKS/DEF # f <0> iter s # g <|> and(other->8) vK/1 # 8 <;> nextstate(main 1 -e:1) v:>,<,% @@ -361,7 +361,7 @@ EOT_EOT # 4 <$> const(IV 1) s # 5 <$> const(IV 10) s # 6 <$> gv(*_) s -# 7 <{> enteriter(next->e last->h redo->8) lKS/8 +# 7 <{> enteriter(next->e last->h redo->8) vKS/DEF # f <0> iter s # g <|> and(other->8) vK/1 # 8 <;> nextstate(main 1 -e:1) v:>,<,% @@ -386,7 +386,7 @@ checkOptree ( name => '-exec sub { print "foo $_" foreach (1..10) }', # 3 <$> const[IV 1] s # 4 <$> const[IV 10] s # 5 <#> gv[*_] s -# 6 <{> enteriter(next->c last->f redo->7) lKS/8 +# 6 <{> enteriter(next->c last->f redo->7) KS/DEF # d <0> iter s # e <|> and(other->7) K/1 # 7 <0> pushmark s @@ -404,7 +404,7 @@ EOT_EOT # 3 <$> const(IV 1) s # 4 <$> const(IV 10) s # 5 <$> gv(*_) s -# 6 <{> enteriter(next->c last->f redo->7) lKS/8 +# 6 <{> enteriter(next->c last->f redo->7) KS/DEF # d <0> iter s # e <|> and(other->7) K/1 # 7 <0> pushmark s @@ -437,7 +437,7 @@ checkOptree ( name => '@foo = grep(!/^\#/, @bar)', # a <0> pushmark s # b <#> gv[*foo] s # c <1> rv2av[t2] lKRM*/1 -# d <2> aassign[t6] KS/COMMON +# d <2> aassign[t6] KS/COM_AGG # e <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 496 (eval 20):1) v:{ @@ -453,7 +453,7 @@ EOT_EOT # a <0> pushmark s # b <$> gv(*foo) s # c <1> rv2av[t1] lKRM*/1 -# d <2> aassign[t4] KS/COMMON +# d <2> aassign[t4] KS/COM_AGG # e <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -485,7 +485,7 @@ checkOptree ( name => '%h = map { getkey($_) => $_ } @a', # h <#> gv[*h] s # i <1> rv2hv[t2] lKRM*/1 < 5.019006 # i <1> rv2hv lKRM*/1 >=5.019006 -# j <2> aassign[t10] KS/COMMON +# j <2> aassign[t10] KS/COM_AGG # k <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 501 (eval 22):1) v:{ @@ -509,7 +509,7 @@ EOT_EOT # h <$> gv(*h) s # i <1> rv2hv[t1] lKRM*/1 < 5.019006 # i <1> rv2hv lKRM*/1 >=5.019006 -# j <2> aassign[t5] KS/COMMON +# j <2> aassign[t5] KS/COM_AGG # k <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -530,7 +530,7 @@ checkOptree ( name => '%h=(); for $_(@a){$h{getkey($_)} = $_}', # a <1> rv2av[t6] sKRM/1 # b <#> gv[*_] s # c <1> rv2gv sKRM/1 -# d <{> enteriter(next->o last->r redo->e) lKS/8 +# d <{> enteriter(next->o last->r redo->e) KS/DEF # p <0> iter s # q <|> and(other->e) K/1 # e <;> nextstate(main 505 (eval 24):1) v:{ @@ -561,7 +561,7 @@ EOT_EOT # a <1> rv2av[t3] sKRM/1 # b <$> gv(*_) s # c <1> rv2gv sKRM/1 -# d <{> enteriter(next->o last->r redo->e) lKS/8 +# d <{> enteriter(next->o last->r redo->e) KS/DEF # p <0> iter s # q <|> and(other->e) K/1 # e <;> nextstate(main 505 (eval 24):1) v:{ diff --git a/gnu/usr.bin/perl/ext/B/t/optree_sort.t b/gnu/usr.bin/perl/ext/B/t/optree_sort.t index a78b31ee94a..0b5897d575d 100755 --- a/gnu/usr.bin/perl/ext/B/t/optree_sort.t +++ b/gnu/usr.bin/perl/ext/B/t/optree_sort.t @@ -77,7 +77,7 @@ checkOptree ( name => 'sub {@a = sort @a}', 7 <0> pushmark s 8 <#> gv[*a] s 9 <1> rv2av[t2] lKRM*/1 -a <2> aassign[t5] KS/COMMON +a <2> aassign[t5] KS/COM_AGG b <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 65 optree.t:311) v:>,<,% @@ -89,7 +89,7 @@ EOT_EOT # 7 <0> pushmark s # 8 <$> gv(*a) s # 9 <1> rv2av[t1] lKRM*/1 -# a <2> aassign[t3] KS/COMMON +# a <2> aassign[t3] KS/COM_AGG # b <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -196,9 +196,10 @@ checkOptree ( name => 'sub {my @a; @a = sort @a}', 5 <0> pushmark s 6 <0> padav[@a:-437,-436] l 7 <@> sort lK -8 <0> padrange[@a:-437,-436] l/1 -9 <2> aassign[t2] KS/COMMON -a <1> leavesub[1 ref] K/REFC,1 +8 <0> pushmark s +9 <0> padav[@a:-437,-436] lRM* +a <2> aassign[t2] KS/COM_AGG +b <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 427 optree_sort.t:172) v:>,<,% # 2 <0> padav[@a:427,428] vM/LVINTRO @@ -207,9 +208,10 @@ EOT_EOT # 5 <0> pushmark s # 6 <0> padav[@a:427,428] l # 7 <@> sort lK -# 8 <0> padrange[@a:427,428] l/1 -# 9 <2> aassign[t2] KS/COMMON -# a <1> leavesub[1 ref] K/REFC,1 +# 8 <0> pushmark s +# 9 <0> padav[@a:-437,-436] lRM* +# a <2> aassign[t2] KS/COM_AGG +# b <1> leavesub[1 ref] K/REFC,1 EONT_EONT checkOptree ( name => 'my @a; @a = sort @a', @@ -222,18 +224,20 @@ checkOptree ( name => 'my @a; @a = sort @a', 3 <0> padav[@a:1,2] vM/LVINTRO 4 <;> nextstate(main 2 -e:1) v:>,<,%,{ 5 <0> pushmark s -6 <0> padrange[@a:1,2] l/1 -7 <@> sort lK/INPLACE -8 <@> leave[1 ref] vKP/REFC +6 <0> pushmark s +7 <0> padav[@a:1,2] lRM* +8 <@> sort lK/INPLACE +9 <@> leave[1 ref] vKP/REFC EOT_EOT # 1 <0> enter # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ # 3 <0> padav[@a:1,2] vM/LVINTRO # 4 <;> nextstate(main 2 -e:1) v:>,<,%,{ # 5 <0> pushmark s -# 6 <0> padrange[@a:1,2] l/1 -# 7 <@> sort lK/INPLACE -# 8 <@> leave[1 ref] vKP/REFC +# 6 <0> pushmark s +# 7 <0> padav[@a:1,2] lRM* +# 8 <@> sort lK/INPLACE +# 9 <@> leave[1 ref] vKP/REFC EONT_EONT checkOptree ( name => 'sub {my @a; @a = sort @a; push @a, 1}', @@ -246,25 +250,29 @@ checkOptree ( name => 'sub {my @a; @a = sort @a; push @a, 1}', 2 <0> padav[@a:-437,-436] vM/LVINTRO 3 <;> nextstate(main -436 optree.t:325) v:>,<,% 4 <0> pushmark s -5 <0> padrange[@a:-437,-436] l/1 -6 <@> sort lK/INPLACE -7 <;> nextstate(main -436 optree.t:325) v:>,<,%,{ -8 <0> padrange[@a:-437,-436] l/1 -9 <$> const[IV 1] s -a <@> push[t3] sK/2 -b <1> leavesub[1 ref] K/REFC,1 +5 <0> pushmark s +6 <0> padav[@a:-437,-436] lRM* +7 <@> sort lK/INPLACE +8 <;> nextstate(main -436 optree.t:325) v:>,<,%,{ +9 <0> pushmark s +a <0> padav[@a:-437,-436] lRM +b <$> const[IV 1] s +c <@> push[t3] sK/2 +d <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 429 optree_sort.t:219) v:>,<,% # 2 <0> padav[@a:429,430] vM/LVINTRO # 3 <;> nextstate(main 430 optree_sort.t:220) v:>,<,% # 4 <0> pushmark s -# 5 <0> padrange[@a:429,430] l/1 -# 6 <@> sort lK/INPLACE -# 7 <;> nextstate(main 430 optree_sort.t:220) v:>,<,%,{ -# 8 <0> padrange[@a:429,430] l/1 -# 9 <$> const(IV 1) s -# a <@> push[t3] sK/2 -# b <1> leavesub[1 ref] K/REFC,1 +# 5 <0> pushmark s +# 6 <0> padav[@a:429,430] lRM* +# 7 <@> sort lK/INPLACE +# 8 <;> nextstate(main 430 optree_sort.t:220) v:>,<,%,{ +# 9 <0> pushmark s +# a <0> padav[@a:429,430] lRM +# b <$> const(IV 1) s +# c <@> push[t3] sK/2 +# d <1> leavesub[1 ref] K/REFC,1 EONT_EONT checkOptree ( name => 'sub {my @a; @a = sort @a; 1}', @@ -277,19 +285,21 @@ checkOptree ( name => 'sub {my @a; @a = sort @a; 1}', 2 <0> padav[@a:-437,-436] vM/LVINTRO 3 <;> nextstate(main -436 optree.t:325) v:>,<,% 4 <0> pushmark s -5 <0> padrange[@a:-437,-436] l/1 -6 <@> sort lK/INPLACE -7 <;> nextstate(main -436 optree.t:346) v:>,<,%,{ -8 <$> const[IV 1] s -9 <1> leavesub[1 ref] K/REFC,1 +5 <0> pushmark s +6 <0> padav[@a:-437,-436] lRM* +7 <@> sort lK/INPLACE +8 <;> nextstate(main -436 optree.t:346) v:>,<,%,{ +9 <$> const[IV 1] s +a <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 431 optree_sort.t:250) v:>,<,% # 2 <0> padav[@a:431,432] vM/LVINTRO # 3 <;> nextstate(main 432 optree_sort.t:251) v:>,<,% # 4 <0> pushmark s -# 5 <0> padrange[@a:431,432] l/1 -# 6 <@> sort lK/INPLACE -# 7 <;> nextstate(main 432 optree_sort.t:251) v:>,<,%,{ -# 8 <$> const(IV 1) s -# 9 <1> leavesub[1 ref] K/REFC,1 +# 5 <0> pushmark s +# 6 <0> padav[@a:431,432] lRM* +# 7 <@> sort lK/INPLACE +# 8 <;> nextstate(main 432 optree_sort.t:251) v:>,<,%,{ +# 9 <$> const(IV 1) s +# a <1> leavesub[1 ref] K/REFC,1 EONT_EONT diff --git a/gnu/usr.bin/perl/ext/B/t/optree_specials.t b/gnu/usr.bin/perl/ext/B/t/optree_specials.t index 3cf354c826e..d7200db9894 100755 --- a/gnu/usr.bin/perl/ext/B/t/optree_specials.t +++ b/gnu/usr.bin/perl/ext/B/t/optree_specials.t @@ -45,42 +45,42 @@ checkOptree ( name => 'BEGIN', # 1 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$ ->2 # 3 <1> require sK/1 ->4 # 2 <$> const[PV "strict.pm"] s/BARE ->3 -# 4 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$ ->5 +# - <;> ex-nextstate(B::Concise -837 Concise.pm:366) v:*,&,{,x*,x&,x$,$ ->4 # - <@> lineseq K ->- -# - <0> null ->5 -# 9 <1> entersub[t1] KS*/TARG,2 ->a +# 4 <;> nextstate(B::Concise -275 Concise.pm:356) :*,&,{,x*,x&,x$,$ ->5 +# 9 <1> entersub[t1] KS*/TARG,STRICT ->a # 5 <0> pushmark s ->6 # 6 <$> const[PV "strict"] sM ->7 # 7 <$> const[PV "refs"] sM ->8 -# 8 <$> method_named[PV "unimport"] ->9 +# 8 <.> method_named[PV "unimport"] ->9 # BEGIN 2: # k <1> leavesub[1 ref] K/REFC,1 ->(end) # - <@> lineseq K ->k # b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$ ->c # d <1> require sK/1 ->e # c <$> const[PV "strict.pm"] s/BARE ->d -# e <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$ ->f +# - <;> ex-nextstate(B::Concise -812 Concise.pm:386) v:*,&,x*,x&,x$,$ ->e # - <@> lineseq K ->- -# - <0> null ->f -# j <1> entersub[t1] KS*/TARG,2 ->k +# e <;> nextstate(B::Concise -265 Concise.pm:367) :*,&,x*,x&,x$,$ ->f +# j <1> entersub[t1] KS*/TARG,STRICT ->k # f <0> pushmark s ->g # g <$> const[PV "strict"] sM ->h # h <$> const[PV "refs"] sM ->i -# i <$> method_named[PV "unimport"] ->j +# i <.> method_named[PV "unimport"] ->j # BEGIN 3: # u <1> leavesub[1 ref] K/REFC,1 ->(end) # - <@> lineseq KP ->u # l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$ ->m # n <1> require sK/1 ->o # m <$> const[PV "warnings.pm"] s/BARE ->n -# o <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$ ->p +# - <;> ex-nextstate(B::Concise -798 Concise.pm:406) v:*,&,{,x*,x&,x$,$ ->o # - <@> lineseq K ->- -# - <0> null ->p -# t <1> entersub[t1] KS*/TARG,2 ->u +# o <;> nextstate(B::Concise -254 Concise.pm:386) :*,&,{,x*,x&,x$,$ ->p +# t <1> entersub[t1] KS*/TARG,STRICT ->u # p <0> pushmark s ->q # q <$> const[PV "warnings"] sM ->r # r <$> const[PV "qw"] sM ->s -# s <$> method_named[PV "unimport"] ->t +# s <.> method_named[PV "unimport"] ->t # BEGIN 4: # y <1> leavesub[1 ref] K/REFC,1 ->(end) # - <@> lineseq KP ->y @@ -95,42 +95,42 @@ EOT_EOT # 1 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$ ->2 # 3 <1> require sK/1 ->4 # 2 <$> const(PV "strict.pm") s/BARE ->3 -# 4 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$ ->5 +# - <;> ex-nextstate(B::Concise -837 Concise.pm:366) v:*,&,{,x*,x&,x$,$ ->4 # - <@> lineseq K ->- -# - <0> null ->5 -# 9 <1> entersub[t1] KS*/TARG,2 ->a +# 4 <;> nextstate(B::Concise -275 Concise.pm:356) :*,&,{,x*,x&,x$,$ ->5 +# 9 <1> entersub[t1] KS*/TARG,STRICT ->a # 5 <0> pushmark s ->6 # 6 <$> const(PV "strict") sM ->7 # 7 <$> const(PV "refs") sM ->8 -# 8 <$> method_named(PV "unimport") ->9 +# 8 <.> method_named(PV "unimport") ->9 # BEGIN 2: # k <1> leavesub[1 ref] K/REFC,1 ->(end) # - <@> lineseq K ->k # b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$ ->c # d <1> require sK/1 ->e # c <$> const(PV "strict.pm") s/BARE ->d -# e <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$ ->f +# - <;> ex-nextstate(B::Concise -812 Concise.pm:386) v:*,&,x*,x&,x$,$ ->e # - <@> lineseq K ->- -# - <0> null ->f -# j <1> entersub[t1] KS*/TARG,2 ->k +# e <;> nextstate(B::Concise -265 Concise.pm:367) :*,&,x*,x&,x$,$ ->f +# j <1> entersub[t1] KS*/TARG,STRICT ->k # f <0> pushmark s ->g # g <$> const(PV "strict") sM ->h # h <$> const(PV "refs") sM ->i -# i <$> method_named(PV "unimport") ->j +# i <.> method_named(PV "unimport") ->j # BEGIN 3: # u <1> leavesub[1 ref] K/REFC,1 ->(end) # - <@> lineseq KP ->u # l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$ ->m # n <1> require sK/1 ->o # m <$> const(PV "warnings.pm") s/BARE ->n -# o <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$ ->p +# - <;> ex-nextstate(B::Concise -798 Concise.pm:406) v:*,&,{,x*,x&,x$,$ ->o # - <@> lineseq K ->- -# - <0> null ->p -# t <1> entersub[t1] KS*/TARG,2 ->u +# o <;> nextstate(B::Concise -254 Concise.pm:386) :*,&,{,x*,x&,x$,$ ->p +# t <1> entersub[t1] KS*/TARG,STRICT ->u # p <0> pushmark s ->q # q <$> const(PV "warnings") sM ->r # r <$> const(PV "qw") sM ->s -# s <$> method_named(PV "unimport") ->t +# s <.> method_named(PV "unimport") ->t # BEGIN 4: # y <1> leavesub[1 ref] K/REFC,1 ->(end) # - <@> lineseq KP ->y @@ -241,34 +241,34 @@ checkOptree ( name => 'all of BEGIN END INIT CHECK UNITCHECK -exec', # 1 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$ # 2 <$> const[PV "strict.pm"] s/BARE # 3 <1> require sK/1 -# 4 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$ +# 4 <;> nextstate(B::Concise -275 Concise.pm:356) :*,&,{,x*,x&,x$,$ # 5 <0> pushmark s # 6 <$> const[PV "strict"] sM # 7 <$> const[PV "refs"] sM -# 8 <$> method_named[PV "unimport"] -# 9 <1> entersub[t1] KS*/TARG,2 +# 8 <.> method_named[PV "unimport"] +# 9 <1> entersub[t1] KS*/TARG,STRICT # a <1> leavesub[1 ref] K/REFC,1 # BEGIN 2: # b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$ # c <$> const[PV "strict.pm"] s/BARE # d <1> require sK/1 -# e <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$ +# e <;> nextstate(B::Concise -265 Concise.pm:367) :*,&,x*,x&,x$,$ # f <0> pushmark s # g <$> const[PV "strict"] sM # h <$> const[PV "refs"] sM -# i <$> method_named[PV "unimport"] -# j <1> entersub[t1] KS*/TARG,2 +# i <.> method_named[PV "unimport"] +# j <1> entersub[t1] KS*/TARG,STRICT # k <1> leavesub[1 ref] K/REFC,1 # BEGIN 3: # l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$ # m <$> const[PV "warnings.pm"] s/BARE # n <1> require sK/1 -# o <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$ +# o <;> nextstate(B::Concise -254 Concise.pm:386) :*,&,{,x*,x&,x$,$ # p <0> pushmark s # q <$> const[PV "warnings"] sM # r <$> const[PV "qw"] sM -# s <$> method_named[PV "unimport"] -# t <1> entersub[t1] KS*/TARG,2 +# s <.> method_named[PV "unimport"] +# t <1> entersub[t1] KS*/TARG,STRICT # u <1> leavesub[1 ref] K/REFC,1 # BEGIN 4: # v <;> nextstate(main 2 -e:1) v:>,<,%,{ @@ -300,34 +300,34 @@ EOT_EOT # 1 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$ # 2 <$> const(PV "strict.pm") s/BARE # 3 <1> require sK/1 -# 4 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$ +# 4 <;> nextstate(B::Concise -275 Concise.pm:356) :*,&,{,x*,x&,x$,$ # 5 <0> pushmark s # 6 <$> const(PV "strict") sM # 7 <$> const(PV "refs") sM -# 8 <$> method_named(PV "unimport") -# 9 <1> entersub[t1] KS*/TARG,2 +# 8 <.> method_named(PV "unimport") +# 9 <1> entersub[t1] KS*/TARG,STRICT # a <1> leavesub[1 ref] K/REFC,1 # BEGIN 2: # b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$ # c <$> const(PV "strict.pm") s/BARE # d <1> require sK/1 -# e <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$ +# e <;> nextstate(B::Concise -265 Concise.pm:367) :*,&,x*,x&,x$,$ # f <0> pushmark s # g <$> const(PV "strict") sM # h <$> const(PV "refs") sM -# i <$> method_named(PV "unimport") -# j <1> entersub[t1] KS*/TARG,2 +# i <.> method_named(PV "unimport") +# j <1> entersub[t1] KS*/TARG,STRICT # k <1> leavesub[1 ref] K/REFC,1 # BEGIN 3: # l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$ # m <$> const(PV "warnings.pm") s/BARE # n <1> require sK/1 -# o <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$ +# o <;> nextstate(B::Concise -254 Concise.pm:386) :*,&,{,x*,x&,x$,$ # p <0> pushmark s # q <$> const(PV "warnings") sM # r <$> const(PV "qw") sM -# s <$> method_named(PV "unimport") -# t <1> entersub[t1] KS*/TARG,2 +# s <.> method_named(PV "unimport") +# t <1> entersub[t1] KS*/TARG,STRICT # u <1> leavesub[1 ref] K/REFC,1 # BEGIN 4: # v <;> nextstate(main 2 -e:1) v:>,<,%,{ @@ -369,67 +369,67 @@ checkOptree ( name => 'regression test for patch 25352', # 1 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$ # 2 <$> const[PV "strict.pm"] s/BARE # 3 <1> require sK/1 -# 4 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$ +# 4 <;> nextstate(B::Concise -275 Concise.pm:356) :*,&,{,x*,x&,x$,$ # 5 <0> pushmark s # 6 <$> const[PV "strict"] sM # 7 <$> const[PV "refs"] sM -# 8 <$> method_named[PV "unimport"] -# 9 <1> entersub[t1] KS*/TARG,2 +# 8 <.> method_named[PV "unimport"] +# 9 <1> entersub[t1] KS*/TARG,STRICT # a <1> leavesub[1 ref] K/REFC,1 # BEGIN 2: # b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$ # c <$> const[PV "strict.pm"] s/BARE # d <1> require sK/1 -# e <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$ +# e <;> nextstate(B::Concise -265 Concise.pm:367) :*,&,x*,x&,x$,$ # f <0> pushmark s # g <$> const[PV "strict"] sM # h <$> const[PV "refs"] sM -# i <$> method_named[PV "unimport"] -# j <1> entersub[t1] KS*/TARG,2 +# i <.> method_named[PV "unimport"] +# j <1> entersub[t1] KS*/TARG,STRICT # k <1> leavesub[1 ref] K/REFC,1 # BEGIN 3: # l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$ # m <$> const[PV "warnings.pm"] s/BARE # n <1> require sK/1 -# o <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$ +# o <;> nextstate(B::Concise -254 Concise.pm:386) :*,&,{,x*,x&,x$,$ # p <0> pushmark s # q <$> const[PV "warnings"] sM # r <$> const[PV "qw"] sM -# s <$> method_named[PV "unimport"] -# t <1> entersub[t1] KS*/TARG,2 +# s <.> method_named[PV "unimport"] +# t <1> entersub[t1] KS*/TARG,STRICT # u <1> leavesub[1 ref] K/REFC,1 EOT_EOT # BEGIN 1: # 1 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$ # 2 <$> const(PV "strict.pm") s/BARE # 3 <1> require sK/1 -# 4 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$ +# 4 <;> nextstate(B::Concise -275 Concise.pm:356) :*,&,{,x*,x&,x$,$ # 5 <0> pushmark s # 6 <$> const(PV "strict") sM # 7 <$> const(PV "refs") sM -# 8 <$> method_named(PV "unimport") -# 9 <1> entersub[t1] KS*/TARG,2 +# 8 <.> method_named(PV "unimport") +# 9 <1> entersub[t1] KS*/TARG,STRICT # a <1> leavesub[1 ref] K/REFC,1 # BEGIN 2: # b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$ # c <$> const(PV "strict.pm") s/BARE # d <1> require sK/1 -# e <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$ +# e <;> nextstate(B::Concise -265 Concise.pm:367) :*,&,x*,x&,x$,$ # f <0> pushmark s # g <$> const(PV "strict") sM # h <$> const(PV "refs") sM -# i <$> method_named(PV "unimport") -# j <1> entersub[t1] KS*/TARG,2 +# i <.> method_named(PV "unimport") +# j <1> entersub[t1] KS*/TARG,STRICT # k <1> leavesub[1 ref] K/REFC,1 # BEGIN 3: # l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$ # m <$> const(PV "warnings.pm") s/BARE # n <1> require sK/1 -# o <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$ +# o <;> nextstate(B::Concise -254 Concise.pm:386) :*,&,{,x*,x&,x$,$ # p <0> pushmark s # q <$> const(PV "warnings") sM # r <$> const(PV "qw") sM -# s <$> method_named(PV "unimport") -# t <1> entersub[t1] KS*/TARG,2 +# s <.> method_named(PV "unimport") +# t <1> entersub[t1] KS*/TARG,STRICT # u <1> leavesub[1 ref] K/REFC,1 EONT_EONT diff --git a/gnu/usr.bin/perl/ext/B/t/optree_varinit.t b/gnu/usr.bin/perl/ext/B/t/optree_varinit.t index ca2b59b6ed5..6d2038deb82 100755 --- a/gnu/usr.bin/perl/ext/B/t/optree_varinit.t +++ b/gnu/usr.bin/perl/ext/B/t/optree_varinit.t @@ -24,11 +24,11 @@ checkOptree ( name => 'sub {my $a}', strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); # 1 <;> nextstate(main 45 optree.t:23) v:>,<,% -# 2 <0> padsv[$a:45,46] M/LVINTRO +# 2 <0> padsv[$a:45,46] sM/LVINTRO # 3 <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 45 optree.t:23) v:>,<,% -# 2 <0> padsv[$a:45,46] M/LVINTRO +# 2 <0> padsv[$a:45,46] sM/LVINTRO # 3 <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -38,11 +38,11 @@ checkOptree ( name => '-exec sub {my $a}', strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); # 1 <;> nextstate(main 49 optree.t:52) v:>,<,% -# 2 <0> padsv[$a:49,50] M/LVINTRO +# 2 <0> padsv[$a:49,50] sM/LVINTRO # 3 <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 49 optree.t:45) v:>,<,% -# 2 <0> padsv[$a:49,50] M/LVINTRO +# 2 <0> padsv[$a:49,50] sM/LVINTRO # 3 <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -95,17 +95,17 @@ checkOptree ( name => 'our $a', bcopts => '-basic', strip_open_hints => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); -4 <@> leave[1 ref] vKP/REFC ->(end) +3 <@> leave[1 ref] vKP/REFC ->(end) 1 <0> enter ->2 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3 -- <1> ex-rv2sv vK/17 ->4 -3 <#> gvsv[*a] s/OURINTR ->4 +- <1> rv2sv vK/OURINTR,1 ->3 +- <#> gv[*a] s ->- EOT_EOT -# 4 <@> leave[1 ref] vKP/REFC ->(end) +# 3 <@> leave[1 ref] vKP/REFC ->(end) # 1 <0> enter ->2 # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3 -# - <1> ex-rv2sv vK/17 ->4 -# 3 <$> gvsv(*a) s/OURINTR ->4 +# - <1> rv2sv vK/OURINTR,1 ->3 +# - <$> gv(*a) s ->- EONT_EONT checkOptree ( name => 'local $c', @@ -117,13 +117,13 @@ checkOptree ( name => 'local $c', 4 <@> leave[1 ref] vKP/REFC ->(end) 1 <0> enter ->2 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3 -- <1> ex-rv2sv vKM/129 ->4 +- <1> ex-rv2sv vKM/LVINTRO,1 ->4 3 <#> gvsv[*c] s/LVINTRO ->4 EOT_EOT # 4 <@> leave[1 ref] vKP/REFC ->(end) # 1 <0> enter ->2 # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3 -# - <1> ex-rv2sv vKM/129 ->4 +# - <1> ex-rv2sv vKM/LVINTRO,1 ->4 # 3 <$> gvsv(*c) s/LVINTRO ->4 EONT_EONT @@ -160,7 +160,7 @@ checkOptree ( name => 'sub {our $a=undef}', 1 <;> nextstate(main 26 optree.t:109) v:>,<,%,{ ->2 4 <2> sassign sKS/2 ->5 2 <0> undef s ->3 -- <1> ex-rv2sv sKRM*/17 ->4 +- <1> ex-rv2sv sKRM*/OURINTR,1 ->4 3 <#> gvsv[*a] s/OURINTR ->4 EOT_EOT # 5 <1> leavesub[1 ref] K/REFC,1 ->(end) @@ -168,7 +168,7 @@ EOT_EOT # 1 <;> nextstate(main 446 optree_varinit.t:137) v:>,<,%,{ ->2 # 4 <2> sassign sKS/2 ->5 # 2 <0> undef s ->3 -# - <1> ex-rv2sv sKRM*/17 ->4 +# - <1> ex-rv2sv sKRM*/OURINTR,1 ->4 # 3 <$> gvsv(*a) s/OURINTR ->4 EONT_EONT @@ -183,7 +183,7 @@ checkOptree ( name => 'sub {local $a=undef}', 1 <;> nextstate(main 28 optree.t:122) v:>,<,%,{ ->2 4 <2> sassign sKS/2 ->5 2 <0> undef s ->3 -- <1> ex-rv2sv sKRM*/129 ->4 +- <1> ex-rv2sv sKRM*/LVINTRO,1 ->4 3 <#> gvsv[*a] s/LVINTRO ->4 EOT_EOT # 5 <1> leavesub[1 ref] K/REFC,1 ->(end) @@ -191,7 +191,7 @@ EOT_EOT # 1 <;> nextstate(main 58 optree.t:141) v:>,<,%,{ ->2 # 4 <2> sassign sKS/2 ->5 # 2 <0> undef s ->3 -# - <1> ex-rv2sv sKRM*/129 ->4 +# - <1> ex-rv2sv sKRM*/LVINTRO,1 ->4 # 3 <$> gvsv(*a) s/LVINTRO ->4 EONT_EONT @@ -226,7 +226,7 @@ checkOptree ( name => 'our $a=undef', 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3 5 <2> sassign vKS/2 ->6 3 <0> undef s ->4 -- <1> ex-rv2sv sKRM*/17 ->5 +- <1> ex-rv2sv sKRM*/OURINTR,1 ->5 4 <#> gvsv[*a] s/OURINTR ->5 EOT_EOT # 6 <@> leave[1 ref] vKP/REFC ->(end) @@ -234,7 +234,7 @@ EOT_EOT # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3 # 5 <2> sassign vKS/2 ->6 # 3 <0> undef s ->4 -# - <1> ex-rv2sv sKRM*/17 ->5 +# - <1> ex-rv2sv sKRM*/OURINTR,1 ->5 # 4 <$> gvsv(*a) s/OURINTR ->5 EONT_EONT @@ -250,7 +250,7 @@ checkOptree ( name => 'local $c=undef', 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3 5 <2> sassign vKS/2 ->6 3 <0> undef s ->4 -- <1> ex-rv2sv sKRM*/129 ->5 +- <1> ex-rv2sv sKRM*/LVINTRO,1 ->5 4 <#> gvsv[*c] s/LVINTRO ->5 EOT_EOT # 6 <@> leave[1 ref] vKP/REFC ->(end) @@ -258,7 +258,7 @@ EOT_EOT # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3 # 5 <2> sassign vKS/2 ->6 # 3 <0> undef s ->4 -# - <1> ex-rv2sv sKRM*/129 ->5 +# - <1> ex-rv2sv sKRM*/LVINTRO,1 ->5 # 4 <$> gvsv(*c) s/LVINTRO ->5 EONT_EONT @@ -390,14 +390,14 @@ checkOptree ( name => 'my ($a,$b)=()', # 1 <0> enter # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ # 3 <0> pushmark s -# 4 <0> padrange[$a:1,2; $b:1,2] lRM/LVINTRO,2 +# 4 <0> padrange[$a:1,2; $b:1,2] RM/LVINTRO,2 # 5 <2> aassign[t3] vKS # 6 <@> leave[1 ref] vKP/REFC EOT_EOT # 1 <0> enter # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ # 3 <0> pushmark s -# 4 <0> padrange[$a:1,2; $b:1,2] lRM/LVINTRO,2 +# 4 <0> padrange[$a:1,2; $b:1,2] RM/LVINTRO,2 # 5 <2> aassign[t3] vKS # 6 <@> leave[1 ref] vKP/REFC EONT_EONT diff --git a/gnu/usr.bin/perl/ext/B/t/showlex.t b/gnu/usr.bin/perl/ext/B/t/showlex.t index 2871622a5dd..dd5cdb7f38a 100644 --- a/gnu/usr.bin/perl/ext/B/t/showlex.t +++ b/gnu/usr.bin/perl/ext/B/t/showlex.t @@ -31,7 +31,7 @@ if ($is_thread) { ok "# use5005threads: test skipped\n"; } else { $a = `$^X $path "-MO=Showlex" -e "my \@one" 2>&1`; - like ($a, qr/sv_undef.*PVNV.*\@one.*Nullsv.*AV/s, + like ($a, qr/undef.*: \([^)]*\) \@one.*Nullsv.*AV/s, "canonical usage works"); } @@ -43,8 +43,8 @@ my ($out, $newlex); # output, option-flag sub padrep { my ($varname,$newlex) = @_; return ($newlex) - ? 'PVNV \(0x[0-9a-fA-F]+\) "\\'.$varname.'" = ' - : "PVNV \\\(0x[0-9a-fA-F]+\\\) \\$varname\n"; + ? '\(0x[0-9a-fA-F]+\) "\\'.$varname.'" = ' + : "\\\(0x[0-9a-fA-F]+\\\) \\$varname\n"; } for $newlex ('', '-newlex') { diff --git a/gnu/usr.bin/perl/ext/B/t/sv_stash.t b/gnu/usr.bin/perl/ext/B/t/sv_stash.t new file mode 100644 index 00000000000..e9abf4d55d9 --- /dev/null +++ b/gnu/usr.bin/perl/ext/B/t/sv_stash.t @@ -0,0 +1,21 @@ +#!./perl -w + +BEGIN { + unshift @INC, 't'; + require Config; + if ( ( $Config::Config{'extensions'} !~ /\bB\b/ ) ) { + print "1..0 # Skip -- Perl configured without B module\n"; + exit 0; + } + require 'test.pl'; +} +plan 1; + +# RT #126410 = used to coredump when doing SvSTASH on %version:: + +TODO: { + fresh_perl_is( + 'use B; version->new("v5.22.0"); $s = B::svref_2object(\%version::); $s->SvSTASH; print "ok\n"', + "ok\n", { stderr => 1 }, 'RT #126410 - SvSTASH against %version::' + ); +} diff --git a/gnu/usr.bin/perl/ext/B/typemap b/gnu/usr.bin/perl/ext/B/typemap index e97fb76d94f..045d6a0f717 100644 --- a/gnu/usr.bin/perl/ext/B/typemap +++ b/gnu/usr.bin/perl/ext/B/typemap @@ -37,6 +37,8 @@ B::HE T_HE_OBJ B::RHE T_RHE_OBJ B::PADLIST T_PL_OBJ +B::PADNAMELIST T_PNL_OBJ +B::PADNAME T_PN_OBJ INPUT T_OP_OBJ @@ -87,6 +89,22 @@ T_PL_OBJ else croak(\"$var is not a reference\") +T_PNL_OBJ + if (SvROK($arg)) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type,tmp); + } + else + croak(\"$var is not a reference\") + +T_PN_OBJ + if (SvROK($arg)) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type,tmp); + } + else + croak(\"$var is not a reference\") + OUTPUT T_MG_OBJ sv_setiv(newSVrv($arg, "B::MAGIC"), PTR2IV($var)); @@ -100,3 +118,11 @@ T_RHE_OBJ T_PL_OBJ sv_setiv(newSVrv($arg, $var ? "B::PADLIST" : "B::NULL"), PTR2IV($var)); + +T_PNL_OBJ + sv_setiv(newSVrv($arg, $var ? "B::PADNAMELIST" : "B::NULL"), + PTR2IV($var)); + +T_PN_OBJ + sv_setiv(newSVrv($arg, $var ? "B::PADNAME" : "B::SPECIAL"), + PTR2IV($var)); diff --git a/gnu/usr.bin/perl/ext/Devel-Peek/Peek.pm b/gnu/usr.bin/perl/ext/Devel-Peek/Peek.pm index 731dc111176..c0483ca1449 100644 --- a/gnu/usr.bin/perl/ext/Devel-Peek/Peek.pm +++ b/gnu/usr.bin/perl/ext/Devel-Peek/Peek.pm @@ -3,7 +3,7 @@ package Devel::Peek; -$VERSION = '1.16'; +$VERSION = '1.23'; $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -64,6 +64,16 @@ sub debug_flags (;$) { $out } +sub B::Deparse::pp_Devel_Peek_Dump { + my ($deparse,$op,$cx) = @_; + my @kids = $deparse->deparse($op->first, 6); + my $sib = $op->first->sibling; + if (ref $sib ne 'B::NULL') { + push @kids, $deparse->deparse($sib, 6); + } + return "Devel::Peek::Dump(" . join(", ", @kids) . ")"; +} + 1; __END__ @@ -105,6 +115,8 @@ counts on SVs. This document will take a passive, and safe, approach to data debugging and for that it will describe only the C<Dump()> function. +All output is to STDERR. + The C<Dump()> function takes one or two arguments: something to dump, and an optional limit for recursion and array elements (default is 4). The first argument is evaluted in rvalue scalar context, with exceptions for diff --git a/gnu/usr.bin/perl/ext/Devel-Peek/Peek.xs b/gnu/usr.bin/perl/ext/Devel-Peek/Peek.xs index 679efa5d063..132cad79e32 100644 --- a/gnu/usr.bin/perl/ext/Devel-Peek/Peek.xs +++ b/gnu/usr.bin/perl/ext/Devel-Peek/Peek.xs @@ -31,7 +31,7 @@ DeadCode(pTHX) for (sv = sva + 1; sv < svend; ++sv) { if (SvTYPE(sv) == SVt_PVCV) { CV *cv = (CV*)sv; - PADLIST* padlist = CvPADLIST(cv); + PADLIST* padlist; AV *argav; SV** svp; SV** pad; @@ -54,6 +54,7 @@ DeadCode(pTHX) PerlIO_printf(Perl_debug_log, " busy\n"); continue; } + padlist = CvPADLIST(cv); svp = (SV**) PadlistARRAY(padlist); while (++i <= PadlistMAX(padlist)) { /* Depth. */ SV **args; @@ -351,7 +352,7 @@ S_pp_dump(pTHX) static OP * S_ck_dump(pTHX_ OP *entersubop, GV *namegv, SV *cv) { - OP *aop, *prev, *first, *second = NULL; + OP *parent, *pm, *first, *second; BINOP *newop; PERL_UNUSED_ARG(cv); @@ -359,24 +360,25 @@ S_ck_dump(pTHX_ OP *entersubop, GV *namegv, SV *cv) ck_entersub_args_proto(entersubop, namegv, newSVpvn_flags("$;$", 3, SVs_TEMP)); - aop = cUNOPx(entersubop)->op_first; - if (!aop->op_sibling) - aop = cUNOPx(aop)->op_first; - prev = aop; - aop = aop->op_sibling; - while (PL_madskills && aop->op_type == OP_STUB) { - prev = aop; - aop = aop->op_sibling; + parent = entersubop; + pm = cUNOPx(entersubop)->op_first; + if (!OpHAS_SIBLING(pm)) { + parent = pm; + pm = cUNOPx(pm)->op_first; } - if (PL_madskills && aop->op_type == OP_NULL) { - first = ((UNOP*)aop)->op_first; - ((UNOP*)aop)->op_first = NULL; - prev = aop; - } - else { - first = aop; - prev->op_sibling = first->op_sibling; + first = OpSIBLING(pm); + second = OpSIBLING(first); + if (!second) { + /* It doesn’t really matter what we return here, as this only + occurs after yyerror. */ + return entersubop; } + /* we either have Dump($x): [pushmark]->[first]->[ex-cvop] + * or Dump($x,1); [pushmark]->[first]->[second]->[ex-cvop] + */ + if (!OpHAS_SIBLING(second)) + second = NULL; + if (first->op_type == OP_RV2AV || first->op_type == OP_PADAV || first->op_type == OP_RV2HV || @@ -385,41 +387,32 @@ S_ck_dump(pTHX_ OP *entersubop, GV *namegv, SV *cv) first->op_flags |= OPf_REF; else first->op_flags &= ~OPf_MOD; - aop = aop->op_sibling; - while (PL_madskills && aop->op_type == OP_STUB) { - prev = aop; - aop = aop->op_sibling; - } - if (!aop) { - /* It doesn’t really matter what we return here, as this only - occurs after yyerror. */ - op_free(first); - return entersubop; - } - /* aop now points to the second arg if there is one, the cvop otherwise - */ - if (aop->op_sibling) { - prev->op_sibling = aop->op_sibling; - second = aop; - second->op_sibling = NULL; - } - first->op_sibling = second; + /* splice out first (and optionally second) ops, then discard the rest + * of the op tree */ + op_sibling_splice(parent, pm, second ? 2 : 1, NULL); op_free(entersubop); + /* then attach first (and second) to a new binop */ + NewOp(1234, newop, 1, BINOP); newop->op_type = OP_CUSTOM; newop->op_ppaddr = S_pp_dump; - newop->op_first = first; - newop->op_last = second; newop->op_private= second ? 2 : 1; newop->op_flags = OPf_KIDS|OPf_WANT_SCALAR; + op_sibling_splice((OP*)newop, NULL, 0, first); return (OP *)newop; } -static XOP my_xop; +static const XOP my_xop = { + XOPf_xop_name|XOPf_xop_desc|XOPf_xop_class, /* xop_flags */ + "Devel_Peek_Dump", /* xop_name */ + "Dump", /* xop_desc */ + OA_BINOP, /* xop_class */ + NULL /* xop_peep */ +}; MODULE = Devel::Peek PACKAGE = Devel::Peek @@ -450,11 +443,8 @@ PPCODE: BOOT: { CV * const cv = get_cvn_flags("Devel::Peek::Dump", 17, 0); + assert(cv); cv_set_call_checker(cv, S_ck_dump, (SV *)cv); - - XopENTRY_set(&my_xop, xop_name, "Dump"); - XopENTRY_set(&my_xop, xop_desc, "Dump"); - XopENTRY_set(&my_xop, xop_class, OA_BINOP); Perl_custom_op_register(aTHX_ S_pp_dump, &my_xop); } diff --git a/gnu/usr.bin/perl/ext/Devel-Peek/t/Peek.t b/gnu/usr.bin/perl/ext/Devel-Peek/t/Peek.t index 2cfd8a52059..56522af1e8d 100755 --- a/gnu/usr.bin/perl/ext/Devel-Peek/t/Peek.t +++ b/gnu/usr.bin/perl/ext/Devel-Peek/t/Peek.t @@ -82,18 +82,15 @@ sub do_test { : $_ # Didn't match, so this line is in } split /^/, $pattern; - $pattern =~ s/\$PADMY/ - ($] < 5.009) ? 'PADBUSY,PADMY' : 'PADMY'; - /mge; - $pattern =~ s/\$PADTMP/ - ($] < 5.009) ? 'PADBUSY,PADTMP' : 'PADTMP'; + $pattern =~ s/\$PADMY,/ + $] < 5.012005 ? 'PADMY,' : ''; /mge; $pattern =~ s/\$RV/ ($] < 5.011) ? 'RV' : 'IV'; /mge; $pattern =~ s/^\h+COW_REFCNT = .*\n//mg if $Config{ccflags} =~ - /-DPERL_(?:OLD_COPY_ON_WRITE|NO_COW)/ + /-DPERL_(?:OLD_COPY_ON_WRITE|NO_COW)\b/ || $] < 5.019003; print $pattern, "\n" if $DEBUG; my ($dump, $dump2) = split m/\*\*\*\*\*\n/, scalar <IN>; @@ -140,7 +137,8 @@ do_test('immediate constant (string)', "bar", 'SV = PV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(.*POK,READONLY,(?:IsCOW,)?pPOK\\) + FLAGS = \\(.*POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005 + FLAGS = \\(.*POK,(?:IsCOW,)?READONLY,PROTECT,pPOK\\) # $] >=5.021005 PV = $ADDR "bar"\\\0 CUR = 3 LEN = \\d+ @@ -158,7 +156,8 @@ do_test('immediate constant (integer)', 456, 'SV = IV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(.*IOK,READONLY,pIOK\\) + FLAGS = \\(.*IOK,READONLY,pIOK\\) # $] < 5.021005 + FLAGS = \\(.*IOK,READONLY,PROTECT,pIOK\\) # $] >=5.021005 IV = 456'); do_test('assignment of immediate constant (integer)', @@ -186,7 +185,7 @@ my $type = do_test('result of addition', do_test('floating point value', $d, $] < 5.019003 - || $Config{ccflags} =~ /-DPERL_(?:NO_COW|OLD_COPY_ON_WRITE)/ + || $Config{ccflags} =~ /-DPERL_(?:NO_COW|OLD_COPY_ON_WRITE)\b/ ? 'SV = PVNV\\($ADDR\\) at $ADDR REFCNT = 1 @@ -208,14 +207,17 @@ do_test('integer constant', 0xabcd, 'SV = IV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(.*IOK,READONLY,pIOK\\) + FLAGS = \\(.*IOK,READONLY,pIOK\\) # $] < 5.021005 + FLAGS = \\(.*IOK,READONLY,PROTECT,pIOK\\) # $] >=5.021005 IV = 43981'); do_test('undef', undef, 'SV = NULL\\(0x0\\) at $ADDR REFCNT = \d+ - FLAGS = \\(READONLY\\)'); + FLAGS = \\(READONLY\\) # $] < 5.021005 + FLAGS = \\(READONLY,PROTECT\\) # $] >=5.021005 +'); do_test('reference to scalar', \$a, @@ -257,8 +259,6 @@ do_test('reference to array', SV = PVAV\\($ADDR\\) at $ADDR REFCNT = 1 FLAGS = \\(\\) - IV = 0 # $] < 5.009 - NV = 0 # $] < 5.009 ARRAY = $ADDR FILL = 1 MAX = 1 @@ -280,8 +280,6 @@ do_test('reference to hash', SV = PVHV\\($ADDR\\) at $ADDR REFCNT = [12] FLAGS = \\(SHAREKEYS\\) - IV = 1 # $] < 5.009 - NV = $FLOAT # $] < 5.009 ARRAY = $ADDR \\(0:7, 1:1\\) hash quality = 100.0% KEYS = 1 @@ -289,7 +287,7 @@ do_test('reference to hash', MAX = 7 Elt "123" HASH = $ADDR' . $c_pattern, '', - $] > 5.009 && $] < 5.015 + $] < 5.015 && 'The hash iterator used in dump.c sets the OOK flag'); do_test('reference to anon sub with empty prototype', @@ -302,21 +300,16 @@ do_test('reference to anon sub with empty prototype', REFCNT = 2 FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC\\) # $] < 5.015 || !thr FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC,DYNFILE\\) # $] >= 5.015 && thr - IV = 0 # $] < 5.009 - NV = 0 # $] < 5.009 PROTOTYPE = "" COMP_STASH = $ADDR\\t"main" START = $ADDR ===> \\d+ ROOT = $ADDR - XSUB = 0x0 # $] < 5.009 - XSUBANY = 0 # $] < 5.009 GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*" FILE = ".*\\b(?i:peek\\.t)" DEPTH = 0(?: MUTEXP = $ADDR OWNER = $ADDR)? - FLAGS = 0x404 # $] < 5.009 - FLAGS = 0x490 # $] >= 5.009 && ($] < 5.015 || !thr) + FLAGS = 0x490 # $] < 5.015 || !thr FLAGS = 0x1490 # $] >= 5.015 && thr OUTSIDE_SEQ = \\d+ PADLIST = $ADDR @@ -331,22 +324,19 @@ do_test('reference to named subroutine without prototype', RV = $ADDR SV = PVCV\\($ADDR\\) at $ADDR REFCNT = (3|4) - FLAGS = \\((?:HASEVAL)?\\) # $] < 5.015 || !thr - FLAGS = \\(DYNFILE(?:,HASEVAL)?\\) # $] >= 5.015 && thr - IV = 0 # $] < 5.009 - NV = 0 # $] < 5.009 + FLAGS = \\((?:HASEVAL(?:,NAMED)?)?\\) # $] < 5.015 || !thr + FLAGS = \\(DYNFILE(?:,HASEVAL(?:,NAMED)?)?\\) # $] >= 5.015 && thr COMP_STASH = $ADDR\\t"main" START = $ADDR ===> \\d+ ROOT = $ADDR - XSUB = 0x0 # $] < 5.009 - XSUBANY = 0 # $] < 5.009 - GVGV::GV = $ADDR\\t"main" :: "do_test" + NAME = "do_test" # $] >=5.021004 + GVGV::GV = $ADDR\\t"main" :: "do_test" # $] < 5.021004 FILE = ".*\\b(?i:peek\\.t)" DEPTH = 1(?: MUTEXP = $ADDR OWNER = $ADDR)? - FLAGS = 0x(?:400)?0 # $] < 5.015 || !thr - FLAGS = 0x[145]000 # $] >= 5.015 && thr + FLAGS = 0x(?:[c4]00)?0 # $] < 5.015 || !thr + FLAGS = 0x[cd145]000 # $] >= 5.015 && thr OUTSIDE_SEQ = \\d+ PADLIST = $ADDR PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\) @@ -355,8 +345,7 @@ do_test('reference to named subroutine without prototype', \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern" \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$do_eval" \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$sub" - \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" # $] < 5.009 - \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0 # $] >= 5.009 + \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump" \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump2" OUTSIDE = $ADDR \\(MAIN\\)'); @@ -449,8 +438,8 @@ do_test('reference to regexp', MG_VIRTUAL = $ADDR MG_TYPE = PERL_MAGIC_qr\(r\) MG_OBJ = $ADDR - PAT = "\(\?^:tic\)" # $] >= 5.009 - REFCNT = 2 # $] >= 5.009 + PAT = "\(\?^:tic\)" + REFCNT = 2 STASH = $ADDR\\t"Regexp"'); } @@ -463,35 +452,24 @@ do_test('reference to blessed hash', SV = PVHV\\($ADDR\\) at $ADDR REFCNT = [12] FLAGS = \\(OBJECT,SHAREKEYS\\) - IV = 0 # $] < 5.009 - NV = 0 # $] < 5.009 STASH = $ADDR\\t"Tac" ARRAY = 0x0 KEYS = 0 FILL = 0 MAX = 7', '', - $] > 5.009 - ? $] >= 5.015 + $] >= 5.015 ? 0 - : 'The hash iterator used in dump.c sets the OOK flag' - : "Something causes the HV's array to become allocated"); + : 'The hash iterator used in dump.c sets the OOK flag'); do_test('typeglob', *a, 'SV = PVGV\\($ADDR\\) at $ADDR REFCNT = 5 - FLAGS = \\(MULTI(?:,IN_PAD)?\\) # $] >= 5.009 - FLAGS = \\(GMG,SMG,MULTI(?:,IN_PAD)?\\) # $] < 5.009 - IV = 0 # $] < 5.009 - NV = 0 # $] < 5.009 - PV = 0 # $] < 5.009 - MAGIC = $ADDR # $] < 5.009 - MG_VIRTUAL = &PL_vtbl_glob # $] < 5.009 - MG_TYPE = PERL_MAGIC_glob\(\*\) # $] < 5.009 - MG_OBJ = $ADDR # $] < 5.009 + FLAGS = \\(MULTI(?:,IN_PAD)?\\) NAME = "a" NAMELEN = 1 GvSTASH = $ADDR\\t"main" + FLAGS = $ADDR # $] >=5.021004 GP = $ADDR SV = $ADDR REFCNT = 1 @@ -501,10 +479,10 @@ do_test('typeglob', HV = 0x0 CV = 0x0 CVGEN = 0x0 - GPFLAGS = 0x0 # $] < 5.009 + GPFLAGS = 0x0 \(\) # $] >= 5.021004 LINE = \\d+ FILE = ".*\\b(?i:peek\\.t)" - FLAGS = $ADDR + FLAGS = $ADDR # $] < 5.021004 EGV = $ADDR\\t"a"'); if (ord('A') == 193) { @@ -512,8 +490,8 @@ do_test('string with Unicode', chr(256).chr(0).chr(512), 'SV = PV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\) # $] < 5.019003 - FLAGS = \\((?:$PADTMP,)?POK,(?:IsCOW,)?pPOK,UTF8\\) # $] >=5.019003 + FLAGS = \\((?:PADTMP,)?POK,READONLY,pPOK,UTF8\\) # $] < 5.019003 + FLAGS = \\((?:PADTMP,)?POK,(?:IsCOW,)?pPOK,UTF8\\) # $] >=5.019003 PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\] CUR = 5 LEN = \\d+ @@ -524,8 +502,8 @@ do_test('string with Unicode', chr(256).chr(0).chr(512), 'SV = PV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\) # $] < 5.019003 - FLAGS = \\((?:$PADTMP,)?POK,(?:IsCOW,)?pPOK,UTF8\\) # $] >=5.019003 + FLAGS = \\((?:PADTMP,)?POK,READONLY,pPOK,UTF8\\) # $] < 5.019003 + FLAGS = \\((?:PADTMP,)?POK,(?:IsCOW,)?pPOK,UTF8\\) # $] >=5.019003 PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\] CUR = 5 LEN = \\d+ @@ -543,8 +521,6 @@ do_test('reference to hash containing Unicode', SV = PVHV\\($ADDR\\) at $ADDR REFCNT = [12] FLAGS = \\(SHAREKEYS,HASKFLAGS\\) - UV = 1 # $] < 5.009 - NV = $FLOAT # $] < 5.009 ARRAY = $ADDR \\(0:7, 1:1\\) hash quality = 100.0% KEYS = 1 @@ -559,11 +535,9 @@ do_test('reference to hash containing Unicode', LEN = \\d+ COW_REFCNT = 1 # $] < 5.019007 ', '', - $] > 5.009 - ? $] >= 5.015 + $] >= 5.015 ? 0 - : 'The hash iterator used in dump.c sets the OOK flag' - : 'sv_length has been called on the element, and cached the result in MAGIC'); + : 'The hash iterator used in dump.c sets the OOK flag'); } else { do_test('reference to hash containing Unicode', {chr(256)=>chr(512)}, @@ -574,8 +548,6 @@ do_test('reference to hash containing Unicode', SV = PVHV\\($ADDR\\) at $ADDR REFCNT = [12] FLAGS = \\(SHAREKEYS,HASKFLAGS\\) - UV = 1 # $] < 5.009 - NV = 0 # $] < 5.009 ARRAY = $ADDR \\(0:7, 1:1\\) hash quality = 100.0% KEYS = 1 @@ -590,11 +562,9 @@ do_test('reference to hash containing Unicode', LEN = \\d+ COW_REFCNT = 1 # $] < 5.019007 ', '', - $] > 5.009 - ? $] >= 5.015 + $] >= 5.015 ? 0 - : 'The hash iterator used in dump.c sets the OOK flag' - : 'sv_length has been called on the element, and cached the result in MAGIC'); + : 'The hash iterator used in dump.c sets the OOK flag'); } my $x=""; @@ -675,7 +645,8 @@ do_test('blessed reference', RV = $ADDR SV = NULL\\(0x0\\) at $ADDR REFCNT = \d+ - FLAGS = \\(READONLY\\) + FLAGS = \\(READONLY\\) # $] < 5.021005 + FLAGS = \\(READONLY,PROTECT\\) # $] >=5.021005 PV = $ADDR "" CUR = 0 LEN = 0 @@ -695,16 +666,15 @@ do_test('constant subroutine', REFCNT = (2) FLAGS = \\(POK,pPOK,CONST,ISXSUB\\) # $] < 5.015 FLAGS = \\(POK,pPOK,CONST,DYNFILE,ISXSUB\\) # $] >= 5.015 - IV = 0 # $] < 5.009 - NV = 0 # $] < 5.009 PROTOTYPE = "" - COMP_STASH = 0x0 - ROOT = 0x0 # $] < 5.009 + COMP_STASH = 0x0 # $] < 5.021004 + COMP_STASH = $ADDR "main" # $] >=5.021004 XSUB = $ADDR XSUBANY = $ADDR \\(CONST SV\\) SV = PV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(.*POK,READONLY,(?:IsCOW,)?pPOK\\) + FLAGS = \\(.*POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005 + FLAGS = \\(.*POK,(?:IsCOW,)?READONLY,PROTECT,pPOK\\) # $] >=5.021005 PV = $ADDR "Perl rules"\\\0 CUR = 10 LEN = \\d+ @@ -714,12 +684,12 @@ do_test('constant subroutine', DEPTH = 0(?: MUTEXP = $ADDR OWNER = $ADDR)? - FLAGS = 0x200 # $] < 5.009 - FLAGS = 0xc00 # $] >= 5.009 && $] < 5.013 + FLAGS = 0xc00 # $] < 5.013 FLAGS = 0xc # $] >= 5.013 && $] < 5.015 FLAGS = 0x100c # $] >= 5.015 OUTSIDE_SEQ = 0 - PADLIST = 0x0 + PADLIST = 0x0 # $] < 5.021006 + HSCXT = $ADDR # $] >= 5.021006 OUTSIDE = 0x0 \\(null\\)'); do_test('isUV should show on PVMG', @@ -753,7 +723,6 @@ do_test('IO', TOP_GV = 0x0 FMT_GV = 0x0 BOTTOM_GV = 0x0 - SUBPROCESS = 0 # $] < 5.009 TYPE = \'>\' FLAGS = 0x4'); @@ -767,14 +736,10 @@ do_test('FORMAT', REFCNT = 2 FLAGS = \\(\\) # $] < 5.015 || !thr FLAGS = \\(DYNFILE\\) # $] >= 5.015 && thr - IV = 0 # $] < 5.009 - NV = 0 # $] < 5.009 (?: PV = 0 )? COMP_STASH = 0x0 START = $ADDR ===> \\d+ ROOT = $ADDR - XSUB = 0x0 # $] < 5.009 - XSUBANY = 0 # $] < 5.009 GVGV::GV = $ADDR\\t"main" :: "PIE" FILE = ".*\\b(?i:peek\\.t)"(?: DEPTH = 0)?(?: @@ -797,18 +762,14 @@ do_test('blessing to a class with embedded NUL characters', SV = PVHV\\($ADDR\\) at $ADDR REFCNT = [12] FLAGS = \\(OBJECT,SHAREKEYS\\) - IV = 0 # $] < 5.009 - NV = 0 # $] < 5.009 STASH = $ADDR\\t"\\\\0::foo::\\\\n::baz::\\\\t::\\\\0" ARRAY = $ADDR KEYS = 0 FILL = 0 MAX = 7', '', - $] > 5.009 - ? $] >= 5.015 + $] >= 5.015 ? 0 - : 'The hash iterator used in dump.c sets the OOK flag' - : "Something causes the HV's array to become allocated"); + : 'The hash iterator used in dump.c sets the OOK flag'); do_test('ENAME on a stash', \%RWOM::, @@ -819,8 +780,6 @@ do_test('ENAME on a stash', SV = PVHV\\($ADDR\\) at $ADDR REFCNT = 2 FLAGS = \\(OOK,SHAREKEYS\\) - IV = 1 # $] < 5.009 - NV = $FLOAT # $] < 5.009 AUX_FLAGS = 0 # $] > 5.019008 ARRAY = $ADDR KEYS = 0 @@ -844,8 +803,6 @@ do_test('ENAMEs on a stash', SV = PVHV\\($ADDR\\) at $ADDR REFCNT = 3 FLAGS = \\(OOK,SHAREKEYS\\) - IV = 1 # $] < 5.009 - NV = $FLOAT # $] < 5.009 AUX_FLAGS = 0 # $] > 5.019008 ARRAY = $ADDR KEYS = 0 @@ -870,9 +827,8 @@ do_test('ENAMEs on a stash with no NAME', SV = PVHV\\($ADDR\\) at $ADDR REFCNT = 3 FLAGS = \\(OOK,SHAREKEYS\\) # $] < 5.017 - FLAGS = \\(OOK,OVERLOAD,SHAREKEYS\\) # $] >=5.017 - IV = 1 # $] < 5.009 - NV = $FLOAT # $] < 5.009 + FLAGS = \\(OOK,OVERLOAD,SHAREKEYS\\) # $] >=5.017 && $]<5.021005 + FLAGS = \\(OOK,SHAREKEYS,OVERLOAD\\) # $] >=5.021005 AUX_FLAGS = 0 # $] > 5.019008 ARRAY = $ADDR KEYS = 0 @@ -895,9 +851,7 @@ do_test('small hash', RV = $ADDR SV = PVHV\\($ADDR\\) at $ADDR REFCNT = 2 - FLAGS = \\(PADMY,SHAREKEYS\\) - IV = 1 # $] < 5.009 - NV = $FLOAT # $] < 5.009 + FLAGS = \\($PADMY,SHAREKEYS\\) ARRAY = $ADDR \\(0:[67],.*\\) hash quality = [0-9.]+% KEYS = 2 @@ -923,9 +877,7 @@ do_test('small hash after keys', RV = $ADDR SV = PVHV\\($ADDR\\) at $ADDR REFCNT = 2 - FLAGS = \\(PADMY,OOK,SHAREKEYS\\) - IV = 1 # $] < 5.009 - NV = $FLOAT # $] < 5.009 + FLAGS = \\($PADMY,OOK,SHAREKEYS\\) AUX_FLAGS = 0 # $] > 5.019008 ARRAY = $ADDR \\(0:[67],.*\\) hash quality = [0-9.]+% @@ -955,9 +907,7 @@ do_test('small hash after keys and scalar', RV = $ADDR SV = PVHV\\($ADDR\\) at $ADDR REFCNT = 2 - FLAGS = \\(PADMY,OOK,SHAREKEYS\\) - IV = 1 # $] < 5.009 - NV = $FLOAT # $] < 5.009 + FLAGS = \\($PADMY,OOK,SHAREKEYS\\) AUX_FLAGS = 0 # $] > 5.019008 ARRAY = $ADDR \\(0:[67],.*\\) hash quality = [0-9.]+% @@ -988,9 +938,7 @@ do_test('large hash', RV = $ADDR SV = PVHV\\($ADDR\\) at $ADDR REFCNT = 2 - FLAGS = \\(PADMY,OOK,SHAREKEYS\\) - IV = 1 # $] < 5.009 - NV = $FLOAT # $] < 5.009 + FLAGS = \\($PADMY,OOK,SHAREKEYS\\) AUX_FLAGS = 0 # $] > 5.019008 ARRAY = $ADDR \\(0:\d+,.*\\) hash quality = \d+\\.\d+% @@ -1030,6 +978,23 @@ SV = PVAV\($ADDR\) at $ADDR FLAGS = \(IOK,pIOK\) IV = 3 ARRAY + +do_test('Dump @array,1', '@array,1', <<'ARRAY', '', '', 1); +SV = PVAV\($ADDR\) at $ADDR + REFCNT = 1 + FLAGS = \(\) + ARRAY = $ADDR + FILL = 2 + MAX = 3 + ARYLEN = 0x0 + FLAGS = \(REAL\) + Elt No. 0 + SV = IV\($ADDR\) at $ADDR + REFCNT = 1 + FLAGS = \(IOK,pIOK\) + IV = 1 +ARRAY + %hash = 1..2; do_test('Dump %hash', '%hash', <<'HASH', '', '', 1); SV = PVHV\($ADDR\) at $ADDR @@ -1046,6 +1011,7 @@ SV = PVHV\($ADDR\) at $ADDR FLAGS = \(IOK,pIOK\) IV = 2 HASH + $_ = "hello"; do_test('rvalue substr', 'substr $_, 1, 2', <<'SUBSTR', '', '', 1); SV = PV\($ADDR\) at $ADDR @@ -1077,8 +1043,16 @@ SKIP: { # a way to make a better place for it: use constant { - perl => 'rules', - beer => 'foamy', + + # The length of the rhs string must be such that if chr() is applied to it + # doesn't yield a character with a backslash mnemonic. For example, if it + # were 'rules' instead of 'rule', it would have 5 characters, and on + # EBCDIC, chr(5) is \t. The dumping code would translate all the 5's in + # MG_PTR into "\t", and this test code would be expecting \5's, so the + # tests would fail. No platform that Perl works on translates chr(4) into + # a mnemonic. + perl => 'rule', + beer => 'foam', }; unless ($Config{useithreads}) { @@ -1088,9 +1062,10 @@ unless ($Config{useithreads}) { do_test('regular string constant', perl, 'SV = PV\\($ADDR\\) at $ADDR REFCNT = 5 - FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\) - PV = $ADDR "rules"\\\0 - CUR = 5 + FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005 + FLAGS = \\(POK,(?:IsCOW,)?READONLY,pPOK\\) # $] >=5.021005 + PV = $ADDR "rule"\\\0 + CUR = 4 LEN = \d+ COW_REFCNT = 0 '); @@ -1104,9 +1079,9 @@ unless ($Config{useithreads}) { do_test('string constant now an FBM', perl, 'SV = PVMG\\($ADDR\\) at $ADDR REFCNT = 5 - FLAGS = \\(PADMY,SMG,POK,READONLY,(?:IsCOW,)?pPOK,VALID,EVALED\\) - PV = $ADDR "rules"\\\0 - CUR = 5 + FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK,VALID,EVALED\\) + PV = $ADDR "rule"\\\0 + CUR = 4 LEN = \d+ COW_REFCNT = 0 MAGIC = $ADDR @@ -1124,9 +1099,9 @@ unless ($Config{useithreads}) { do_test('string constant still an FBM', perl, 'SV = PVMG\\($ADDR\\) at $ADDR REFCNT = 5 - FLAGS = \\(PADMY,SMG,POK,READONLY,(?:IsCOW,)?pPOK,VALID,EVALED\\) - PV = $ADDR "rules"\\\0 - CUR = 5 + FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK,VALID,EVALED\\) + PV = $ADDR "rule"\\\0 + CUR = 4 LEN = \d+ COW_REFCNT = 0 MAGIC = $ADDR @@ -1142,9 +1117,10 @@ unless ($Config{useithreads}) { do_test('regular string constant', beer, 'SV = PV\\($ADDR\\) at $ADDR REFCNT = 6 - FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\) - PV = $ADDR "foamy"\\\0 - CUR = 5 + FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005 + FLAGS = \\(POK,(?:IsCOW,)?READONLY,pPOK\\) # $] >=5.021005 + PV = $ADDR "foam"\\\0 + CUR = 4 LEN = \d+ COW_REFCNT = 0 '); @@ -1153,18 +1129,19 @@ unless ($Config{useithreads}) { do_test('string constant quite unaffected', beer, 'SV = PV\\($ADDR\\) at $ADDR REFCNT = 6 - FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\) - PV = $ADDR "foamy"\\\0 - CUR = 5 + FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005 + FLAGS = \\(POK,(?:IsCOW,)?READONLY,pPOK\\) # $] >=5.021005 + PV = $ADDR "foam"\\\0 + CUR = 4 LEN = \d+ COW_REFCNT = 0 '); my $want = 'SV = PVMG\\($ADDR\\) at $ADDR REFCNT = 6 - FLAGS = \\(PADMY,SMG,POK,READONLY,(?:IsCOW,)?pPOK,VALID,EVALED\\) - PV = $ADDR "foamy"\\\0 - CUR = 5 + FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK,VALID,EVALED\\) + PV = $ADDR "foam"\\\0 + CUR = 4 LEN = \d+ COW_REFCNT = 0 MAGIC = $ADDR @@ -1189,7 +1166,7 @@ unless ($Config{useithreads}) { do_test('second string also unaffected', $pie, 'SV = PV\\($ADDR\\) at $ADDR REFCNT = 1 - FLAGS = \\(PADMY,POK,(?:IsCOW,)?pPOK\\) + FLAGS = \\($PADMY,POK,(?:IsCOW,)?pPOK\\) PV = $ADDR "good"\\\0 CUR = 4 LEN = \d+ @@ -1221,7 +1198,7 @@ do_test('UTF-8 in a regular expression', CUR = 13 STASH = $ADDR "Regexp" COMPFLAGS = 0x0 \(\) - EXTFLAGS = 0x680040 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\) + EXTFLAGS = $ADDR \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\) (?: ENGINE = $ADDR \(STANDARD\) )? INTFLAGS = 0x0(?: \(\))? NPARENS = 0 @@ -1244,7 +1221,7 @@ do_test('UTF-8 in a regular expression', PV = $ADDR "\(\?\^u:\\\\\\\\x\{100\}\)" \[UTF8 "\(\?\^u:\\\\\\\\x\{100\}\)"\] CUR = 13 COMPFLAGS = 0x0 \(\) - EXTFLAGS = 0x680040 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\) + EXTFLAGS = $ADDR \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\) (?: ENGINE = $ADDR \(STANDARD\) )? INTFLAGS = 0x0(?: \(\))? NPARENS = 0 @@ -1456,6 +1433,7 @@ for my $test ( } +my $runperl_args = { switches => ['-Ilib'] }; sub test_DumpProg { my ($prog, $expected, $name, $test) = @_; $test ||= 'like'; @@ -1469,10 +1447,10 @@ sub test_DumpProg { utf8::encode($prog); if ( $test eq 'is' ) { - t::fresh_perl_is($prog . $u, $expected, undef, $name) + t::fresh_perl_is($prog . $u, $expected, $runperl_args, $name) } else { - t::fresh_perl_like($prog . $u, $expected, undef, $name) + t::fresh_perl_like($prog . $u, $expected, $runperl_args, $name) } $builder->current_test(t::curr_test() - 1); @@ -1504,41 +1482,44 @@ for my $test ( test_DumpProg(@$test); } -my $e = <<'EODUMP'; -dumpindent is 4 at - line 1. +{ + local $TODO = 'This gets mangled by the current pipe implementation' if $^O eq 'VMS'; + my $e = <<'EODUMP'; +dumpindent is 4 at -e line 1. { 1 TYPE = leave ===> NULL TARG = 1 FLAGS = (VOID,KIDS,PARENS,SLABBED) - PRIVATE = (REFCOUNTED) + PRIVATE = (REFC) REFCNT = 1 { 2 TYPE = enter ===> 3 - FLAGS = (UNKNOWN,SLABBED) + FLAGS = (UNKNOWN,SLABBED,MORESIB) } { 3 TYPE = nextstate ===> 4 - FLAGS = (VOID,SLABBED) + FLAGS = (VOID,SLABBED,MORESIB) LINE = 1 PACKAGE = "t" } { 5 TYPE = entersub ===> 1 - TARG = TARGS_REPLACE + TARG = 1 FLAGS = (VOID,KIDS,STACKED,SLABBED) - PRIVATE = (HASTARG) + PRIVATE = (TARG) { 6 TYPE = null ===> (5) (was list) FLAGS = (UNKNOWN,KIDS,SLABBED) { 4 TYPE = pushmark ===> 7 - FLAGS = (SCALAR,SLABBED) + FLAGS = (SCALAR,SLABBED,MORESIB) } { 8 TYPE = null ===> (6) (was rv2cv) FLAGS = (SCALAR,KIDS,SLABBED) + PRIVATE = (0x1) { 7 TYPE = gv ===> 5 FLAGS = (SCALAR,SLABBED) @@ -1550,9 +1531,13 @@ dumpindent is 4 at - line 1. } EODUMP -$e =~ s/TARGS_REPLACE/$threads ? 3 : 1/e; -$e =~ s/GV_OR_PADIX/$threads ? "PADIX = 2" : "GV = t::DumpProg"/e; - -test_DumpProg("package t;", $e, "DumpProg() has no 'Attempt to free X prematurely' warning", "is" ); - + $e =~ s/GV_OR_PADIX/$threads ? "PADIX = 2" : "GV = t::DumpProg"/e; + $e =~ s/.*PRIVATE = \(0x1\).*\n// if $] < 5.021004; + my $out = t::runperl + switches => ['-Ilib'], + prog => 'package t; use Devel::Peek q-DumpProg-; DumpProg();', + stderr=>1; + $out =~ s/ *SEQ = .*\n//; + is $out, $e, "DumpProg() has no 'Attempt to free X prematurely' warning"; +} done_testing(); diff --git a/gnu/usr.bin/perl/ext/DynaLoader/DynaLoader_pm.PL b/gnu/usr.bin/perl/ext/DynaLoader/DynaLoader_pm.PL index 5fb52a27684..e828f357571 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/DynaLoader_pm.PL +++ b/gnu/usr.bin/perl/ext/DynaLoader/DynaLoader_pm.PL @@ -68,7 +68,7 @@ unlink "DynaLoader.pm" if -f "DynaLoader.pm"; open OUT, ">DynaLoader.pm" or die $!; print OUT <<'EOT'; -# Generated from DynaLoader_pm.PL +# Generated from DynaLoader_pm.PL, this file is unique for every OS package DynaLoader; @@ -85,10 +85,16 @@ package DynaLoader; # Tim.Bunce@ig.co.uk, August 1994 BEGIN { - $VERSION = '1.25'; + $VERSION = '1.38'; } -use Config; +EOT + +if (!$ENV{PERL_BUILD_EXPAND_CONFIG_VARS}) { + print OUT "use Config;\n"; +} + +print OUT <<'EOT'; # enable debug/trace messages from DynaLoader perl code $dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug; @@ -132,8 +138,9 @@ $Is_VMS = $^O eq 'VMS'; <</$^O-eq-VMS>> $do_expand = <<$^O-eq-VMS>>1<<|$^O-eq-VMS>>0<</$^O-eq-VMS>>; -@dl_require_symbols = (); # names of symbols we need -@dl_resolve_using = (); # names of files to link with +@dl_require_symbols = (); # names of symbols we need<<$^O-eq-freemint>> +@dl_resolve_using = (); # names of files to link with<</$^O-eq-freemint>><<$^O-eq-hpux>> +@dl_resolve_using = (); # names of files to link with<</$^O-eq-hpux>> @dl_library_path = (); # path to look for files #XSLoader.pm may have added elements before we were required @@ -141,9 +148,6 @@ $do_expand = <<$^O-eq-VMS>>1<<|$^O-eq-VMS>>0<</$^O-eq-VMS>>; #@dl_librefs = (); # things we have loaded #@dl_modules = (); # Modules we have loaded -# This is a fix to support DLD's unfortunate desire to relink -lc -@dl_resolve_using = dl_findfile('-lc') if $dlsrc eq "dl_dld.xs"; - EOT my $cfg_dl_library_path = <<'EOT'; @@ -315,6 +319,7 @@ sub bootstrap { <</$^O-eq-os2>> my @modparts = split(/::/,$module); my $modfname = $modparts[-1]; + my $modfname_orig = $modfname; # For .bs file search # Some systems have restrictions on files names for DLL's etc. # mod2fname returns appropriate file base name (typically truncated) @@ -334,9 +339,10 @@ sub bootstrap { "(auto/$modpname/$modfname.$dl_dlext)\n" if $dl_debug; + my $dir; foreach (@INC) { <<$^O-eq-VMS>>chop($_ = VMS::Filespec::unixpath($_));<</$^O-eq-VMS>> - my $dir = "$_/auto/$modpname"; + $dir = "$_/auto/$modpname"; next unless -d $dir; # skip over uninteresting directories @@ -361,7 +367,9 @@ sub bootstrap { # Execute optional '.bootstrap' perl script for this module. # The .bs file can be used to configure @dl_resolve_using etc to # match the needs of the individual module on this architecture. - my $bs = $file; + # N.B. The .bs file does not following the naming convention used + # by mod2fname. + my $bs = "$dir/$modfname_orig"; $bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library if (-s $bs) { # only read file if it's not empty print STDERR "BS: $bs ($^O, $dlsrc)\n" if $dl_debug; @@ -372,7 +380,7 @@ sub bootstrap { my $boot_symbol_ref; <<$^O-eq-darwin>> - if ($boot_symbol_ref = dl_find_symbol(0, $bootname)) { + if ($boot_symbol_ref = dl_find_symbol(0, $bootname, 1)) { goto boot; #extension library has already been loaded, e.g. darwin } <</$^O-eq-darwin>> @@ -393,13 +401,13 @@ sub bootstrap { croak("Can't load '$file' for module $module: ".dl_error()); push(@dl_librefs,$libref); # record loaded object - +<<$^O-eq-freemint>> my @unresolved = dl_undef_symbols(); if (@unresolved) { require Carp; Carp::carp("Undefined symbols present after loading $file: @unresolved\n"); } - +<</$^O-eq-freemint>> $boot_symbol_ref = dl_find_symbol($libref, $bootname) or croak("Can't find '$bootname' symbol in $file\n"); @@ -416,7 +424,6 @@ sub bootstrap { } sub dl_findfile { - # Read ext/DynaLoader/DynaLoader.doc for detailed information. # This function does not automatically consider the architecture # or the perl library auto directories. my (@args) = @_; @@ -473,7 +480,6 @@ sub dl_findfile { push(@names,"cyg$_.$dl_so") unless m:/:; <</$^O-eq-cygwin>> push(@names,"lib$_.$dl_so") unless m:/:; - push(@names,"$_.a") if !m/\.a$/ and $dlsrc eq "dl_dld.xs"; push(@names, $_); } my $dirsep = '/'; @@ -543,7 +549,7 @@ sub dl_find_symbol_anywhere my $sym = shift; my $libref; foreach $libref (@dl_librefs) { - my $symref = dl_find_symbol($libref,$sym); + my $symref = dl_find_symbol($libref,$sym,1); return $symref if $symref; } return undef; @@ -578,7 +584,7 @@ anyone wishing to use the DynaLoader directly in an application. The DynaLoader is designed to be a very simple high-level interface that is sufficiently general to cover the requirements -of SunOS, HP-UX, NeXT, Linux, VMS and other platforms. +of SunOS, HP-UX, Linux, VMS and other platforms. It is also hoped that the interface will cover the needs of OS/2, NT etc and also allow pseudo-dynamic linking (using C<ld -A> at runtime). @@ -796,7 +802,6 @@ current values of @dl_require_symbols and @dl_resolve_using if required. SunOS: dlopen($filename) HP-UX: shl_load($filename) Linux: dld_create_reference(@dl_require_symbols); dld_link($filename) - NeXT: rld_load($filename, @dl_resolve_using) VMS: lib$find_image_symbol($filename,$dl_require_symbols[0]) (The dlopen() function is also used by Solaris and some versions of @@ -833,7 +838,6 @@ Apache and mod_perl built with the APXS mechanism. SunOS: dlclose($libref) HP-UX: ??? Linux: ??? - NeXT: ??? VMS: ??? (The dlclose() function is also used by Solaris and some versions of @@ -869,7 +873,6 @@ be passed to, and understood by, dl_install_xsub(). SunOS: dlsym($libref, $symbol) HP-UX: shl_findsym($libref, $symbol) Linux: dld_get_func($symbol) and/or dld_get_symbol($symbol) - NeXT: rld_lookup("_$symbol") VMS: lib$find_image_symbol($libref,$symbol) @@ -902,7 +905,7 @@ Syntax: Create a new Perl external subroutine named $perl_name using $symref as a pointer to the function which implements the routine. This is simply -a direct call to newXSUB(). Returns a reference to the installed +a direct call to newXS()/newXS_flags(). Returns a reference to the installed function. The $filename parameter is used by Perl to identify the source file for diff --git a/gnu/usr.bin/perl/ext/DynaLoader/Makefile.PL b/gnu/usr.bin/perl/ext/DynaLoader/Makefile.PL index a0f83b6e674..864af3ed8e2 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/Makefile.PL +++ b/gnu/usr.bin/perl/ext/DynaLoader/Makefile.PL @@ -14,7 +14,8 @@ WriteMakefile( VERSION_FROM => 'DynaLoader_pm.PL', PL_FILES => {'DynaLoader_pm.PL'=>'DynaLoader.pm'}, PM => {'DynaLoader.pm' => '$(INST_LIBDIR)/DynaLoader.pm'}, - depend => {'DynaLoader$(OBJ_EXT)' => 'dlutils.c'}, + depend => { 'DynaLoader$(OBJ_EXT)' => 'dlutils.c', + 'DynaLoader.c' => 'DynaLoader.xs'}, clean => {FILES => 'DynaLoader.c DynaLoader.xs DynaLoader.pm'}, ); @@ -64,8 +65,8 @@ sub MY::static { return " $object : \$(FIRST_MAKEFILE) \$(OBJECT) - #\$(RM_RF) $object - #\$(CP) \$(OBJECT) $object + \$(RM_RF) $object + \$(CP) \$(OBJECT) $object static :: $object "; diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_aix.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_aix.xs index 9c98972da34..8e7d8ac0a55 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/dl_aix.xs +++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_aix.xs @@ -12,6 +12,8 @@ */ #define PERLIO_NOT_STDIO 0 +#define PERL_EXT +#define PERL_IN_DL_AIX_XS /* * On AIX 4.3 and above the emulation layer is not needed any more, and @@ -720,9 +722,10 @@ dl_unload_file(libref) RETVAL void -dl_find_symbol(libhandle, symbolname) +dl_find_symbol(libhandle, symbolname, ign_err=0) void * libhandle char * symbolname + int ign_err PREINIT: void *retv; CODE: @@ -730,10 +733,11 @@ dl_find_symbol(libhandle, symbolname) libhandle, symbolname)); retv = dlsym(libhandle, symbolname); DLDEBUG(2,PerlIO_printf(Perl_debug_log, " symbolref = %x\n", retv)); - ST(0) = sv_newmortal() ; - if (retv == NULL) - SaveError(aTHX_ "%s",dlerror()) ; - else + ST(0) = sv_newmortal(); + if (retv == NULL) { + if (!ign_err) + SaveError(aTHX_ "%s", dlerror()); + } else sv_setiv( ST(0), PTR2IV(retv)); @@ -759,11 +763,11 @@ dl_install_xsub(perl_name, symref, filename="$Package") XS_DYNAMIC_FILENAME))); -char * +SV * dl_error() CODE: dMY_CXT; - RETVAL = dl_last_error ; + RETVAL = newSVsv(MY_CXT.x_dl_last_error); OUTPUT: RETVAL @@ -780,7 +784,7 @@ CLONE(...) * using Perl variables that belong to another thread, we create our * own for this thread. */ - MY_CXT.x_dl_last_error = newSVpvn("", 0); + MY_CXT.x_dl_last_error = newSVpvs(""); #endif diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_dllload.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_dllload.xs index ea0a8f6219d..c63ffbabb4f 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/dl_dllload.xs +++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_dllload.xs @@ -84,7 +84,9 @@ Other comments within the dl_dlopen.xs file may be helpful as well. */ +#define PERL_EXT #include "EXTERN.h" +#define PERL_IN_DL_DLLLOAD_XS #include "perl.h" #include "XSUB.h" @@ -140,9 +142,10 @@ dl_unload_file(libref) void -dl_find_symbol(libhandle, symbolname) +dl_find_symbol(libhandle, symbolname, ign_err=0) void * libhandle char * symbolname + int ign_err PREINIT: void *retv; PPCODE: @@ -153,9 +156,10 @@ dl_find_symbol(libhandle, symbolname) retv = dllqueryvar(libhandle, symbolname); DLDEBUG(2, PerlIO_printf(Perl_debug_log, " symbolref = %lx\n", (unsigned long) retv)); - ST(0) = sv_newmortal() ; - if (retv == NULL) - SaveError(aTHX_ "%s",strerror(errno)) ; + ST(0) = sv_newmortal(); + if (retv == NULL) { + if (!ign_err) SaveError(aTHX_ "%s", strerror(errno)); + } else sv_setiv( ST(0), PTR2IV(retv)); XSRETURN(1); @@ -184,11 +188,11 @@ dl_install_xsub(perl_name, symref, filename="$Package") XSRETURN(1); -char * +SV * dl_error() CODE: dMY_CXT; - RETVAL = dl_last_error ; + RETVAL = newSVsv(MY_CXT.x_dl_last_error); OUTPUT: RETVAL @@ -205,7 +209,7 @@ CLONE(...) * using Perl variables that belong to another thread, we create our * own for this thread. */ - MY_CXT.x_dl_last_error = newSVpvn("", 0); + MY_CXT.x_dl_last_error = newSVpvs(""); #endif diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_dlopen.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_dlopen.xs index 96d30dea243..172da13ce7d 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/dl_dlopen.xs +++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_dlopen.xs @@ -12,6 +12,7 @@ * basic FreeBSD support, removed ClearError * 29th February 2000 - Alan Burlison: Added functionality to close dlopen'd * files when the interpreter exits + * 2015-03-12 - rurban: Added optional 3rd dl_find_symbol argument * */ @@ -117,8 +118,10 @@ */ #define PERL_NO_GET_CONTEXT +#define PERL_EXT #include "EXTERN.h" +#define PERL_IN_DL_DLOPEN_XS #include "perl.h" #include "XSUB.h" @@ -169,10 +172,11 @@ dl_load_file(filename, flags=0) #if defined(DLOPEN_WONT_DO_RELATIVE_PATHS) char pathbuf[PATH_MAX + 2]; if (*filename != '/' && strchr(filename, '/')) { - if (getcwd(pathbuf, PATH_MAX - strlen(filename))) { - my_strlcat(pathbuf, "/", sizeof(pathbuf)); - my_strlcat(pathbuf, filename, sizeof(pathbuf)); - filename = pathbuf; + const size_t filename_len = strlen(filename); + if (getcwd(pathbuf, PATH_MAX - filename_len)) { + const size_t path_len = strlen(pathbuf); + pathbuf[path_len] = '/'; + filename = (char *) memcpy(pathbuf + path_len + 1, filename, filename_len + 1); } } #endif @@ -214,9 +218,10 @@ dl_unload_file(libref) void -dl_find_symbol(libhandle, symbolname) +dl_find_symbol(libhandle, symbolname, ign_err=0) void * libhandle char * symbolname + int ign_err PREINIT: void *sym; CODE: @@ -229,10 +234,11 @@ dl_find_symbol(libhandle, symbolname) sym = dlsym(libhandle, symbolname); DLDEBUG(2, PerlIO_printf(Perl_debug_log, " symbolref = %lx\n", (unsigned long) sym)); - ST(0) = sv_newmortal() ; - if (sym == NULL) - SaveError(aTHX_ "%s",dlerror()) ; - else + ST(0) = sv_newmortal(); + if (sym == NULL) { + if (!ign_err) + SaveError(aTHX_ "%s", dlerror()); + } else sv_setiv( ST(0), PTR2IV(sym)); @@ -258,11 +264,11 @@ dl_install_xsub(perl_name, symref, filename="$Package") XS_DYNAMIC_FILENAME))); -char * +SV * dl_error() CODE: dMY_CXT; - RETVAL = dl_last_error ; + RETVAL = newSVsv(MY_CXT.x_dl_last_error); OUTPUT: RETVAL @@ -279,7 +285,7 @@ CLONE(...) * using Perl variables that belong to another thread, we create our * own for this thread. */ - MY_CXT.x_dl_last_error = newSVpvn("", 0); + MY_CXT.x_dl_last_error = newSVpvs(""); #endif diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_dyld.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_dyld.xs index caa94676b04..38a38400d45 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/dl_dyld.xs +++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_dyld.xs @@ -39,7 +39,9 @@ been tested on NeXT platforms. */ +#define PERL_EXT #include "EXTERN.h" +#define PERL_IN_DL_DYLD_XS #include "perl.h" #include "XSUB.h" @@ -173,9 +175,10 @@ dl_load_file(filename, flags=0) void * -dl_find_symbol(libhandle, symbolname) +dl_find_symbol(libhandle, symbolname, ign_err=0) void * libhandle char * symbolname + int ign_err CODE: symbolname = Perl_form_nocontext("_%s", symbolname); DLDEBUG(2, PerlIO_printf(Perl_debug_log, @@ -185,9 +188,10 @@ dl_find_symbol(libhandle, symbolname) DLDEBUG(2, PerlIO_printf(Perl_debug_log, " symbolref = %lx\n", (unsigned long) RETVAL)); ST(0) = sv_newmortal() ; - if (RETVAL == NULL) - SaveError(aTHX_ "%s",dlerror()) ; - else + if (RETVAL == NULL) { + if (!ign_err) + SaveError(aTHX_ "%s",dlerror()) ; + } else sv_setiv( ST(0), PTR2IV(RETVAL) ); @@ -213,11 +217,11 @@ dl_install_xsub(perl_name, symref, filename="$Package") XS_DYNAMIC_FILENAME))); -char * +SV * dl_error() CODE: dMY_CXT; - RETVAL = dl_last_error ; + RETVAL = newSVsv(MY_CXT.x_dl_last_error); OUTPUT: RETVAL @@ -234,7 +238,7 @@ CLONE(...) * using Perl variables that belong to another thread, we create our * own for this thread. */ - MY_CXT.x_dl_last_error = newSVpvn("", 0); + MY_CXT.x_dl_last_error = newSVpvs(""); #endif diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_freemint.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_freemint.xs index 6970a760e2a..e932a422181 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/dl_freemint.xs +++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_freemint.xs @@ -37,7 +37,9 @@ * */ +#define PERL_EXT #include "EXTERN.h" +#define PERL_IN_DL_FREEMINT_XS #include "perl.h" #include "XSUB.h" @@ -143,9 +145,10 @@ haverror: void -dl_find_symbol(libhandle, symbolname) +dl_find_symbol(libhandle, symbolname, ign_err=0) void * libhandle char * symbolname + int ign_err PREINIT: void *retv; CODE: @@ -154,9 +157,10 @@ dl_find_symbol(libhandle, symbolname) retv = (void *)dld_get_func(symbolname); DLDEBUG(2,PerlIO_printf(Perl_debug_log, " symbolref = %x\n", (unsigned int)retv)); ST(0) = sv_newmortal() ; - if (retv == NULL) - SaveError(aTHX_ "dl_find_symbol: Unable to find '%s' symbol", symbolname) ; - else + if (retv == NULL) { + if (!ign_err) + SaveError(aTHX_ "dl_find_symbol: Unable to find '%s' symbol", symbolname) ; + } else sv_setiv(ST(0), PTR2IV(retv)); XSRETURN(1); @@ -191,12 +195,11 @@ dl_install_xsub(perl_name, symref, filename="$Package") XS_DYNAMIC_FILENAME))); XSRETURN(1); -char * +SV * dl_error() - PREINIT: - dMY_CXT; CODE: - RETVAL = dl_last_error ; + dMY_CXT; + RETVAL = newSVsv(MY_CXT.x_dl_last_error); OUTPUT: RETVAL @@ -211,7 +214,7 @@ CLONE(...) * using Perl variables that belong to another thread, we create our * own for this thread. */ - MY_CXT.x_dl_last_error = newSVpvn("", 0); + MY_CXT.x_dl_last_error = newSVpvs(""); dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI); dl_require_symbols = get_av("DynaLoader::dl_require_symbols", GV_ADDMULTI); diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_hpux.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_hpux.xs index 4acc8c12e3f..82cee5430d2 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/dl_hpux.xs +++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_hpux.xs @@ -22,7 +22,9 @@ #undef MAGIC #endif +#define PERL_EXT #include "EXTERN.h" +#define PERL_IN_DL_HPUX_XS #include "perl.h" #include "XSUB.h" @@ -93,7 +95,7 @@ dl_load_file(filename, flags=0) DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s): ", filename)); obj = shl_load(filename, bind_type, 0L); - DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", obj)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%p\n", (void*)obj)); end: ST(0) = sv_newmortal() ; if (obj == NULL) @@ -107,7 +109,7 @@ dl_unload_file(libref) void * libref CODE: DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_unload_file(%lx):\n", PTR2ul(libref))); - RETVAL = (shl_unload(libref) == 0 ? 1 : 0); + RETVAL = (shl_unload((shl_t)libref) == 0 ? 1 : 0); if (!RETVAL) SaveError(aTHX_ "%s", Strerror(errno)); DLDEBUG(2,PerlIO_printf(Perl_debug_log, " retval = %d\n", RETVAL)); @@ -116,9 +118,10 @@ dl_unload_file(libref) void -dl_find_symbol(libhandle, symbolname) +dl_find_symbol(libhandle, symbolname, ign_err=0) void * libhandle char * symbolname + int ign_err PREINIT: shl_t obj = (shl_t) libhandle; void *symaddr = NULL; @@ -135,15 +138,15 @@ dl_find_symbol(libhandle, symbolname) errno = 0; status = shl_findsym(&obj, symbolname, TYPE_PROCEDURE, &symaddr); - DLDEBUG(2,PerlIO_printf(Perl_debug_log, " symbolref(PROCEDURE) = %x\n", symaddr)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " symbolref(PROCEDURE) = %p\n", (void*)symaddr)); if (status == -1 && errno == 0) { /* try TYPE_DATA instead */ status = shl_findsym(&obj, symbolname, TYPE_DATA, &symaddr); - DLDEBUG(2,PerlIO_printf(Perl_debug_log, " symbolref(DATA) = %x\n", symaddr)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " symbolref(DATA) = %p\n", (void*)symaddr)); } if (status == -1) { - SaveError(aTHX_ "%s",(errno) ? Strerror(errno) : "Symbol not found") ; + if (!ign_err) SaveError(aTHX_ "%s",(errno) ? Strerror(errno) : "Symbol not found") ; } else { sv_setiv( ST(0), PTR2IV(symaddr) ); } @@ -163,18 +166,18 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref const char * filename CODE: - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n", - perl_name, symref)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%p)\n", + perl_name, (void*)symref)); ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name, (void(*)(pTHX_ CV *))symref, filename, NULL, XS_DYNAMIC_FILENAME))); -char * +SV * dl_error() CODE: dMY_CXT; - RETVAL = dl_last_error ; + RETVAL = newSVsv(MY_CXT.x_dl_last_error); OUTPUT: RETVAL @@ -191,7 +194,7 @@ CLONE(...) * using Perl variables that belong to another thread, we create our * own for this thread. */ - MY_CXT.x_dl_last_error = newSVpvn("", 0); + MY_CXT.x_dl_last_error = newSVpvs(""); dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI); #endif diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_next.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_next.xs deleted file mode 100644 index f1fb1c46371..00000000000 --- a/gnu/usr.bin/perl/ext/DynaLoader/dl_next.xs +++ /dev/null @@ -1,345 +0,0 @@ -/* dl_next.xs - * - * Platform: NeXT NS 3.2 - * Author: Anno Siegel (siegel@zrz.TU-Berlin.DE) - * Based on: dl_dlopen.xs by Paul Marquess - * Created: Aug 15th, 1994 - * - */ - -/* - * And Gandalf said: 'Many folk like to know beforehand what is to - * be set on the table; but those who have laboured to prepare the - * feast like to keep their secret; for wonder makes the words of - * praise louder.' - * - * [p.970 of _The Lord of the Rings_, VI/v: "The Steward and the King"] - */ - -/* Porting notes: - -dl_next.xs is itself a port from dl_dlopen.xs by Paul Marquess. It -should not be used as a base for further ports though it may be used -as an example for how dl_dlopen.xs can be ported to other platforms. - -The method used here is just to supply the sun style dlopen etc. -functions in terms of NeXTs rld_*. The xs code proper is unchanged -from Paul's original. - -The port could use some streamlining. For one, error handling could -be simplified. - -Anno Siegel - -*/ - -#if NS_TARGET_MAJOR >= 4 -#else -/* include these before perl headers */ -#include <mach-o/rld.h> -#include <streams/streams.h> -#endif - -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#define DL_LOADONCEONLY - -typedef struct { - AV * x_resolve_using; -} my_cxtx_t; /* this *must* be named my_cxtx_t */ - -#define DL_CXT_EXTRA /* ask for dl_cxtx to be defined in dlutils.c */ -#include "dlutils.c" /* SaveError() etc */ - -#define dl_resolve_using (dl_cxtx.x_resolve_using) - -static char *dlerror() -{ - dTHX; - dMY_CXT; - return dl_last_error; -} - -int dlclose(handle) /* stub only */ -void *handle; -{ - return 0; -} - -#if NS_TARGET_MAJOR >= 4 -#import <mach-o/dyld.h> - -enum dyldErrorSource -{ - OFImage, -}; - -static void TranslateError - (const char *path, enum dyldErrorSource type, int number) -{ - dTHX; - dMY_CXT; - char *error; - unsigned int index; - static char *OFIErrorStrings[] = - { - "%s(%d): Object Image Load Failure\n", - "%s(%d): Object Image Load Success\n", - "%s(%d): Not a recognisable object file\n", - "%s(%d): No valid architecture\n", - "%s(%d): Object image has an invalid format\n", - "%s(%d): Invalid access (permissions?)\n", - "%s(%d): Unknown error code from NSCreateObjectFileImageFromFile\n", - }; -#define NUM_OFI_ERRORS (sizeof(OFIErrorStrings) / sizeof(OFIErrorStrings[0])) - - switch (type) - { - case OFImage: - index = number; - if (index > NUM_OFI_ERRORS - 1) - index = NUM_OFI_ERRORS - 1; - error = Perl_form_nocontext(OFIErrorStrings[index], path, number); - break; - - default: - error = Perl_form_nocontext("%s(%d): Totally unknown error type %d\n", - path, number, type); - break; - } - Safefree(dl_last_error); - dl_last_error = savepv(error); -} - -static char *dlopen(char *path, int mode /* mode is ignored */) -{ - int dyld_result; - NSObjectFileImage ofile; - NSModule handle = NULL; - - dyld_result = NSCreateObjectFileImageFromFile(path, &ofile); - if (dyld_result != NSObjectFileImageSuccess) - TranslateError(path, OFImage, dyld_result); - else - { - // NSLinkModule will cause the run to abort on any link error's - // not very friendly but the error recovery functionality is limited. - handle = NSLinkModule(ofile, path, TRUE); - } - - return handle; -} - -void * -dlsym(handle, symbol) -void *handle; -char *symbol; -{ - void *addr; - - if (NSIsSymbolNameDefined(symbol)) - addr = NSAddressOfSymbol(NSLookupAndBindSymbol(symbol)); - else - addr = NULL; - - return addr; -} - -#else /* NS_TARGET_MAJOR <= 3 */ - -static NXStream *OpenError(void) -{ - return NXOpenMemory( (char *) 0, 0, NX_WRITEONLY); -} - -static void TransferError(NXStream *s) -{ - char *buffer; - int len, maxlen; - dTHX; - dMY_CXT; - - if ( dl_last_error ) { - Safefree(dl_last_error); - } - NXGetMemoryBuffer(s, &buffer, &len, &maxlen); - Newx(dl_last_error, len, char); - strcpy(dl_last_error, buffer); -} - -static void CloseError(NXStream *s) -{ - if ( s ) { - NXCloseMemory( s, NX_FREEBUFFER); - } -} - -static char *dlopen(char *path, int mode /* mode is ignored */) -{ - int rld_success; - NXStream *nxerr; - I32 i, psize; - char *result; - char **p; - STRLEN n_a; - dTHX; - dMY_CXT; - - /* Do not load what is already loaded into this process */ - if (hv_fetch(dl_loaded_files, path, strlen(path), 0)) - return path; - - nxerr = OpenError(); - psize = AvFILL(dl_resolve_using) + 3; - p = (char **) safemalloc(psize * sizeof(char*)); - p[0] = path; - for(i=1; i<psize-1; i++) { - p[i] = SvPVx(*av_fetch(dl_resolve_using, i-1, TRUE), n_a); - } - p[psize-1] = 0; - rld_success = rld_load(nxerr, (struct mach_header **)0, p, - (const char *) 0); - safefree((char*) p); - if (rld_success) { - result = path; - /* prevent multiple loads of same file into same process */ - hv_store(dl_loaded_files, path, strlen(path), &PL_sv_yes, 0); - } else { - TransferError(nxerr); - result = (char*) 0; - } - CloseError(nxerr); - return result; -} - -void * -dlsym(handle, symbol) -void *handle; -char *symbol; -{ - NXStream *nxerr = OpenError(); - unsigned long symref = 0; - - if (!rld_lookup(nxerr, Perl_form_nocontext("_%s", symbol), &symref)) - TransferError(nxerr); - CloseError(nxerr); - return (void*) symref; -} - -#endif /* NS_TARGET_MAJOR >= 4 */ - - -/* ----- code from dl_dlopen.xs below here ----- */ - - -static void -dl_private_init(pTHX) -{ - (void)dl_generic_private_init(aTHX); - { - dMY_CXT; - dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI); - } -} - -MODULE = DynaLoader PACKAGE = DynaLoader - -BOOT: - (void)dl_private_init(aTHX); - - - -void -dl_load_file(filename, flags=0) - char * filename - int flags - PREINIT: - int mode = 1; - void *retv; - CODE: - DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags)); - if (flags & 0x01) - Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename); - retv = dlopen(filename, mode) ; - DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", retv)); - ST(0) = sv_newmortal() ; - if (retv == NULL) - SaveError(aTHX_ "%s",dlerror()) ; - else - sv_setiv( ST(0), PTR2IV(retv) ); - - -void -dl_find_symbol(libhandle, symbolname) - void * libhandle - char * symbolname - PREINIT: - void *retv; - CODE: -#if NS_TARGET_MAJOR >= 4 - symbolname = Perl_form_nocontext("_%s", symbolname); -#endif - DLDEBUG(2, PerlIO_printf(Perl_debug_log, - "dl_find_symbol(handle=%lx, symbol=%s)\n", - (unsigned long) libhandle, symbolname)); - retv = dlsym(libhandle, symbolname); - DLDEBUG(2, PerlIO_printf(Perl_debug_log, - " symbolref = %lx\n", (unsigned long) retv)); - ST(0) = sv_newmortal() ; - if (retv == NULL) - SaveError(aTHX_ "%s",dlerror()) ; - else - sv_setiv( ST(0), PTR2IV(retv) ); - - -void -dl_undef_symbols() - CODE: - - - -# These functions should not need changing on any platform: - -void -dl_install_xsub(perl_name, symref, filename="$Package") - char * perl_name - void * symref - const char * filename - CODE: - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n", - perl_name, symref)); - ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name, - (void(*)(pTHX_ CV *))symref, - filename, NULL, - XS_DYNAMIC_FILENAME))); - - -char * -dl_error() - CODE: - dMY_CXT; - RETVAL = dl_last_error ; - OUTPUT: - RETVAL - -#if defined(USE_ITHREADS) - -void -CLONE(...) - CODE: - MY_CXT_CLONE; - - PERL_UNUSED_VAR(items); - - /* MY_CXT_CLONE just does a memcpy on the whole structure, so to avoid - * using Perl variables that belong to another thread, we create our - * own for this thread. - */ - MY_CXT.x_dl_last_error = newSVpvn("", 0); - dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI); - -#endif - -# end. diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_none.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_none.xs index 5a193e4346e..d2cb2bcb76c 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/dl_none.xs +++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_none.xs @@ -3,7 +3,9 @@ * Stubs for platforms that do not support dynamic linking */ +#define PERL_EXT #include "EXTERN.h" +#define PERL_IN_DL_NONE_XS #include "perl.h" #include "XSUB.h" diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_symbian.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_symbian.xs index 7f0c0d39006..c2d1094aeda 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/dl_symbian.xs +++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_symbian.xs @@ -25,7 +25,8 @@ * only after that the Perl ones. Otherwise you will get a lot * trouble because of Symbian's New(), Copy(), etc definitions. */ -#define DL_SYMBIAN_XS +#define PERL_EXT +#define PERL_IN_DL_SYMBIAN_XS #include "EXTERN.h" #include "perl.h" @@ -162,8 +163,8 @@ dl_load_file(filename, flags=0) if (h && h->error == KErrNone) sv_setiv(ST(0), PTR2IV(h)); else - PerlIO_printf(Perl_debug_log, "(dl_load_file %s %d)", - filename, h ? h->error : -1); + SaveError(aTHX_ "(dl_load_file %s %d)" + filename, h ? h->error : -1); } @@ -177,20 +178,23 @@ dl_unload_file(libhandle) void -dl_find_symbol(libhandle, symbolname) +dl_find_symbol(libhandle, symbolname, ign_err=0) void * libhandle char * symbolname + int ign_err PREINIT: void *sym; CODE: PerlSymbianLibHandle* h = (PerlSymbianLibHandle*)libhandle; sym = dlsym(libhandle, symbolname); ST(0) = sv_newmortal(); - if (sym) + if (sym) { sv_setiv(ST(0), PTR2IV(sym)); - else - PerlIO_printf(Perl_debug_log, "(dl_find_symbol %s %d)", + } else { + if (!ign_err) + SaveError(aTHX_ "(dl_find_symbol %s %d)", symbolname, h ? h->error : -1); + } void @@ -213,11 +217,11 @@ dl_install_xsub(perl_name, symref, filename="$Package") XS_DYNAMIC_FILENAME))); -char * +SV * dl_error() CODE: dMY_CXT; - RETVAL = dl_last_error; + RETVAL = newSVsv(MY_CXT.x_dl_last_error); OUTPUT: RETVAL @@ -234,7 +238,7 @@ CLONE(...) * using Perl variables that belong to another thread, we create our * own for this thread. */ - MY_CXT.x_dl_last_error = newSVpvn("", 0); + MY_CXT.x_dl_last_error = newSVpvs(""); #endif diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_vms.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_vms.xs index 6eb2c546b2e..6a32fc18a0f 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/dl_vms.xs +++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_vms.xs @@ -45,7 +45,9 @@ * */ +#define PERL_EXT #include "EXTERN.h" +#define PERL_IN_DL_VMS_XS #include "perl.h" #include "XSUB.h" @@ -300,9 +302,10 @@ dl_load_file(filename, flags=0) void -dl_find_symbol(librefptr,symname) +dl_find_symbol(librefptr,symname,ign_err=0) void * librefptr SV * symname + int ign_err PREINIT: struct libref thislib = *((struct libref *)librefptr); struct dsc$descriptor_s @@ -320,7 +323,7 @@ dl_find_symbol(librefptr,symname) DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tentry point is %d\n", (unsigned long int) entry)); if (!(sts & 1)) { - dl_set_error(sts,0); + if (!ign_err) dl_set_error(sts,0); ST(0) = &PL_sv_undef; } else ST(0) = sv_2mortal(newSViv(PTR2IV(entry))); @@ -347,13 +350,13 @@ dl_install_xsub(perl_name, symref, filename="$Package") XS_DYNAMIC_FILENAME))); -char * +SV * dl_error() CODE: dMY_CXT; - RETVAL = dl_last_error ; + RETVAL = newSVsv(MY_CXT.x_dl_last_error); OUTPUT: - RETVAL + RETVAL #if defined(USE_ITHREADS) @@ -368,9 +371,18 @@ CLONE(...) * using Perl variables that belong to another thread, we create our * own for this thread. */ - MY_CXT.x_dl_last_error = newSVpvn("", 0); + MY_CXT.x_dl_last_error = newSVpvs(""); dl_require_symbols = get_av("DynaLoader::dl_require_symbols", GV_ADDMULTI); + /* Set up the "static" control blocks for dl_expand_filespec() */ + dl_fab = cc$rms_fab; + dl_nam = cc$rms_nam; + dl_fab.fab$l_nam = &dl_nam; + dl_nam.nam$l_esa = dl_esa; + dl_nam.nam$b_ess = sizeof dl_esa; + dl_nam.nam$l_rsa = dl_rsa; + dl_nam.nam$b_rss = sizeof dl_rsa; + #endif # end. diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_win32.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_win32.xs index f5d56cf5e85..3260402f3d6 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/dl_win32.xs +++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_win32.xs @@ -25,6 +25,8 @@ calls. #include <string.h> #define PERL_NO_GET_CONTEXT +#define PERL_EXT +#define PERL_IN_DL_WIN32_XS #include "EXTERN.h" #include "perl.h" @@ -47,10 +49,13 @@ OS_Error_String(pTHX) dMY_CXT; DWORD err = GetLastError(); STRLEN len; - if (!dl_error_sv) - dl_error_sv = newSVpvn("",0); - PerlProc_GetOSError(dl_error_sv,err); - return SvPV(dl_error_sv,len); + SV ** l_dl_error_svp = &dl_error_sv; + SV * l_dl_error_sv; + if (!*l_dl_error_svp) + *l_dl_error_svp = newSVpvs(""); + l_dl_error_sv = *l_dl_error_svp; + PerlProc_GetOSError(l_dl_error_sv,err); + return SvPV(l_dl_error_sv,len); } static void @@ -114,11 +119,14 @@ BOOT: void dl_load_file(filename,flags=0) char * filename - int flags +#flags is unused + SV * flags = NO_INIT PREINIT: void *retv; + SV * retsv; CODE: { + PERL_UNUSED_VAR(flags); DLDEBUG(1,PerlIO_printf(Perl_debug_log,"dl_load_file(%s):\n", filename)); if (dl_static_linked(filename) == 0) { retv = PerlProc_DynaLoad(filename); @@ -126,12 +134,15 @@ dl_load_file(filename,flags=0) else retv = (void*) Win_GetModuleHandle(NULL); DLDEBUG(2,PerlIO_printf(Perl_debug_log," libref=%x\n", retv)); - ST(0) = sv_newmortal() ; - if (retv == NULL) + + if (retv == NULL) { SaveError(aTHX_ "load_file:%s", OS_Error_String(aTHX)) ; + retsv = &PL_sv_undef; + } else - sv_setiv( ST(0), (IV)retv); + retsv = sv_2mortal(newSViv((IV)retv)); + ST(0) = retsv; } int @@ -139,7 +150,7 @@ dl_unload_file(libref) void * libref CODE: DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_unload_file(%lx):\n", PTR2ul(libref))); - RETVAL = FreeLibrary(libref); + RETVAL = FreeLibrary((HMODULE)libref); if (!RETVAL) SaveError(aTHX_ "unload_file:%s", OS_Error_String(aTHX)) ; DLDEBUG(2,PerlIO_printf(Perl_debug_log, " retval = %d\n", RETVAL)); @@ -147,9 +158,10 @@ dl_unload_file(libref) RETVAL void -dl_find_symbol(libhandle, symbolname) +dl_find_symbol(libhandle, symbolname, ign_err=0) void * libhandle char * symbolname + int ign_err PREINIT: void *retv; CODE: @@ -157,11 +169,10 @@ dl_find_symbol(libhandle, symbolname) libhandle, symbolname)); retv = (void*) GetProcAddress((HINSTANCE) libhandle, symbolname); DLDEBUG(2,PerlIO_printf(Perl_debug_log," symbolref = %x\n", retv)); - ST(0) = sv_newmortal() ; - if (retv == NULL) - SaveError(aTHX_ "find_symbol:%s", - OS_Error_String(aTHX)) ; - else + ST(0) = sv_newmortal(); + if (retv == NULL) { + if (!ign_err) SaveError(aTHX_ "find_symbol:%s", OS_Error_String(aTHX)); + } else sv_setiv( ST(0), (IV)retv); @@ -186,11 +197,11 @@ dl_install_xsub(perl_name, symref, filename="$Package") filename))); -char * +SV * dl_error() CODE: dMY_CXT; - RETVAL = dl_last_error; + RETVAL = newSVsv(MY_CXT.x_dl_last_error); OUTPUT: RETVAL @@ -207,7 +218,7 @@ CLONE(...) * using Perl variables that belong to another thread, we create our * own for this thread. */ - MY_CXT.x_dl_last_error = newSVpvn("", 0); + MY_CXT.x_dl_last_error = newSVpvs(""); #endif diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dlutils.c b/gnu/usr.bin/perl/ext/DynaLoader/dlutils.c index 574ccadc34b..557c0ec1db6 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/dlutils.c +++ b/gnu/usr.bin/perl/ext/DynaLoader/dlutils.c @@ -10,6 +10,7 @@ #define PERL_EUPXS_ALWAYS_EXPORT #ifndef START_MY_CXT /* Some IDEs try compiling this standalone. */ +# define PERL_EXT # include "EXTERN.h" # include "perl.h" # include "XSUB.h" @@ -20,11 +21,17 @@ #endif #define MY_CXT_KEY "DynaLoader::_guts" XS_VERSION +/* disable version checking since DynaLoader can't be DynaLoaded */ +#undef dXSBOOTARGSXSAPIVERCHK +#define dXSBOOTARGSXSAPIVERCHK dXSBOOTARGSNOVERCHK + typedef struct { SV* x_dl_last_error; /* pointer to allocated memory for last error message */ +#if defined(PERL_IN_DL_HPUX_XS) || defined(PERL_IN_DL_DLOPEN_XS) int x_dl_nonlazy; /* flag for immediate rather than lazy linking (spots unresolved symbol) */ +#endif #ifdef DL_LOADONCEONLY HV * x_dl_loaded_files; /* only needed on a few systems */ #endif @@ -39,7 +46,9 @@ typedef struct { START_MY_CXT #define dl_last_error (SvPVX(MY_CXT.x_dl_last_error)) +#if defined(PERL_IN_DL_HPUX_XS) || defined(PERL_IN_DL_DLOPEN_XS) #define dl_nonlazy (MY_CXT.x_dl_nonlazy) +#endif #ifdef DL_LOADONCEONLY #define dl_loaded_files (MY_CXT.x_dl_loaded_files) #endif @@ -71,12 +80,13 @@ dl_unload_all_files(pTHX_ void *unused) if ((sub = get_cvs("DynaLoader::dl_unload_file", 0)) != NULL) { dl_librefs = get_av("DynaLoader::dl_librefs", 0); + EXTEND(SP,1); while ((dl_libref = av_pop(dl_librefs)) != &PL_sv_undef) { dSP; ENTER; SAVETMPS; PUSHMARK(SP); - XPUSHs(sv_2mortal(dl_libref)); + PUSHs(sv_2mortal(dl_libref)); PUTBACK; call_sv((SV*)sub, G_DISCARD | G_NODEBUG); FREETMPS; @@ -89,11 +99,13 @@ dl_unload_all_files(pTHX_ void *unused) static void dl_generic_private_init(pTHX) /* called by dl_*.xs dl_private_init() */ { +#if defined(PERL_IN_DL_HPUX_XS) || defined(PERL_IN_DL_DLOPEN_XS) char *perl_dl_nonlazy; + UV uv; +#endif MY_CXT_INIT; - MY_CXT.x_dl_last_error = newSVpvn("", 0); - dl_nonlazy = 0; + MY_CXT.x_dl_last_error = newSVpvs(""); #ifdef DL_LOADONCEONLY dl_loaded_files = NULL; #endif @@ -103,10 +115,18 @@ dl_generic_private_init(pTHX) /* called by dl_*.xs dl_private_init() */ dl_debug = sv ? SvIV(sv) : 0; } #endif - if ( (perl_dl_nonlazy = getenv("PERL_DL_NONLAZY")) != NULL ) - dl_nonlazy = atoi(perl_dl_nonlazy); + +#if defined(PERL_IN_DL_HPUX_XS) || defined(PERL_IN_DL_DLOPEN_XS) + if ( (perl_dl_nonlazy = getenv("PERL_DL_NONLAZY")) != NULL + && grok_atoUV(perl_dl_nonlazy, &uv, NULL) + && uv <= INT_MAX + ) { + dl_nonlazy = (int)uv; + } else + dl_nonlazy = 0; if (dl_nonlazy) DLDEBUG(1,PerlIO_printf(Perl_debug_log, "DynaLoader bind mode is 'non-lazy'\n")); +#endif #ifdef DL_LOADONCEONLY if (!dl_loaded_files) dl_loaded_files = newHV(); /* provide cache for dl_*.xs if needed */ @@ -122,7 +142,6 @@ dl_generic_private_init(pTHX) /* called by dl_*.xs dl_private_init() */ static void SaveError(pTHX_ const char* pat, ...) { - dMY_CXT; va_list args; SV *msv; const char *message; @@ -137,9 +156,12 @@ SaveError(pTHX_ const char* pat, ...) message = SvPV(msv,len); len++; /* include terminating null char */ + { + dMY_CXT; /* Copy message into dl_last_error (including terminating null char) */ - sv_setpvn(MY_CXT.x_dl_last_error, message, len) ; - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "DynaLoader: stored error msg '%s'\n",dl_last_error)); + sv_setpvn(MY_CXT.x_dl_last_error, message, len) ; + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "DynaLoader: stored error msg '%s'\n",dl_last_error)); + } } #endif diff --git a/gnu/usr.bin/perl/ext/DynaLoader/t/DynaLoader.t b/gnu/usr.bin/perl/ext/DynaLoader/t/DynaLoader.t index ade1f8e52b9..77fb65d4702 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/t/DynaLoader.t +++ b/gnu/usr.bin/perl/ext/DynaLoader/t/DynaLoader.t @@ -2,7 +2,13 @@ use strict; use Config; -use Test::More; +push @INC, '.'; +if (-f 't/test.pl') { + require 't/test.pl'; +} else { + require '../../t/test.pl'; +} + my %modules; my $db_file; @@ -17,17 +23,16 @@ BEGIN { } %modules = ( - # ModuleName => q| code to check that it was loaded |, - 'List::Util' => q| ::is( ref List::Util->can('first'), 'CODE' ) |, # 5.7.2 - 'Cwd' => q| ::is( ref Cwd->can('fastcwd'),'CODE' ) |, # 5.7 ? - 'File::Glob' => q| ::is( ref File::Glob->can('doglob'),'CODE' ) |, # 5.6 - $db_file => q| ::is( ref $db_file->can('TIEHASH'), 'CODE' ) |, # 5.0 - 'Socket' => q| ::is( ref Socket->can('inet_aton'),'CODE' ) |, # 5.0 - 'Time::HiRes'=> q| ::is( ref Time::HiRes->can('usleep'),'CODE' ) |, # 5.7.3 + # ModuleName => q| code to check that it was loaded |, + 'List::Util' => q| ::is( ref List::Util->can('first'), 'CODE' ) |, # 5.7.2 + 'Cwd' => q| ::is( ref Cwd->can('fastcwd'),'CODE' ) |, # 5.7 ? + 'File::Glob' => q| ::is( ref File::Glob->can('doglob'),'CODE' ) |, # 5.6 + $db_file => q| ::is( ref $db_file->can('TIEHASH'), 'CODE' ) |, # 5.0 + 'Socket' => q| ::is( ref Socket->can('inet_aton'),'CODE' ) |, # 5.0 + 'Time::HiRes' => q| ::is( ref Time::HiRes->can('usleep'),'CODE' ) |, # 5.7.3 ); -plan tests => 26 + keys(%modules) * 3; - +plan (26 + keys(%modules) * 3); # Try to load the module use_ok( 'DynaLoader' ); @@ -48,7 +53,7 @@ if ($Config{usedl}) { can_ok( 'DynaLoader' => 'dl_load_file' ); # defined in XS section can_ok( 'DynaLoader' => 'dl_undef_symbols' ); # defined in XS section SKIP: { - skip "unloading unsupported on $^O", 1 if ($old_darwin || $^O eq 'VMS'); + skip( "unloading unsupported on $^O", 1 ) if ($old_darwin || $^O eq 'VMS'); can_ok( 'DynaLoader' => 'dl_unload_file' ); # defined in XS section } } else { @@ -67,23 +72,23 @@ can_ok( 'DynaLoader' => 'dl_find_symbol_anywhere' ); # Check error messages # .. for bootstrap() eval { DynaLoader::bootstrap() }; -like( $@, q{/^Usage: DynaLoader::bootstrap\(module\)/}, +like( $@, qr/^Usage: DynaLoader::bootstrap\(module\)/, "calling DynaLoader::bootstrap() with no argument" ); eval { package egg_bacon_sausage_and_spam; DynaLoader::bootstrap("egg_bacon_sausage_and_spam") }; if ($Config{usedl}) { - like( $@, q{/^Can't locate loadable object for module egg_bacon_sausage_and_spam/}, + like( $@, qr/^Can't locate loadable object for module egg_bacon_sausage_and_spam/, "calling DynaLoader::bootstrap() with a package without binary object" ); } else { - like( $@, q{/^Can't load module egg_bacon_sausage_and_spam/}, + like( $@, qr/^Can't load module egg_bacon_sausage_and_spam/, "calling DynaLoader::bootstrap() with a package without binary object" ); } # .. for dl_load_file() SKIP: { - skip "no dl_load_file with dl_none.xs", 2 unless $Config{usedl}; + skip( "no dl_load_file with dl_none.xs", 2 ) unless $Config{usedl}; eval { DynaLoader::dl_load_file() }; - like( $@, q{/^Usage: DynaLoader::dl_load_file\(filename, flags=0\)/}, + like( $@, qr/^Usage: DynaLoader::dl_load_file\(filename, flags=0\)/, "calling DynaLoader::dl_load_file() with no argument" ); eval { no warnings 'uninitialized'; DynaLoader::dl_load_file(undef) }; @@ -94,7 +99,7 @@ my ($dlhandle, $dlerr); eval { $dlhandle = DynaLoader::dl_load_file("egg_bacon_sausage_and_spam") }; $dlerr = DynaLoader::dl_error(); SKIP: { - skip "dl_load_file() does not attempt to load file on VMS (and thus does not fail) when \@dl_require_symbols is empty", 1 if $^O eq 'VMS'; + skip( "dl_load_file() does not attempt to load file on VMS (and thus does not fail) when \@dl_require_symbols is empty", 1 ) if $^O eq 'VMS'; ok( !$dlhandle, "calling DynaLoader::dl_load_file() without an existing library should fail" ); } ok( defined $dlerr, "dl_error() returning an error message: '$dlerr'" ); @@ -111,13 +116,13 @@ SKIP: { # Some platforms are known to not have a "libc" # (not at least by that name) that the dl_findfile() # could find. - skip "dl_findfile test not appropriate on $^O", 1 - if $^O =~ /(win32|vms|openbsd|bitrig|cygwin|vos)/i; + skip( "dl_findfile test not appropriate on $^O", 1 ) + if $^O =~ /(win32|vms|openbsd|bitrig|cygwin|vos|os390)/i; # Play safe and only try this test if this system # looks pretty much Unix-like. - skip "dl_findfile test not appropriate on $^O", 1 + skip( "dl_findfile test not appropriate on $^O", 1 ) unless -d '/usr' && -f '/bin/ls'; - skip "dl_findfile test not always appropriate when cross-compiling", 1 + skip( "dl_findfile test not always appropriate when cross-compiling", 1 ) if $Config{usecrosscompile}; cmp_ok( scalar @files, '>=', 1, "array should contain one result result or more: libc => (@files)" ); } @@ -130,7 +135,7 @@ for my $module (sort keys %modules) { SKIP: { if ($extensions !~ /\b$module\b/) { delete($modules{$module}); - skip "$module not available", 3; + skip( "$module not available", 3); } eval "use $module"; is( $@, '', "loading $module" ); @@ -144,13 +149,13 @@ is( scalar @DynaLoader::dl_modules, scalar keys %modules, "checking number of it my @loaded_modules = @DynaLoader::dl_modules; for my $libref (reverse @DynaLoader::dl_librefs) { TODO: { - todo_skip "Can't safely unload with -DPERL_GLOBAL_STRUCT_PRIVATE (RT #119409)", 2 + todo_skip( "Can't safely unload with -DPERL_GLOBAL_STRUCT_PRIVATE (RT #119409)", 2 ) if $Config{ccflags} =~ /(?:^|\s)-DPERL_GLOBAL_STRUCT_PRIVATE\b/; SKIP: { - skip "unloading unsupported on $^O", 2 + skip( "unloading unsupported on $^O", 2 ) if ($old_darwin || $^O eq 'VMS'); my $module = pop @loaded_modules; - skip "File::Glob sets PL_opfreehook", 2 if $module eq 'File::Glob'; + skip( "File::Glob sets PL_opfreehook", 2 ) if $module eq 'File::Glob'; my $r = eval { DynaLoader::dl_unload_file($libref) }; is( $@, '', "calling dl_unload_file() for $module" ); is( $r, 1, " - unload was successful" ); @@ -159,7 +164,7 @@ for my $libref (reverse @DynaLoader::dl_librefs) { } SKIP: { - skip "mod2fname not defined on this platform", 4 + skip( "mod2fname not defined on this platform", 4 ) unless defined &DynaLoader::mod2fname && $Config{d_libname_unique}; is( @@ -186,3 +191,4 @@ SKIP: { "mod2fname + libname_unique correctly truncates long names" ); } + diff --git a/gnu/usr.bin/perl/ext/Errno/Errno_pm.PL b/gnu/usr.bin/perl/ext/Errno/Errno_pm.PL index f82c091bef1..6251a3cf33b 100644 --- a/gnu/usr.bin/perl/ext/Errno/Errno_pm.PL +++ b/gnu/usr.bin/perl/ext/Errno/Errno_pm.PL @@ -2,7 +2,7 @@ use ExtUtils::MakeMaker; use Config; use strict; -our $VERSION = "1.20_06"; +our $VERSION = "1.25"; my %err = (); @@ -61,11 +61,7 @@ sub process_file { warn "Cannot open '$file'"; return; } - } elsif ($Config{gccversion} ne '' - # OpenSTEP has gcc 2.7.2.1 which recognizes but - # doesn't implement the -dM flag. - && $^O ne 'openstep' && $^O ne 'next' && $^O ne 'darwin' - ) { + } elsif ($Config{gccversion} ne '' && $^O ne 'darwin' ) { # With the -dM option, gcc outputs every #define it finds unless(open(FH,"$Config{cc} -E -dM $Config{cppflags} $file |")) { warn "Cannot open '$file'"; @@ -80,9 +76,16 @@ sub process_file { } } + my $pat; + if ($IsMSWin32) { + $pat = '^\s*#\s*define\s+((?:WSA)?E\w+)\s+'; + } + else { + $pat = '^\s*#\s*define\s+(E\w+)\s+'; + } while(<FH>) { $err{$1} = 1 - if /^\s*#\s*define\s+(E\w+)\s+/; + if /$pat/; } close(FH); @@ -108,15 +111,9 @@ sub default_cpp { sub get_files { my %file = (); - # VMS keeps its include files in system libraries (well, except for Gcc) + # VMS keeps its include files in system libraries if ($^O eq 'VMS') { - if ($Config{vms_cc_type} eq 'decc') { - $file{'Sys$Library:DECC$RTLDEF.TLB'} = 1; - } elsif ($Config{vms_cc_type} eq 'vaxc') { - $file{'Sys$Library:vaxcdef.tlb'} = 1; - } elsif ($Config{vms_cc_type} eq 'gcc') { - $file{'gnu_cc_include:[000000]errno.h'} = 1; - } + $file{'Sys$Library:DECC$RTLDEF.TLB'} = 1; } elsif ($^O eq 'os390') { # OS/390 C compiler doesn't generate #file or #line directives $file{'/usr/include/errno.h'} = 1; @@ -288,13 +285,24 @@ sub write_errno_pm { package Errno; require Exporter; -use Config; use strict; +EDQ + + # Errno only needs Config to make sure it hasn't changed platforms. + # If someone set $ENV{PERL_BUILD_EXPAND_CONFIG_VARS} at build time, + # they've already declared perl doesn't need to worry about this risk. + if(!$ENV{'PERL_BUILD_EXPAND_CONFIG_VARS'}) { + print <<"CONFIG_CHECK_END"; +use Config; "\$Config{'archname'}-\$Config{'osvers'}" eq "$archname-$Config{'osvers'}" or die "Errno architecture ($archname-$Config{'osvers'}) does not match executable architecture (\$Config{'archname'}-\$Config{'osvers'})"; +CONFIG_CHECK_END +} + + print <<"EDQ"; our \$VERSION = "$VERSION"; \$VERSION = eval \$VERSION; our \@ISA = 'Exporter'; @@ -357,7 +365,16 @@ ESQ EUSERS EWOULDBLOCK EXDEV)); $k =~ s/(.{50,70})\s/$1\n\t/g; - print "\t",$k,"\n )]\n);\n\n"; + print "\t",$k,"\n )],\n"; + + if ($IsMSWin32) { + print " WINSOCK => [qw(\n"; + $k = join(" ", grep { /^WSAE/ } keys %err); + $k =~ s/(.{50,70})\s/$1\n\t/g; + print "\t",$k,"\n )],\n"; + } + + print ");\n\n"; print <<'ESQ'; sub TIEHASH { bless \%err } @@ -405,9 +422,13 @@ Errno - System errno constants =head1 DESCRIPTION C<Errno> defines and conditionally exports all the error constants -defined in your system C<errno.h> include file. It has a single export +defined in your system F<errno.h> include file. It has a single export tag, C<:POSIX>, which will export all POSIX defined error numbers. +On Windows, C<Errno> also defines and conditionally exports all the +Winsock error constants defined in your system F<WinError.h> include +file. These are included in a second export tag, C<:WINSOCK>. + C<Errno> also makes C<%!> magic such that each element of C<%!> has a non-zero value only if C<$!> is set to that value. For example: diff --git a/gnu/usr.bin/perl/ext/ExtUtils-Miniperl/lib/ExtUtils/Miniperl.pm b/gnu/usr.bin/perl/ext/ExtUtils-Miniperl/lib/ExtUtils/Miniperl.pm index cede3180f8a..61c66df7ed1 100644 --- a/gnu/usr.bin/perl/ext/ExtUtils-Miniperl/lib/ExtUtils/Miniperl.pm +++ b/gnu/usr.bin/perl/ext/ExtUtils-Miniperl/lib/ExtUtils/Miniperl.pm @@ -8,7 +8,7 @@ use vars qw($VERSION @ISA @EXPORT); @ISA = qw(Exporter); @EXPORT = qw(writemain); -$VERSION = '1.01'; +$VERSION = '1.05'; # blead will run this with miniperl, hence we can't use autodie or File::Temp my $temp; @@ -136,6 +136,8 @@ main(int argc, char **argv, char **env) Perl_atfork_unlock); #endif + PERL_SYS_FPU_INIT; + if (!PL_do_undump) { my_perl = perl_alloc(); if (!my_perl) @@ -191,7 +193,6 @@ main(int argc, char **argv, char **env) #endif /* PERL_GLOBAL_STRUCT */ exit(exitstatus); - return exitstatus; } /* Register any extra external extensions */ @@ -233,8 +234,9 @@ C<writemain()> takes an argument list of directories containing archive libraries that relate to perl modules and should be linked into a new perl binary. It writes a corresponding F<perlmain.c> file that is a plain C file containing all the bootstrap code to make the +modules associated with the libraries available from within perl. If the first argument to C<writemain()> is a reference to a scalar it is -used as the filename to open for ouput. Any other reference is used as +used as the filename to open for output. Any other reference is used as the filehandle to write to. Otherwise output defaults to C<STDOUT>. The typical usage is from within a Makefile generated by @@ -247,10 +249,4 @@ L<ExtUtils::MakeMaker> =cut -# Local variables: -# c-indentation-style: bsd -# c-basic-offset: 4 -# indent-tabs-mode: nil -# End: -# # ex: set ts=8 sts=4 sw=4 et: diff --git a/gnu/usr.bin/perl/ext/Fcntl/Fcntl.pm b/gnu/usr.bin/perl/ext/Fcntl/Fcntl.pm index cc35ff02be8..fa5f3935025 100644 --- a/gnu/usr.bin/perl/ext/Fcntl/Fcntl.pm +++ b/gnu/usr.bin/perl/ext/Fcntl/Fcntl.pm @@ -61,7 +61,7 @@ our($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); require Exporter; require XSLoader; @ISA = qw(Exporter); -$VERSION = '1.11'; +$VERSION = '1.13'; XSLoader::load(); @@ -169,18 +169,25 @@ XSLoader::load(); DN_MULTISHOT DN_RENAME F_GETLEASE + F_GETPIPE_SZ F_GETSIG F_NOTIFY F_SETLEASE + F_SETPIPE_SZ F_SETSIG LOCK_MAND LOCK_READ LOCK_RW LOCK_WRITE + O_ALT_IO + O_EVTONLY O_IGNORE_CTTY O_NOATIME O_NOLINK + O_NOSIGPIPE O_NOTRANS + O_SYMLINK + O_TTY_INIT ), map {@{$_}} values %EXPORT_TAGS); 1; diff --git a/gnu/usr.bin/perl/ext/Fcntl/Makefile.PL b/gnu/usr.bin/perl/ext/Fcntl/Makefile.PL index cb8a8e67882..ec17548baba 100644 --- a/gnu/usr.bin/perl/ext/Fcntl/Makefile.PL +++ b/gnu/usr.bin/perl/ext/Fcntl/Makefile.PL @@ -14,19 +14,19 @@ my @names = (qw( FRSYNC FSYNC FTRUNC F_ALLOCSP F_ALLOCSP64 F_COMPAT F_DUP2FD F_DUPFD F_EXLCK F_FREESP F_FREESP64 F_FSYNC F_FSYNC64 F_GETFD F_GETFL F_GETLEASE F_GETLK F_GETLK64 - F_GETOWN F_GETSIG F_NODNY F_NOTIFY F_POSIX F_RDACC + F_GETOWN F_GETPIPE_SZ F_GETSIG F_NODNY F_NOTIFY F_POSIX F_RDACC F_RDDNY F_RDLCK F_RWACC F_RWDNY F_SETFD F_SETFL F_SETLEASE F_SETLK F_SETLK64 F_SETLKW F_SETLKW64 - F_SETOWN F_SETSIG F_SHARE F_SHLCK F_UNLCK F_UNSHARE + F_SETOWN F_SETPIPE_SZ F_SETSIG F_SHARE F_SHLCK F_UNLCK F_UNSHARE F_WRACC F_WRDNY F_WRLCK LOCK_MAND LOCK_READ LOCK_WRITE - LOCK_RW O_ACCMODE O_ALIAS O_APPEND O_ASYNC O_BINARY - O_CREAT O_DEFER O_DIRECT O_DIRECTORY O_DSYNC O_EXCL + LOCK_RW O_ACCMODE O_ALIAS O_ALT_IO O_APPEND O_ASYNC O_BINARY + O_CREAT O_DEFER O_DIRECT O_DIRECTORY O_DSYNC O_EVTONLY O_EXCL O_EXLOCK O_IGNORE_CTTY O_LARGEFILE O_NDELAY O_NOATIME - O_NOCTTY O_NOFOLLOW O_NOINHERIT O_NOLINK O_NONBLOCK + O_NOCTTY O_NOFOLLOW O_NOINHERIT O_NOLINK O_NONBLOCK O_NOSIGPIPE O_NOTRANS O_RANDOM O_RAW O_RDONLY O_RDWR O_RSRC O_RSYNC - O_SEQUENTIAL O_SHLOCK O_SYNC O_TEMPORARY O_TEXT O_TRUNC - O_WRONLY S_ENFMT S_IEXEC S_IFBLK S_IFCHR S_IFDIR - S_IFIFO S_IFLNK S_IFREG S_IFSOCK S_IFWHT S_IREAD + O_SEQUENTIAL O_SHLOCK O_SYMLINK O_SYNC O_TEMPORARY O_TEXT + O_TRUNC O_TTY_INIT O_WRONLY S_ENFMT S_IEXEC S_IFBLK S_IFCHR + S_IFDIR S_IFIFO S_IFLNK S_IFREG S_IFSOCK S_IFWHT S_IREAD S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU S_ISGID S_ISTXT S_ISUID S_ISVTX S_IWGRP S_IWOTH S_IWRITE S_IWUSR S_IXGRP S_IXOTH S_IXUSR), @@ -37,7 +37,7 @@ my @names = (qw( {name=>"SEEK_SET", default=>["IV", "0"]}, {name=>"SEEK_CUR", default=>["IV", "1"]}, {name=>"SEEK_END", default=>["IV", "2"]}, - {name=>"_S_IFMT", macro=>"S_IFMT", value=>"S_IFMT"}); + {name=>"_S_IFMT", macro=>"S_IFMT", value=>"S_IFMT", type=>"UV"}); WriteConstants( PROXYSUBS => {autoload => 1}, NAME => 'Fcntl', diff --git a/gnu/usr.bin/perl/ext/File-DosGlob/t/DosGlob.t b/gnu/usr.bin/perl/ext/File-DosGlob/t/DosGlob.t index 600b87a0b50..49a0f9e7e81 100644 --- a/gnu/usr.bin/perl/ext/File-DosGlob/t/DosGlob.t +++ b/gnu/usr.bin/perl/ext/File-DosGlob/t/DosGlob.t @@ -28,7 +28,7 @@ is ($_, $expected, 'test if $_ takes as the default'); cmp_ok(@r, '>=', 9) or diag("|@r|"); @r = <*/a*.t>; -# atleast {argv,abbrev,anydbm,autoloader,append,arith,array,assignwarn,auto}.t +# at least {argv,abbrev,anydbm,autoloader,append,arith,array,assignwarn,auto}.t cmp_ok(@r, '>=', 9, 'check <*/*>') or diag("|@r|"); my $r = scalar @r; diff --git a/gnu/usr.bin/perl/ext/File-Find/lib/File/Find.pm b/gnu/usr.bin/perl/ext/File-Find/lib/File/Find.pm index 6cfdb59aef3..03dac9fbda7 100644 --- a/gnu/usr.bin/perl/ext/File-Find/lib/File/Find.pm +++ b/gnu/usr.bin/perl/ext/File-Find/lib/File/Find.pm @@ -3,353 +3,10 @@ use 5.006; use strict; use warnings; use warnings::register; -our $VERSION = '1.27'; +our $VERSION = '1.34'; require Exporter; require Cwd; -# -# Modified to ensure sub-directory traversal order is not inverted by stack -# push and pops. That is remains in the same order as in the directory file, -# or user pre-processing (EG:sorted). -# - -=head1 NAME - -File::Find - Traverse a directory tree. - -=head1 SYNOPSIS - - use File::Find; - find(\&wanted, @directories_to_search); - sub wanted { ... } - - use File::Find; - finddepth(\&wanted, @directories_to_search); - sub wanted { ... } - - use File::Find; - find({ wanted => \&process, follow => 1 }, '.'); - -=head1 DESCRIPTION - -These are functions for searching through directory trees doing work -on each file found similar to the Unix I<find> command. File::Find -exports two functions, C<find> and C<finddepth>. They work similarly -but have subtle differences. - -=over 4 - -=item B<find> - - find(\&wanted, @directories); - find(\%options, @directories); - -C<find()> does a depth-first search over the given C<@directories> in -the order they are given. For each file or directory found, it calls -the C<&wanted> subroutine. (See below for details on how to use the -C<&wanted> function). Additionally, for each directory found, it will -C<chdir()> into that directory and continue the search, invoking the -C<&wanted> function on each file or subdirectory in the directory. - -=item B<finddepth> - - finddepth(\&wanted, @directories); - finddepth(\%options, @directories); - -C<finddepth()> works just like C<find()> except that it invokes the -C<&wanted> function for a directory I<after> invoking it for the -directory's contents. It does a postorder traversal instead of a -preorder traversal, working from the bottom of the directory tree up -where C<find()> works from the top of the tree down. - -=back - -=head2 %options - -The first argument to C<find()> is either a code reference to your -C<&wanted> function, or a hash reference describing the operations -to be performed for each file. The -code reference is described in L<The wanted function> below. - -Here are the possible keys for the hash: - -=over 3 - -=item C<wanted> - -The value should be a code reference. This code reference is -described in L<The wanted function> below. The C<&wanted> subroutine is -mandatory. - -=item C<bydepth> - -Reports the name of a directory only AFTER all its entries -have been reported. Entry point C<finddepth()> is a shortcut for -specifying C<< { bydepth => 1 } >> in the first argument of C<find()>. - -=item C<preprocess> - -The value should be a code reference. This code reference is used to -preprocess the current directory. The name of the currently processed -directory is in C<$File::Find::dir>. Your preprocessing function is -called after C<readdir()>, but before the loop that calls the C<wanted()> -function. It is called with a list of strings (actually file/directory -names) and is expected to return a list of strings. The code can be -used to sort the file/directory names alphabetically, numerically, -or to filter out directory entries based on their name alone. When -I<follow> or I<follow_fast> are in effect, C<preprocess> is a no-op. - -=item C<postprocess> - -The value should be a code reference. It is invoked just before leaving -the currently processed directory. It is called in void context with no -arguments. The name of the current directory is in C<$File::Find::dir>. This -hook is handy for summarizing a directory, such as calculating its disk -usage. When I<follow> or I<follow_fast> are in effect, C<postprocess> is a -no-op. - -=item C<follow> - -Causes symbolic links to be followed. Since directory trees with symbolic -links (followed) may contain files more than once and may even have -cycles, a hash has to be built up with an entry for each file. -This might be expensive both in space and time for a large -directory tree. See L</follow_fast> and L</follow_skip> below. -If either I<follow> or I<follow_fast> is in effect: - -=over 6 - -=item * - -It is guaranteed that an I<lstat> has been called before the user's -C<wanted()> function is called. This enables fast file checks involving S<_>. -Note that this guarantee no longer holds if I<follow> or I<follow_fast> -are not set. - -=item * - -There is a variable C<$File::Find::fullname> which holds the absolute -pathname of the file with all symbolic links resolved. If the link is -a dangling symbolic link, then fullname will be set to C<undef>. - -=back - -This is a no-op on Win32. - -=item C<follow_fast> - -This is similar to I<follow> except that it may report some files more -than once. It does detect cycles, however. Since only symbolic links -have to be hashed, this is much cheaper both in space and time. If -processing a file more than once (by the user's C<wanted()> function) -is worse than just taking time, the option I<follow> should be used. - -This is also a no-op on Win32. - -=item C<follow_skip> - -C<follow_skip==1>, which is the default, causes all files which are -neither directories nor symbolic links to be ignored if they are about -to be processed a second time. If a directory or a symbolic link -are about to be processed a second time, File::Find dies. - -C<follow_skip==0> causes File::Find to die if any file is about to be -processed a second time. - -C<follow_skip==2> causes File::Find to ignore any duplicate files and -directories but to proceed normally otherwise. - -=item C<dangling_symlinks> - -If true and a code reference, will be called with the symbolic link -name and the directory it lives in as arguments. Otherwise, if true -and warnings are on, warning "symbolic_link_name is a dangling -symbolic link\n" will be issued. If false, the dangling symbolic link -will be silently ignored. - -=item C<no_chdir> - -Does not C<chdir()> to each directory as it recurses. The C<wanted()> -function will need to be aware of this, of course. In this case, -C<$_> will be the same as C<$File::Find::name>. - -=item C<untaint> - -If find is used in taint-mode (-T command line switch or if EUID != UID -or if EGID != GID) then internally directory names have to be untainted -before they can be chdir'ed to. Therefore they are checked against a regular -expression I<untaint_pattern>. Note that all names passed to the user's -I<wanted()> function are still tainted. If this option is used while -not in taint-mode, C<untaint> is a no-op. - -=item C<untaint_pattern> - -See above. This should be set using the C<qr> quoting operator. -The default is set to C<qr|^([-+@\w./]+)$|>. -Note that the parentheses are vital. - -=item C<untaint_skip> - -If set, a directory which fails the I<untaint_pattern> is skipped, -including all its sub-directories. The default is to 'die' in such a case. - -=back - -=head2 The wanted function - -The C<wanted()> function does whatever verifications you want on -each file and directory. Note that despite its name, the C<wanted()> -function is a generic callback function, and does B<not> tell -File::Find if a file is "wanted" or not. In fact, its return value -is ignored. - -The wanted function takes no arguments but rather does its work -through a collection of variables. - -=over 4 - -=item C<$File::Find::dir> is the current directory name, - -=item C<$_> is the current filename within that directory - -=item C<$File::Find::name> is the complete pathname to the file. - -=back - -The above variables have all been localized and may be changed without -affecting data outside of the wanted function. - -For example, when examining the file F</some/path/foo.ext> you will have: - - $File::Find::dir = /some/path/ - $_ = foo.ext - $File::Find::name = /some/path/foo.ext - -You are chdir()'d to C<$File::Find::dir> when the function is called, -unless C<no_chdir> was specified. Note that when changing to -directories is in effect the root directory (F</>) is a somewhat -special case inasmuch as the concatenation of C<$File::Find::dir>, -C<'/'> and C<$_> is not literally equal to C<$File::Find::name>. The -table below summarizes all variants: - - $File::Find::name $File::Find::dir $_ - default / / . - no_chdir=>0 /etc / etc - /etc/x /etc x - - no_chdir=>1 / / / - /etc / /etc - /etc/x /etc /etc/x - - -When C<follow> or C<follow_fast> are in effect, there is -also a C<$File::Find::fullname>. The function may set -C<$File::Find::prune> to prune the tree unless C<bydepth> was -specified. Unless C<follow> or C<follow_fast> is specified, for -compatibility reasons (find.pl, find2perl) there are in addition the -following globals available: C<$File::Find::topdir>, -C<$File::Find::topdev>, C<$File::Find::topino>, -C<$File::Find::topmode> and C<$File::Find::topnlink>. - -This library is useful for the C<find2perl> tool, which when fed, - - find2perl / -name .nfs\* -mtime +7 \ - -exec rm -f {} \; -o -fstype nfs -prune - -produces something like: - - sub wanted { - /^\.nfs.*\z/s && - (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_)) && - int(-M _) > 7 && - unlink($_) - || - ($nlink || (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_))) && - $dev < 0 && - ($File::Find::prune = 1); - } - -Notice the C<_> in the above C<int(-M _)>: the C<_> is a magical -filehandle that caches the information from the preceding -C<stat()>, C<lstat()>, or filetest. - -Here's another interesting wanted function. It will find all symbolic -links that don't resolve: - - sub wanted { - -l && !-e && print "bogus link: $File::Find::name\n"; - } - -Note that you may mix directories and (non-directory) files in the list of -directories to be searched by the C<wanted()> function. - - find(\&wanted, "./foo", "./bar", "./baz/epsilon"); - -In the example above, no file in F<./baz/> other than F<./baz/epsilon> will be -evaluated by C<wanted()>. - -See also the script C<pfind> on CPAN for a nice application of this -module. - -=head1 WARNINGS - -If you run your program with the C<-w> switch, or if you use the -C<warnings> pragma, File::Find will report warnings for several weird -situations. You can disable these warnings by putting the statement - - no warnings 'File::Find'; - -in the appropriate scope. See L<warnings> for more info about lexical -warnings. - -=head1 CAVEAT - -=over 2 - -=item $dont_use_nlink - -You can set the variable C<$File::Find::dont_use_nlink> to 1, if you want to -force File::Find to always stat directories. This was used for file systems -that do not have an C<nlink> count matching the number of sub-directories. -Examples are ISO-9660 (CD-ROM), AFS, HPFS (OS/2 file system), FAT (DOS file -system) and a couple of others. - -You shouldn't need to set this variable, since File::Find should now detect -such file systems on-the-fly and switch itself to using stat. This works even -for parts of your file system, like a mounted CD-ROM. - -If you do set C<$File::Find::dont_use_nlink> to 1, you will notice slow-downs. - -=item symlinks - -Be aware that the option to follow symbolic links can be dangerous. -Depending on the structure of the directory tree (including symbolic -links to directories) you might traverse a given (physical) directory -more than once (only if C<follow_fast> is in effect). -Furthermore, deleting or changing files in a symbolically linked directory -might cause very unpleasant surprises, since you delete or change files -in an unknown directory. - -=back - -=head1 BUGS AND CAVEATS - -Despite the name of the C<finddepth()> function, both C<find()> and -C<finddepth()> perform a depth-first search of the directory -hierarchy. - -=head1 HISTORY - -File::Find used to produce incorrect results if called recursively. -During the development of perl 5.8 this bug was fixed. -The first fixed version of File::Find was 1.01. - -=head1 SEE ALSO - -find, find2perl. - -=cut - our @ISA = qw(Exporter); our @EXPORT = qw(find finddepth); @@ -469,6 +126,7 @@ sub is_tainted_pp { sub _find_opt { my $wanted = shift; + return unless @_; die "invalid top directory" unless defined $_[0]; # This function must local()ize everything because callbacks may @@ -763,9 +421,9 @@ sub _find_dir($$$) { # This dir has subdirectories. $subcount = $nlink - 2; - # HACK: insert directories at this position. so as to preserve - # the user pre-processed ordering of files. - # EG: directory traversal is in user sorted order, not at random. + # HACK: insert directories at this position, so as to preserve + # the user pre-processed ordering of files (thus ensuring + # directory traversal is in user sorted order, not at random). my $stack_top = @Stack; for my $FN (@filenames) { @@ -1055,21 +713,42 @@ sub _find_dir_symlnk($$$) { sub wrap_wanted { my $wanted = shift; if ( ref($wanted) eq 'HASH' ) { + # RT #122547 + my %valid_options = map {$_ => 1} qw( + wanted + bydepth + preprocess + postprocess + follow + follow_fast + follow_skip + dangling_symlinks + no_chdir + untaint + untaint_pattern + untaint_skip + ); + my @invalid_options = (); + for my $v (keys %{$wanted}) { + push @invalid_options, $v unless exists $valid_options{$v}; + } + warn "Invalid option(s): @invalid_options" if @invalid_options; + unless( exists $wanted->{wanted} and ref( $wanted->{wanted} ) eq 'CODE' ) { die 'no &wanted subroutine given'; } - if ( $wanted->{follow} || $wanted->{follow_fast}) { - $wanted->{follow_skip} = 1 unless defined $wanted->{follow_skip}; - } - if ( $wanted->{untaint} ) { - $wanted->{untaint_pattern} = $File::Find::untaint_pattern - unless defined $wanted->{untaint_pattern}; - $wanted->{untaint_skip} = 0 unless defined $wanted->{untaint_skip}; - } - return $wanted; + if ( $wanted->{follow} || $wanted->{follow_fast}) { + $wanted->{follow_skip} = 1 unless defined $wanted->{follow_skip}; + } + if ( $wanted->{untaint} ) { + $wanted->{untaint_pattern} = $File::Find::untaint_pattern + unless defined $wanted->{untaint_pattern}; + $wanted->{untaint_skip} = 0 unless defined $wanted->{untaint_skip}; + } + return $wanted; } elsif( ref( $wanted ) eq 'CODE' ) { - return { wanted => $wanted }; + return { wanted => $wanted }; } else { die 'no &wanted subroutine given'; @@ -1094,7 +773,7 @@ $File::Find::untaint_pattern = qr|^([-+@\w./]+)$|; # These are hard-coded for now, but may move to hint files. if ($^O eq 'VMS') { $Is_VMS = 1; - $File::Find::dont_use_nlink = 1; + $File::Find::dont_use_nlink = 1; } elsif ($^O eq 'MSWin32') { $Is_Win32 = 1; @@ -1111,7 +790,7 @@ $File::Find::dont_use_nlink = 1 # Set dont_use_nlink in your hint file if your system's stat doesn't # report the number of links in a directory as an indication # of the number of files. -# See, e.g. hints/machten.sh for MachTen 2.2. +# See e.g. hints/haiku.sh for Haiku. unless ($File::Find::dont_use_nlink) { require Config; $File::Find::dont_use_nlink = 1 if ($Config::Config{'dont_use_nlink'}); @@ -1127,3 +806,344 @@ unless ($File::Find::dont_use_nlink) { } 1; + +__END__ + +=head1 NAME + +File::Find - Traverse a directory tree. + +=head1 SYNOPSIS + + use File::Find; + find(\&wanted, @directories_to_search); + sub wanted { ... } + + use File::Find; + finddepth(\&wanted, @directories_to_search); + sub wanted { ... } + + use File::Find; + find({ wanted => \&process, follow => 1 }, '.'); + +=head1 DESCRIPTION + +These are functions for searching through directory trees doing work +on each file found similar to the Unix I<find> command. File::Find +exports two functions, C<find> and C<finddepth>. They work similarly +but have subtle differences. + +=over 4 + +=item B<find> + + find(\&wanted, @directories); + find(\%options, @directories); + +C<find()> does a depth-first search over the given C<@directories> in +the order they are given. For each file or directory found, it calls +the C<&wanted> subroutine. (See below for details on how to use the +C<&wanted> function). Additionally, for each directory found, it will +C<chdir()> into that directory and continue the search, invoking the +C<&wanted> function on each file or subdirectory in the directory. + +=item B<finddepth> + + finddepth(\&wanted, @directories); + finddepth(\%options, @directories); + +C<finddepth()> works just like C<find()> except that it invokes the +C<&wanted> function for a directory I<after> invoking it for the +directory's contents. It does a postorder traversal instead of a +preorder traversal, working from the bottom of the directory tree up +where C<find()> works from the top of the tree down. + +=back + +=head2 %options + +The first argument to C<find()> is either a code reference to your +C<&wanted> function, or a hash reference describing the operations +to be performed for each file. The +code reference is described in L</The wanted function> below. + +Here are the possible keys for the hash: + +=over 3 + +=item C<wanted> + +The value should be a code reference. This code reference is +described in L</The wanted function> below. The C<&wanted> subroutine is +mandatory. + +=item C<bydepth> + +Reports the name of a directory only AFTER all its entries +have been reported. Entry point C<finddepth()> is a shortcut for +specifying C<< { bydepth => 1 } >> in the first argument of C<find()>. + +=item C<preprocess> + +The value should be a code reference. This code reference is used to +preprocess the current directory. The name of the currently processed +directory is in C<$File::Find::dir>. Your preprocessing function is +called after C<readdir()>, but before the loop that calls the C<wanted()> +function. It is called with a list of strings (actually file/directory +names) and is expected to return a list of strings. The code can be +used to sort the file/directory names alphabetically, numerically, +or to filter out directory entries based on their name alone. When +I<follow> or I<follow_fast> are in effect, C<preprocess> is a no-op. + +=item C<postprocess> + +The value should be a code reference. It is invoked just before leaving +the currently processed directory. It is called in void context with no +arguments. The name of the current directory is in C<$File::Find::dir>. This +hook is handy for summarizing a directory, such as calculating its disk +usage. When I<follow> or I<follow_fast> are in effect, C<postprocess> is a +no-op. + +=item C<follow> + +Causes symbolic links to be followed. Since directory trees with symbolic +links (followed) may contain files more than once and may even have +cycles, a hash has to be built up with an entry for each file. +This might be expensive both in space and time for a large +directory tree. See L</follow_fast> and L</follow_skip> below. +If either I<follow> or I<follow_fast> is in effect: + +=over 6 + +=item * + +It is guaranteed that an I<lstat> has been called before the user's +C<wanted()> function is called. This enables fast file checks involving C<_>. +Note that this guarantee no longer holds if I<follow> or I<follow_fast> +are not set. + +=item * + +There is a variable C<$File::Find::fullname> which holds the absolute +pathname of the file with all symbolic links resolved. If the link is +a dangling symbolic link, then fullname will be set to C<undef>. + +=back + +This is a no-op on Win32. + +=item C<follow_fast> + +This is similar to I<follow> except that it may report some files more +than once. It does detect cycles, however. Since only symbolic links +have to be hashed, this is much cheaper both in space and time. If +processing a file more than once (by the user's C<wanted()> function) +is worse than just taking time, the option I<follow> should be used. + +This is also a no-op on Win32. + +=item C<follow_skip> + +C<follow_skip==1>, which is the default, causes all files which are +neither directories nor symbolic links to be ignored if they are about +to be processed a second time. If a directory or a symbolic link +are about to be processed a second time, File::Find dies. + +C<follow_skip==0> causes File::Find to die if any file is about to be +processed a second time. + +C<follow_skip==2> causes File::Find to ignore any duplicate files and +directories but to proceed normally otherwise. + +=item C<dangling_symlinks> + +Specifies what to do with symbolic links whose target doesn't exist. +If true and a code reference, will be called with the symbolic link +name and the directory it lives in as arguments. Otherwise, if true +and warnings are on, a warning of the form C<"symbolic_link_name is a dangling +symbolic link\n"> will be issued. If false, the dangling symbolic link +will be silently ignored. + +=item C<no_chdir> + +Does not C<chdir()> to each directory as it recurses. The C<wanted()> +function will need to be aware of this, of course. In this case, +C<$_> will be the same as C<$File::Find::name>. + +=item C<untaint> + +If find is used in L<taint-mode|perlsec/Taint mode> (-T command line switch or +if EUID != UID or if EGID != GID), then internally directory names have to be +untainted before they can be C<chdir>'d to. Therefore they are checked against +a regular expression I<untaint_pattern>. Note that all names passed to the +user's C<wanted()> function are still tainted. If this option is used while not +in taint-mode, C<untaint> is a no-op. + +=item C<untaint_pattern> + +See above. This should be set using the C<qr> quoting operator. +The default is set to C<qr|^([-+@\w./]+)$|>. +Note that the parentheses are vital. + +=item C<untaint_skip> + +If set, a directory which fails the I<untaint_pattern> is skipped, +including all its sub-directories. The default is to C<die> in such a case. + +=back + +=head2 The wanted function + +The C<wanted()> function does whatever verifications you want on +each file and directory. Note that despite its name, the C<wanted()> +function is a generic callback function, and does B<not> tell +File::Find if a file is "wanted" or not. In fact, its return value +is ignored. + +The wanted function takes no arguments but rather does its work +through a collection of variables. + +=over 4 + +=item C<$File::Find::dir> is the current directory name, + +=item C<$_> is the current filename within that directory + +=item C<$File::Find::name> is the complete pathname to the file. + +=back + +The above variables have all been localized and may be changed without +affecting data outside of the wanted function. + +For example, when examining the file F</some/path/foo.ext> you will have: + + $File::Find::dir = /some/path/ + $_ = foo.ext + $File::Find::name = /some/path/foo.ext + +You are chdir()'d to C<$File::Find::dir> when the function is called, +unless C<no_chdir> was specified. Note that when changing to +directories is in effect, the root directory (F</>) is a somewhat +special case inasmuch as the concatenation of C<$File::Find::dir>, +C<'/'> and C<$_> is not literally equal to C<$File::Find::name>. The +table below summarizes all variants: + + $File::Find::name $File::Find::dir $_ + default / / . + no_chdir=>0 /etc / etc + /etc/x /etc x + + no_chdir=>1 / / / + /etc / /etc + /etc/x /etc /etc/x + + +When C<follow> or C<follow_fast> are in effect, there is +also a C<$File::Find::fullname>. The function may set +C<$File::Find::prune> to prune the tree unless C<bydepth> was +specified. Unless C<follow> or C<follow_fast> is specified, for +compatibility reasons (find.pl, find2perl) there are in addition the +following globals available: C<$File::Find::topdir>, +C<$File::Find::topdev>, C<$File::Find::topino>, +C<$File::Find::topmode> and C<$File::Find::topnlink>. + +This library is useful for the C<find2perl> tool (distributed as part of the +App-find2perl CPAN distribution), which when fed, + + find2perl / -name .nfs\* -mtime +7 \ + -exec rm -f {} \; -o -fstype nfs -prune + +produces something like: + + sub wanted { + /^\.nfs.*\z/s && + (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_)) && + int(-M _) > 7 && + unlink($_) + || + ($nlink || (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_))) && + $dev < 0 && + ($File::Find::prune = 1); + } + +Notice the C<_> in the above C<int(-M _)>: the C<_> is a magical +filehandle that caches the information from the preceding +C<stat()>, C<lstat()>, or filetest. + +Here's another interesting wanted function. It will find all symbolic +links that don't resolve: + + sub wanted { + -l && !-e && print "bogus link: $File::Find::name\n"; + } + +Note that you may mix directories and (non-directory) files in the list of +directories to be searched by the C<wanted()> function. + + find(\&wanted, "./foo", "./bar", "./baz/epsilon"); + +In the example above, no file in F<./baz/> other than F<./baz/epsilon> will be +evaluated by C<wanted()>. + +See also the script C<pfind> on CPAN for a nice application of this +module. + +=head1 WARNINGS + +If you run your program with the C<-w> switch, or if you use the +C<warnings> pragma, File::Find will report warnings for several weird +situations. You can disable these warnings by putting the statement + + no warnings 'File::Find'; + +in the appropriate scope. See L<warnings> for more info about lexical +warnings. + +=head1 CAVEAT + +=over 2 + +=item $dont_use_nlink + +You can set the variable C<$File::Find::dont_use_nlink> to 1 if you want to +force File::Find to always stat directories. This was used for file systems +that do not have an C<nlink> count matching the number of sub-directories. +Examples are ISO-9660 (CD-ROM), AFS, HPFS (OS/2 file system), FAT (DOS file +system) and a couple of others. + +You shouldn't need to set this variable, since File::Find should now detect +such file systems on-the-fly and switch itself to using stat. This works even +for parts of your file system, like a mounted CD-ROM. + +If you do set C<$File::Find::dont_use_nlink> to 1, you will notice slow-downs. + +=item symlinks + +Be aware that the option to follow symbolic links can be dangerous. +Depending on the structure of the directory tree (including symbolic +links to directories) you might traverse a given (physical) directory +more than once (only if C<follow_fast> is in effect). +Furthermore, deleting or changing files in a symbolically linked directory +might cause very unpleasant surprises, since you delete or change files +in an unknown directory. + +=back + +=head1 BUGS AND CAVEATS + +Despite the name of the C<finddepth()> function, both C<find()> and +C<finddepth()> perform a depth-first search of the directory +hierarchy. + +=head1 HISTORY + +File::Find used to produce incorrect results if called recursively. +During the development of perl 5.8 this bug was fixed. +The first fixed version of File::Find was 1.01. + +=head1 SEE ALSO + +L<find(1)>, find2perl. + +=cut diff --git a/gnu/usr.bin/perl/ext/File-Find/t/find.t b/gnu/usr.bin/perl/ext/File-Find/t/find.t index 4b52f1e8abc..b532752a5a2 100644 --- a/gnu/usr.bin/perl/ext/File-Find/t/find.t +++ b/gnu/usr.bin/perl/ext/File-Find/t/find.t @@ -24,7 +24,7 @@ BEGIN { } my $symlink_exists = eval { symlink("",""); 1 }; -my $test_count = 102; +my $test_count = 111; $test_count += 127 if $symlink_exists; $test_count += 26 if $^O eq 'MSWin32'; $test_count += 2 if $^O eq 'MSWin32' and $symlink_exists; @@ -66,6 +66,16 @@ my $orig_dir = cwd(); cleanup(); ##### Sanity checks ##### +# Do find() and finddepth() work correctly with an empty list of +# directories? +{ + ok(eval { find(\&noop_wanted); 1 }, + "'find' successfully returned for an empty list of directories"); + + ok(eval { finddepth(\&noop_wanted); 1 }, + "'finddepth' successfully returned for an empty list of directories"); +} + # Do find() and finddepth() work correctly in the directory # from which we start? (Test presumes the presence of 'taint.t' in same # directory as this test file.) @@ -80,6 +90,46 @@ finddepth({wanted => sub { ++$::count_taint if $_ eq 'taint.t'; } }, File::Spec->curdir); is($::count_taint, 1, "'finddepth' found exactly 1 file named 'taint.t'"); +##### RT #122547 ##### +# Do find() and finddepth() correctly warn on invalid options? +{ + my $bad_option = 'foobar'; + my $second_bad_option = 'really_foobar'; + + $::count_taint = 0; + local $SIG{__WARN__} = sub { $warn_msg = $_[0]; }; + { + find( + { + wanted => sub { ++$::count_taint if $_ eq 'taint.t'; }, + $bad_option => undef, + }, + File::Spec->curdir + ); + }; + like($warn_msg, qr/Invalid option/s, "Got warning for invalid option"); + like($warn_msg, qr/$bad_option/s, "Got warning for $bad_option"); + is($::count_taint, 1, "count_taint incremented"); + undef $warn_msg; + + $::count_taint = 0; + { + finddepth( + { + wanted => sub { ++$::count_taint if $_ eq 'taint.t'; }, + $bad_option => undef, + $second_bad_option => undef, + }, + File::Spec->curdir + ); + }; + like($warn_msg, qr/Invalid option/s, "Got warning for invalid option"); + like($warn_msg, qr/$bad_option/s, "Got warning for $bad_option"); + like($warn_msg, qr/$second_bad_option/s, "Got warning for $second_bad_option"); + is($::count_taint, 1, "count_taint incremented"); + undef $warn_msg; +} + my $FastFileTests_OK = 0; sub cleanup { diff --git a/gnu/usr.bin/perl/ext/File-Glob/Glob.pm b/gnu/usr.bin/perl/ext/File-Glob/Glob.pm index 2b39dce6a8e..c0b5a4720d9 100644 --- a/gnu/usr.bin/perl/ext/File-Glob/Glob.pm +++ b/gnu/usr.bin/perl/ext/File-Glob/Glob.pm @@ -37,7 +37,7 @@ pop @{$EXPORT_TAGS{bsd_glob}}; # no "glob" @EXPORT_OK = (@{$EXPORT_TAGS{'glob'}}, 'csh_glob'); -$VERSION = '1.23'; +$VERSION = '1.26'; sub import { require Exporter; @@ -363,35 +363,47 @@ E<lt>gsar@activestate.comE<gt>, and Thomas Wegner E<lt>wegner_thomas@yahoo.comE<gt>. The C glob code has the following copyright: - Copyright (c) 1989, 1993 The Regents of the University of California. - All rights reserved. - - This code is derived from software contributed to Berkeley by - Guido van Rossum. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - 3. Neither the name of the University nor the names of its contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS "AS IS" AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - SUCH DAMAGE. +Copyright (c) 1989, 1993 The Regents of the University of California. +All rights reserved. + +This code is derived from software contributed to Berkeley by +Guido van Rossum. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +=over 4 + +=item 1. + +Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. + +=item 2. + +Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +=item 3. + +Neither the name of the University nor the names of its contributors +may be used to endorse or promote products derived from this software +without specific prior written permission. + +=back + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. =cut diff --git a/gnu/usr.bin/perl/ext/File-Glob/Glob.xs b/gnu/usr.bin/perl/ext/File-Glob/Glob.xs index 99d22f6af3e..e0a36814e09 100644 --- a/gnu/usr.bin/perl/ext/File-Glob/Glob.xs +++ b/gnu/usr.bin/perl/ext/File-Glob/Glob.xs @@ -153,8 +153,8 @@ csh_glob(pTHX_ AV *entries, const char *pat, STRLEN len, bool is_utf8) const char *s = NULL; const char *piece = NULL; SV *word = NULL; - int const flags = - (int)SvIV(get_sv("File::Glob::DEFAULT_FLAGS", GV_ADD)); + SV *flags_sv = get_sv("File::Glob::DEFAULT_FLAGS", GV_ADD); + int const flags = (int)SvIV(flags_sv); U32 const gimme = GIMME_V; patend = pat + len; @@ -308,8 +308,8 @@ static bool doglob_iter_wrapper(pTHX_ AV *entries, const char *pattern, STRLEN len, bool is_utf8) { dSP; - int const flags = - (int)SvIV(get_sv("File::Glob::DEFAULT_FLAGS", GV_ADD)); + SV * flags_sv = get_sv("File::Glob::DEFAULT_FLAGS", GV_ADD); + int const flags = (int)SvIV(flags_sv); PERL_UNUSED_VAR(len); /* we use \0 termination instead */ /* XXX we currently just use the underlying bytes of the passed SV. @@ -375,7 +375,8 @@ PPCODE: /* remove unsupported flags */ flags &= ~(GLOB_APPEND | GLOB_DOOFFS | GLOB_ALTDIRFUNC | GLOB_MAGCHAR); } else { - flags = (int) SvIV(get_sv("File::Glob::DEFAULT_FLAGS", GV_ADD)); + SV * flags_sv = get_sv("File::Glob::DEFAULT_FLAGS", GV_ADD); + flags = (int)SvIV(flags_sv); } PUTBACK; diff --git a/gnu/usr.bin/perl/ext/File-Glob/bsd_glob.c b/gnu/usr.bin/perl/ext/File-Glob/bsd_glob.c index 2ba0d494071..821ef200ad6 100644 --- a/gnu/usr.bin/perl/ext/File-Glob/bsd_glob.c +++ b/gnu/usr.bin/perl/ext/File-Glob/bsd_glob.c @@ -602,6 +602,7 @@ glob0(const Char *pattern, glob_t *pglob) return(globextend(qpat, pglob, &limit)); } else if (!(pglob->gl_flags & GLOB_NOSORT)) + if (pglob->gl_pathv) qsort(pglob->gl_pathv + pglob->gl_offs + oldpathc, pglob->gl_pathc - oldpathc, sizeof(char *), (pglob->gl_flags & (GLOB_ALPHASORT|GLOB_NOCASE)) diff --git a/gnu/usr.bin/perl/ext/File-Glob/t/rt114984.t b/gnu/usr.bin/perl/ext/File-Glob/t/rt114984.t index 285bb70e957..43e90d7508c 100644 --- a/gnu/usr.bin/perl/ext/File-Glob/t/rt114984.t +++ b/gnu/usr.bin/perl/ext/File-Glob/t/rt114984.t @@ -16,16 +16,26 @@ my @mp = (1000..1205); my $path = tempdir uc cleanup => 1; +my $md = 0; +my $mp = 0; + foreach (@md) { - open(my $f, ">", catfile $path, "md_$_.dat"); - close $f; + if (open(my $f, ">", catfile $path, "md_$_.dat")) { + $md++; + close $f; + } } foreach (@mp) { - open(my $f, ">", catfile $path, "mp_$_.dat"); - close $f; + if (open(my $f, ">", catfile $path, "mp_$_.dat")) { + $mp++; + close $f; + } +} +my @b = glob(qq{$path/mp_[0123456789]*.dat $path/md_[0123456789]*.dat}); +if ($md+$mp < @md+@mp) { + warn sprintf("$0: expected to create %d files, created only %d (path $path)\n", + @md+@mp, $md+$mp); } -my @b = glob(qq{$path/mp_[0123456789]*.dat - $path/md_[0123456789]*.dat}); -is scalar(@b), @md+@mp, +is scalar(@b), $md+$mp, 'File::Glob extends the stack when returning a long list'; diff --git a/gnu/usr.bin/perl/ext/Hash-Util-FieldHash/FieldHash.xs b/gnu/usr.bin/perl/ext/Hash-Util-FieldHash/FieldHash.xs index 327b8200808..2fcb612525a 100644 --- a/gnu/usr.bin/perl/ext/Hash-Util-FieldHash/FieldHash.xs +++ b/gnu/usr.bin/perl/ext/Hash-Util-FieldHash/FieldHash.xs @@ -19,7 +19,7 @@ typedef struct { START_MY_CXT /* Inquire the object registry (a lexical hash) from perl */ -HV * +static HV * HUF_get_ob_reg(pTHX) { dSP; HV* ob_reg = NULL; @@ -47,7 +47,7 @@ HUF_get_ob_reg(pTHX) { #define HUF_CLONE 0 #define HUF_RESET -1 -void +static void HUF_global(pTHX_ I32 how) { if (how == HUF_INIT) { MY_CXT_INIT; @@ -66,7 +66,7 @@ HUF_global(pTHX_ I32 how) { /* definition of id transformation */ #define HUF_OBJ_ID(x) newSVuv(PTR2UV(x)) -SV * +static SV * HUF_obj_id(pTHX_ SV *obj) { SV *item = SvRV(obj); MAGIC *mg; @@ -94,7 +94,7 @@ HUF_obj_id(pTHX_ SV *obj) { } /* set up uvar magic for any sv */ -void +static void HUF_add_uvar_magic( pTHX_ SV* sv, /* the sv to enchant, visible to get/set */ @@ -111,7 +111,7 @@ HUF_add_uvar_magic( } /* Fetch the data container of a trigger */ -AV * +static AV * HUF_get_trigger_content(pTHX_ SV *trigger) { MAGIC* mg; if (trigger && (mg = mg_find(trigger, PERL_MAGIC_uvar))) @@ -123,7 +123,7 @@ HUF_get_trigger_content(pTHX_ SV *trigger) { * the object's entry from the object registry. This function goes in * the uf_set field of the uvar magic of a trigger. */ -I32 HUF_destroy_obj(pTHX_ IV index, SV *trigger) { +static I32 HUF_destroy_obj(pTHX_ IV index, SV *trigger) { PERL_UNUSED_ARG(index); /* Do nothing if the weakref wasn't undef'd. Also don't bother * during global destruction. (MY_CXT.ob_reg is sometimes funny there) */ @@ -155,7 +155,7 @@ I32 HUF_destroy_obj(pTHX_ IV index, SV *trigger) { * object may * have to be deleted. The trigger is stored in the * object registry and is also deleted when the object expires. */ -SV * +static SV * HUF_new_trigger(pTHX_ SV *obj, SV *ob_id) { dMY_CXT; SV* trigger = sv_rvweaken(newRV_inc(SvRV(obj))); @@ -169,7 +169,7 @@ HUF_new_trigger(pTHX_ SV *obj, SV *ob_id) { } /* retrieve a trigger for obj if one exists, return NULL otherwise */ -SV * +static SV * HUF_ask_trigger(pTHX_ SV *ob_id) { dMY_CXT; HE* ent; @@ -178,16 +178,7 @@ HUF_ask_trigger(pTHX_ SV *ob_id) { return NULL; } -/* get the trigger for an object, creating it if necessary */ -SV * -HUF_get_trigger0(pTHX_ SV *obj, SV *ob_id) { - SV* trigger; - if (!(trigger = HUF_ask_trigger(aTHX_ ob_id))) - trigger = HUF_new_trigger(aTHX_ obj, ob_id); - return trigger; -} - -SV * +static SV * HUF_get_trigger(pTHX_ SV *obj, SV *ob_id) { SV* trigger = HUF_ask_trigger(aTHX_ ob_id); if (!trigger) @@ -198,7 +189,7 @@ HUF_get_trigger(pTHX_ SV *obj, SV *ob_id) { /* mark an object (trigger) as having been used with a field (a clenup-liability) */ -void +static void HUF_mark_field(pTHX_ SV *trigger, SV *field) { AV* cont = HUF_get_trigger_content(aTHX_ trigger); HV* field_tab = (HV*) *av_fetch(cont, 1, 0); @@ -213,7 +204,7 @@ HUF_mark_field(pTHX_ SV *trigger, SV *field) { /* The key exchange functions. They communicate with S_hv_magic_uvar_xkey * in hv.c */ -I32 HUF_watch_key_safe(pTHX_ IV action, SV* field) { +static I32 HUF_watch_key_safe(pTHX_ IV action, SV* field) { MAGIC* mg = mg_find(field, PERL_MAGIC_uvar); SV* keysv; if (mg && (keysv = mg->mg_obj)) { @@ -236,7 +227,7 @@ I32 HUF_watch_key_safe(pTHX_ IV action, SV* field) { return 0; } -I32 HUF_watch_key_id(pTHX_ IV action, SV* field) { +static I32 HUF_watch_key_id(pTHX_ IV action, SV* field) { MAGIC* mg = mg_find(field, PERL_MAGIC_uvar); SV* keysv; PERL_UNUSED_ARG(action); @@ -249,7 +240,7 @@ I32 HUF_watch_key_id(pTHX_ IV action, SV* field) { return 0; } -int HUF_func_2mode( I32(* val)(pTHX_ IV, SV*)) { +static int HUF_func_2mode( I32(* val)(pTHX_ IV, SV*)) { int ans = 0; if (val == &HUF_watch_key_id) ans = 1; @@ -258,7 +249,7 @@ int HUF_func_2mode( I32(* val)(pTHX_ IV, SV*)) { return(ans); } -I32(* HUF_mode_2func( int mode))(pTHX_ IV, SV*) { +static I32(* HUF_mode_2func( int mode))(pTHX_ IV, SV*) { I32(* ans)(pTHX_ IV, SV*) = NULL; switch (mode) { case 1: @@ -272,7 +263,7 @@ I32(* HUF_mode_2func( int mode))(pTHX_ IV, SV*) { } /* see if something is a field hash */ -int +static int HUF_get_status(pTHX_ HV *hash) { int ans = 0; if (hash && (SvTYPE(hash) == SVt_PVHV)) { @@ -291,7 +282,7 @@ HUF_get_status(pTHX_ HV *hash) { /* Thread support. These routines are called by CLONE (and nothing else) */ /* Fix entries for one object in all field hashes */ -void +static void HUF_fix_trigger(pTHX_ SV *trigger, SV *new_id) { AV* cont = HUF_get_trigger_content(aTHX_ trigger); HV* field_tab = (HV*) *av_fetch(cont, 1, 0); @@ -318,7 +309,7 @@ HUF_fix_trigger(pTHX_ SV *trigger, SV *new_id) { /* Go over object registry and fix all objects. Also fix the object * registry. */ -void +static void HUF_fix_objects(pTHX) { dMY_CXT; I32 i, len; diff --git a/gnu/usr.bin/perl/ext/Hash-Util-FieldHash/lib/Hash/Util/FieldHash.pm b/gnu/usr.bin/perl/ext/Hash-Util-FieldHash/lib/Hash/Util/FieldHash.pm index 2441491fa5c..0d0b7921c3c 100644 --- a/gnu/usr.bin/perl/ext/Hash-Util-FieldHash/lib/Hash/Util/FieldHash.pm +++ b/gnu/usr.bin/perl/ext/Hash-Util-FieldHash/lib/Hash/Util/FieldHash.pm @@ -5,7 +5,7 @@ use strict; use warnings; use Scalar::Util qw( reftype); -our $VERSION = '1.15'; +our $VERSION = '1.19'; require Exporter; our @ISA = qw(Exporter); @@ -103,7 +103,7 @@ Returns the reference address of a reference $obj. If $obj is not a reference, returns $obj. This function is a stand-in replacement for -L<Scalar::Util::refaddr|Scalar::Util/"$addr = refaddr( $ref )">, +L<Scalar::Util::refaddr|Scalar::Util/refaddr>, that is, it returns the reference address of its argument as a numeric value. The only difference is that C<refaddr()> returns C<undef> when given a diff --git a/gnu/usr.bin/perl/ext/Hash-Util-FieldHash/t/05_perlhook.t b/gnu/usr.bin/perl/ext/Hash-Util-FieldHash/t/05_perlhook.t index 92c6b7ac4fc..61d02ec6465 100755 --- a/gnu/usr.bin/perl/ext/Hash-Util-FieldHash/t/05_perlhook.t +++ b/gnu/usr.bin/perl/ext/Hash-Util-FieldHash/t/05_perlhook.t @@ -6,6 +6,13 @@ my $n_tests; use Hash::Util::FieldHash; use Scalar::Util qw( weaken); +sub numbers_first { # Sort helper: All digit entries sort in front of others + # Makes sorting portable across ASCII/EBCDIC + return $a cmp $b if ($a =~ /^\d+$/) == ($b =~ /^\d+$/); + return -1 if $a =~ /^\d+$/; + return 1; +} + # The functions in Hash::Util::FieldHash # _test_uvar_get, _test_uvar_get and _test_uvar_both @@ -108,7 +115,7 @@ use Scalar::Util qw( weaken); $h{ def} = 456; is( $counter, 2, "lvalue assign triggers"); - (@x) = sort %h; + (@x) = sort numbers_first %h; is( $counter, 2, "hash in list context doesn't trigger"); is( "@x", "123 456 abc def", "correct result"); @@ -121,14 +128,14 @@ use Scalar::Util qw( weaken); delete $h{ def}; is( $counter, 5, "good delete triggers"); - (@x) = sort %h; + (@x) = sort numbers_first %h; is( $counter, 5, "hash in list context doesn't trigger"); is( "@x", "123 abc", "correct result"); delete $h{ xyz}; is( $counter, 6, "bad delete triggers"); - (@x) = sort %h; + (@x) = sort numbers_first %h; is( $counter, 6, "hash in list context doesn't trigger"); is( "@x", "123 abc", "correct result"); @@ -138,7 +145,7 @@ use Scalar::Util qw( weaken); $x = $h{ xyz}; is( $counter, 8, "bad read triggers"); - (@x) = sort %h; + (@x) = sort numbers_first %h; is( $counter, 8, "hash in list context doesn't trigger"); is( "@x", "123 abc", "correct result"); diff --git a/gnu/usr.bin/perl/ext/Hash-Util/Changes b/gnu/usr.bin/perl/ext/Hash-Util/Changes index 06589b56ff1..ddef72cea6e 100644 --- a/gnu/usr.bin/perl/ext/Hash-Util/Changes +++ b/gnu/usr.bin/perl/ext/Hash-Util/Changes @@ -1,9 +1,12 @@ Revision history for Perl extension Hash::Util. -0.05 +0.17 + Add bucket_stats_formatted() as utility method to Hash::Util + Bug fixes to hash_stats() -Pre /ext version of the code. By Michael G Schwern <schwern@pobox.com> -on top of code by Nick Ing-Simmons and Jeffrey Friedl. +0.07 Sun Jun 11 21:24:15 CEST 2006 + - added front-end support for the new Hash::Util::FieldHash + (Anno Siegel) 0.06 Thu Mar 25 20:26:32 2004 - original XS version; created by h2xs 1.21 with options @@ -13,8 +16,8 @@ on top of code by Nick Ing-Simmons and Jeffrey Friedl. developed to support restricted hashes in Data::Dump::Streamer (shameless plug :-) +0.05 +Pre /ext version of the code. By Michael G Schwern <schwern@pobox.com> +on top of code by Nick Ing-Simmons and Jeffrey Friedl. -0.07 Sun Jun 11 21:24:15 CEST 2006 - - added front-end support for the new Hash::Util::FieldHash - (Anno Siegel) diff --git a/gnu/usr.bin/perl/ext/Hash-Util/Util.xs b/gnu/usr.bin/perl/ext/Hash-Util/Util.xs index 2758d69047f..9481dc7997b 100644 --- a/gnu/usr.bin/perl/ext/Hash-Util/Util.xs +++ b/gnu/usr.bin/perl/ext/Hash-Util/Util.xs @@ -70,17 +70,28 @@ hash_seed() void -hash_value(string) +hash_value(string,...) SV* string - PROTOTYPE: $ + PROTOTYPE: $;$ PPCODE: - STRLEN len; - char *pv; +{ UV uv; + STRLEN len; + char *pv= SvPV(string,len); + if (items<2) { + PERL_HASH(uv, pv, len); + } else { + STRLEN seedlen; + U8 *seedbuf= (U8 *)SvPV(ST(1),seedlen); + if ( seedlen < PERL_HASH_SEED_BYTES ) { + sv_dump(ST(1)); + Perl_croak(aTHX_ "seed len must be at least %d long only got %"UVuf" bytes", PERL_HASH_SEED_BYTES, (UV)seedlen); + } - pv= SvPV(string,len); - PERL_HASH(uv,pv,len); + PERL_HASH_WITH_SEED(seedbuf, uv, pv, len); + } XSRETURN_UV(uv); +} void hash_traversal_mask(rhv, ...) @@ -128,8 +139,13 @@ bucket_info(rhv) nothing (the empty list). */ + const HV * hv = NULL; if (SvROK(rhv) && SvTYPE(SvRV(rhv))==SVt_PVHV && !SvMAGICAL(SvRV(rhv))) { - const HV * const hv = (const HV *) SvRV(rhv); + hv = (const HV *) SvRV(rhv); + } else if (!SvOK(rhv)) { + hv = PL_strtab; + } + if (hv) { U32 max_bucket_index= HvMAX(hv); U32 total_keys= HvUSEDKEYS(hv); HE **bucket_array= HvARRAY(hv); @@ -183,8 +199,13 @@ bucket_array(rhv) * of the hash store, combined with regular remappings means that relative * order of keys changes each remap. */ + const HV * hv = NULL; if (SvROK(rhv) && SvTYPE(SvRV(rhv))==SVt_PVHV && !SvMAGICAL(SvRV(rhv))) { - const HV * const hv = (const HV *) SvRV(rhv); + hv = (const HV *) SvRV(rhv); + } else if (!SvOK(rhv)) { + hv = PL_strtab; + } + if (hv) { HE **he_ptr= HvARRAY(hv); if (!he_ptr) { XSRETURN(0); diff --git a/gnu/usr.bin/perl/ext/Hash-Util/lib/Hash/Util.pm b/gnu/usr.bin/perl/ext/Hash-Util/lib/Hash/Util.pm index 8ae25d14d97..a947b9a76ef 100644 --- a/gnu/usr.bin/perl/ext/Hash-Util/lib/Hash/Util.pm +++ b/gnu/usr.bin/perl/ext/Hash-Util/lib/Hash/Util.pm @@ -29,12 +29,13 @@ our @EXPORT_OK = qw( hidden_ref_keys legal_ref_keys hash_seed hash_value hv_store - bucket_stats bucket_info bucket_array + bucket_stats bucket_stats_formatted bucket_info bucket_array lock_hash_recurse unlock_hash_recurse + lock_hashref_recurse unlock_hashref_recurse hash_traversal_mask ); -our $VERSION = '0.16'; +our $VERSION = '0.19'; require XSLoader; XSLoader::load(); @@ -78,6 +79,7 @@ Hash::Util - A selection of general-utility hash subroutines hash_seed hash_value hv_store bucket_stats bucket_info bucket_array lock_hash_recurse unlock_hash_recurse + lock_hashref_recurse unlock_hashref_recurse hash_traversal_mask ); @@ -364,7 +366,7 @@ sub unlock_hashref_recurse { if (defined($type) and $type eq 'HASH') { unlock_hashref_recurse($value); } - Internals::SvREADONLY($value,1); + Internals::SvREADONLY($value,0); } unlock_ref_keys($hash); return $hash; @@ -523,21 +525,20 @@ See also bucket_stats() and bucket_array(). Returns a list of statistics about a hash. - my ($keys, buckets, $used, $utilization_ratio, $collision_pct, - $mean, $stddev, @length_counts) = bucket_info($hashref); - + my ($keys, $buckets, $used, $quality, $utilization_ratio, + $collision_pct, $mean, $stddev, @length_counts) + = bucket_stats($hashref); Fields are as follows: - 0: Number of keys in the hash 1: Number of buckets in the hash 2: Number of used buckets in the hash 3: Hash Quality Score 4: Percent of buckets used 5: Percent of keys which are in collision - 6: Average bucket length - 7: Standard Deviation of bucket lengths. + 6: Mean bucket length of occupied buckets + 7: Standard Deviation of bucket lengths of occupied buckets rest : list of counts, Kth element is the number of buckets with K keys in it. @@ -581,21 +582,128 @@ sub bucket_stats { my ($keys, $buckets, $used, @length_counts) = bucket_info($hash); my $sum; my $score; - for (0 .. $#length_counts) { + for (1 .. $#length_counts) { $sum += ($length_counts[$_] * $_); $score += $length_counts[$_] * ( $_ * ($_ + 1 ) / 2 ); } $score = $score / (( $keys / (2 * $buckets )) * ( $keys + ( 2 * $buckets ) - 1 )) if $keys; - my $mean= $sum/$buckets; - $sum= 0; - $sum += ($length_counts[$_] * (($_-$mean)**2)) for 0 .. $#length_counts; + my ($mean, $stddev)= (0, 0); + if ($used) { + $mean= $sum / $used; + $sum= 0; + $sum += ($length_counts[$_] * (($_-$mean)**2)) for 1 .. $#length_counts; - my $stddev= sqrt($sum/$buckets); + $stddev= sqrt($sum/$used); + } return $keys, $buckets, $used, $keys ? ($score, $used/$buckets, ($keys-$used)/$keys, $mean, $stddev, @length_counts) : (); } +=item B<bucket_stats_formatted> + + print bucket_stats_formatted($hashref); + +Return a formatted report of the information returned by bucket_stats(). +An example report looks like this: + + Keys: 50 Buckets: 33/64 Quality-Score: 1.01 (Good) + Utilized Buckets: 51.56% Optimal: 78.12% Keys In Collision: 34.00% + Chain Length - mean: 1.52 stddev: 0.66 + Buckets 64 [0000000000000000000000000000000111111111111111111122222222222333] + Len 0 Pct: 48.44 [###############################] + Len 1 Pct: 29.69 [###################] + Len 2 Pct: 17.19 [###########] + Len 3 Pct: 4.69 [###] + Keys 50 [11111111111111111111111111111111122222222222222333] + Pos 1 Pct: 66.00 [#################################] + Pos 2 Pct: 28.00 [##############] + Pos 3 Pct: 6.00 [###] + +The first set of stats gives some summary statistical information, +including the quality score translated into "Good", "Poor" and "Bad", +(score<=1.05, score<=1.2, score>1.2). See the documentation in +bucket_stats() for more details. + +The two sets of barcharts give stats and a visual indication of performance +of the hash. + +The first gives data on bucket chain lengths and provides insight on how +much work a fetch *miss* will take. In this case we have to inspect every item +in a bucket before we can be sure the item is not in the list. The performance +for an insert is equivalent to this case, as is a delete where the item +is not in the hash. + +The second gives data on how many keys are at each depth in the chain, and +gives an idea of how much work a fetch *hit* will take. The performance for +an update or delete of an item in the hash is equivalent to this case. + +Note that these statistics are summary only. Actual performance will depend +on real hit/miss ratios accessing the hash. If you are concerned by hit ratios +you are recommended to "oversize" your hash by using something like: + + keys(%hash)= keys(%hash) << $k; + +With $k chosen carefully, and likely to be a small number like 1 or 2. In +theory the larger the bucket array the less chance of collision. + +=cut + + +sub _bucket_stats_formatted_bars { + my ($total, $ary, $start_idx, $title, $row_title)= @_; + + my $return = ""; + my $max_width= $total > 64 ? 64 : $total; + my $bar_width= $max_width / $total; + + my $str= ""; + if ( @$ary < 10) { + for my $idx ($start_idx .. $#$ary) { + $str .= $idx x sprintf("%.0f", ($ary->[$idx] * $bar_width)); + } + } else { + $str= "-" x $max_width; + } + $return .= sprintf "%-7s %6d [%s]\n",$title, $total, $str; + + foreach my $idx ($start_idx .. $#$ary) { + $return .= sprintf "%-.3s %3d %6.2f%% %6d [%s]\n", + $row_title, + $idx, + $ary->[$idx] / $total * 100, + $ary->[$idx], + "#" x sprintf("%.0f", ($ary->[$idx] * $bar_width)), + ; + } + return $return; +} + +sub bucket_stats_formatted { + my ($hashref)= @_; + my ($keys, $buckets, $used, $score, $utilization_ratio, $collision_pct, + $mean, $stddev, @length_counts) = bucket_stats($hashref); + + my $return= sprintf "Keys: %d Buckets: %d/%d Quality-Score: %.2f (%s)\n" + . "Utilized Buckets: %.2f%% Optimal: %.2f%% Keys In Collision: %.2f%%\n" + . "Chain Length - mean: %.2f stddev: %.2f\n", + $keys, $used, $buckets, $score, $score <= 1.05 ? "Good" : $score < 1.2 ? "Poor" : "Bad", + $utilization_ratio * 100, + $keys/$buckets * 100, + $collision_pct * 100, + $mean, $stddev; + + my @key_depth; + $key_depth[$_]= $length_counts[$_] + ( $key_depth[$_+1] || 0 ) + for reverse 1 .. $#length_counts; + + if ($keys) { + $return .= _bucket_stats_formatted_bars($buckets, \@length_counts, 0, "Buckets", "Len"); + $return .= _bucket_stats_formatted_bars($keys, \@key_depth, 1, "Keys", "Pos"); + } + return $return +} + =item B<hv_store> my $sv = 0; diff --git a/gnu/usr.bin/perl/ext/Hash-Util/t/Util.t b/gnu/usr.bin/perl/ext/Hash-Util/t/Util.t index 2e9e3337e33..4a12fd1764f 100755 --- a/gnu/usr.bin/perl/ext/Hash-Util/t/Util.t +++ b/gnu/usr.bin/perl/ext/Hash-Util/t/Util.t @@ -13,6 +13,14 @@ BEGIN { use strict; use Test::More; + +sub numbers_first { # Sort helper: All digit entries sort in front of others + # Makes sorting portable across ASCII/EBCDIC + return $a cmp $b if ($a =~ /^\d+$/) == ($b =~ /^\d+$/); + return -1 if $a =~ /^\d+$/; + return 1; +} + my @Exported_Funcs; BEGIN { @Exported_Funcs = qw( @@ -36,8 +44,9 @@ BEGIN { hash_seed hash_value bucket_stats bucket_info bucket_array hv_store lock_hash_recurse unlock_hash_recurse + lock_hashref_recurse unlock_hashref_recurse ); - plan tests => 236 + @Exported_Funcs; + plan tests => 244 + @Exported_Funcs; use_ok 'Hash::Util', @Exported_Funcs; } foreach my $func (@Exported_Funcs) { @@ -427,9 +436,9 @@ ok(defined($hash_seed) && $hash_seed ne '', "hash_seed $hash_seed"); my %hash=(0..9); lock_keys(%hash,keys(%hash),'a'..'f'); ok(Internals::SvREADONLY(%hash),'lock_keys args DDS/t'); - my @hidden=sort(hidden_keys(%hash)); - my @legal=sort(legal_keys(%hash)); - my @keys=sort(keys(%hash)); + my @hidden=sort numbers_first hidden_keys(%hash); + my @legal=sort numbers_first legal_keys(%hash); + my @keys=sort numbers_first keys(%hash); is("@hidden","a b c d e f",'lock_keys() @hidden DDS/t 3'); is("@legal","0 2 4 6 8 a b c d e f",'lock_keys() @legal DDS/t 3'); is("@keys","0 2 4 6 8",'lock_keys() @keys'); @@ -452,9 +461,9 @@ ok(defined($hash_seed) && $hash_seed ne '', "hash_seed $hash_seed"); my %hash=(0..9); lock_ref_keys(\%hash,keys %hash,'a'..'f'); ok(Internals::SvREADONLY(%hash),'lock_ref_keys args DDS/t'); - my @hidden=sort(hidden_keys(%hash)); - my @legal=sort(legal_keys(%hash)); - my @keys=sort(keys(%hash)); + my @hidden=sort numbers_first hidden_keys(%hash); + my @legal=sort numbers_first legal_keys(%hash); + my @keys=sort numbers_first keys(%hash); is("@hidden","a b c d e f",'lock_ref_keys() @hidden DDS/t 2'); is("@legal","0 2 4 6 8 a b c d e f",'lock_ref_keys() @legal DDS/t 2'); is("@keys","0 2 4 6 8",'lock_ref_keys() @keys DDS/t 2'); @@ -463,9 +472,9 @@ ok(defined($hash_seed) && $hash_seed ne '', "hash_seed $hash_seed"); my %hash=(0..9); lock_ref_keys_plus(\%hash,'a'..'f'); ok(Internals::SvREADONLY(%hash),'lock_ref_keys_plus args DDS/t'); - my @hidden=sort(hidden_keys(%hash)); - my @legal=sort(legal_keys(%hash)); - my @keys=sort(keys(%hash)); + my @hidden=sort numbers_first hidden_keys(%hash); + my @legal=sort numbers_first legal_keys(%hash); + my @keys=sort numbers_first keys(%hash); is("@hidden","a b c d e f",'lock_ref_keys_plus() @hidden DDS/t'); is("@legal","0 2 4 6 8 a b c d e f",'lock_ref_keys_plus() @legal DDS/t'); is("@keys","0 2 4 6 8",'lock_ref_keys_plus() @keys DDS/t'); @@ -474,9 +483,9 @@ ok(defined($hash_seed) && $hash_seed ne '', "hash_seed $hash_seed"); my %hash=(0..9, 'a' => 'alpha'); lock_ref_keys_plus(\%hash,'a'..'f'); ok(Internals::SvREADONLY(%hash),'lock_ref_keys_plus args overlap'); - my @hidden=sort(hidden_keys(%hash)); - my @legal=sort(legal_keys(%hash)); - my @keys=sort(keys(%hash)); + my @hidden=sort numbers_first hidden_keys(%hash); + my @legal=sort numbers_first legal_keys(%hash); + my @keys=sort numbers_first keys(%hash); is("@hidden","b c d e f",'lock_ref_keys_plus() @hidden overlap'); is("@legal","0 2 4 6 8 a b c d e f",'lock_ref_keys_plus() @legal overlap'); is("@keys","0 2 4 6 8 a",'lock_ref_keys_plus() @keys overlap'); @@ -485,9 +494,9 @@ ok(defined($hash_seed) && $hash_seed ne '', "hash_seed $hash_seed"); my %hash=(0..9); lock_keys_plus(%hash,'a'..'f'); ok(Internals::SvREADONLY(%hash),'lock_keys_plus args DDS/t'); - my @hidden=sort(hidden_keys(%hash)); - my @legal=sort(legal_keys(%hash)); - my @keys=sort(keys(%hash)); + my @hidden=sort numbers_first hidden_keys(%hash); + my @legal=sort numbers_first legal_keys(%hash); + my @keys=sort numbers_first keys(%hash); is("@hidden","a b c d e f",'lock_keys_plus() @hidden DDS/t 3'); is("@legal","0 2 4 6 8 a b c d e f",'lock_keys_plus() @legal DDS/t 3'); is("@keys","0 2 4 6 8",'lock_keys_plus() @keys DDS/t 3'); @@ -496,9 +505,9 @@ ok(defined($hash_seed) && $hash_seed ne '', "hash_seed $hash_seed"); my %hash=(0..9, 'a' => 'alpha'); lock_keys_plus(%hash,'a'..'f'); ok(Internals::SvREADONLY(%hash),'lock_keys_plus args overlap non-ref'); - my @hidden=sort(hidden_keys(%hash)); - my @legal=sort(legal_keys(%hash)); - my @keys=sort(keys(%hash)); + my @hidden=sort numbers_first hidden_keys(%hash); + my @legal=sort numbers_first legal_keys(%hash); + my @keys=sort numbers_first keys(%hash); is("@hidden","b c d e f",'lock_keys_plus() @hidden overlap non-ref'); is("@legal","0 2 4 6 8 a b c d e f",'lock_keys_plus() @legal overlap non-ref'); is("@keys","0 2 4 6 8 a",'lock_keys_plus() @keys overlap non-ref'); @@ -522,6 +531,7 @@ ok(defined($hash_seed) && $hash_seed ne '', "hash_seed $hash_seed"); } { + # lock_hash_recurse / unlock_hash_recurse my %hash = ( a => 'alpha', b => [ qw( beta gamma delta ) ], @@ -541,6 +551,43 @@ ok(defined($hash_seed) && $hash_seed ne '', "hash_seed $hash_seed"); "unlock_hash_recurse(): top-level hash unlocked" ); ok( hash_unlocked(%{$hash{d}}), "unlock_hash_recurse(): element which is hashref unlocked" ); + { + local $@; + eval { $hash{d} = { theta => 'kappa' }; }; + ok(! $@, "No error; can assign to unlocked hash") + or diag($@); + } + ok( hash_unlocked(%{$hash{c}[1]}), + "unlock_hash_recurse(): element which is hashref in array ref not locked" ); +} + +{ + # lock_hashref_recurse / unlock_hashref_recurse + my %hash = ( + a => 'alpha', + b => [ qw( beta gamma delta ) ], + c => [ 'epsilon', { zeta => 'eta' }, ], + d => { theta => 'iota' }, + ); + Hash::Util::lock_hashref_recurse(\%hash); + ok( hash_locked(%hash), + "lock_hash_recurse(): top-level hash locked" ); + ok( hash_locked(%{$hash{d}}), + "lock_hash_recurse(): element which is hashref locked" ); + ok( ! hash_locked(%{$hash{c}[1]}), + "lock_hash_recurse(): element which is hashref in array ref not locked" ); + + Hash::Util::unlock_hashref_recurse(\%hash); + ok( hash_unlocked(%hash), + "unlock_hash_recurse(): top-level hash unlocked" ); + ok( hash_unlocked(%{$hash{d}}), + "unlock_hash_recurse(): element which is hashref unlocked" ); + { + local $@; + eval { $hash{d} = { theta => 'kappa' }; }; + ok(! $@, "No error; can assign to unlocked hash") + or diag($@); + } ok( hash_unlocked(%{$hash{c}[1]}), "unlock_hash_recurse(): element which is hashref in array ref not locked" ); } diff --git a/gnu/usr.bin/perl/ext/I18N-Langinfo/Langinfo.pm b/gnu/usr.bin/perl/ext/I18N-Langinfo/Langinfo.pm index 8bca1113058..033d8de1d7c 100644 --- a/gnu/usr.bin/perl/ext/I18N-Langinfo/Langinfo.pm +++ b/gnu/usr.bin/perl/ext/I18N-Langinfo/Langinfo.pm @@ -72,7 +72,7 @@ our @EXPORT_OK = qw( YESSTR ); -our $VERSION = '0.11'; +our $VERSION = '0.13'; XSLoader::load(); @@ -166,7 +166,7 @@ you can wrap the import in an eval like this: I18N::Langinfo->import(qw(langinfo CODESET)); $codeset = langinfo(CODESET()); # note the () }; - if (!$@) { ... failed ... } + if ($@) { ... failed ... } =head2 EXPORT diff --git a/gnu/usr.bin/perl/ext/I18N-Langinfo/Langinfo.xs b/gnu/usr.bin/perl/ext/I18N-Langinfo/Langinfo.xs index 8b1fd5a4ef0..582b7fa634c 100644 --- a/gnu/usr.bin/perl/ext/I18N-Langinfo/Langinfo.xs +++ b/gnu/usr.bin/perl/ext/I18N-Langinfo/Langinfo.xs @@ -23,7 +23,12 @@ langinfo(code) PROTOTYPE: _ CODE: #ifdef HAS_NL_LANGINFO - RETVAL = newSVpv(nl_langinfo(code), 0); + if (code < 0) { + SETERRNO(EINVAL, LIB_INVARG); + RETVAL = &PL_sv_undef; + } else { + RETVAL = newSVpv(nl_langinfo(code), 0); + } #else croak("nl_langinfo() not implemented on this architecture"); #endif diff --git a/gnu/usr.bin/perl/ext/IPC-Open3/lib/IPC/Open3.pm b/gnu/usr.bin/perl/ext/IPC-Open3/lib/IPC/Open3.pm index c8620b77ae7..e5924a30a65 100644 --- a/gnu/usr.bin/perl/ext/IPC-Open3/lib/IPC/Open3.pm +++ b/gnu/usr.bin/perl/ext/IPC-Open3/lib/IPC/Open3.pm @@ -9,7 +9,7 @@ require Exporter; use Carp; use Symbol qw(gensym qualify); -$VERSION = '1.16'; +$VERSION = '1.20'; @ISA = qw(Exporter); @EXPORT = qw(open3); @@ -246,6 +246,7 @@ sub _open3 { # A tie in the parent should not be allowed to cause problems. untie *STDIN; untie *STDOUT; + untie *STDERR; close $stat_r; require Fcntl; @@ -279,7 +280,7 @@ sub _open3 { return 1 if ($_[0] eq '-'); exec @_ or do { local($")=(" "); - croak "$Me: exec of @_ failed"; + croak "$Me: exec of @_ failed: $!"; }; } and do { close $stat_w; @@ -361,7 +362,7 @@ sub open3 { sub spawn_with_handles { my $fds = shift; # Fields: handle, mode, open_as my $close_in_child = shift; - my ($fd, $pid, @saved_fh, $saved, %saved, @errs); + my ($fd, %saved, @errs); foreach $fd (@$fds) { $fd->{tmp_copy} = IO::Handle->new_from_fd($fd->{handle}, $fd->{mode}); @@ -372,10 +373,12 @@ sub spawn_with_handles { unless eval { $fd->{handle}->isa('IO::Handle') } ; # If some of handles to redirect-to coincide with handles to # redirect, we need to use saved variants: - $fd->{handle}->fdopen(defined fileno $fd->{open_as} - ? $saved{fileno $fd->{open_as}} || $fd->{open_as} - : $fd->{open_as}, - $fd->{mode}); + my $open_as = $fd->{open_as}; + my $fileno = fileno($open_as); + $fd->{handle}->fdopen(defined($fileno) + ? $saved{$fileno} || $open_as + : $open_as, + $fd->{mode}); } unless ($^O eq 'MSWin32') { require Fcntl; @@ -387,6 +390,7 @@ sub spawn_with_handles { } } + my $pid; unless (@errs) { if (FORCE_DEBUG_SPAWN) { pipe my $r, my $w or die "Pipe failed: $!"; @@ -408,7 +412,11 @@ sub spawn_with_handles { } else { $pid = eval { system 1, @_ }; # 1 == P_NOWAIT } - push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!" if !$pid || $pid < 0; + if($@) { + push @errs, "IO::Pipe: Can't spawn-NOWAIT: $@"; + } elsif(!$pid || $pid < 0) { + push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!"; + } } # Do this in reverse, so that STDERR is restored first: diff --git a/gnu/usr.bin/perl/ext/IPC-Open3/t/IPC-Open3.t b/gnu/usr.bin/perl/ext/IPC-Open3/t/IPC-Open3.t index 6ab519d002a..25cfdfb6aee 100755 --- a/gnu/usr.bin/perl/ext/IPC-Open3/t/IPC-Open3.t +++ b/gnu/usr.bin/perl/ext/IPC-Open3/t/IPC-Open3.t @@ -14,7 +14,7 @@ BEGIN { } use strict; -use Test::More tests => 38; +use Test::More tests => 45; use IO::Handle; use IPC::Open3; @@ -165,6 +165,46 @@ $pid = eval { open3 'WRITE', '', 'ERROR', '/non/existent/program'; }; like($@, qr/^open3: Modification of a read-only value attempted at /, 'open3 faults read-only parameters correctly') or do {waitpid $pid, 0}; +package NoFetch; + +my $fetchcount = 1; + +sub TIESCALAR { + my $class = shift; + my $instance = shift || undef; + return bless \$instance => $class; +} + +sub FETCH { + my $cmd; #dont let "@args = @DB::args;" in Carp::caller_info fire this die + #fetchcount may need to be increased to 2 if this code is being stepped with + #a perl debugger + if($fetchcount == 1 && (caller(1))[3] ne 'Carp::caller_info') { + #Carp croak reports the errors as being in IPC-Open3.t, so it is + #unacceptable for testing where the FETCH failure occured, we dont want + #it failing in a $foo = $_[0]; #later# system($foo), where the failure + #is supposed to be triggered in the inner most syscall, aka system() + my ($package, $filename, $line, $subroutine) = caller(2); + + die("FETCH not allowed in ".((caller(1))[3])." in ".((caller(2))[3])."\n"); + } else { + $fetchcount++; + return tie($cmd, 'NoFetch'); + } +} + +package main; + +{ + my $cmd; + tie($cmd, 'NoFetch'); + + $pid = eval { open3 'WRITE', 'READ', 'ERROR', $cmd; }; + like($@, qr/^(?:open3: IO::Pipe: Can't spawn-NOWAIT: FETCH not allowed in \(eval\) (?x: + )in IPC::Open3::spawn_with_handles|FETCH not allowed in \(eval\) in IPC::Open3::_open3)/, + 'dieing inside Tied arg propagates correctly') or do {waitpid $pid, 0}; +} + foreach my $handle (qw (DUMMY STDIN STDOUT STDERR)) { local $::{$handle}; my $out = IO::Handle->new(); @@ -187,3 +227,34 @@ foreach my $handle (qw (DUMMY STDIN STDOUT STDERR)) { } waitpid $pid, 0; } + +# Test that tied STDIN, STDOUT, and STDERR do not cause open3 any discomfort. +# In particular, tied STDERR used to be able to prevent open3 from working +# correctly. RT #119843. +SKIP: { + if (&IPC::Open3::DO_SPAWN) { + skip "Calling open3 with tied filehandles does not work here", 6 + } + + { # This just throws things out + package My::Tied::FH; + sub TIEHANDLE { bless \my $self } + sub PRINT {} + # Note the absence of OPEN and FILENO + } + my $message = "japh\n"; + foreach my $handle (*STDIN, *STDOUT, *STDERR) { + tie $handle, 'My::Tied::FH'; + my ($in, $out); + my $pid = eval { + open3 $in, $out, undef, $perl, '-ne', 'print'; + }; + is($@, '', "no errors calling open3 with tied $handle"); + print $in $message; + close $in; + my $japh = <$out>; + waitpid $pid, 0; + is($japh, $message, "read input correctly"); + untie $handle; + } +} diff --git a/gnu/usr.bin/perl/ext/NDBM_File/Makefile.PL b/gnu/usr.bin/perl/ext/NDBM_File/Makefile.PL index a48c039fa88..a8adbf01218 100644 --- a/gnu/usr.bin/perl/ext/NDBM_File/Makefile.PL +++ b/gnu/usr.bin/perl/ext/NDBM_File/Makefile.PL @@ -1,7 +1,7 @@ use ExtUtils::MakeMaker; WriteMakefile( NAME => 'NDBM_File', - #LIBS => ["-L/usr/local/lib -lndbm", "-ldbm -lucb"], + LIBS => ["-L/usr/local/lib -lndbm", "-ldbm -lucb"], XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'NDBM_File.pm', INC => ($^O eq "MacOS" ? "-i ::::db:include" : "") diff --git a/gnu/usr.bin/perl/ext/NDBM_File/NDBM_File.pm b/gnu/usr.bin/perl/ext/NDBM_File/NDBM_File.pm index 8b9a4539792..fc250ec840b 100644 --- a/gnu/usr.bin/perl/ext/NDBM_File/NDBM_File.pm +++ b/gnu/usr.bin/perl/ext/NDBM_File/NDBM_File.pm @@ -7,7 +7,7 @@ require Tie::Hash; require XSLoader; our @ISA = qw(Tie::Hash); -our $VERSION = "1.12"; +our $VERSION = "1.14"; XSLoader::load(); diff --git a/gnu/usr.bin/perl/ext/NDBM_File/NDBM_File.xs b/gnu/usr.bin/perl/ext/NDBM_File/NDBM_File.xs index 52e60fc88b3..eed671a6fcc 100644 --- a/gnu/usr.bin/perl/ext/NDBM_File/NDBM_File.xs +++ b/gnu/usr.bin/perl/ext/NDBM_File/NDBM_File.xs @@ -109,7 +109,7 @@ ndbm_STORE(db, key, value, flags = DBM_REPLACE) if (RETVAL < 0 && errno == EPERM) croak("No write permission to ndbm file"); croak("ndbm store returned %d, errno %d, key \"%s\"", - RETVAL,errno,key.dptr); + RETVAL, errno, (const char *)key.dptr); dbm_clearerr(db->dbp); } @@ -129,16 +129,22 @@ datum_key ndbm_NEXTKEY(db, key) NDBM_File db datum_key key = NO_INIT + CLEANUP: + PERL_UNUSED_VAR(key); #define ndbm_error(db) dbm_error(db->dbp) int ndbm_error(db) NDBM_File db + CLEANUP: + PERL_UNUSED_VAR(db); #define ndbm_clearerr(db) dbm_clearerr(db->dbp) void ndbm_clearerr(db) NDBM_File db + CLEANUP: + PERL_UNUSED_VAR(db); SV * diff --git a/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.pm b/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.pm index 958232cb7fd..31840257a37 100644 --- a/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.pm +++ b/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.pm @@ -7,7 +7,7 @@ require Tie::Hash; require XSLoader; our @ISA = qw(Tie::Hash); -our $VERSION = "1.12"; +our $VERSION = "1.14"; XSLoader::load(); diff --git a/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.xs b/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.xs index d1ece7ff9be..eaa1923c36f 100644 --- a/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.xs +++ b/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.xs @@ -3,6 +3,10 @@ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" +#if defined(PERL_IMPLICIT_SYS) +# undef open +# define open PerlLIO_open3 +#endif #ifdef I_DBM # include <dbm.h> @@ -99,16 +103,37 @@ odbm_TIEHASH(dbtype, filename, flags, mode) Newx(tmpbuf, strlen(filename) + 5, char); SAVEFREEPV(tmpbuf); sprintf(tmpbuf,"%s.dir",filename); - if (stat(tmpbuf, &PL_statbuf) < 0) { - if (flags & O_CREAT) { - if (mode < 0 || close(creat(tmpbuf,mode)) < 0) - croak("ODBM_File: Can't create %s", filename); - sprintf(tmpbuf,"%s.pag",filename); - if (close(creat(tmpbuf,mode)) < 0) - croak("ODBM_File: Can't create %s", filename); - } - else - croak("ODBM_FILE: Can't open %s", filename); + if ((flags & O_CREAT)) { + const int oflags = O_CREAT | O_TRUNC | O_WRONLY | O_EXCL; + int created = 0; + int fd; + if (mode < 0) + goto creat_done; + if ((fd = open(tmpbuf,oflags,mode)) < 0 && errno != EEXIST) + goto creat_done; + if (close(fd) < 0) + goto creat_done; + sprintf(tmpbuf,"%s.pag",filename); + if ((fd = open(tmpbuf,oflags,mode)) < 0 && errno != EEXIST) + goto creat_done; + if (close(fd) < 0) + goto creat_done; + created = 1; + creat_done: + if (!created) + croak("ODBM_File: Can't create %s", filename); + } + else { + int opened = 0; + int fd; + if ((fd = open(tmpbuf,O_RDONLY,mode)) < 0) + goto rdonly_done; + if (close(fd) < 0) + goto rdonly_done; + opened = 1; + rdonly_done: + if (!opened) + croak("ODBM_FILE: Can't open %s", filename); } dbp = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0); RETVAL = (ODBM_File)safecalloc(1, sizeof(ODBM_File_type)); diff --git a/gnu/usr.bin/perl/ext/ODBM_File/typemap b/gnu/usr.bin/perl/ext/ODBM_File/typemap index 8aed61c8c50..706212dfa71 100644 --- a/gnu/usr.bin/perl/ext/ODBM_File/typemap +++ b/gnu/usr.bin/perl/ext/ODBM_File/typemap @@ -42,7 +42,7 @@ T_DATUM_V $var.dsize = (int)len; } else { - $var.dptr = \"\"; + $var.dptr = (char *)\"\"; $var.dsize = 0; } T_GDATUM diff --git a/gnu/usr.bin/perl/ext/Opcode/Opcode.pm b/gnu/usr.bin/perl/ext/Opcode/Opcode.pm index a48b01d3069..1522c4c3780 100644 --- a/gnu/usr.bin/perl/ext/Opcode/Opcode.pm +++ b/gnu/usr.bin/perl/ext/Opcode/Opcode.pm @@ -6,7 +6,7 @@ use strict; our($VERSION, @ISA, @EXPORT_OK); -$VERSION = "1.27"; +$VERSION = "1.34"; use Carp; use Exporter (); @@ -312,14 +312,15 @@ invert_opset function. av2arylen rv2hv helem hslice kvhslice each values keys exists delete - aeach akeys avalues reach rvalues rkeys + aeach akeys avalues multideref preinc i_preinc predec i_predec postinc i_postinc postdec i_postdec int hex oct abs pow multiply i_multiply divide i_divide modulo i_modulo add i_add subtract i_subtract - left_shift right_shift bit_and bit_xor bit_or negate i_negate - not complement + left_shift right_shift bit_and bit_xor bit_or nbit_and + nbit_xor nbit_or sbit_and sbit_xor sbit_or negate i_negate not + complement ncomplement scomplement lt i_lt gt i_gt le i_le ge i_ge eq i_eq ne i_ne ncmp i_ncmp slt sgt sle sge seq sne scmp @@ -337,9 +338,10 @@ invert_opset function. warn die lineseq nextstate scope enter leave - rv2cv anoncode prototype coreargs + rv2cv anoncode prototype coreargs anonconst entersub leavesub leavesublv return method method_named + method_super method_redir method_redir_super -- XXX loops via recursion? leaveeval -- needed for Safe to operate, is safe @@ -402,7 +404,7 @@ These are a hotchpotch of opcodes still waiting to be considered once - rv2gv refgen srefgen ref + rv2gv refgen srefgen ref refassign lvref lvrefslice lvavref bless -- could be used to change ownership of objects (reblessing) diff --git a/gnu/usr.bin/perl/ext/Opcode/Opcode.xs b/gnu/usr.bin/perl/ext/Opcode/Opcode.xs index 386dddf508d..936ffba25ee 100644 --- a/gnu/usr.bin/perl/ext/Opcode/Opcode.xs +++ b/gnu/usr.bin/perl/ext/Opcode/Opcode.xs @@ -13,7 +13,9 @@ typedef struct { HV * x_op_named_bits; /* cache shared for whole process */ SV * x_opset_all; /* mask with all bits set */ IV x_opset_len; /* length of opmasks in bytes */ - int x_opcode_debug; +#ifdef OPCODE_DEBUG + int x_opcode_debug; /* unused warn() emitting debugging code */ +#endif } my_cxt_t; START_MY_CXT @@ -21,7 +23,12 @@ START_MY_CXT #define op_named_bits (MY_CXT.x_op_named_bits) #define opset_all (MY_CXT.x_opset_all) #define opset_len (MY_CXT.x_opset_len) -#define opcode_debug (MY_CXT.x_opcode_debug) +#ifdef OPCODE_DEBUG +# define opcode_debug (MY_CXT.x_opcode_debug) +#else + /* no API to turn this on at runtime, so constant fold the code away */ +# define opcode_debug 0 +#endif static SV *new_opset (pTHX_ SV *old_opset); static int verify_opset (pTHX_ SV *opset, int fatal); @@ -220,7 +227,9 @@ static void opmask_addlocal(pTHX_ SV *opset, char *op_mask_buf) /* Localise PL_op_mask then opmask_add() */ { char *orig_op_mask = PL_op_mask; +#ifdef OPCODE_DEBUG dMY_CXT; +#endif SAVEVPTR(PL_op_mask); /* XXX casting to an ordinary function ptr from a member function ptr @@ -310,16 +319,21 @@ PPCODE: dummy_hv = save_hash(PL_incgv); GvHV(PL_incgv) = (HV*)SvREFCNT_inc(GvHV(gv_HVadd(gv_fetchpvs("INC",GV_ADD,SVt_PVHV)))); - /* Invalidate ISA and method caches */ + /* Invalidate class and method caches */ ++PL_sub_generation; hv_clear(PL_stashcache); PUSHMARK(SP); - perl_call_sv(codesv, GIMME|G_EVAL|G_KEEPERR); /* use callers context */ + /* use caller’s context */ + perl_call_sv(codesv, GIMME_V|G_EVAL|G_KEEPERR); sv_free( (SV *) dummy_hv); /* get rid of what save_hash gave us*/ SPAGAIN; /* for the PUTBACK added by xsubpp */ LEAVE; + /* Invalidate again */ + ++PL_sub_generation; + hv_clear(PL_stashcache); + int verify_opset(opset, fatal = 0) @@ -520,7 +534,7 @@ CODE: void opcodes() PPCODE: - if (GIMME == G_ARRAY) { + if (GIMME_V == G_ARRAY) { croak("opcodes in list context not yet implemented"); /* XXX */ } else { diff --git a/gnu/usr.bin/perl/ext/Opcode/t/Opcode.t b/gnu/usr.bin/perl/ext/Opcode/t/Opcode.t index 1c0b427f9d4..82028cc5b2c 100644 --- a/gnu/usr.bin/perl/ext/Opcode/t/Opcode.t +++ b/gnu/usr.bin/perl/ext/Opcode/t/Opcode.t @@ -113,6 +113,23 @@ is(($s2 ^ $s3), opset('padsv','padhv')); my @o2 = opset_to_ops(invert_opset $s3); is_deeply(\@o1, \@o2); +# --- test context of undocumented _safe_call_sv (used by Safe.pm) + +my %inc = %INC; +my $expect; +sub f { + %INC = %inc; + no warnings 'uninitialized'; + is wantarray, $expect, + sprintf "_safe_call_sv gives %s context", + qw[void scalar list][$expect + defined $expect] +}; +Opcode::_safe_call_sv("main", empty_opset, \&f); +$expect = !1; +$_ = Opcode::_safe_call_sv("main", empty_opset, \&f); +$expect = !0; +() = Opcode::_safe_call_sv("main", empty_opset, \&f); + # --- finally, check some opname assertions foreach my $opname (@full_l1) { diff --git a/gnu/usr.bin/perl/ext/POSIX/Makefile.PL b/gnu/usr.bin/perl/ext/POSIX/Makefile.PL index 77ebae7d5af..5a65173958f 100644 --- a/gnu/usr.bin/perl/ext/POSIX/Makefile.PL +++ b/gnu/usr.bin/perl/ext/POSIX/Makefile.PL @@ -12,11 +12,17 @@ if ($Config{sig_name} =~ /\bRTMIN\b/ && $Config{sig_name} =~ /\bRTMAX\b/) { my @libs; if ($^O ne 'MSWin32' && $^O ne 'freemint') { - @libs = ('LIBS' => ["-lm -lposix -lcposix"]); + push @libs, qw(m posix cposix); +} +if ($^O eq 'solaris') { + push @libs, qw(sunmath); +} +if ($^O eq 'aix' && $Config{uselongdouble}) { + push @libs, qw(c128); } WriteMakefile( NAME => 'POSIX', - @libs, + @libs ? ( 'LIBS' => [ join(" ", map { "-l$_" } @libs) ] ) : (), XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'lib/POSIX.pm', ABSTRACT_FROM => 'lib/POSIX.pod', @@ -88,6 +94,12 @@ END #endif '}); +push @names, + {name=>"INFINITY", type=>"NV", value=>"NV_INF", not_constant=>1}, + {name=>"NAN", type=>"NV", value=>"NV_NAN", not_constant=>1}, + {name=>"Inf", type=>"NV", value=>"NV_INF", not_constant=>1}, + {name=>"NaN", type=>"NV", value=>"NV_NAN", not_constant=>1}; + push @names, {name=>$_, type=>"UV"} foreach (qw(SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK SA_RESETHAND SA_RESTART SA_SIGINFO UCHAR_MAX UINT_MAX ULONG_MAX USHRT_MAX)); @@ -101,6 +113,14 @@ push @names, {name=>$_, type=>"NV"} FLT_MIN_10_EXP FLT_MIN_EXP FLT_RADIX LDBL_DIG LDBL_MANT_DIG LDBL_MAX_10_EXP LDBL_MAX_EXP LDBL_MIN_10_EXP LDBL_MIN_EXP)); +push @names, {name=>$_, type=>"NV"} + foreach (qw(FP_ILOGB0 FP_ILOGBNAN FP_INFINITE FP_NAN FP_NORMAL + FP_SUBNORMAL FP_ZERO M_1_PI M_2_PI M_2_SQRTPI M_E M_LN10 M_LN2 + M_LOG10E M_LOG2E M_PI M_PI_2 M_PI_4 M_SQRT1_2 M_SQRT2)); + +push @names, {name=>$_, type=>"IV"} + foreach (qw(FE_DOWNWARD FE_TONEAREST FE_TOWARDZERO FE_UPWARD)); + push @names, {name=>$_, type=>"IV", default=>["IV", "0"]} foreach (qw(_POSIX_ARG_MAX _POSIX_CHILD_MAX _POSIX_CHOWN_RESTRICTED _POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT _POSIX_NAME_MAX @@ -108,6 +128,18 @@ push @names, {name=>$_, type=>"IV", default=>["IV", "0"]} _POSIX_PATH_MAX _POSIX_PIPE_BUF _POSIX_SSIZE_MAX _POSIX_STREAM_MAX _POSIX_TZNAME_MAX _POSIX_VDISABLE _POSIX_VERSION )); +push @names, {name=>$_, type =>"IV"}, + foreach (qw(ILL_ILLOPC ILL_ILLOPN ILL_ILLADR ILL_ILLTRP ILL_PRVOPC ILL_PRVREG + ILL_COPROC ILL_BADSTK + FPE_INTDIV FPE_INTOVF FPE_FLTDIV FPE_FLTOVF FPE_FLTUND + FPE_FLTRES FPE_FLTINV FPE_FLTSUB + SEGV_MAPERR SEGV_ACCERR + BUS_ADRALN BUS_ADRERR BUS_OBJERR + TRAP_BRKPT TRAP_TRACE + CLD_EXITED CLD_KILLED CLD_DUMPED CLD_TRAPPED CLD_STOPPED CLD_CONTINUED + POLL_IN POLL_OUT POLL_MSG POLL_ERR POLL_PRI POLL_HUP + SI_USER SI_QUEUE SI_TIMER SI_ASYNCIO SI_MESGQ + )); if ($rt_signals) { push @names, {name=>"SIGRTMAX", not_constant=>1}, @@ -119,6 +151,22 @@ if ($rt_signals) { {name=>"SIGRTMIN", macro=>0}, } +if ($^O eq 'MSWin32') { + push @names, qw( + WSAEINTR WSAEBADF WSAEACCES WSAEFAULT WSAEINVAL WSAEMFILE WSAEWOULDBLOCK + WSAEINPROGRESS WSAEALREADY WSAENOTSOCK WSAEDESTADDRREQ WSAEMSGSIZE + WSAEPROTOTYPE WSAENOPROTOOPT WSAEPROTONOSUPPORT WSAESOCKTNOSUPPORT + WSAEOPNOTSUPP WSAEPFNOSUPPORT WSAEAFNOSUPPORT WSAEADDRINUSE + WSAEADDRNOTAVAIL WSAENETDOWN WSAENETUNREACH WSAENETRESET WSAECONNABORTED + WSAECONNRESET WSAENOBUFS WSAEISCONN WSAENOTCONN WSAESHUTDOWN + WSAETOOMANYREFS WSAETIMEDOUT WSAECONNREFUSED WSAELOOP WSAENAMETOOLONG + WSAEHOSTDOWN WSAEHOSTUNREACH WSAENOTEMPTY WSAEPROCLIM WSAEUSERS + WSAEDQUOT WSAESTALE WSAEREMOTE WSAEDISCON WSAENOMORE WSAECANCELLED + WSAEINVALIDPROCTABLE WSAEINVALIDPROVIDER WSAEPROVIDERFAILEDINIT + WSAEREFUSED + ); +} + WriteConstants( PROXYSUBS => {croak_on_error => 1}, NAME => 'POSIX', diff --git a/gnu/usr.bin/perl/ext/POSIX/POSIX.xs b/gnu/usr.bin/perl/ext/POSIX/POSIX.xs index 307d5bf5368..281bea8bae1 100644 --- a/gnu/usr.bin/perl/ext/POSIX/POSIX.xs +++ b/gnu/usr.bin/perl/ext/POSIX/POSIX.xs @@ -34,6 +34,9 @@ #ifdef I_FLOAT #include <float.h> #endif +#ifdef I_FENV +#include <fenv.h> +#endif #ifdef I_LIMITS #include <limits.h> #endif @@ -54,6 +57,1230 @@ #include <unistd.h> #endif +#if defined(USE_QUADMATH) && defined(I_QUADMATH) + +# undef M_E +# undef M_LOG2E +# undef M_LOG10E +# undef M_LN2 +# undef M_LN10 +# undef M_PI +# undef M_PI_2 +# undef M_PI_4 +# undef M_1_PI +# undef M_2_PI +# undef M_2_SQRTPI +# undef M_SQRT2 +# undef M_SQRT1_2 + +# define M_E M_Eq +# define M_LOG2E M_LOG2Eq +# define M_LOG10E M_LOG10Eq +# define M_LN2 M_LN2q +# define M_LN10 M_LN10q +# define M_PI M_PIq +# define M_PI_2 M_PI_2q +# define M_PI_4 M_PI_4q +# define M_1_PI M_1_PIq +# define M_2_PI M_2_PIq +# define M_2_SQRTPI M_2_SQRTPIq +# define M_SQRT2 M_SQRT2q +# define M_SQRT1_2 M_SQRT1_2q + +#else + +# ifdef USE_LONG_DOUBLE +# undef M_E +# undef M_LOG2E +# undef M_LOG10E +# undef M_LN2 +# undef M_LN10 +# undef M_PI +# undef M_PI_2 +# undef M_PI_4 +# undef M_1_PI +# undef M_2_PI +# undef M_2_SQRTPI +# undef M_SQRT2 +# undef M_SQRT1_2 +# define FLOAT_C(c) CAT2(c,L) +# else +# define FLOAT_C(c) (c) +# endif + +# ifndef M_E +# define M_E FLOAT_C(2.71828182845904523536028747135266250) +# endif +# ifndef M_LOG2E +# define M_LOG2E FLOAT_C(1.44269504088896340735992468100189214) +# endif +# ifndef M_LOG10E +# define M_LOG10E FLOAT_C(0.434294481903251827651128918916605082) +# endif +# ifndef M_LN2 +# define M_LN2 FLOAT_C(0.693147180559945309417232121458176568) +# endif +# ifndef M_LN10 +# define M_LN10 FLOAT_C(2.30258509299404568401799145468436421) +# endif +# ifndef M_PI +# define M_PI FLOAT_C(3.14159265358979323846264338327950288) +# endif +# ifndef M_PI_2 +# define M_PI_2 FLOAT_C(1.57079632679489661923132169163975144) +# endif +# ifndef M_PI_4 +# define M_PI_4 FLOAT_C(0.785398163397448309615660845819875721) +# endif +# ifndef M_1_PI +# define M_1_PI FLOAT_C(0.318309886183790671537767526745028724) +# endif +# ifndef M_2_PI +# define M_2_PI FLOAT_C(0.636619772367581343075535053490057448) +# endif +# ifndef M_2_SQRTPI +# define M_2_SQRTPI FLOAT_C(1.12837916709551257389615890312154517) +# endif +# ifndef M_SQRT2 +# define M_SQRT2 FLOAT_C(1.41421356237309504880168872420969808) +# endif +# ifndef M_SQRT1_2 +# define M_SQRT1_2 FLOAT_C(0.707106781186547524400844362104849039) +# endif + +#endif + +#if !defined(INFINITY) && defined(NV_INF) +# define INFINITY NV_INF +#endif + +#if !defined(NAN) && defined(NV_NAN) +# define NAN NV_NAN +#endif + +#if !defined(Inf) && defined(NV_INF) +# define Inf NV_INF +#endif + +#if !defined(NaN) && defined(NV_NAN) +# define NaN NV_NAN +#endif + +/* We will have an emulation. */ +#ifndef FP_INFINITE +# define FP_INFINITE 0 +# define FP_NAN 1 +# define FP_NORMAL 2 +# define FP_SUBNORMAL 3 +# define FP_ZERO 4 +#endif + +/* We will have an emulation. */ +#ifndef FE_TONEAREST +# define FE_TOWARDZERO 0 +# define FE_TONEAREST 1 +# define FE_UPWARD 2 +# define FE_DOWNWARD 3 +#endif + +/* C89 math.h: + + acos asin atan atan2 ceil cos cosh exp fabs floor fmod frexp ldexp + log log10 modf pow sin sinh sqrt tan tanh + + * Implemented in core: + + atan2 cos exp log pow sin sqrt + + * C99 math.h added: + + acosh asinh atanh cbrt copysign erf erfc exp2 expm1 fdim fma fmax + fmin fpclassify hypot ilogb isfinite isgreater isgreaterequal isinf + isless islessequal islessgreater isnan isnormal isunordered lgamma + log1p log2 logb lrint lround nan nearbyint nextafter nexttoward remainder + remquo rint round scalbn signbit tgamma trunc + + See: + http://pubs.opengroup.org/onlinepubs/009695399/basedefs/math.h.html + + * Berkeley/SVID extensions: + + j0 j1 jn y0 y1 yn + + * Configure already (5.21.5) scans for: + + copysign*l* fpclassify isfinite isinf isnan isnan*l* ilogb*l* signbit scalbn*l* + + * For floating-point round mode (which matters for e.g. lrint and rint) + + fegetround fesetround + +*/ + +/* XXX Constant FP_FAST_FMA (if true, FMA is faster) */ + +/* XXX Add ldiv(), lldiv()? It's C99, but from stdlib.h, not math.h */ + +/* XXX Beware old gamma() -- one cannot know whether that is the + * gamma or the log of gamma, that's why the new tgamma and lgamma. + * Though also remember lgamma_r. */ + +/* Certain AIX releases have the C99 math, but not in long double. + * The <math.h> has them, e.g. __expl128, but no library has them! + * + * Also see the comments in hints/aix.sh about long doubles. */ + +#if defined(USE_QUADMATH) && defined(I_QUADMATH) +# define c99_acosh acoshq +# define c99_asinh asinhq +# define c99_atanh atanhq +# define c99_cbrt cbrtq +# define c99_copysign copysignq +# define c99_erf erfq +# define c99_erfc erfcq +/* no exp2q */ +# define c99_expm1 expm1q +# define c99_fdim fdimq +# define c99_fma fmaq +# define c99_fmax fmaxq +# define c99_fmin fminq +# define c99_hypot hypotq +# define c99_ilogb ilogbq +# define c99_lgamma lgammaq +# define c99_log1p log1pq +# define c99_log2 log2q +/* no logbq */ +# if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG +# define c99_lrint llrintq +# define c99_lround llroundq +# else +# define c99_lrint lrintq +# define c99_lround lroundq +# endif +# define c99_nan nanq +# define c99_nearbyint nearbyintq +# define c99_nextafter nextafterq +/* no nexttowardq */ +# define c99_remainder remainderq +# define c99_remquo remquoq +# define c99_rint rintq +# define c99_round roundq +# define c99_scalbn scalbnq +# define c99_signbit signbitq +# define c99_tgamma tgammaq +# define c99_trunc truncq +# define bessel_j0 j0q +# define bessel_j1 j1q +# define bessel_jn jnq +# define bessel_y0 y0q +# define bessel_y1 y1q +# define bessel_yn ynq +#elif defined(USE_LONG_DOUBLE) && \ + (defined(HAS_FREXPL) || defined(HAS_ILOGBL)) && defined(HAS_SQRTL) +/* Use some of the Configure scans for long double math functions + * as the canary for all the C99 *l variants being defined. */ +# define c99_acosh acoshl +# define c99_asinh asinhl +# define c99_atanh atanhl +# define c99_cbrt cbrtl +# define c99_copysign copysignl +# define c99_erf erfl +# define c99_erfc erfcl +# define c99_exp2 exp2l +# define c99_expm1 expm1l +# define c99_fdim fdiml +# define c99_fma fmal +# define c99_fmax fmaxl +# define c99_fmin fminl +# define c99_hypot hypotl +# define c99_ilogb ilogbl +# define c99_lgamma lgammal +# define c99_log1p log1pl +# define c99_log2 log2l +# define c99_logb logbl +# if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_LLRINTL) +# define c99_lrint llrintl +# elif defined(HAS_LRINTL) +# define c99_lrint lrintl +# endif +# if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_LLROUNDL) +# define c99_lround llroundl +# elif defined(HAS_LROUNDL) +# define c99_lround lroundl +# endif +# define c99_nan nanl +# define c99_nearbyint nearbyintl +# define c99_nextafter nextafterl +# define c99_nexttoward nexttowardl +# define c99_remainder remainderl +# define c99_remquo remquol +# define c99_rint rintl +# define c99_round roundl +# define c99_scalbn scalbnl +# ifdef HAS_SIGNBIT /* possibly bad assumption */ +# define c99_signbit signbitl +# endif +# define c99_tgamma tgammal +# define c99_trunc truncl +#else +# define c99_acosh acosh +# define c99_asinh asinh +# define c99_atanh atanh +# define c99_cbrt cbrt +# define c99_copysign copysign +# define c99_erf erf +# define c99_erfc erfc +# define c99_exp2 exp2 +# define c99_expm1 expm1 +# define c99_fdim fdim +# define c99_fma fma +# define c99_fmax fmax +# define c99_fmin fmin +# define c99_hypot hypot +# define c99_ilogb ilogb +# define c99_lgamma lgamma +# define c99_log1p log1p +# define c99_log2 log2 +# define c99_logb logb +# if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_LLRINT) +# define c99_lrint llrint +# else +# define c99_lrint lrint +# endif +# if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_LLROUND) +# define c99_lround llround +# else +# define c99_lround lround +# endif +# define c99_nan nan +# define c99_nearbyint nearbyint +# define c99_nextafter nextafter +# define c99_nexttoward nexttoward +# define c99_remainder remainder +# define c99_remquo remquo +# define c99_rint rint +# define c99_round round +# define c99_scalbn scalbn +/* We already define Perl_signbit in perl.h. */ +# ifdef HAS_SIGNBIT +# define c99_signbit signbit +# endif +# define c99_tgamma tgamma +# define c99_trunc trunc +#endif + +/* AIX xlc (__IBMC__) really doesn't have the following long double + * math interfaces (no __acoshl128 aka acoshl, etc.), see + * hints/aix.sh. These are in the -lc128 but fail to be found + * during dynamic linking/loading. + * + * XXX1 Better Configure scans + * XXX2 Is this xlc version dependent? */ +#if defined(USE_LONG_DOUBLE) && defined(__IBMC__) +# undef c99_acosh +# undef c99_asinh +# undef c99_atanh +# undef c99_cbrt +# undef c99_copysign +# undef c99_exp2 +# undef c99_expm1 +# undef c99_fdim +# undef c99_fma +# undef c99_fmax +# undef c99_fmin +# undef c99_hypot +# undef c99_ilogb +# undef c99_lrint +# undef c99_lround +# undef c99_log1p +# undef c99_log2 +# undef c99_logb +# undef c99_nan +# undef c99_nearbyint +# undef c99_nextafter +# undef c99_nexttoward +# undef c99_remainder +# undef c99_remquo +# undef c99_rint +# undef c99_round +# undef c99_scalbn +# undef c99_tgamma +# undef c99_trunc +#endif + +#ifndef isunordered +# ifdef Perl_isnan +# define isunordered(x, y) (Perl_isnan(x) || Perl_isnan(y)) +# elif defined(HAS_UNORDERED) +# define isunordered(x, y) unordered(x, y) +# endif +#endif + +/* XXX these isgreater/isnormal/isunordered macros definitions should + * be moved further in the file to be part of the emulations, so that + * platforms can e.g. #undef c99_isunordered and have it work like + * it does for the other interfaces. */ + +#if !defined(isgreater) && defined(isunordered) +# define isgreater(x, y) (!isunordered((x), (y)) && (x) > (y)) +# define isgreaterequal(x, y) (!isunordered((x), (y)) && (x) >= (y)) +# define isless(x, y) (!isunordered((x), (y)) && (x) < (y)) +# define islessequal(x, y) (!isunordered((x), (y)) && (x) <= (y)) +# define islessgreater(x, y) (!isunordered((x), (y)) && \ + ((x) > (y) || (y) > (x))) +#endif + +/* Check both the Configure symbol and the macro-ness (like C99 promises). */ +#if defined(HAS_FPCLASSIFY) && defined(fpclassify) +# define c99_fpclassify fpclassify +#endif +/* Like isnormal(), the isfinite(), isinf(), and isnan() are also C99 + and also (sizeof-arg-aware) macros, but they are already well taken + care of by Configure et al, and defined in perl.h as + Perl_isfinite(), Perl_isinf(), and Perl_isnan(). */ +#ifdef isnormal +# define c99_isnormal isnormal +#endif +#ifdef isgreater /* canary for all the C99 is*<cmp>* macros. */ +# define c99_isgreater isgreater +# define c99_isgreaterequal isgreaterequal +# define c99_isless isless +# define c99_islessequal islessequal +# define c99_islessgreater islessgreater +# define c99_isunordered isunordered +#endif + +/* The Great Wall of Undef where according to the definedness of HAS_FOO symbols + * the corresponding c99_foo wrappers are undefined. This list doesn't include + * the isfoo() interfaces because they are either type-aware macros, or dealt + * separately, already in perl.h */ + +#ifndef HAS_ACOSH +# undef c99_acosh +#endif +#ifndef HAS_ASINH +# undef c99_asinh +#endif +#ifndef HAS_ATANH +# undef c99_atanh +#endif +#ifndef HAS_CBRT +# undef c99_cbrt +#endif +#ifndef HAS_COPYSIGN +# undef c99_copysign +#endif +#ifndef HAS_ERF +# undef c99_erf +#endif +#ifndef HAS_ERFC +# undef c99_erfc +#endif +#ifndef HAS_EXP2 +# undef c99_exp2 +#endif +#ifndef HAS_EXPM1 +# undef c99_expm1 +#endif +#ifndef HAS_FDIM +# undef c99_fdim +#endif +#ifndef HAS_FMA +# undef c99_fma +#endif +#ifndef HAS_FMAX +# undef c99_fmax +#endif +#ifndef HAS_FMIN +# undef c99_fmin +#endif +#ifndef HAS_FPCLASSIFY +# undef c99_fpclassify +#endif +#ifndef HAS_HYPOT +# undef c99_hypot +#endif +#ifndef HAS_ILOGB +# undef c99_ilogb +#endif +#ifndef HAS_LGAMMA +# undef c99_lgamma +#endif +#ifndef HAS_LOG1P +# undef c99_log1p +#endif +#ifndef HAS_LOG2 +# undef c99_log2 +#endif +#ifndef HAS_LOGB +# undef c99_logb +#endif +#ifndef HAS_LRINT +# undef c99_lrint +#endif +#ifndef HAS_LROUND +# undef c99_lround +#endif +#ifndef HAS_NAN +# undef c99_nan +#endif +#ifndef HAS_NEARBYINT +# undef c99_nearbyint +#endif +#ifndef HAS_NEXTAFTER +# undef c99_nextafter +#endif +#ifndef HAS_NEXTTOWARD +# undef c99_nexttoward +#endif +#ifndef HAS_REMAINDER +# undef c99_remainder +#endif +#ifndef HAS_REMQUO +# undef c99_remquo +#endif +#ifndef HAS_RINT +# undef c99_rint +#endif +#ifndef HAS_ROUND +# undef c99_round +#endif +#ifndef HAS_SCALBN +# undef c99_scalbn +#endif +#ifndef HAS_SIGNBIT +# undef c99_signbit +#endif +#ifndef HAS_TGAMMA +# undef c99_tgamma +#endif +#ifndef HAS_TRUNC +# undef c99_trunc +#endif + +#ifdef WIN32 + +/* Some APIs exist under Win32 with "underbar" names. */ +# undef c99_hypot +# undef c99_logb +# undef c99_nextafter +# define c99_hypot _hypot +# define c99_logb _logb +# define c99_nextafter _nextafter + +# define bessel_j0 _j0 +# define bessel_j1 _j1 +# define bessel_jn _jn +# define bessel_y0 _y0 +# define bessel_y1 _y1 +# define bessel_yn _yn + +#endif + +/* The Bessel functions: BSD, SVID, XPG4, and POSIX. But not C99. */ +#if defined(HAS_J0) && !defined(bessel_j0) +# if defined(USE_LONG_DOUBLE) && defined(HAS_J0L) +# define bessel_j0 j0l +# define bessel_j1 j1l +# define bessel_jn jnl +# define bessel_y0 y0l +# define bessel_y1 y1l +# define bessel_yn ynl +# else +# define bessel_j0 j0 +# define bessel_j1 j1 +# define bessel_jn jn +# define bessel_y0 y0 +# define bessel_y1 y1 +# define bessel_yn yn +# endif +#endif + +/* Emulations for missing math APIs. + * + * Keep in mind that the point of many of these functions is that + * they, if available, are supposed to give more precise/more + * numerically stable results. + * + * See e.g. http://www.johndcook.com/math_h.html + */ + +#ifndef c99_acosh +static NV my_acosh(NV x) +{ + return Perl_log(x + Perl_sqrt(x * x - 1)); +} +# define c99_acosh my_acosh +#endif + +#ifndef c99_asinh +static NV my_asinh(NV x) +{ + return Perl_log(x + Perl_sqrt(x * x + 1)); +} +# define c99_asinh my_asinh +#endif + +#ifndef c99_atanh +static NV my_atanh(NV x) +{ + return (Perl_log(1 + x) - Perl_log(1 - x)) / 2; +} +# define c99_atanh my_atanh +#endif + +#ifndef c99_cbrt +static NV my_cbrt(NV x) +{ + static const NV one_third = (NV)1.0/3; + return x >= 0.0 ? Perl_pow(x, one_third) : -Perl_pow(-x, one_third); +} +# define c99_cbrt my_cbrt +#endif + +#ifndef c99_copysign +static NV my_copysign(NV x, NV y) +{ + return y >= 0 ? (x < 0 ? -x : x) : (x < 0 ? x : -x); +} +# define c99_copysign my_copysign +#endif + +/* XXX cosh (though c89) */ + +#ifndef c99_erf +static NV my_erf(NV x) +{ + /* http://www.johndcook.com/cpp_erf.html -- public domain */ + NV a1 = 0.254829592; + NV a2 = -0.284496736; + NV a3 = 1.421413741; + NV a4 = -1.453152027; + NV a5 = 1.061405429; + NV p = 0.3275911; + NV t, y; + int sign = x < 0 ? -1 : 1; /* Save the sign. */ + x = PERL_ABS(x); + + /* Abramowitz and Stegun formula 7.1.26 */ + t = 1.0 / (1.0 + p * x); + y = 1.0 - (((((a5*t + a4)*t) + a3)*t + a2)*t + a1) * t * Perl_exp(-x*x); + + return sign * y; +} +# define c99_erf my_erf +#endif + +#ifndef c99_erfc +static NV my_erfc(NV x) { + /* This is not necessarily numerically stable, but better than nothing. */ + return 1.0 - c99_erf(x); +} +# define c99_erfc my_erfc +#endif + +#ifndef c99_exp2 +static NV my_exp2(NV x) +{ + return Perl_pow((NV)2.0, x); +} +# define c99_exp2 my_exp2 +#endif + +#ifndef c99_expm1 +static NV my_expm1(NV x) +{ + if (PERL_ABS(x) < 1e-5) + /* http://www.johndcook.com/cpp_expm1.html -- public domain. + * Taylor series, the first four terms (the last term quartic). */ + /* Probably not enough for long doubles. */ + return x * (1.0 + x * (1/2.0 + x * (1/6.0 + x/24.0))); + else + return Perl_exp(x) - 1; +} +# define c99_expm1 my_expm1 +#endif + +#ifndef c99_fdim +static NV my_fdim(NV x, NV y) +{ + return (Perl_isnan(x) || Perl_isnan(y)) ? NV_NAN : (x > y ? x - y : 0); +} +# define c99_fdim my_fdim +#endif + +#ifndef c99_fma +static NV my_fma(NV x, NV y, NV z) +{ + return (x * y) + z; +} +# define c99_fma my_fma +#endif + +#ifndef c99_fmax +static NV my_fmax(NV x, NV y) +{ + if (Perl_isnan(x)) { + return Perl_isnan(y) ? NV_NAN : y; + } else if (Perl_isnan(y)) { + return x; + } + return x > y ? x : y; +} +# define c99_fmax my_fmax +#endif + +#ifndef c99_fmin +static NV my_fmin(NV x, NV y) +{ + if (Perl_isnan(x)) { + return Perl_isnan(y) ? NV_NAN : y; + } else if (Perl_isnan(y)) { + return x; + } + return x < y ? x : y; +} +# define c99_fmin my_fmin +#endif + +#ifndef c99_fpclassify + +static IV my_fpclassify(NV x) +{ +#ifdef Perl_fp_class_inf + if (Perl_fp_class_inf(x)) return FP_INFINITE; + if (Perl_fp_class_nan(x)) return FP_NAN; + if (Perl_fp_class_norm(x)) return FP_NORMAL; + if (Perl_fp_class_denorm(x)) return FP_SUBNORMAL; + if (Perl_fp_class_zero(x)) return FP_ZERO; +# define c99_fpclassify my_fpclassify +#endif + return -1; +} + +#endif + +#ifndef c99_hypot +static NV my_hypot(NV x, NV y) +{ + /* http://en.wikipedia.org/wiki/Hypot */ + NV t; + x = PERL_ABS(x); /* Take absolute values. */ + if (y == 0) + return x; + if (Perl_isnan(y)) + return NV_INF; + y = PERL_ABS(y); + if (x < y) { /* Swap so that y is less. */ + t = x; + x = y; + y = t; + } + t = y / x; + return x * Perl_sqrt(1.0 + t * t); +} +# define c99_hypot my_hypot +#endif + +#ifndef c99_ilogb +static IV my_ilogb(NV x) +{ + return (IV)(Perl_log(x) * M_LOG2E); +} +# define c99_ilogb my_ilogb +#endif + +/* tgamma and lgamma emulations based on + * http://www.johndcook.com/cpp_gamma.html, + * code placed in public domain. + * + * Note that these implementations (neither the johndcook originals + * nor these) do NOT set the global signgam variable. This is not + * necessarily a bad thing. */ + +/* Note that the tgamma() and lgamma() implementations + * here depend on each other. */ + +#if !defined(HAS_TGAMMA) || !defined(c99_tgamma) +static NV my_tgamma(NV x); +# define c99_tgamma my_tgamma +# define USE_MY_TGAMMA +#endif +#if !defined(HAS_LGAMMA) || !defined(c99_lgamma) +static NV my_lgamma(NV x); +# define c99_lgamma my_lgamma +# define USE_MY_LGAMMA +#endif + +#ifdef USE_MY_TGAMMA +static NV my_tgamma(NV x) +{ + const NV gamma = 0.577215664901532860606512090; /* Euler's gamma constant. */ + if (Perl_isnan(x) || x < 0.0) + return NV_NAN; + if (x == 0.0 || x == NV_INF) + return x == -0.0 ? -NV_INF : NV_INF; + + /* The function domain is split into three intervals: + * (0, 0.001), [0.001, 12), and (12, infinity) */ + + /* First interval: (0, 0.001) + * For small values, 1/tgamma(x) has power series x + gamma x^2, + * so in this range, 1/tgamma(x) = x + gamma x^2 with error on the order of x^3. + * The relative error over this interval is less than 6e-7. */ + if (x < 0.001) + return 1.0 / (x * (1.0 + gamma * x)); + + /* Second interval: [0.001, 12) */ + if (x < 12.0) { + double y = x; /* Working copy. */ + int n = 0; + /* Numerator coefficients for approximation over the interval (1,2) */ + static const NV p[] = { + -1.71618513886549492533811E+0, + 2.47656508055759199108314E+1, + -3.79804256470945635097577E+2, + 6.29331155312818442661052E+2, + 8.66966202790413211295064E+2, + -3.14512729688483675254357E+4, + -3.61444134186911729807069E+4, + 6.64561438202405440627855E+4 + }; + /* Denominator coefficients for approximation over the interval (1, 2) */ + static const NV q[] = { + -3.08402300119738975254353E+1, + 3.15350626979604161529144E+2, + -1.01515636749021914166146E+3, + -3.10777167157231109440444E+3, + 2.25381184209801510330112E+4, + 4.75584627752788110767815E+3, + -1.34659959864969306392456E+5, + -1.15132259675553483497211E+5 + }; + NV num = 0.0; + NV den = 1.0; + NV z; + NV result; + int i; + + if (x < 1.0) + y += 1.0; + else { + n = (int)Perl_floor(y) - 1; + y -= n; + } + z = y - 1; + for (i = 0; i < 8; i++) { + num = (num + p[i]) * z; + den = den * z + q[i]; + } + result = num / den + 1.0; + + if (x < 1.0) { + /* Use the identity tgamma(z) = tgamma(z+1)/z + * The variable "result" now holds tgamma of the original y + 1 + * Thus we use y - 1 to get back the original y. */ + result /= (y - 1.0); + } + else { + /* Use the identity tgamma(z+n) = z*(z+1)* ... *(z+n-1)*tgamma(z) */ + for (i = 0; i < n; i++) + result *= y++; + } + + return result; + } + + /* Third interval: [12, +Inf) */ +#if LDBL_MANT_DIG == 113 /* IEEE quad prec */ + if (x > 1755.548) { + return NV_INF; + } +#else + if (x > 171.624) { + return NV_INF; + } +#endif + + return Perl_exp(c99_lgamma(x)); +} +#endif + +#ifdef USE_MY_LGAMMA +static NV my_lgamma(NV x) +{ + if (Perl_isnan(x)) + return NV_NAN; + if (x <= 0 || x == NV_INF) + return NV_INF; + if (x == 1.0 || x == 2.0) + return 0; + if (x < 12.0) + return Perl_log(PERL_ABS(c99_tgamma(x))); + /* Abramowitz and Stegun 6.1.41 + * Asymptotic series should be good to at least 11 or 12 figures + * For error analysis, see Whittiker and Watson + * A Course in Modern Analysis (1927), page 252 */ + { + static const NV c[8] = { + 1.0/12.0, + -1.0/360.0, + 1.0/1260.0, + -1.0/1680.0, + 1.0/1188.0, + -691.0/360360.0, + 1.0/156.0, + -3617.0/122400.0 + }; + NV z = 1.0 / (x * x); + NV sum = c[7]; + static const NV half_log_of_two_pi = + 0.91893853320467274178032973640562; + NV series; + int i; + for (i = 6; i >= 0; i--) { + sum *= z; + sum += c[i]; + } + series = sum / x; + return (x - 0.5) * Perl_log(x) - x + half_log_of_two_pi + series; + } +} +#endif + +#ifndef c99_log1p +static NV my_log1p(NV x) +{ + /* http://www.johndcook.com/cpp_log_one_plus_x.html -- public domain. + * Taylor series, the first four terms (the last term quartic). */ + if (x < -1.0) + return NV_NAN; + if (x == -1.0) + return -NV_INF; + if (PERL_ABS(x) > 1e-4) + return Perl_log(1.0 + x); + else + /* Probably not enough for long doubles. */ + return x * (1.0 + x * (-1/2.0 + x * (1/3.0 - x/4.0))); +} +# define c99_log1p my_log1p +#endif + +#ifndef c99_log2 +static NV my_log2(NV x) +{ + return Perl_log(x) * M_LOG2E; +} +# define c99_log2 my_log2 +#endif + +/* XXX nextafter */ + +/* XXX nexttoward */ + +static int my_fegetround() +{ +#ifdef HAS_FEGETROUND + return fegetround(); +#elif defined(HAS_FPGETROUND) + switch (fpgetround()) { + case FP_RN: return FE_TONEAREST; + case FP_RZ: return FE_TOWARDZERO; + case FP_RM: return FE_DOWNWARD; + case FP_RP: return FE_UPWARD; + default: return -1; + } +#elif defined(FLT_ROUNDS) + switch (FLT_ROUNDS) { + case 0: return FE_TOWARDZERO; + case 1: return FE_TONEAREST; + case 2: return FE_UPWARD; + case 3: return FE_DOWNWARD; + default: return -1; + } +#elif defined(__osf__) /* Tru64 */ + switch (read_rnd()) { + case FP_RND_RN: return FE_TONEAREST; + case FP_RND_RZ: return FE_TOWARDZERO; + case FP_RND_RM: return FE_DOWNWARD; + case FP_RND_RP: return FE_UPWARD; + default: return -1; + } +#else + return -1; +#endif +} + +/* Toward closest integer. */ +#define MY_ROUND_NEAREST(x) ((NV)((IV)((x) >= 0.0 ? (x) + 0.5 : (x) - 0.5))) + +/* Toward zero. */ +#define MY_ROUND_TRUNC(x) ((NV)((IV)(x))) + +/* Toward minus infinity. */ +#define MY_ROUND_DOWN(x) ((NV)((IV)((x) >= 0.0 ? (x) : (x) - 0.5))) + +/* Toward plus infinity. */ +#define MY_ROUND_UP(x) ((NV)((IV)((x) >= 0.0 ? (x) + 0.5 : (x)))) + +#if (!defined(c99_nearbyint) || !defined(c99_lrint)) && defined(FE_TONEAREST) +static NV my_rint(NV x) +{ +#ifdef FE_TONEAREST + switch (my_fegetround()) { + case FE_TONEAREST: return MY_ROUND_NEAREST(x); + case FE_TOWARDZERO: return MY_ROUND_TRUNC(x); + case FE_DOWNWARD: return MY_ROUND_DOWN(x); + case FE_UPWARD: return MY_ROUND_UP(x); + default: return NV_NAN; + } +#elif defined(HAS_FPGETROUND) + switch (fpgetround()) { + case FP_RN: return MY_ROUND_NEAREST(x); + case FP_RZ: return MY_ROUND_TRUNC(x); + case FP_RM: return MY_ROUND_DOWN(x); + case FE_RP: return MY_ROUND_UP(x); + default: return NV_NAN; + } +#else + return NV_NAN; +#endif +} +#endif + +/* XXX nearbyint() and rint() are not really identical -- but the difference + * is messy: nearbyint is defined NOT to raise FE_INEXACT floating point + * exceptions, while rint() is defined to MAYBE raise them. At the moment + * Perl is blissfully unaware of such fine detail of floating point. */ +#ifndef c99_nearbyint +# ifdef FE_TONEAREST +# define c99_nearbyrint my_rint +# endif +#endif + +#ifndef c99_lrint +# ifdef FE_TONEAREST +static IV my_lrint(NV x) +{ + return (IV)my_rint(x); +} +# define c99_lrint my_lrint +# endif +#endif + +#ifndef c99_lround +static IV my_lround(NV x) +{ + return (IV)MY_ROUND_NEAREST(x); +} +# define c99_lround my_lround +#endif + +/* XXX remainder */ + +/* XXX remquo */ + +#ifndef c99_rint +# ifdef FE_TONEAREST +# define c99_rint my_rint +# endif +#endif + +#ifndef c99_round +static NV my_round(NV x) +{ + return MY_ROUND_NEAREST(x); +} +# define c99_round my_round +#endif + +#ifndef c99_scalbn +# if defined(Perl_ldexp) && FLT_RADIX == 2 +static NV my_scalbn(NV x, int y) +{ + return Perl_ldexp(x, y); +} +# define c99_scalbn my_scalbn +# endif +#endif + +/* XXX sinh (though c89) */ + +/* tgamma -- see lgamma */ + +/* XXX tanh (though c89) */ + +#ifndef c99_trunc +static NV my_trunc(NV x) +{ + return MY_ROUND_TRUNC(x); +} +# define c99_trunc my_trunc +#endif + +#undef NV_PAYLOAD_DEBUG + +/* NOTE: the NaN payload API implementation is hand-rolled, since the + * APIs are only proposed ones as of June 2015, so very few, if any, + * platforms have implementations yet, so HAS_SETPAYLOAD and such are + * unlikely to be helpful. + * + * XXX - if the core numification wants to actually generate + * the nan payload in "nan(123)", and maybe "nans(456)", for + * signaling payload", this needs to be moved to e.g. numeric.c + * (look for grok_infnan) + * + * Conversely, if the core stringification wants the nan payload + * and/or the nan quiet/signaling distinction, S_getpayload() + * from this file needs to be moved, to e.g. sv.c (look for S_infnan_2pv), + * and the (trivial) functionality of issignaling() copied + * (for generating "NaNS", or maybe even "NaNQ") -- or maybe there + * are too many formatting parameters for simple stringification? + */ + +/* While it might make sense for the payload to be UV or IV, + * to avoid conversion loss, the proposed ISO interfaces use + * a floating point input, which is then truncated to integer, + * and only the integer part being used. This is workable, + * except for: (1) the conversion loss (2) suboptimal for + * 32-bit integer platforms. A workaround API for (2) and + * in general for bit-honesty would be an array of integers + * as the payload... but the proposed C API does nothing of + * the kind. */ +#if NVSIZE == UVSIZE +# define NV_PAYLOAD_TYPE UV +#else +# define NV_PAYLOAD_TYPE NV +#endif + +#ifdef LONGDOUBLE_DOUBLEDOUBLE +# define NV_PAYLOAD_SIZEOF_ASSERT(a) assert(sizeof(a) == NVSIZE / 2) +#else +# define NV_PAYLOAD_SIZEOF_ASSERT(a) assert(sizeof(a) == NVSIZE) +#endif + +static void S_setpayload(NV* nvp, NV_PAYLOAD_TYPE payload, bool signaling) +{ + dTHX; + static const U8 m[] = { NV_NAN_PAYLOAD_MASK }; + static const U8 p[] = { NV_NAN_PAYLOAD_PERM }; + UV a[(NVSIZE + UVSIZE - 1) / UVSIZE] = { 0 }; + int i; + NV_PAYLOAD_SIZEOF_ASSERT(m); + NV_PAYLOAD_SIZEOF_ASSERT(p); + *nvp = NV_NAN; + /* Divide the input into the array in "base unsigned integer" in + * little-endian order. Note that the integer might be smaller than + * an NV (if UV is U32, for example). */ +#if NVSIZE == UVSIZE + a[0] = payload; /* The trivial case. */ +#else + { + NV t1 = c99_trunc(payload); /* towards zero (drop fractional) */ +#ifdef NV_PAYLOAD_DEBUG + Perl_warn(aTHX_ "t1 = %"NVgf" (payload %"NVgf")\n", t1, payload); +#endif + if (t1 <= UV_MAX) { + a[0] = (UV)t1; /* Fast path, also avoids rounding errors (right?) */ + } else { + /* UVSIZE < NVSIZE or payload > UV_MAX. + * + * This may happen for example if: + * (1) UVSIZE == 32 and common 64-bit double NV + * (32-bit system not using -Duse64bitint) + * (2) UVSIZE == 64 and the x86-style 80-bit long double NV + * (note that here the room for payload is actually the 64 bits) + * (3) UVSIZE == 64 and the 128-bit IEEE 764 quadruple NV + * (112 bits in mantissa, 111 bits room for payload) + * + * NOTE: this is very sensitive to correctly functioning + * fmod()/fmodl(), and correct casting of big-unsigned-integer to NV. + * If these don't work right, especially the low order bits + * are in danger. For example Solaris and AIX seem to have issues + * here, especially if using 32-bit UVs. */ + NV t2; + for (i = 0, t2 = t1; i < (int)C_ARRAY_LENGTH(a); i++) { + a[i] = (UV)Perl_fmod(t2, (NV)UV_MAX); + t2 = Perl_floor(t2 / (NV)UV_MAX); + } + } + } +#endif +#ifdef NV_PAYLOAD_DEBUG + for (i = 0; i < (int)C_ARRAY_LENGTH(a); i++) { + Perl_warn(aTHX_ "a[%d] = 0x%"UVxf"\n", i, a[i]); + } +#endif + for (i = 0; i < (int)sizeof(p); i++) { + if (m[i] && p[i] < sizeof(p)) { + U8 s = (p[i] % UVSIZE) << 3; + UV u = a[p[i] / UVSIZE] & ((UV)0xFF << s); + U8 b = (U8)((u >> s) & m[i]); + ((U8 *)(nvp))[i] &= ~m[i]; /* For NaNs with non-zero payload bits. */ + ((U8 *)(nvp))[i] |= b; +#ifdef NV_PAYLOAD_DEBUG + Perl_warn(aTHX_ "set p[%2d] = %02x (i = %d, m = %02x, s = %2d, b = %02x, u = %08"UVxf")\n", i, ((U8 *)(nvp))[i], i, m[i], s, b, u); +#endif + a[p[i] / UVSIZE] &= ~u; + } + } + if (signaling) { + NV_NAN_SET_SIGNALING(nvp); + } +#ifdef USE_LONG_DOUBLE +# if LONG_DOUBLEKIND == 3 || LONG_DOUBLEKIND == 4 +# if LONG_DOUBLESIZE > 10 + memset((char *)nvp + 10, '\0', LONG_DOUBLESIZE - 10); /* x86 long double */ +# endif +# endif +#endif + for (i = 0; i < (int)C_ARRAY_LENGTH(a); i++) { + if (a[i]) { + Perl_warn(aTHX_ "payload lost bits (%"UVxf")", a[i]); + break; + } + } +#ifdef NV_PAYLOAD_DEBUG + for (i = 0; i < NVSIZE; i++) { + PerlIO_printf(Perl_debug_log, "%02x ", ((U8 *)(nvp))[i]); + } + PerlIO_printf(Perl_debug_log, "\n"); +#endif +} + +static NV_PAYLOAD_TYPE S_getpayload(NV nv) +{ + dTHX; + static const U8 m[] = { NV_NAN_PAYLOAD_MASK }; + static const U8 p[] = { NV_NAN_PAYLOAD_PERM }; + UV a[(NVSIZE + UVSIZE - 1) / UVSIZE] = { 0 }; + int i; + NV payload; + NV_PAYLOAD_SIZEOF_ASSERT(m); + NV_PAYLOAD_SIZEOF_ASSERT(p); + payload = 0; + for (i = 0; i < (int)sizeof(p); i++) { + if (m[i] && p[i] < NVSIZE) { + U8 s = (p[i] % UVSIZE) << 3; + a[p[i] / UVSIZE] |= (UV)(((U8 *)(&nv))[i] & m[i]) << s; + } + } + for (i = (int)C_ARRAY_LENGTH(a) - 1; i >= 0; i--) { +#ifdef NV_PAYLOAD_DEBUG + Perl_warn(aTHX_ "a[%d] = %"UVxf"\n", i, a[i]); +#endif + payload *= UV_MAX; + payload += a[i]; + } +#ifdef NV_PAYLOAD_DEBUG + for (i = 0; i < NVSIZE; i++) { + PerlIO_printf(Perl_debug_log, "%02x ", ((U8 *)(&nv))[i]); + } + PerlIO_printf(Perl_debug_log, "\n"); +#endif + return payload; +} + /* XXX This comment is just to make I_TERMIO and I_SGTTY visible to metaconfig for future extension writers. We don't use them in POSIX. (This is really sneaky :-) --AD @@ -133,10 +1360,13 @@ char *tzname[] = { "" , "" }; # define setuid(a) not_here("setuid") # define setgid(a) not_here("setgid") #endif /* NETWARE */ +#ifndef USE_LONG_DOUBLE +# define strtold(s1,s2) not_here("strtold") +#endif /* USE_LONG_DOUBLE */ #else # ifndef HAS_MKFIFO -# if defined(OS2) +# if defined(OS2) || defined(__amigaos4__) # define mkfifo(a,b) not_here("mkfifo") # else /* !( defined OS2 ) */ # ifndef mkfifo @@ -152,7 +1382,9 @@ char *tzname[] = { "" , "" }; # ifdef HAS_UNAME # include <sys/utsname.h> # endif -# include <sys/wait.h> +# ifndef __amigaos4__ +# include <sys/wait.h> +# endif # ifdef I_UTIME # include <utime.h> # endif @@ -163,6 +1395,8 @@ typedef int SysRet; typedef long SysRetLong; typedef sigset_t* POSIX__SigSet; typedef HV* POSIX__SigAction; +typedef int POSIX__SigNo; +typedef int POSIX__Fd; #ifdef I_TERMIOS typedef struct termios* POSIX__Termios; #else /* Define termios types to int, and call not_here for the functions.*/ @@ -189,6 +1423,9 @@ START_EXTERN_C double strtod (const char *, char **); long strtol (const char *, char **, int); unsigned long strtoul (const char *, char **, int); +#ifdef HAS_STRTOLD +long double strtold (const char *, char **); +#endif END_EXTERN_C #endif @@ -227,6 +1464,9 @@ END_EXTERN_C #ifndef HAS_STRTOD #define strtod(s1,s2) not_here("strtod") #endif +#ifndef HAS_STRTOLD +#define strtold(s1,s2) not_here("strtold") +#endif #ifndef HAS_STRTOL #define strtol(s1,s2,b) not_here("strtol") #endif @@ -282,55 +1522,76 @@ END_EXTERN_C #endif #endif -#ifdef HAS_LOCALECONV +#ifndef HAS_LOCALECONV +# define localeconv() not_here("localeconv") +#else struct lconv_offset { const char *name; size_t offset; }; -const struct lconv_offset lconv_strings[] = { - {"decimal_point", offsetof(struct lconv, decimal_point)}, - {"thousands_sep", offsetof(struct lconv, thousands_sep)}, -#ifndef NO_LOCALECONV_GROUPING - {"grouping", offsetof(struct lconv, grouping)}, -#endif - {"int_curr_symbol", offsetof(struct lconv, int_curr_symbol)}, - {"currency_symbol", offsetof(struct lconv, currency_symbol)}, - {"mon_decimal_point", offsetof(struct lconv, mon_decimal_point)}, -#ifndef NO_LOCALECONV_MON_THOUSANDS_SEP - {"mon_thousands_sep", offsetof(struct lconv, mon_thousands_sep)}, +static const struct lconv_offset lconv_strings[] = { +#ifdef USE_LOCALE_NUMERIC + {"decimal_point", STRUCT_OFFSET(struct lconv, decimal_point)}, + {"thousands_sep", STRUCT_OFFSET(struct lconv, thousands_sep)}, +# ifndef NO_LOCALECONV_GROUPING + {"grouping", STRUCT_OFFSET(struct lconv, grouping)}, +# endif #endif -#ifndef NO_LOCALECONV_MON_GROUPING - {"mon_grouping", offsetof(struct lconv, mon_grouping)}, +#ifdef USE_LOCALE_MONETARY + {"int_curr_symbol", STRUCT_OFFSET(struct lconv, int_curr_symbol)}, + {"currency_symbol", STRUCT_OFFSET(struct lconv, currency_symbol)}, + {"mon_decimal_point", STRUCT_OFFSET(struct lconv, mon_decimal_point)}, +# ifndef NO_LOCALECONV_MON_THOUSANDS_SEP + {"mon_thousands_sep", STRUCT_OFFSET(struct lconv, mon_thousands_sep)}, +# endif +# ifndef NO_LOCALECONV_MON_GROUPING + {"mon_grouping", STRUCT_OFFSET(struct lconv, mon_grouping)}, +# endif + {"positive_sign", STRUCT_OFFSET(struct lconv, positive_sign)}, + {"negative_sign", STRUCT_OFFSET(struct lconv, negative_sign)}, #endif - {"positive_sign", offsetof(struct lconv, positive_sign)}, - {"negative_sign", offsetof(struct lconv, negative_sign)}, {NULL, 0} }; -const struct lconv_offset lconv_integers[] = { - {"int_frac_digits", offsetof(struct lconv, int_frac_digits)}, - {"frac_digits", offsetof(struct lconv, frac_digits)}, - {"p_cs_precedes", offsetof(struct lconv, p_cs_precedes)}, - {"p_sep_by_space", offsetof(struct lconv, p_sep_by_space)}, - {"n_cs_precedes", offsetof(struct lconv, n_cs_precedes)}, - {"n_sep_by_space", offsetof(struct lconv, n_sep_by_space)}, - {"p_sign_posn", offsetof(struct lconv, p_sign_posn)}, - {"n_sign_posn", offsetof(struct lconv, n_sign_posn)}, +#ifdef USE_LOCALE_NUMERIC + +/* The Linux man pages say these are the field names for the structure + * components that are LC_NUMERIC; the rest being LC_MONETARY */ +# define isLC_NUMERIC_STRING(name) (strEQ(name, "decimal_point") \ + || strEQ(name, "thousands_sep") \ + \ + /* There should be no harm done \ + * checking for this, even if \ + * NO_LOCALECONV_GROUPING */ \ + || strEQ(name, "grouping")) +#else +# define isLC_NUMERIC_STRING(name) (0) +#endif + +static const struct lconv_offset lconv_integers[] = { +#ifdef USE_LOCALE_MONETARY + {"int_frac_digits", STRUCT_OFFSET(struct lconv, int_frac_digits)}, + {"frac_digits", STRUCT_OFFSET(struct lconv, frac_digits)}, + {"p_cs_precedes", STRUCT_OFFSET(struct lconv, p_cs_precedes)}, + {"p_sep_by_space", STRUCT_OFFSET(struct lconv, p_sep_by_space)}, + {"n_cs_precedes", STRUCT_OFFSET(struct lconv, n_cs_precedes)}, + {"n_sep_by_space", STRUCT_OFFSET(struct lconv, n_sep_by_space)}, + {"p_sign_posn", STRUCT_OFFSET(struct lconv, p_sign_posn)}, + {"n_sign_posn", STRUCT_OFFSET(struct lconv, n_sign_posn)}, #ifdef HAS_LC_MONETARY_2008 - {"int_p_cs_precedes", offsetof(struct lconv, int_p_cs_precedes)}, - {"int_p_sep_by_space", offsetof(struct lconv, int_p_sep_by_space)}, - {"int_n_cs_precedes", offsetof(struct lconv, int_n_cs_precedes)}, - {"int_n_sep_by_space", offsetof(struct lconv, int_n_sep_by_space)}, - {"int_p_sign_posn", offsetof(struct lconv, int_p_sign_posn)}, - {"int_n_sign_posn", offsetof(struct lconv, int_n_sign_posn)}, + {"int_p_cs_precedes", STRUCT_OFFSET(struct lconv, int_p_cs_precedes)}, + {"int_p_sep_by_space", STRUCT_OFFSET(struct lconv, int_p_sep_by_space)}, + {"int_n_cs_precedes", STRUCT_OFFSET(struct lconv, int_n_cs_precedes)}, + {"int_n_sep_by_space", STRUCT_OFFSET(struct lconv, int_n_sep_by_space)}, + {"int_p_sign_posn", STRUCT_OFFSET(struct lconv, int_p_sign_posn)}, + {"int_n_sign_posn", STRUCT_OFFSET(struct lconv, int_n_sign_posn)}, +#endif #endif {NULL, 0} }; -#else -#define localeconv() not_here("localeconv") -#endif +#endif /* HAS_LOCALECONV */ #ifdef HAS_LONG_DOUBLE # if LONG_DOUBLESIZE > NVSIZE @@ -391,8 +1652,10 @@ restore_sigmask(pTHX_ SV *osset_sv) * supposed to return -1 from sigaction unless the disposition * was unaffected. */ +#if !(defined(__amigaos4__) && defined(__NEWLIB__)) sigset_t *ossetp = (sigset_t *) SvPV_nolen( osset_sv ); (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0); +#endif } static void * @@ -515,106 +1778,6 @@ my_tzset(pTHX) tzset(); } -typedef int (*isfunc_t)(int); -typedef void (*any_dptr_t)(void *); - -/* This needs to be ALIASed in a custom way, hence can't easily be defined as - a regular XSUB. */ -static XSPROTO(is_common); /* prototype to pass -Wmissing-prototypes */ -static XSPROTO(is_common) -{ - dXSARGS; - static PTR_TBL_t * is_common_ptr_table; - - if (items != 1) - croak_xs_usage(cv, "charstring"); - - { - dXSTARG; - STRLEN len; - /*int RETVAL = 0; YYY means uncomment this to return false on an - * empty string input */ - int RETVAL; - unsigned char *s = (unsigned char *) SvPV(ST(0), len); - unsigned char *e = s + len; - isfunc_t isfunc = (isfunc_t) XSANY.any_dptr; - - if (ckWARN_d(WARN_DEPRECATED)) { - - /* Warn exactly once for each lexical place this function is - * called. See thread at - * http://markmail.org/thread/jhqcag5njmx7jpyu */ - - if (! is_common_ptr_table) { - is_common_ptr_table = ptr_table_new(); - } - if (! ptr_table_fetch(is_common_ptr_table, PL_op)) { - Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), - "Calling POSIX::%"HEKf"() is deprecated", - HEKfARG(GvNAME_HEK(CvGV(cv)))); - ptr_table_store(is_common_ptr_table, PL_op, (void *) 1); - } - } - - /*if (e > s) { YYY */ - for (RETVAL = 1; RETVAL && s < e; s++) - if (!isfunc(*s)) - RETVAL = 0; - /*} YYY */ - XSprePUSH; - PUSHi((IV)RETVAL); - } - XSRETURN(1); -} - -MODULE = POSIX PACKAGE = POSIX - -BOOT: -{ - CV *cv; - const char *file = __FILE__; - - - /* silence compiler warning about not_here() defined but not used */ - if (0) not_here(""); - - /* Ensure we get the function, not a macro implementation. Like the C89 - standard says we can... */ -#undef isalnum - cv = newXS("POSIX::isalnum", is_common, file); - XSANY.any_dptr = (any_dptr_t) &isalnum; -#undef isalpha - cv = newXS("POSIX::isalpha", is_common, file); - XSANY.any_dptr = (any_dptr_t) &isalpha; -#undef iscntrl - cv = newXS("POSIX::iscntrl", is_common, file); - XSANY.any_dptr = (any_dptr_t) &iscntrl; -#undef isdigit - cv = newXS("POSIX::isdigit", is_common, file); - XSANY.any_dptr = (any_dptr_t) &isdigit; -#undef isgraph - cv = newXS("POSIX::isgraph", is_common, file); - XSANY.any_dptr = (any_dptr_t) &isgraph; -#undef islower - cv = newXS("POSIX::islower", is_common, file); - XSANY.any_dptr = (any_dptr_t) &islower; -#undef isprint - cv = newXS("POSIX::isprint", is_common, file); - XSANY.any_dptr = (any_dptr_t) &isprint; -#undef ispunct - cv = newXS("POSIX::ispunct", is_common, file); - XSANY.any_dptr = (any_dptr_t) &ispunct; -#undef isspace - cv = newXS("POSIX::isspace", is_common, file); - XSANY.any_dptr = (any_dptr_t) &isspace; -#undef isupper - cv = newXS("POSIX::isupper", is_common, file); - XSANY.any_dptr = (any_dptr_t) &isupper; -#undef isxdigit - cv = newXS("POSIX::isxdigit", is_common, file); - XSANY.any_dptr = (any_dptr_t) &isxdigit; -} - MODULE = SigSet PACKAGE = POSIX::SigSet PREFIX = sig void @@ -636,7 +1799,7 @@ new(packname = "POSIX::SigSet", ...) SysRet addset(sigset, sig) POSIX::SigSet sigset - int sig + POSIX::SigNo sig ALIAS: delset = 1 CODE: @@ -657,7 +1820,7 @@ emptyset(sigset) int sigismember(sigset, sig) POSIX::SigSet sigset - int sig + POSIX::SigNo sig MODULE = Termios PACKAGE = POSIX::Termios PREFIX = cf @@ -683,7 +1846,7 @@ new(packname = "POSIX::Termios", ...) SysRet getattr(termios_ref, fd = 0) POSIX::Termios termios_ref - int fd + POSIX::Fd fd CODE: RETVAL = tcgetattr(fd, termios_ref); OUTPUT: @@ -699,14 +1862,19 @@ getattr(termios_ref, fd = 0) SysRet setattr(termios_ref, fd = 0, optional_actions = DEF_SETATTR_ACTION) POSIX::Termios termios_ref - int fd + POSIX::Fd fd int optional_actions CODE: /* The second argument to the call is mandatory, but we'd like to give it a useful default. 0 isn't valid on all operating systems - on - Solaris (at least) TCSANOW, TCSADRAIN and TCSAFLUSH have the same - values as the equivalent ioctls, TCSETS, TCSETSW and TCSETSF. */ - RETVAL = tcsetattr(fd, optional_actions, termios_ref); + Solaris (at least) TCSANOW, TCSADRAIN and TCSAFLUSH have the same + values as the equivalent ioctls, TCSETS, TCSETSW and TCSETSF. */ + if (optional_actions < 0) { + SETERRNO(EINVAL, LIB_INVARG); + RETVAL = -1; + } else { + RETVAL = tcsetattr(fd, optional_actions, termios_ref); + } OUTPUT: RETVAL @@ -886,7 +2054,7 @@ WEXITSTATUS(status) #endif break; default: - Perl_croak(aTHX_ "Illegal alias %d for POSIX::W*", (int)ix); + croak("Illegal alias %d for POSIX::W*", (int)ix); } OUTPUT: RETVAL @@ -907,8 +2075,16 @@ open(filename, flags = O_RDONLY, mode = 0666) HV * localeconv() CODE: -#ifdef HAS_LOCALECONV +#ifndef HAS_LOCALECONV + localeconv(); /* A stub to call not_here(). */ +#else struct lconv *lcbuf; + + /* localeconv() deals with both LC_NUMERIC and LC_MONETARY, but + * LC_MONETARY is already in the correct locale */ + DECLARATION_FOR_LC_NUMERIC_MANIPULATION; + STORE_LC_NUMERIC_FORCE_TO_UNDERLYING(); + RETVAL = newHV(); sv_2mortal((SV*)RETVAL); if ((lcbuf = localeconv())) { @@ -916,47 +2092,108 @@ localeconv() const struct lconv_offset *integers = lconv_integers; const char *ptr = (const char *) lcbuf; - do { + while (strings->name) { + /* This string may be controlled by either LC_NUMERIC, or + * LC_MONETARY */ + bool is_utf8_locale +#if defined(USE_LOCALE_NUMERIC) && defined(USE_LOCALE_MONETARY) + = _is_cur_LC_category_utf8((isLC_NUMERIC_STRING(strings->name)) + ? LC_NUMERIC + : LC_MONETARY); +#elif defined(USE_LOCALE_NUMERIC) + = _is_cur_LC_category_utf8(LC_NUMERIC); +#elif defined(USE_LOCALE_MONETARY) + = _is_cur_LC_category_utf8(LC_MONETARY); +#else + = FALSE; +#endif + const char *value = *((const char **)(ptr + strings->offset)); - if (value && *value) - (void) hv_store(RETVAL, strings->name, strlen(strings->name), - newSVpv(value, 0), 0); - } while ((++strings)->name); + if (value && *value) { + (void) hv_store(RETVAL, + strings->name, + strlen(strings->name), + newSVpvn_utf8(value, + strlen(value), + + /* We mark it as UTF-8 if a utf8 locale + * and is valid and variant under UTF-8 */ + is_utf8_locale + && ! is_invariant_string((U8 *) value, 0) + && is_utf8_string((U8 *) value, 0)), + 0); + } + strings++; + } - do { + while (integers->name) { const char value = *((const char *)(ptr + integers->offset)); if (value != CHAR_MAX) (void) hv_store(RETVAL, integers->name, strlen(integers->name), newSViv(value), 0); - } while ((++integers)->name); + integers++; + } } -#else - localeconv(); /* A stub to call not_here(). */ -#endif + RESTORE_LC_NUMERIC_STANDARD(); +#endif /* HAS_LOCALECONV */ OUTPUT: RETVAL char * setlocale(category, locale = 0) int category - char * locale + const char * locale PREINIT: char * retval; CODE: +#ifdef USE_LOCALE_NUMERIC + /* A 0 (or NULL) locale means only query what the current one is. We + * have the LC_NUMERIC name saved, because we are normally switched + * into the C locale for it. Switch back so an LC_ALL query will yield + * the correct results; all other categories don't require special + * handling */ + if (locale == 0) { + if (category == LC_NUMERIC) { + XSRETURN_PV(PL_numeric_name); + } +# ifdef LC_ALL + else if (category == LC_ALL) { + SET_NUMERIC_UNDERLYING(); + } +# endif + } +#endif #ifdef WIN32 /* Use wrapper on Windows */ retval = Perl_my_setlocale(aTHX_ category, locale); #else retval = setlocale(category, locale); #endif + DEBUG_L(PerlIO_printf(Perl_debug_log, + "%s:%d: %s\n", __FILE__, __LINE__, + _setlocale_debug_string(category, locale, retval))); if (! retval) { + /* Should never happen that a query would return an error, but be + * sure and reset to C locale */ + if (locale == 0) { + SET_NUMERIC_STANDARD(); + } XSRETURN_UNDEF; } + + /* Save retval since subsequent setlocale() calls may overwrite it. */ + retval = savepv(retval); + SAVEFREEPV(retval); + + /* For locale == 0, we may have switched to NUMERIC_UNDERLYING. Switch + * back */ + if (locale == 0) { + SET_NUMERIC_STANDARD(); + XSRETURN_PV(retval); + } else { - /* Save retval since subsequent setlocale() calls - * may overwrite it. */ - RETVAL = savepv(retval); + RETVAL = retval; #ifdef USE_LOCALE_CTYPE if (category == LC_CTYPE #ifdef LC_ALL @@ -966,8 +2203,12 @@ setlocale(category, locale = 0) { char *newctype; #ifdef LC_ALL - if (category == LC_ALL) + if (category == LC_ALL) { newctype = setlocale(LC_CTYPE, NULL); + DEBUG_Lv(PerlIO_printf(Perl_debug_log, + "%s:%d: %s\n", __FILE__, __LINE__, + _setlocale_debug_string(LC_CTYPE, NULL, newctype))); + } else #endif newctype = RETVAL; @@ -983,8 +2224,12 @@ setlocale(category, locale = 0) { char *newcoll; #ifdef LC_ALL - if (category == LC_ALL) + if (category == LC_ALL) { newcoll = setlocale(LC_COLLATE, NULL); + DEBUG_Lv(PerlIO_printf(Perl_debug_log, + "%s:%d: %s\n", __FILE__, __LINE__, + _setlocale_debug_string(LC_COLLATE, NULL, newcoll))); + } else #endif newcoll = RETVAL; @@ -1000,8 +2245,12 @@ setlocale(category, locale = 0) { char *newnum; #ifdef LC_ALL - if (category == LC_ALL) + if (category == LC_ALL) { newnum = setlocale(LC_NUMERIC, NULL); + DEBUG_Lv(PerlIO_printf(Perl_debug_log, + "%s:%d: %s\n", __FILE__, __LINE__, + _setlocale_debug_string(LC_NUMERIC, NULL, newnum))); + } else #endif newnum = RETVAL; @@ -1011,61 +2260,509 @@ setlocale(category, locale = 0) } OUTPUT: RETVAL - CLEANUP: - Safefree(RETVAL); NV acos(x) NV x ALIAS: - asin = 1 - atan = 2 - ceil = 3 - cosh = 4 - floor = 5 - log10 = 6 - sinh = 7 - tan = 8 - tanh = 9 + acosh = 1 + asin = 2 + asinh = 3 + atan = 4 + atanh = 5 + cbrt = 6 + ceil = 7 + cosh = 8 + erf = 9 + erfc = 10 + exp2 = 11 + expm1 = 12 + floor = 13 + j0 = 14 + j1 = 15 + lgamma = 16 + log10 = 17 + log1p = 18 + log2 = 19 + logb = 20 + nearbyint = 21 + rint = 22 + round = 23 + sinh = 24 + tan = 25 + tanh = 26 + tgamma = 27 + trunc = 28 + y0 = 29 + y1 = 30 CODE: + PERL_UNUSED_VAR(x); + RETVAL = NV_NAN; switch (ix) { case 0: - RETVAL = acos(x); + RETVAL = Perl_acos(x); /* C89 math */ break; case 1: - RETVAL = asin(x); +#ifdef c99_acosh + RETVAL = c99_acosh(x); +#else + not_here("acosh"); +#endif break; case 2: - RETVAL = atan(x); + RETVAL = Perl_asin(x); /* C89 math */ break; case 3: - RETVAL = ceil(x); +#ifdef c99_asinh + RETVAL = c99_asinh(x); +#else + not_here("asinh"); +#endif break; case 4: - RETVAL = cosh(x); + RETVAL = Perl_atan(x); /* C89 math */ break; case 5: - RETVAL = floor(x); +#ifdef c99_atanh + RETVAL = c99_atanh(x); +#else + not_here("atanh"); +#endif break; case 6: - RETVAL = log10(x); +#ifdef c99_cbrt + RETVAL = c99_cbrt(x); +#else + not_here("cbrt"); +#endif break; case 7: - RETVAL = sinh(x); + RETVAL = Perl_ceil(x); /* C89 math */ break; case 8: - RETVAL = tan(x); + RETVAL = Perl_cosh(x); /* C89 math */ + break; + case 9: +#ifdef c99_erf + RETVAL = c99_erf(x); +#else + not_here("erf"); +#endif + break; + case 10: +#ifdef c99_erfc + RETVAL = c99_erfc(x); +#else + not_here("erfc"); +#endif + break; + case 11: +#ifdef c99_exp2 + RETVAL = c99_exp2(x); +#else + not_here("exp2"); +#endif + break; + case 12: +#ifdef c99_expm1 + RETVAL = c99_expm1(x); +#else + not_here("expm1"); +#endif + break; + case 13: + RETVAL = Perl_floor(x); /* C89 math */ + break; + case 14: +#ifdef bessel_j0 + RETVAL = bessel_j0(x); +#else + not_here("j0"); +#endif + break; + case 15: +#ifdef bessel_j1 + RETVAL = bessel_j1(x); +#else + not_here("j1"); +#endif + break; + case 16: + /* XXX Note: the lgamma modifies a global variable (signgam), + * which is evil. Some platforms have lgamma_r, which has + * extra output parameter instead of the global variable. */ +#ifdef c99_lgamma + RETVAL = c99_lgamma(x); +#else + not_here("lgamma"); +#endif + break; + case 17: + RETVAL = log10(x); /* C89 math */ + break; + case 18: +#ifdef c99_log1p + RETVAL = c99_log1p(x); +#else + not_here("log1p"); +#endif + break; + case 19: +#ifdef c99_log2 + RETVAL = c99_log2(x); +#else + not_here("log2"); +#endif + break; + case 20: +#ifdef c99_logb + RETVAL = c99_logb(x); +#elif defined(c99_log2) && FLT_RADIX == 2 + RETVAL = Perl_floor(c99_log2(PERL_ABS(x))); +#else + not_here("logb"); +#endif + break; + case 21: +#ifdef c99_nearbyint + RETVAL = c99_nearbyint(x); +#else + not_here("nearbyint"); +#endif + break; + case 22: +#ifdef c99_rint + RETVAL = c99_rint(x); +#else + not_here("rint"); +#endif break; + case 23: +#ifdef c99_round + RETVAL = c99_round(x); +#else + not_here("round"); +#endif + break; + case 24: + RETVAL = Perl_sinh(x); /* C89 math */ + break; + case 25: + RETVAL = Perl_tan(x); /* C89 math */ + break; + case 26: + RETVAL = Perl_tanh(x); /* C89 math */ + break; + case 27: +#ifdef c99_tgamma + RETVAL = c99_tgamma(x); +#else + not_here("tgamma"); +#endif + break; + case 28: +#ifdef c99_trunc + RETVAL = c99_trunc(x); +#else + not_here("trunc"); +#endif + break; + case 29: +#ifdef bessel_y0 + RETVAL = bessel_y0(x); +#else + not_here("y0"); +#endif + break; + case 30: default: - RETVAL = tanh(x); +#ifdef bessel_y1 + RETVAL = bessel_y1(x); +#else + not_here("y1"); +#endif + } + OUTPUT: + RETVAL + +IV +fegetround() + CODE: +#ifdef HAS_FEGETROUND + RETVAL = my_fegetround(); +#else + RETVAL = -1; + not_here("fegetround"); +#endif + OUTPUT: + RETVAL + +IV +fesetround(x) + IV x + CODE: +#ifdef HAS_FEGETROUND /* canary for fesetround */ + RETVAL = fesetround(x); +#elif defined(HAS_FPGETROUND) /* canary for fpsetround */ + switch (x) { + case FE_TONEAREST: RETVAL = fpsetround(FP_RN); break; + case FE_TOWARDZERO: RETVAL = fpsetround(FP_RZ); break; + case FE_DOWNWARD: RETVAL = fpsetround(FP_RM); break; + case FE_UPWARD: RETVAL = fpsetround(FP_RP); break; + default: RETVAL = -1; break; + } +#elif defined(__osf__) /* Tru64 */ + switch (x) { + case FE_TONEAREST: RETVAL = write_rnd(FP_RND_RN); break; + case FE_TOWARDZERO: RETVAL = write_rnd(FP_RND_RZ); break; + case FE_DOWNWARD: RETVAL = write_rnd(FP_RND_RM); break; + case FE_UPWARD: RETVAL = write_rnd(FP_RND_RP); break; + default: RETVAL = -1; break; + } +#else + PERL_UNUSED_VAR(x); + RETVAL = -1; + not_here("fesetround"); +#endif + OUTPUT: + RETVAL + +IV +fpclassify(x) + NV x + ALIAS: + ilogb = 1 + isfinite = 2 + isinf = 3 + isnan = 4 + isnormal = 5 + lrint = 6 + lround = 7 + signbit = 8 + CODE: + PERL_UNUSED_VAR(x); + RETVAL = -1; + switch (ix) { + case 0: +#ifdef c99_fpclassify + RETVAL = c99_fpclassify(x); +#else + not_here("fpclassify"); +#endif + break; + case 1: +#ifdef c99_ilogb + RETVAL = c99_ilogb(x); +#else + not_here("ilogb"); +#endif + break; + case 2: + RETVAL = Perl_isfinite(x); + break; + case 3: + RETVAL = Perl_isinf(x); + break; + case 4: + RETVAL = Perl_isnan(x); + break; + case 5: +#ifdef c99_isnormal + RETVAL = c99_isnormal(x); +#else + not_here("isnormal"); +#endif + break; + case 6: +#ifdef c99_lrint + RETVAL = c99_lrint(x); +#else + not_here("lrint"); +#endif + break; + case 7: +#ifdef c99_lround + RETVAL = c99_lround(x); +#else + not_here("lround"); +#endif + break; + case 8: + default: +#ifdef Perl_signbit + RETVAL = Perl_signbit(x); +#else + RETVAL = (x < 0) || (x == -0.0); +#endif + break; } OUTPUT: RETVAL NV -fmod(x,y) +getpayload(nv) + NV nv + CODE: + RETVAL = S_getpayload(nv); + OUTPUT: + RETVAL + +void +setpayload(nv, payload) + NV nv + NV payload + CODE: + S_setpayload(&nv, payload, FALSE); + OUTPUT: + nv + +void +setpayloadsig(nv, payload) + NV nv + NV payload + CODE: + nv = NV_NAN; + S_setpayload(&nv, payload, TRUE); + OUTPUT: + nv + +int +issignaling(nv) + NV nv + CODE: + RETVAL = Perl_isnan(nv) && NV_NAN_IS_SIGNALING(&nv); + OUTPUT: + RETVAL + +NV +copysign(x,y) NV x NV y + ALIAS: + fdim = 1 + fmax = 2 + fmin = 3 + fmod = 4 + hypot = 5 + isgreater = 6 + isgreaterequal = 7 + isless = 8 + islessequal = 9 + islessgreater = 10 + isunordered = 11 + nextafter = 12 + nexttoward = 13 + remainder = 14 + CODE: + PERL_UNUSED_VAR(x); + PERL_UNUSED_VAR(y); + RETVAL = NV_NAN; + switch (ix) { + case 0: +#ifdef c99_copysign + RETVAL = c99_copysign(x, y); +#else + not_here("copysign"); +#endif + break; + case 1: +#ifdef c99_fdim + RETVAL = c99_fdim(x, y); +#else + not_here("fdim"); +#endif + break; + case 2: +#ifdef c99_fmax + RETVAL = c99_fmax(x, y); +#else + not_here("fmax"); +#endif + break; + case 3: +#ifdef c99_fmin + RETVAL = c99_fmin(x, y); +#else + not_here("fmin"); +#endif + break; + case 4: + RETVAL = Perl_fmod(x, y); /* C89 math */ + break; + case 5: +#ifdef c99_hypot + RETVAL = c99_hypot(x, y); +#else + not_here("hypot"); +#endif + break; + case 6: +#ifdef c99_isgreater + RETVAL = c99_isgreater(x, y); +#else + not_here("isgreater"); +#endif + break; + case 7: +#ifdef c99_isgreaterequal + RETVAL = c99_isgreaterequal(x, y); +#else + not_here("isgreaterequal"); +#endif + break; + case 8: +#ifdef c99_isless + RETVAL = c99_isless(x, y); +#else + not_here("isless"); +#endif + break; + case 9: +#ifdef c99_islessequal + RETVAL = c99_islessequal(x, y); +#else + not_here("islessequal"); +#endif + break; + case 10: +#ifdef c99_islessgreater + RETVAL = c99_islessgreater(x, y); +#else + not_here("islessgreater"); +#endif + break; + case 11: +#ifdef c99_isunordered + RETVAL = c99_isunordered(x, y); +#else + not_here("isunordered"); +#endif + break; + case 12: +#ifdef c99_nextafter + RETVAL = c99_nextafter(x, y); +#else + not_here("nextafter"); +#endif + break; + case 13: +#ifdef c99_nexttoward + RETVAL = c99_nexttoward(x, y); +#else + not_here("nexttoward"); +#endif + break; + case 14: + default: +#ifdef c99_remainder + RETVAL = c99_remainder(x, y); +#else + not_here("remainder"); +#endif + break; + } + OUTPUT: + RETVAL void frexp(x) @@ -1073,7 +2770,7 @@ frexp(x) PPCODE: int expvar; /* (We already know stack is long enough.) */ - PUSHs(sv_2mortal(newSVnv(frexp(x,&expvar)))); + PUSHs(sv_2mortal(newSVnv(Perl_frexp(x,&expvar)))); /* C89 math */ PUSHs(sv_2mortal(newSViv(expvar))); NV @@ -1087,19 +2784,127 @@ modf(x) PPCODE: NV intvar; /* (We already know stack is long enough.) */ - PUSHs(sv_2mortal(newSVnv(Perl_modf(x,&intvar)))); + PUSHs(sv_2mortal(newSVnv(Perl_modf(x,&intvar)))); /* C89 math */ PUSHs(sv_2mortal(newSVnv(intvar))); +void +remquo(x,y) + NV x + NV y + PPCODE: +#ifdef c99_remquo + int intvar; + PUSHs(sv_2mortal(newSVnv(c99_remquo(x,y,&intvar)))); + PUSHs(sv_2mortal(newSVnv(intvar))); +#else + PERL_UNUSED_VAR(x); + PERL_UNUSED_VAR(y); + not_here("remquo"); +#endif + +NV +scalbn(x,y) + NV x + IV y + CODE: +#ifdef c99_scalbn + RETVAL = c99_scalbn(x, y); +#else + PERL_UNUSED_VAR(x); + PERL_UNUSED_VAR(y); + RETVAL = NV_NAN; + not_here("scalbn"); +#endif + OUTPUT: + RETVAL + +NV +fma(x,y,z) + NV x + NV y + NV z + CODE: +#ifdef c99_fma + RETVAL = c99_fma(x, y, z); +#else + PERL_UNUSED_VAR(x); + PERL_UNUSED_VAR(y); + PERL_UNUSED_VAR(z); + not_here("fma"); +#endif + OUTPUT: + RETVAL + +NV +nan(payload = 0) + NV payload + CODE: +#ifdef NV_NAN + /* If no payload given, just return the default NaN. + * This makes a difference in platforms where the default + * NaN is not all zeros. */ + if (items == 0) { + RETVAL = NV_NAN; + } else { + S_setpayload(&RETVAL, payload, FALSE); + } +#elif defined(c99_nan) + { + STRLEN elen = my_snprintf(PL_efloatbuf, PL_efloatsize, "%g", nv); + if ((IV)elen == -1) { + RETVAL = NV_NAN; + } else { + RETVAL = c99_nan(PL_efloatbuf); + } + } +#else + not_here("nan"); +#endif + OUTPUT: + RETVAL + +NV +jn(x,y) + IV x + NV y + ALIAS: + yn = 1 + CODE: + RETVAL = NV_NAN; + switch (ix) { + case 0: +#ifdef bessel_jn + RETVAL = bessel_jn(x, y); +#else + PERL_UNUSED_VAR(x); + PERL_UNUSED_VAR(y); + not_here("jn"); +#endif + break; + case 1: + default: +#ifdef bessel_yn + RETVAL = bessel_yn(x, y); +#else + PERL_UNUSED_VAR(x); + PERL_UNUSED_VAR(y); + not_here("yn"); +#endif + break; + } + OUTPUT: + RETVAL + SysRet sigaction(sig, optaction, oldaction = 0) int sig SV * optaction POSIX::SigAction oldaction CODE: -#if defined(WIN32) || defined(NETWARE) +#if defined(WIN32) || defined(NETWARE) || (defined(__amigaos4__) && defined(__NEWLIB__)) RETVAL = not_here("sigaction"); #else -# This code is really grody because we're trying to make the signal +# This code is really grody because we are trying to make the signal # interface look beautiful, which is hard. { @@ -1286,7 +3091,11 @@ sigpending(sigset) ALIAS: sigsuspend = 1 CODE: +#ifdef __amigaos4__ + RETVAL = not_here("sigpending"); +#else RETVAL = ix ? sigsuspend(sigset) : sigpending(sigset); +#endif OUTPUT: RETVAL CLEANUP: @@ -1323,26 +3132,34 @@ dup2(fd1, fd2) int fd1 int fd2 CODE: + if (fd1 >= 0 && fd2 >= 0) { #ifdef WIN32 - /* RT #98912 - More Microsoft muppetry - failing to actually implemented - the well known documented POSIX behaviour for a POSIX API. - http://msdn.microsoft.com/en-us/library/8syseb29.aspx */ - RETVAL = dup2(fd1, fd2) == -1 ? -1 : fd2; + /* RT #98912 - More Microsoft muppetry - failing to + actually implemented the well known documented POSIX + behaviour for a POSIX API. + http://msdn.microsoft.com/en-us/library/8syseb29.aspx */ + RETVAL = dup2(fd1, fd2) == -1 ? -1 : fd2; #else - RETVAL = dup2(fd1, fd2); + RETVAL = dup2(fd1, fd2); #endif + } else { + SETERRNO(EBADF,RMS_IFI); + RETVAL = -1; + } OUTPUT: RETVAL SV * lseek(fd, offset, whence) - int fd + POSIX::Fd fd Off_t offset int whence CODE: - Off_t pos = PerlLIO_lseek(fd, offset, whence); - RETVAL = sizeof(Off_t) > sizeof(IV) - ? newSVnv((NV)pos) : newSViv((IV)pos); + { + Off_t pos = PerlLIO_lseek(fd, offset, whence); + RETVAL = sizeof(Off_t) > sizeof(IV) + ? newSVnv((NV)pos) : newSViv((IV)pos); + } OUTPUT: RETVAL @@ -1373,7 +3190,7 @@ read(fd, buffer, nbytes) PREINIT: SV *sv_buffer = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1); INPUT: - int fd + POSIX::Fd fd size_t nbytes char * buffer = sv_grow( sv_buffer, nbytes+1 ); CLEANUP: @@ -1394,11 +3211,11 @@ setsid() pid_t tcgetpgrp(fd) - int fd + POSIX::Fd fd SysRet tcsetpgrp(fd, pgrp_id) - int fd + POSIX::Fd fd pid_t pgrp_id void @@ -1420,7 +3237,7 @@ uname() SysRet write(fd, buffer, nbytes) - int fd + POSIX::Fd fd char * buffer size_t nbytes @@ -1430,8 +3247,21 @@ tmpnam() STRLEN i; int len; CODE: - RETVAL = newSVpvn("", 0); + 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: @@ -1480,40 +3310,74 @@ strtod(str) double num; char *unparsed; PPCODE: - STORE_NUMERIC_STANDARD_FORCE_LOCAL(); + DECLARATION_FOR_LC_NUMERIC_MANIPULATION; + STORE_LC_NUMERIC_FORCE_TO_UNDERLYING(); num = strtod(str, &unparsed); PUSHs(sv_2mortal(newSVnv(num))); - if (GIMME == G_ARRAY) { + if (GIMME_V == G_ARRAY) { EXTEND(SP, 1); if (unparsed) PUSHs(sv_2mortal(newSViv(strlen(unparsed)))); else PUSHs(&PL_sv_undef); } - RESTORE_NUMERIC_STANDARD(); + RESTORE_LC_NUMERIC_STANDARD(); + +#ifdef HAS_STRTOLD void -strtol(str, base = 0) +strtold(str) char * str - int base PREINIT: - long num; + long double num; char *unparsed; PPCODE: - num = strtol(str, &unparsed, base); -#if IVSIZE <= LONGSIZE - if (num < IV_MIN || num > IV_MAX) - PUSHs(sv_2mortal(newSVnv((double)num))); - else -#endif - PUSHs(sv_2mortal(newSViv((IV)num))); - if (GIMME == G_ARRAY) { + DECLARATION_FOR_LC_NUMERIC_MANIPULATION; + STORE_LC_NUMERIC_FORCE_TO_UNDERLYING(); + num = strtold(str, &unparsed); + PUSHs(sv_2mortal(newSVnv(num))); + if (GIMME_V == G_ARRAY) { EXTEND(SP, 1); if (unparsed) PUSHs(sv_2mortal(newSViv(strlen(unparsed)))); else PUSHs(&PL_sv_undef); } + RESTORE_LC_NUMERIC_STANDARD(); + +#endif + +void +strtol(str, base = 0) + char * str + int base + PREINIT: + long num; + char *unparsed; + PPCODE: + if (base == 0 || (base >= 2 && base <= 36)) { + num = strtol(str, &unparsed, base); +#if IVSIZE < LONGSIZE + if (num < IV_MIN || num > IV_MAX) + PUSHs(sv_2mortal(newSVnv((double)num))); + else +#endif + PUSHs(sv_2mortal(newSViv((IV)num))); + if (GIMME_V == G_ARRAY) { + EXTEND(SP, 1); + if (unparsed) + PUSHs(sv_2mortal(newSViv(strlen(unparsed)))); + else + PUSHs(&PL_sv_undef); + } + } else { + SETERRNO(EINVAL, LIB_INVARG); + PUSHs(&PL_sv_undef); + if (GIMME_V == G_ARRAY) { + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + } + } void strtoul(str, base = 0) @@ -1523,20 +3387,31 @@ strtoul(str, base = 0) unsigned long num; char *unparsed; PPCODE: - num = strtoul(str, &unparsed, base); + PERL_UNUSED_VAR(str); + PERL_UNUSED_VAR(base); + if (base == 0 || (base >= 2 && base <= 36)) { + num = strtoul(str, &unparsed, base); #if IVSIZE <= LONGSIZE - if (num > IV_MAX) - PUSHs(sv_2mortal(newSVnv((double)num))); - else -#endif - PUSHs(sv_2mortal(newSViv((IV)num))); - if (GIMME == G_ARRAY) { - EXTEND(SP, 1); - if (unparsed) - PUSHs(sv_2mortal(newSViv(strlen(unparsed)))); - else - PUSHs(&PL_sv_undef); - } + if (num > IV_MAX) + PUSHs(sv_2mortal(newSVnv((double)num))); + else +#endif + PUSHs(sv_2mortal(newSViv((IV)num))); + if (GIMME_V == G_ARRAY) { + EXTEND(SP, 1); + if (unparsed) + PUSHs(sv_2mortal(newSViv(strlen(unparsed)))); + else + PUSHs(&PL_sv_undef); + } + } else { + SETERRNO(EINVAL, LIB_INVARG); + PUSHs(&PL_sv_undef); + if (GIMME_V == G_ARRAY) { + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + } + } void strxfrm(src) @@ -1545,11 +3420,13 @@ strxfrm(src) { STRLEN srclen; STRLEN dstlen; + STRLEN buflen; char *p = SvPV(src,srclen); srclen++; - ST(0) = sv_2mortal(newSV(srclen*4+1)); - dstlen = strxfrm(SvPVX(ST(0)), p, (size_t)srclen); - if (dstlen > srclen) { + buflen = srclen * 4 + 1; + ST(0) = sv_2mortal(newSV(buflen)); + dstlen = strxfrm(SvPVX(ST(0)), p, (size_t)buflen); + if (dstlen >= buflen) { dstlen++; SvGROW(ST(0), dstlen); strxfrm(SvPVX(ST(0)), p, (size_t)dstlen); @@ -1577,27 +3454,37 @@ mkfifo(filename, mode) SysRet tcdrain(fd) - int fd + POSIX::Fd fd ALIAS: close = 1 dup = 2 CODE: - RETVAL = ix == 1 ? close(fd) - : (ix < 1 ? tcdrain(fd) : dup(fd)); + if (fd >= 0) { + RETVAL = ix == 1 ? close(fd) + : (ix < 1 ? tcdrain(fd) : dup(fd)); + } else { + SETERRNO(EBADF,RMS_IFI); + RETVAL = -1; + } OUTPUT: RETVAL SysRet tcflow(fd, action) - int fd + POSIX::Fd fd int action ALIAS: tcflush = 1 tcsendbreak = 2 CODE: - RETVAL = ix == 1 ? tcflush(fd, action) - : (ix < 1 ? tcflow(fd, action) : tcsendbreak(fd, action)); + if (action >= 0) { + RETVAL = ix == 1 ? tcflush(fd, action) + : (ix < 1 ? tcflow(fd, action) : tcsendbreak(fd, action)); + } else { + SETERRNO(EINVAL,LIB_INVARG); + RETVAL = -1; + } OUTPUT: RETVAL @@ -1686,6 +3573,7 @@ strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1) CODE: { char *buf; + SV *sv; /* allowing user-supplied (rather than literal) formats * is normally frowned upon as a potential security risk; @@ -1693,14 +3581,30 @@ strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1) GCC_DIAG_IGNORE(-Wformat-nonliteral); buf = my_strftime(SvPV_nolen(fmt), sec, min, hour, mday, mon, year, wday, yday, isdst); GCC_DIAG_RESTORE; + sv = sv_newmortal(); if (buf) { - SV *const sv = sv_newmortal(); - sv_usepvn_flags(sv, buf, strlen(buf), SV_HAS_TRAILING_NUL); - if (SvUTF8(fmt)) { + STRLEN len = strlen(buf); + sv_usepvn_flags(sv, buf, len, SV_HAS_TRAILING_NUL); + if (SvUTF8(fmt) + || (! is_invariant_string((U8*) buf, len) + && is_utf8_string((U8*) buf, len) +#ifdef USE_LOCALE_TIME + && _is_cur_LC_category_utf8(LC_TIME) +#endif + )) { SvUTF8_on(sv); } - ST(0) = sv; - } + } + else { /* We can't distinguish between errors and just an empty + * return; in all cases just return an empty string */ + SvUPGRADE(sv, SVt_PV); + SvPV_set(sv, (char *) ""); + SvPOK_on(sv); + SvCUR_set(sv, 0); + SvLEN_set(sv, 0); /* Won't attempt to free the string when sv + gets destroyed */ + } + ST(0) = sv; } void @@ -1737,6 +3641,7 @@ cuserid(s = 0) #ifdef HAS_CUSERID RETVAL = cuserid(s); #else + PERL_UNUSED_VAR(s); RETVAL = 0; not_here("cuserid"); #endif @@ -1745,7 +3650,7 @@ cuserid(s = 0) SysRetLong fpathconf(fd, name) - int fd + POSIX::Fd fd int name SysRetLong @@ -1780,7 +3685,7 @@ sysconf(name) char * ttyname(fd) - int fd + POSIX::Fd fd void getcwd() @@ -1802,6 +3707,9 @@ lchown(uid, gid, path) * but consistent with CORE::chown() */ RETVAL = lchown(path, uid, gid); #else + PERL_UNUSED_VAR(uid); + PERL_UNUSED_VAR(gid); + PERL_UNUSED_VAR(path); RETVAL = not_here("lchown"); #endif OUTPUT: diff --git a/gnu/usr.bin/perl/ext/POSIX/hints/next_3.pl b/gnu/usr.bin/perl/ext/POSIX/hints/next_3.pl deleted file mode 100644 index d90778398b2..00000000000 --- a/gnu/usr.bin/perl/ext/POSIX/hints/next_3.pl +++ /dev/null @@ -1,5 +0,0 @@ -# NeXT *does* have setpgid when we use the -posix flag, but -# doesn't when we don't. The main perl sources are compiled -# without -posix, so the hints/next_3.sh hint file tells Configure -# that d_setpgid=undef. -$self->{CCFLAGS} = $Config{ccflags} . ' -posix -DHAS_SETPGID' ; diff --git a/gnu/usr.bin/perl/ext/POSIX/lib/POSIX.pm b/gnu/usr.bin/perl/ext/POSIX/lib/POSIX.pm index 78ffe2f3183..05bdbbe7e6d 100644 --- a/gnu/usr.bin/perl/ext/POSIX/lib/POSIX.pm +++ b/gnu/usr.bin/perl/ext/POSIX/lib/POSIX.pm @@ -4,7 +4,7 @@ use warnings; our ($AUTOLOAD, %SIGRT); -our $VERSION = '1.38_03'; +our $VERSION = '1.65'; require XSLoader; @@ -151,7 +151,7 @@ my %reimpl = ( exit => 'status => CORE::exit($_[0])', getenv => 'name => $ENV{$_[0]}', system => 'command => CORE::system($_[0])', - strerror => 'errno => local $! = $_[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. @@ -234,7 +234,7 @@ sub sprintf { } sub load_imports { -our %EXPORT_TAGS = ( +my %default_export_tags = ( # cf. exports policy below assert_h => [qw(assert NDEBUG)], @@ -296,8 +296,13 @@ our %EXPORT_TAGS = ( LC_MONETARY LC_NUMERIC LC_TIME NULL localeconv setlocale)], - math_h => [qw(HUGE_VAL acos asin atan ceil cosh fabs floor fmod - frexp ldexp log10 modf pow sinh tan tanh)], + math_h => [qw(FP_ILOGB0 FP_ILOGBNAN FP_INFINITE FP_NAN FP_NORMAL + FP_SUBNORMAL FP_ZERO + M_1_PI M_2_PI M_2_SQRTPI M_E M_LN10 M_LN2 M_LOG10E M_LOG2E + M_PI M_PI_2 M_PI_4 M_SQRT1_2 M_SQRT2 + HUGE_VAL INFINITY NAN + acos asin atan ceil cosh fabs floor fmod + frexp ldexp log10 modf pow sinh tan tanh)], pwd_h => [], @@ -384,18 +389,74 @@ our %EXPORT_TAGS = ( utime_h => [], ); -# Exporter::export_tags(); +if ($^O eq 'MSWin32') { + $default_export_tags{winsock_h} = [qw( + WSAEINTR WSAEBADF WSAEACCES WSAEFAULT WSAEINVAL WSAEMFILE WSAEWOULDBLOCK + WSAEINPROGRESS WSAEALREADY WSAENOTSOCK WSAEDESTADDRREQ WSAEMSGSIZE + WSAEPROTOTYPE WSAENOPROTOOPT WSAEPROTONOSUPPORT WSAESOCKTNOSUPPORT + WSAEOPNOTSUPP WSAEPFNOSUPPORT WSAEAFNOSUPPORT WSAEADDRINUSE + WSAEADDRNOTAVAIL WSAENETDOWN WSAENETUNREACH WSAENETRESET WSAECONNABORTED + WSAECONNRESET WSAENOBUFS WSAEISCONN WSAENOTCONN WSAESHUTDOWN + WSAETOOMANYREFS WSAETIMEDOUT WSAECONNREFUSED WSAELOOP WSAENAMETOOLONG + WSAEHOSTDOWN WSAEHOSTUNREACH WSAENOTEMPTY WSAEPROCLIM WSAEUSERS + WSAEDQUOT WSAESTALE WSAEREMOTE WSAEDISCON WSAENOMORE WSAECANCELLED + WSAEINVALIDPROCTABLE WSAEINVALIDPROVIDER WSAEPROVIDERFAILEDINIT + WSAEREFUSED)]; +} + +my %other_export_tags = ( # cf. exports policy below + fenv_h => [qw( + FE_DOWNWARD FE_TONEAREST FE_TOWARDZERO FE_UPWARD fegetround fesetround + )], + + math_h_c99 => [ @{$default_export_tags{math_h}}, qw( + Inf NaN acosh asinh atanh cbrt copysign erf erfc exp2 expm1 fdim fma + fmax fmin fpclassify hypot ilogb isfinite isgreater isgreaterequal + isinf isless islessequal islessgreater isnan isnormal isunordered j0 j1 + jn lgamma log1p log2 logb lrint nan nearbyint nextafter nexttoward + remainder remquo rint round scalbn signbit tgamma trunc y0 y1 yn + )], + + stdlib_h_c99 => [ @{$default_export_tags{stdlib_h}}, 'strtold' ], + + nan_payload => [ qw(getpayload setpayload setpayloadsig issignaling) ], + + signal_h_si_code => [qw( + ILL_ILLOPC ILL_ILLOPN ILL_ILLADR ILL_ILLTRP ILL_PRVOPC ILL_PRVREG + ILL_COPROC ILL_BADSTK + FPE_INTDIV FPE_INTOVF FPE_FLTDIV FPE_FLTOVF FPE_FLTUND + FPE_FLTRES FPE_FLTINV FPE_FLTSUB + SEGV_MAPERR SEGV_ACCERR + BUS_ADRALN BUS_ADRERR BUS_OBJERR + TRAP_BRKPT TRAP_TRACE + CLD_EXITED CLD_KILLED CLD_DUMPED CLD_TRAPPED CLD_STOPPED CLD_CONTINUED + POLL_IN POLL_OUT POLL_MSG POLL_ERR POLL_PRI POLL_HUP + SI_USER SI_QUEUE SI_TIMER SI_ASYNCIO SI_MESGQ + )], +); + +# exports policy: +# - new functions may not be added to @EXPORT, only to @EXPORT_OK +# - new SHOUTYCONSTANTS are OK to add to @EXPORT + { # De-duplicate the export list: - my %export; - @export{map {@$_} values %EXPORT_TAGS} = (); + my ( %export, %export_ok ); + @export {map {@$_} values %default_export_tags} = (); + @export_ok{map {@$_} values %other_export_tags} = (); # Doing the de-dup with a temporary hash has the advantage that the SVs in # @EXPORT are actually shared hash key scalars, which will save some memory. our @EXPORT = keys %export; + # you do not want to add symbols to the following list. add a new tag instead our @EXPORT_OK = (qw(close lchown nice open pipe read sleep times write - printf sprintf), - grep {!exists $export{$_}} keys %reimpl, keys %replacement); + printf sprintf lround), + # lround() should really be in the :math_h_c99 tag, but + # we're too far into the 5.24 code freeze for that to be + # done now. This can be revisited in the 5.25.x cycle. + grep {!exists $export{$_}} keys %reimpl, keys %replacement, keys %export_ok); + + our %EXPORT_TAGS = ( %default_export_tags, %other_export_tags ); } require Exporter; diff --git a/gnu/usr.bin/perl/ext/POSIX/lib/POSIX.pod b/gnu/usr.bin/perl/ext/POSIX/lib/POSIX.pod index f72beb6aa5b..1d263a7bc40 100644 --- a/gnu/usr.bin/perl/ext/POSIX/lib/POSIX.pod +++ b/gnu/usr.bin/perl/ext/POSIX/lib/POSIX.pod @@ -21,15 +21,6 @@ The POSIX module permits you to access all (or nearly all) the standard POSIX 1003.1 identifiers. Many of these identifiers have been given Perl-ish interfaces. -I<Everything is exported by default> with the exception of any POSIX -functions with the same name as a built-in Perl function, such as -C<abs>, C<alarm>, C<rmdir>, C<write>, etc.., which will be exported -only if you ask for them explicitly. This is an unfortunate backwards -compatibility feature. You can stop the exporting by saying S<C<use -POSIX ()>> and then use the fully qualified names (I<e.g.>, C<POSIX::SEEK_END>), -or by giving an explicit import list. If you do neither, and opt for the -default, S<C<use POSIX;>> has to import I<553 symbols>. - This document gives a condensed list of the features available in the POSIX module. Consult your operating system's manpages for general information on most features. Consult L<perlfunc> for functions which are noted as being @@ -43,6 +34,15 @@ constants and macros in an organization which roughly follows IEEE Std =head1 CAVEATS +I<Everything is exported by default> (with a handful of exceptions). +This is an unfortunate backwards compatibility feature and its use is +B<strongly L<discouraged|perlpolicy/discouraged>>. +You should either prevent the exporting (by saying S<C<use POSIX ();>>, +as usual) and then use fully qualified names (e.g. C<POSIX::SEEK_END>), +or give an explicit import list. +If you do neither and opt for the default (as in S<C<use POSIX;>>), you +will import I<hundreds and hundreds> of symbols into your namespace. + A few functions are not implemented because they are C specific. If you attempt to call these, they will print a message telling you that they aren't implemented, and suggest using the Perl equivalent, should one @@ -102,6 +102,12 @@ I<race condition>. This is identical to the C function C<acos()>, returning the arcus cosine of its numerical argument. See also L<Math::Trig>. +=item C<acosh> + +This is identical to the C function C<acosh()>, returning the +hyperbolic arcus cosine of its numerical argument [C99]. See also +L<Math::Trig>. + =item C<alarm> This is identical to Perl's builtin C<alarm()> function, @@ -128,6 +134,12 @@ The C<$mon> is zero-based: January equals C<0>. The C<$year> is This is identical to the C function C<asin()>, returning the arcus sine of its numerical argument. See also L<Math::Trig>. +=item C<asinh> + +This is identical to the C function C<asinh()>, returning the +hyperbolic arcus sine of its numerical argument [C99]. See also +L<Math::Trig>. + =item C<assert> Unimplemented, but you can use L<perlfunc/die> and the L<Carp> module @@ -138,6 +150,12 @@ to achieve similar things. This is identical to the C function C<atan()>, returning the arcus tangent of its numerical argument. See also L<Math::Trig>. +=item C<atanh> + +This is identical to the C function C<atanh()>, returning the +hyperbolic arcus tangent of its numerical argument [C99]. See also +L<Math::Trig>. + =item C<atan2> This is identical to Perl's builtin C<atan2()> function, returning @@ -146,22 +164,22 @@ coordinate and the I<x> coordinate. See also L<Math::Trig>. =item C<atexit> -C<atexit()> is C-specific: use C<END {}> instead, see L<perlmod>. +Not implemented. C<atexit()> is C-specific: use C<END {}> instead, see L<perlmod>. =item C<atof> -C<atof()> is C-specific. Perl converts strings to numbers transparently. +Not implemented. C<atof()> is C-specific. Perl converts strings to numbers transparently. If you need to force a scalar to a number, add a zero to it. =item C<atoi> -C<atoi()> is C-specific. Perl converts strings to numbers transparently. +Not implemented. C<atoi()> is C-specific. Perl converts strings to numbers transparently. If you need to force a scalar to a number, add a zero to it. If you need to have just the integer part, see L<perlfunc/int>. =item C<atol> -C<atol()> is C-specific. Perl converts strings to numbers transparently. +Not implemented. C<atol()> is C-specific. Perl converts strings to numbers transparently. If you need to force a scalar to a number, add a zero to it. If you need to have just the integer part, see L<perlfunc/int>. @@ -172,7 +190,11 @@ see L<Search::Dict>. =item C<calloc> -C<calloc()> is C-specific. Perl does memory management transparently. +Not implemented. C<calloc()> is C-specific. Perl does memory management transparently. + +=item C<cbrt> + +The cube root [C99]. =item C<ceil> @@ -196,7 +218,7 @@ to change file and directory owners and groups, see L<perlfunc/chown>. =item C<clearerr> -Use the method C<IO::Handle::clearerr()> instead, to reset the error +Not implemented. Use the method C<IO::Handle::clearerr()> instead, to reset the error state (if any) and EOF state (if any) of the given stream. =item C<clock> @@ -232,6 +254,14 @@ See also L<Math::Trig>. This is identical to the C function C<cosh()>, for returning the hyperbolic cosine of its numeric argument. See also L<Math::Trig>. +=item C<copysign> + +Returns C<x> but with the sign of C<y> [C99]. + + $x_with_sign_of_y = POSIX::copysign($x, $y); + +See also L</signbit>. + =item C<creat> Create a new file. This returns a file descriptor like the ones returned by @@ -267,7 +297,7 @@ by C<time()>), see L</time>. =item C<div> -C<div()> is C-specific, use L<perlfunc/int> on the usual C</> division and +Not implemented. C<div()> is C-specific, use L<perlfunc/int> on the usual C</> division and the modulus C<%>. =item C<dup> @@ -290,6 +320,14 @@ C<POSIX::open>. Returns C<undef> on failure. +=item C<erf> + +The error function [C99]. + +=item C<erfc> + +The complementary error function [C99]. + =item C<errno> Returns the value of errno. @@ -300,27 +338,27 @@ This identical to the numerical values of the C<$!>, see L<perlvar/$ERRNO>. =item C<execl> -C<execl()> is C-specific, see L<perlfunc/exec>. +Not implemented. C<execl()> is C-specific, see L<perlfunc/exec>. =item C<execle> -C<execle()> is C-specific, see L<perlfunc/exec>. +Not implemented. C<execle()> is C-specific, see L<perlfunc/exec>. =item C<execlp> -C<execlp()> is C-specific, see L<perlfunc/exec>. +Not implemented. C<execlp()> is C-specific, see L<perlfunc/exec>. =item C<execv> -C<execv()> is C-specific, see L<perlfunc/exec>. +Not implemented. C<execv()> is C-specific, see L<perlfunc/exec>. =item C<execve> -C<execve()> is C-specific, see L<perlfunc/exec>. +Not implemented. C<execve()> is C-specific, see L<perlfunc/exec>. =item C<execvp> -C<execvp()> is C-specific, see L<perlfunc/exec>. +Not implemented. C<execvp()> is C-specific, see L<perlfunc/exec>. =item C<exit> @@ -333,6 +371,12 @@ This is identical to Perl's builtin C<exp()> function for returning the exponent (I<e>-based) of the numerical argument, see L<perlfunc/exp>. +=item C<expm1> + +Equivalent to C<exp(x) - 1>, but more precise for small argument values [C99]. + +See also L</log1p>. + =item C<fabs> This is identical to Perl's builtin C<abs()> function for returning @@ -340,7 +384,7 @@ the absolute value of the numerical argument, see L<perlfunc/abs>. =item C<fclose> -Use method C<IO::Handle::close()> instead, or see L<perlfunc/close>. +Not implemented. Use method C<IO::Handle::close()> instead, or see L<perlfunc/close>. =item C<fcntl> @@ -349,56 +393,91 @@ see L<perlfunc/fcntl>. =item C<fdopen> -Use method C<IO::Handle::new_from_fd()> instead, or see L<perlfunc/open>. +Not implemented. Use method C<IO::Handle::new_from_fd()> instead, or see L<perlfunc/open>. =item C<feof> -Use method C<IO::Handle::eof()> instead, or see L<perlfunc/eof>. +Not implemented. Use method C<IO::Handle::eof()> instead, or see L<perlfunc/eof>. =item C<ferror> -Use method C<IO::Handle::error()> instead. +Not implemented. Use method C<IO::Handle::error()> instead. =item C<fflush> -Use method C<IO::Handle::flush()> instead. +Not implemented. Use method C<IO::Handle::flush()> instead. See also C<L<perlvar/$OUTPUT_AUTOFLUSH>>. =item C<fgetc> -Use method C<IO::Handle::getc()> instead, or see L<perlfunc/read>. +Not implemented. Use method C<IO::Handle::getc()> instead, or see L<perlfunc/read>. =item C<fgetpos> -Use method C<IO::Seekable::getpos()> instead, or see L<perlfunc/seek>. +Not implemented. Use method C<IO::Seekable::getpos()> instead, or see L<perlfunc/seek>. =item C<fgets> -Use method C<IO::Handle::gets()> instead. Similar to E<lt>E<gt>, also known +Not implemented. Use method C<IO::Handle::gets()> instead. Similar to E<lt>E<gt>, also known as L<perlfunc/readline>. =item C<fileno> -Use method C<IO::Handle::fileno()> instead, or see L<perlfunc/fileno>. +Not implemented. Use method C<IO::Handle::fileno()> instead, or see L<perlfunc/fileno>. =item C<floor> This is identical to the C function C<floor()>, returning the largest integer value less than or equal to the numerical argument. +=item C<fdim> + +"Positive difference", S<C<x - y>> if S<C<x E<gt> y>>, zero otherwise [C99]. + +=item C<fegetround> + +Returns the current floating point rounding mode, one of + + FE_TONEAREST FE_TOWARDZERO FE_UPWARD FE_UPWARD + +C<FE_TONEAREST> is like L</round>, C<FE_TOWARDZERO> is like L</trunc> [C99]. + +=item C<fesetround> + +Sets the floating point rounding mode, see L</fegetround> [C99]. + +=item C<fma> + +"Fused multiply-add", S<C<x * y + z>>, possibly faster (and less lossy) +than the explicit two operations [C99]. + + my $fused = POSIX::fma($x, $y, $z); + +=item C<fmax> + +Maximum of C<x> and C<y>, except when either is C<NaN>, returns the other [C99]. + + my $min = POSIX::fmax($x, $y); + +=item C<fmin> + +Minimum of C<x> and C<y>, except when either is C<NaN>, returns the other [C99]. + + my $min = POSIX::fmin($x, $y); + =item C<fmod> This is identical to the C function C<fmod()>. $r = fmod($x, $y); -It returns the remainder C<$r = $x - $n*$y>, where C<$n = trunc($x/$y)>. +It returns the remainder S<C<$r = $x - $n*$y>>, where S<C<$n = trunc($x/$y)>>. The C<$r> has the same sign as C<$x> and magnitude (absolute value) less than the magnitude of C<$y>. =item C<fopen> -Use method C<IO::File::open()> instead, or see L<perlfunc/open>. +Not implemented. Use method C<IO::File::open()> instead, or see L<perlfunc/open>. =item C<fork> @@ -419,29 +498,40 @@ pathname on the filesystem which holds F</var/foo>. Returns C<undef> on failure. +=item C<fpclassify> + +Returns one of + + FP_NORMAL FP_ZERO FP_SUBNORMAL FP_INFINITE FP_NAN + +telling the class of the argument [C99]. C<FP_INFINITE> is positive +or negative infinity, C<FP_NAN> is not-a-number. C<FP_SUBNORMAL> +means subnormal numbers (also known as denormals), very small numbers +with low precision. C<FP_ZERO> is zero. C<FP_NORMAL> is all the rest. + =item C<fprintf> -C<fprintf()> is C-specific, see L<perlfunc/printf> instead. +Not implemented. C<fprintf()> is C-specific, see L<perlfunc/printf> instead. =item C<fputc> -C<fputc()> is C-specific, see L<perlfunc/print> instead. +Not implemented. C<fputc()> is C-specific, see L<perlfunc/print> instead. =item C<fputs> -C<fputs()> is C-specific, see L<perlfunc/print> instead. +Not implemented. C<fputs()> is C-specific, see L<perlfunc/print> instead. =item C<fread> -C<fread()> is C-specific, see L<perlfunc/read> instead. +Not implemented. C<fread()> is C-specific, see L<perlfunc/read> instead. =item C<free> -C<free()> is C-specific. Perl does memory management transparently. +Not implemented. C<free()> is C-specific. Perl does memory management transparently. =item C<freopen> -C<freopen()> is C-specific, see L<perlfunc/open> instead. +Not implemented. C<freopen()> is C-specific, see L<perlfunc/open> instead. =item C<frexp> @@ -451,15 +541,15 @@ Return the mantissa and exponent of a floating-point number. =item C<fscanf> -C<fscanf()> is C-specific, use E<lt>E<gt> and regular expressions instead. +Not implemented. C<fscanf()> is C-specific, use E<lt>E<gt> and regular expressions instead. =item C<fseek> -Use method C<IO::Seekable::seek()> instead, or see L<perlfunc/seek>. +Not implemented. Use method C<IO::Seekable::seek()> instead, or see L<perlfunc/seek>. =item C<fsetpos> -Use method C<IO::Seekable::setpos()> instead, or seek L<perlfunc/seek>. +Not implemented. Use method C<IO::Seekable::setpos()> instead, or seek L<perlfunc/seek>. =item C<fstat> @@ -472,15 +562,15 @@ Perl's builtin C<stat> function. =item C<fsync> -Use method C<IO::Handle::sync()> instead. +Not implemented. Use method C<IO::Handle::sync()> instead. =item C<ftell> -Use method C<IO::Seekable::tell()> instead, or see L<perlfunc/tell>. +Not implemented. Use method C<IO::Seekable::tell()> instead, or see L<perlfunc/tell>. =item C<fwrite> -C<fwrite()> is C-specific, see L<perlfunc/print> instead. +Not implemented. C<fwrite()> is C-specific, see L<perlfunc/print> instead. =item C<getc> @@ -539,6 +629,17 @@ This is identical to Perl's builtin C<getlogin()> function for returning the user name associated with the current session, see L<perlfunc/getlogin>. +=item C<getpayload> + + use POSIX ':nan_payload'; + getpayload($var) + +Returns the C<NaN> payload. + +Note the API instability warning in L</setpayload>. + +See L</nan> for more discussion about C<NaN>. + =item C<getpgrp> This is identical to Perl's builtin C<getpgrp()> function for @@ -587,40 +688,40 @@ This is identical to Perl's builtin C<gmtime()> function for converting seconds since the epoch to a date in Greenwich Mean Time, see L<perlfunc/gmtime>. -=item C<isalnum> +=item C<hypot> -Deprecated function whose use raises a warning, and which is slated to -be removed in a future Perl version. It is very similar to matching -against S<C<qr/ ^ [[:alnum:]]+ $ /x>>, which you should convert to use -instead. The function is deprecated because 1) it doesn't handle UTF-8 -encoded strings properly; and 2) it returns C<TRUE> even if the input is -the empty string. The function return is always based on the current -locale, whereas using locale rules is optional with the regular -expression, based on pragmas in effect and pattern modifiers (see -L<perlre/Character set modifiers> and L<perlre/Which character set -modifier is in effect?>). +Equivalent to C<S<sqrt(x * x + y * y)>> except more stable on very large +or very small arguments [C99]. -The function returns C<TRUE> if the input string is empty, or if the -corresponding C function returns C<TRUE> for every byte in the string. +=item C<ilogb> -You may want to use the C<L<E<sol>\wE<sol>|perlrecharclass/Word -characters>> construct instead. +Integer binary logarithm [C99] -=item C<isalpha> +For example C<ilogb(20)> is 4, as an integer. -Deprecated function whose use raises a warning, and which is slated to -be removed in a future Perl version. It is very similar to matching -against S<C<qr/ ^ [[:alpha:]]+ $ /x>>, which you should convert to use -instead. The function is deprecated because 1) it doesn't handle UTF-8 -encoded strings properly; and 2) it returns C<TRUE> even if the input is -the empty string. The function return is always based on the current -locale, whereas using locale rules is optional with the regular -expression, based on pragmas in effect and pattern modifiers (see -L<perlre/Character set modifiers> and L<perlre/Which character set -modifier is in effect?>). +See also L</logb>. -The function returns C<TRUE> if the input string is empty, or if the -corresponding C function returns C<TRUE> for every byte in the string. +=item C<Inf> + +The infinity as a constant: + + use POSIX qw(Inf); + my $pos_inf = +Inf; # Or just Inf. + my $neg_inf = -Inf; + +See also L</isinf>, and L</fpclassify>. + +=item C<isalnum> + +This function has been removed as of v5.24. It was very similar to +matching against S<C<qr/ ^ [[:alnum:]]+ $ /x>>, which you should convert +to use instead. See L<perlrecharclass/POSIX Character Classes>. + +=item C<isalpha> + +This function has been removed as of v5.24. It was very similar to +matching against S<C<qr/ ^ [[:alpha:]]+ $ /x>>, which you should convert +to use instead. See L<perlrecharclass/POSIX Character Classes>. =item C<isatty> @@ -629,157 +730,121 @@ to a tty. Similar to the C<-t> operator, see L<perlfunc/-X>. =item C<iscntrl> -Deprecated function whose use raises a warning, and which is slated to -be removed in a future Perl version. It is very similar to matching -against S<C<qr/ ^ [[:cntrl:]]+ $ /x>>, which you should convert to use -instead. The function is deprecated because 1) it doesn't handle UTF-8 -encoded strings properly; and 2) it returns C<TRUE> even if the input is -the empty string. The function return is always based on the current -locale, whereas using locale rules is optional with the regular -expression, based on pragmas in effect and pattern modifiers (see -L<perlre/Character set modifiers> and L<perlre/Which character set -modifier is in effect?>). - -The function returns C<TRUE> if the input string is empty, or if the -corresponding C function returns C<TRUE> for every byte in the string. +This function has been removed as of v5.24. It was very similar to +matching against S<C<qr/ ^ [[:cntrl:]]+ $ /x>>, which you should convert +to use instead. See L<perlrecharclass/POSIX Character Classes>. =item C<isdigit> -Deprecated function whose use raises a warning, and which is slated to -be removed in a future Perl version. It is very similar to matching -against S<C<qr/ ^ [[:digit:]]+ $ /x>>, which you should convert to use -instead. The function is deprecated because 1) it doesn't handle UTF-8 -encoded strings properly; and 2) it returns C<TRUE> even if the input is -the empty string. The function return is always based on the current -locale, whereas using locale rules is optional with the regular -expression, based on pragmas in effect and pattern modifiers (see -L<perlre/Character set modifiers> and L<perlre/Which character set -modifier is in effect?>). +This function has been removed as of v5.24. It was very similar to +matching against S<C<qr/ ^ [[:digit:]]+ $ /x>>, which you should convert +to use instead. See L<perlrecharclass/POSIX Character Classes>. + +=item C<isfinite> -The function returns C<TRUE> if the input string is empty, or if the -corresponding C function returns C<TRUE> for every byte in the string. +Returns true if the argument is a finite number (that is, not an +infinity, or the not-a-number) [C99]. -You may want to use the C<L<E<sol>\dE<sol>|perlrecharclass/Digits>> -construct instead. +See also L</isinf>, L</isnan>, and L</fpclassify>. =item C<isgraph> -Deprecated function whose use raises a warning, and which is slated to -be removed in a future Perl version. It is very similar to matching -against S<C<qr/ ^ [[:graph:]]+ $ /x>>, which you should convert to use -instead. The function is deprecated because 1) it doesn't handle UTF-8 -encoded strings properly; and 2) it returns C<TRUE> even if the input is -the empty string. The function return is always based on the current -locale, whereas using locale rules is optional with the regular -expression, based on pragmas in effect and pattern modifiers (see -L<perlre/Character set modifiers> and L<perlre/Which character set -modifier is in effect?>). +This function has been removed as of v5.24. It was very similar to +matching against S<C<qr/ ^ [[:graph:]]+ $ /x>>, which you should convert +to use instead. See L<perlrecharclass/POSIX Character Classes>. + +=item C<isgreater> -The function returns C<TRUE> if the input string is empty, or if the -corresponding C function returns C<TRUE> for every byte in the string. +(Also C<isgreaterequal>, C<isless>, C<islessequal>, C<islessgreater>, +C<isunordered>) + +Floating point comparisons which handle the C<NaN> [C99]. + +=item C<isinf> + +Returns true if the argument is an infinity (positive or negative) [C99]. + +See also L</Inf>, L</isnan>, L</isfinite>, and L</fpclassify>. =item C<islower> -Deprecated function whose use raises a warning, and which is slated to -be removed in a future Perl version. It is very similar to matching -against S<C<qr/ ^ [[:lower:]]+ $ /x>>, which you should convert to use -instead. The function is deprecated because 1) it doesn't handle UTF-8 -encoded strings properly; and 2) it returns C<TRUE> even if the input is -the empty string. The function return is always based on the current -locale, whereas using locale rules is optional with the regular -expression, based on pragmas in effect and pattern modifiers (see -L<perlre/Character set modifiers> and L<perlre/Which character set -modifier is in effect?>). +This function has been removed as of v5.24. It was very similar to +matching against S<C<qr/ ^ [[:lower:]]+ $ /x>>, which you should convert +to use instead. See L<perlrecharclass/POSIX Character Classes>. -The function returns C<TRUE> if the input string is empty, or if the -corresponding C function returns C<TRUE> for every byte in the string. +=item C<isnan> -Do B<not> use C</[a-z]/> unless you don't care about the current locale. +Returns true if the argument is C<NaN> (not-a-number) [C99]. -=item C<isprint> +Note that you cannot test for "C<NaN>-ness" with + + $x == $x -Deprecated function whose use raises a warning, and which is slated to -be removed in a future Perl version. It is very similar to matching -against S<C<qr/ ^ [[:print:]]+ $ /x>>, which you should convert to use -instead. The function is deprecated because 1) it doesn't handle UTF-8 -encoded strings properly; and 2) it returns C<TRUE> even if the input is -the empty string. The function return is always based on the current -locale, whereas using locale rules is optional with the regular -expression, based on pragmas in effect and pattern modifiers (see -L<perlre/Character set modifiers> and L<perlre/Which character set -modifier is in effect?>). +since the C<NaN> is not equivalent to anything, B<including itself>. + +See also L</nan>, L</NaN>, L</isinf>, and L</fpclassify>. + +=item C<isnormal> + +Returns true if the argument is normal (that is, not a subnormal/denormal, +and not an infinity, or a not-a-number) [C99]. + +See also L</isfinite>, and L</fpclassify>. + +=item C<isprint> -The function returns C<TRUE> if the input string is empty, or if the -corresponding C function returns C<TRUE> for every byte in the string. +This function has been removed as of v5.24. It was very similar to +matching against S<C<qr/ ^ [[:print:]]+ $ /x>>, which you should convert +to use instead. See L<perlrecharclass/POSIX Character Classes>. =item C<ispunct> -Deprecated function whose use raises a warning, and which is slated to -be removed in a future Perl version. It is very similar to matching -against S<C<qr/ ^ [[:punct:]]+ $ /x>>, which you should convert to use -instead. The function is deprecated because 1) it doesn't handle UTF-8 -encoded strings properly; and 2) it returns C<TRUE> even if the input is -the empty string. The function return is always based on the current -locale, whereas using locale rules is optional with the regular -expression, based on pragmas in effect and pattern modifiers (see -L<perlre/Character set modifiers> and L<perlre/Which character set -modifier is in effect?>). +This function has been removed as of v5.24. It was very similar to +matching against S<C<qr/ ^ [[:punct:]]+ $ /x>>, which you should convert +to use instead. See L<perlrecharclass/POSIX Character Classes>. -The function returns C<TRUE> if the input string is empty, or if the -corresponding C function returns C<TRUE> for every byte in the string. +=item C<issignaling> -=item C<isspace> + use POSIX ':nan_payload'; + issignaling($var, $payload) -Deprecated function whose use raises a warning, and which is slated to -be removed in a future Perl version. It is very similar to matching -against S<C<qr/ ^ [[:space:]]+ $ /x>>, which you should convert to use -instead. The function is deprecated because 1) it doesn't handle UTF-8 -encoded strings properly; and 2) it returns C<TRUE> even if the input is -the empty string. The function return is always based on the current -locale, whereas using locale rules is optional with the regular -expression, based on pragmas in effect and pattern modifiers (see -L<perlre/Character set modifiers> and L<perlre/Which character set -modifier is in effect?>). +Return true if the argument is a I<signaling> NaN. -The function returns C<TRUE> if the input string is empty, or if the -corresponding C function returns C<TRUE> for every byte in the string. +Note the API instability warning in L</setpayload>. -You may want to use the C<L<E<sol>\sE<sol>|perlrecharclass/Whitespace>> -construct instead. +See L</nan> for more discussion about C<NaN>. -=item C<isupper> +=item C<isspace> -Deprecated function whose use raises a warning, and which is slated to -be removed in a future Perl version. It is very similar to matching -against S<C<qr/ ^ [[:upper:]]+ $ /x>>, which you should convert to use -instead. The function is deprecated because 1) it doesn't handle UTF-8 -encoded strings properly; and 2) it returns C<TRUE> even if the input is -the empty string. The function return is always based on the current -locale, whereas using locale rules is optional with the regular -expression, based on pragmas in effect and pattern modifiers (see -L<perlre/Character set modifiers> and L<perlre/Which character set -modifier is in effect?>). +This function has been removed as of v5.24. It was very similar to +matching against S<C<qr/ ^ [[:space:]]+ $ /x>>, which you should convert +to use instead. See L<perlrecharclass/POSIX Character Classes>. -The function returns C<TRUE> if the input string is empty, or if the -corresponding C function returns C<TRUE> for every byte in the string. +=item C<isupper> -Do B<not> use C</[A-Z]/> unless you don't care about the current locale. +This function has been removed as of v5.24. It was very similar to +matching against S<C<qr/ ^ [[:upper:]]+ $ /x>>, which you should convert +to use instead. See L<perlrecharclass/POSIX Character Classes>. =item C<isxdigit> -Deprecated function whose use raises a warning, and which is slated to -be removed in a future Perl version. It is very similar to matching -against S<C<qr/ ^ [[:xdigit:]]+ $ /x>>, which you should convert to use -instead. The function is deprecated because 1) it doesn't handle UTF-8 -encoded strings properly; and 2) it returns C<TRUE> even if the input is -the empty string. The function return is always based on the current -locale, whereas using locale rules is optional with the regular -expression, based on pragmas in effect and pattern modifiers (see -L<perlre/Character set modifiers> and L<perlre/Which character set -modifier is in effect?>). +This function has been removed as of v5.24. It was very similar to +matching against S<C<qr/ ^ [[:xdigit:]]+ $ /x>>, which you should +convert to use instead. See L<perlrecharclass/POSIX Character Classes>. + +=item C<j0> + +=item C<j1> -The function returns C<TRUE> if the input string is empty, or if the -corresponding C function returns C<TRUE> for every byte in the string. +=item C<jn> + +=item C<y0> + +=item C<y1> + +=item C<yn> + +The Bessel function of the first kind of the order zero. =item C<kill> @@ -788,17 +853,19 @@ signals to processes (often to terminate them), see L<perlfunc/kill>. =item C<labs> -(For returning absolute values of long integers.) +Not implemented. (For returning absolute values of long integers.) C<labs()> is C-specific, see L<perlfunc/abs> instead. =item C<lchown> This is identical to the C function, except the order of arguments is consistent with Perl's builtin C<chown()> with the added restriction -of only one path, not an list of paths. Does the same thing as the -C<chown()> function but changes the owner of a symbolic link instead +of only one path, not a list of paths. Does the same thing as the +C<chown()> function but changes the owner of a symbolic link instead of the file the symbolic link points to. + POSIX::lchown($uid, $gid, $file_path); + =item C<ldexp> This is identical to the C function C<ldexp()> @@ -808,9 +875,34 @@ for multiplying floating point numbers with powers of two. =item C<ldiv> -(For computing dividends of long integers.) +Not implemented. (For computing dividends of long integers.) C<ldiv()> is C-specific, use C</> and C<int()> instead. +=item C<lgamma> + +The logarithm of the Gamma function [C99]. + +See also L</tgamma>. + +=item C<log1p> + +Equivalent to S<C<log(1 + x)>>, but more stable results for small argument +values [C99]. + +=item C<log2> + +Logarithm base two [C99]. + +See also L</expm1>. + +=item C<logb> + +Integer binary logarithm [C99]. + +For example C<logb(20)> is 4, as a floating point number. + +See also L</ilogb>. + =item C<link> This is identical to Perl's builtin C<link()> function @@ -819,7 +911,7 @@ for creating hard links into files, see L<perlfunc/link>. =item C<localeconv> Get numeric formatting information. Returns a reference to a hash -containing the current locale formatting values. Users of this function +containing the current underlying locale's formatting values. Users of this function should also read L<perllocale>, which provides a comprehensive discussion of Perl locale handling, including L<a section devoted to this function|perllocale/The localeconv function>. @@ -860,6 +952,9 @@ Here is how to query the database for the B<de> (Deutsch or German) locale. $property, $lconv->{$property}; } +The members whose names begin with C<int_p_> and C<int_n_> were added by +POSIX.1-2008 and are only available on systems that support them. + =item C<localtime> This is identical to Perl's builtin C<localtime()> function for @@ -889,7 +984,7 @@ or =item C<longjmp> -C<longjmp()> is C-specific: use L<perlfunc/die> instead. +Not implemented. C<longjmp()> is C-specific: use L<perlfunc/die> instead. =item C<lseek> @@ -901,50 +996,70 @@ those obtained by calling C<POSIX::open>. Returns C<undef> on failure. +=item C<lrint> + +Depending on the current floating point rounding mode, rounds the +argument either toward nearest (like L</round>), toward zero (like +L</trunc>), downward (toward negative infinity), or upward (toward +positive infinity) [C99]. + +For the rounding mode, see L</fegetround>. + +=item C<lround> + +Like L</round>, but as integer, as opposed to floating point [C99]. + +See also L</ceil>, L</floor>, L</trunc>. + +Owing to an oversight, this is not currently exported by default, or as part of +the C<:math_h_c99> export tag; importing it must therefore be done by explicit +name. This will be changed in Perl 5.26. + =item C<malloc> -C<malloc()> is C-specific. Perl does memory management transparently. +Not implemented. C<malloc()> is C-specific. Perl does memory management transparently. =item C<mblen> This is identical to the C function C<mblen()>. -Perl does not have any support for the wide and multibyte -characters of the C standards, so this might be a rather -useless function. + +Core Perl does not have any support for the wide and multibyte +characters of the C standards, except under UTF-8 locales, so this might +be a rather useless function. + +However, Perl supports Unicode, see L<perluniintro>. =item C<mbstowcs> This is identical to the C function C<mbstowcs()>. -Perl does not have any support for the wide and multibyte -characters of the C standards, so this might be a rather -useless function. + +See L</mblen>. =item C<mbtowc> This is identical to the C function C<mbtowc()>. -Perl does not have any support for the wide and multibyte -characters of the C standards, so this might be a rather -useless function. + +See L</mblen>. =item C<memchr> -C<memchr()> is C-specific, see L<perlfunc/index> instead. +Not implemented. C<memchr()> is C-specific, see L<perlfunc/index> instead. =item C<memcmp> -C<memcmp()> is C-specific, use C<eq> instead, see L<perlop>. +Not implemented. C<memcmp()> is C-specific, use C<eq> instead, see L<perlop>. =item C<memcpy> -C<memcpy()> is C-specific, use C<=>, see L<perlop>, or see L<perlfunc/substr>. +Not implemented. C<memcpy()> is C-specific, use C<=>, see L<perlop>, or see L<perlfunc/substr>. =item C<memmove> -C<memmove()> is C-specific, use C<=>, see L<perlop>, or see L<perlfunc/substr>. +Not implemented. C<memmove()> is C-specific, use C<=>, see L<perlop>, or see L<perlfunc/substr>. =item C<memset> -C<memset()> is C-specific, use C<x> instead, see L<perlop>. +Not implemented. C<memset()> is C-specific, use C<x> instead, see L<perlop>. =item C<mkdir> @@ -971,9 +1086,9 @@ Synopsis: mktime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = -1) -The month (C<mon>), weekday (C<wday>), and yearday (C<yday>) begin at zero. -I.e. January is 0, not 1; Sunday is 0, not 1; January 1st is 0, not 1. The -year (C<year>) is given in years since 1900. I.e. The year 1995 is 95; the +The month (C<mon>), weekday (C<wday>), and yearday (C<yday>) begin at zero, +I<i.e.>, January is 0, not 1; Sunday is 0, not 1; January 1st is 0, not 1. The +year (C<year>) is given in years since 1900; I<i.e.>, the year 1995 is 95; the year 2001 is 101. Consult your system's C<mktime()> manpage for details about these and the other arguments. @@ -990,18 +1105,90 @@ Return the integral and fractional parts of a floating-point number. ($fractional, $integral) = POSIX::modf( 3.14 ); +See also L</round>. + +=item C<NaN> + +The not-a-number as a constant: + + use POSIX qw(NaN); + my $nan = NaN; + +See also L</nan>, C</isnan>, and L</fpclassify>. + +=item C<nan> + + my $nan = nan(); + +Returns C<NaN>, not-a-number [C99]. + +The returned NaN is always a I<quiet> NaN, as opposed to I<signaling>. + +With an argument, can be used to generate a NaN with I<payload>. +The argument is first interpreted as a floating point number, +but then any fractional parts are truncated (towards zero), +and the value is interpreted as an unsigned integer. +The bits of this integer are stored in the unused bits of the NaN. + +The result has a dual nature: it is a NaN, but it also carries +the integer inside it. The integer can be retrieved with L</getpayload>. +Note, though, that the payload is not propagated, not even on copies, +and definitely not in arithmetic operations. + +How many bits fit in the NaN depends on what kind of floating points +are being used, but on the most common platforms (64-bit IEEE 754, +or the x86 80-bit long doubles) there are 51 and 61 bits available, +respectively. (There would be 52 and 62, but the quiet/signaling +bit of NaNs takes away one.) However, because of the floating-point-to- +integer-and-back conversions, please test carefully whether you get back +what you put in. If your integers are only 32 bits wide, you probably +should not rely on more than 32 bits of payload. + +Whether a "signaling" NaN is in any way different from a "quiet" NaN, +depends on the platform. Also note that the payload of the default +NaN (no argument to nan()) is not necessarily zero, use C<setpayload> +to explicitly set the payload. On some platforms like the 32-bit x86, +(unless using the 80-bit long doubles) the signaling bit is not supported +at all. + +See also L</isnan>, L</NaN>, L</setpayload> and L</issignaling>. + +=item C<nearbyint> + +Returns the nearest integer to the argument, according to the current +rounding mode (see L</fegetround>) [C99]. + +=item C<nextafter> + +Returns the next representable floating point number after C<x> in the +direction of C<y> [C99]. + + my $nextafter = POSIX::nextafter($x, $y); + +Like L</nexttoward>, but potentially less accurate. + +=item C<nexttoward> + +Returns the next representable floating point number after C<x> in the +direction of C<y> [C99]. + + my $nexttoward = POSIX::nexttoward($x, $y); + +Like L</nextafter>, but potentially more accurate. + =item C<nice> This is similar to the C function C<nice()>, for changing the scheduling preference of the current process. Positive -arguments mean more polite process, negative values more -needy process. Normal user processes can only be more polite. +arguments mean a more polite process, negative values a more +needy process. Normal (non-root) user processes can only change towards +being more polite. Returns C<undef> on failure. =item C<offsetof> -C<offsetof()> is C-specific, you probably want to see L<perlfunc/pack> instead. +Not implemented. C<offsetof()> is C-specific, you probably want to see L<perlfunc/pack> instead. =item C<open> @@ -1089,24 +1276,24 @@ You can also use the C<**> operator, see L<perlop>. =item C<printf> -Formats and prints the specified arguments to STDOUT. +Formats and prints the specified arguments to C<STDOUT>. See also L<perlfunc/printf>. =item C<putc> -C<putc()> is C-specific, see L<perlfunc/print> instead. +Not implemented. C<putc()> is C-specific, see L<perlfunc/print> instead. =item C<putchar> -C<putchar()> is C-specific, see L<perlfunc/print> instead. +Not implemented. C<putchar()> is C-specific, see L<perlfunc/print> instead. =item C<puts> -C<puts()> is C-specific, see L<perlfunc/print> instead. +Not implemented. C<puts()> is C-specific, see L<perlfunc/print> instead. =item C<qsort> -C<qsort()> is C-specific, see L<perlfunc/sort> instead. +Not implemented. C<qsort()> is C-specific, see L<perlfunc/sort> instead. =item C<raise> @@ -1115,7 +1302,7 @@ See also L<perlfunc/kill> and the C<$$> in L<perlvar/$PID>. =item C<rand> -C<rand()> is non-portable, see L<perlfunc/rand> instead. +Not implemented. C<rand()> is non-portable, see L<perlfunc/rand> instead. =item C<read> @@ -1137,13 +1324,30 @@ for reading directory entries, see L<perlfunc/readdir>. =item C<realloc> -C<realloc()> is C-specific. Perl does memory management transparently. +Not implemented. C<realloc()> is C-specific. Perl does memory management transparently. + +=item C<remainder> + +Given C<x> and C<y>, returns the value S<C<x - n*y>>, where C<n> is the integer +closest to C<x>/C<y>. [C99] + + my $remainder = POSIX::remainder($x, $y) + +See also L</remquo>. =item C<remove> This is identical to Perl's builtin C<unlink()> function for removing files, see L<perlfunc/unlink>. +=item C<remquo> + +Like L</remainder> but also returns the low-order bits of the quotient (n) +[C99] + +(This is quite esoteric interface, mainly used to implement numerical +algorithms.) + =item C<rename> This is identical to Perl's builtin C<rename()> function @@ -1158,14 +1362,31 @@ Seeks to the beginning of the file. This is identical to Perl's builtin C<rewinddir()> function for rewinding directory entry streams, see L<perlfunc/rewinddir>. +=item C<rint> + +Identical to L</lrint>. + =item C<rmdir> This is identical to Perl's builtin C<rmdir()> function for removing (empty) directories, see L<perlfunc/rmdir>. +=item C<round> + +Returns the integer (but still as floating point) nearest to the +argument [C99]. + +See also L</ceil>, L</floor>, L</lround>, L</modf>, and L</trunc>. + +=item C<scalbn> + +Returns S<C<x * 2**y>> [C99]. + +See also L</frexp> and L</ldexp>. + =item C<scanf> -C<scanf()> is C-specific, use E<lt>E<gt> and regular expressions instead, +Not implemented. C<scanf()> is C-specific, use E<lt>E<gt> and regular expressions instead, see L<perlre>. =item C<setgid> @@ -1179,11 +1400,18 @@ list of numbers. =item C<setjmp> -C<setjmp()> is C-specific: use C<eval {}> instead, +Not implemented. C<setjmp()> is C-specific: use C<eval {}> instead, see L<perlfunc/eval>. =item C<setlocale> +WARNING! Do NOT use this function in a L<thread|threads>. The locale +will change in all other threads at the same time, and should your +thread get paused by the operating system, and another started, that +thread will not have the locale it is expecting. On some platforms, +there can be a race leading to segfaults if two threads call this +function nearly simultaneously. + Modifies and queries the program's underlying locale. Users of this function should read L<perllocale>, whch provides a comprehensive discussion of Perl locale handling, knowledge of which is necessary to @@ -1192,7 +1420,7 @@ L<a section devoted to this function|perllocale/The setlocale function>. The discussion here is merely a summary reference for C<setlocale()>. Note that Perl itself is almost entirely unaffected by the locale except within the scope of S<C<"use locale">>. (Exceptions are listed -in L<perllocale/Not within the scope of any "use locale" variant>.) +in L<perllocale/Not within the scope of "use locale">.) The following examples assume @@ -1224,6 +1452,38 @@ out which locales are available in your system. $loc = setlocale( LC_COLLATE, "es_AR.ISO8859-1" ); +=item C<setpayload> + + use POSIX ':nan_payload'; + setpayload($var, $payload); + +Sets the C<NaN> payload of var. + +NOTE: the NaN payload APIs are based on the latest (as of June 2015) +proposed ISO C interfaces, but they are not yet a standard. Things +may change. + +See L</nan> for more discussion about C<NaN>. + +See also L</setpayloadsig>, L</isnan>, L</getpayload>, and L</issignaling>. + +=item C<setpayloadsig> + + use POSIX ':nan_payload'; + setpayloadsig($var, $payload); + +Like L</setpayload> but also makes the NaN I<signaling>. + +Depending on the platform the NaN may or may not behave differently. + +Note the API instability warning in L</setpayload>. + +Note that because how the floating point formats work out, on the most +common platforms signaling payload of zero is best avoided, +since it might end up being identical to C<+Inf>. + +See also L</nan>, L</isnan>, L</getpayload>, and L</issignaling>. + =item C<setpgid> This is similar to the C function C<setpgid()> for @@ -1269,6 +1529,9 @@ semantics, as defined by POSIX/SUSv3: a user process and the uid and pid make sense, otherwise the signal was sent by the kernel +The constants for specific C<code> values can be imported individually +or using the C<:signal_h_si_code> tag. + The following are also defined by POSIX/SUSv3, but unfortunately not very widely implemented: @@ -1276,6 +1539,8 @@ not very widely implemented: uid the uid of the process id generating the signal status exit value or signal for SIGCHLD band band event for SIGPOLL + addr address of faulting instruction or memory + reference for SIGILL, SIGFPE, SIGSEGV or SIGBUS A third argument is also passed to the handler, which contains a copy of the raw binary contents of the C<siginfo> structure: if a system has @@ -1289,7 +1554,11 @@ C<sigaction> and possibly also C<siginfo> documentation. =item C<siglongjmp> -C<siglongjmp()> is C-specific: use L<perlfunc/die> instead. +Not implemented. C<siglongjmp()> is C-specific: use L<perlfunc/die> instead. + +=item C<signbit> + +Returns zero for positive arguments, non-zero for negative arguments [C99]. =item C<sigpending> @@ -1321,7 +1590,7 @@ reliably. =item C<sigsetjmp> -C<sigsetjmp()> is C-specific: use C<eval {}> instead, +Not implemented. C<sigsetjmp()> is C-specific: use C<eval {}> instead, see L<perlfunc/eval>. =item C<sigsuspend> @@ -1375,7 +1644,7 @@ Give a seed the pseudorandom number generator, see L<perlfunc/srand>. =item C<sscanf> -C<sscanf()> is C-specific, use regular expressions instead, +Not implemented. C<sscanf()> is C-specific, use regular expressions instead, see L<perlre>. =item C<stat> @@ -1385,15 +1654,15 @@ for returning information about files and directories. =item C<strcat> -C<strcat()> is C-specific, use C<.=> instead, see L<perlop>. +Not implemented. C<strcat()> is C-specific, use C<.=> instead, see L<perlop>. =item C<strchr> -C<strchr()> is C-specific, see L<perlfunc/index> instead. +Not implemented. C<strchr()> is C-specific, see L<perlfunc/index> instead. =item C<strcmp> -C<strcmp()> is C-specific, use C<eq> or C<cmp> instead, see L<perlop>. +Not implemented. C<strcmp()> is C-specific, use C<eq> or C<cmp> instead, see L<perlop>. =item C<strcoll> @@ -1404,17 +1673,17 @@ Perl can do this transparently, see L<perllocale>. =item C<strcpy> -C<strcpy()> is C-specific, use C<=> instead, see L<perlop>. +Not implemented. C<strcpy()> is C-specific, use C<=> instead, see L<perlop>. =item C<strcspn> -C<strcspn()> is C-specific, use regular expressions instead, +Not implemented. C<strcspn()> is C-specific, use regular expressions instead, see L<perlre>. =item C<strerror> Returns the error string for the specified errno. -Identical to the string form of the C<$!>, see L<perlvar/$ERRNO>. +Identical to the string form of C<$!>, see L<perlvar/$ERRNO>. =item C<strftime> @@ -1425,9 +1694,9 @@ Synopsis: strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1) -The month (C<mon>), weekday (C<wday>), and yearday (C<yday>) begin at zero. -I.e. January is 0, not 1; Sunday is 0, not 1; January 1st is 0, not 1. The -year (C<year>) is given in years since 1900. I.e., the year 1995 is 95; the +The month (C<mon>), weekday (C<wday>), and yearday (C<yday>) begin at zero, +I<i.e.>, January is 0, not 1; Sunday is 0, not 1; January 1st is 0, not 1. The +year (C<year>) is given in years since 1900, I<i.e.>, the year 1995 is 95; the year 2001 is 101. Consult your system's C<strftime()> manpage for details about these and the other arguments. @@ -1456,32 +1725,32 @@ The string for Tuesday, December 12, 1995. =item C<strlen> -C<strlen()> is C-specific, use C<length()> instead, see L<perlfunc/length>. +Not implemented. C<strlen()> is C-specific, use C<length()> instead, see L<perlfunc/length>. =item C<strncat> -C<strncat()> is C-specific, use C<.=> instead, see L<perlop>. +Not implemented. C<strncat()> is C-specific, use C<.=> instead, see L<perlop>. =item C<strncmp> -C<strncmp()> is C-specific, use C<eq> instead, see L<perlop>. +Not implemented. C<strncmp()> is C-specific, use C<eq> instead, see L<perlop>. =item C<strncpy> -C<strncpy()> is C-specific, use C<=> instead, see L<perlop>. +Not implemented. C<strncpy()> is C-specific, use C<=> instead, see L<perlop>. =item C<strpbrk> -C<strpbrk()> is C-specific, use regular expressions instead, +Not implemented. C<strpbrk()> is C-specific, use regular expressions instead, see L<perlre>. =item C<strrchr> -C<strrchr()> is C-specific, see L<perlfunc/rindex> instead. +Not implemented. C<strrchr()> is C-specific, see L<perlfunc/rindex> instead. =item C<strspn> -C<strspn()> is C-specific, use regular expressions instead, +Not implemented. C<strspn()> is C-specific, use regular expressions instead, see L<perlre>. =item C<strstr> @@ -1494,10 +1763,10 @@ see L<perlfunc/index>. String to double translation. Returns the parsed number and the number of characters in the unparsed portion of the string. Truly POSIX-compliant systems set C<$!> (C<$ERRNO>) to indicate a translation -error, so clear C<$!> before calling strtod. However, non-POSIX systems +error, so clear C<$!> before calling C<strtod>. However, non-POSIX systems may not check for overflow, and therefore will never set C<$!>. -strtod respects any POSIX I<setlocale()> C<LC_TIME> settings, +C<strtod> respects any POSIX C<setlocale()> C<LC_TIME> settings, regardless of whether or not it is called from Perl code that is within the scope of S<C<use locale>>. @@ -1512,11 +1781,11 @@ The second returned item and C<$!> can be used to check for valid input: die "Non-numeric input $str" . ($! ? ": $!\n" : "\n"); } -When called in a scalar context strtod returns the parsed number. +When called in a scalar context C<strtod> returns the parsed number. =item C<strtok> -C<strtok()> is C-specific, use regular expressions instead, see +Not implemented. C<strtok()> is C-specific, use regular expressions instead, see L<perlre>, or L<perlfunc/split>. =item C<strtol> @@ -1535,7 +1804,7 @@ To parse a string C<$str> as a number in some base C<$base> use ($num, $n_unparsed) = POSIX::strtol($str, $base); The base should be zero or between 2 and 36, inclusive. When the base -is zero or omitted strtol will use the string itself to determine the +is zero or omitted C<strtol> will use the string itself to determine the base: a leading "0x" or "0X" means hexadecimal; a leading "0" means octal; any other leading characters mean decimal. Thus, "1234" is parsed as a decimal number, "01234" as an octal number, and "0x1234" @@ -1547,7 +1816,12 @@ The second returned item and C<$!> can be used to check for valid input: die "Non-numeric input $str" . $! ? ": $!\n" : "\n"; } -When called in a scalar context strtol returns the parsed number. +When called in a scalar context C<strtol> returns the parsed number. + +=item C<strtold> + +Like L</strtod> but for long doubles. Defined only if the +system supports long doubles. =item C<strtoul> @@ -1636,6 +1910,12 @@ terminal. Returns C<undef> on failure. +=item C<tgamma> + +The Gamma function [C99]. + +See also L</lgamma>. + =item C<time> This is identical to Perl's builtin C<time()> function @@ -1649,7 +1929,7 @@ The C<times()> function returns elapsed realtime since some point in the past and system times used by child processes. All times are returned in clock ticks. - ($realtime, $user, $system, $cuser, $csystem) + ($realtime, $user, $system, $cuser, $csystem) = POSIX::times(); Note: Perl's builtin C<times()> function returns four values, measured in @@ -1657,7 +1937,7 @@ seconds. =item C<tmpfile> -Use method C<IO::File::new_tmpfile()> instead, or see L<File::Temp>. +Not implemented. Use method C<IO::File::new_tmpfile()> instead, or see L<File::Temp>. =item C<tmpnam> @@ -1672,16 +1952,23 @@ should not be used; instead see L<File::Temp>. =item C<tolower> This is identical to the C function, except that it can apply to a single -character or to a whole string. Consider using the C<lc()> function, +character or to a whole string, and currently operates as if the locale +always is "C". Consider using the C<lc()> function, see L<perlfunc/lc>, see L<perlfunc/lc>, or the equivalent C<\L> operator inside doublequotish strings. =item C<toupper> -This is identical to the C function, except that it can apply to a single -character or to a whole string. Consider using the C<uc()> function, -see L<perlfunc/uc>, or the equivalent C<\U> operator inside doublequotish -strings. +This is similar to the C function, except that it can apply to a single +character or to a whole string, and currently operates as if the locale +always is "C". Consider using the C<uc()> function, see L<perlfunc/uc>, +or the equivalent C<\U> operator inside doublequotish strings. + +=item C<trunc> + +Returns the integer toward zero from the argument [C99]. + +See also L</ceil>, L</floor>, and L</round>. =item C<ttyname> @@ -1726,7 +2013,7 @@ Maybe. =item C<ungetc> -Use method C<IO::Handle::ungetc()> instead. +Not implemented. Use method C<IO::Handle::ungetc()> instead. =item C<unlink> @@ -1741,15 +2028,15 @@ see L<perlfunc/utime>. =item C<vfprintf> -C<vfprintf()> is C-specific, see L<perlfunc/printf> instead. +Not implemented. C<vfprintf()> is C-specific, see L<perlfunc/printf> instead. =item C<vprintf> -C<vprintf()> is C-specific, see L<perlfunc/printf> instead. +Not implemented. C<vprintf()> is C-specific, see L<perlfunc/printf> instead. =item C<vsprintf> -C<vsprintf()> is C-specific, see L<perlfunc/sprintf> instead. +Not implemented. C<vsprintf()> is C-specific, see L<perlfunc/sprintf> instead. =item C<wait> @@ -1767,16 +2054,14 @@ builtin C<waitpid()> function, see L<perlfunc/waitpid>. =item C<wcstombs> This is identical to the C function C<wcstombs()>. -Perl does not have any support for the wide and multibyte -characters of the C standards, so this might be a rather -useless function. + +See L</mblen>. =item C<wctomb> This is identical to the C function C<wctomb()>. -Perl does not have any support for the wide and multibyte -characters of the C standards, so this might be a rather -useless function. + +See L</mblen>. =item C<write> @@ -1968,7 +2253,7 @@ Tests the SigSet object to see if it contains a specific signal. =item C<new> Create a new Termios object. This object will be destroyed automatically -when it is no longer needed. A Termios object corresponds to the termios +when it is no longer needed. A Termios object corresponds to the C<termios> C struct. C<new()> mallocs a new one, C<getattr()> fills it from a file descriptor, and C<setattr()> sets a file descriptor's parameters to match Termios' contents. @@ -1978,7 +2263,7 @@ and C<setattr()> sets a file descriptor's parameters to match Termios' contents. Get terminal control attributes. -Obtain the attributes for stdin. +Obtain the attributes for C<stdin>. $termios->getattr( 0 ) # Recommended for clarity. $termios->getattr() @@ -1991,20 +2276,20 @@ Returns C<undef> on failure. =item C<getcc> -Retrieve a value from the c_cc field of a termios object. The c_cc field is +Retrieve a value from the C<c_cc> field of a C<termios> object. The C<c_cc> field is an array so an index must be specified. $c_cc[1] = $termios->getcc(1); =item C<getcflag> -Retrieve the c_cflag field of a termios object. +Retrieve the C<c_cflag> field of a C<termios> object. $c_cflag = $termios->getcflag; =item C<getiflag> -Retrieve the c_iflag field of a termios object. +Retrieve the C<c_iflag> field of a C<termios> object. $c_iflag = $termios->getiflag; @@ -2016,13 +2301,13 @@ Retrieve the input baud rate. =item C<getlflag> -Retrieve the c_lflag field of a termios object. +Retrieve the C<c_lflag> field of a C<termios> object. $c_lflag = $termios->getlflag; =item C<getoflag> -Retrieve the c_oflag field of a termios object. +Retrieve the C<c_oflag> field of a C<termios> object. $c_oflag = $termios->getoflag; @@ -2044,20 +2329,20 @@ Returns C<undef> on failure. =item C<setcc> -Set a value in the c_cc field of a termios object. The c_cc field is an +Set a value in the C<c_cc> field of a C<termios> object. The C<c_cc> field is an array so an index must be specified. $termios->setcc( &POSIX::VEOF, 1 ); =item C<setcflag> -Set the c_cflag field of a termios object. +Set the C<c_cflag> field of a C<termios> object. $termios->setcflag( $c_cflag | &POSIX::CLOCAL ); =item C<setiflag> -Set the c_iflag field of a termios object. +Set the C<c_iflag> field of a C<termios> object. $termios->setiflag( $c_iflag | &POSIX::BRKINT ); @@ -2071,13 +2356,13 @@ Returns C<undef> on failure. =item C<setlflag> -Set the c_lflag field of a termios object. +Set the C<c_lflag> field of a C<termios> object. $termios->setlflag( $c_lflag | &POSIX::ECHO ); =item C<setoflag> -Set the c_oflag field of a termios object. +Set the C<c_oflag> field of a C<termios> object. $termios->setoflag( $c_oflag | &POSIX::OPOST ); @@ -2202,6 +2487,17 @@ C<LDBL_MAX_EXP> C<LDBL_MIN> C<LDBL_MIN_10_EXP> C<LDBL_MIN_EXP> =back +=head1 FLOATING-POINT ENVIRONMENT + +=over 8 + +=item Constants + +C<FE_DOWNWARD> C<FE_TONEAREST> C<FE_TOWARDZERO> C<FE_UPWARD> +on systems that support them. + +=back + =head1 LIMITS =over 8 @@ -2221,7 +2517,8 @@ C<UCHAR_MAX> C<UINT_MAX> C<ULONG_MAX> C<USHRT_MAX> =item Constants -C<LC_ALL> C<LC_COLLATE> C<LC_CTYPE> C<LC_MONETARY> C<LC_NUMERIC> C<LC_TIME> +C<LC_ALL> C<LC_COLLATE> C<LC_CTYPE> C<LC_MONETARY> C<LC_NUMERIC> C<LC_TIME> C<LC_MESSAGES> +on systems that support them. =back @@ -2233,6 +2530,12 @@ C<LC_ALL> C<LC_COLLATE> C<LC_CTYPE> C<LC_MONETARY> C<LC_NUMERIC> C<LC_TIME> C<HUGE_VAL> +C<FP_ILOGB0> C<FP_ILOGBNAN> C<FP_INFINITE> C<FP_NAN> C<FP_NORMAL> C<FP_SUBNORMAL> C<FP_ZERO> +C<INFINITY> C<NAN> C<Inf> C<NaN> +C<M_1_PI> C<M_2_PI> C<M_2_SQRTPI> C<M_E> C<M_LN10> C<M_LN2> C<M_LOG10E> C<M_LOG2E> C<M_PI> +C<M_PI_2> C<M_PI_4> C<M_SQRT1_2> C<M_SQRT2> +on systems with C99 support. + =back =head1 SIGNAL @@ -2246,6 +2549,12 @@ C<SA_SIGINFO> C<SIGABRT> C<SIGALRM> C<SIGCHLD> C<SIGCONT> C<SIGFPE> C<SIGHUP> C< C<SIGKILL> C<SIGPIPE> C<SIGQUIT> C<SIGSEGV> C<SIGSTOP> C<SIGTERM> C<SIGTSTP> C<SIGTTIN> C<SIGTTOU> C<SIGUSR1> C<SIGUSR2> C<SIG_BLOCK> C<SIG_DFL> C<SIG_ERR> C<SIG_IGN> C<SIG_SETMASK> C<SIG_UNBLOCK> +C<ILL_ILLOPC> C<ILL_ILLOPN> C<ILL_ILLADR> C<ILL_ILLTRP> C<ILL_PRVOPC> C<ILL_PRVREG> C<ILL_COPROC> +C<ILL_BADSTK> C<FPE_INTDIV> C<FPE_INTOVF> C<FPE_FLTDIV> C<FPE_FLTOVF> C<FPE_FLTUND> C<FPE_FLTRES> +C<FPE_FLTINV> C<FPE_FLTSUB> C<SEGV_MAPERR> C<SEGV_ACCERR> C<BUS_ADRALN> C<BUS_ADRERR> +C<BUS_OBJERR> C<TRAP_BRKPT> C<TRAP_TRACE> C<CLD_EXITED> C<CLD_KILLED> C<CLD_DUMPED> C<CLD_TRAPPED> +C<CLD_STOPPED> C<CLD_CONTINUED> C<POLL_IN> C<POLL_OUT> C<POLL_MSG> C<POLL_ERR> C<POLL_PRI> +C<POLL_HUP> C<SI_USER> C<SI_QUEUE> C<SI_TIMER> C<SI_ASYNCIO> C<SI_MESGQ> =back @@ -2371,3 +2680,25 @@ is true) =back +=head1 WINSOCK + +(Windows only.) + +=over 8 + +=item Constants + +C<WSAEINTR> C<WSAEBADF> C<WSAEACCES> C<WSAEFAULT> C<WSAEINVAL> C<WSAEMFILE> C<WSAEWOULDBLOCK> +C<WSAEINPROGRESS> C<WSAEALREADY> C<WSAENOTSOCK> C<WSAEDESTADDRREQ> C<WSAEMSGSIZE> +C<WSAEPROTOTYPE> C<WSAENOPROTOOPT> C<WSAEPROTONOSUPPORT> C<WSAESOCKTNOSUPPORT> +C<WSAEOPNOTSUPP> C<WSAEPFNOSUPPORT> C<WSAEAFNOSUPPORT> C<WSAEADDRINUSE> +C<WSAEADDRNOTAVAIL> C<WSAENETDOWN> C<WSAENETUNREACH> C<WSAENETRESET> C<WSAECONNABORTED> +C<WSAECONNRESET> C<WSAENOBUFS> C<WSAEISCONN> C<WSAENOTCONN> C<WSAESHUTDOWN> +C<WSAETOOMANYREFS> C<WSAETIMEDOUT> C<WSAECONNREFUSED> C<WSAELOOP> C<WSAENAMETOOLONG> +C<WSAEHOSTDOWN> C<WSAEHOSTUNREACH> C<WSAENOTEMPTY> C<WSAEPROCLIM> C<WSAEUSERS> +C<WSAEDQUOT> C<WSAESTALE> C<WSAEREMOTE> C<WSAEDISCON> C<WSAENOMORE> C<WSAECANCELLED> +C<WSAEINVALIDPROCTABLE> C<WSAEINVALIDPROVIDER> C<WSAEPROVIDERFAILEDINIT> +C<WSAEREFUSED> + +=back + diff --git a/gnu/usr.bin/perl/ext/POSIX/t/export.t b/gnu/usr.bin/perl/ext/POSIX/t/export.t index f76c60c9ea7..5c37f83a07b 100644 --- a/gnu/usr.bin/perl/ext/POSIX/t/export.t +++ b/gnu/usr.bin/perl/ext/POSIX/t/export.t @@ -13,100 +13,164 @@ POSIX->import(); # @POSIX::EXPORT and @POSIX::EXPORT_OK are generated. The intent of this test is # to catch *unintended* changes to them introduced by bugs in refactoring. +# N.B. the data must be sorted at runtime even though it appears sorted here +# because it is given in ASCII order and we might be on a non-ASCII platform my %expect = ( - EXPORT => [qw(%SIGRT ARG_MAX B0 B110 B1200 B134 B150 B1800 B19200 B200 - B2400 B300 B38400 B4800 B50 B600 B75 B9600 BRKINT BUFSIZ - CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX CLK_TCK CLOCAL - CLOCKS_PER_SEC CREAD CS5 CS6 CS7 CS8 CSIZE CSTOPB DBL_DIG - DBL_EPSILON DBL_MANT_DIG DBL_MAX DBL_MAX_10_EXP DBL_MAX_EXP - DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP E2BIG EACCES EADDRINUSE - EADDRNOTAVAIL EAFNOSUPPORT EAGAIN EALREADY EBADF EBADMSG EBUSY - ECANCELED ECHILD ECHO ECHOE ECHOK ECHONL ECONNABORTED - ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT - EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EIDRM EILSEQ - EINPROGRESS EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE - EMLINK EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH - ENFILE ENOBUFS ENODATA ENODEV ENOENT ENOEXEC ENOLCK ENOLINK - ENOMEM ENOMSG ENOPROTOOPT ENOSPC ENOSR ENOSTR ENOSYS ENOTBLK - ENOTCONN ENOTDIR ENOTEMPTY ENOTRECOVERABLE ENOTSOCK ENOTSUP - ENOTTY ENXIO EOF EOPNOTSUPP EOTHER EOVERFLOW EOWNERDEAD EPERM - EPFNOSUPPORT EPIPE EPROCLIM EPROTO EPROTONOSUPPORT EPROTOTYPE - ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT ESPIPE - ESRCH ESTALE ETIME ETIMEDOUT ETOOMANYREFS ETXTBSY EUSERS - EWOULDBLOCK EXDEV - EXIT_FAILURE EXIT_SUCCESS FD_CLOEXEC FILENAME_MAX - FLT_DIG FLT_EPSILON FLT_MANT_DIG FLT_MAX FLT_MAX_10_EXP - FLT_MAX_EXP FLT_MIN FLT_MIN_10_EXP FLT_MIN_EXP FLT_RADIX - FLT_ROUNDS F_DUPFD F_GETFD F_GETFL F_GETLK F_OK F_RDLCK - F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK HUGE_VAL - HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR INLCR INPCK - INT_MAX INT_MIN ISIG ISTRIP IXOFF IXON LC_ALL LC_COLLATE - LC_CTYPE LC_MESSAGES LC_MONETARY LC_NUMERIC LC_TIME LDBL_DIG - LDBL_EPSILON LDBL_MANT_DIG LDBL_MAX LDBL_MAX_10_EXP - LDBL_MAX_EXP LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP LINK_MAX - LONG_MAX LONG_MIN L_ctermid L_cuserid L_tmpname MAX_CANON - MAX_INPUT MB_CUR_MAX MB_LEN_MAX NAME_MAX NCCS NDEBUG - NGROUPS_MAX NOFLSH NULL OPEN_MAX OPOST O_ACCMODE O_APPEND - O_CREAT O_EXCL O_NOCTTY O_NONBLOCK O_RDONLY O_RDWR O_TRUNC - O_WRONLY PARENB PARMRK PARODD PATH_MAX PIPE_BUF RAND_MAX R_OK - SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK SA_RESETHAND - SA_RESTART SA_SIGINFO SCHAR_MAX SCHAR_MIN SEEK_CUR SEEK_END - SEEK_SET SHRT_MAX SHRT_MIN SIGABRT SIGALRM SIGBUS SIGCHLD - SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGKILL SIGPIPE SIGPOLL - SIGPROF SIGQUIT SIGRTMAX SIGRTMIN SIGSEGV SIGSTOP SIGSYS - SIGTERM SIGTRAP SIGTSTP SIGTTIN SIGTTOU SIGURG SIGUSR1 - SIGUSR2 SIGVTALRM SIGXCPU SIGXFSZ SIG_BLOCK SIG_DFL SIG_ERR - SIG_IGN SIG_SETMASK SIG_UNBLOCK SSIZE_MAX STDERR_FILENO - STDIN_FILENO STDOUT_FILENO STREAM_MAX S_IRGRP S_IROTH S_IRUSR - S_IRWXG S_IRWXO S_IRWXU S_ISBLK S_ISCHR S_ISDIR S_ISFIFO - S_ISGID S_ISREG S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP - S_IXOTH S_IXUSR TCIFLUSH TCIOFF TCIOFLUSH TCION TCOFLUSH - TCOOFF TCOON TCSADRAIN TCSAFLUSH TCSANOW TMP_MAX TOSTOP - TZNAME_MAX UCHAR_MAX UINT_MAX ULONG_MAX USHRT_MAX VEOF VEOL - VERASE VINTR VKILL VMIN VQUIT VSTART VSTOP VSUSP VTIME - WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED WNOHANG WSTOPSIG - WTERMSIG WUNTRACED W_OK X_OK _PC_CHOWN_RESTRICTED - _PC_LINK_MAX _PC_MAX_CANON _PC_MAX_INPUT _PC_NAME_MAX - _PC_NO_TRUNC _PC_PATH_MAX _PC_PIPE_BUF _PC_VDISABLE - _POSIX_ARG_MAX _POSIX_CHILD_MAX _POSIX_CHOWN_RESTRICTED - _POSIX_JOB_CONTROL _POSIX_LINK_MAX _POSIX_MAX_CANON - _POSIX_MAX_INPUT _POSIX_NAME_MAX _POSIX_NGROUPS_MAX - _POSIX_NO_TRUNC _POSIX_OPEN_MAX _POSIX_PATH_MAX - _POSIX_PIPE_BUF _POSIX_SAVED_IDS _POSIX_SSIZE_MAX - _POSIX_STREAM_MAX _POSIX_TZNAME_MAX _POSIX_VDISABLE - _POSIX_VERSION _SC_ARG_MAX _SC_CHILD_MAX _SC_CLK_TCK - _SC_JOB_CONTROL _SC_NGROUPS_MAX _SC_OPEN_MAX _SC_PAGESIZE - _SC_SAVED_IDS _SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION _exit - abort access acos asctime asin assert atan atexit atof atoi - atol bsearch calloc ceil cfgetispeed cfgetospeed cfsetispeed - cfsetospeed clearerr clock cosh creat ctermid ctime cuserid - difftime div dup dup2 errno execl execle execlp execv execve - execvp fabs fclose fdopen feof ferror fflush fgetc fgetpos - fgets floor fmod fopen fpathconf fprintf fputc fputs fread - free freopen frexp fscanf fseek fsetpos fstat fsync ftell - fwrite getchar getcwd getegid getenv geteuid getgid getgroups - getpid gets getuid isalnum isalpha isatty iscntrl isdigit - isgraph islower isprint ispunct isspace isupper isxdigit labs - ldexp ldiv localeconv log10 longjmp lseek malloc mblen - mbstowcs mbtowc memchr memcmp memcpy memmove memset mkfifo - mktime modf offsetof pathconf pause perror pow putc putchar - puts qsort raise realloc remove rewind scanf setbuf setgid - setjmp setlocale setpgid setsid setuid setvbuf sigaction - siglongjmp signal sigpending sigprocmask sigsetjmp sigsuspend - sinh sscanf stderr stdin stdout strcat strchr strcmp strcoll - strcpy strcspn strerror strftime strlen strncat strncmp - strncpy strpbrk strrchr strspn strstr strtod strtok strtol - strtoul strxfrm sysconf tan tanh tcdrain tcflow tcflush - tcgetattr tcgetpgrp tcsendbreak tcsetattr tcsetpgrp tmpfile - tmpnam tolower toupper ttyname tzname tzset uname ungetc - vfprintf vprintf vsprintf wcstombs wctomb)], - EXPORT_OK => [qw(abs alarm atan2 chdir chmod chown close closedir cos exit - exp fcntl fileno fork getc getgrgid getgrnam getlogin - getpgrp getppid getpwnam getpwuid gmtime kill lchown link - localtime log mkdir nice open opendir pipe printf rand - read readdir rename rewinddir rmdir sin sleep sprintf sqrt - srand stat system time times umask unlink utime wait - waitpid write)], + EXPORT => [sort + # this stuff was in 5.20.2 + qw( + %SIGRT ARG_MAX B0 B110 B1200 B134 B150 B1800 B19200 B200 + B2400 B300 B38400 B4800 B50 B600 B75 B9600 BRKINT BUFSIZ + CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX CLK_TCK CLOCAL + CLOCKS_PER_SEC CREAD CS5 CS6 CS7 CS8 CSIZE CSTOPB DBL_DIG + DBL_EPSILON DBL_MANT_DIG DBL_MAX DBL_MAX_10_EXP DBL_MAX_EXP + DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP E2BIG EACCES EADDRINUSE + EADDRNOTAVAIL EAFNOSUPPORT EAGAIN EALREADY EBADF EBADMSG EBUSY + ECANCELED ECHILD ECHO ECHOE ECHOK ECHONL ECONNABORTED + ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT + EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EIDRM EILSEQ + EINPROGRESS EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE + EMLINK EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH + ENFILE ENOBUFS ENODATA ENODEV ENOENT ENOEXEC ENOLCK ENOLINK + ENOMEM ENOMSG ENOPROTOOPT ENOSPC ENOSR ENOSTR ENOSYS ENOTBLK + ENOTCONN ENOTDIR ENOTEMPTY ENOTRECOVERABLE ENOTSOCK ENOTSUP + ENOTTY ENXIO EOF EOPNOTSUPP EOTHER EOVERFLOW EOWNERDEAD EPERM + EPFNOSUPPORT EPIPE EPROCLIM EPROTO EPROTONOSUPPORT EPROTOTYPE + ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT ESPIPE + ESRCH ESTALE ETIME ETIMEDOUT ETOOMANYREFS ETXTBSY EUSERS + EWOULDBLOCK EXDEV + EXIT_FAILURE EXIT_SUCCESS FD_CLOEXEC FILENAME_MAX + FLT_DIG FLT_EPSILON FLT_MANT_DIG FLT_MAX FLT_MAX_10_EXP + FLT_MAX_EXP FLT_MIN FLT_MIN_10_EXP FLT_MIN_EXP FLT_RADIX + FLT_ROUNDS F_DUPFD F_GETFD F_GETFL F_GETLK F_OK F_RDLCK + F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK HUGE_VAL + HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR INLCR INPCK + INT_MAX INT_MIN ISIG ISTRIP IXOFF IXON LC_ALL LC_COLLATE + LC_CTYPE LC_MESSAGES LC_MONETARY LC_NUMERIC LC_TIME LDBL_DIG + LDBL_EPSILON LDBL_MANT_DIG LDBL_MAX LDBL_MAX_10_EXP + LDBL_MAX_EXP LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP LINK_MAX + LONG_MAX LONG_MIN L_ctermid L_cuserid L_tmpname MAX_CANON + MAX_INPUT MB_CUR_MAX MB_LEN_MAX NAME_MAX NCCS NDEBUG + NGROUPS_MAX NOFLSH NULL OPEN_MAX OPOST O_ACCMODE O_APPEND + O_CREAT O_EXCL O_NOCTTY O_NONBLOCK O_RDONLY O_RDWR O_TRUNC + O_WRONLY PARENB PARMRK PARODD PATH_MAX PIPE_BUF RAND_MAX R_OK + SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK SA_RESETHAND + SA_RESTART SA_SIGINFO SCHAR_MAX SCHAR_MIN SEEK_CUR SEEK_END + SEEK_SET SHRT_MAX SHRT_MIN SIGABRT SIGALRM SIGBUS SIGCHLD + SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGKILL SIGPIPE SIGPOLL + SIGPROF SIGQUIT SIGRTMAX SIGRTMIN SIGSEGV SIGSTOP SIGSYS + SIGTERM SIGTRAP SIGTSTP SIGTTIN SIGTTOU SIGURG SIGUSR1 + SIGUSR2 SIGVTALRM SIGXCPU SIGXFSZ SIG_BLOCK SIG_DFL SIG_ERR + SIG_IGN SIG_SETMASK SIG_UNBLOCK SSIZE_MAX STDERR_FILENO + STDIN_FILENO STDOUT_FILENO STREAM_MAX S_IRGRP S_IROTH S_IRUSR + S_IRWXG S_IRWXO S_IRWXU S_ISBLK S_ISCHR S_ISDIR S_ISFIFO + S_ISGID S_ISREG S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP + S_IXOTH S_IXUSR TCIFLUSH TCIOFF TCIOFLUSH TCION TCOFLUSH + TCOOFF TCOON TCSADRAIN TCSAFLUSH TCSANOW TMP_MAX TOSTOP + TZNAME_MAX UCHAR_MAX UINT_MAX ULONG_MAX USHRT_MAX VEOF VEOL + VERASE VINTR VKILL VMIN VQUIT VSTART VSTOP VSUSP VTIME + WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED WNOHANG WSTOPSIG + WTERMSIG WUNTRACED W_OK X_OK _PC_CHOWN_RESTRICTED + _PC_LINK_MAX _PC_MAX_CANON _PC_MAX_INPUT _PC_NAME_MAX + _PC_NO_TRUNC _PC_PATH_MAX _PC_PIPE_BUF _PC_VDISABLE + _POSIX_ARG_MAX _POSIX_CHILD_MAX _POSIX_CHOWN_RESTRICTED + _POSIX_JOB_CONTROL _POSIX_LINK_MAX _POSIX_MAX_CANON + _POSIX_MAX_INPUT _POSIX_NAME_MAX _POSIX_NGROUPS_MAX + _POSIX_NO_TRUNC _POSIX_OPEN_MAX _POSIX_PATH_MAX + _POSIX_PIPE_BUF _POSIX_SAVED_IDS _POSIX_SSIZE_MAX + _POSIX_STREAM_MAX _POSIX_TZNAME_MAX _POSIX_VDISABLE + _POSIX_VERSION _SC_ARG_MAX _SC_CHILD_MAX _SC_CLK_TCK + _SC_JOB_CONTROL _SC_NGROUPS_MAX _SC_OPEN_MAX _SC_PAGESIZE + _SC_SAVED_IDS _SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION _exit + abort access acos asctime asin assert atan atexit atof atoi + atol bsearch calloc ceil cfgetispeed cfgetospeed cfsetispeed + cfsetospeed clearerr clock cosh creat ctermid ctime cuserid + difftime div dup dup2 errno execl execle execlp execv execve + execvp fabs fclose fdopen feof ferror fflush fgetc fgetpos + fgets floor fmod fopen fpathconf fprintf fputc fputs fread + free freopen frexp fscanf fseek fsetpos fstat fsync ftell + fwrite getchar getcwd getegid getenv geteuid getgid getgroups + getpid gets getuid isalnum isalpha isatty iscntrl isdigit + isgraph islower isprint ispunct isspace isupper isxdigit labs + ldexp ldiv localeconv log10 longjmp lseek malloc mblen + mbstowcs mbtowc memchr memcmp memcpy memmove memset mkfifo + mktime modf offsetof pathconf pause perror pow putc putchar + puts qsort raise realloc remove rewind scanf setbuf setgid + setjmp setlocale setpgid setsid setuid setvbuf sigaction + siglongjmp signal sigpending sigprocmask sigsetjmp sigsuspend + sinh sscanf stderr stdin stdout strcat strchr strcmp strcoll + strcpy strcspn strerror strftime strlen strncat strncmp + strncpy strpbrk strrchr strspn strstr strtod strtok strtol + strtoul strxfrm sysconf tan tanh tcdrain tcflow tcflush + tcgetattr tcgetpgrp tcsendbreak tcsetattr tcsetpgrp tmpfile + tmpnam tolower toupper ttyname tzname tzset uname ungetc + vfprintf vprintf vsprintf wcstombs wctomb + ), + # this stuff was added in 5.21 + qw( + FP_ILOGB0 FP_ILOGBNAN FP_INFINITE FP_NAN FP_NORMAL FP_SUBNORMAL FP_ZERO + M_1_PI M_2_PI M_2_SQRTPI M_E M_LN10 M_LN2 M_LOG10E M_LOG2E M_PI + M_PI_2 M_PI_4 M_SQRT1_2 M_SQRT2 INFINITY NAN + ), + # this stuff was added for Windows in 5.23 + ($^O eq 'MSWin32' ? qw( + WSAEINTR WSAEBADF WSAEACCES WSAEFAULT WSAEINVAL WSAEMFILE WSAEWOULDBLOCK + WSAEINPROGRESS WSAEALREADY WSAENOTSOCK WSAEDESTADDRREQ WSAEMSGSIZE + WSAEPROTOTYPE WSAENOPROTOOPT WSAEPROTONOSUPPORT WSAESOCKTNOSUPPORT + WSAEOPNOTSUPP WSAEPFNOSUPPORT WSAEAFNOSUPPORT WSAEADDRINUSE + WSAEADDRNOTAVAIL WSAENETDOWN WSAENETUNREACH WSAENETRESET WSAECONNABORTED + WSAECONNRESET WSAENOBUFS WSAEISCONN WSAENOTCONN WSAESHUTDOWN + WSAETOOMANYREFS WSAETIMEDOUT WSAECONNREFUSED WSAELOOP WSAENAMETOOLONG + WSAEHOSTDOWN WSAEHOSTUNREACH WSAENOTEMPTY WSAEPROCLIM WSAEUSERS + WSAEDQUOT WSAESTALE WSAEREMOTE WSAEDISCON WSAENOMORE WSAECANCELLED + WSAEINVALIDPROCTABLE WSAEINVALIDPROVIDER WSAEPROVIDERFAILEDINIT + WSAEREFUSED + ) : ()), + # adding new functions to EXPORT is a BACKWARD COMPATIBILITY BREAKING CHANGE + # it is OK to add new constants, but new functions may only go in EXPORT_OK + ], + EXPORT_OK => [sort + # this stuff was in 5.20.2 + qw( + abs alarm atan2 chdir chmod chown close closedir cos exit + exp fcntl fileno fork getc getgrgid getgrnam getlogin + getpgrp getppid getpwnam getpwuid gmtime kill lchown link + localtime log mkdir nice open opendir pipe printf rand + read readdir rename rewinddir rmdir sin sleep sprintf sqrt + srand stat system time times umask unlink utime wait + waitpid write + ), + # this stuff was added in 5.21 + qw( + FE_DOWNWARD FE_TONEAREST FE_TOWARDZERO FE_UPWARD + fegetround fesetround + Inf NaN + acosh asinh atanh cbrt copysign erf erfc exp2 expm1 fdim + fma fmax fmin fpclassify hypot ilogb isfinite isgreater + isgreaterequal isinf isless islessequal islessgreater isnan + isnormal isunordered j0 j1 jn lgamma log1p log2 logb lrint nan + nearbyint nextafter nexttoward remainder remquo rint round scalbn + signbit tgamma trunc y0 y1 yn strtold + ), + # this stuff was added in 5.23 + qw( + getpayload issignaling setpayload setpayloadsig + ILL_ILLOPC ILL_ILLOPN ILL_ILLADR ILL_ILLTRP ILL_PRVOPC ILL_PRVREG + ILL_COPROC ILL_BADSTK + FPE_INTDIV FPE_INTOVF FPE_FLTDIV FPE_FLTOVF FPE_FLTUND + FPE_FLTRES FPE_FLTINV FPE_FLTSUB + SEGV_MAPERR SEGV_ACCERR + BUS_ADRALN BUS_ADRERR BUS_OBJERR + TRAP_BRKPT TRAP_TRACE + CLD_EXITED CLD_KILLED CLD_DUMPED CLD_TRAPPED CLD_STOPPED CLD_CONTINUED + POLL_IN POLL_OUT POLL_MSG POLL_ERR POLL_PRI POLL_HUP + SI_USER SI_QUEUE SI_TIMER SI_ASYNCIO SI_MESGQ + ), + # this was implemented in 5.21, but not exported; it was added to + # @EXPORT_OK late in 5.23, and will be added to :math_h_c99 tag early + # in 5.25 + qw( lround ), + ], ); plan (tests => 2 * keys %expect); diff --git a/gnu/usr.bin/perl/ext/POSIX/t/is.t b/gnu/usr.bin/perl/ext/POSIX/t/is.t deleted file mode 100644 index 0ab328e2f15..00000000000 --- a/gnu/usr.bin/perl/ext/POSIX/t/is.t +++ /dev/null @@ -1,121 +0,0 @@ -#!./perl -w - -use strict; -use Test::More; -use Config; - -BEGIN { - plan(skip_all => "\$^O eq '$^O'") if $^O eq 'VMS'; - plan(skip_all => "POSIX is unavailable") - unless $Config{extensions} =~ /\bPOSIX\b/; -} - -use POSIX; - -# E.g. \t might or might not be isprint() depending on the locale, -# so let's reset to the default. -setlocale(LC_ALL, 'C') if $Config{d_setlocale}; - -$| = 1; - -# List of characters (and strings) to feed to the is<xxx> functions. -# -# The left-hand side (key) is a character or string. -# The right-hand side (value) is a list of character classes to which -# this string belongs. This is a *complete* list: any classes not -# listed, are expected to return '0' for the given string. -my %classes = - ( - 'a' => [ qw(print graph alnum alpha lower xdigit) ], - 'A' => [ qw(print graph alnum alpha upper xdigit) ], - 'z' => [ qw(print graph alnum alpha lower) ], - 'Z' => [ qw(print graph alnum alpha upper) ], - '0' => [ qw(print graph alnum digit xdigit) ], - '9' => [ qw(print graph alnum digit xdigit) ], - '.' => [ qw(print graph punct) ], - '?' => [ qw(print graph punct) ], - ' ' => [ qw(print space) ], - "\t" => [ qw(cntrl space) ], - "\001" => [ qw(cntrl) ], - - # Multi-character strings. These are logically ANDed, so the - # presence of different types of chars in one string will - # reduce the list on the right. - 'abc' => [ qw(print graph alnum alpha lower xdigit) ], - 'az' => [ qw(print graph alnum alpha lower) ], - 'aZ' => [ qw(print graph alnum alpha) ], - 'abc ' => [ qw(print) ], - - '012aF' => [ qw(print graph alnum xdigit) ], - - " \t" => [ qw(space) ], - - "abcde\001" => [], - - # An empty string. Always true (al least in old days) [bug #24554] - '' => [ qw(print graph alnum alpha lower upper digit xdigit - punct cntrl space) ], - ); - - -# Pass 1: convert the above arrays to hashes. While doing so, obtain -# a complete list of all the 'is<xxx>' functions. At least, the ones -# listed above. -my %functions; -foreach my $s (keys %classes) { - $classes{$s} = { map { - $functions{"is$_"}++; # Keep track of all the 'is<xxx>' functions - "is$_" => 1; # Our return value: is<xxx>($s) should pass. - } @{$classes{$s}} }; -} - -# Expected number of tests is one each for every combination of a -# known is<xxx> function and string listed above. -plan(tests => keys(%classes) * keys(%functions) + 1); - -# Main test loop: Run all POSIX::is<xxx> tests on each string defined above. -# Only the character classes listed for that string should return 1. We -# always run all functions on every string, and expect to get 0 for the -# character classes not listed in the given string's hash value. -# -foreach my $s (sort keys %classes) { - foreach my $f (sort keys %functions) { - my $expected = exists $classes{$s}->{$f}; - my $actual = eval "no warnings 'deprecated'; POSIX::$f( \$s )"; - - cmp_ok($actual, '==', $expected, "$f('$s')"); - } -} - -{ - my @warnings; - local $SIG {__WARN__} = sub { push @warnings, @_; }; - - foreach (0 .. 3) { - my $a; - $a =POSIX::isalnum("a"); - $a =POSIX::isalpha("a"); - $a =POSIX::iscntrl("a"); - $a =POSIX::isdigit("a"); - $a =POSIX::isgraph("a"); - $a =POSIX::islower("a"); - $a =POSIX::ispunct("a"); - $a =POSIX::isspace("a"); - $a =POSIX::isupper("a"); - $a =POSIX::isxdigit("a"); - $a =POSIX::isalnum("a"); - $a =POSIX::isalpha("a"); - $a =POSIX::iscntrl("a"); - $a =POSIX::isdigit("a"); - $a =POSIX::isgraph("a"); - $a =POSIX::islower("a"); - $a =POSIX::ispunct("a"); - $a =POSIX::isspace("a"); - $a =POSIX::isupper("a"); - $a =POSIX::isxdigit("a"); - } - - # Each of the 10 classes should warn twice, because each has 2 lexical - # calls - is(scalar @warnings, 20); -} diff --git a/gnu/usr.bin/perl/ext/POSIX/t/iscrash b/gnu/usr.bin/perl/ext/POSIX/t/iscrash new file mode 100644 index 00000000000..94d04cb54e6 --- /dev/null +++ b/gnu/usr.bin/perl/ext/POSIX/t/iscrash @@ -0,0 +1,20 @@ +# test file for checking that the is*() functions don't crash +use Win32API::File qw(SetErrorMode SEM_NOGPFAULTERRORBOX SEM_NOOPENFILEERRORBOX); +use strict; +use threads; +use POSIX qw(isalpha islower); + +SetErrorMode(SEM_NOGPFAULTERRORBOX | SEM_NOOPENFILEERRORBOX); + +use warnings; # we want the warnings code to run +$SIG{__WARN__} = sub {}; # but don't want to display them + +my $t1 = threads->create(sub { isalpha("c") }); +$t1->join; + +islower("a"); + +my $t2 = threads->create(sub { isalpha("a") }); +$t2->join; + +print "ok\n"; diff --git a/gnu/usr.bin/perl/ext/POSIX/t/math.t b/gnu/usr.bin/perl/ext/POSIX/t/math.t index bf0c2decc4a..54067d1f02d 100644 --- a/gnu/usr.bin/perl/ext/POSIX/t/math.t +++ b/gnu/usr.bin/perl/ext/POSIX/t/math.t @@ -2,9 +2,13 @@ use strict; -use POSIX; +use POSIX ':math_h_c99'; +use POSIX ':nan_payload'; +use POSIX 'lround'; use Test::More; +use Config; + # These tests are mainly to make sure that these arithmetic functions # exist and are accessible. They are not meant to be an exhaustive # test for the interface. @@ -52,4 +56,192 @@ between(0.76, tanh(1), 0.77, 'tanh(1)'); between(-0.77, tanh(-1), -0.76, 'tanh(-1)'); cmp_ok(tanh(1), '==', -tanh(-1), 'tanh(1) == -tanh(-1)'); +SKIP: { + skip "no fpclassify", 4 unless $Config{d_fpclassify}; + is(fpclassify(1), FP_NORMAL, "fpclassify 1"); + is(fpclassify(0), FP_ZERO, "fpclassify 0"); + is(fpclassify(INFINITY), FP_INFINITE, "fpclassify INFINITY"); + is(fpclassify(NAN), FP_NAN, "fpclassify NAN"); +} + +sub near { + my ($got, $want, $msg, $eps) = @_; + $eps ||= 1e-6; + cmp_ok(abs($got - $want), '<', $eps, $msg); +} + +SKIP: { + unless ($Config{d_acosh}) { + skip "no acosh, suspecting no C99 math"; + } + if ($^O =~ /Win32|VMS/) { + skip "running in $^O, C99 math support uneven"; + } + near(M_SQRT2, 1.4142135623731, "M_SQRT2", 1e-9); + near(M_E, 2.71828182845905, "M_E", 1e-9); + near(M_PI, 3.14159265358979, "M_PI", 1e-9); + near(acosh(2), 1.31695789692482, "acosh", 1e-9); + near(asinh(1), 0.881373587019543, "asinh", 1e-9); + near(atanh(0.5), 0.549306144334055, "atanh", 1e-9); + near(cbrt(8), 2, "cbrt", 1e-9); + near(cbrt(-27), -3, "cbrt", 1e-9); + near(copysign(3.14, -2), -3.14, "copysign", 1e-9); + near(expm1(2), 6.38905609893065, "expm1", 1e-9); + near(expm1(1e-6), 1.00000050000017e-06, "expm1", 1e-9); + is(fdim(12, 34), 0, "fdim 12 34"); + is(fdim(34, 12), 22, "fdim 34 12"); + is(fmax(12, 34), 34, "fmax 12 34"); + is(fmin(12, 34), 12, "fmin 12 34"); + is(hypot(3, 4), 5, "hypot 3 4"); + near(hypot(-2, 1), sqrt(5), "hypot -1 2", 1e-9); + is(ilogb(255), 7, "ilogb 255"); + is(ilogb(256), 8, "ilogb 256"); + ok(isfinite(1), "isfinite 1"); + ok(!isfinite(Inf), "isfinite Inf"); + ok(!isfinite(NaN), "isfinite NaN"); + ok(isinf(INFINITY), "isinf INFINITY"); + ok(isinf(Inf), "isinf Inf"); + ok(!isinf(NaN), "isinf NaN"); + ok(!isinf(42), "isinf 42"); + ok(isnan(NAN), "isnan NAN"); + ok(isnan(NaN), "isnan NaN"); + ok(!isnan(Inf), "isnan Inf"); + ok(!isnan(42), "isnan Inf"); + cmp_ok(nan(), '!=', nan(), 'nan'); + near(log1p(2), 1.09861228866811, "log1p", 1e-9); + near(log1p(1e-6), 9.99999500000333e-07, "log1p", 1e-9); + near(log2(8), 3, "log2", 1e-9); + is(signbit(2), 0, "signbit 2"); # zero + ok(signbit(-2), "signbit -2"); # non-zero + is(round(2.25), 2, "round 2.25"); + is(round(-2.25), -2, "round -2.25"); + is(round(2.5), 3, "round 2.5"); + is(round(-2.5), -3, "round -2.5"); + is(round(2.75), 3, "round 2.75"); + is(round(-2.75), -3, "round 2.75"); + is(lround(-2.75), -3, "lround -0.25"); + is(signbit(lround(-0.25)), 0, "lround -0.25 -> +0"); # unlike round() + is(trunc(2.25), 2, "trunc 2.25"); + is(trunc(-2.25), -2, "trunc -2.25"); + is(trunc(2.5), 2, "trunc 2.5"); + is(trunc(-2.5), -2, "trunc -2.5"); + is(trunc(2.75), 2, "trunc 2.75"); + is(trunc(-2.75), -2, "trunc -2.75"); + ok(isless(1, 2), "isless 1 2"); + ok(!isless(2, 1), "isless 2 1"); + ok(!isless(1, 1), "isless 1 1"); + ok(!isless(1, NaN), "isless 1 NaN"); + ok(isgreater(2, 1), "isgreater 2 1"); + ok(islessequal(1, 1), "islessequal 1 1"); + ok(isunordered(1, NaN), "isunordered 1 NaN"); + + near(erf(0.5), 0.520499877813047, "erf 0.5", 1.5e-7); + near(erf(1), 0.842700792949715, "erf 1", 1.5e-7); + near(erf(9), 1, "erf 9", 1.5e-7); + near(erfc(0.5), 0.479500122186953, "erfc 0.5", 1.5e-7); + near(erfc(1), 0.157299207050285, "erfc 1", 1.5e-7); + near(erfc(9), 0, "erfc 9", 1.5e-7); + + # tgamma(n) = (n - 1)! + # lgamma(n) = log(tgamma(n)) + near(tgamma(5), 24, "tgamma 5", 1.5e-7); + near(tgamma(5.5), 52.3427777845535, "tgamma 5.5", 1.5e-7); + near(tgamma(9), 40320, "tgamma 9", 1.5e-7); + near(lgamma(5), 3.17805383034795, "lgamma 4", 1.5e-7); + near(lgamma(5.5), 3.95781396761872, "lgamma 5.5", 1.5e-7); + near(lgamma(9), 10.6046029027452, "lgamma 9", 1.5e-7); + + # These don't work on old mips/hppa platforms because == Inf (or == -Inf). + # ok(isnan(setpayload(0)), "setpayload zero"); + # is(getpayload(setpayload(0)), 0, "setpayload + getpayload (zero)"); + # + # These don't work on most platforms because == Inf (or == -Inf). + # ok(isnan(setpayloadsig(0)), "setpayload zero"); + # is(getpayload(setpayloadsig(0)), 0, "setpayload + getpayload (zero)"); + + # Verify that the payload set be setpayload() + # (1) still is a nan + # (2) but the payload can be retrieved + # (3) but is not signaling + my $x = 0; + setpayload($x, 0x12345); + ok(isnan($x), "setpayload + isnan"); + is(getpayload($x), 0x12345, "setpayload + getpayload"); + ok(!issignaling($x), "setpayload + issignaling"); + + # Verify that the signaling payload set be setpayloadsig() + # (1) still is a nan + # (2) but the payload can be retrieved + # (3) and is signaling + setpayloadsig($x, 0x12345); + ok(isnan($x), "setpayloadsig + isnan"); + is(getpayload($x), 0x12345, "setpayloadsig + getpayload"); + SKIP: { + # https://rt.perl.org/Ticket/Display.html?id=125710 + # In the 32-bit x86 ABI cannot preserve the signaling bit + # (the x87 simply does not preserve that). But using the + # 80-bit extended format aka long double, the bit is preserved. + # https://gcc.gnu.org/bugzilla/show_bug.cgi?id=57484 + my $could_be_x86_32 = + # This is a really weak test: there are other 32-bit + # little-endian platforms than just Intel (some embedded + # processors, for example), but we use this just for not + # bothering with the test if things look iffy. + # We could, say, $Config{ccsymbols} =~ /\b__[xi][3-7]86=1\b/, + # but that feels quite shaky. + $Config{byteorder} =~ /1234/ && + $Config{longdblkind} == 3 && + $Config{ptrsize} == 4; + skip($^O, 1) if $could_be_x86_32 && !$Config{uselongdouble}; + ok(issignaling($x), "setpayloadsig + issignaling"); + } + + # Try a payload more than one byte. + is(getpayload(nan(0x12345)), 0x12345, "nan + getpayload"); + + # Try payloads of 2^k, most importantly at and beyond 2^32. These + # tests will fail if NV is just 32-bit float, but that Should Not + # Happen (tm). + is(getpayload(nan(2**31)), 2**31, "nan + getpayload 2**31"); + is(getpayload(nan(2**32)), 2**32, "nan + getpayload 2**32"); + is(getpayload(nan(2**33)), 2**33, "nan + getpayload 2**33"); + + # Payloads just lower than 2^k. + is(getpayload(nan(2**31-1)), 2**31-1, "nan + getpayload 2**31-1"); + is(getpayload(nan(2**32-1)), 2**32-1, "nan + getpayload 2**32-1"); + + # Payloads not divisible by two (and larger than 2**32). + + SKIP: { + # solaris gets 10460353202 from getpayload() when it should + # get 10460353203 (the 3**21). Things go wrong already in + # the nan() payload setting: [0x2, 0x6f7c52b4] (ivsize=4) + # instead [0x2, 0x6f7c52b3]. Then at getpayload() things + # go wrong again, now in other direction: with the (wrong) + # [0x2, 0x6f7c52b4] encoded in the nan we should decode into + # 10460353204, but we get 10460353202. It doesn't seem to + # help even if we use 'unsigned long long' instead of UV/U32 + # in the POSIX.xs:S_setpayload/S_getpayload. + # + # casting bug? fmod() bug? Though also broken with + # -Duselongdouble + fmodl(), so maybe Solaris cc bug + # in general? + # + # Ironically, the large prime seems to work even in Solaris, + # probably just by blind luck. + skip($^O, 1) if $^O eq 'solaris'; + is(getpayload(nan(3**21)), 3**21, "nan + getpayload 3**21"); + } + is(getpayload(nan(4294967311)), 4294967311, "nan + getpayload prime"); + + # Truncates towards zero. + is(getpayload(nan(1234.567)), 1234, "nan (trunc) + getpayload"); + + # Not signaling. + ok(!issignaling(0), "issignaling zero"); + ok(!issignaling(+Inf), "issignaling +Inf"); + ok(!issignaling(-Inf), "issignaling -Inf"); + ok(!issignaling(NaN), "issignaling NaN"); +} # SKIP + done_testing(); diff --git a/gnu/usr.bin/perl/ext/POSIX/t/posix.t b/gnu/usr.bin/perl/ext/POSIX/t/posix.t index cd46485d9bf..bd5c3009fcf 100644 --- a/gnu/usr.bin/perl/ext/POSIX/t/posix.t +++ b/gnu/usr.bin/perl/ext/POSIX/t/posix.t @@ -6,9 +6,11 @@ BEGIN { print "1..0\n"; exit 0; } + unshift @INC, "../../t"; + require 'loc_tools.pl'; } -use Test::More tests => 115; +use Test::More tests => 94; use POSIX qw(fcntl_h signal_h limits_h _exit getcwd open read strftime write errno localeconv dup dup2 lseek access); @@ -162,7 +164,7 @@ like( getcwd(), qr/$pat/, 'getcwd' ); SKIP: { skip("strtod() not present", 2) unless $Config{d_strtod}; - if ($Config{d_setlocale}) { + if (locales_enabled('LC_NUMERIC')) { $lc = &POSIX::setlocale(&POSIX::LC_NUMERIC); &POSIX::setlocale(&POSIX::LC_NUMERIC, 'C'); } @@ -172,7 +174,23 @@ SKIP: { cmp_ok(abs("3.14159" - $n), '<', 1e-6, 'strtod works'); is($x, 6, 'strtod works'); - &POSIX::setlocale(&POSIX::LC_NUMERIC, $lc) if $Config{d_setlocale}; + &POSIX::setlocale(&POSIX::LC_NUMERIC, $lc) if locales_enabled('LC_NUMERIC'); +} + +SKIP: { + skip("strtold() not present", 2) unless $Config{d_strtold}; + + if (locales_enabled('LC_NUMERIC')) { + $lc = &POSIX::setlocale(&POSIX::LC_NUMERIC); + &POSIX::setlocale(&POSIX::LC_NUMERIC, 'C'); + } + + # we're just checking that strtold works, not how accurate it is + ($n, $x) = &POSIX::strtod('2.718_ISH'); + cmp_ok(abs("2.718" - $n), '<', 1e-6, 'strtold works'); + is($x, 4, 'strtold works'); + + &POSIX::setlocale(&POSIX::LC_NUMERIC, $lc) if locales_enabled('LC_NUMERIC'); } SKIP: { @@ -209,7 +227,7 @@ sub try_strftime { is($got, $expect, "validating mini_mktime() and strftime(): $expect"); } -if ($Config{d_setlocale}) { +if (locales_enabled('LC_TIME')) { $lc = &POSIX::setlocale(&POSIX::LC_TIME); &POSIX::setlocale(&POSIX::LC_TIME, 'C'); } @@ -248,7 +266,7 @@ try_strftime("Fri Mar 31 00:00:00 2000 091", 0,0,0, 31,2,100); try_strftime("Thu Dec 30 00:00:00 1999 364", 0,0,0, -1,0,100,0,10); } -&POSIX::setlocale(&POSIX::LC_TIME, $lc) if $Config{d_setlocale}; +&POSIX::setlocale(&POSIX::LC_TIME, $lc) if locales_enabled('LC_TIME'); { for my $test (0, 1) { @@ -290,45 +308,12 @@ is ($result, undef, "fgets should fail"); like ($@, qr/^Use method IO::Handle::gets\(\) instead/, "check its redef message"); -{ - no warnings 'deprecated'; - # Simplistic tests for the isXXX() functions (bug #16799) - ok( POSIX::isalnum('1'), 'isalnum' ); - ok(!POSIX::isalnum('*'), 'isalnum' ); - ok( POSIX::isalpha('f'), 'isalpha' ); - ok(!POSIX::isalpha('7'), 'isalpha' ); - ok( POSIX::iscntrl("\cA"),'iscntrl' ); - ok(!POSIX::iscntrl("A"), 'iscntrl' ); - ok( POSIX::isdigit('1'), 'isdigit' ); - ok(!POSIX::isdigit('z'), 'isdigit' ); - ok( POSIX::isgraph('@'), 'isgraph' ); - ok(!POSIX::isgraph(' '), 'isgraph' ); - ok( POSIX::islower('l'), 'islower' ); - ok(!POSIX::islower('L'), 'islower' ); - ok( POSIX::isupper('U'), 'isupper' ); - ok(!POSIX::isupper('u'), 'isupper' ); - ok( POSIX::isprint('$'), 'isprint' ); - ok(!POSIX::isprint("\n"), 'isprint' ); - ok( POSIX::ispunct('%'), 'ispunct' ); - ok(!POSIX::ispunct('u'), 'ispunct' ); - ok( POSIX::isspace("\t"), 'isspace' ); - ok(!POSIX::isspace('_'), 'isspace' ); - ok( POSIX::isxdigit('f'), 'isxdigit' ); - ok(!POSIX::isxdigit('g'), 'isxdigit' ); - # metaphysical question : what should be returned for an empty string ? - # anyway this shouldn't segfault (bug #24554) - ok( POSIX::isalnum(''), 'isalnum empty string' ); - ok( POSIX::isalnum(undef),'isalnum undef' ); - # those functions should stringify their arguments - ok(!POSIX::isalpha([]), 'isalpha []' ); - ok( POSIX::isprint([]), 'isprint []' ); -} - eval { use strict; POSIX->import("S_ISBLK"); my $x = S_ISBLK }; unlike( $@, qr/Can't use string .* as a symbol ref/, "Can import autoloaded constants" ); SKIP: { - skip("localeconv() not present", 20) unless $Config{d_locconv}; + skip("locales not available", 26) unless locales_enabled(qw(NUMERIC MONETARY)); + skip("localeconv() not available", 26) unless $Config{d_locconv}; my $conv = localeconv; is(ref $conv, 'HASH', 'localconv returns a hash reference'); @@ -359,7 +344,7 @@ SKIP: { int_p_sign_posn int_n_sign_posn ); } - + foreach (@lconv) { SKIP: { skip("localeconv has no result for $_", 1) @@ -417,6 +402,21 @@ 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"); +} + # Check that output is not flushed by _exit. This test should be last # in the file, and is not counted in the total number of tests. if ($^O eq 'vos') { diff --git a/gnu/usr.bin/perl/ext/POSIX/t/sigaction.t b/gnu/usr.bin/perl/ext/POSIX/t/sigaction.t index 1d0315f0942..d19341c2461 100644 --- a/gnu/usr.bin/perl/ext/POSIX/t/sigaction.t +++ b/gnu/usr.bin/perl/ext/POSIX/t/sigaction.t @@ -11,7 +11,7 @@ BEGIN{ } } -use Test::More tests => 33; +use Test::More tests => 36; use strict; use vars qw/$bad $bad7 $ok10 $bad18 $ok/; @@ -191,11 +191,37 @@ SKIP: { } SKIP: { + my %siginfo = ( + signo => SIGHUP, + pid => $$, + uid => $<, + ); + my %opt_val = ( code => 'SI_USER' ); + my %always = map +($_ => 1), qw(signo code); + my %skip = ( code => { darwin => "not set to SI_USER for kill()" } ); + $skip{pid}{$^O} = $skip{uid}{$^O} = "not set for kill()" + if (($^O.$Config{osvers}) =~ /^darwin[0-8]\./ + || + ($^O.$Config{osvers}) =~ /^openbsd[0-5]\./); + my $tests = keys %{{ %siginfo, %opt_val }}; eval 'use POSIX qw(SA_SIGINFO); SA_SIGINFO'; - skip("no SA_SIGINFO", 1) if $@; - skip("SA_SIGINFO is broken on AIX 4.2", 1) if ($^O.$Config{osvers}) =~ m/^aix4\.2/; + skip("no SA_SIGINFO", $tests) if $@; + skip("SA_SIGINFO is broken on AIX 4.2", $tests) if ($^O.$Config{osvers}) =~ m/^aix4\.2/; + skip("SA_SIGINFO is broken on os390", $tests) if ($^O.$Config{osvers}) =~ m/os390/; + eval "use POSIX qw($opt_val{$_}); \$siginfo{$_} = $opt_val{$_}" + for keys %opt_val; sub hiphup { - is($_[1]->{signo}, SIGHUP, "SA_SIGINFO got right signal"); + for my $field (sort keys %{{ %siginfo, %opt_val }}) { + SKIP: { + skip("siginfo_t has no $field field", 1) + unless %always{$field} or ($Config{"d_siginfo_si_$field"} || '') eq 'define'; + skip("no constant defined for SA_SIGINFO $field value $opt_val{$field}", 1) + unless defined $siginfo{$field}; + skip("SA_SIGINFO $field value is wrong on $^O: $skip{$field}{$^O}", 1) + if $skip{$field}{$^O}; + is($_[1]->{$field}, $siginfo{$field}, "SA_SIGINFO got right $field") + } + } } my $act = POSIX::SigAction->new('hiphup', 0, SA_SIGINFO); sigaction(SIGHUP, $act); diff --git a/gnu/usr.bin/perl/ext/POSIX/t/strerror_errno.t b/gnu/usr.bin/perl/ext/POSIX/t/strerror_errno.t new file mode 100644 index 00000000000..df691f177f0 --- /dev/null +++ b/gnu/usr.bin/perl/ext/POSIX/t/strerror_errno.t @@ -0,0 +1,24 @@ +use Config; +use Test::More; + +# This is placed in a separate file, as some 'requires' and 'uses' are known +# to cause it to not fail even with the bug it's testing still being +# broken. [perl #123503]. + +plan(skip_all => "POSIX is unavailable") + unless $Config{extensions} =~ /\bPOSIX\b/; + +require POSIX; + +$! = 1; +POSIX::strerror(1); +is (0+$!, 1, 'strerror doesn\'t destroy $!'); + +# [perl #126229] POSIX::strerror() clears $! +{ + local $! = 29; + my $e = POSIX::strerror($!); + is (0+$!, 29); +} + +done_testing(); diff --git a/gnu/usr.bin/perl/ext/POSIX/t/time.t b/gnu/usr.bin/perl/ext/POSIX/t/time.t index 472624f3e05..6a906e031d6 100644 --- a/gnu/usr.bin/perl/ext/POSIX/t/time.t +++ b/gnu/usr.bin/perl/ext/POSIX/t/time.t @@ -1,5 +1,10 @@ #!perl -w +BEGIN { + unshift @INC, "../../t"; + require 'loc_tools.pl'; +} + use strict; use Config; @@ -48,7 +53,7 @@ is(asctime(POSIX::localtime(12345678)), ctime(12345678), # Careful! strftime() is locale sensitive. Let's take care of that my $orig_loc = 'C'; -if ( $Config{d_setlocale} ) { +if (locales_enabled('LC_TIME')) { $orig_loc = setlocale(LC_TIME) || die "Cannot get locale information: $!"; setlocale(LC_TIME, "C") || die "Cannot setlocale() to C: $!"; } @@ -72,7 +77,7 @@ is(ord strftime($ss, POSIX::localtime(time)), 223, 'Format string has correct character'); unlike($ss, qr/\w/, 'Still not internally UTF-8 encoded'); -if ( $Config{d_setlocale} ) { +if (locales_enabled('LC_TIME')) { setlocale(LC_TIME, $orig_loc) || die "Cannot setlocale() back to orig: $!"; } diff --git a/gnu/usr.bin/perl/ext/POSIX/t/wrappers.t b/gnu/usr.bin/perl/ext/POSIX/t/wrappers.t index 5b9f6d630d8..f09b92595f1 100644 --- a/gnu/usr.bin/perl/ext/POSIX/t/wrappers.t +++ b/gnu/usr.bin/perl/ext/POSIX/t/wrappers.t @@ -10,6 +10,8 @@ plan(skip_all => "POSIX is unavailable") require POSIX; require Symbol; require File::Temp; +unshift @INC, "../../t"; +require 'loc_tools.pl'; use constant NOT_HERE => 'this-file-should-not-exist'; @@ -21,6 +23,24 @@ my $temp_file = $temp_fh->filename; # exit, fork, waitpid, sleep in waitpid.t # errno in posix.t +if (locales_enabled('LC_MESSAGES')) { + my $non_english_locale; + local $! = 1; + my $english_message = "$!"; # Should be C locale since not in scope of + # "use locale" + for $non_english_locale (find_locales(&POSIX::LC_MESSAGES, + 'reasonable_locales_only')) + { + use locale; + setlocale(&POSIX::LC_MESSAGES, $non_english_locale); + $! = 1; + last if "$!" ne $english_message; + } + + # If we found a locale whose message wasn't in English, we have + # setlocale() to it. +} + is(POSIX::abs(-42), 42, 'abs'); is(POSIX::abs(-3.14), 3.14, 'abs'); is(POSIX::abs(POSIX::exp(1)), CORE::exp(1), 'abs'); @@ -115,8 +135,10 @@ is(POSIX::sprintf('%o', 42), '52', 'sprintf'); is(POSIX::sqrt(256), 16, 'sqrt'); is_deeply([POSIX::stat($temp_file)], [stat $temp_file], 'stat'); { + use locale; local $! = 2; my $error = "$!"; + no locale; is(POSIX::strerror(2), $error, 'strerror'); } diff --git a/gnu/usr.bin/perl/ext/POSIX/typemap b/gnu/usr.bin/perl/ext/POSIX/typemap index e6a82dc3840..753afcd1a54 100644 --- a/gnu/usr.bin/perl/ext/POSIX/typemap +++ b/gnu/usr.bin/perl/ext/POSIX/typemap @@ -14,16 +14,33 @@ cc_t T_IV POSIX::SigSet T_OPAQUEPTROBJ POSIX::Termios T_OPAQUEPTROBJ POSIX::SigAction T_HVREF +POSIX::SigNo T_SIGNO +POSIX::Fd T_FD INPUT T_OPAQUEPTROBJ - if (SvROK($arg) && sv_derived_from($arg, \"${ntype}\")) { - $var = ($type)SvPV_nolen(SvRV($arg)); + { + SV * sv = $arg; + if (SvROK(sv) && sv_derived_from(sv, \"${ntype}\")) + $var = ($type)SvPV_nolen(SvRV(sv)); + else + croak(\"%s: %s is not of type %s\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\", \"$ntype\"); + } + +T_SIGNO + if ((sig = SvIV($arg)) < 0) { + croak(\"%s: Negative signals are not allowed %d\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + sig); + } + +T_FD + if ((fd = (int)SvIV($arg)) < 0) { + SETERRNO(EBADF, RMS_IFI); + XSRETURN_IV(-1); } - else - Perl_croak(aTHX_ \"%s: %s is not of type %s\", - ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, - \"$var\", \"$ntype\") OUTPUT T_OPAQUEPTROBJ diff --git a/gnu/usr.bin/perl/ext/PerlIO-encoding/encoding.pm b/gnu/usr.bin/perl/ext/PerlIO-encoding/encoding.pm index 8d39ed9a205..13cb20b3bd9 100644 --- a/gnu/usr.bin/perl/ext/PerlIO-encoding/encoding.pm +++ b/gnu/usr.bin/perl/ext/PerlIO-encoding/encoding.pm @@ -1,7 +1,7 @@ package PerlIO::encoding; use strict; -our $VERSION = '0.18'; +our $VERSION = '0.24'; our $DEBUG = 0; $DEBUG and warn __PACKAGE__, " called by ", join(", ", caller), "\n"; diff --git a/gnu/usr.bin/perl/ext/PerlIO-encoding/encoding.xs b/gnu/usr.bin/perl/ext/PerlIO-encoding/encoding.xs index fababd1d702..ee0836ff730 100644 --- a/gnu/usr.bin/perl/ext/PerlIO-encoding/encoding.xs +++ b/gnu/usr.bin/perl/ext/PerlIO-encoding/encoding.xs @@ -49,13 +49,23 @@ typedef struct { #define NEEDS_LINES 1 -SV * +static const MGVTBL PerlIOEncode_tag = { 0, 0, 0, 0, 0, 0, 0, 0 }; + +static SV * PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags) { PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode); - SV *sv = &PL_sv_undef; - PERL_UNUSED_ARG(param); + SV *sv; PERL_UNUSED_ARG(flags); + /* During cloning, return an undef token object so that _pushed() knows + * that it should not call methods and wait for _dup() to actually dup the + * encoding object. */ + if (param) { + sv = newSV(0); + sv_magicext(sv, NULL, PERL_MAGIC_ext, &PerlIOEncode_tag, 0, 0); + return sv; + } + sv = &PL_sv_undef; if (e->enc) { dSP; /* Not 100% sure stack swap is right thing to do during dup ... */ @@ -77,7 +87,7 @@ PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags) return sv; } -IV +static IV PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg, PerlIO_funcs *tab) { PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode); @@ -85,6 +95,14 @@ PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg, PerlIO_funcs * IV code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv,tab); SV *result = Nullsv; + if (SvTYPE(arg) >= SVt_PVMG + && mg_findext(arg, PERL_MAGIC_ext, &PerlIOEncode_tag)) { + e->enc = NULL; + e->chk = NULL; + e->inEncodeCall = 0; + return code; + } + PUSHSTACKi(PERLSI_MAGIC); ENTER; SAVETMPS; @@ -154,7 +172,7 @@ PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg, PerlIO_funcs * return code; } -IV +static IV PerlIOEncode_popped(pTHX_ PerlIO * f) { PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode); @@ -177,7 +195,7 @@ PerlIOEncode_popped(pTHX_ PerlIO * f) return 0; } -STDCHAR * +static STDCHAR * PerlIOEncode_get_base(pTHX_ PerlIO * f) { PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode); @@ -214,7 +232,7 @@ PerlIOEncode_get_base(pTHX_ PerlIO * f) return e->base.buf; } -IV +static IV PerlIOEncode_fill(pTHX_ PerlIO * f) { PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode); @@ -385,7 +403,10 @@ PerlIOEncode_fill(pTHX_ PerlIO * f) if (avail == 0) PerlIOBase(f)->flags |= PERLIO_F_EOF; else + { PerlIOBase(f)->flags |= PERLIO_F_ERROR; + Perl_PerlIO_save_errno(aTHX_ f); + } } FREETMPS; LEAVE; @@ -393,7 +414,7 @@ PerlIOEncode_fill(pTHX_ PerlIO * f) return code; } -IV +static IV PerlIOEncode_flush(pTHX_ PerlIO * f) { PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode); @@ -441,8 +462,8 @@ PerlIOEncode_flush(pTHX_ PerlIO * f) if (!SvPOKp(e->bufsv) || SvTHINKFIRST(e->bufsv)) (void)SvPV_force_nolen(e->bufsv); if ((STDCHAR *)SvPVX(e->bufsv) != e->base.buf) { - e->base.ptr = SvEND(e->bufsv); - e->base.end = SvPVX(e->bufsv) + (e->base.end-e->base.buf); + e->base.ptr = (STDCHAR *)SvEND(e->bufsv); + e->base.end = (STDCHAR *)SvPVX(e->bufsv) + (e->base.end-e->base.buf); e->base.buf = (STDCHAR *)SvPVX(e->bufsv); } (void)PerlIOEncode_get_base(aTHX_ f); @@ -510,7 +531,7 @@ PerlIOEncode_flush(pTHX_ PerlIO * f) return code; } -IV +static IV PerlIOEncode_close(pTHX_ PerlIO * f) { PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode); @@ -539,7 +560,7 @@ PerlIOEncode_close(pTHX_ PerlIO * f) return code; } -Off_t +static Off_t PerlIOEncode_tell(pTHX_ PerlIO * f) { PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); @@ -553,7 +574,7 @@ PerlIOEncode_tell(pTHX_ PerlIO * f) return PerlIO_tell(PerlIONext(f)); } -PerlIO * +static PerlIO * PerlIOEncode_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * params, int flags) { @@ -563,11 +584,14 @@ PerlIOEncode_dup(pTHX_ PerlIO * f, PerlIO * o, if (oe->enc) { fe->enc = PerlIO_sv_dup(aTHX_ oe->enc, params); } + if (oe->chk) { + fe->chk = PerlIO_sv_dup(aTHX_ oe->chk, params); + } } return f; } -SSize_t +static SSize_t PerlIOEncode_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) { PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode); @@ -599,7 +623,7 @@ PerlIOEncode_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) } } -PerlIO_funcs PerlIO_encode = { +static PERLIO_FUNCS_DECL(PerlIO_encode) = { sizeof(PerlIO_funcs), "encoding", sizeof(PerlIOEncode), @@ -650,7 +674,7 @@ BOOT: Perl_warner(aTHX_ packWARN(WARN_IO), ":encoding without 'use Encode'"); #endif /* The SV is magically freed by load_module */ - load_module(PERL_LOADMOD_NOIMPORT, newSVpvn("Encode", 6), Nullsv, Nullsv); + load_module(PERL_LOADMOD_NOIMPORT, newSVpvs("Encode"), Nullsv, Nullsv); assert(sp == PL_stack_sp); } PUSHMARK(sp); @@ -663,7 +687,7 @@ BOOT: sv_setsv(chk, POPs); PUTBACK; #ifdef PERLIO_LAYERS - PerlIO_define_layer(aTHX_ &PerlIO_encode); + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_encode)); #endif POPSTACK; } diff --git a/gnu/usr.bin/perl/ext/PerlIO-encoding/t/encoding.t b/gnu/usr.bin/perl/ext/PerlIO-encoding/t/encoding.t index 6b4d3d068a6..cba14a82439 100755 --- a/gnu/usr.bin/perl/ext/PerlIO-encoding/t/encoding.t +++ b/gnu/usr.bin/perl/ext/PerlIO-encoding/t/encoding.t @@ -9,6 +9,11 @@ BEGIN { print "1..0 # Skip: not Encode\n"; exit 0; } + if (ord("A") == 193) { + print "1..0 # Skip: EBCDIC\n"; + exit 0; + } + require "../../t/charset_tools.pl"; } use Test::More tests => 24; @@ -37,13 +42,9 @@ if (open(GRK, ">$grk")) { if (open(UTF, "<$utf")) { binmode(UTF, ":bytes"); - if (ord('A') == 193) { # EBCDIC - # alpha beta gamma in UTF-EBCDIC Unicode (0x3b1 0x3b2 0x3b3) - is(scalar <UTF>, "\xb4\x58\xb4\x59\xb4\x62"); - } else { - # alpha beta gamma in UTF-8 Unicode (0x3b1 0x3b2 0x3b3) - is(scalar <UTF>, "\xce\xb1\xce\xb2\xce\xb3"); - } + + # alpha beta gamma in UTF-8 Unicode (0x3b1 0x3b2 0x3b3) + is(scalar <UTF>, byte_utf8a_to_utf8n("\xce\xb1\xce\xb2\xce\xb3")); close UTF; } diff --git a/gnu/usr.bin/perl/ext/PerlIO-encoding/t/fallback.t b/gnu/usr.bin/perl/ext/PerlIO-encoding/t/fallback.t index 3944f7dff01..17c241c17a0 100755 --- a/gnu/usr.bin/perl/ext/PerlIO-encoding/t/fallback.t +++ b/gnu/usr.bin/perl/ext/PerlIO-encoding/t/fallback.t @@ -1,19 +1,23 @@ #!./perl BEGIN { - skip_all("No perlio") unless (find PerlIO::Layer 'perlio'); + unless (find PerlIO::Layer 'perlio') { + print "1..0 # No perlio\n"; + exit 0; + } if (ord("A") == 193) { print "1..0 # Skip: EBCDIC\n"; exit 0; } - unless( eval { require Encode } ) { + unless ( eval { require Encode } ) { print "1..0 # Skip: No Encode\n"; exit 0; } - use Test::More tests => 9; import Encode qw(:fallback_all); } +use Test::More tests => 9; + # $PerlIO::encoding = 0; # WARN_ON_ERR|PERLQQ; my $file = "fallback$$.txt"; diff --git a/gnu/usr.bin/perl/ext/PerlIO-encoding/t/nolooping.t b/gnu/usr.bin/perl/ext/PerlIO-encoding/t/nolooping.t index 4acb0f59d74..5e262be7f4e 100755 --- a/gnu/usr.bin/perl/ext/PerlIO-encoding/t/nolooping.t +++ b/gnu/usr.bin/perl/ext/PerlIO-encoding/t/nolooping.t @@ -10,10 +10,11 @@ BEGIN { use Config; -use Test::More $Config{useperlio} - ? (tests => 1) - : (skip_all => 'No PerlIO enabled'); - +use Test::More (ord("A") == 65 && $Config{useperlio}) + ? (tests => 1) + : (skip_all => '(No PerlIO enabled;' + . ' or is EBCDIC platform which doesnt have' + . ' "use encoding" used by open ":locale")'); BEGIN { $SIG{__WARN__} = sub { $warn .= $_[0] }; } diff --git a/gnu/usr.bin/perl/ext/PerlIO-encoding/t/threads.t b/gnu/usr.bin/perl/ext/PerlIO-encoding/t/threads.t new file mode 100644 index 00000000000..64f0e559a63 --- /dev/null +++ b/gnu/usr.bin/perl/ext/PerlIO-encoding/t/threads.t @@ -0,0 +1,35 @@ +#!perl + +use strict; +use warnings; + +BEGIN { + use Config; + if ($Config{extensions} !~ /\bEncode\b/) { + print "1..0 # Skip: no Encode\n"; + exit 0; + } + unless ($Config{useithreads}) { + print "1..0 # Skip: no threads\n"; + exit 0; + } +} + +use threads; + +use Test::More tests => 3 + 1; + +binmode *STDOUT, ':encoding(UTF-8)'; + +SKIP: { + local $@; + my $ret = eval { + my $thread = threads->create(sub { pass 'in thread'; return 1 }); + skip 'test thread could not be spawned' => 3 unless $thread; + $thread->join; + }; + is $@, '', 'thread did not croak'; + is $ret, 1, 'thread returned the right value'; +} + +pass 'passes at least one test'; diff --git a/gnu/usr.bin/perl/ext/PerlIO-mmap/mmap.pm b/gnu/usr.bin/perl/ext/PerlIO-mmap/mmap.pm index cf97882fa59..0ed59d2db49 100644 --- a/gnu/usr.bin/perl/ext/PerlIO-mmap/mmap.pm +++ b/gnu/usr.bin/perl/ext/PerlIO-mmap/mmap.pm @@ -1,7 +1,7 @@ package PerlIO::mmap; use strict; use warnings; -our $VERSION = '0.011'; +our $VERSION = '0.016'; use XSLoader; XSLoader::load(__PACKAGE__, __PACKAGE__->VERSION); diff --git a/gnu/usr.bin/perl/ext/PerlIO-mmap/mmap.xs b/gnu/usr.bin/perl/ext/PerlIO-mmap/mmap.xs index 4c96da84f78..b3f1c4fd50e 100644 --- a/gnu/usr.bin/perl/ext/PerlIO-mmap/mmap.xs +++ b/gnu/usr.bin/perl/ext/PerlIO-mmap/mmap.xs @@ -1,10 +1,4 @@ /* - * Local variables: - * c-indentation-style: bsd - * c-basic-offset: 4 - * indent-tabs-mode: nil - * End: - * * ex: set ts=8 sts=4 sw=4 et: */ @@ -29,7 +23,7 @@ typedef struct { STDCHAR *bbuf; /* malloced buffer if map fails */ } PerlIOMmap; -IV +static IV PerlIOMmap_map(pTHX_ PerlIO *f) { dVAR; @@ -40,8 +34,12 @@ PerlIOMmap_map(pTHX_ PerlIO *f) abort(); if (flags & PERLIO_F_CANREAD) { PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); - const int fd = PerlIO_fileno(f); Stat_t st; + const int fd = PerlIO_fileno(f); + if (fd < 0) { + SETERRNO(EBADF,RMS_IFI); + return -1; + } code = Fstat(fd, &st); if (code == 0 && S_ISREG(st.st_mode)) { SSize_t len = st.st_size - b->posn; @@ -90,7 +88,7 @@ PerlIOMmap_map(pTHX_ PerlIO *f) return code; } -IV +static IV PerlIOMmap_unmap(pTHX_ PerlIO *f) { PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap); @@ -118,7 +116,7 @@ PerlIOMmap_unmap(pTHX_ PerlIO *f) return code; } -STDCHAR * +static STDCHAR * PerlIOMmap_get_base(pTHX_ PerlIO *f) { PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap); @@ -151,7 +149,7 @@ PerlIOMmap_get_base(pTHX_ PerlIO *f) return PerlIOBuf_get_base(aTHX_ f); } -SSize_t +static SSize_t PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) { PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap); @@ -182,7 +180,7 @@ PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) return PerlIOBuf_unread(aTHX_ f, vbuf, count); } -SSize_t +static SSize_t PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) { PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap); @@ -209,7 +207,7 @@ PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) return PerlIOBuf_write(aTHX_ f, vbuf, count); } -IV +static IV PerlIOMmap_flush(pTHX_ PerlIO *f) { PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap); @@ -237,7 +235,7 @@ PerlIOMmap_flush(pTHX_ PerlIO *f) return code; } -IV +static IV PerlIOMmap_fill(pTHX_ PerlIO *f) { PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); @@ -251,30 +249,14 @@ PerlIOMmap_fill(pTHX_ PerlIO *f) return code; } -IV -PerlIOMmap_close(pTHX_ PerlIO *f) -{ - PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap); - PerlIOBuf * const b = &m->base; - IV code = PerlIO_flush(f); - if (m->bbuf) { - b->buf = m->bbuf; - m->bbuf = NULL; - b->ptr = b->end = b->buf; - } - if (PerlIOBuf_close(aTHX_ f) != 0) - code = -1; - return code; -} - -PerlIO * +static PerlIO * PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) { return PerlIOBase_dup(aTHX_ f, o, param, flags); } -PERLIO_FUNCS_DECL(PerlIO_mmap) = { +static PERLIO_FUNCS_DECL(PerlIO_mmap) = { sizeof(PerlIO_funcs), "mmap", sizeof(PerlIOMmap), diff --git a/gnu/usr.bin/perl/ext/PerlIO-scalar/scalar.pm b/gnu/usr.bin/perl/ext/PerlIO-scalar/scalar.pm index 7e93f6da562..4ed4e4060da 100644 --- a/gnu/usr.bin/perl/ext/PerlIO-scalar/scalar.pm +++ b/gnu/usr.bin/perl/ext/PerlIO-scalar/scalar.pm @@ -1,5 +1,5 @@ package PerlIO::scalar; -our $VERSION = '0.18_01'; +our $VERSION = '0.24'; require XSLoader; XSLoader::load(); 1; diff --git a/gnu/usr.bin/perl/ext/PerlIO-scalar/scalar.xs b/gnu/usr.bin/perl/ext/PerlIO-scalar/scalar.xs index 5c5eccf812a..f3dff499bd6 100644 --- a/gnu/usr.bin/perl/ext/PerlIO-scalar/scalar.xs +++ b/gnu/usr.bin/perl/ext/PerlIO-scalar/scalar.xs @@ -15,7 +15,7 @@ typedef struct { Off_t posn; } PerlIOScalar; -IV +static IV PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg, PerlIO_funcs * tab) { @@ -46,7 +46,7 @@ PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg, } } else { - s->var = newSVpvn("", 0); + s->var = newSVpvs(""); } SvUPGRADE(s->var, SVt_PV); @@ -73,7 +73,7 @@ PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg, return code; } -IV +static IV PerlIOScalar_popped(pTHX_ PerlIO * f) { PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); @@ -84,7 +84,7 @@ PerlIOScalar_popped(pTHX_ PerlIO * f) return 0; } -IV +static IV PerlIOScalar_close(pTHX_ PerlIO * f) { IV code = PerlIOBase_close(aTHX_ f); @@ -92,14 +92,14 @@ PerlIOScalar_close(pTHX_ PerlIO * f) return code; } -IV +static IV PerlIOScalar_fileno(pTHX_ PerlIO * f) { PERL_UNUSED_ARG(f); return -1; } -IV +static IV PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence) { PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); @@ -133,7 +133,7 @@ PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence) return 0; } -Off_t +static Off_t PerlIOScalar_tell(pTHX_ PerlIO * f) { PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); @@ -141,7 +141,7 @@ PerlIOScalar_tell(pTHX_ PerlIO * f) } -SSize_t +static SSize_t PerlIOScalar_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) { if (!f) @@ -149,6 +149,7 @@ PerlIOScalar_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) { PerlIOBase(f)->flags |= PERLIO_F_ERROR; SETERRNO(EBADF, SS_IVCHAN); + Perl_PerlIO_save_errno(aTHX_ f); return 0; } { @@ -186,7 +187,7 @@ PerlIOScalar_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) } } -SSize_t +static SSize_t PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count) { if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) { @@ -210,6 +211,21 @@ PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count) } else { STRLEN const cur = SvCUR(sv); + + /* ensure we don't try to create ridiculously large + * SVs on small platforms + */ +#if Size_t_size < Off_t_size + if (s->posn > SSize_t_MAX) { +#ifdef EFBIG + SETERRNO(EFBIG, SS_BUFFEROVF); +#else + SETERRNO(ENOSPC, SS_BUFFEROVF); +#endif + return 0; + } +#endif + if ((STRLEN)s->posn > cur) { dst = SvGROW(sv, (STRLEN)s->posn + count + 1); Zero(SvPVX(sv) + cur, (STRLEN)s->posn - cur, char); @@ -234,21 +250,21 @@ PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count) return 0; } -IV +static IV PerlIOScalar_fill(pTHX_ PerlIO * f) { PERL_UNUSED_ARG(f); return -1; } -IV +static IV PerlIOScalar_flush(pTHX_ PerlIO * f) { PERL_UNUSED_ARG(f); return 0; } -STDCHAR * +static STDCHAR * PerlIOScalar_get_base(pTHX_ PerlIO * f) { PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); @@ -259,7 +275,7 @@ PerlIOScalar_get_base(pTHX_ PerlIO * f) return (STDCHAR *) NULL; } -STDCHAR * +static STDCHAR * PerlIOScalar_get_ptr(pTHX_ PerlIO * f) { if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) { @@ -269,7 +285,7 @@ PerlIOScalar_get_ptr(pTHX_ PerlIO * f) return (STDCHAR *) NULL; } -SSize_t +static SSize_t PerlIOScalar_get_cnt(pTHX_ PerlIO * f) { if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) { @@ -284,7 +300,7 @@ PerlIOScalar_get_cnt(pTHX_ PerlIO * f) return 0; } -Size_t +static Size_t PerlIOScalar_bufsiz(pTHX_ PerlIO * f) { if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) { @@ -295,7 +311,7 @@ PerlIOScalar_bufsiz(pTHX_ PerlIO * f) return 0; } -void +static void PerlIOScalar_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt) { PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); @@ -305,7 +321,7 @@ PerlIOScalar_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt) s->posn = len - cnt; } -PerlIO * +static PerlIO * PerlIOScalar_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO * f, int narg, SV ** args) @@ -326,7 +342,7 @@ PerlIOScalar_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers, IV n, return NULL; } -SV * +static SV * PerlIOScalar_arg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags) { PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); @@ -343,7 +359,7 @@ PerlIOScalar_arg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags) return newRV_noinc(var); } -PerlIO * +static PerlIO * PerlIOScalar_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param, int flags) { @@ -370,7 +386,7 @@ PerlIOScalar_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param, return f; } -PERLIO_FUNCS_DECL(PerlIO_scalar) = { +static PERLIO_FUNCS_DECL(PerlIO_scalar) = { sizeof(PerlIO_funcs), "scalar", sizeof(PerlIOScalar), diff --git a/gnu/usr.bin/perl/ext/PerlIO-scalar/t/scalar.t b/gnu/usr.bin/perl/ext/PerlIO-scalar/t/scalar.t index f4cfbefaf96..3dfcced38d3 100755 --- a/gnu/usr.bin/perl/ext/PerlIO-scalar/t/scalar.t +++ b/gnu/usr.bin/perl/ext/PerlIO-scalar/t/scalar.t @@ -16,7 +16,7 @@ use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END); # Not 0, 1, 2 everywhere. $| = 1; -use Test::More tests => 120; +use Test::More tests => 122; my $fh; my $var = "aaa\n"; @@ -510,3 +510,14 @@ SKIP: ok(!seek($fh, -10, SEEK_CUR), "seek to negative position"); is(tell($fh), 0, "shouldn't change the position"); } + +SKIP: +{ # write() beyond SSize_t limit + skip "Can't overflow SSize_t with Off_t", 2 + if $Config::Config{lseeksize} <= $Config::Config{sizesize}; + my $buf0 = "hello"; + open my $fh, "+<", \$buf0 or die $!; + ok(seek($fh, 2**32, SEEK_SET), "seek to a large position"); + select((select($fh), ++$|)[0]); + ok(!(print $fh "x"), "write to a large offset"); +} diff --git a/gnu/usr.bin/perl/ext/PerlIO-via/hints/aix.pl b/gnu/usr.bin/perl/ext/PerlIO-via/hints/aix.pl index 960a8fdfe09..2b23ab3be7e 100644 --- a/gnu/usr.bin/perl/ext/PerlIO-via/hints/aix.pl +++ b/gnu/usr.bin/perl/ext/PerlIO-via/hints/aix.pl @@ -1,2 +1,6 @@ # compilation may hang at -O3 level -$self->{OPTIMIZE} = '-O'; +use Config; + +my $optimize = $Config{optimize}; +$optimize =~ s/(^| )-O[2-9]\b/$1-O/g + and $self->{OPTIMIZE} = $optimize; diff --git a/gnu/usr.bin/perl/ext/PerlIO-via/via.pm b/gnu/usr.bin/perl/ext/PerlIO-via/via.pm index a10f7ee67e8..e477dcca193 100644 --- a/gnu/usr.bin/perl/ext/PerlIO-via/via.pm +++ b/gnu/usr.bin/perl/ext/PerlIO-via/via.pm @@ -1,5 +1,5 @@ package PerlIO::via; -our $VERSION = '0.15'; +our $VERSION = '0.16'; require XSLoader; XSLoader::load(); 1; diff --git a/gnu/usr.bin/perl/ext/PerlIO-via/via.xs b/gnu/usr.bin/perl/ext/PerlIO-via/via.xs index d7a037b054e..8a7f1fc9ed4 100644 --- a/gnu/usr.bin/perl/ext/PerlIO-via/via.xs +++ b/gnu/usr.bin/perl/ext/PerlIO-via/via.xs @@ -40,7 +40,7 @@ typedef struct #define MYMethod(x) #x,&s->x -CV * +static CV * PerlIOVia_fetchmethod(pTHX_ PerlIOVia * s, const char *method, CV ** save) { GV *gv = gv_fetchmeth(s->stash, method, strlen(method), 0); @@ -63,7 +63,7 @@ PerlIOVia_fetchmethod(pTHX_ PerlIOVia * s, const char *method, CV ** save) * Returns scalar returned by method (if any) otherwise sv_undef */ -SV * +static SV * PerlIOVia_method(pTHX_ PerlIO * f, const char *method, CV ** save, int flags, ...) { @@ -126,7 +126,7 @@ PerlIOVia_method(pTHX_ PerlIO * f, const char *method, CV ** save, int flags, return result; } -IV +static IV PerlIOVia_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg, PerlIO_funcs * tab) { @@ -209,7 +209,7 @@ push_failed: return code; } -PerlIO * +static PerlIO * PerlIOVia_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO * f, int narg, SV ** args) @@ -304,7 +304,7 @@ PerlIOVia_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers, return f; } -IV +static IV PerlIOVia_popped(pTHX_ PerlIO * f) { PerlIOVia *s = PerlIOSelf(f, PerlIOVia); @@ -330,7 +330,7 @@ PerlIOVia_popped(pTHX_ PerlIO * f) return 0; } -IV +static IV PerlIOVia_close(pTHX_ PerlIO * f) { PerlIOVia *s = PerlIOSelf(f, PerlIOVia); @@ -343,7 +343,7 @@ PerlIOVia_close(pTHX_ PerlIO * f) return code; } -IV +static IV PerlIOVia_fileno(pTHX_ PerlIO * f) { PerlIOVia *s = PerlIOSelf(f, PerlIOVia); @@ -352,7 +352,7 @@ PerlIOVia_fileno(pTHX_ PerlIO * f) return (result) ? SvIV(result) : PerlIO_fileno(PerlIONext(f)); } -IV +static IV PerlIOVia_binmode(pTHX_ PerlIO * f) { PerlIOVia *s = PerlIOSelf(f, PerlIOVia); @@ -365,7 +365,7 @@ PerlIOVia_binmode(pTHX_ PerlIO * f) return SvIV(result); } -IV +static IV PerlIOVia_seek(pTHX_ PerlIO * f, Off_t offset, int whence) { PerlIOVia *s = PerlIOSelf(f, PerlIOVia); @@ -385,7 +385,7 @@ PerlIOVia_seek(pTHX_ PerlIO * f, Off_t offset, int whence) #endif } -Off_t +static Off_t PerlIOVia_tell(pTHX_ PerlIO * f) { PerlIOVia *s = PerlIOSelf(f, PerlIOVia); @@ -396,7 +396,7 @@ PerlIOVia_tell(pTHX_ PerlIO * f) : (Off_t) - 1; } -SSize_t +static SSize_t PerlIOVia_unread(pTHX_ PerlIO * f, const void *vbuf, Size_t count) { PerlIOVia *s = PerlIOSelf(f, PerlIOVia); @@ -410,7 +410,7 @@ PerlIOVia_unread(pTHX_ PerlIO * f, const void *vbuf, Size_t count) } } -SSize_t +static SSize_t PerlIOVia_read(pTHX_ PerlIO * f, void *vbuf, Size_t count) { SSize_t rd = 0; @@ -435,7 +435,7 @@ PerlIOVia_read(pTHX_ PerlIO * f, void *vbuf, Size_t count) return rd; } -SSize_t +static SSize_t PerlIOVia_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count) { if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) { @@ -452,7 +452,7 @@ PerlIOVia_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count) return 0; } -IV +static IV PerlIOVia_fill(pTHX_ PerlIO * f) { if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) { @@ -476,7 +476,7 @@ PerlIOVia_fill(pTHX_ PerlIO * f) return -1; } -IV +static IV PerlIOVia_flush(pTHX_ PerlIO * f) { PerlIOVia *s = PerlIOSelf(f, PerlIOVia); @@ -489,7 +489,7 @@ PerlIOVia_flush(pTHX_ PerlIO * f) return (result) ? SvIV(result) : 0; } -STDCHAR * +static STDCHAR * PerlIOVia_get_base(pTHX_ PerlIO * f) { if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) { @@ -501,7 +501,7 @@ PerlIOVia_get_base(pTHX_ PerlIO * f) return (STDCHAR *) NULL; } -STDCHAR * +static STDCHAR * PerlIOVia_get_ptr(pTHX_ PerlIO * f) { if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) { @@ -514,7 +514,7 @@ PerlIOVia_get_ptr(pTHX_ PerlIO * f) return (STDCHAR *) NULL; } -SSize_t +static SSize_t PerlIOVia_get_cnt(pTHX_ PerlIO * f) { if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) { @@ -526,7 +526,7 @@ PerlIOVia_get_cnt(pTHX_ PerlIO * f) return 0; } -Size_t +static Size_t PerlIOVia_bufsiz(pTHX_ PerlIO * f) { if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) { @@ -537,7 +537,7 @@ PerlIOVia_bufsiz(pTHX_ PerlIO * f) return 0; } -void +static void PerlIOVia_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt) { PerlIOVia *s = PerlIOSelf(f, PerlIOVia); @@ -545,7 +545,7 @@ PerlIOVia_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt) s->cnt = cnt; } -void +static void PerlIOVia_setlinebuf(pTHX_ PerlIO * f) { PerlIOVia *s = PerlIOSelf(f, PerlIOVia); @@ -553,7 +553,7 @@ PerlIOVia_setlinebuf(pTHX_ PerlIO * f) PerlIOBase_setlinebuf(aTHX_ f); } -void +static void PerlIOVia_clearerr(pTHX_ PerlIO * f) { PerlIOVia *s = PerlIOSelf(f, PerlIOVia); @@ -561,7 +561,7 @@ PerlIOVia_clearerr(pTHX_ PerlIO * f) PerlIOBase_clearerr(aTHX_ f); } -IV +static IV PerlIOVia_error(pTHX_ PerlIO * f) { PerlIOVia *s = PerlIOSelf(f, PerlIOVia); @@ -570,7 +570,7 @@ PerlIOVia_error(pTHX_ PerlIO * f) return (result) ? SvIV(result) : PerlIOBase_error(aTHX_ f); } -IV +static IV PerlIOVia_eof(pTHX_ PerlIO * f) { PerlIOVia *s = PerlIOSelf(f, PerlIOVia); @@ -579,7 +579,7 @@ PerlIOVia_eof(pTHX_ PerlIO * f) return (result) ? SvIV(result) : PerlIOBase_eof(aTHX_ f); } -SV * +static SV * PerlIOVia_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags) { PerlIOVia *s = PerlIOSelf(f, PerlIOVia); @@ -588,7 +588,7 @@ PerlIOVia_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags) return PerlIOVia_method(aTHX_ f, MYMethod(GETARG), G_SCALAR, Nullsv); } -PerlIO * +static PerlIO * PerlIOVia_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param, int flags) { @@ -602,7 +602,7 @@ PerlIOVia_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param, -PERLIO_FUNCS_DECL(PerlIO_object) = { +static PERLIO_FUNCS_DECL(PerlIO_object) = { sizeof(PerlIO_funcs), "via", sizeof(PerlIOVia), diff --git a/gnu/usr.bin/perl/ext/Pod-Functions/Functions_pm.PL b/gnu/usr.bin/perl/ext/Pod-Functions/Functions_pm.PL index 578ec8996b0..af5d37a5f8c 100644 --- a/gnu/usr.bin/perl/ext/Pod-Functions/Functions_pm.PL +++ b/gnu/usr.bin/perl/ext/Pod-Functions/Functions_pm.PL @@ -58,13 +58,16 @@ foreach my $TL_node (@$tree[2 .. $#$tree]) { foreach my $func (@$para[2 .. $#$para]) { next unless ref $func eq 'ARRAY'; - die "Expected only C<> blocks in paragraph after item at $TL_node->[$i-2][1]{start_line}" - unless $func->[0] eq 'C' && !ref $func->[2]; - # Everything is plain text (ie $func->[2] is everything) + my $c_node = + $func->[0] eq 'C' && !ref $func->[2] ? $func : + $func->[0] eq 'L' && ref $func->[2] + && $func->[2][0] eq 'C' && !ref $func->[2][2] ? $func->[2] : + die "Expected only C<> blocks in paragraph after item at $TL_node->[$i-2][1]{start_line}"; + # Everything is plain text (ie $c_node->[2] is everything) # except for C<-I<X>>. So untangle up to one level of nested <> my $funcname = join '', map { ref $_ ? $_->[2] : $_ - } @$func[2..$#$func]; + } @$c_node[2..$#$c_node]; $funcname =~ s!(q.?)//!$1/STRING/!; push @{$Kinds{$text}}, $funcname; } @@ -91,11 +94,19 @@ while (my ($type, $funcs) = each %Kinds) { } # We sort __SUB__ after sub, but before substr, but __PACKAGE__ after package, -# and __END__ after END. +# and __END__ after END. (We create a temporary array of two elements, where +# the second has the underscores squeezed out, and sort on that element +# first.) sub sort_funcs { map { $_->[0] } - sort { uc $a->[1] cmp uc $b->[1] || $b->[1] cmp $a->[1] || $a->[0] cmp $b->[0] } - map { my $f = tr/_//dr; [ $_, $f ] } + sort { uc $a->[1] cmp uc $b->[1] + || $b->[1] cmp $a->[1] + || $a->[0] =~ /^_/ # here $a and $b are identical when + # underscores squeezed out; so if $a + # begins with an underscore, it should + # sort after $b + || $a->[0] cmp $b->[0] + } map { my $f = tr/_//dr; [ $_, $f ] } @_; } @@ -196,7 +207,7 @@ L<perlfunc/"Perl Functions by Category"> section. =cut -our $VERSION = '1.08'; +our $VERSION = '1.10'; require Exporter; diff --git a/gnu/usr.bin/perl/ext/Pod-Functions/t/Functions.t b/gnu/usr.bin/perl/ext/Pod-Functions/t/Functions.t index 53da93a46c8..2beccc1ac62 100644 --- a/gnu/usr.bin/perl/ext/Pod-Functions/t/Functions.t +++ b/gnu/usr.bin/perl/ext/Pod-Functions/t/Functions.t @@ -29,18 +29,18 @@ is( $pkg_ref, $exp_ref, '%Pod::Functions::Type_Description exported' ); is( $pkg_ref, $exp_ref, '@Pod::Functions::Type_Order exported' ); # Check @Type_Order -my @catagories = qw( +my @categories = qw( String Regexp Math ARRAY LIST HASH I/O Binary File Flow Namespace Misc Process Modules Objects Socket SysV User Network Time ); -ok( eq_array( \@Type_Order, \@catagories ), +ok( eq_array( \@Type_Order, \@categories ), '@Type_Order' ); my @cat_keys = grep exists $Type_Description{ $_ } => @Type_Order; -ok( eq_array( \@cat_keys, \@catagories ), +ok( eq_array( \@cat_keys, \@categories ), 'keys() %Type_Description' ); SKIP: { @@ -110,7 +110,7 @@ Functions for fixed-length data or records: Functions for filehandles, files, or directories: -X, chdir, chmod, chown, chroot, fcntl, glob, ioctl, link, lstat, mkdir, open, opendir, readlink, rename, rmdir, - stat, symlink, sysopen, umask, unlink, utime + select, stat, symlink, sysopen, umask, unlink, utime Keywords related to the control flow of your Perl program: __FILE__, __LINE__, __PACKAGE__, __SUB__, break, caller, diff --git a/gnu/usr.bin/perl/ext/Pod-Html/lib/Pod/Html.pm b/gnu/usr.bin/perl/ext/Pod-Html/lib/Pod/Html.pm index 8510217d807..cef329e1ef9 100644 --- a/gnu/usr.bin/perl/ext/Pod-Html/lib/Pod/Html.pm +++ b/gnu/usr.bin/perl/ext/Pod-Html/lib/Pod/Html.pm @@ -3,7 +3,7 @@ use strict; require Exporter; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); -$VERSION = 1.21_01; +$VERSION = 1.2201; @ISA = qw(Exporter); @EXPORT = qw(pod2html htmlify); @EXPORT_OK = qw(anchorify); @@ -16,11 +16,7 @@ use File::Spec; use File::Spec::Unix; use Getopt::Long; use Pod::Simple::Search; -BEGIN { - if($Config{d_setlocale}) { - require locale; import locale; # make \w work right in non-ASCII lands - } -} +use locale; # make \w work right in non-ASCII lands =head1 NAME diff --git a/gnu/usr.bin/perl/ext/Pod-Html/t/crossref.pod b/gnu/usr.bin/perl/ext/Pod-Html/t/crossref.pod index f6dddf1f58a..21ee0f4f59e 100644 --- a/gnu/usr.bin/perl/ext/Pod-Html/t/crossref.pod +++ b/gnu/usr.bin/perl/ext/Pod-Html/t/crossref.pod @@ -10,7 +10,7 @@ L<htmllink/section 2> L</"item1"> -L</"non existant section"> +L</"non existent section"> L<var-copy> diff --git a/gnu/usr.bin/perl/ext/Pod-Html/t/crossref.t b/gnu/usr.bin/perl/ext/Pod-Html/t/crossref.t index 30fa6d35fe6..bc033c46e27 100644 --- a/gnu/usr.bin/perl/ext/Pod-Html/t/crossref.t +++ b/gnu/usr.bin/perl/ext/Pod-Html/t/crossref.t @@ -66,7 +66,7 @@ __DATA__ <p><a href="#item1">"item1"</a></p> -<p><a href="#non-existant-section">"non existant section"</a></p> +<p><a href="#non-existent-section">"non existent section"</a></p> <p><a href="/[RELCURRENTWORKINGDIRECTORY]/testdir/test.lib/var-copy.html">var-copy</a></p> diff --git a/gnu/usr.bin/perl/ext/Pod-Html/t/crossref2.t b/gnu/usr.bin/perl/ext/Pod-Html/t/crossref2.t index 536cfbb4e36..70eae7e2bb3 100644 --- a/gnu/usr.bin/perl/ext/Pod-Html/t/crossref2.t +++ b/gnu/usr.bin/perl/ext/Pod-Html/t/crossref2.t @@ -62,7 +62,7 @@ __DATA__ <p><a href="#item1">"item1"</a></p> -<p><a href="#non-existant-section">"non existant section"</a></p> +<p><a href="#non-existent-section">"non existent section"</a></p> <p><a href="../testdir/test.lib/var-copy.html">var-copy</a></p> diff --git a/gnu/usr.bin/perl/ext/Pod-Html/t/crossref3.t b/gnu/usr.bin/perl/ext/Pod-Html/t/crossref3.t index ab8f055d17b..cfa0abcfcfb 100644 --- a/gnu/usr.bin/perl/ext/Pod-Html/t/crossref3.t +++ b/gnu/usr.bin/perl/ext/Pod-Html/t/crossref3.t @@ -62,7 +62,7 @@ __DATA__ <p><a href="#item1">"item1"</a></p> -<p><a href="#non-existant-section">"non existant section"</a></p> +<p><a href="#non-existent-section">"non existent section"</a></p> <p><a href="[ABSCURRENTWORKINGDIRECTORY]/testdir/test.lib/var-copy.html">var-copy</a></p> diff --git a/gnu/usr.bin/perl/ext/Pod-Html/t/htmlview.t b/gnu/usr.bin/perl/ext/Pod-Html/t/htmlview.t index 792df934047..06914d10c0d 100644 --- a/gnu/usr.bin/perl/ext/Pod-Html/t/htmlview.t +++ b/gnu/usr.bin/perl/ext/Pod-Html/t/htmlview.t @@ -193,11 +193,11 @@ blah blah <p>intermediate text</p> - - <more> HTML -</more>some text +</more> + +some text <h1 id="TESTING-URLs-hyperlinking">TESTING URLs hyperlinking</h1> diff --git a/gnu/usr.bin/perl/ext/Pod-Html/t/pod2html-lib.pl b/gnu/usr.bin/perl/ext/Pod-Html/t/pod2html-lib.pl index 42cf1c97c4f..27e3e94b967 100644 --- a/gnu/usr.bin/perl/ext/Pod-Html/t/pod2html-lib.pl +++ b/gnu/usr.bin/perl/ext/Pod-Html/t/pod2html-lib.pl @@ -64,6 +64,10 @@ sub convert_n_test { if (ord("A") == 193) { # EBCDIC. $expect =~ s/item_mat_3c_21_3e/item_mat_4c_5a_6e/; } + if (Pod::Simple->VERSION > 3.28) { + $expect =~ s/\n\n(some html)/$1/m; + $expect =~ s{(TESTING FOR AND BEGIN</h1>)\n\n}{$1}m; + } # result open my $in, $outfile or die "cannot open $outfile: $!"; diff --git a/gnu/usr.bin/perl/ext/Pod-Html/testdir/perlpodspec-copy.pod b/gnu/usr.bin/perl/ext/Pod-Html/testdir/perlpodspec-copy.pod index 97319c90b27..593a4e21aad 100644 --- a/gnu/usr.bin/perl/ext/Pod-Html/testdir/perlpodspec-copy.pod +++ b/gnu/usr.bin/perl/ext/Pod-Html/testdir/perlpodspec-copy.pod @@ -1165,53 +1165,53 @@ a requirement that these be passed as an actual list or array.) For example: - L<Foo::Bar> - => undef, # link text - "Foo::Bar", # possibly inferred link text - "Foo::Bar", # name - undef, # section - 'pod', # what sort of link - "Foo::Bar" # original content - - L<Perlport's section on NL's|perlport/Newlines> - => "Perlport's section on NL's", # link text - "Perlport's section on NL's", # possibly inferred link text - "perlport", # name - "Newlines", # section - 'pod', # what sort of link - "Perlport's section on NL's|perlport/Newlines" # orig. content - - L<perlport/Newlines> - => undef, # link text - '"Newlines" in perlport', # possibly inferred link text - "perlport", # name - "Newlines", # section - 'pod', # what sort of link - "perlport/Newlines" # original content - - L<crontab(5)/"DESCRIPTION"> - => undef, # link text - '"DESCRIPTION" in crontab(5)', # possibly inferred link text - "crontab(5)", # name - "DESCRIPTION", # section - 'man', # what sort of link - 'crontab(5)/"DESCRIPTION"' # original content - - L</Object Attributes> - => undef, # link text - '"Object Attributes"', # possibly inferred link text - undef, # name - "Object Attributes", # section - 'pod', # what sort of link - "/Object Attributes" # original content - - L<http://www.perl.org/> - => undef, # link text - "http://www.perl.org/", # possibly inferred link text - "http://www.perl.org/", # name - undef, # section - 'url', # what sort of link - "http://www.perl.org/" # original content + L<Foo::Bar> + => undef, # link text + "Foo::Bar", # possibly inferred link text + "Foo::Bar", # name + undef, # section + 'pod', # what sort of link + "Foo::Bar" # original content + + L<Perlport's section on NL's|perlport/Newlines> + => "Perlport's section on NL's", # link text + "Perlport's section on NL's", # possibly inferred link text + "perlport", # name + "Newlines", # section + 'pod', # what sort of link + "Perlport's section on NL's|perlport/Newlines" # orig. content + + L<perlport/Newlines> + => undef, # link text + '"Newlines" in perlport', # possibly inferred link text + "perlport", # name + "Newlines", # section + 'pod', # what sort of link + "perlport/Newlines" # original content + + L<crontab(5)/"DESCRIPTION"> + => undef, # link text + '"DESCRIPTION" in crontab(5)', # possibly inferred link text + "crontab(5)", # name + "DESCRIPTION", # section + 'man', # what sort of link + 'crontab(5)/"DESCRIPTION"' # original content + + L</Object Attributes> + => undef, # link text + '"Object Attributes"', # possibly inferred link text + undef, # name + "Object Attributes", # section + 'pod', # what sort of link + "/Object Attributes" # original content + + L<http://www.perl.org/> + => undef, # link text + "http://www.perl.org/", # possibly inferred link text + "http://www.perl.org/", # name + undef, # section + 'url', # what sort of link + "http://www.perl.org/" # original content Note that you can distinguish URL-links from anything else by the fact that they match C<m/\A\w+:[^:\s]\S*\z/>. So diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/CHANGES b/gnu/usr.bin/perl/ext/SDBM_File/CHANGES index f7296d1b3aa..f7296d1b3aa 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/CHANGES +++ b/gnu/usr.bin/perl/ext/SDBM_File/CHANGES diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/COMPARE b/gnu/usr.bin/perl/ext/SDBM_File/COMPARE index a595e831d26..a595e831d26 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/COMPARE +++ b/gnu/usr.bin/perl/ext/SDBM_File/COMPARE diff --git a/gnu/usr.bin/perl/ext/SDBM_File/Makefile.PL b/gnu/usr.bin/perl/ext/SDBM_File/Makefile.PL index 676708ca4e4..ebee26e7ce2 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/Makefile.PL +++ b/gnu/usr.bin/perl/ext/SDBM_File/Makefile.PL @@ -1,66 +1,17 @@ +use strict; use warnings; use ExtUtils::MakeMaker; -use Config; -# The existence of the ./sdbm/Makefile.PL file causes MakeMaker -# to automatically include Makefile code for the targets -# config, all, clean, realclean and sdbm/Makefile -# which perform the corresponding actions in the subdirectory. +my $define = '-DSDBM -DDUFF'; -# Work around: Darwin ppc64 bug ignores archive contents when building bundles - -$define = ($^O eq 'MSWin32') ? '-DMSDOS' : ''; -if ($^O eq 'MSWin32') { $myextlib = 'sdbm\\libsdbm$(LIB_EXT)'; } -elsif ($^O eq 'darwin' && $Config{'ldflags'} =~/-arch ppc64/) { - $myextlib = '-all_load sdbm/libsdbm$(LIB_EXT)'; } -else { $myextlib = 'sdbm/libsdbm$(LIB_EXT)'; } +my $dirfext = $^O eq 'VMS' ? '.sdbm_dir' : '.dir'; WriteMakefile( - NAME => 'SDBM_File', - MYEXTLIB => $myextlib, - XSPROTOARG => '-noprototypes', # XXX remove later? - VERSION_FROM => 'SDBM_File.pm', - DEFINE => $define, - ); - -# We don't want the default subdir rule, as it creates a race condition with the -# rule we add below. -sub MY::subdir_x { - return ''; -} - -sub MY::postamble { - if ($^O =~ /MSWin32/ && !defined($ENV{SYSTEMROOT})) { - if ($Config{'make'} =~ /dmake/i) { - # dmake-specific - return <<'EOT'; -$(MYEXTLIB): sdbm/Makefile -@[ - cd sdbm - $(MAKE) all - cd .. -] -EOT - } elsif ($Config{'make'} =~ /nmake/i) { - # - return <<'EOT'; -$(MYEXTLIB): sdbm/Makefile - cd sdbm - $(MAKE) all - cd .. -EOT - } -} elsif ($^O ne 'VMS') { - ' -$(MYEXTLIB): sdbm/Makefile - cd sdbm && $(MAKE) all -'; - } - else { - ' -$(MYEXTLIB) : [.sdbm]descrip.mms - set def [.sdbm] - $(MMS) all - set def [-] -'; - } -} + NAME => 'SDBM_File', + VERSION_FROM => 'SDBM_File.pm', + DEFINE => $define, + INC => '-I$(PERL_INC)', # force PERL_INC dir ahead of system -I's + OBJECT => '$(O_FILES)', + clean => {'FILES' => "dbu dbd dba dbe x-dbu *${dirfext} *.pag"}, + H => [qw(tune.h sdbm.h pair.h $(PERL_INC)/config.h)], + C => [qw(SDBM_File.c sdbm.c pair.c hash.c)], +); diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/README b/gnu/usr.bin/perl/ext/SDBM_File/README index a5a23e00d3c..a5a23e00d3c 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/README +++ b/gnu/usr.bin/perl/ext/SDBM_File/README diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/README.too b/gnu/usr.bin/perl/ext/SDBM_File/README.too index cc86fb4dd54..cc86fb4dd54 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/README.too +++ b/gnu/usr.bin/perl/ext/SDBM_File/README.too diff --git a/gnu/usr.bin/perl/ext/SDBM_File/SDBM_File.pm b/gnu/usr.bin/perl/ext/SDBM_File/SDBM_File.pm index 0410bef32d8..5df90857606 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/SDBM_File.pm +++ b/gnu/usr.bin/perl/ext/SDBM_File/SDBM_File.pm @@ -7,7 +7,7 @@ require Tie::Hash; require XSLoader; our @ISA = qw(Tie::Hash); -our $VERSION = "1.11"; +our $VERSION = "1.14"; our @EXPORT_OK = qw(PAGFEXT DIRFEXT PAIRMAX); use Exporter "import"; diff --git a/gnu/usr.bin/perl/ext/SDBM_File/SDBM_File.xs b/gnu/usr.bin/perl/ext/SDBM_File/SDBM_File.xs index 070f0745adb..0df2855a21a 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/SDBM_File.xs +++ b/gnu/usr.bin/perl/ext/SDBM_File/SDBM_File.xs @@ -2,7 +2,7 @@ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" -#include "sdbm/sdbm.h" +#include "sdbm.h" #define fetch_key 0 #define store_key 1 @@ -29,6 +29,8 @@ typedef datum datum_value ; MODULE = SDBM_File PACKAGE = SDBM_File PREFIX = sdbm_ +PROTOTYPES: DISABLE + SDBM_File sdbm_TIEHASH(dbtype, filename, flags, mode, pagname=NULL) char * dbtype @@ -65,7 +67,7 @@ sdbm_DESTROY(db) sdbm_close(db->dbp); do { if (db->filter[i]) - SvREFCNT_dec(db->filter[i]); + SvREFCNT_dec_NN(db->filter[i]); } while (i-- > 0); safefree(db) ; } diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/biblio b/gnu/usr.bin/perl/ext/SDBM_File/biblio index f2880dc4903..f2880dc4903 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/biblio +++ b/gnu/usr.bin/perl/ext/SDBM_File/biblio diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/dba.c b/gnu/usr.bin/perl/ext/SDBM_File/dba.c index b27c3e66a47..b27c3e66a47 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/dba.c +++ b/gnu/usr.bin/perl/ext/SDBM_File/dba.c diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/dbd.c b/gnu/usr.bin/perl/ext/SDBM_File/dbd.c index df27d174a80..df27d174a80 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/dbd.c +++ b/gnu/usr.bin/perl/ext/SDBM_File/dbd.c diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/dbe.1 b/gnu/usr.bin/perl/ext/SDBM_File/dbe.1 index 3b32272684b..3b32272684b 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/dbe.1 +++ b/gnu/usr.bin/perl/ext/SDBM_File/dbe.1 diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/dbe.c b/gnu/usr.bin/perl/ext/SDBM_File/dbe.c index 18ce54677e8..18ce54677e8 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/dbe.c +++ b/gnu/usr.bin/perl/ext/SDBM_File/dbe.c diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/dbu.c b/gnu/usr.bin/perl/ext/SDBM_File/dbu.c index d861c0f1b19..4631d40acd6 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/dbu.c +++ b/gnu/usr.bin/perl/ext/SDBM_File/dbu.c @@ -224,19 +224,29 @@ static void prdatum(FILE *stream, datum d) { int c; - char *p = d.dptr; + U8 *p = (U8 *) d.dptr; int n = d.dsize; while (n--) { - c = *p++ & 0377; + c = *p++; +#ifndef EBCDIC /* Meta notation doesn't make sense on EBCDIC systems*/ if (c & 0200) { - fprintf(stream, "M-"); - c &= 0177; + fprintf(stream, "M-"); + c &= 0177; } - if (c == 0177 || c < ' ') - fprintf(stream, "^%c", (c == 0177) ? '?' : c + '@'); - else - putc(c, stream); +#endif + /* \c notation applies for \0 . \x1f, plus \c? */ + if (c <= 0x1F || c == QUESTION_MARK_CTRL) { + fprintf(stream, "^%c", toCTRL(c)); + } +#ifdef EBCDIC /* Instead of meta, use \x{} for non-printables */ + else if (! isPRINT_A(c)) { + fprintf(stream, "\\x{%02x}", c); + } +#endif + else { /* must be an ASCII printable */ + putc(c, stream); + } } } diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/grind b/gnu/usr.bin/perl/ext/SDBM_File/grind index 23728b7d494..23728b7d494 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/grind +++ b/gnu/usr.bin/perl/ext/SDBM_File/grind diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/hash.c b/gnu/usr.bin/perl/ext/SDBM_File/hash.c index f0115baa545..f0115baa545 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/hash.c +++ b/gnu/usr.bin/perl/ext/SDBM_File/hash.c diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/linux.patches b/gnu/usr.bin/perl/ext/SDBM_File/linux.patches index cb7b1b7d8eb..cb7b1b7d8eb 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/linux.patches +++ b/gnu/usr.bin/perl/ext/SDBM_File/linux.patches diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/makefile.sdbm b/gnu/usr.bin/perl/ext/SDBM_File/makefile.sdbm index c959c1fab55..c959c1fab55 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/makefile.sdbm +++ b/gnu/usr.bin/perl/ext/SDBM_File/makefile.sdbm diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.c b/gnu/usr.bin/perl/ext/SDBM_File/pair.c index 62045ec9773..62045ec9773 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.c +++ b/gnu/usr.bin/perl/ext/SDBM_File/pair.c diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.h b/gnu/usr.bin/perl/ext/SDBM_File/pair.h index b6944edd071..b6944edd071 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.h +++ b/gnu/usr.bin/perl/ext/SDBM_File/pair.h diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/readme.ms b/gnu/usr.bin/perl/ext/SDBM_File/readme.ms index 5d2c526a7d5..5d2c526a7d5 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/readme.ms +++ b/gnu/usr.bin/perl/ext/SDBM_File/readme.ms diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.3 b/gnu/usr.bin/perl/ext/SDBM_File/sdbm.3 index 25afcbe4fee..25afcbe4fee 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.3 +++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm.3 diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.c b/gnu/usr.bin/perl/ext/SDBM_File/sdbm.c index 5241fea5133..cf5dc75d27c 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.c +++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm.c @@ -48,6 +48,8 @@ extern Free_t free proto((Malloc_t)); } #endif +const datum nullitem = {0, 0}; + /* * forward */ diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.h b/gnu/usr.bin/perl/ext/SDBM_File/sdbm.h index 2ada7a18caf..8d9cffd479f 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.h +++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm.h @@ -51,11 +51,7 @@ typedef struct { int dsize; } datum; -EXTCONST datum nullitem -#ifdef DOINIT - = {0, 0} -#endif - ; +extern const datum nullitem; #if defined(__STDC__) || defined(__cplusplus) || defined(CAN_PROTOTYPE) #define proto(p) p diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/Makefile.PL b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/Makefile.PL deleted file mode 100644 index 48e3c4916ef..00000000000 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/Makefile.PL +++ /dev/null @@ -1,53 +0,0 @@ -use ExtUtils::MakeMaker; - -my $define = '-DSDBM -DDUFF'; -$define .= ' -DWIN32 -DPERL_STATIC_SYMS' if ($^O eq 'MSWin32'); - -if ($^O eq 'VMS') { # Old VAXC compiler can't handle Duff's device - require Config; - $define =~ s/\s+-DDUFF// if $Config::Config{'vms_cc_type'} eq 'vaxc'; -} - -WriteMakefile( - NAME => 'sdbm', # (doesn't matter what the name is here) oh yes it does -# LINKTYPE => 'static', - DEFINE => $define, - INC => '-I$(PERL_INC)', # force PERL_INC dir ahead of system -I's - SKIP => [qw(dynamic dynamic_lib dlsyms)], - OBJECT => '$(O_FILES)', - clean => {'FILES' => 'dbu libsdbm.a dbd dba dbe x-dbu *.dir *.pag'}, - H => [qw(tune.h sdbm.h pair.h $(PERL_INC)/config.h)], - C => [qw(sdbm.c pair.c hash.c)] -); - -sub MY::constants { - package MY; - my $self = shift; - - $self->{INST_STATIC} = 'libsdbm$(LIB_EXT)'; - - return $self->SUPER::constants(); -} - -sub MY::top_targets { - my $r = ' -all :: static - $(NOECHO) $(NOOP) - -config :: - $(NOECHO) $(NOOP) - -lint: - lint -abchx $(LIBSRCS) - -'; - $r .= ' -# This is a workaround, the problem is that our old GNU make exports -# variables into the environment so $(MYEXTLIB) is set in here to this -# value which can not be built. -sdbm/libsdbm.a: - $(NOECHO) $(NOOP) -' unless $^O eq 'VMS'; - - return $r; -} diff --git a/gnu/usr.bin/perl/ext/SDBM_File/t/prep.t b/gnu/usr.bin/perl/ext/SDBM_File/t/prep.t index a222a648f05..14bd2e8fd6c 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/t/prep.t +++ b/gnu/usr.bin/perl/ext/SDBM_File/t/prep.t @@ -6,8 +6,8 @@ use SDBM_File; use File::Temp 'tempfile'; use Fcntl; -my ($dirfh, $dirname) = tempfile(); -my ($pagfh, $pagname) = tempfile(); +my ($dirfh, $dirname) = tempfile(UNLINK => 1); +my ($pagfh, $pagname) = tempfile(UNLINK => 1); # close so Win32 allows them to be re-opened close $dirfh; diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/tune.h b/gnu/usr.bin/perl/ext/SDBM_File/tune.h index b95c8c8634a..b95c8c8634a 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/tune.h +++ b/gnu/usr.bin/perl/ext/SDBM_File/tune.h diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/util.c b/gnu/usr.bin/perl/ext/SDBM_File/util.c index a58085d559a..a58085d559a 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/util.c +++ b/gnu/usr.bin/perl/ext/SDBM_File/util.c diff --git a/gnu/usr.bin/perl/ext/Sys-Hostname/Hostname.pm b/gnu/usr.bin/perl/ext/Sys-Hostname/Hostname.pm index 1d2e47210a7..42e9293c3fa 100644 --- a/gnu/usr.bin/perl/ext/Sys-Hostname/Hostname.pm +++ b/gnu/usr.bin/perl/ext/Sys-Hostname/Hostname.pm @@ -14,7 +14,7 @@ our $VERSION; our $host; BEGIN { - $VERSION = '1.18'; + $VERSION = '1.20'; { local $SIG{__DIE__}; eval { diff --git a/gnu/usr.bin/perl/ext/Sys-Hostname/Hostname.xs b/gnu/usr.bin/perl/ext/Sys-Hostname/Hostname.xs index 6e974dd41fe..c75bbcea69e 100644 --- a/gnu/usr.bin/perl/ext/Sys-Hostname/Hostname.xs +++ b/gnu/usr.bin/perl/ext/Sys-Hostname/Hostname.xs @@ -13,18 +13,12 @@ # define MAXHOSTNAMELEN 256 #endif -/* swiped from POSIX.xs */ -#if defined(__VMS) && !defined(__POSIX_SOURCE) -# if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) -# include <utsname.h> -# endif -#endif - #ifdef I_SYSUTSNAME # include <sys/utsname.h> #endif MODULE = Sys::Hostname PACKAGE = Sys::Hostname +PROTOTYPES: DISABLE void ghname() diff --git a/gnu/usr.bin/perl/ext/VMS-DCLsym/DCLsym.pm b/gnu/usr.bin/perl/ext/VMS-DCLsym/DCLsym.pm index f299c43b58b..b8c9c1bf376 100644 --- a/gnu/usr.bin/perl/ext/VMS-DCLsym/DCLsym.pm +++ b/gnu/usr.bin/perl/ext/VMS-DCLsym/DCLsym.pm @@ -7,7 +7,7 @@ use strict; # Package globals @ISA = ( 'DynaLoader' ); -$VERSION = '1.05_01'; +$VERSION = '1.06'; my(%Locsyms) = ( ':ID' => 'LOCAL' ); my(%Gblsyms) = ( ':ID' => 'GLOBAL'); my $DoCache = 1; @@ -265,7 +265,7 @@ Charles Bailey bailey@newman.upenn.edu =head1 VERSION -1.05_01 16-Jun-2013 +1.05 12-Feb-2011 =head1 BUGS diff --git a/gnu/usr.bin/perl/ext/VMS-DCLsym/DCLsym.xs b/gnu/usr.bin/perl/ext/VMS-DCLsym/DCLsym.xs index f0f19f4d160..242be0f510a 100644 --- a/gnu/usr.bin/perl/ext/VMS-DCLsym/DCLsym.xs +++ b/gnu/usr.bin/perl/ext/VMS-DCLsym/DCLsym.xs @@ -44,17 +44,15 @@ _getsym(name) if (retsts & 1) { PUSHs(sv_2mortal(newSVpv(valdsc.dsc$w_length ? valdsc.dsc$a_pointer : "",valdsc.dsc$w_length))); - if (GIMME) { - EXTEND(sp,2); /* just in case we're at the end of the stack */ - if (tbltype == LIB$K_CLI_LOCAL_SYM) + EXTEND(sp,2); /* just in case we're at the end of the stack */ + if (tbltype == LIB$K_CLI_LOCAL_SYM) PUSHs(sv_2mortal(newSVpv("LOCAL",5))); - else + else PUSHs(sv_2mortal(newSVpv("GLOBAL",6))); - } _ckvmssts(lib$sfree1_dd(&valdsc)); } else { - ST(0) = &PL_sv_undef; /* error - we're returning undef, if anything */ + /* error - we'll return an empty list */ switch (retsts) { case LIB$_NOSUCHSYM: break; /* nobody home */; diff --git a/gnu/usr.bin/perl/ext/VMS-Filespec/t/filespec.t b/gnu/usr.bin/perl/ext/VMS-Filespec/t/filespec.t index c14ce99c8a5..6d421e1ad92 100644 --- a/gnu/usr.bin/perl/ext/VMS-Filespec/t/filespec.t +++ b/gnu/usr.bin/perl/ext/VMS-Filespec/t/filespec.t @@ -34,6 +34,8 @@ foreach $test (@tests) { ($arg,$func,$expect2,$expect5) = split(/(?<!\\)\s+/,$test); $arg =~ s/\\//g; # to get whitespace into the argument escape with \ + $expect2 =~ s/\\//g; + $expect5 =~ s/\\//g; $expect2 = undef if $expect2 eq 'undef'; $expect2 = undef if $expect2 eq '^'; $expect5 = undef if $expect5 eq 'undef'; @@ -106,6 +108,9 @@ __some_:<__where_.__over_>__the_.__rainbow_ unixify /__some_/__where_/__over_ [...] unixify .../ ^ __lyrics_:[__are_.__very_^.__sappy_]__but_^.__rhymes_^.__are_.__true_ unixify /__lyrics_/__are_/__very_.__sappy_/__but_.__rhymes_.__are_.__true_ ^ [.$(macro)] unixify $(macro)/ ^ +^+foo.tmp unixify +foo.tmp ^ +[-.foo^_^_bar] unixify ../foo\ \ bar/ ^ +[]foo.tmp unixify ./foo.tmp ^ # and back again /__some_/__where_/__over_/__the_.__rainbow_ vmsify __some_:[__where_.__over_]__the_.__rainbow_ ^ @@ -129,6 +134,10 @@ __some_/__where_/... vmsify [.__some_.__where_...] ^ ./$(m+ vmsify []$^(m^+ ^ foo-bar-0^.01/ vmsify [.foo-bar-0_01] [.foo-bar-0^.01] \ foo.tmp vmsify ^_foo.tmp ^ ++foo.tmp vmsify ^+foo.tmp ^ +../foo\ \ bar/ vmsify [-.foo^_^_bar] ^ +./foo.tmp vmsify []foo.tmp ^ + # Fileifying directory specs __down_:[__the_.__garden_.__path_] fileify __down_:[__the_.__garden_]__path_.dir;1 ^ [.__down_.__the_.__garden_.__path_] fileify [.__down_.__the_.__garden_]__path_.dir;1 ^ diff --git a/gnu/usr.bin/perl/ext/Win32CORE/Win32CORE.c b/gnu/usr.bin/perl/ext/Win32CORE/Win32CORE.c index 91759e8082d..5024642b071 100644 --- a/gnu/usr.bin/perl/ext/Win32CORE/Win32CORE.c +++ b/gnu/usr.bin/perl/ext/Win32CORE/Win32CORE.c @@ -33,7 +33,7 @@ XS(w32_CORE_all){ * subs */ const char *function = (const char *) XSANY.any_ptr; - Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("Win32",5), newSVnv(0.27)); + Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvs("Win32"), newSVnv(0.27)); SetLastError(err); errno = saved_errno; /* mark and SP from caller are passed through unchanged */ @@ -46,7 +46,10 @@ XS_EXTERNAL(boot_Win32CORE) * and win32/buildext.pl will all generate references to it. The function * should never be called though, as Win32CORE.pm doesn't use DynaLoader. */ + PERL_UNUSED_ARG(cv); } + +EXTERN_C #if !defined(__CYGWIN__) || defined(USEIMPORTLIB) __declspec(dllexport) #endif diff --git a/gnu/usr.bin/perl/ext/XS-APItest/APItest.pm b/gnu/usr.bin/perl/ext/XS-APItest/APItest.pm index 63ea85831a0..875579e20e3 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/APItest.pm +++ b/gnu/usr.bin/perl/ext/XS-APItest/APItest.pm @@ -1,11 +1,11 @@ package XS::APItest; -{ use 5.011001; } +{ use 5.011001; } # 5.11 is a long long time ago... What gives with this? use strict; use warnings; use Carp; -our $VERSION = '0.60_01'; +our $VERSION = '0.80'; require XSLoader; @@ -40,7 +40,7 @@ sub import { } } foreach (keys %{$exports||{}}) { - next unless /\A(?:rpn|calcrpn|stufftest|swaptwostmts|looprest|scopelessblock|stmtasexpr|stmtsasexpr|loopblock|blockasexpr|swaplabel|labelconst|arrayfullexpr|arraylistexpr|arraytermexpr|arrayarithexpr|arrayexprflags)\z/; + next unless /\A(?:rpn|calcrpn|stufftest|swaptwostmts|looprest|scopelessblock|stmtasexpr|stmtsasexpr|loopblock|blockasexpr|swaplabel|labelconst|arrayfullexpr|arraylistexpr|arraytermexpr|arrayarithexpr|arrayexprflags|DEFSV|with_vars|join_with_space)\z/; $^H{"XS::APItest/$_"} = 1; delete $exports->{$_}; } @@ -254,6 +254,10 @@ They are lexically scoped. =over +=item DEFSV + +Behaves like C<$_>. + =item rpn(EXPRESSION) This construct is a Perl expression. I<EXPRESSION> must be an RPN diff --git a/gnu/usr.bin/perl/ext/XS-APItest/APItest.xs b/gnu/usr.bin/perl/ext/XS-APItest/APItest.xs index 8e78736af7a..4d41654926c 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/APItest.xs +++ b/gnu/usr.bin/perl/ext/XS-APItest/APItest.xs @@ -1,4 +1,8 @@ #define PERL_IN_XS_APITEST + +/* We want to be able to test things that aren't API yet. */ +#define PERL_EXT + #include "EXTERN.h" #include "perl.h" #include "XSUB.h" @@ -10,6 +14,61 @@ typedef PTR_TBL_t *XS__APItest__PtrTable; #define croak_fail() croak("fail at " __FILE__ " line %d", __LINE__) #define croak_fail_ne(h, w) croak("fail %p!=%p at " __FILE__ " line %d", (h), (w), __LINE__) +#ifdef EBCDIC + +void +cat_utf8a2n(SV* sv, const char * const ascii_utf8, STRLEN len) +{ + /* Converts variant UTF-8 text pointed to by 'ascii_utf8' of length 'len', + * to UTF-EBCDIC, appending that text to the text already in 'sv'. + * Currently doesn't work on invariants, as that is unneeded here, and we + * could get double translations if we did. + * + * It has the algorithm for strict UTF-8 hard-coded in to find the code + * point it represents, then calls uvchr_to_utf8() to convert to + * UTF-EBCDIC). + * + * Note that this uses code points, not characters. Thus if the input is + * the UTF-8 for the code point 0xFF, the output will be the UTF-EBCDIC for + * 0xFF, even though that code point represents different characters on + * ASCII vs EBCDIC platforms. */ + + dTHX; + char * p = (char *) ascii_utf8; + const char * const e = p + len; + + while (p < e) { + UV code_point; + U8 native_utf8[UTF8_MAXBYTES + 1]; + U8 * char_end; + U8 start = (U8) *p; + + /* Start bytes are the same in both UTF-8 and I8, therefore we can + * treat this ASCII UTF-8 byte as an I8 byte. But PL_utf8skip[] is + * indexed by NATIVE_UTF8 bytes, so transform to that */ + STRLEN char_bytes_len = PL_utf8skip[I8_TO_NATIVE_UTF8(start)]; + + if (start < 0xc2) { + croak("fail: Expecting start byte, instead got 0x%X at %s line %d", + (U8) *p, __FILE__, __LINE__); + } + code_point = (start & (((char_bytes_len) >= 7) + ? 0x00 + : (0x1F >> ((char_bytes_len)-2)))); + p++; + while (p < e && ((( (U8) *p) & 0xC0) == 0x80)) { + + code_point = (code_point << 6) | (( (U8) *p) & 0x3F); + p++; + } + + char_end = uvchr_to_utf8(native_utf8, code_point); + sv_catpvn(sv, (char *) native_utf8, char_end - native_utf8); + } +} + +#endif + /* for my_cxt tests */ #define MY_CXT_KEY "XS::APItest::_guts" XS_VERSION @@ -83,7 +142,6 @@ typedef void (freeent_function)(pTHX_ HV *, HE *); void test_freeent(freeent_function *f) { - dTHX; dSP; HV *test_hash = newHV(); HE *victim; @@ -131,6 +189,9 @@ test_freeent(freeent_function *f) { SvREFCNT_dec(test_scalar); } +/* Not that it matters much, but it's handy for the flipped character to just + * be the opposite case (at least for ASCII-range and most Latin1 as well). */ +#define FLIP_BIT ('A' ^ 'a') static I32 bitflip_key(pTHX_ IV action, SV *field) { @@ -142,24 +203,33 @@ bitflip_key(pTHX_ IV action, SV *field) { const char *p = SvPV(keysv, len); if (len) { - SV *newkey = newSV(len); - char *new_p = SvPVX(newkey); + /* Allow for the flipped val to be longer than the original. This + * is just for testing, so can afford to have some slop */ + const STRLEN newlen = len * 2; + + SV *newkey = newSV(newlen); + const char * const new_p_orig = SvPVX(newkey); + char *new_p = (char *) new_p_orig; if (SvUTF8(keysv)) { const char *const end = p + len; while (p < end) { - STRLEN len; - UV chr = utf8_to_uvchr_buf((U8 *)p, (U8 *) end, &len); - new_p = (char *)uvchr_to_utf8((U8 *)new_p, chr ^ 32); - p += len; + STRLEN curlen; + UV chr = utf8_to_uvchr_buf((U8 *)p, (U8 *) end, &curlen); + + /* Make sure don't exceed bounds */ + assert(new_p - new_p_orig + curlen < newlen); + + new_p = (char *)uvchr_to_utf8((U8 *)new_p, chr ^ FLIP_BIT); + p += curlen; } SvUTF8_on(newkey); } else { while (len--) - *new_p++ = *p++ ^ 32; + *new_p++ = *p++ ^ FLIP_BIT; } *new_p = '\0'; - SvCUR_set(newkey, SvCUR(keysv)); + SvCUR_set(newkey, new_p - new_p_orig); SvPOK_on(newkey); mg->mg_obj = newkey; @@ -260,7 +330,12 @@ rmagical_a_dummy(pTHX_ IV idx, SV *sv) { return 0; } -STATIC MGVTBL rmagical_b = { 0 }; +/* We could do "= { 0 };" but some versions of gcc do warn + * (with -Wextra) about missing initializer, this is probably gcc + * being a bit too paranoid. But since this is file-static, we can + * just have it without initializer, since it should get + * zero-initialized. */ +STATIC MGVTBL rmagical_b; STATIC void blockhook_csc_start(pTHX_ int full) @@ -401,9 +476,9 @@ THX_ck_entersub_args_scalars(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) OP *aop = cUNOPx(entersubop)->op_first; PERL_UNUSED_ARG(namegv); PERL_UNUSED_ARG(ckobj); - if (!aop->op_sibling) + if (!OpHAS_SIBLING(aop)) aop = cUNOPx(aop)->op_first; - for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) { + for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) { op_contextualize(aop, G_SCALAR); } return entersubop; @@ -413,17 +488,20 @@ STATIC OP * THX_ck_entersub_multi_sum(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) { OP *sumop = NULL; + OP *parent = entersubop; OP *pushop = cUNOPx(entersubop)->op_first; PERL_UNUSED_ARG(namegv); PERL_UNUSED_ARG(ckobj); - if (!pushop->op_sibling) + if (!OpHAS_SIBLING(pushop)) { + parent = pushop; pushop = cUNOPx(pushop)->op_first; + } while (1) { - OP *aop = pushop->op_sibling; - if (!aop->op_sibling) + OP *aop = OpSIBLING(pushop); + if (!OpHAS_SIBLING(aop)) break; - pushop->op_sibling = aop->op_sibling; - aop->op_sibling = NULL; + /* cut out first arg */ + op_sibling_splice(parent, pushop, 1, NULL); op_contextualize(aop, G_SCALAR); if (sumop) { sumop = newBINOP(OP_ADD, 0, sumop, aop); @@ -450,7 +528,7 @@ test_op_list_describe_part(SV *res, OP *o) if (o->op_flags & OPf_KIDS) { OP *k; sv_catpvs(res, "["); - for (k = cUNOPx(o)->op_first; k; k = k->op_sibling) + for (k = cUNOPx(o)->op_first; k; k = OpSIBLING(k)) test_op_list_describe_part(res, k); sv_catpvs(res, "]"); } else { @@ -477,8 +555,7 @@ THX_mkUNOP(pTHX_ U32 type, OP *first) UNOP *unop; NewOp(1103, unop, 1, UNOP); unop->op_type = (OPCODE)type; - unop->op_first = first; - unop->op_flags = OPf_KIDS; + op_sibling_splice((OP*)unop, NULL, 0, first); return (OP *)unop; } @@ -489,10 +566,8 @@ THX_mkBINOP(pTHX_ U32 type, OP *first, OP *last) BINOP *binop; NewOp(1103, binop, 1, BINOP); binop->op_type = (OPCODE)type; - binop->op_first = first; - binop->op_flags = OPf_KIDS; - binop->op_last = last; - first->op_sibling = last; + op_sibling_splice((OP*)binop, NULL, 0, last); + op_sibling_splice((OP*)binop, NULL, 0, first); return (OP *)binop; } @@ -503,11 +578,9 @@ THX_mkLISTOP(pTHX_ U32 type, OP *first, OP *sib, OP *last) LISTOP *listop; NewOp(1103, listop, 1, LISTOP); listop->op_type = (OPCODE)type; - listop->op_flags = OPf_KIDS; - listop->op_first = first; - first->op_sibling = sib; - sib->op_sibling = last; - listop->op_last = last; + op_sibling_splice((OP*)listop, NULL, 0, last); + op_sibling_splice((OP*)listop, NULL, 0, sib); + op_sibling_splice((OP*)listop, NULL, 0, first); return (OP *)listop; } @@ -558,19 +631,21 @@ THX_pp_establish_cleanup(pTHX) STATIC OP * THX_ck_entersub_establish_cleanup(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) { - OP *pushop, *argop, *estop; + OP *parent, *pushop, *argop, *estop; ck_entersub_args_proto(entersubop, namegv, ckobj); + parent = entersubop; pushop = cUNOPx(entersubop)->op_first; - if(!pushop->op_sibling) pushop = cUNOPx(pushop)->op_first; - argop = pushop->op_sibling; - pushop->op_sibling = argop->op_sibling; - argop->op_sibling = NULL; + if(!OpHAS_SIBLING(pushop)) { + parent = pushop; + pushop = cUNOPx(pushop)->op_first; + } + /* extract out first arg, then delete the rest of the tree */ + argop = OpSIBLING(pushop); + op_sibling_splice(parent, pushop, 1, NULL); op_free(entersubop); - NewOpSz(0, estop, sizeof(UNOP)); - estop->op_type = OP_RAND; + + estop = mkUNOP(OP_RAND, argop); estop->op_ppaddr = THX_pp_establish_cleanup; - cUNOPx(estop)->op_flags = OPf_KIDS; - cUNOPx(estop)->op_first = argop; PL_hints |= HINT_BLOCK_SCOPE; return estop; } @@ -578,13 +653,16 @@ THX_ck_entersub_establish_cleanup(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) STATIC OP * THX_ck_entersub_postinc(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) { - OP *pushop, *argop; + OP *parent, *pushop, *argop; ck_entersub_args_proto(entersubop, namegv, ckobj); + parent = entersubop; pushop = cUNOPx(entersubop)->op_first; - if(!pushop->op_sibling) pushop = cUNOPx(pushop)->op_first; - argop = pushop->op_sibling; - pushop->op_sibling = argop->op_sibling; - argop->op_sibling = NULL; + if(!OpHAS_SIBLING(pushop)) { + parent = pushop; + pushop = cUNOPx(pushop)->op_first; + } + argop = OpSIBLING(pushop); + op_sibling_splice(parent, pushop, 1, NULL); op_free(entersubop); return newUNOP(OP_POSTINC, 0, op_lvalue(op_contextualize(argop, G_SCALAR), OP_POSTINC)); @@ -598,12 +676,13 @@ THX_ck_entersub_pad_scalar(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) SV *a0, *a1; ck_entersub_args_proto(entersubop, namegv, ckobj); pushop = cUNOPx(entersubop)->op_first; - if(!pushop->op_sibling) pushop = cUNOPx(pushop)->op_first; - argop = pushop->op_sibling; - if(argop->op_type != OP_CONST || argop->op_sibling->op_type != OP_CONST) + if(!OpHAS_SIBLING(pushop)) + pushop = cUNOPx(pushop)->op_first; + argop = OpSIBLING(pushop); + if(argop->op_type != OP_CONST || OpSIBLING(argop)->op_type != OP_CONST) croak("bad argument expression type for pad_scalar()"); a0 = cSVOPx_sv(argop); - a1 = cSVOPx_sv(argop->op_sibling); + a1 = cSVOPx_sv(OpSIBLING(argop)); switch(SvIV(a0)) { case 1: { SV *namesv = sv_2mortal(newSVpvs("$")); @@ -659,6 +738,9 @@ static SV *hintkey_swaplabel_sv, *hintkey_labelconst_sv; static SV *hintkey_arrayfullexpr_sv, *hintkey_arraylistexpr_sv; static SV *hintkey_arraytermexpr_sv, *hintkey_arrayarithexpr_sv; static SV *hintkey_arrayexprflags_sv; +static SV *hintkey_DEFSV_sv; +static SV *hintkey_with_vars_sv; +static SV *hintkey_join_with_space_sv; static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **); /* low-level parser helpers */ @@ -691,16 +773,18 @@ static OP *THX_parse_var(pTHX) } #define push_rpn_item(o) \ - (tmpop = (o), tmpop->op_sibling = stack, stack = tmpop) -#define pop_rpn_item() \ - (!stack ? (croak("RPN stack underflow"), (OP*)NULL) : \ - (tmpop = stack, stack = stack->op_sibling, \ - tmpop->op_sibling = NULL, tmpop)) + op_sibling_splice(parent, NULL, 0, o); +#define pop_rpn_item() ( \ + (tmpop = op_sibling_splice(parent, NULL, 1, NULL)) \ + ? tmpop : (croak("RPN stack underflow"), (OP*)NULL)) #define parse_rpn_expr() THX_parse_rpn_expr(aTHX) static OP *THX_parse_rpn_expr(pTHX) { - OP *stack = NULL, *tmpop; + OP *tmpop; + /* fake parent for splice to mess with */ + OP *parent = mkBINOP(OP_NULL, NULL, NULL); + while(1) { I32 c; lex_read_space(0); @@ -708,7 +792,9 @@ static OP *THX_parse_rpn_expr(pTHX) switch(c) { case /*(*/')': case /*{*/'}': { OP *result = pop_rpn_item(); - if(stack) croak("RPN expression must return a single value"); + if(cLISTOPx(parent)->op_first) + croak("RPN expression must return a single value"); + op_free(parent); return result; } break; case '0': case '1': case '2': case '3': case '4': @@ -944,6 +1030,106 @@ static OP *THX_parse_keyword_arrayexprflags(pTHX) return o ? newANONLIST(o) : newANONHASH(newOP(OP_STUB, 0)); } +#define parse_keyword_DEFSV() THX_parse_keyword_DEFSV(aTHX) +static OP *THX_parse_keyword_DEFSV(pTHX) +{ + return newDEFSVOP(); +} + +#define sv_cat_c(a,b) THX_sv_cat_c(aTHX_ a, b) +static void THX_sv_cat_c(pTHX_ SV *sv, U32 c) { + char ds[UTF8_MAXBYTES + 1], *d; + d = (char *)uvchr_to_utf8((U8 *)ds, c); + if (d - ds > 1) { + sv_utf8_upgrade(sv); + } + sv_catpvn(sv, ds, d - ds); +} + +#define parse_keyword_with_vars() THX_parse_keyword_with_vars(aTHX) +static OP *THX_parse_keyword_with_vars(pTHX) +{ + I32 c; + IV count; + int save_ix; + OP *vardeclseq, *body; + + save_ix = block_start(TRUE); + vardeclseq = NULL; + + count = 0; + + lex_read_space(0); + c = lex_peek_unichar(0); + while (c != '{') { + SV *varname; + PADOFFSET padoff; + + if (c == -1) { + croak("unexpected EOF; expecting '{'"); + } + + if (!isIDFIRST_uni(c)) { + croak("unexpected '%c'; expecting an identifier", (int)c); + } + + varname = newSVpvs("$"); + if (lex_bufutf8()) { + SvUTF8_on(varname); + } + + sv_cat_c(varname, c); + lex_read_unichar(0); + + while (c = lex_peek_unichar(0), c != -1 && isIDCONT_uni(c)) { + sv_cat_c(varname, c); + lex_read_unichar(0); + } + + padoff = pad_add_name_sv(varname, padadd_NO_DUP_CHECK, NULL, NULL); + + { + OP *my_var = newOP(OP_PADSV, OPf_MOD | (OPpLVAL_INTRO << 8)); + my_var->op_targ = padoff; + + vardeclseq = op_append_list( + OP_LINESEQ, + vardeclseq, + newSTATEOP( + 0, NULL, + newASSIGNOP( + OPf_STACKED, + my_var, 0, + newSVOP( + OP_CONST, 0, + newSViv(++count) + ) + ) + ) + ); + } + + lex_read_space(0); + c = lex_peek_unichar(0); + } + + intro_my(); + + body = parse_block(0); + + return block_end(save_ix, op_append_list(OP_LINESEQ, vardeclseq, body)); +} + +#define parse_join_with_space() THX_parse_join_with_space(aTHX) +static OP *THX_parse_join_with_space(pTHX) +{ + OP *delim, *args; + + args = parse_listexpr(0); + delim = newSVOP(OP_CONST, 0, newSVpvs(" ")); + return op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, delim, args)); +} + /* plugin glue */ #define keyword_active(hintkey_sv) THX_keyword_active(aTHX_ hintkey_sv) @@ -1028,6 +1214,18 @@ static int my_keyword_plugin(pTHX_ keyword_active(hintkey_arrayexprflags_sv)) { *op_ptr = parse_keyword_arrayexprflags(); return KEYWORD_PLUGIN_EXPR; + } else if(keyword_len == 5 && strnEQ(keyword_ptr, "DEFSV", 5) && + keyword_active(hintkey_DEFSV_sv)) { + *op_ptr = parse_keyword_DEFSV(); + return KEYWORD_PLUGIN_EXPR; + } else if(keyword_len == 9 && strnEQ(keyword_ptr, "with_vars", 9) && + keyword_active(hintkey_with_vars_sv)) { + *op_ptr = parse_keyword_with_vars(); + return KEYWORD_PLUGIN_STMT; + } else if(keyword_len == 15 && strnEQ(keyword_ptr, "join_with_space", 15) && + keyword_active(hintkey_join_with_space_sv)) { + *op_ptr = parse_join_with_space(); + return KEYWORD_PLUGIN_EXPR; } else { return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr); } @@ -1092,14 +1290,14 @@ addissub_myck_add(pTHX_ OP *op) OP *aop, *bop; U8 flags; if (!(flag_svp && SvTRUE(*flag_svp) && (op->op_flags & OPf_KIDS) && - (aop = cBINOPx(op)->op_first) && (bop = aop->op_sibling) && - !bop->op_sibling)) + (aop = cBINOPx(op)->op_first) && (bop = OpSIBLING(aop)) && + !OpHAS_SIBLING(bop))) return addissub_nxck_add(aTHX_ op); - aop->op_sibling = NULL; - cBINOPx(op)->op_first = NULL; - op->op_flags &= ~OPf_KIDS; flags = op->op_flags; - op_free(op); + op_sibling_splice(op, NULL, 1, NULL); /* excise aop */ + op_sibling_splice(op, NULL, 1, NULL); /* excise bop */ + op_free(op); /* free the empty husk */ + flags &= ~OPf_KIDS; return newBINOP(OP_SUBTRACT, flags, aop, bop); } @@ -1134,6 +1332,14 @@ INCLUDE: const-xs.inc INCLUDE: numeric.xs +void +assertx(int x) + CODE: + /* this only needs to compile and checks that assert() can be + used this way syntactically */ + (void)(assert(x), 1); + (void)(x); + MODULE = XS::APItest::utf8 PACKAGE = XS::APItest::utf8 int @@ -1187,6 +1393,54 @@ test_utf8n_to_uvchr(s, len, flags) OUTPUT: RETVAL +AV * +test_valid_utf8_to_uvchr(s) + + SV *s + PREINIT: + STRLEN retlen; + UV ret; + STRLEN slen; + + CODE: + /* Call utf8n_to_uvchr() with the inputs. It always asks for the + * actual length to be returned + * + * Length to assume <s> is; not checked, so could have buffer overflow + */ + RETVAL = newAV(); + sv_2mortal((SV*)RETVAL); + + ret + = valid_utf8_to_uvchr((U8*) SvPV(s, slen), &retlen); + + /* Returns the return value in [0]; <retlen> in [1] */ + av_push(RETVAL, newSVuv(ret)); + av_push(RETVAL, newSVuv(retlen)); + + OUTPUT: + RETVAL + +SV * +test_uvchr_to_utf8_flags(uv, flags) + + SV *uv + SV *flags + PREINIT: + U8 dest[UTF8_MAXBYTES]; + U8 *ret; + + CODE: + /* Call uvchr_to_utf8_flags() with the inputs. */ + ret = uvchr_to_utf8_flags(dest, SvUV(uv), SvUV(flags)); + if (! ret) { + XSRETURN_UNDEF; + } + RETVAL = newSVpvn((char *) dest, ret - dest); + + OUTPUT: + RETVAL + MODULE = XS::APItest:Overload PACKAGE = XS::APItest::Overload void @@ -1249,6 +1503,61 @@ XS_APIVERSION_valid(...) XS_APIVERSION_BOOTCHECK; XSRETURN_EMPTY; +void +xsreturn( int len ) + PPCODE: + int i = 0; + EXTEND( SP, len ); + for ( ; i < len; i++ ) { + ST(i) = sv_2mortal( newSViv(i) ); + } + XSRETURN( len ); + +void +xsreturn_iv() + PPCODE: + XSRETURN_IV(I32_MIN + 1); + +void +xsreturn_uv() + PPCODE: + XSRETURN_UV( (U32)((1U<<31) + 1) ); + +void +xsreturn_nv() + PPCODE: + XSRETURN_NV(0.25); + +void +xsreturn_pv() + PPCODE: + XSRETURN_PV("returned"); + +void +xsreturn_pvn() + PPCODE: + XSRETURN_PVN("returned too much",8); + +void +xsreturn_no() + PPCODE: + XSRETURN_NO; + +void +xsreturn_yes() + PPCODE: + XSRETURN_YES; + +void +xsreturn_undef() + PPCODE: + XSRETURN_UNDEF; + +void +xsreturn_empty() + PPCODE: + XSRETURN_EMPTY; + MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash void @@ -1457,13 +1766,17 @@ common(params) if ((svp = hv_fetchs(params, "hash", 0))) hash = SvUV(*svp); - if ((svp = hv_fetchs(params, "hash_pv", 0))) { + if (hv_fetchs(params, "hash_pv", 0)) { + assert(key); PERL_HASH(hash, key, klen); } - if ((svp = hv_fetchs(params, "hash_sv", 0))) { - STRLEN len; - const char *const p = SvPV(keysv, len); - PERL_HASH(hash, p, len); + if (hv_fetchs(params, "hash_sv", 0)) { + assert(keysv); + { + STRLEN len; + const char *const p = SvPV(keysv, len); + PERL_HASH(hash, p, len); + } } result = (HE *)hv_common(hv, keysv, key, klen, flags, action, val, hash); @@ -1540,7 +1853,7 @@ void test_force_keys(HV *hv) PREINIT: HE *he; - STRLEN count = 0; + SSize_t count = 0; PPCODE: hv_iterinit(hv); he = hv_iternext(hv); @@ -1729,12 +2042,9 @@ xop_build_optree () kid = newSVOP(OP_CONST, 0, newSViv(42)); - NewOp(1102, unop, 1, UNOP); - unop->op_type = OP_CUSTOM; + unop = (UNOP*)mkUNOP(OP_CUSTOM, kid); unop->op_ppaddr = pp_xop; - unop->op_flags = OPf_KIDS; unop->op_private = 0; - unop->op_first = kid; unop->op_next = NULL; kid->op_next = (OP*)unop; @@ -1763,12 +2073,9 @@ xop_from_custom_op () UNOP *unop; XOP *xop; - NewOp(1102, unop, 1, UNOP); - unop->op_type = OP_CUSTOM; + unop = (UNOP*)mkUNOP(OP_CUSTOM, NULL); unop->op_ppaddr = pp_xop; - unop->op_flags = OPf_KIDS; unop->op_private = 0; - unop->op_first = NULL; unop->op_next = NULL; xop = Perl_custom_op_xop(aTHX_ (OP *)unop); @@ -1945,6 +2252,39 @@ mxpushu() mXPUSHu(3); XSRETURN(3); + + # test_EXTEND(): excerise the EXTEND() macro. + # After calling EXTEND(), it also does *(p+n) = NULL and + # *PL_stack_max = NULL to allow valgrind etc to spot if the stack hasn't + # actually been extended properly. + # + # max_offset specifies the SP to use. It is treated as a signed offset + # from PL_stack_max. + # nsv is the SV holding the value of n indicating how many slots + # to extend the stack by. + # use_ss is a boolean indicating that n should be cast to a SSize_t + +void +test_EXTEND(max_offset, nsv, use_ss) + IV max_offset; + SV *nsv; + bool use_ss; +PREINIT: + SV **sp = PL_stack_max + max_offset; +PPCODE: + if (use_ss) { + SSize_t n = (SSize_t)SvIV(nsv); + EXTEND(sp, n); + *(sp + n) = NULL; + } + else { + IV n = SvIV(nsv); + EXTEND(sp, n); + *(sp + n) = NULL; + } + *PL_stack_max = NULL; + + void call_sv_C() PREINIT: @@ -2096,6 +2436,7 @@ newCONSTSUB(stash, name, flags, sv) break; } EXTEND(SP, 2); + assert(mycv); PUSHs( CvCONST(mycv) ? &PL_sv_yes : &PL_sv_no ); PUSHs((SV*)CvGV(mycv)); @@ -2241,6 +2582,26 @@ gv_autoload_type(stash, methname, type, method) } XPUSHs( gv ? (SV*)gv : &PL_sv_undef); +SV * +gv_const_sv(SV *name) + PREINIT: + GV *gv; + CODE: + if (SvPOK(name)) { + HV *stash = gv_stashpv("main",0); + HE *he = hv_fetch_ent(stash, name, 0, 0); + gv = (GV *)HeVAL(he); + } + else { + gv = (GV *)name; + } + RETVAL = gv_const_sv(gv); + if (!RETVAL) + XSRETURN_EMPTY; + RETVAL = newSVsv(RETVAL); + OUTPUT: + RETVAL + void whichsig_type(namesv, type) SV* namesv @@ -2429,7 +2790,7 @@ my_caller(level) ST(4) = cop_hints_fetch_pvs(cx->blk_oldcop, "foo", 0); ST(5) = cop_hints_fetch_pvn(cx->blk_oldcop, "foo", 3, 0, 0); ST(6) = cop_hints_fetch_sv(cx->blk_oldcop, - sv_2mortal(newSVpvn("foo", 3)), 0, 0); + sv_2mortal(newSVpvs("foo")), 0, 0); hv = cop_hints_2hv(cx->blk_oldcop, 0); ST(7) = hv ? sv_2mortal(newRV_noinc((SV *)hv)) : &PL_sv_undef; @@ -2749,6 +3110,11 @@ void test_cophh() PREINIT: COPHH *a, *b; +#ifdef EBCDIC + SV* key_sv; + char * key_name; + STRLEN key_len; +#endif CODE: #define check_ph(EXPR) \ do { if((EXPR) != &PL_sv_placeholder) croak("fail"); } while(0) @@ -2812,24 +3178,81 @@ test_cophh() check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333); check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444); check_ph(cophh_fetch_pvs(a, "foo_5", 0)); - a = cophh_store_pvs(a, "foo_1", msviv(11111), COPHH_KEY_UTF8); + a = cophh_store_pvs(a, "foo_1", msviv(11111), COPHH_KEY_UTF8); a = cophh_store_pvs(a, "foo_\xaa", msviv(123), 0); +#ifndef EBCDIC a = cophh_store_pvs(a, "foo_\xc2\xbb", msviv(456), COPHH_KEY_UTF8); +#else + /* On EBCDIC, we need to translate the UTF-8 in the ASCII test to the + * equivalent UTF-EBCDIC for the code page. This is done at runtime + * (with the helper function in this file). Therefore we can't use + * cophhh_store_pvs(), as we don't have literal string */ + key_sv = sv_2mortal(newSVpvs("foo_")); + cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xbb")); + key_name = SvPV(key_sv, key_len); + a = cophh_store_pvn(a, key_name, key_len, 0, msviv(456), COPHH_KEY_UTF8); +#endif +#ifndef EBCDIC a = cophh_store_pvs(a, "foo_\xc3\x8c", msviv(789), COPHH_KEY_UTF8); +#else + sv_setpvs(key_sv, "foo_"); + cat_utf8a2n(key_sv, STR_WITH_LEN("\xc3\x8c")); + key_name = SvPV(key_sv, key_len); + a = cophh_store_pvn(a, key_name, key_len, 0, msviv(789), COPHH_KEY_UTF8); +#endif +#ifndef EBCDIC a = cophh_store_pvs(a, "foo_\xd9\xa6", msviv(666), COPHH_KEY_UTF8); +#else + sv_setpvs(key_sv, "foo_"); + cat_utf8a2n(key_sv, STR_WITH_LEN("\xd9\xa6")); + key_name = SvPV(key_sv, key_len); + a = cophh_store_pvn(a, key_name, key_len, 0, msviv(666), COPHH_KEY_UTF8); +#endif check_iv(cophh_fetch_pvs(a, "foo_1", 0), 11111); check_iv(cophh_fetch_pvs(a, "foo_1", COPHH_KEY_UTF8), 11111); check_iv(cophh_fetch_pvs(a, "foo_\xaa", 0), 123); +#ifndef EBCDIC check_iv(cophh_fetch_pvs(a, "foo_\xc2\xaa", COPHH_KEY_UTF8), 123); check_ph(cophh_fetch_pvs(a, "foo_\xc2\xaa", 0)); +#else + sv_setpvs(key_sv, "foo_"); + cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xaa")); + key_name = SvPV(key_sv, key_len); + check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 123); + check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0)); +#endif check_iv(cophh_fetch_pvs(a, "foo_\xbb", 0), 456); +#ifndef EBCDIC check_iv(cophh_fetch_pvs(a, "foo_\xc2\xbb", COPHH_KEY_UTF8), 456); check_ph(cophh_fetch_pvs(a, "foo_\xc2\xbb", 0)); +#else + sv_setpvs(key_sv, "foo_"); + cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xbb")); + key_name = SvPV(key_sv, key_len); + check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 456); + check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0)); +#endif check_iv(cophh_fetch_pvs(a, "foo_\xcc", 0), 789); +#ifndef EBCDIC check_iv(cophh_fetch_pvs(a, "foo_\xc3\x8c", COPHH_KEY_UTF8), 789); check_ph(cophh_fetch_pvs(a, "foo_\xc2\x8c", 0)); +#else + sv_setpvs(key_sv, "foo_"); + cat_utf8a2n(key_sv, STR_WITH_LEN("\xc3\x8c")); + key_name = SvPV(key_sv, key_len); + check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 789); + check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0)); +#endif +#ifndef EBCDIC check_iv(cophh_fetch_pvs(a, "foo_\xd9\xa6", COPHH_KEY_UTF8), 666); check_ph(cophh_fetch_pvs(a, "foo_\xd9\xa6", 0)); +#else + sv_setpvs(key_sv, "foo_"); + cat_utf8a2n(key_sv, STR_WITH_LEN("\xd9\xa6")); + key_name = SvPV(key_sv, key_len); + check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 666); + check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0)); +#endif ENTER; SAVEFREECOPHH(a); LEAVE; @@ -2864,15 +3287,41 @@ HV * example_cophh_2hv() PREINIT: COPHH *a; +#ifdef EBCDIC + SV* key_sv; + char * key_name; + STRLEN key_len; +#endif CODE: #define msviv(VALUE) sv_2mortal(newSViv(VALUE)) a = cophh_new_empty(); a = cophh_store_pvs(a, "foo_0", msviv(999), 0); a = cophh_store_pvs(a, "foo_1", msviv(111), 0); a = cophh_store_pvs(a, "foo_\xaa", msviv(123), 0); +#ifndef EBCDIC a = cophh_store_pvs(a, "foo_\xc2\xbb", msviv(456), COPHH_KEY_UTF8); +#else + key_sv = sv_2mortal(newSVpvs("foo_")); + cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xbb")); + key_name = SvPV(key_sv, key_len); + a = cophh_store_pvn(a, key_name, key_len, 0, msviv(456), COPHH_KEY_UTF8); +#endif +#ifndef EBCDIC a = cophh_store_pvs(a, "foo_\xc3\x8c", msviv(789), COPHH_KEY_UTF8); +#else + sv_setpvs(key_sv, "foo_"); + cat_utf8a2n(key_sv, STR_WITH_LEN("\xc3\x8c")); + key_name = SvPV(key_sv, key_len); + a = cophh_store_pvn(a, key_name, key_len, 0, msviv(789), COPHH_KEY_UTF8); +#endif +#ifndef EBCDIC a = cophh_store_pvs(a, "foo_\xd9\xa6", msviv(666), COPHH_KEY_UTF8); +#else + sv_setpvs(key_sv, "foo_"); + cat_utf8a2n(key_sv, STR_WITH_LEN("\xd9\xa6")); + key_name = SvPV(key_sv, key_len); + a = cophh_store_pvn(a, key_name, key_len, 0, msviv(666), COPHH_KEY_UTF8); +#endif a = cophh_delete_pvs(a, "foo_0", 0); a = cophh_delete_pvs(a, "foo_2", 0); RETVAL = cophh_2hv(a, 0); @@ -3191,10 +3640,72 @@ CODE: MULTICALL; } POP_MULTICALL; - PERL_UNUSED_VAR(newsp); XSRETURN_UNDEF; } +=pod + +multicall_return(): call the passed sub once in the specificed context +and return whatever it returns + +=cut + +void +multicall_return(block, context) + SV *block + I32 context +PROTOTYPE: &$ +CODE: +{ + dSP; + dMULTICALL; + GV *gv; + HV *stash; + I32 gimme = context; + CV *cv; + AV *av; + SV **p; + SSize_t i, size; + + cv = sv_2cv(block, &stash, &gv, 0); + if (cv == Nullcv) { + croak("multicall_return not a subroutine reference"); + } + PUSH_MULTICALL(cv); + + MULTICALL; + + /* copy returned values into an array so they're not freed during + * POP_MULTICALL */ + + av = newAV(); + SPAGAIN; + + switch (context) { + case G_VOID: + break; + + case G_SCALAR: + av_push(av, SvREFCNT_inc(TOPs)); + break; + + case G_ARRAY: + for (p = PL_stack_base + 1; p <= SP; p++) + av_push(av, SvREFCNT_inc(*p)); + break; + } + + POP_MULTICALL; + + size = AvFILLp(av) + 1; + EXTEND(SP, size); + for (i = 0; i < size; i++) + ST(i) = *av_fetch(av, i, FALSE); + sv_2mortal((SV*)av); + XSRETURN(size); +} + + #ifdef USE_ITHREADS void @@ -3211,11 +3722,12 @@ CODE: PERL_SET_CONTEXT(interp); POPSTACK_TO(PL_mainstack); - dounwind(-1); + if (cxstack_ix >= 0) { + dounwind(-1); + cx_popblock(cxstack); + } LEAVE_SCOPE(0); - - while (interp->Iscopestack_ix > 1) - LEAVE; + PL_scopestack_ix = oldscope; FREETMPS; perl_destruct(interp); @@ -3315,6 +3827,9 @@ BOOT: hintkey_arraytermexpr_sv = newSVpvs_share("XS::APItest/arraytermexpr"); hintkey_arrayarithexpr_sv = newSVpvs_share("XS::APItest/arrayarithexpr"); hintkey_arrayexprflags_sv = newSVpvs_share("XS::APItest/arrayexprflags"); + hintkey_DEFSV_sv = newSVpvs_share("XS::APItest/DEFSV"); + hintkey_with_vars_sv = newSVpvs_share("XS::APItest/with_vars"); + hintkey_join_with_space_sv = newSVpvs_share("XS::APItest/join_with_space"); next_keyword_plugin = PL_keyword_plugin; PL_keyword_plugin = my_keyword_plugin; } @@ -3511,14 +4026,25 @@ test_newFOROP_without_slab() CODE: { const I32 floor = start_subparse(0,0); + OP *o; /* The slab allocator does not like CvROOT being set. */ CvROOT(PL_compcv) = (OP *)1; - op_free(newFOROP(0, 0, newOP(OP_PUSHMARK, 0), 0, 0)); + o = newFOROP(0, 0, newOP(OP_PUSHMARK, 0), 0, 0); +#ifdef PERL_OP_PARENT + if (cLOOPx(cUNOPo->op_first)->op_last->op_sibparent + != cUNOPo->op_first) + { + Perl_warn(aTHX_ "Op parent pointer is stale"); + RETVAL = FALSE; + } + else +#endif + /* If we do not crash before returning, the test passes. */ + RETVAL = TRUE; + op_free(o); CvROOT(PL_compcv) = NULL; SvREFCNT_dec(PL_compcv); LEAVE_SCOPE(floor); - /* If we have not crashed yet, then the test passes. */ - RETVAL = TRUE; } OUTPUT: RETVAL @@ -3583,6 +4109,80 @@ alias_av(AV *av, IV ix, SV *sv) CODE: av_store(av, ix, SvREFCNT_inc(sv)); +SV * +cv_name(SVREF ref, ...) + CODE: + RETVAL = SvREFCNT_inc(cv_name((CV *)ref, + items>1 && ST(1) != &PL_sv_undef + ? ST(1) + : NULL, + items>2 ? SvUV(ST(2)) : 0)); + OUTPUT: + RETVAL + +void +sv_catpvn(SV *sv, SV *sv2) + CODE: + { + STRLEN len; + const char *s = SvPV(sv2,len); + sv_catpvn_flags(sv,s,len, SvUTF8(sv2) ? SV_CATUTF8 : SV_CATBYTES); + } + +bool +test_newOP_CUSTOM() + CODE: + { + OP *o = newLISTOP(OP_CUSTOM, 0, NULL, NULL); + op_free(o); + o = newOP(OP_CUSTOM, 0); + op_free(o); + o = newUNOP(OP_CUSTOM, 0, NULL); + op_free(o); + o = newUNOP_AUX(OP_CUSTOM, 0, NULL, NULL); + op_free(o); + o = newMETHOP(OP_CUSTOM, 0, newOP(OP_NULL,0)); + op_free(o); + o = newMETHOP_named(OP_CUSTOM, 0, newSV(0)); + op_free(o); + o = newBINOP(OP_CUSTOM, 0, NULL, NULL); + op_free(o); + o = newPMOP(OP_CUSTOM, 0); + op_free(o); + o = newSVOP(OP_CUSTOM, 0, newSV(0)); + op_free(o); +#ifdef USE_ITHREADS + ENTER; + lex_start(NULL, NULL, 0); + { + I32 ix = start_subparse(FALSE,0); + o = newPADOP(OP_CUSTOM, 0, newSV(0)); + op_free(o); + LEAVE_SCOPE(ix); + } + LEAVE; +#endif + o = newPVOP(OP_CUSTOM, 0, NULL); + op_free(o); + o = newLOGOP(OP_CUSTOM, 0, newOP(OP_NULL,0), newOP(OP_NULL,0)); + op_free(o); + o = newLOOPEX(OP_CUSTOM, newOP(OP_NULL,0)); + op_free(o); + RETVAL = TRUE; + } + OUTPUT: + RETVAL + +void +test_sv_catpvf(SV *fmtsv) + PREINIT: + SV *sv; + char *fmt; + CODE: + fmt = SvPV_nolen(fmtsv); + sv = sv_2mortal(newSVpvn("", 0)); + sv_catpvf(sv, fmt, 5, 6, 7, 8); + MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest int @@ -3635,6 +4235,11 @@ ALIAS: CODE: sv_unmagicext(SvRV(sv), PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo); +void +sv_magic(SV *sv, SV *thingy) +CODE: + sv_magic(SvRV(sv), NULL, PERL_MAGIC_ext, (const char *)thingy, 0); + UV test_get_vtbl() PREINIT: @@ -4570,6 +5175,90 @@ test_isQUOTEMETA(UV ord) RETVAL UV +test_OFFUNISKIP(UV ord) + CODE: + RETVAL = OFFUNISKIP(ord); + OUTPUT: + RETVAL + +bool +test_OFFUNI_IS_INVARIANT(UV ord) + CODE: + RETVAL = OFFUNI_IS_INVARIANT(ord); + OUTPUT: + RETVAL + +bool +test_UVCHR_IS_INVARIANT(UV ord) + CODE: + RETVAL = UVCHR_IS_INVARIANT(ord); + OUTPUT: + RETVAL + +bool +test_UTF8_IS_INVARIANT(char ch) + CODE: + RETVAL = UTF8_IS_INVARIANT(ch); + OUTPUT: + RETVAL + +UV +test_UVCHR_SKIP(UV ord) + CODE: + RETVAL = UVCHR_SKIP(ord); + OUTPUT: + RETVAL + +UV +test_UTF8_SKIP(char * ch) + CODE: + RETVAL = UTF8_SKIP(ch); + OUTPUT: + RETVAL + +bool +test_UTF8_IS_START(char ch) + CODE: + RETVAL = UTF8_IS_START(ch); + OUTPUT: + RETVAL + +bool +test_UTF8_IS_CONTINUATION(char ch) + CODE: + RETVAL = UTF8_IS_CONTINUATION(ch); + OUTPUT: + RETVAL + +bool +test_UTF8_IS_CONTINUED(char ch) + CODE: + RETVAL = UTF8_IS_CONTINUED(ch); + OUTPUT: + RETVAL + +bool +test_UTF8_IS_DOWNGRADEABLE_START(char ch) + CODE: + RETVAL = UTF8_IS_DOWNGRADEABLE_START(ch); + OUTPUT: + RETVAL + +bool +test_UTF8_IS_ABOVE_LATIN1(char ch) + CODE: + RETVAL = UTF8_IS_ABOVE_LATIN1(ch); + OUTPUT: + RETVAL + +bool +test_isUTF8_POSSIBLY_PROBLEMATIC(char ch) + CODE: + RETVAL = isUTF8_POSSIBLY_PROBLEMATIC(ch); + OUTPUT: + RETVAL + +UV test_toLOWER(UV ord) CODE: RETVAL = toLOWER(ord); @@ -4792,3 +5481,85 @@ test_toTITLE_utf8(SV * p) RETVAL = av; OUTPUT: RETVAL + +SV * +test_Gconvert(SV * number, SV * num_digits) + PREINIT: + char buffer[100]; + int len; + CODE: + len = (int) SvIV(num_digits); + if (len > 99) croak("Too long a number for test_Gconvert"); + if (len < 0) croak("Too short a number for test_Gconvert"); + PERL_UNUSED_RESULT(Gconvert(SvNV(number), len, + 0, /* No trailing zeroes */ + buffer)); + RETVAL = newSVpv(buffer, 0); + OUTPUT: + RETVAL + +MODULE = XS::APItest PACKAGE = XS::APItest::Backrefs + +void +apitest_weaken(SV *sv) + PROTOTYPE: $ + CODE: + sv_rvweaken(sv); + +SV * +has_backrefs(SV *sv) + CODE: + if (SvROK(sv) && sv_get_backrefs(SvRV(sv))) + RETVAL = &PL_sv_yes; + else + RETVAL = &PL_sv_no; + OUTPUT: + RETVAL + +#ifdef WIN32 +#ifdef PERL_IMPLICIT_SYS + +const char * +PerlDir_mapA(const char *path) + +const WCHAR * +PerlDir_mapW(const WCHAR *wpath) + +#endif + +void +Comctl32Version() + PREINIT: + HMODULE dll; + VS_FIXEDFILEINFO *info; + UINT len; + HRSRC hrsc; + HGLOBAL ver; + void * vercopy; + PPCODE: + dll = GetModuleHandle("comctl32.dll"); /* must already be in proc */ + if(!dll) + croak("Comctl32Version: comctl32.dll not in process???"); + hrsc = FindResource(dll, MAKEINTRESOURCE(VS_VERSION_INFO), + MAKEINTRESOURCE(VS_FILE_INFO)); + if(!hrsc) + croak("Comctl32Version: comctl32.dll no version???"); + ver = LoadResource(dll, hrsc); + len = SizeofResource(dll, hrsc); + vercopy = _alloca(len); + memcpy(vercopy, ver, len); + if (VerQueryValue(vercopy, "\\", (void**)&info, &len)) { + int dwValueMS1 = (info->dwFileVersionMS>>16); + int dwValueMS2 = (info->dwFileVersionMS&0xffff); + int dwValueLS1 = (info->dwFileVersionLS>>16); + int dwValueLS2 = (info->dwFileVersionLS&0xffff); + EXTEND(SP, 4); + mPUSHi(dwValueMS1); + mPUSHi(dwValueMS2); + mPUSHi(dwValueLS1); + mPUSHi(dwValueLS2); + } + +#endif + + diff --git a/gnu/usr.bin/perl/ext/XS-APItest/Makefile.PL b/gnu/usr.bin/perl/ext/XS-APItest/Makefile.PL index 031ce8a0b0a..5b4d100659c 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/Makefile.PL +++ b/gnu/usr.bin/perl/ext/XS-APItest/Makefile.PL @@ -3,6 +3,8 @@ use ExtUtils::MakeMaker; use ExtUtils::Constant 0.11 'WriteConstants'; use Config; +my $dtrace_o = $Config{dtraceobject} ? ' dtrace$(OBJ_EXT)' : ''; + WriteMakefile( 'NAME' => 'XS::APItest', 'VERSION_FROM' => 'APItest.pm', # finds $VERSION @@ -10,7 +12,7 @@ WriteMakefile( ABSTRACT_FROM => 'APItest.pm', # retrieve abstract from module AUTHOR => 'Tim Jenness <t.jenness@jach.hawaii.edu>, Christian Soeller <csoelle@mph.auckland.ac.nz>, Hugo van der Sanden <hv@crypt.compulink.co.uk>, Andrew Main (Zefram) <zefram@fysh.org>', 'C' => ['exception.c', 'core.c', 'notcore.c'], - 'OBJECT' => '$(BASEEXT)$(OBJ_EXT) XSUB-undef-XS_VERSION$(OBJ_EXT) XSUB-redefined-macros$(OBJ_EXT) $(O_FILES)', + 'OBJECT' => '$(BASEEXT)$(OBJ_EXT) XSUB-undef-XS_VERSION$(OBJ_EXT) XSUB-redefined-macros$(OBJ_EXT) $(O_FILES)'. $dtrace_o, realclean => {FILES => 'const-c.inc const-xs.inc'}, ($Config{gccversion} && $Config{d_attribute_deprecated} ? (CCFLAGS => $Config{ccflags} . ' -Wno-deprecated-declarations') : ()), @@ -24,7 +26,7 @@ my @names = (qw(HV_DELETE HV_DISABLE_UVAR_XKEY HV_FETCH_ISSTORE G_KEEPERR G_NODEBUG G_METHOD G_FAKINGEVAL IS_NUMBER_IN_UV IS_NUMBER_GREATER_THAN_UV_MAX IS_NUMBER_NOT_INT IS_NUMBER_NEG IS_NUMBER_INFINITY - IS_NUMBER_NAN + IS_NUMBER_NAN IS_NUMBER_TRAILING PERL_SCAN_TRAILING ), {name=>"G_WANT", default=>["IV", "G_ARRAY|G_VOID"]}); @@ -40,3 +42,24 @@ WriteConstants( ); sub MY::install { "install ::\n" }; + + +sub MY::postamble +{ + package MY; + my $post = shift->SUPER::postamble(@_); + use Config; + return $post unless $Config{dtraceobject}; + + # core.o is build using PERL_CORE, so picks up any dtrace probes + + $post .= <<POSTAMBLE; + +DTRACE_D = ../../perldtrace.d + +dtrace\$(OBJ_EXT): \$(DTRACE_D) core\$(OBJ_EXT) + $Config{dtrace} -G -s \$(DTRACE_D) -o dtrace\$(OBJ_EXT) core\$(OBJ_EXT) +POSTAMBLE + + return $post; +} diff --git a/gnu/usr.bin/perl/ext/XS-APItest/XSUB-redefined-macros.xs b/gnu/usr.bin/perl/ext/XS-APItest/XSUB-redefined-macros.xs index 275f380d942..ad3132947db 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/XSUB-redefined-macros.xs +++ b/gnu/usr.bin/perl/ext/XS-APItest/XSUB-redefined-macros.xs @@ -4,7 +4,7 @@ /* We have to be in a different .xs so that we can do this: */ #undef XS_VERSION -#define XS_VERSION "" +#define XS_VERSION " " #undef PERL_API_VERSION_STRING #define PERL_API_VERSION_STRING "1.0.16" #include "XSUB.h" diff --git a/gnu/usr.bin/perl/ext/XS-APItest/core_or_not.inc b/gnu/usr.bin/perl/ext/XS-APItest/core_or_not.inc index 9c1cf561d59..412074a28f2 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/core_or_not.inc +++ b/gnu/usr.bin/perl/ext/XS-APItest/core_or_not.inc @@ -35,9 +35,6 @@ CAT2(sv_setsv_cow_hashkey_, SUFFIX) () { /* * Local variables: * mode: c - * c-indentation-style: bsd - * c-basic-offset: 4 - * indent-tabs-mode: nil * End: * * ex: set ts=8 sts=4 sw=4 et: diff --git a/gnu/usr.bin/perl/ext/XS-APItest/numeric.xs b/gnu/usr.bin/perl/ext/XS-APItest/numeric.xs index b06258d3c1a..0ce9e080fff 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/numeric.xs +++ b/gnu/usr.bin/perl/ext/XS-APItest/numeric.xs @@ -14,3 +14,48 @@ grok_number(number) PUSHs(sv_2mortal(newSViv(result))); if (result & IS_NUMBER_IN_UV) PUSHs(sv_2mortal(newSVuv(value))); + +void +grok_number_flags(number, flags) + SV *number + U32 flags + PREINIT: + STRLEN len; + const char *pv = SvPV(number, len); + UV value; + int result; + PPCODE: + EXTEND(SP,2); + result = grok_number_flags(pv, len, &value, flags); + PUSHs(sv_2mortal(newSViv(result))); + if (result & IS_NUMBER_IN_UV) + PUSHs(sv_2mortal(newSVuv(value))); + +void +grok_atoUV(number, endsv) + SV *number + SV *endsv + PREINIT: + STRLEN len; + const char *pv = SvPV(number, len); + UV value = 0xdeadbeef; + bool result; + const char* endptr; + PPCODE: + EXTEND(SP,2); + if (endsv == &PL_sv_undef) { + result = grok_atoUV(pv, &value, NULL); + } else { + result = grok_atoUV(pv, &value, &endptr); + } + PUSHs(result ? &PL_sv_yes : &PL_sv_no); + PUSHs(sv_2mortal(newSVuv(value))); + if (endsv == &PL_sv_undef) { + PUSHs(sv_2mortal(newSVpvn(NULL, 0))); + } else { + if (endptr) { + PUSHs(sv_2mortal(newSViv(endptr - pv))); + } else { + PUSHs(sv_2mortal(newSViv(0))); + } + } diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/call.t b/gnu/usr.bin/perl/ext/XS-APItest/t/call.t index 54f45ec4892..15b09653edb 100755 --- a/gnu/usr.bin/perl/ext/XS-APItest/t/call.t +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/call.t @@ -11,7 +11,7 @@ use strict; BEGIN { require '../../t/test.pl'; - plan(437); + plan(455); use_ok('XS::APItest') }; @@ -56,8 +56,8 @@ sub Foo::d { for my $test ( # flags args expected description - [ G_VOID, [ ], [ qw(z 1) ], '0 args, G_VOID' ], - [ G_VOID, [ qw(a p q) ], [ qw(z 1) ], '3 args, G_VOID' ], + [ G_VOID, [ ], [ 0 ], '0 args, G_VOID' ], + [ G_VOID, [ qw(a p q) ], [ 0 ], '3 args, G_VOID' ], [ G_SCALAR, [ ], [ qw(y 1) ], '0 args, G_SCALAR' ], [ G_SCALAR, [ qw(a p q) ], [ qw(y 1) ], '3 args, G_SCALAR' ], [ G_ARRAY, [ ], [ qw(x 1) ], '0 args, G_ARRAY' ], @@ -81,7 +81,7 @@ for my $test ( "$description call_pv('f')"); ok(eq_array( [ eval_sv('f(' . join(',',map"'$_'",@$args) . ')', $flags) ], - $expected), "$description eval_sv('f(args)')"); + $expected), "$description eval_sv('f(args)')"); ok(eq_array( [ call_method('meth', $flags, $obj, @$args) ], $expected), "$description call_method('meth')"); @@ -135,7 +135,7 @@ for my $test ( $expected), "$description G_NOARGS call_pv('f')"); ok(eq_array( [ sub { eval_sv('f(@_)', $flags|G_NOARGS) }->(@$args) ], - $expected), "$description G_NOARGS eval_sv('f(@_)')"); + $expected), "$description G_NOARGS eval_sv('f(@_)')"); # XXX call_method(G_NOARGS) isn't tested: I'm assuming # it's not a sensible combination. DAPM. @@ -213,35 +213,45 @@ is($@, "its_dead_jim\n", "eval { eval_pv('d()', 1) } - \$@"); sub f99 { 99 }; +my @bodies = ( + # [ code, is_fn_name, expect_success, has_inner_die, expected_err ] -for my $fn_type (0..2) { # 0:eval_pv 1:eval_sv 2:call_sv + # ok + [ 'f99', 1, 1, 0, qr/^$/, ], + # compile-time err + [ '$x=', 0, 0, 0, qr/syntax error/, ], + # compile-time exception + [ 'BEGIN { die "die in BEGIN"}', 0, 0, 1, qr/die in BEGIN/, ], + # run-time exception + [ 'd', 1, 0, 0, qr/its_dead_jim/, ], + # success with caught exception + [ 'eval { die "blah" }; 99', 0, 1, 1, qr/^$/, ], +); + + +for my $fn_type (qw(eval_pv eval_sv call_sv)) { my $warn_msg; local $SIG{__WARN__} = sub { $warn_msg .= $_[0] }; - for my $code_type (0..3) { + for my $body (@bodies) { + my ($code, $is_fn_name, $expect_success, + $has_inner_die, $expected_err_qr) = @$body; # call_sv can only handle function names, not code snippets - next if $fn_type == 2 and ($code_type == 1 or $code_type == 2); - - my $code = ( - 'f99', # ok - '$x=', # compile-time err - 'BEGIN { die "die in BEGIN"}', # compile-time exception - 'd', # run-time exception - )[$code_type]; + next if $fn_type eq 'call_sv' and !$is_fn_name; for my $keep (0, G_KEEPERR) { my $keep_desc = $keep ? 'G_KEEPERR' : '0'; my $desc; - my $expect = ($code_type == 0) ? 1 : 0; + my $expect = $expect_success; undef $warn_msg; $@ = 'pre-err'; my @ret; - if ($fn_type == 0) { # eval_pv + if ($fn_type eq 'eval_pv') { # eval_pv returns its result rather than a 'succeed' boolean $expect = $expect ? '99' : undef; @@ -258,37 +268,30 @@ for my $fn_type (0..2) { # 0:eval_pv 1:eval_sv 2:call_sv @ret = eval_pv($code, 0); } } - elsif ($fn_type == 1) { # eval_sv + elsif ($fn_type eq 'eval_sv') { $desc = "eval_sv('$code', G_ARRAY|$keep_desc)"; @ret = eval_sv($code, G_ARRAY|$keep); } - elsif ($fn_type == 2) { # call_sv + elsif ($fn_type eq 'call_sv') { $desc = "call_sv('$code', G_EVAL|G_ARRAY|$keep_desc)"; @ret = call_sv($code, G_EVAL|G_ARRAY|$keep); } - is(scalar @ret, ($code_type == 0 && $fn_type != 0) ? 2 : 1, + is(scalar @ret, ($expect_success && $fn_type ne 'eval_pv') ? 2 : 1, "$desc - number of returned args"); is($ret[-1], $expect, "$desc - return value"); - if ($keep && $fn_type != 0) { + if ($keep && $fn_type ne 'eval_pv') { # G_KEEPERR doesn't propagate into inner evals, requires etc - unless ($keep && $code_type == 2) { + unless ($keep && $has_inner_die) { is($@, 'pre-err', "$desc - \$@ unmodified"); } $@ = $warn_msg; } else { is($warn_msg, undef, "$desc - __WARN__ not called"); - unlike($@, 'pre-err', "$desc - \$@ modified"); + unlike($@, qr/pre-err/, "$desc - \$@ modified"); } - like($@, - ( - qr/^$/, - qr/syntax error/, - qr/die in BEGIN/, - qr/its_dead_jim/, - )[$code_type], - "$desc - the correct error message"); + like($@, $expected_err_qr, "$desc - the correct error message"); } } } diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/call_checker.t b/gnu/usr.bin/perl/ext/XS-APItest/t/call_checker.t index 377cb749802..9367096b160 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/t/call_checker.t +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/call_checker.t @@ -1,11 +1,14 @@ use warnings; use strict; -use Test::More tests => 76; +use Test::More tests => 78; use XS::APItest; -XS::APItest::test_cv_getset_call_checker(); -ok 1; +{ + local $TODO = $^O eq "cygwin" ? "[perl #78502] function pointers don't match on cygwin" : ""; + ok( eval { XS::APItest::test_cv_getset_call_checker(); 1 }) + or diag $@; +} my @z = (); my @a = qw(a); @@ -161,6 +164,8 @@ is $foo_ret, 9; sub MODIFY_CODE_ATTRIBUTES { cv_set_call_checker_lists($_[1]); () } BEGIN { *foo2 = sub($$) :Attr { $foo_got = [ @_ ]; return "z"; }; + my $foo = 3; + *foo3 = sub() :Attr { $foo }; } $foo_got = undef; @@ -169,6 +174,10 @@ is $@, ""; is_deeply $foo_got, [ qw(a b), qw(a b c) ]; is $foo_ret, "z"; +eval q{$foo_ret = foo3(@b, @c);}; +is $@, ""; +is $foo_ret, 3; + cv_set_call_checker_lists(\&foo); undef &foo; $foo_got = undef; diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/callregexec.t b/gnu/usr.bin/perl/ext/XS-APItest/t/callregexec.t index 3111390686b..22446b66f56 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/t/callregexec.t +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/callregexec.t @@ -10,7 +10,7 @@ use strict; use XS::APItest; *callregexec = *XS::APItest::callregexec; -use Test::More tests => 50; +use Test::More tests => 48; # Test that the regex engine can handle strings without terminating \0 # XXX This is by no means comprehensive; it doesn't test all ops, nor all @@ -42,7 +42,6 @@ sub try { try "ax", qr/a$/m, 1, 'MEOL'; try "ax", qr/a$/s, 1, 'SEOL'; try "abx", qr/^(ab|X)./s, 0, 'SANY'; - try "abx", qr/^(ab|X)\C/, 0, 'CANY'; try "abx", qr/^(ab|X)./, 0, 'REG_ANY'; try "abx", qr/^ab(c|d|e|x)/, 0, 'TRIE/TRIEC'; try "abx", qr/^abx/, 0, 'EXACT'; diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/clone-with-stack.t b/gnu/usr.bin/perl/ext/XS-APItest/t/clone-with-stack.t index 3238e9f3c99..10fa036dc73 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/t/clone-with-stack.t +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/clone-with-stack.t @@ -17,7 +17,7 @@ if (not $Config{'useithreads'}) { skip_all("clone_with_stack requires threads"); } -plan(5); +plan(8); fresh_perl_is( <<'----', <<'====', undef, "minimal clone_with_stack" ); use XS::APItest; @@ -67,6 +67,19 @@ X-Y-0:1:2:3:4-Z } { + fresh_perl_is( <<'----', <<'====', undef, "with a lexical sub" ); +use XS::APItest; +use experimental lexical_subs=>; +my sub f { print "42\n" } +clone_with_stack(); +f(); +---- +42 +==== + +} + +{ fresh_perl_is( <<'----', <<'====', undef, "with localised stuff" ); use XS::APItest; $s = "outer"; @@ -88,3 +101,52 @@ hsh: hale ==== } + +{ + fresh_perl_is( <<'----', <<'====', undef, "inside a loop inside a fn" ); +use XS::APItest; +my $a = 'aa'; +sub f { + my $b = 'bb'; + my @c; + my $d = 'dd'; + for my $d (0..4) { + clone_with_stack() if $d == 2; + push @c, $d; + } + return @c, $d; +} +print "X-$a-", join(':', f()), "-Z\n"; +---- +X-aa-0:1:2:3:4:dd-Z +==== + +} + +{ + fresh_perl_is( <<'----', <<'====', undef, "inside fn inside a loop inside a fn" ); +use XS::APItest; +my $a = 'aa'; + +sub g { + my $e = 'ee'; + my $f = 'ff'; + clone_with_stack(); +} + +sub f { + my $b = 'bb'; + my @c; + my $d = 'dd'; + for my $d (0..4) { + g() if $d == 2; + push @c, $d; + } + return @c, $d; +} +print "X-$a-", join(':', f()), "-Z\n"; +---- +X-aa-0:1:2:3:4:dd-Z +==== + +} diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/customop.t b/gnu/usr.bin/perl/ext/XS-APItest/t/customop.t index b7cc598b2c8..90362e9f52f 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/t/customop.t +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/customop.t @@ -3,7 +3,7 @@ use warnings; use strict; -use Test::More tests => 24; +use Test::More tests => 25; use XS::APItest; my $ppaddr = xop_ppaddr; @@ -76,3 +76,6 @@ is $av->[3], "DESC:unknown custom operator", "clearing XOP resets desc"; is $av->[4], "CLASS:0", "clearing XOP resets class"; is scalar @$av, 5, "clearing XOP removes peep"; + +ok test_newOP_CUSTOM(), + 'newOP et al. do not fail assertions with OP_CUSTOM'; diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/cv_name.t b/gnu/usr.bin/perl/ext/XS-APItest/t/cv_name.t new file mode 100644 index 00000000000..450336e26cf --- /dev/null +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/cv_name.t @@ -0,0 +1,53 @@ +use XS::APItest; +use Test::More tests => 30; +use feature "lexical_subs", "state"; +no warnings "experimental::lexical_subs"; + +is (cv_name(\&foo), 'main::foo', 'cv_name with package sub'); +is (cv_name(*{"foo"}{CODE}), 'main::foo', + 'cv_name with package sub via glob'); +is (cv_name(\*{"foo"}), 'main::foo', 'cv_name with typeglob'); +is (cv_name(\"foo"), 'foo', 'cv_name with string'); +state sub lex1; +is (cv_name(\&lex1), 'lex1', 'cv_name with lexical sub'); + +$ret = \cv_name(\&bar, $name); +is $ret, \$name, 'cv_name with package sub returns 2nd argument'; +is ($name, 'main::bar', 'retval of cv_name with package sub & 2nd arg'); +$ret = \cv_name(*{"bar"}{CODE}, $name); +is $ret, \$name, 'cv_name with package sub via glob returns 2nd argument'; +is ($name, 'main::bar', 'retval of cv_name w/pkg sub via glob & 2nd arg'); +$ret = \cv_name(\*{"bar"}, $name); +is $ret, \$name, 'cv_name with typeglob returns 2nd argument'; +is ($name, 'main::bar', 'retval of cv_name with typeglob & 2nd arg'); +$ret = \cv_name(\"bar", $name); +is $ret, \$name, 'cv_name with string returns 2nd argument'; +is ($name, 'bar', 'retval of cv_name with string & 2nd arg'); +state sub lex2; +$ret = \cv_name(\&lex2, $name); +is $ret, \$name, 'cv_name with lexical sub returns 2nd argument'; +is ($name, 'lex2', 'retval of cv_name with lexical sub & 2nd arg'); + +# nq in test names means CV_NAME_NOTQUAL +is (cv_name(\&foo, undef, 1), 'foo', 'cv_name with package sub (nq)'); +is (cv_name(*{"foo"}{CODE}, undef, 1), 'foo', + 'cv_name with package sub via glob (nq)'); +is (cv_name(\*{"foo"}, undef, 1), 'foo', 'cv_name with typeglob (nq)'); +is (cv_name(\"foo", undef, 1), 'foo', 'cv_name with string (nq)'); +is (cv_name(\&lex1, undef, 1), 'lex1', 'cv_name with lexical sub (nq)'); + +$ret = \cv_name(\&bar, $name, 1); +is $ret, \$name, 'cv_name with package sub returns 2nd argument (nq)'; +is ($name, 'bar', 'retval of cv_name with package sub & 2nd arg (nq)'); +$ret = \cv_name(*{"bar"}{CODE}, $name, 1); +is $ret, \$name, 'cv_name with package sub via glob returns 2nd arg (nq)'; +is ($name, 'bar', 'retval of cv_name w/pkg sub via glob & 2nd arg (nq)'); +$ret = \cv_name(\*{"bar"}, $name, 1); +is $ret, \$name, 'cv_name with typeglob returns 2nd argument (nq)'; +is ($name, 'bar', 'retval of cv_name with typeglob & 2nd arg (nq)'); +$ret = \cv_name(\"bar", $name, 1); +is $ret, \$name, 'cv_name with string returns 2nd argument (nq)'; +is ($name, 'bar', 'retval of cv_name with string & 2nd arg (nq)'); +$ret = \cv_name(\&lex2, $name, 1); +is $ret, \$name, 'cv_name with lexical sub returns 2nd argument (nq)'; +is ($name, 'lex2', 'retval of cv_name with lexical sub & 2nd arg (nq)'); diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/extend.t b/gnu/usr.bin/perl/ext/XS-APItest/t/extend.t new file mode 100644 index 00000000000..b3834b4cd74 --- /dev/null +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/extend.t @@ -0,0 +1,68 @@ +#!perl +# +# Test stack expansion macros: EXTEND() etc, especially for edge cases +# where the count wraps to a native value or gets truncated. +# +# Some of these tests aren't really testing; they are however exercising +# edge cases, which other tools like ASAN may then detect problems with. +# In particular, test_EXTEND() does *(p+n) = NULL and *PL_stack_max = NULL +# before returning, to help such tools spot errors. +# +# Also, it doesn't test large but legal grow requests; only ridiculously +# large requests that are guaranteed to wrap. + +use Test::More; +use Config; +use XS::APItest qw(test_EXTEND); + +plan tests => 48; + +my $uvsize = $Config::Config{uvsize}; # sizeof(UV) +my $sizesize = $Config::Config{sizesize}; # sizeof(Size_t) + +# The first arg to test_EXTEND() is the SP to use in EXTEND(), treated +# as an offset from PL_stack_max. So extend(-1, 1, $use_ss) shouldn't +# call Perl_stack_grow(), while extend(-1, 2, $use_ss) should. +# Exercise offsets near to PL_stack_max to detect edge cases. +# Note that having the SP pointer beyond PL_stack_max is legal. + +for my $offset (-1, 0, 1) { + + # treat N as either an IV or a SSize_t + for my $use_ss (0, 1) { + + # test with N in range -1 .. 3; only the -1 should panic + + eval { test_EXTEND($offset, -1, $use_ss) }; + like $@, qr/panic: .*negative count/, "test_EXTEND($offset, -1, $use_ss)"; + + for my $n (0,1,2,3) { + eval { test_EXTEND($offset, $n, $use_ss) }; + is $@, "", "test_EXTEND($offset, $n, $use_ss)"; + } + + # some things can wrap if the int size is greater than the ptr size + + SKIP: { + skip "Not small ptrs", 3 if $use_ss || $uvsize <= $sizesize; + + # 0xffff... wraps to -1 + eval { test_EXTEND($offset, (1 << 8*$sizesize)-1, $use_ss) }; + like $@, qr/panic: .*negative count/, + "test_EXTEND(-1, SIZE_MAX, $use_ss)"; + + # 0x10000... truncates to zero; + # but the wrap-detection code converts it to -1 to force a panic + eval { test_EXTEND($offset, 1 << 8*$sizesize, $use_ss) }; + like $@, qr/panic: .*negative count/, + "test_EXTEND(-1, SIZE_MAX+1, $use_ss)"; + + # 0x1ffff... truncates and then wraps to -1 + eval { test_EXTEND($offset, (1 << (8*$sizesize+1))-1, $use_ss) }; + like $@, qr/panic: .*negative count/, + "test_EXTEND(-1, 2*SIZE_MAX-1, $use_ss)"; + + + } + } +} diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/fetch_pad_names.t b/gnu/usr.bin/perl/ext/XS-APItest/t/fetch_pad_names.t index 3d422809526..bdff1a8fe62 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/t/fetch_pad_names.t +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/fetch_pad_names.t @@ -2,7 +2,15 @@ use strict; use warnings; use Encode (); -use Test::More tests => 77; +use Test::More; +if (ord("A") != 65) { + # pad_scalar() requires constant input. To port this to EBCDIC would + # require copy, paste, and changing all the values for each code page. + plan skip_all => "ASCII-centric tests"; +} +else { + plan tests => 77; +} use XS::APItest qw( fetch_pad_names pad_scalar ); @@ -41,8 +49,8 @@ general_tests( $cv->(), $names_av, { ], pad_size => { total => { cmp => 2, msg => 'Sub has two lexicals.' }, - utf8 => { cmp => 0, msg => 'Sub has no UTF-8 encoded vars.' }, - invariant => { cmp => 2, msg => 'Sub has two invariant vars.' }, + utf8 => { cmp => 2, msg => 'Sub has only UTF-8 vars.' }, + invariant => { cmp => 0, msg => 'Sub has no invariant vars.' }, }, vars => [ { name => '$zest', msg => 'Sub has [\$zest].', type => 'ok' }, @@ -79,8 +87,8 @@ general_tests( $cv->(), $names_av, { ], pad_size => { total => { cmp => 2, msg => 'Sub has two lexicals, including those it closed over.' }, - utf8 => { cmp => 1, msg => 'UTF-8 in the pad.' }, - invariant => { cmp => 1, msg => '' }, + utf8 => { cmp => 2, msg => 'UTF-8 in the pad.' }, + invariant => { cmp => 0, msg => '' }, }, vars => [ { name => '$ascii', msg => 'Sub has [$ascii].', type => 'ok' }, @@ -120,8 +128,8 @@ general_tests( $cv->(), $names_av, { ], pad_size => { total => { cmp => 2, msg => 'Sub has two lexicals' }, - utf8 => { cmp => 0, msg => 'Latin-1 not upgraded to UTF-8.' }, - invariant => { cmp => 2, msg => '' }, + utf8 => { cmp => 2, msg => 'Latin-1 got upgraded to UTF-8.' }, + invariant => { cmp => 0, msg => '' }, }, vars => [ { name => '$Leon', msg => 'Sub has [$Leon].', type => 'ok' }, @@ -153,8 +161,8 @@ END_EVAL results => [ ({ SKIP => 1 }) x 3 ], pad_size => { total => { cmp => 1, msg => 'Sub has one lexical, which it closed over.' }, - utf8 => { cmp => 0, msg => '' }, - invariant => { cmp => 1, msg => '' }, + utf8 => { cmp => 1, msg => '' }, + invariant => { cmp => 0, msg => '' }, }, vars => [ { name => '$Ceon', msg => "Sub doesn't have [\$Ceon].", type => 'not ok' }, @@ -189,8 +197,8 @@ general_tests( $cv->(), $names_av, { ], pad_size => { total => { cmp => 3, msg => 'Sub has three lexicals.' }, - utf8 => { cmp => 1, msg => 'Japanese stored as UTF-8.' }, - invariant => { cmp => 2, msg => '' }, + utf8 => { cmp => 3, msg => 'Japanese stored as UTF-8.' }, + invariant => { cmp => 0, msg => '' }, }, vars => [ { name => "\$\x{6226}\x{56fd}", msg => "Sub has [\$\x{6226}\x{56fd}].", type => 'ok' }, @@ -236,8 +244,8 @@ general_tests( $cv->(), $names_av, { ], pad_size => { total => { cmp => 1, msg => 'Sub has one lexical.' }, - utf8 => { cmp => 0, msg => '' }, - invariant => { cmp => 1, msg => '' }, + utf8 => { cmp => 1, msg => '' }, + invariant => { cmp => 0, msg => '' }, }, vars => [], }); @@ -307,8 +315,10 @@ sub general_tests { } is @$names_av, $tests->{pad_size}{total}{cmp}, $tests->{pad_size}{total}{msg}; - is grep( Encode::is_utf8($_), @$names_av), $tests->{pad_size}{utf8}{cmp}; - is grep( !Encode::is_utf8($_), @$names_av), $tests->{pad_size}{invariant}{cmp}; + is grep( Encode::is_utf8($_), @$names_av), + $tests->{pad_size}{utf8}{cmp}, $tests->{pad_size}{utf8}{msg}; + is grep( !Encode::is_utf8($_), @$names_av), $tests->{pad_size}{invariant}{cmp}, + $tests->{pad_size}{invariant}{msg}; for my $var (@{$tests->{vars}}) { no warnings 'experimental::smartmatch'; diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/grok.t b/gnu/usr.bin/perl/ext/XS-APItest/t/grok.t index 99fbc5d3da4..c3169ce7ccb 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/t/grok.t +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/grok.t @@ -74,4 +74,193 @@ foreach my $leader ('', ' ', ' ') { } } +# format tests +my @groks = + ( + # input, in flags, out uv, out flags + [ "1", 0, 1, IS_NUMBER_IN_UV ], + [ "1x", 0, undef, 0 ], + [ "1x", PERL_SCAN_TRAILING, 1, IS_NUMBER_IN_UV | IS_NUMBER_TRAILING ], + [ "3.1", 0, 3, IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT ], + [ "3.1a", 0, undef, 0 ], + [ "3.1a", PERL_SCAN_TRAILING, 3, + IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ], + [ "3e5", 0, undef, IS_NUMBER_NOT_INT ], + [ "3e", 0, undef, 0 ], + [ "3e", PERL_SCAN_TRAILING, 3, IS_NUMBER_IN_UV | IS_NUMBER_TRAILING ], + [ "3e+", 0, undef, 0 ], + [ "3e+", PERL_SCAN_TRAILING, 3, IS_NUMBER_IN_UV | IS_NUMBER_TRAILING ], + [ "Inf", 0, undef, + IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT ], + [ "In", 0, undef, 0 ], + [ "Infin",0, undef, IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ], + # this doesn't work and hasn't been needed yet + #[ "Infin",PERL_SCAN_TRAILING, undef, + # IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ], + [ "nan", 0, undef, IS_NUMBER_NAN | IS_NUMBER_NOT_INT ], + # even without PERL_SCAN_TRAILING nan can have weird stuff trailing + [ "nanx", 0, undef, IS_NUMBER_NAN | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ], + [ "nanx", PERL_SCAN_TRAILING, undef, IS_NUMBER_NAN | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ], + ); + +for my $grok (@groks) { + my ($out_flags, $out_uv) = grok_number_flags($grok->[0], $grok->[1]); + is($out_uv, $grok->[2], "'$grok->[0]' flags $grok->[1] - check number"); + is($out_flags, $grok->[3], "'$grok->[0]' flags $grok->[1] - check flags"); +} + +my $ATOU_MAX = ~0; + +# atou tests +my @atous = + ( + # [ input, endsv, out uv, out len ] + + # Basic cases. + [ "0", "", 0, 1 ], + [ "1", "", 1, 1 ], + [ "2", "", 2, 1 ], + [ "9", "", 9, 1 ], + [ "12", "", 12, 2 ], + [ "123", "", 123, 3 ], + + # Trailing whitespace is accepted or rejected, depending on endptr. + [ "0 ", " ", 0, 1 ], + [ "1 ", " ", 1, 1 ], + [ "2 ", " ", 2, 1 ], + [ "12 ", " ", 12, 2 ], + + # Trailing garbage is accepted or rejected, depending on endptr. + [ "0x", "x", 0, 1 ], + [ "1x", "x", 1, 1 ], + [ "2x", "x", 2, 1 ], + [ "12x", "x", 12, 2 ], + + # Leading whitespace is failure. + [ " 0", undef, 0, 0 ], + [ " 1", undef, 0, 0 ], + [ " 12", undef, 0, 0 ], + + # Leading garbage is outright failure. + [ "x0", undef, 0, 0 ], + [ "x1", undef, 0, 0 ], + [ "x12", undef, 0, 0 ], + + # We do not parse decimal point. + [ "12.3", ".3", 12, 2 ], + + # Leading pluses or minuses are no good. + [ "+12", undef, 0, 0 ], + [ "-12", undef, 0, 0 ], + + # Extra leading zeros are no good. + [ "00", undef, $ATOU_MAX, 0 ], + [ "01", undef, $ATOU_MAX, 0 ], + [ "012", undef, $ATOU_MAX, 0 ], + ); + +# Values near overflow point. +if ($Config{uvsize} == 8) { + push @atous, + ( + # 32-bit values no problem for 64-bit. + [ "4294967293", "", 4294967293, 10, ], + [ "4294967294", "", 4294967294, 10, ], + [ "4294967295", "", 4294967295, 10, ], + [ "4294967296", "", 4294967296, 10, ], + [ "4294967297", "", 4294967297, 10, ], + + # This is well within 64-bit. + [ "9999999999", "", 9999999999, 10, ], + + # Values valid up to 64-bit, failing beyond. + [ "18446744073709551613", "", 18446744073709551613, 20, ], + [ "18446744073709551614", "", 18446744073709551614, 20, ], + [ "18446744073709551615", "", $ATOU_MAX, 20, ], + [ "18446744073709551616", undef, $ATOU_MAX, 0, ], + [ "18446744073709551617", undef, $ATOU_MAX, 0, ], + ); +} elsif ($Config{uvsize} == 4) { + push @atous, + ( + # Values valid up to 32-bit, failing beyond. + [ "4294967293", "", 4294967293, 10, ], + [ "4294967294", "", 4294967294, 10, ], + [ "4294967295", "", $ATOU_MAX, 10, ], + [ "4294967296", undef, $ATOU_MAX, 0, ], + [ "4294967297", undef, $ATOU_MAX, 0, ], + + # Still beyond 32-bit. + [ "4999999999", undef, $ATOU_MAX, 0, ], + [ "5678901234", undef, $ATOU_MAX, 0, ], + [ "6789012345", undef, $ATOU_MAX, 0, ], + [ "7890123456", undef, $ATOU_MAX, 0, ], + [ "8901234567", undef, $ATOU_MAX, 0, ], + [ "9012345678", undef, $ATOU_MAX, 0, ], + [ "9999999999", undef, $ATOU_MAX, 0, ], + [ "10000000000", undef, $ATOU_MAX, 0, ], + [ "12345678901", undef, $ATOU_MAX, 0, ], + + # 64-bit values are way beyond. + [ "18446744073709551613", undef, $ATOU_MAX, 0, ], + [ "18446744073709551614", undef, $ATOU_MAX, 0, ], + [ "18446744073709551615", undef, $ATOU_MAX, 0, ], + [ "18446744073709551616", undef, $ATOU_MAX, 0, ], + [ "18446744073709551617", undef, $ATOU_MAX, 0, ], + ); +} + +# These will fail to fail once 128/256-bit systems arrive. +push @atous, + ( + [ "23456789012345678901", undef, $ATOU_MAX, 0 ], + [ "34567890123456789012", undef, $ATOU_MAX, 0 ], + [ "98765432109876543210", undef, $ATOU_MAX, 0 ], + [ "98765432109876543211", undef, $ATOU_MAX, 0 ], + [ "99999999999999999999", undef, $ATOU_MAX, 0 ], + ); + +for my $grok (@atous) { + my $input = $grok->[0]; + my $endsv = $grok->[1]; + my $expect_ok = defined $endsv; + my $strict_ok = $expect_ok && $endsv eq ''; + + my ($ok, $out_uv, $out_len); + + # First with endsv. + ($ok, $out_uv, $out_len) = grok_atoUV($input, $endsv); + is($expect_ok, $ok, sprintf "'$input' expected %s, got %s", + ($expect_ok ? 'success' : 'failure'), + ($ok ? 'success' : 'failure'), + ); + if ($expect_ok) { + is($expect_ok, $ok, "'$input' expect success"); + is($out_uv, $grok->[2], + "'$input' $endsv - number success (got $out_uv cf $grok->[2])"); + ok($grok->[3] <= length $input, "'$input' $endsv - length sanity 1"); + unless (length $grok->[1]) { + is($out_len, $grok->[3], "'$input' $endsv - length sanity 2"); + } # else { ... } ? + if ($out_len) { + is($endsv, substr($input, $out_len), + "'$input' $endsv - length sanity 3"); + } + } else { + is($expect_ok, $ok, "'$input' expect failure"); + is(0xdeadbeef, $out_uv, "'$input' on failure expect value unchanged"); + } + + # Then without endsv (undef == NULL). + ($ok, $out_uv, $out_len) = grok_atoUV($input, undef); + if ($strict_ok) { + is($strict_ok, $ok, "'$input' expect strict success"); + is($out_uv, $grok->[2], + "'$input' $endsv - strict number success (got $out_uv cf $grok->[2])"); + } else { + is($strict_ok, $ok, "'$input' expect strict failure"); + is(0xdeadbeef, $out_uv, "'$input' on strict failure expect value unchanged"); + } +} + done_testing(); diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/gv_const_sv.t b/gnu/usr.bin/perl/ext/XS-APItest/t/gv_const_sv.t new file mode 100644 index 00000000000..688fd48f046 --- /dev/null +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/gv_const_sv.t @@ -0,0 +1,18 @@ +#!perl + +use strict; +use warnings; +use Test::More tests => 6; + +use XS::APItest; + +sub foo () { "abc" } + +sub bar { } + +is(XS::APItest::gv_const_sv(*foo), "abc", "on const glob"); +is(XS::APItest::gv_const_sv("foo"), "abc", "on const by name"); +is(XS::APItest::gv_const_sv($::{"foo"}), "abc", "on const by lookup"); +is(XS::APItest::gv_const_sv(*bar), undef, "on non-const glob"); +is(XS::APItest::gv_const_sv("bar"), undef, "on non-const by name"); +is(XS::APItest::gv_const_sv($::{"bar"}), undef, "on non-const by lookup"); diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/handy.t b/gnu/usr.bin/perl/ext/XS-APItest/t/handy.t index ef7ace99ecc..359769a1993 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/t/handy.t +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/handy.t @@ -1,7 +1,8 @@ #!perl -w BEGIN { - require 'loc_tools.pl'; # Contains find_utf8_ctype_locale() + require 'loc_tools.pl'; # Contains locales_enabled() and + # find_utf8_ctype_locale() } use strict; @@ -18,20 +19,16 @@ sub truth($) { # Converts values so is() works my $locale; my $utf8_locale; -if($Config{d_setlocale}) { +if(locales_enabled('LC_ALL')) { require POSIX; $locale = POSIX::setlocale( &POSIX::LC_ALL, "C"); if (defined $locale && $locale eq 'C') { - BEGIN { - if($Config{d_setlocale}) { - require locale; import locale; # make \w work right in non-ASCII lands - } - } + use locale; # make \w work right in non-ASCII lands # Some locale implementations don't have the 128-255 characters all # mean nothing. Skip the locale tests in that situation for my $i (128 .. 255) { - if (chr($i) =~ /[[:print:]]/) { + if (chr(utf8::unicode_to_native($i)) =~ /[[:print:]]/) { undef $locale; last; } @@ -46,7 +43,7 @@ my %properties = ( alnum => 'Word', wordchar => 'Word', alphanumeric => 'Alnum', - alpha => 'Alpha', + alpha => 'XPosixAlpha', ascii => 'ASCII', blank => 'Blank', cntrl => 'Control', @@ -54,14 +51,14 @@ my %properties = ( graph => 'Graph', idfirst => '_Perl_IDStart', idcont => '_Perl_IDCont', - lower => 'Lower', + lower => 'XPosixLower', print => 'Print', psxspc => 'XPosixSpace', punct => 'XPosixPunct', quotemeta => '_Perl_Quotemeta', space => 'XPerlSpace', vertws => 'VertSpace', - upper => 'Upper', + upper => 'XPosixUpper', xdigit => 'XDigit', ); @@ -73,8 +70,13 @@ foreach my $name (sort keys %properties) { my $property = $properties{$name}; my @invlist = prop_invlist($property, '_perl_core_internal_ok'); if (! @invlist) { - fail("No inversion list found for $property"); - next; + + # An empty return could mean an unknown property, or merely that it is + # empty. Call in scalar context to differentiate + if (! prop_invlist($property, '_perl_core_internal_ok')) { + fail("No inversion list found for $property"); + next; + } } # Include all the Latin1 code points, plus 0x100. @@ -115,7 +117,7 @@ foreach my $name (sort keys %properties) { my $ret; my $char_name = charnames::viacode($i) // "No name"; - my $display_name = sprintf "\\N{U+%02X, %s}", $i, $char_name; + my $display_name = sprintf "\\x{%02X, %s}", $i, $char_name; if ($name eq 'quotemeta') { # There is only one macro for this, and is # defined only for Latin1 range @@ -140,7 +142,7 @@ foreach my $name (sort keys %properties) { fail($@); } else { - my $truth = truth($matches && $i < 128); + my $truth = truth($matches && utf8::native_to_unicode($i) < 128); is ($ret, $truth, "is${function}_A( $display_name ) == $truth"); } $ret = truth eval "test_is${function}_L1($i)"; @@ -154,15 +156,14 @@ foreach my $name (sort keys %properties) { } if (defined $locale) { - require locale; import locale; - + use locale; POSIX::setlocale( &POSIX::LC_ALL, "C"); $ret = truth eval "test_is${function}_LC($i)"; if ($@) { fail($@); } else { - my $truth = truth($matches && $i < 128); + my $truth = truth($matches && utf8::native_to_unicode($i) < 128); is ($ret, $truth, "is${function}_LC( $display_name ) == $truth (C locale)"); } } @@ -193,15 +194,14 @@ foreach my $name (sort keys %properties) { } if (defined $locale && $name ne 'vertws') { - require locale; import locale; - + use locale; POSIX::setlocale( &POSIX::LC_ALL, "C"); $ret = truth eval "test_is${function}_LC_uvchr('$i')"; if ($@) { fail($@); } else { - my $truth = truth($matches && ($i < 128 || $i > 255)); + my $truth = truth($matches && (utf8::native_to_unicode($i) < 128 || $i > 255)); is ($ret, $truth, "is${function}_LC_uvchr( $display_name ) == $truth (C locale)"); } } @@ -232,15 +232,14 @@ foreach my $name (sort keys %properties) { } if ($name ne 'vertws' && defined $locale) { - require locale; import locale; - + use locale; POSIX::setlocale( &POSIX::LC_ALL, "C"); $ret = truth eval "test_is${function}_LC_utf8('$char')"; if ($@) { fail($@); } else { - my $truth = truth($matches && ($i < 128 || $i > 255)); + my $truth = truth($matches && (utf8::native_to_unicode($i) < 128 || $i > 255)); is ($ret, $truth, "is${function}_LC_utf8( $display_name ) == $truth (C locale)"); } } @@ -277,7 +276,7 @@ foreach my $name (sort keys %to_properties) { fail("No inversion map found for $property"); next; } - if ($format ne "al") { + if ($format !~ / ^ a l? $ /x) { fail("Unexpected inversion map format ('$format') found for $property"); next; } @@ -348,9 +347,8 @@ foreach my $name (sort keys %to_properties) { if ($name ne 'TITLE') { # Test _LC; titlecase is not defined in locales. if (defined $locale) { - require locale; import locale; - - POSIX::setlocale( &POSIX::LC_ALL, "C"); + use locale; + POSIX::setlocale( &POSIX::LC_ALL, "C"); $ret = eval "test_to${function}_LC($j)"; if ($@) { fail($@); diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/hash.t b/gnu/usr.bin/perl/ext/XS-APItest/t/hash.t index 8a8c607dd7b..77a23aad238 100755 --- a/gnu/usr.bin/perl/ext/XS-APItest/t/hash.t +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/hash.t @@ -20,7 +20,7 @@ sub test_fetch_absent; my $utf8_for_258 = chr 258; utf8::encode $utf8_for_258; -my @testkeys = ('N', chr 198, chr 256); +my @testkeys = ('N', chr utf8::unicode_to_native(198), chr 256); my @keys = (@testkeys, $utf8_for_258); foreach (@keys) { @@ -102,11 +102,21 @@ foreach my $in ("", "N", "a\0b") { foreach my $upgrade_n (0, 1) { my (%hash, %placebo); XS::APItest::Hash::bitflip_hash(\%hash); - foreach my $new (["7", 65, 67, 80], - ["8", 163, 171, 215], + foreach my $new (["7", utf8::unicode_to_native(65), + utf8::unicode_to_native(67), + utf8::unicode_to_native(80) + ], + ["8", utf8::unicode_to_native(163), + utf8::unicode_to_native(171), + utf8::unicode_to_native(215) + ], ["U", 2603, 2604, 2604], - ) { - foreach my $code (78, 240, 256, 1336) { + ) { + foreach my $code (utf8::unicode_to_native(78), + utf8::unicode_to_native(240), + 256, + 1336 + ) { my $key = chr $code; # This is the UTF-8 byte sequence for the key. my $key_utf8 = $key; @@ -396,7 +406,7 @@ sub test_U_hash { sub main_tests { my ($keys, $testkeys, $description) = @_; foreach my $key (@$testkeys) { - my $lckey = ($key eq chr 198) ? chr 230 : lc $key; + my $lckey = ($key eq chr utf8::unicode_to_native(198)) ? chr utf8::unicode_to_native(230) : lc $key; my $unikey = $key; utf8::encode $unikey; @@ -571,6 +581,7 @@ sub rot13 { } sub bitflip { - my @results = map {join '', map {chr(32 ^ ord $_)} split '', $_} @_; + my $flip_bit = ord("A") ^ ord("a"); + my @results = map {join '', map {chr($flip_bit ^ ord $_)} split '', $_} @_; wantarray ? @results : $results[0]; } diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/join_with_space.t b/gnu/usr.bin/perl/ext/XS-APItest/t/join_with_space.t new file mode 100644 index 00000000000..420f1477dd2 --- /dev/null +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/join_with_space.t @@ -0,0 +1,16 @@ +#!perl + +use strict; +use warnings; + +use Test::More tests => 1; + +use XS::APItest qw(join_with_space); + +sub foo { 'A' .. 'C' } + +my $bar = 42; +my @baz = ('x', 'y'); + +my $str = join_with_space $bar, foo, @baz; +is $str, "42 A B C x y"; diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/locale.t b/gnu/usr.bin/perl/ext/XS-APItest/t/locale.t new file mode 100644 index 00000000000..be594b08041 --- /dev/null +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/locale.t @@ -0,0 +1,36 @@ +BEGIN { + require '../../t/test.pl'; + require '../../t/loc_tools.pl'; # to find locales +} + +use XS::APItest; +use Config; + +skip_all("locales not available") unless locales_enabled('LC_NUMERIC'); + +my @locales = eval { find_locales( &LC_NUMERIC ) }; +skip_all("no LC_NUMERIC locales available") unless @locales; + +my $non_dot_locale; +for (@locales) { + use locale; + setlocale(LC_NUMERIC, $_) or next; + my $in = 4.2; # avoid any constant folding bugs + if (sprintf("%g", $in) ne "4.2") { + $non_dot_locale = $_; + last; + } +} + +skip_all("no non-dot radix locales available") unless $non_dot_locale; + +plan tests => 2; + +SKIP: { + if ($Config{usequadmath}) { + skip "no gconvert with usequadmath", 2; + } + is(test_Gconvert(4.179, 2), "4.2", "Gconvert doesn't recognize underlying locale outside 'use locale'"); + use locale; + is(test_Gconvert(4.179, 2), "4.2", "Gconvert doesn't recognize underlying locale inside 'use locale'"); +} diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/magic.t b/gnu/usr.bin/perl/ext/XS-APItest/t/magic.t index 8451f0196a3..8f1c2c409d5 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/t/magic.t +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/magic.t @@ -29,4 +29,8 @@ ok !mg_find_bar($sv), '... and bar magic is removed too'; is(test_get_vtbl(), 0, 'get_vtbl(-1) returns NULL'); +use Scalar::Util 'weaken'; +eval { sv_magic(\!0, $foo) }; +is $@, "", 'PERL_MAGIC_ext is permitted on read-only things'; + done_testing; diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/multicall.t b/gnu/usr.bin/perl/ext/XS-APItest/t/multicall.t index f96f62e7436..51ef276b14e 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/t/multicall.t +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/multicall.t @@ -7,7 +7,7 @@ use warnings; use strict; -use Test::More tests => 7; +use Test::More tests => 80; use XS::APItest; @@ -24,7 +24,7 @@ use XS::APItest; } # [perl #78070] -# multicall using a sub that aleady has CvDEPTH > 1 caused sub +# multicall using a sub that already has CvDEPTH > 1 caused sub # to be prematurely freed { @@ -52,8 +52,8 @@ use XS::APItest; # [perl #115602] # deep recursion realloced the CX stack, but the dMULTICALL local var # 'cx' still pointed to the old one. -# Thius doesn;t actually test the failure (I couldn't think of a way to -# get the failure to show at the perl level) but it allows valgribnd or +# This doesn't actually test the failure (I couldn't think of a way to +# get the failure to show at the perl level) but it allows valgrind or # similar to spot any errors. { @@ -61,3 +61,110 @@ use XS::APItest; my @r = XS::APItest::multicall_each { rec(90) } 1,2,3; pass("recursion"); } + + + +# Confirm that MULTICALL handles arg return correctly in the various +# contexts. Also check that lvalue subs are handled the same way, as +# these take different code paths. +# Whenever an explicit 'return' is used, it is followed by '1;' to avoid +# the return being optimised into a leavesub. +# Adding a 'for' loop pushes extra junk on the stack, which we we want to +# avoid being interpreted as a return arg. + +{ + package Ret; + + use XS::APItest qw(multicall_return G_VOID G_SCALAR G_ARRAY); + + # Helper function for the block that follows: + # check that @$got matches what would be expected if a function returned + # the items in @$args in $gimme context. + + sub gimme_check { + my ($gimme, $got, $args, $desc) = @_; + + if ($gimme == G_VOID) { + ::is (scalar @$got, 0, "G_VOID: $desc"); + } + elsif ($gimme == G_SCALAR) { + ::is (scalar @$got, 1, "G_SCALAR: $desc: expect 1 arg"); + ::is ($got->[0], (@$args ? $args->[-1] : undef), + "G_SCALAR: $desc: correct arg"); + } + else { + ::is (join('-',@$got), join('-', @$args), "G_ARRAY: $desc"); + } + } + + for my $gimme (G_VOID, G_SCALAR, G_ARRAY) { + my @a; + + # zero args + + @a = multicall_return {()} $gimme; + gimme_check($gimme, \@a, [], "()"); + sub f1 :lvalue { () } + @a = multicall_return \&f1, $gimme; + gimme_check($gimme, \@a, [], "() lval"); + + @a = multicall_return { return; 1 } $gimme; + gimme_check($gimme, \@a, [], "return"); + sub f2 :lvalue { return; 1 } + @a = multicall_return \&f2, $gimme; + gimme_check($gimme, \@a, [], "return lval"); + + + @a = multicall_return { for (1,2) { return; 1 } } $gimme; + gimme_check($gimme, \@a, [], "for-return"); + sub f3 :lvalue { for (1,2) { return; 1 } } + @a = multicall_return \&f3, $gimme; + gimme_check($gimme, \@a, [], "for-return lval"); + + # one arg + + @a = multicall_return {"one"} $gimme; + gimme_check($gimme, \@a, ["one"], "one arg"); + sub f4 :lvalue { "one" } + @a = multicall_return \&f4, $gimme; + gimme_check($gimme, \@a, ["one"], "one arg lval"); + + @a = multicall_return { return "one"; 1} $gimme; + gimme_check($gimme, \@a, ["one"], "return one arg"); + sub f5 :lvalue { return "one"; 1 } + @a = multicall_return \&f5, $gimme; + gimme_check($gimme, \@a, ["one"], "return one arg lval"); + + @a = multicall_return { for (1,2) { return "one"; 1} } $gimme; + gimme_check($gimme, \@a, ["one"], "for-return one arg"); + sub f6 :lvalue { for (1,2) { return "one"; 1 } } + @a = multicall_return \&f6, $gimme; + gimme_check($gimme, \@a, ["one"], "for-return one arg lval"); + + # two args + + @a = multicall_return {"one", "two" } $gimme; + gimme_check($gimme, \@a, ["one", "two"], "two args"); + sub f7 :lvalue { "one", "two" } + @a = multicall_return \&f7, $gimme; + gimme_check($gimme, \@a, ["one", "two"], "two args lval"); + + @a = multicall_return { return "one", "two"; 1} $gimme; + gimme_check($gimme, \@a, ["one", "two"], "return two args"); + sub f8 :lvalue { return "one", "two"; 1 } + @a = multicall_return \&f8, $gimme; + gimme_check($gimme, \@a, ["one", "two"], "return two args lval"); + + @a = multicall_return { for (1,2) { return "one", "two"; 1} } $gimme; + gimme_check($gimme, \@a, ["one", "two"], "for-return two args"); + sub f9 :lvalue { for (1,2) { return "one", "two"; 1 } } + @a = multicall_return \&f9, $gimme; + gimme_check($gimme, \@a, ["one", "two"], "for-return two args lval"); + } + + # MULTICALL *shouldn't* clear savestack after each call + + sub f10 { my $x = 1; $x }; + my @a = XS::APItest::multicall_return \&f10, G_SCALAR; + ::is($a[0], 1, "leave scope"); +} diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/newDEFSVOP.t b/gnu/usr.bin/perl/ext/XS-APItest/t/newDEFSVOP.t new file mode 100644 index 00000000000..42d45b26337 --- /dev/null +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/newDEFSVOP.t @@ -0,0 +1,20 @@ +#!perl + +use strict; +use warnings; + +use Test::More tests => 7; + +use XS::APItest qw(DEFSV); + +is $_, undef; +is DEFSV, undef; +is \DEFSV, \$_; + +DEFSV = "foo"; +is DEFSV, "foo"; +is $_, "foo"; + +$_ = "bar"; +is DEFSV, "bar"; +is $_, "bar"; diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/printf.t b/gnu/usr.bin/perl/ext/XS-APItest/t/printf.t index 76cc19fcaf0..8f43ee2532a 100755 --- a/gnu/usr.bin/perl/ext/XS-APItest/t/printf.t +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/printf.t @@ -1,3 +1,11 @@ +BEGIN { + require Config; import Config; + if ($Config{usequadmath}) { + print "1..0 # Skip: usequadmath\n"; + exit(0); + } +} + use Test::More tests => 11; BEGIN { use_ok('XS::APItest') }; diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/svcat.t b/gnu/usr.bin/perl/ext/XS-APItest/t/svcat.t new file mode 100644 index 00000000000..72348d5ffa9 --- /dev/null +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/svcat.t @@ -0,0 +1,19 @@ +#!perl + +use Test::More tests => 4; +use XS::APItest; +use utf8; + +my $e_acute = chr utf8::unicode_to_native(0xe9); +$_ = "καλοκαίρι"; +sv_catpvn($_, " ${e_acute}t$e_acute"); # uses SV_CATBYTES +is $_, "καλοκαίρι été", 'sv_catpvn_flags(utfsv, ... SV_CATBYTES)'; +$_ = "${e_acute}t$e_acute"; +sv_catpvn($_, " καλοκαίρι"); # uses SV_CATUTF8 +is $_, "été καλοκαίρι", 'sv_catpvn_flags(bytesv, ... SV_CATUTF8)'; +$_ = "καλοκαίρι"; +sv_catpvn($_, " été"); # uses SV_CATUTF8 +is $_, "καλοκαίρι été", 'sv_catpvn_flags(utfsv, ... SV_CATUTF8)'; +$_ = "${e_acute}t$e_acute"; +sv_catpvn($_, " ${e_acute}t$e_acute"); # uses SV_CATBYTES +is $_, "été été", 'sv_catpvn_flags(bytesv, ... SV_CATBYTES)'; diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/svcatpvf.t b/gnu/usr.bin/perl/ext/XS-APItest/t/svcatpvf.t new file mode 100644 index 00000000000..15348891bf2 --- /dev/null +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/svcatpvf.t @@ -0,0 +1,21 @@ +use strict; +use warnings; + +use Test::More tests => 4; + +use XS::APItest; + +my @cases = ( + [field => '%2$d'], + [precision => '%.*2$d'], + [vector => '%2$vd'], + [width => '%*2$d'], +); + +for my $case (@cases) { + my ($what, $format) = @$case; + my $got = eval { test_sv_catpvf($format); 1 }; + my $exn = $got ? undef : $@; + like($exn, qr/\b\QCannot yet reorder sv_catpvfn() arguments from va_list\E\b/, + "explicit $what index forbidden in va_list arguments"); +} diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/svpeek.t b/gnu/usr.bin/perl/ext/XS-APItest/t/svpeek.t index 5d18297ce5a..25eb2349fb6 100755 --- a/gnu/usr.bin/perl/ext/XS-APItest/t/svpeek.t +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/svpeek.t @@ -27,8 +27,9 @@ if ($^O eq 'VMS') { } is (DPeek ($|), 'PVMG(1)', '$|'); - "abc" =~ m/(b)/; # Don't know why these magic vars have this content -like (DPeek ($1), qr'^PVMG\("', ' $1'); + "abc" =~ m/b/; # Don't know why these magic vars have this content + () = $1 || ''; + is (DPeek ($1), 'PVMG()', ' $1'); is (DPeek ($`), 'PVMG()', ' $`'); is (DPeek ($&), 'PVMG()', ' $&'); is (DPeek ($'), 'PVMG()', " \$'"); @@ -65,12 +66,15 @@ if ($^O eq 'vos') { $VAR = ""; is (DPeek ($VAR), 'PVIV(""\0)', ' $VAR ""'); is (DPeek (\$VAR), '\PVIV(""\0)', '\$VAR ""'); - $VAR = "\xa8"; - is (DPeek ($VAR), 'PVIV("\250"\0)', ' $VAR "\xa8"'); - is (DPeek (\$VAR), '\PVIV("\250"\0)', '\$VAR "\xa8"'); - $VAR = "a\x0a\x{20ac}"; - is (DPeek ($VAR), 'PVIV("a\n\342\202\254"\0) [UTF8 "a\n\x{20ac}"]', + $VAR = "\xdf"; # \xdf works for both ASCII and EBCDIC + is (DPeek ($VAR), 'PVIV("\337"\0)', ' $VAR "\xdf"'); + is (DPeek (\$VAR), '\PVIV("\337"\0)', '\$VAR "\xdf"'); + SKIP: { + skip("ASCII-centric tests", 1) if ord "A" == 193; + $VAR = "a\x0a\x{20ac}"; + is (DPeek ($VAR), 'PVIV("a\n\342\202\254"\0) [UTF8 "a\n\x{20ac}"]', ' $VAR "a\x0a\x{20ac}"'); + } $VAR = sub { "VAR" }; is (DPeek ($VAR), '\CV(__ANON__)', ' $VAR sub { "VAR" }'); is (DPeek (\$VAR), '\\\CV(__ANON__)', '\$VAR sub { "VAR" }'); diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/svpv_magic.t b/gnu/usr.bin/perl/ext/XS-APItest/t/svpv_magic.t index c57257e2011..00edb91504b 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/t/svpv_magic.t +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/svpv_magic.t @@ -3,7 +3,8 @@ use Test::More tests => 10; BEGIN { - use_ok('XS::APItest') + use_ok('XS::APItest'); + require 'charset_tools.pl'; }; $b = "\303\244"; # or encode_utf8("\x{e4}"); @@ -30,20 +31,20 @@ is(eval { XS::APItest::first_byte($1) } || $@, 0303, "utf8 flag fetched correctly without stringification"); sub TIESCALAR { bless [], shift } -sub FETCH { ++$f; *{chr 255} } +sub FETCH { ++$f; *{chr utf8::unicode_to_native(255)} } tie $t, "main"; -is SvPVutf8($t), "*main::\xc3\xbf", +is SvPVutf8($t), "*main::" . byte_utf8a_to_utf8n("\xc3\xbf"), 'SvPVutf8 works with get-magic changing the SV type'; is $f, 1, 'SvPVutf8 calls get-magic once'; package t { @ISA = 'main'; - sub FETCH { ++$::f; chr 255 } + sub FETCH { ++$::f; chr utf8::unicode_to_native(255) } sub STORE { } } tie $t, "t"; undef $f; -is SvPVutf8($t), "\xc3\xbf", +is SvPVutf8($t), byte_utf8a_to_utf8n("\xc3\xbf"), 'SvPVutf8 works with get-magic downgrading the SV'; is $f, 1, 'SvPVutf8 calls get-magic once'; ()="$t"; diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/synthetic_scope.t b/gnu/usr.bin/perl/ext/XS-APItest/t/synthetic_scope.t new file mode 100644 index 00000000000..43a758f077b --- /dev/null +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/synthetic_scope.t @@ -0,0 +1,42 @@ +#!perl + +use strict; +use warnings; + +use Test::More tests => 18; + +use XS::APItest qw(with_vars); + +my $foo = "A"; my $rfoo = \$foo; +my $bar = "B"; my $rbar = \$bar; +my $baz = "C"; my $rbaz = \$baz; + +with_vars foo bar baz { + is $foo, 1; + is $$rfoo, "A"; + isnt \$foo, $rfoo; + + is $bar, 2; + is $$rbar, "B"; + isnt \$bar, $rbar; + + is $baz, 3; + is $$rbaz, "C"; + isnt \$baz, $rbaz; +} + +is $foo, "A"; +is \$foo, $rfoo; + +is $bar, "B"; +is \$bar, $rbar; + +is $baz, "C"; +is \$baz, $rbaz; + +with_vars x { + is $x, 1; +} + +is eval('$x++'), undef; +like $@, qr/explicit package name/; diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/underscore_length.t b/gnu/usr.bin/perl/ext/XS-APItest/t/underscore_length.t index 545b2a32408..580f9f9e009 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/t/underscore_length.t +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/underscore_length.t @@ -1,7 +1,7 @@ -use warnings; no warnings 'experimental::lexical_topic'; +use warnings; use strict; -use Test::More tests => 4; +use Test::More tests => 2; use XS::APItest qw(underscore_length); @@ -11,10 +11,4 @@ is underscore_length(), 3; $_ = "snowman \x{2603}"; is underscore_length(), 9; -my $_ = "xyzzy"; -is underscore_length(), 5; - -$_ = "pile of poo \x{1f4a9}"; -is underscore_length(), 13; - 1; diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/utf8.t b/gnu/usr.bin/perl/ext/XS-APItest/t/utf8.t index bc5a7ed0c1d..9b5ed9b58a3 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/t/utf8.t +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/utf8.t @@ -2,16 +2,110 @@ use strict; use Test::More; +$|=1; + +no warnings 'deprecated'; # Some of the below are above IV_MAX on 32 bit + # machines, and that is tested elsewhere use XS::APItest; +my $pound_sign = chr utf8::unicode_to_native(163); + +sub isASCII { ord "A" == 65 } + +sub display_bytes { + my $string = shift; + return '"' + . join("", map { sprintf("\\x%02x", ord $_) } split "", $string) + . '"'; +} + +# This test file can't use byte_utf8a_to_utf8n() from t/charset_tools.pl +# because that uses the same functions we are testing here. So UTF-EBCDIC +# strings are hard-coded as I8 strings in this file instead, and we use array +# lookup to translate into the appropriate code page. + +my @i8_to_native = ( # Only code page 1047 so far. +# _0 _1 _2 _3 _4 _5 _6 _7 _8 _9 _A _B _C _D _E _F +0x00,0x01,0x02,0x03,0x37,0x2D,0x2E,0x2F,0x16,0x05,0x15,0x0B,0x0C,0x0D,0x0E,0x0F, +0x10,0x11,0x12,0x13,0x3C,0x3D,0x32,0x26,0x18,0x19,0x3F,0x27,0x1C,0x1D,0x1E,0x1F, +0x40,0x5A,0x7F,0x7B,0x5B,0x6C,0x50,0x7D,0x4D,0x5D,0x5C,0x4E,0x6B,0x60,0x4B,0x61, +0xF0,0xF1,0xF2,0xF3,0xF4,0xF5,0xF6,0xF7,0xF8,0xF9,0x7A,0x5E,0x4C,0x7E,0x6E,0x6F, +0x7C,0xC1,0xC2,0xC3,0xC4,0xC5,0xC6,0xC7,0xC8,0xC9,0xD1,0xD2,0xD3,0xD4,0xD5,0xD6, +0xD7,0xD8,0xD9,0xE2,0xE3,0xE4,0xE5,0xE6,0xE7,0xE8,0xE9,0xAD,0xE0,0xBD,0x5F,0x6D, +0x79,0x81,0x82,0x83,0x84,0x85,0x86,0x87,0x88,0x89,0x91,0x92,0x93,0x94,0x95,0x96, +0x97,0x98,0x99,0xA2,0xA3,0xA4,0xA5,0xA6,0xA7,0xA8,0xA9,0xC0,0x4F,0xD0,0xA1,0x07, +0x20,0x21,0x22,0x23,0x24,0x25,0x06,0x17,0x28,0x29,0x2A,0x2B,0x2C,0x09,0x0A,0x1B, +0x30,0x31,0x1A,0x33,0x34,0x35,0x36,0x08,0x38,0x39,0x3A,0x3B,0x04,0x14,0x3E,0xFF, +0x41,0x42,0x43,0x44,0x45,0x46,0x47,0x48,0x49,0x4A,0x51,0x52,0x53,0x54,0x55,0x56, +0x57,0x58,0x59,0x62,0x63,0x64,0x65,0x66,0x67,0x68,0x69,0x6A,0x70,0x71,0x72,0x73, +0x74,0x75,0x76,0x77,0x78,0x80,0x8A,0x8B,0x8C,0x8D,0x8E,0x8F,0x90,0x9A,0x9B,0x9C, +0x9D,0x9E,0x9F,0xA0,0xAA,0xAB,0xAC,0xAE,0xAF,0xB0,0xB1,0xB2,0xB3,0xB4,0xB5,0xB6, +0xB7,0xB8,0xB9,0xBA,0xBB,0xBC,0xBE,0xBF,0xCA,0xCB,0xCC,0xCD,0xCE,0xCF,0xDA,0xDB, +0xDC,0xDD,0xDE,0xDF,0xE1,0xEA,0xEB,0xEC,0xED,0xEE,0xEF,0xFA,0xFB,0xFC,0xFD,0xFE, +); + +*I8_to_native = (isASCII) + ? sub { return shift } + : sub { return join "", map { chr $i8_to_native[ord $_] } + split "", shift }; + +my $is64bit = length sprintf("%x", ~0) > 8; + + +# Test utf8n_to_uvchr(). These provide essentially complete code coverage. +# Copied from utf8.h +my $UTF8_ALLOW_EMPTY = 0x0001; +my $UTF8_ALLOW_CONTINUATION = 0x0002; +my $UTF8_ALLOW_NON_CONTINUATION = 0x0004; +my $UTF8_ALLOW_SHORT = 0x0008; +my $UTF8_ALLOW_LONG = 0x0010; +my $UTF8_DISALLOW_SURROGATE = 0x0020; +my $UTF8_WARN_SURROGATE = 0x0040; +my $UTF8_DISALLOW_NONCHAR = 0x0080; +my $UTF8_WARN_NONCHAR = 0x0100; +my $UTF8_DISALLOW_SUPER = 0x0200; +my $UTF8_WARN_SUPER = 0x0400; +my $UTF8_DISALLOW_ABOVE_31_BIT = 0x0800; +my $UTF8_WARN_ABOVE_31_BIT = 0x1000; +my $UTF8_CHECK_ONLY = 0x2000; + +# Test uvchr_to_utf8(). +my $UNICODE_WARN_SURROGATE = 0x0001; +my $UNICODE_WARN_NONCHAR = 0x0002; +my $UNICODE_WARN_SUPER = 0x0004; +my $UNICODE_WARN_ABOVE_31_BIT = 0x0008; +my $UNICODE_DISALLOW_SURROGATE = 0x0010; +my $UNICODE_DISALLOW_NONCHAR = 0x0020; +my $UNICODE_DISALLOW_SUPER = 0x0040; +my $UNICODE_DISALLOW_ABOVE_31_BIT = 0x0080; + +my $look_for_everything_utf8n_to + = $UTF8_DISALLOW_SURROGATE + | $UTF8_WARN_SURROGATE + | $UTF8_DISALLOW_NONCHAR + | $UTF8_WARN_NONCHAR + | $UTF8_DISALLOW_SUPER + | $UTF8_WARN_SUPER + | $UTF8_DISALLOW_ABOVE_31_BIT + | $UTF8_WARN_ABOVE_31_BIT; +my $look_for_everything_uvchr_to + = $UNICODE_DISALLOW_SURROGATE + | $UNICODE_WARN_SURROGATE + | $UNICODE_DISALLOW_NONCHAR + | $UNICODE_WARN_NONCHAR + | $UNICODE_DISALLOW_SUPER + | $UNICODE_WARN_SUPER + | $UNICODE_DISALLOW_ABOVE_31_BIT + | $UNICODE_WARN_ABOVE_31_BIT; + foreach ([0, '', '', 'empty'], [0, 'N', 'N', '1 char'], [1, 'NN', 'N', '1 char substring'], [-2, 'Perl', 'Rules', 'different'], - [0, chr 163, chr 163, 'pound sign'], - [1, chr (163) . 10, chr (163) . 1, '10 pounds is more than 1 pound'], - [1, chr(163) . chr(163), chr 163, '2 pound signs are more than 1'], + [0, $pound_sign, $pound_sign, 'pound sign'], + [1, $pound_sign . 10, $pound_sign . 1, '10 pounds is more than 1 pound'], + [1, $pound_sign . $pound_sign, $pound_sign, '2 pound signs are more than 1'], [-2, ' $!', " \x{1F42B}!", 'Camels are worth more than 1 dollar'], [-1, '!', "!\x{1F42A}", 'Initial substrings match'], ) { @@ -24,65 +118,381 @@ foreach ([0, '', '', 'empty'], is(bytes_cmp_utf8($right, $left), -$expect, "$desc reversed"); } -# Test uft8n_to_uvchr(). These provide essentially complete code coverage. +# The keys to this hash are Unicode code points, their values are the native +# UTF-8 representations of them. The code points are chosen because they are +# "interesting" on either or both ASCII and EBCDIC platforms. First we add +# boundaries where the number of bytes required to represent them increase, or +# are adjacent to problematic code points, so we want to make sure they aren't +# considered problematic. +my %code_points = ( + 0x0100 => (isASCII) ? "\xc4\x80" : I8_to_native("\xc8\xa0"), + 0x0400 - 1 => (isASCII) ? "\xcf\xbf" : I8_to_native("\xdf\xbf"), + 0x0400 => (isASCII) ? "\xd0\x80" : I8_to_native("\xe1\xa0\xa0"), + 0x0800 - 1 => (isASCII) ? "\xdf\xbf" : I8_to_native("\xe1\xbf\xbf"), + 0x0800 => (isASCII) ? "\xe0\xa0\x80" : I8_to_native("\xe2\xa0\xa0"), + 0x4000 - 1 => (isASCII) ? "\xe3\xbf\xbf" : I8_to_native("\xef\xbf\xbf"), + 0x4000 => (isASCII) ? "\xe4\x80\x80" : I8_to_native("\xf0\xb0\xa0\xa0"), + 0x8000 - 1 => (isASCII) ? "\xe7\xbf\xbf" : I8_to_native("\xf0\xbf\xbf\xbf"), -# Copied from utf8.h -my $UTF8_ALLOW_EMPTY = 0x0001; -my $UTF8_ALLOW_CONTINUATION = 0x0002; -my $UTF8_ALLOW_NON_CONTINUATION = 0x0004; -my $UTF8_ALLOW_SHORT = 0x0008; -my $UTF8_ALLOW_LONG = 0x0010; -my $UTF8_DISALLOW_SURROGATE = 0x0020; -my $UTF8_WARN_SURROGATE = 0x0040; -my $UTF8_DISALLOW_NONCHAR = 0x0080; -my $UTF8_WARN_NONCHAR = 0x0100; -my $UTF8_DISALLOW_SUPER = 0x0200; -my $UTF8_WARN_SUPER = 0x0400; -my $UTF8_DISALLOW_FE_FF = 0x0800; -my $UTF8_WARN_FE_FF = 0x1000; -my $UTF8_CHECK_ONLY = 0x2000; + # First code point that the implementation of isUTF8_POSSIBLY_PROBLEMATIC, + # as of this writing, considers potentially problematic on EBCDIC + 0x8000 => (isASCII) ? "\xe8\x80\x80" : I8_to_native("\xf1\xa0\xa0\xa0"), -my $REPLACEMENT = 0xFFFD; + 0xD000 - 1 => (isASCII) ? "\xec\xbf\xbf" : I8_to_native("\xf1\xb3\xbf\xbf"), + + # First code point that the implementation of isUTF8_POSSIBLY_PROBLEMATIC, + # as of this writing, considers potentially problematic on ASCII + 0xD000 => (isASCII) ? "\xed\x80\x80" : I8_to_native("\xf1\xb4\xa0\xa0"), + + # Bracket the surrogates + 0xD7FF => (isASCII) ? "\xed\x9f\xbf" : I8_to_native("\xf1\xb5\xbf\xbf"), + 0xE000 => (isASCII) ? "\xee\x80\x80" : I8_to_native("\xf1\xb8\xa0\xa0"), + + # Bracket the 32 contiguous non characters + 0xFDCF => (isASCII) ? "\xef\xb7\x8f" : I8_to_native("\xf1\xbf\xae\xaf"), + 0xFDF0 => (isASCII) ? "\xef\xb7\xb0" : I8_to_native("\xf1\xbf\xaf\xb0"), + + # Mostly bracket non-characters, but some are transitions to longer + # strings + 0xFFFD => (isASCII) ? "\xef\xbf\xbd" : I8_to_native("\xf1\xbf\xbf\xbd"), + 0x10000 - 1 => (isASCII) ? "\xef\xbf\xbf" : I8_to_native("\xf1\xbf\xbf\xbf"), + 0x10000 => (isASCII) ? "\xf0\x90\x80\x80" : I8_to_native("\xf2\xa0\xa0\xa0"), + 0x1FFFD => (isASCII) ? "\xf0\x9f\xbf\xbd" : I8_to_native("\xf3\xbf\xbf\xbd"), + 0x20000 => (isASCII) ? "\xf0\xa0\x80\x80" : I8_to_native("\xf4\xa0\xa0\xa0"), + 0x2FFFD => (isASCII) ? "\xf0\xaf\xbf\xbd" : I8_to_native("\xf5\xbf\xbf\xbd"), + 0x30000 => (isASCII) ? "\xf0\xb0\x80\x80" : I8_to_native("\xf6\xa0\xa0\xa0"), + 0x3FFFD => (isASCII) ? "\xf0\xbf\xbf\xbd" : I8_to_native("\xf7\xbf\xbf\xbd"), + 0x40000 - 1 => (isASCII) ? "\xf0\xbf\xbf\xbf" : I8_to_native("\xf7\xbf\xbf\xbf"), + 0x40000 => (isASCII) ? "\xf1\x80\x80\x80" : I8_to_native("\xf8\xa8\xa0\xa0\xa0"), + 0x4FFFD => (isASCII) ? "\xf1\x8f\xbf\xbd" : I8_to_native("\xf8\xa9\xbf\xbf\xbd"), + 0x50000 => (isASCII) ? "\xf1\x90\x80\x80" : I8_to_native("\xf8\xaa\xa0\xa0\xa0"), + 0x5FFFD => (isASCII) ? "\xf1\x9f\xbf\xbd" : I8_to_native("\xf8\xab\xbf\xbf\xbd"), + 0x60000 => (isASCII) ? "\xf1\xa0\x80\x80" : I8_to_native("\xf8\xac\xa0\xa0\xa0"), + 0x6FFFD => (isASCII) ? "\xf1\xaf\xbf\xbd" : I8_to_native("\xf8\xad\xbf\xbf\xbd"), + 0x70000 => (isASCII) ? "\xf1\xb0\x80\x80" : I8_to_native("\xf8\xae\xa0\xa0\xa0"), + 0x7FFFD => (isASCII) ? "\xf1\xbf\xbf\xbd" : I8_to_native("\xf8\xaf\xbf\xbf\xbd"), + 0x80000 => (isASCII) ? "\xf2\x80\x80\x80" : I8_to_native("\xf8\xb0\xa0\xa0\xa0"), + 0x8FFFD => (isASCII) ? "\xf2\x8f\xbf\xbd" : I8_to_native("\xf8\xb1\xbf\xbf\xbd"), + 0x90000 => (isASCII) ? "\xf2\x90\x80\x80" : I8_to_native("\xf8\xb2\xa0\xa0\xa0"), + 0x9FFFD => (isASCII) ? "\xf2\x9f\xbf\xbd" : I8_to_native("\xf8\xb3\xbf\xbf\xbd"), + 0xA0000 => (isASCII) ? "\xf2\xa0\x80\x80" : I8_to_native("\xf8\xb4\xa0\xa0\xa0"), + 0xAFFFD => (isASCII) ? "\xf2\xaf\xbf\xbd" : I8_to_native("\xf8\xb5\xbf\xbf\xbd"), + 0xB0000 => (isASCII) ? "\xf2\xb0\x80\x80" : I8_to_native("\xf8\xb6\xa0\xa0\xa0"), + 0xBFFFD => (isASCII) ? "\xf2\xbf\xbf\xbd" : I8_to_native("\xf8\xb7\xbf\xbf\xbd"), + 0xC0000 => (isASCII) ? "\xf3\x80\x80\x80" : I8_to_native("\xf8\xb8\xa0\xa0\xa0"), + 0xCFFFD => (isASCII) ? "\xf3\x8f\xbf\xbd" : I8_to_native("\xf8\xb9\xbf\xbf\xbd"), + 0xD0000 => (isASCII) ? "\xf3\x90\x80\x80" : I8_to_native("\xf8\xba\xa0\xa0\xa0"), + 0xDFFFD => (isASCII) ? "\xf3\x9f\xbf\xbd" : I8_to_native("\xf8\xbb\xbf\xbf\xbd"), + 0xE0000 => (isASCII) ? "\xf3\xa0\x80\x80" : I8_to_native("\xf8\xbc\xa0\xa0\xa0"), + 0xEFFFD => (isASCII) ? "\xf3\xaf\xbf\xbd" : I8_to_native("\xf8\xbd\xbf\xbf\xbd"), + 0xF0000 => (isASCII) ? "\xf3\xb0\x80\x80" : I8_to_native("\xf8\xbe\xa0\xa0\xa0"), + 0xFFFFD => (isASCII) ? "\xf3\xbf\xbf\xbd" : I8_to_native("\xf8\xbf\xbf\xbf\xbd"), + 0x100000 => (isASCII) ? "\xf4\x80\x80\x80" : I8_to_native("\xf9\xa0\xa0\xa0\xa0"), + 0x10FFFD => (isASCII) ? "\xf4\x8f\xbf\xbd" : I8_to_native("\xf9\xa1\xbf\xbf\xbd"), + 0x110000 => (isASCII) ? "\xf4\x90\x80\x80" : I8_to_native("\xf9\xa2\xa0\xa0\xa0"), + + # Things that would be noncharacters if they were in Unicode, and might be + # mistaken, if the C code is bad, to be nonchars + 0x11FFFE => (isASCII) ? "\xf4\x9f\xbf\xbe" : I8_to_native("\xf9\xa3\xbf\xbf\xbe"), + 0x11FFFF => (isASCII) ? "\xf4\x9f\xbf\xbf" : I8_to_native("\xf9\xa3\xbf\xbf\xbf"), + 0x20FFFE => (isASCII) ? "\xf8\x88\x8f\xbf\xbe" : I8_to_native("\xfa\xa1\xbf\xbf\xbe"), + 0x20FFFF => (isASCII) ? "\xf8\x88\x8f\xbf\xbf" : I8_to_native("\xfa\xa1\xbf\xbf\xbf"), + + 0x200000 - 1 => (isASCII) ? "\xf7\xbf\xbf\xbf" : I8_to_native("\xf9\xbf\xbf\xbf\xbf"), + 0x200000 => (isASCII) ? "\xf8\x88\x80\x80\x80" : I8_to_native("\xfa\xa0\xa0\xa0\xa0"), + 0x400000 - 1 => (isASCII) ? "\xf8\x8f\xbf\xbf\xbf" : I8_to_native("\xfb\xbf\xbf\xbf\xbf"), + 0x400000 => (isASCII) ? "\xf8\x90\x80\x80\x80" : I8_to_native("\xfc\xa4\xa0\xa0\xa0\xa0"), + 0x4000000 - 1 => (isASCII) ? "\xfb\xbf\xbf\xbf\xbf" : I8_to_native("\xfd\xbf\xbf\xbf\xbf\xbf"), + 0x4000000 => (isASCII) ? "\xfc\x84\x80\x80\x80\x80" : I8_to_native("\xfe\xa2\xa0\xa0\xa0\xa0\xa0"), + 0x4000000 - 1 => (isASCII) ? "\xfb\xbf\xbf\xbf\xbf" : I8_to_native("\xfd\xbf\xbf\xbf\xbf\xbf"), + 0x4000000 => (isASCII) ? "\xfc\x84\x80\x80\x80\x80" : I8_to_native("\xfe\xa2\xa0\xa0\xa0\xa0\xa0"), + 0x40000000 - 1 => (isASCII) ? "\xfc\xbf\xbf\xbf\xbf\xbf" : I8_to_native("\xfe\xbf\xbf\xbf\xbf\xbf\xbf"), + 0x40000000 => (isASCII) ? "\xfd\x80\x80\x80\x80\x80" : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0"), + 0x80000000 - 1 => (isASCII) ? "\xfd\xbf\xbf\xbf\xbf\xbf" : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa1\xbf\xbf\xbf\xbf\xbf\xbf"), + 0x80000000 => (isASCII) ? "\xfe\x82\x80\x80\x80\x80\x80" : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"), + 0xFFFFFFFF => (isASCII) ? "\xfe\x83\xbf\xbf\xbf\xbf\xbf" : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa3\xbf\xbf\xbf\xbf\xbf\xbf"), +); + +if ($is64bit) { + no warnings qw(overflow portable); + $code_points{0x100000000} = (isASCII) ? "\xfe\x84\x80\x80\x80\x80\x80" : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0"); + $code_points{0x1000000000 - 1} = (isASCII) ? "\xfe\xbf\xbf\xbf\xbf\xbf\xbf" : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa1\xbf\xbf\xbf\xbf\xbf\xbf\xbf"); + $code_points{0x1000000000} = (isASCII) ? "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80" : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0\xa0"); + $code_points{0xFFFFFFFFFFFFFFFF} = (isASCII) ? "\xff\x80\x8f\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf" : I8_to_native("\xff\xaf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"); +} + +# Now add in entries for each of code points 0-255, which require special +# handling on EBCDIC. Remember the keys are Unicode values, and the values +# are the native UTF-8. For invariants, the bytes are just the native chr. + +my $cp = 0; +while ($cp < ((isASCII) ? 128 : 160)) { # This is from the definition of + # invariant + $code_points{$cp} = chr utf8::unicode_to_native($cp); + $cp++; +} + +# Done with the invariants. Now do the variants. All in this range are 2 +# byte. Again, we can't use the internal functions to generate UTF-8, as +# those are what we are trying to test. In the loop, we know what range the +# continuation bytes can be in, and what the lowest start byte can be. So we +# cycle through them. + +my $first_continuation = (isASCII) ? 0x80 : 0xA0; +my $final_continuation = 0xBF; +my $start = (isASCII) ? 0xC2 : 0xC5; + +my $continuation = $first_continuation - 1; + +while ($cp < 255) { + if (++$continuation > $final_continuation) { + + # Wrap to the next start byte when we reach the final continuation + # byte possible + $continuation = $first_continuation; + $start++; + } + $code_points{$cp} = I8_to_native(chr($start) . chr($continuation)); + + $cp++; +} my @warnings; use warnings 'utf8'; local $SIG{__WARN__} = sub { push @warnings, @_ }; -# First test the malformations. All these raise category utf8 warnings. -foreach my $test ( +# This set of tests looks for basic sanity, and lastly tests the bottom level +# decode routine for the given code point. If the earlier tests for that code +# point fail, that one probably will too. Malformations are tested in later +# segments of code. +for my $u (sort { utf8::unicode_to_native($a) <=> utf8::unicode_to_native($b) } + keys %code_points) +{ + my $hex_u = sprintf("0x%02X", $u); + my $n = utf8::unicode_to_native($u); + my $hex_n = sprintf("0x%02X", $n); + my $bytes = $code_points{$u}; + + my $offskip_should_be; + { + no warnings qw(overflow portable); + $offskip_should_be = (isASCII) + ? ( $u < 0x80 ? 1 : + $u < 0x800 ? 2 : + $u < 0x10000 ? 3 : + $u < 0x200000 ? 4 : + $u < 0x4000000 ? 5 : + $u < 0x80000000 ? 6 : (($is64bit) + ? ($u < 0x1000000000 ? 7 : 13) + : 7) + ) + : ($u < 0xA0 ? 1 : + $u < 0x400 ? 2 : + $u < 0x4000 ? 3 : + $u < 0x40000 ? 4 : + $u < 0x400000 ? 5 : + $u < 0x4000000 ? 6 : + $u < 0x40000000 ? 7 : 14 ); + } + + # If this test fails, subsequent ones are meaningless. + next unless is(test_OFFUNISKIP($u), $offskip_should_be, + "Verify OFFUNISKIP($hex_u) is $offskip_should_be"); + my $invariant = $offskip_should_be == 1; + my $display_invariant = $invariant || 0; + is(test_OFFUNI_IS_INVARIANT($u), $invariant, + "Verify OFFUNI_IS_INVARIANT($hex_u) is $display_invariant"); + + my $uvchr_skip_should_be = $offskip_should_be; + next unless is(test_UVCHR_SKIP($n), $uvchr_skip_should_be, + "Verify UVCHR_SKIP($hex_n) is $uvchr_skip_should_be"); + is(test_UVCHR_IS_INVARIANT($n), $offskip_should_be == 1, + "Verify UVCHR_IS_INVARIANT($hex_n) is $display_invariant"); + + my $n_chr = chr $n; + utf8::upgrade $n_chr; + + is(test_UTF8_SKIP($n_chr), $uvchr_skip_should_be, + "Verify UTF8_SKIP(chr $hex_n) is $uvchr_skip_should_be"); + + use bytes; + for (my $j = 0; $j < length $n_chr; $j++) { + my $b = substr($n_chr, $j, 1); + my $hex_b = sprintf("\"\\x%02x\"", ord $b); + + my $byte_invariant = $j == 0 && $uvchr_skip_should_be == 1; + my $display_byte_invariant = $byte_invariant || 0; + next unless is(test_UTF8_IS_INVARIANT($b), $byte_invariant, + " Verify UTF8_IS_INVARIANT($hex_b) for byte $j " + . "is $display_byte_invariant"); + + my $is_start = $j == 0 && $uvchr_skip_should_be > 1; + my $display_is_start = $is_start || 0; + next unless is(test_UTF8_IS_START($b), $is_start, + " Verify UTF8_IS_START($hex_b) is $display_is_start"); + + my $is_continuation = $j != 0 && $uvchr_skip_should_be > 1; + my $display_is_continuation = $is_continuation || 0; + next unless is(test_UTF8_IS_CONTINUATION($b), $is_continuation, + " Verify UTF8_IS_CONTINUATION($hex_b) is " + . "$display_is_continuation"); + + my $is_continued = $uvchr_skip_should_be > 1; + my $display_is_continued = $is_continued || 0; + next unless is(test_UTF8_IS_CONTINUED($b), $is_continued, + " Verify UTF8_IS_CONTINUED($hex_b) is " + . "$display_is_continued"); + + my $is_downgradeable_start = $n < 256 + && $uvchr_skip_should_be > 1 + && $j == 0; + my $display_is_downgradeable_start = $is_downgradeable_start || 0; + next unless is(test_UTF8_IS_DOWNGRADEABLE_START($b), + $is_downgradeable_start, + " Verify UTF8_IS_DOWNGRADEABLE_START($hex_b) is " + . "$display_is_downgradeable_start"); + + my $is_above_latin1 = $n > 255 && $j == 0; + my $display_is_above_latin1 = $is_above_latin1 || 0; + next unless is(test_UTF8_IS_ABOVE_LATIN1($b), + $is_above_latin1, + " Verify UTF8_IS_ABOVE_LATIN1($hex_b) is " + . "$display_is_above_latin1"); + + my $is_possibly_problematic = $j == 0 + && $n >= ((isASCII) + ? 0xD000 + : 0x8000); + my $display_is_possibly_problematic = $is_possibly_problematic || 0; + next unless is(test_isUTF8_POSSIBLY_PROBLEMATIC($b), + $is_possibly_problematic, + " Verify isUTF8_POSSIBLY_PROBLEMATIC($hex_b) is " + . "$display_is_above_latin1"); + } + + # We are not trying to look for warnings, etc, so if they should occur, it + # is an error. But some of the code points here do cause warnings, so we + # check here and turn off the ones that apply to such code points. A + # later section of the code tests for these kinds of things. + my $this_utf8_flags = $look_for_everything_utf8n_to; + my $len = length $bytes; + if ($n > 2 ** 31 - 1) { + $this_utf8_flags &= + ~($UTF8_DISALLOW_ABOVE_31_BIT|$UTF8_WARN_ABOVE_31_BIT); + } + if ($n > 0x10FFFF) { + $this_utf8_flags &= ~($UTF8_DISALLOW_SUPER|$UTF8_WARN_SUPER); + } + elsif (($n & 0xFFFE) == 0xFFFE) { + $this_utf8_flags &= ~($UTF8_DISALLOW_NONCHAR|$UTF8_WARN_NONCHAR); + } + + undef @warnings; + + my $display_flags = sprintf "0x%x", $this_utf8_flags; + my $ret_ref = test_utf8n_to_uvchr($bytes, $len, $this_utf8_flags); + my $display_bytes = display_bytes($bytes); + is($ret_ref->[0], $n, "Verify utf8n_to_uvchr($display_bytes, $display_flags) returns $hex_n"); + is($ret_ref->[1], $len, "Verify utf8n_to_uvchr() for $hex_n returns expected length"); + + unless (is(scalar @warnings, 0, + "Verify utf8n_to_uvchr() for $hex_n generated no warnings")) + { + diag "The warnings were: " . join(", ", @warnings); + } + + undef @warnings; + + $ret_ref = test_valid_utf8_to_uvchr($bytes); + is($ret_ref->[0], $n, "Verify valid_utf8_to_uvchr($display_bytes) returns $hex_n"); + is($ret_ref->[1], $len, "Verify valid_utf8_to_uvchr() for $hex_n returns expected length"); + + unless (is(scalar @warnings, 0, + "Verify valid_utf8_to_uvchr() for $hex_n generated no warnings")) + { + diag "The warnings were: " . join(", ", @warnings); + } + + # Similarly for uvchr_to_utf8 + my $this_uvchr_flags = $look_for_everything_uvchr_to; + if ($n > 2 ** 31 - 1) { + $this_uvchr_flags &= + ~($UNICODE_DISALLOW_ABOVE_31_BIT|$UNICODE_WARN_ABOVE_31_BIT); + } + if ($n > 0x10FFFF) { + $this_uvchr_flags &= ~($UNICODE_DISALLOW_SUPER|$UNICODE_WARN_SUPER); + } + elsif (($n & 0xFFFE) == 0xFFFE) { + $this_uvchr_flags &= ~($UNICODE_DISALLOW_NONCHAR|$UNICODE_WARN_NONCHAR); + } + $display_flags = sprintf "0x%x", $this_uvchr_flags; + + undef @warnings; + + my $ret = test_uvchr_to_utf8_flags($n, $this_uvchr_flags); + ok(defined $ret, "Verify uvchr_to_utf8_flags($hex_n, $display_flags) returned success"); + is($ret, $bytes, "Verify uvchr_to_utf8_flags($hex_n, $display_flags) returns correct bytes"); + + unless (is(scalar @warnings, 0, + "Verify uvchr_to_utf8_flags($hex_n, $display_flags) for $hex_n generated no warnings")) + { + diag "The warnings were: " . join(", ", @warnings); + } +} + +my $REPLACEMENT = 0xFFFD; + +# Now test the malformations. All these raise category utf8 warnings. +my $c = (isASCII) ? "\x80" : "\xa0"; # A continuation byte +my @malformations = ( [ "zero length string malformation", "", 0, $UTF8_ALLOW_EMPTY, 0, 0, qr/empty string/ ], - [ "orphan continuation byte malformation", "\x80a", 2, + [ "orphan continuation byte malformation", I8_to_native("${c}a"), + 2, $UTF8_ALLOW_CONTINUATION, $REPLACEMENT, 1, qr/unexpected continuation byte/ ], - [ "premature next character malformation (immediate)", "\xc2a", 2, + [ "premature next character malformation (immediate)", + (isASCII) ? "\xc2a" : I8_to_native("\xc5") ."a", + 2, $UTF8_ALLOW_NON_CONTINUATION, $REPLACEMENT, 1, qr/unexpected non-continuation byte.*immediately after start byte/ ], - [ "premature next character malformation (non-immediate)", "\xf0\x80a", 3, + [ "premature next character malformation (non-immediate)", + I8_to_native("\xf0${c}a"), + 3, $UTF8_ALLOW_NON_CONTINUATION, $REPLACEMENT, 2, qr/unexpected non-continuation byte .* 2 bytes after start byte/ ], - [ "too short malformation", "\xf0\x80a", 2, + [ "too short malformation", I8_to_native("\xf0${c}a"), 2, # Having the 'a' after this, but saying there are only 2 bytes also # tests that we pay attention to the passed in length $UTF8_ALLOW_SHORT, $REPLACEMENT, 2, qr/2 bytes, need 4/ ], - [ "overlong malformation", "\xc1\xaf", 2, - $UTF8_ALLOW_LONG, ord('o'), 2, + [ "overlong malformation", I8_to_native("\xc0$c"), 2, + $UTF8_ALLOW_LONG, + 0, # NUL + 2, qr/2 bytes, need 1/ ], - [ "overflow malformation", "\xff\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf", 13, + [ "overflow malformation", + # These are the smallest overflowing on 64 byte machines: + # 2**64 + (isASCII) ? "\xff\x80\x90\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0" + : I8_to_native("\xff\xB0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"), + (isASCII) ? 13 : 14, 0, # There is no way to allow this malformation - $REPLACEMENT, 13, + $REPLACEMENT, + (isASCII) ? 13 : 14, qr/overflow/ ], -) { +); + +foreach my $test (@malformations) { my ($testname, $bytes, $length, $allow_flags, $allowed_uv, $expected_len, $message ) = @$test; next if ! ok(length($bytes) >= $length, "$testname: Make sure won't read beyond buffer: " . length($bytes) . " >= $length"); @@ -97,7 +507,7 @@ foreach my $test ( } else { if (scalar @warnings) { - note "The warnings were: " . join(", ", @warnings); + diag "The warnings were: " . join(", ", @warnings); } } @@ -108,7 +518,7 @@ foreach my $test ( is($ret_ref->[0], 0, "$testname: disallowed: no warnings 'utf8': Returns 0"); is($ret_ref->[1], $expected_len, "$testname: disallowed: no warnings 'utf8': Returns expected length"); if (!is(scalar @warnings, 0, "$testname: disallowed: no warnings 'utf8': no warnings generated")) { - note "The warnings were: " . join(", ", @warnings); + diag "The warnings were: " . join(", ", @warnings); } } @@ -118,7 +528,7 @@ foreach my $test ( is($ret_ref->[0], 0, "$testname: CHECK_ONLY: Returns 0"); is($ret_ref->[1], -1, "$testname: CHECK_ONLY: returns expected length"); if (! is(scalar @warnings, 0, "$testname: CHECK_ONLY: no warnings generated")) { - note "The warnings were: " . join(", ", @warnings); + diag "The warnings were: " . join(", ", @warnings); } next if $allow_flags == 0; # Skip if can't allow this malformation @@ -130,67 +540,348 @@ foreach my $test ( is($ret_ref->[1], $expected_len, "$testname: allowed: Returns expected length"); if (!is(scalar @warnings, 0, "$testname: allowed: no warnings generated")) { - note "The warnings were: " . join(", ", @warnings); + diag "The warnings were: " . join(", ", @warnings); } } -my $FF_ret; - -use Unicode::UCD; -my $has_quad = ($Unicode::UCD::MAX_CP > 0xFFFF_FFFF); -if ($has_quad) { - no warnings qw{portable overflow}; - $FF_ret = 0x1000000000; -} -else { # The above overflows unless a quad platform - $FF_ret = 0; -} - # Now test the cases where a legal code point is generated, but may or may not # be allowed/warned on. my @tests = ( - [ "surrogate", "\xed\xa4\x8d", - $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE, 'surrogate', 0xD90D, 3, + [ "lowest surrogate", + (isASCII) ? "\xed\xa0\x80" : I8_to_native("\xf1\xb6\xa0\xa0"), + $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE, + 'surrogate', 0xD800, + (isASCII) ? 3 : 4, qr/surrogate/ ], - [ "non_unicode", "\xf4\x90\x80\x80", - $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER, 'non_unicode', 0x110000, 4, - qr/not Unicode/ + [ "a middle surrogate", + (isASCII) ? "\xed\xa4\x8d" : I8_to_native("\xf1\xb6\xa8\xad"), + $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE, + 'surrogate', 0xD90D, + (isASCII) ? 3 : 4, + qr/surrogate/ ], - [ "non-character code point", "\xEF\xB7\x90", - $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, 'nonchar', 0xFDD0, 3, - qr/Unicode non-character.*is illegal for open interchange/ + [ "highest surrogate", + (isASCII) ? "\xed\xbf\xbf" : I8_to_native("\xf1\xb7\xbf\xbf"), + $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE, + 'surrogate', 0xDFFF, + (isASCII) ? 3 : 4, + qr/surrogate/ ], - [ "begins with FE", "\xfe\x82\x80\x80\x80\x80\x80", - + [ "first non_unicode", + (isASCII) ? "\xf4\x90\x80\x80" : I8_to_native("\xf9\xa2\xa0\xa0\xa0"), + $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER, + 'non_unicode', 0x110000, + (isASCII) ? 4 : 5, + qr/not Unicode.* may not be portable/ + ], + [ "first of 32 consecutive non-character code points", + (isASCII) ? "\xef\xb7\x90" : I8_to_native("\xf1\xbf\xae\xb0"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0xFDD0, + (isASCII) ? 3 : 4, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "a mid non-character code point of the 32 consecutive ones", + (isASCII) ? "\xef\xb7\xa0" : I8_to_native("\xf1\xbf\xaf\xa0"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0xFDE0, + (isASCII) ? 3 : 4, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "final of 32 consecutive non-character code points", + (isASCII) ? "\xef\xb7\xaf" : I8_to_native("\xf1\xbf\xaf\xaf"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0xFDEF, + (isASCII) ? 3 : 4, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+FFFE", + (isASCII) ? "\xef\xbf\xbe" : I8_to_native("\xf1\xbf\xbf\xbe"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0xFFFE, + (isASCII) ? 3 : 4, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+FFFF", + (isASCII) ? "\xef\xbf\xbf" : I8_to_native("\xf1\xbf\xbf\xbf"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0xFFFF, + (isASCII) ? 3 : 4, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+1FFFE", + (isASCII) ? "\xf0\x9f\xbf\xbe" : I8_to_native("\xf3\xbf\xbf\xbe"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0x1FFFE, 4, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+1FFFF", + (isASCII) ? "\xf0\x9f\xbf\xbf" : I8_to_native("\xf3\xbf\xbf\xbf"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0x1FFFF, 4, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+2FFFE", + (isASCII) ? "\xf0\xaf\xbf\xbe" : I8_to_native("\xf5\xbf\xbf\xbe"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0x2FFFE, 4, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+2FFFF", + (isASCII) ? "\xf0\xaf\xbf\xbf" : I8_to_native("\xf5\xbf\xbf\xbf"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0x2FFFF, 4, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+3FFFE", + (isASCII) ? "\xf0\xbf\xbf\xbe" : I8_to_native("\xf7\xbf\xbf\xbe"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0x3FFFE, 4, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+3FFFF", + (isASCII) ? "\xf0\xbf\xbf\xbf" : I8_to_native("\xf7\xbf\xbf\xbf"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0x3FFFF, 4, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+4FFFE", + (isASCII) ? "\xf1\x8f\xbf\xbe" : I8_to_native("\xf8\xa9\xbf\xbf\xbe"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0x4FFFE, + (isASCII) ? 4 : 5, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+4FFFF", + (isASCII) ? "\xf1\x8f\xbf\xbf" : I8_to_native("\xf8\xa9\xbf\xbf\xbf"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0x4FFFF, + (isASCII) ? 4 : 5, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+5FFFE", + (isASCII) ? "\xf1\x9f\xbf\xbe" : I8_to_native("\xf8\xab\xbf\xbf\xbe"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0x5FFFE, + (isASCII) ? 4 : 5, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+5FFFF", + (isASCII) ? "\xf1\x9f\xbf\xbf" : I8_to_native("\xf8\xab\xbf\xbf\xbf"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0x5FFFF, + (isASCII) ? 4 : 5, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+6FFFE", + (isASCII) ? "\xf1\xaf\xbf\xbe" : I8_to_native("\xf8\xad\xbf\xbf\xbe"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0x6FFFE, + (isASCII) ? 4 : 5, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+6FFFF", + (isASCII) ? "\xf1\xaf\xbf\xbf" : I8_to_native("\xf8\xad\xbf\xbf\xbf"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0x6FFFF, + (isASCII) ? 4 : 5, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+7FFFE", + (isASCII) ? "\xf1\xbf\xbf\xbe" : I8_to_native("\xf8\xaf\xbf\xbf\xbe"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0x7FFFE, + (isASCII) ? 4 : 5, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+7FFFF", + (isASCII) ? "\xf1\xbf\xbf\xbf" : I8_to_native("\xf8\xaf\xbf\xbf\xbf"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0x7FFFF, + (isASCII) ? 4 : 5, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+8FFFE", + (isASCII) ? "\xf2\x8f\xbf\xbe" : I8_to_native("\xf8\xb1\xbf\xbf\xbe"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0x8FFFE, + (isASCII) ? 4 : 5, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+8FFFF", + (isASCII) ? "\xf2\x8f\xbf\xbf" : I8_to_native("\xf8\xb1\xbf\xbf\xbf"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0x8FFFF, + (isASCII) ? 4 : 5, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+9FFFE", + (isASCII) ? "\xf2\x9f\xbf\xbe" : I8_to_native("\xf8\xb3\xbf\xbf\xbe"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0x9FFFE, + (isASCII) ? 4 : 5, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+9FFFF", + (isASCII) ? "\xf2\x9f\xbf\xbf" : I8_to_native("\xf8\xb3\xbf\xbf\xbf"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0x9FFFF, + (isASCII) ? 4 : 5, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+AFFFE", + (isASCII) ? "\xf2\xaf\xbf\xbe" : I8_to_native("\xf8\xb5\xbf\xbf\xbe"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0xAFFFE, + (isASCII) ? 4 : 5, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+AFFFF", + (isASCII) ? "\xf2\xaf\xbf\xbf" : I8_to_native("\xf8\xb5\xbf\xbf\xbf"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0xAFFFF, + (isASCII) ? 4 : 5, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+BFFFE", + (isASCII) ? "\xf2\xbf\xbf\xbe" : I8_to_native("\xf8\xb7\xbf\xbf\xbe"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0xBFFFE, + (isASCII) ? 4 : 5, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+BFFFF", + (isASCII) ? "\xf2\xbf\xbf\xbf" : I8_to_native("\xf8\xb7\xbf\xbf\xbf"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0xBFFFF, + (isASCII) ? 4 : 5, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+CFFFE", + (isASCII) ? "\xf3\x8f\xbf\xbe" : I8_to_native("\xf8\xb9\xbf\xbf\xbe"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0xCFFFE, + (isASCII) ? 4 : 5, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+CFFFF", + (isASCII) ? "\xf3\x8f\xbf\xbf" : I8_to_native("\xf8\xb9\xbf\xbf\xbf"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0xCFFFF, + (isASCII) ? 4 : 5, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+DFFFE", + (isASCII) ? "\xf3\x9f\xbf\xbe" : I8_to_native("\xf8\xbb\xbf\xbf\xbe"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0xDFFFE, + (isASCII) ? 4 : 5, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+DFFFF", + (isASCII) ? "\xf3\x9f\xbf\xbf" : I8_to_native("\xf8\xbb\xbf\xbf\xbf"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0xDFFFF, + (isASCII) ? 4 : 5, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+EFFFE", + (isASCII) ? "\xf3\xaf\xbf\xbe" : I8_to_native("\xf8\xbd\xbf\xbf\xbe"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0xEFFFE, + (isASCII) ? 4 : 5, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+EFFFF", + (isASCII) ? "\xf3\xaf\xbf\xbf" : I8_to_native("\xf8\xbd\xbf\xbf\xbf"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0xEFFFF, + (isASCII) ? 4 : 5, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+FFFFE", + (isASCII) ? "\xf3\xbf\xbf\xbe" : I8_to_native("\xf8\xbf\xbf\xbf\xbe"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0xFFFFE, + (isASCII) ? 4 : 5, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+FFFFF", + (isASCII) ? "\xf3\xbf\xbf\xbf" : I8_to_native("\xf8\xbf\xbf\xbf\xbf"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0xFFFFF, + (isASCII) ? 4 : 5, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+10FFFE", + (isASCII) ? "\xf4\x8f\xbf\xbe" : I8_to_native("\xf9\xa1\xbf\xbf\xbe"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0x10FFFE, + (isASCII) ? 4 : 5, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "non-character code point U+10FFFF", + (isASCII) ? "\xf4\x8f\xbf\xbf" : I8_to_native("\xf9\xa1\xbf\xbf\xbf"), + $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, + 'nonchar', 0x10FFFF, + (isASCII) ? 4 : 5, + qr/Unicode non-character.*is not recommended for open interchange/ + ], + [ "requires at least 32 bits", + (isASCII) + ? "\xfe\x82\x80\x80\x80\x80\x80" + : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"), # This code point is chosen so that it is representable in a UV on # 32-bit machines - $UTF8_WARN_FE_FF, $UTF8_DISALLOW_FE_FF, 'utf8', 0x80000000, 7, + $UTF8_WARN_ABOVE_31_BIT, $UTF8_DISALLOW_ABOVE_31_BIT, + 'utf8', 0x80000000, (isASCII) ? 7 :14, + qr/Code point 0x80000000 is not Unicode, and not portable/ + ], + [ "requires at least 32 bits, and use SUPER-type flags, instead of ABOVE_31_BIT", + (isASCII) + ? "\xfe\x82\x80\x80\x80\x80\x80" + : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"), + $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER, + 'utf8', 0x80000000, (isASCII) ? 7 :14, qr/Code point 0x80000000 is not Unicode, and not portable/ ], - [ "overflow with FE/FF", - # This tests the interaction of WARN_FE_FF/DISALLOW_FE_FF with - # overflow. The overflow malformation is never allowed, so preventing - # it takes precedence if the FE_FF options would otherwise allow in an - # overflowing value. These two code points (1 for 32-bits; 1 for 64) - # were chosen because the old overflow detection algorithm did not - # catch them; this means this test also checks for that fix. - ($has_quad) - ? "\xff\x80\x90\x90\x90\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf" - : "\xfe\x86\x80\x80\x80\x80\x80", - - # We include both warning categories to make sure the FE_FF one has - # precedence - "$UTF8_WARN_FE_FF|$UTF8_WARN_SUPER", "$UTF8_DISALLOW_FE_FF", 'utf8', 0, - ($has_quad) ? 13 : 7, + [ "overflow with warnings/disallow for more than 31 bits", + # This tests the interaction of WARN_ABOVE_31_BIT/DISALLOW_ABOVE_31_BIT + # with overflow. The overflow malformation is never allowed, so + # preventing it takes precedence if the ABOVE_31_BIT options would + # otherwise allow in an overflowing value. The ASCII code points (1 + # for 32-bits; 1 for 64) were chosen because the old overflow + # detection algorithm did not catch them; this means this test also + # checks for that fix. The EBCDIC are arbitrary overflowing ones + # since we have no reports of failures with it. + (($is64bit) + ? ((isASCII) + ? "\xff\x80\x90\x90\x90\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf" + : I8_to_native("\xff\xB0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0")) + : ((isASCII) + ? "\xfe\x86\x80\x80\x80\x80\x80" + : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0"))), + + # We include both warning categories to make sure the ABOVE_31_BIT one + # has precedence + "$UTF8_WARN_ABOVE_31_BIT|$UTF8_WARN_SUPER", + "$UTF8_DISALLOW_ABOVE_31_BIT", + 'utf8', 0, + (! isASCII) ? 14 : ($is64bit) ? 13 : 7, qr/overflow at byte .*, after start byte 0xf/ ], ); -if ($has_quad) { # All FF's will overflow on 32 bit +if ($is64bit) { + no warnings qw{portable overflow}; push @tests, - [ "begins with FF", "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80", - $UTF8_WARN_FE_FF, $UTF8_DISALLOW_FE_FF, 'utf8', $FF_ret, 13, + [ "More than 32 bits", + (isASCII) + ? "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80" + : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0\xa0"), + $UTF8_WARN_ABOVE_31_BIT, $UTF8_DISALLOW_ABOVE_31_BIT, + 'utf8', 0x1000000000, (isASCII) ? 13 : 14, qr/Code point 0x.* is not Unicode, and not portable/ ]; } @@ -213,18 +904,18 @@ foreach my $test (@tests) { my $eval_warn = $do_warning ? "use warnings '$warning'" : $warning eq "utf8" - ? "no warnings 'utf8'" - : "use warnings 'utf8'; no warnings '$warning'"; + ? "no warnings 'utf8'" + : "use warnings 'utf8'; no warnings '$warning'"; # is effectively disallowed if will overflow, even if the # flag indicates it is allowed, fix up test name to # indicate this as well my $disallowed = $disallow_flag || $will_overflow; - my $this_name = "$testname: " . (($disallow_flag) + my $this_name = "utf8n_to_uvchr() $testname: " . (($disallow_flag) ? 'disallowed' : ($disallowed) - ? 'FE_FF allowed' + ? 'ABOVE_31_BIT allowed' : 'allowed'); $this_name .= ", $eval_warn"; $this_name .= ", " . (($warn_flag) @@ -233,22 +924,32 @@ foreach my $test (@tests) { undef @warnings; my $ret_ref; - #note __LINE__ . ": $eval_warn; \$ret_ref = test_utf8n_to_uvchr('$bytes', $length, $warn_flag|$disallow_flag)"; - my $eval_text = "$eval_warn; \$ret_ref = test_utf8n_to_uvchr('$bytes', $length, $warn_flag|$disallow_flag)"; + my $display_bytes = display_bytes($bytes); + my $call = "Call was: $eval_warn; \$ret_ref = test_utf8n_to_uvchr('$display_bytes', $length, $warn_flag|$disallow_flag)"; + my $eval_text = "$eval_warn; \$ret_ref = test_utf8n_to_uvchr('$bytes', $length, $warn_flag|$disallow_flag)"; eval "$eval_text"; if (! ok ("$@ eq ''", "$this_name: eval succeeded")) { - note "\$!='$!'; eval'd=\"$eval_text\""; + diag "\$!='$!'; eval'd=\"$call\""; next; } if ($disallowed) { - is($ret_ref->[0], 0, "$this_name: Returns 0"); + unless (is($ret_ref->[0], 0, "$this_name: Returns 0")) + { + diag $call; + } } else { - is($ret_ref->[0], $allowed_uv, - "$this_name: Returns expected uv"); + unless (is($ret_ref->[0], $allowed_uv, + "$this_name: Returns expected uv")) + { + diag $call; + } + } + unless (is($ret_ref->[1], $expected_len, + "$this_name: Returns expected length")) + { + diag $call; } - is($ret_ref->[1], $expected_len, - "$this_name: Returns expected length"); if (! $do_warning && ($warning eq 'utf8' || $warning eq $category)) @@ -256,7 +957,8 @@ foreach my $test (@tests) { if (!is(scalar @warnings, 0, "$this_name: No warnings generated")) { - note "The warnings were: " . join(", ", @warnings); + diag $call; + diag "The warnings were: " . join(", ", @warnings); } } elsif ($will_overflow @@ -271,12 +973,16 @@ foreach my $test (@tests) { if (is(scalar @warnings, 1, "$this_name: Got a single warning ")) { - like($warnings[0], qr/overflow/, - "$this_name: Got overflow warning"); + unless (like($warnings[0], qr/overflow/, + "$this_name: Got overflow warning")) + { + diag $call; + } } else { + diag $call; if (scalar @warnings) { - note "The warnings were: " + diag "The warnings were: " . join(", ", @warnings); } } @@ -287,12 +993,16 @@ foreach my $test (@tests) { if (is(scalar @warnings, 1, "$this_name: Got a single warning ")) { - like($warnings[0], $message, - "$this_name: Got expected warning"); + unless (like($warnings[0], $message, + "$this_name: Got expected warning")) + { + diag $call; + } } else { + diag $call; if (scalar @warnings) { - note "The warnings were: " + diag "The warnings were: " . join(", ", @warnings); } } @@ -305,13 +1015,134 @@ foreach my $test (@tests) { undef @warnings; $ret_ref = test_utf8n_to_uvchr($bytes, $length, $disallow_flag|$UTF8_CHECK_ONLY); - is($ret_ref->[0], 0, "$this_name, CHECK_ONLY: Returns 0"); - is($ret_ref->[1], -1, - "$this_name: CHECK_ONLY: returns expected length"); + unless (is($ret_ref->[0], 0, "$this_name, CHECK_ONLY: Returns 0")) { + diag $call; + } + unless (is($ret_ref->[1], -1, + "$this_name: CHECK_ONLY: returns expected length")) + { + diag $call; + } if (! is(scalar @warnings, 0, "$this_name, CHECK_ONLY: no warnings generated")) { - note "The warnings were: " . join(", ", @warnings); + diag $call; + diag "The warnings were: " . join(", ", @warnings); + } + } + + # Now repeat some of the above, but for + # uvchr_to_utf8_flags(). Since this comes from an + # existing code point, it hasn't overflowed. + next if $will_overflow; + + # The warning and disallow flags passed in are for + # utf8n_to_uvchr(). Convert them for + # uvchr_to_utf8_flags(). + my $uvchr_warn_flag = 0; + my $uvchr_disallow_flag = 0; + if ($warn_flag) { + if ($warn_flag == $UTF8_WARN_SURROGATE) { + $uvchr_warn_flag = $UNICODE_WARN_SURROGATE + } + elsif ($warn_flag == $UTF8_WARN_NONCHAR) { + $uvchr_warn_flag = $UNICODE_WARN_NONCHAR + } + elsif ($warn_flag == $UTF8_WARN_SUPER) { + $uvchr_warn_flag = $UNICODE_WARN_SUPER + } + elsif ($warn_flag == $UTF8_WARN_ABOVE_31_BIT) { + $uvchr_warn_flag = $UNICODE_WARN_ABOVE_31_BIT; + } + else { + fail(sprintf "Unexpected warn flag: %x", + $warn_flag); + next; + } + } + if ($disallow_flag) { + if ($disallow_flag == $UTF8_DISALLOW_SURROGATE) { + $uvchr_disallow_flag = $UNICODE_DISALLOW_SURROGATE + } + elsif ($disallow_flag == $UTF8_DISALLOW_NONCHAR) { + $uvchr_disallow_flag = $UNICODE_DISALLOW_NONCHAR + } + elsif ($disallow_flag == $UTF8_DISALLOW_SUPER) { + $uvchr_disallow_flag = $UNICODE_DISALLOW_SUPER + } + elsif ($disallow_flag == $UTF8_DISALLOW_ABOVE_31_BIT) { + $uvchr_disallow_flag = + $UNICODE_DISALLOW_ABOVE_31_BIT; + } + else { + fail(sprintf "Unexpected disallow flag: %x", + $disallow_flag); + next; + } + } + + $disallowed = $uvchr_disallow_flag; + + $this_name = "uvchr_to_utf8_flags() $testname: " + . (($uvchr_disallow_flag) + ? 'disallowed' + : ($disallowed) + ? 'ABOVE_31_BIT allowed' + : 'allowed'); + $this_name .= ", $eval_warn"; + $this_name .= ", " . (($uvchr_warn_flag) + ? 'with warning flag' + : 'no warning flag'); + + undef @warnings; + my $ret; + my $warn_flag = sprintf "0x%x", $uvchr_warn_flag; + my $disallow_flag = sprintf "0x%x", $uvchr_disallow_flag; + $call = sprintf "call was: $eval_warn; \$ret = test_uvchr_to_utf8_flags(0x%x, $warn_flag|$disallow_flag)", $allowed_uv; + $eval_text = "$eval_warn; \$ret = test_uvchr_to_utf8_flags($allowed_uv, $warn_flag|$disallow_flag)"; + eval "$eval_text"; + if (! ok ("$@ eq ''", "$this_name: eval succeeded")) { + diag "\$!='$!'; eval'd=\"$eval_text\""; + next; + } + if ($disallowed) { + unless (is($ret, undef, "$this_name: Returns undef")) { + diag $call; + } + } + else { + unless (is($ret, $bytes, "$this_name: Returns expected string")) { + diag $call; + } + } + if (! $do_warning + && ($warning eq 'utf8' || $warning eq $category)) + { + if (!is(scalar @warnings, 0, + "$this_name: No warnings generated")) + { + diag $call; + diag "The warnings were: " . join(", ", @warnings); + } + } + elsif ($uvchr_warn_flag + && ($warning eq 'utf8' || $warning eq $category)) + { + if (is(scalar @warnings, 1, + "$this_name: Got a single warning ")) + { + unless (like($warnings[0], $message, + "$this_name: Got expected warning")) + { + diag $call; + } + } + else { + diag $call; + if (scalar @warnings) { + diag "The warnings were: " + . join(", ", @warnings); + } } } } diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/weaken.t b/gnu/usr.bin/perl/ext/XS-APItest/t/weaken.t new file mode 100644 index 00000000000..82659a5da70 --- /dev/null +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/weaken.t @@ -0,0 +1,52 @@ +#!perl + +use strict; +use warnings; + +use Test::More tests => 7; + +use_ok('XS::APItest'); + +# test sv_rvweaken() and sv_get_backrefs() +# +# weaken() maps to sv_rvweaken() and is the same as the one +# from Scalar::Utils - we recreate it in XS::APItest so +# we can test it even if we build without Scalar::Utils +# +# has_backrefs() maps to sv_get_backrefs(), which would not +# normally be useful to Perl code. (Er, maybe :-) + +# has_backrefs is really an internal routine +# which would not normally have to worry about refs +# and things like that, but to use it from perl we cant +# have an AV/HV without having an RV wrapping it, so we +# mandate the ref always. + +my $foo= "foo"; +my $bar= "bar"; + +my $scalar_ref= \$foo; +my $array_ref= [ qw(this is an array) ]; +my $hash_ref= { this => is => a => 'hash' }; + +my $nrml_scalar_ref= \$bar; +my $nrml_array_ref= [ qw( this is an array ) ]; +my $nrml_hash_ref= { this => is => a => 'hash' }; + +# we could probably do other tests here, such as +# verify the refcount of the referents, but maybe +# another day. +apitest_weaken(my $weak_scalar_ref= $scalar_ref); +apitest_weaken(my $weak_array_ref= $array_ref); +apitest_weaken(my $weak_hash_ref= $hash_ref); + +ok(has_backrefs($scalar_ref), "scalar with backrefs"); +ok(has_backrefs($array_ref), "array with backrefs"); +ok(has_backrefs($hash_ref), "hash with backrefs"); + +ok(!has_backrefs($nrml_scalar_ref), "scalar without backrefs"); +ok(!has_backrefs($nrml_array_ref), "array without backrefs"); +ok(!has_backrefs($nrml_hash_ref), "hash without backrefs"); + +1; + diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/win32.t b/gnu/usr.bin/perl/ext/XS-APItest/t/win32.t new file mode 100644 index 00000000000..fdd794a0433 --- /dev/null +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/win32.t @@ -0,0 +1,48 @@ +#!perl -w +use strict; +use Test::More; +use XS::APItest; +use Config; + +plan skip_all => "Tests only apply on MSWin32" + unless $^O eq "MSWin32"; + +SKIP: +{ + # [perl #126755] previous the bad drive tests would crash + $Config{ccflags} =~ /(?:\A|\s)-DPERL_IMPLICIT_SYS\b/ + or skip "need implicit_sys for this test", 1; + eval "use Encode; 1" + or skip "Can't load Encode", 1; + for my $letter ("A" .. "Z", "a" .. "z") { + my $good_drive = $letter . ":"; + my $result = PerlDir_mapA($good_drive); + like($result, qr/^$letter:\\/i, "check good drive $letter"); + + my $wgood_drive = encode("UTF-16LE", $good_drive . "\0"); + $result = PerlDir_mapW($wgood_drive); + like(decode("UTF16-LE", $result), qr/^$letter:\\/i, + "check a good drive (wide)"); + } + for my $bad ('@', '[', '!', '~', '`', '{') { + my $bad_drive = "$bad:"; + my $result = PerlDir_mapA($bad_drive); + is($result, $bad_drive, "check bad drive $bad:"); + + my $wbad_drive = encode("UTF-16LE", $bad_drive . "\0"); + $result = PerlDir_mapW($wbad_drive); + is(decode("UTF16-LE", $result), "$bad_drive\0", + "check bad drive $bad: (wide)"); + } + require Win32; + my (undef, $major, $minor)= Win32::GetOSVersion(); + if ($major >= 5 && $minor >= 1) { #atleast XP, 2K only has V5 + #this is testing the current state of things, specifically manifest stuff + #this test can be changed if perls relationship to comctl32.dll changes + my @ccver = Comctl32Version(); + cmp_ok($ccver[0], '>=', 6, "comctl32.dll is atleast version 6") + or diag "comctl32 version is (@ccver)"; + } +} + +done_testing(); diff --git a/gnu/usr.bin/perl/ext/XS-APItest/t/xsub_h.t b/gnu/usr.bin/perl/ext/XS-APItest/t/xsub_h.t index 9bf0710fa2e..e7631305259 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/t/xsub_h.t +++ b/gnu/usr.bin/perl/ext/XS-APItest/t/xsub_h.t @@ -120,4 +120,35 @@ is(eval {XS_APIVERSION_invalid("Pie"); 1}, undef, like($@, qr/Perl API version v1.0.16 of Pie does not match v5\.\d+\.\d+/, "expected error"); +my @xsreturn; +@xsreturn = XS::APItest::XSUB::xsreturn(2); +is scalar @xsreturn, 2, 'returns a list of 2 elements'; +is $xsreturn[0], 0; +is $xsreturn[1], 1; + +my $xsreturn = XS::APItest::XSUB::xsreturn(3); +is $xsreturn, 2, 'returns the last item on the stack'; + +( $xsreturn ) = XS::APItest::XSUB::xsreturn(3); +is $xsreturn, 0, 'gets the first item on the stack'; + +is XS::APItest::XSUB::xsreturn_iv(), -2**31+1, 'XSRETURN_IV returns signed int'; +is XS::APItest::XSUB::xsreturn_uv(), 2**31+1, 'XSRETURN_UV returns unsigned int'; +is XS::APItest::XSUB::xsreturn_nv(), 0.25, 'XSRETURN_NV returns double'; +is XS::APItest::XSUB::xsreturn_pv(), "returned", 'XSRETURN_PV returns string'; +is XS::APItest::XSUB::xsreturn_pvn(), "returned", 'XSRETURN_PVN returns string with length'; +ok !XS::APItest::XSUB::xsreturn_no(), 'XSRETURN_NO returns falsey'; +ok XS::APItest::XSUB::xsreturn_yes(), 'XSRETURN_YES returns truthy'; + +is XS::APItest::XSUB::xsreturn_undef(), undef, 'XSRETURN_UNDEF returns undef in scalar context'; +my @xs_undef = XS::APItest::XSUB::xsreturn_undef(); +is scalar @xs_undef, 1, 'XSRETURN_UNDEF returns a single-element list'; +is $xs_undef[0], undef, 'XSRETURN_UNDEF returns undef in list context'; + +my @xs_empty = XS::APItest::XSUB::xsreturn_empty(); +is scalar @xs_empty, 0, 'XSRETURN_EMPTY returns empty list in array context'; +my $xs_empty = XS::APItest::XSUB::xsreturn_empty(); +is $xs_empty, undef, 'XSRETURN_EMPTY returns undef in scalar context'; + + done_testing(); diff --git a/gnu/usr.bin/perl/ext/XS-APItest/typemap b/gnu/usr.bin/perl/ext/XS-APItest/typemap index 035f882a6b8..ed86a374f10 100644 --- a/gnu/usr.bin/perl/ext/XS-APItest/typemap +++ b/gnu/usr.bin/perl/ext/XS-APItest/typemap @@ -1 +1,13 @@ XS::APItest::PtrTable T_PTROBJ + +const WCHAR * WPV + +INPUT + +WPV + $var = ($type)SvPV_nolen($arg); + +OUTPUT + +WPV + sv_setpvn($arg, (const char *)($var), sizeof(WCHAR) * (1+wcslen($var))); diff --git a/gnu/usr.bin/perl/ext/XS-Typemap/Typemap.pm b/gnu/usr.bin/perl/ext/XS-Typemap/Typemap.pm index de3319b0594..a1ae0211d2a 100644 --- a/gnu/usr.bin/perl/ext/XS-Typemap/Typemap.pm +++ b/gnu/usr.bin/perl/ext/XS-Typemap/Typemap.pm @@ -36,7 +36,7 @@ require XSLoader; use vars qw/ $VERSION @EXPORT /; -$VERSION = '0.13'; +$VERSION = '0.14'; @EXPORT = (qw/ T_SV @@ -76,7 +76,7 @@ $VERSION = '0.13'; T_OPAQUEPTR_IN T_OPAQUEPTR_OUT T_OPAQUEPTR_OUT_short T_OPAQUEPTR_IN_struct T_OPAQUEPTR_OUT_struct T_ARRAY - T_STDIO_open T_STDIO_close T_STDIO_print + T_STDIO_open T_STDIO_open_ret_in_arg T_STDIO_close T_STDIO_print T_PACKED_in T_PACKED_out T_PACKEDARRAY_in T_PACKEDARRAY_out T_INOUT T_IN T_OUT diff --git a/gnu/usr.bin/perl/ext/XS-Typemap/Typemap.xs b/gnu/usr.bin/perl/ext/XS-Typemap/Typemap.xs index 3fa0e74abc7..8314cc2b04b 100644 --- a/gnu/usr.bin/perl/ext/XS-Typemap/Typemap.xs +++ b/gnu/usr.bin/perl/ext/XS-Typemap/Typemap.xs @@ -906,6 +906,15 @@ T_STDIO_open( file ) OUTPUT: RETVAL +void +T_STDIO_open_ret_in_arg( file, io) + const char * file + FILE * io = NO_INIT + CODE: + io = xsfopen( file ); + OUTPUT: + io + SysRet T_STDIO_close( f ) PerlIO * f diff --git a/gnu/usr.bin/perl/ext/XS-Typemap/t/Typemap.t b/gnu/usr.bin/perl/ext/XS-Typemap/t/Typemap.t index e251c55e7f2..46ab20fd116 100755 --- a/gnu/usr.bin/perl/ext/XS-Typemap/t/Typemap.t +++ b/gnu/usr.bin/perl/ext/XS-Typemap/t/Typemap.t @@ -6,10 +6,11 @@ BEGIN { } } -use Test::More tests => 148; +use Test::More tests => 156; use strict; -use warnings; +#catch WARN_INTERNAL type errors, and anything else unexpected +use warnings FATAL => 'all'; use XS::Typemap; pass(); @@ -213,6 +214,7 @@ is( T_PV("a string"), "a string"); is( T_PV(52), 52); ok !defined T_PV_null, 'RETVAL = NULL returns undef for char*'; { + use warnings NONFATAL => 'all'; my $uninit; local $SIG{__WARN__} = sub { ++$uninit if shift =~ /uninit/ }; () = ''.T_PV_null; @@ -359,6 +361,8 @@ note("T_STDIO"); # open a file in XS for write my $testfile= "stdio.tmp"; +# not everything below cleans up +END { 1 while unlink $testfile; } my $fh = T_STDIO_open( $testfile ); ok( $fh ); @@ -393,6 +397,17 @@ if (defined $fh) { } } +$fh = "FOO"; +T_STDIO_open_ret_in_arg( $testfile, $fh); +ok( $fh ne "FOO", 'return io in arg open succeeds'); +ok( print($fh "first line\n"), 'can print to return io in arg'); +ok( close($fh), 'can close return io in arg'); +$fh = "FOO"; +#now with a bad file name to make sure $fh is written to on failure +my $badfile = $^O eq 'VMS' ? '?' : ''; +T_STDIO_open_ret_in_arg( $badfile, $fh); +ok( !defined$fh, 'return io in arg open failed successfully'); + # T_INOUT note("T_INOUT"); SCOPE: { @@ -405,6 +420,9 @@ SCOPE: { seek($fh2, 0, 0); is(readline($fh2), $str); ok(print $fh2 "foo\n"); + ok(close $fh); + # this fails because the underlying shared handle is already closed + ok(!close $fh2); } # T_IN @@ -431,8 +449,15 @@ SCOPE: { seek($fh2, 0, 0); is(readline($fh2), $str); ok(eval {print $fh2 "foo\n"; 1}); + ok(close $fh); + # this fails because the underlying shared handle is already closed + ok(!close $fh2); } +# Perl RT #124181 SEGV due to double free in typemap +# "Attempt to free unreferenced scalar" +%{*{main::XS::}{HASH}} = (); + sub is_approx { my ($l, $r, $n) = @_; if (not defined $l or not defined $r) { diff --git a/gnu/usr.bin/perl/ext/arybase/arybase.pm b/gnu/usr.bin/perl/ext/arybase/arybase.pm index 3c090d66c2e..a519a4b3927 100644 --- a/gnu/usr.bin/perl/ext/arybase/arybase.pm +++ b/gnu/usr.bin/perl/ext/arybase/arybase.pm @@ -1,6 +1,6 @@ package arybase; -our $VERSION = "0.07"; +our $VERSION = "0.11"; require XSLoader; XSLoader::load(); # This returns true, which makes require happy. diff --git a/gnu/usr.bin/perl/ext/arybase/arybase.xs b/gnu/usr.bin/perl/ext/arybase/arybase.xs index f8f9ce2b390..4ff6cbd68aa 100644 --- a/gnu/usr.bin/perl/ext/arybase/arybase.xs +++ b/gnu/usr.bin/perl/ext/arybase/arybase.xs @@ -156,7 +156,8 @@ STATIC void ab_neuter_dollar_bracket(pTHX_ OP *o) { oldc = cUNOPx(o)->op_first; newc = newGVOP(OP_GV, 0, gv_fetchpvs("arybase::leftbrack", GV_ADDMULTI, SVt_PVGV)); - cUNOPx(o)->op_first = newc; + /* replace oldc with newc */ + op_sibling_splice(o, NULL, 1, newc); op_free(oldc); } @@ -176,7 +177,7 @@ STATIC OP *ab_ck_sassign(pTHX_ OP *o) { o = (*ab_old_ck_sassign)(aTHX_ o); if (o->op_type == OP_SASSIGN && FEATURE_ARYBASE_IS_ENABLED) { OP *right = cBINOPx(o)->op_first; - OP *left = right->op_sibling; + OP *left = OpSIBLING(right); if (left) ab_process_assignment(left, right); } return o; @@ -186,14 +187,15 @@ STATIC OP *ab_ck_aassign(pTHX_ OP *o) { o = (*ab_old_ck_aassign)(aTHX_ o); if (o->op_type == OP_AASSIGN && FEATURE_ARYBASE_IS_ENABLED) { OP *right = cBINOPx(o)->op_first; - OP *left = cBINOPx(right->op_sibling)->op_first->op_sibling; - right = cBINOPx(right)->op_first->op_sibling; + OP *left = OpSIBLING(right); + left = OpSIBLING(cBINOPx(left)->op_first); + right = OpSIBLING(cBINOPx(right)->op_first); ab_process_assignment(left, right); } return o; } -void +STATIC void tie(pTHX_ SV * const sv, SV * const obj, HV *const stash) { SV *rv = newSV_type(SVt_RV); @@ -234,6 +236,7 @@ static OP *ab_pp_basearg(pTHX) { SV **svp; UV count = 1; ab_op_info oi; + Zero(&oi, 1, ab_op_info); ab_map_fetch(PL_op, &oi); switch (PL_op->op_type) { @@ -247,7 +250,7 @@ static OP *ab_pp_basearg(pTHX) { case OP_LSLICE: firstp = PL_stack_base + *(PL_markstack_ptr-1)+1; count = TOPMARK - *(PL_markstack_ptr-1); - if (GIMME != G_ARRAY) { + if (GIMME_V != G_ARRAY) { firstp += count-1; count = 1; } @@ -275,6 +278,7 @@ static OP *ab_pp_av2arylen(pTHX) { SV *sv; ab_op_info oi; OP *ret; + Zero(&oi, 1, ab_op_info); ab_map_fetch(PL_op, &oi); ret = (*oi.old_pp)(aTHX); if (PL_op->op_flags & OPf_MOD || LVRET) { @@ -295,6 +299,7 @@ static OP *ab_pp_keys(pTHX) { OP *retval; const I32 offset = SP - PL_stack_base; SV **svp; + Zero(&oi, 1, ab_op_info); ab_map_fetch(PL_op, &oi); retval = (*oi.old_pp)(aTHX); if (GIMME_V == G_SCALAR) return retval; @@ -309,6 +314,7 @@ static OP *ab_pp_each(pTHX) { ab_op_info oi; OP *retval; const I32 offset = SP - PL_stack_base; + Zero(&oi, 1, ab_op_info); ab_map_fetch(PL_op, &oi); retval = (*oi.old_pp)(aTHX); SPAGAIN; @@ -323,6 +329,7 @@ static OP *ab_pp_index(pTHX) { dVAR; dSP; ab_op_info oi; OP *retval; + Zero(&oi, 1, ab_op_info); ab_map_fetch(PL_op, &oi); if (MAXARG == 3 && TOPs) replace_sv(TOPs,oi.base); retval = (*oi.old_pp)(aTHX); @@ -375,10 +382,17 @@ static OP *ab_ck_base(pTHX_ OP *o) ab_map_store(o, o->op_ppaddr, base); o->op_ppaddr = new_pp; /* Break the aelemfast optimisation */ - if (o->op_type == OP_AELEM && - cBINOPo->op_first->op_sibling->op_type == OP_CONST) { - cBINOPo->op_first->op_sibling - = newUNOP(OP_NULL,0,cBINOPo->op_first->op_sibling); + if (o->op_type == OP_AELEM) { + OP *const first = cBINOPo->op_first; + OP *second = OpSIBLING(first); + OP *newop; + if (second->op_type == OP_CONST) { + /* cut out second arg and replace it with a new unop which is + * the parent of that arg */ + op_sibling_splice(o, first, 1, NULL); + newop = newUNOP(OP_NULL,0,second); + op_sibling_splice(o, first, 0, newop); + } } } else ab_map_delete(o); diff --git a/gnu/usr.bin/perl/ext/arybase/ptable.h b/gnu/usr.bin/perl/ext/arybase/ptable.h index b3f38d8c1ce..f7919befdf6 100644 --- a/gnu/usr.bin/perl/ext/arybase/ptable.h +++ b/gnu/usr.bin/perl/ext/arybase/ptable.h @@ -127,15 +127,15 @@ STATIC void ptable_split(pPTBLMS_ ptable * const t) { t->ary = ary; for (i = 0; i < oldsize; i++, ary++) { - ptable_ent **curentp, **entp, *ent; + ptable_ent **currentp, **entp, *ent; if (!*ary) continue; - curentp = ary + oldsize; + currentp = ary + oldsize; for (entp = ary, ent = *ary; ent; ent = *entp) { if ((newsize & PTABLE_HASH(ent->key)) != i) { *entp = ent->next; - ent->next = *curentp; - *curentp = ent; + ent->next = *currentp; + *currentp = ent; continue; } else entp = &ent->next; diff --git a/gnu/usr.bin/perl/ext/arybase/t/akeys.t b/gnu/usr.bin/perl/ext/arybase/t/akeys.t index dc490c458e5..a76fade9dbc 100644 --- a/gnu/usr.bin/perl/ext/arybase/t/akeys.t +++ b/gnu/usr.bin/perl/ext/arybase/t/akeys.t @@ -1,4 +1,4 @@ -use warnings; no warnings 'deprecated', 'experimental::lexical_topic'; +use warnings; no warnings 'deprecated'; use strict; BEGIN { @@ -8,7 +8,7 @@ BEGIN { } } -use Test::More tests => 8; +use Test::More tests => 4; our @t; @@ -22,19 +22,4 @@ is_deeply [ keys @t ], []; is_deeply [ scalar keys @t ], [ 6 ]; is_deeply [ keys @t ], [ 3, 4, 5, 6, 7, 8 ]; -SKIP: { - skip "no lexical \$_", 4 unless eval q{my $_; 1}; - eval q{ - my $_; - - @t = (); - is_deeply [ scalar keys @t ], [ 0 ]; - is_deeply [ keys @t ], []; - - @t = qw(a b c d e f); - is_deeply [ scalar keys @t ], [ 6 ]; - is_deeply [ keys @t ], [ 3, 4, 5, 6, 7, 8 ]; - }; -} - 1; diff --git a/gnu/usr.bin/perl/ext/arybase/t/aslice.t b/gnu/usr.bin/perl/ext/arybase/t/aslice.t index 462ee3d6558..20782e59a53 100644 --- a/gnu/usr.bin/perl/ext/arybase/t/aslice.t +++ b/gnu/usr.bin/perl/ext/arybase/t/aslice.t @@ -1,7 +1,7 @@ -use warnings; no warnings 'deprecated', 'experimental::lexical_topic'; +use warnings; no warnings 'deprecated'; use strict; -use Test::More tests => 18; +use Test::More tests => 10; our @t = qw(a b c d e f); our $r = \@t; @@ -24,19 +24,4 @@ is_deeply [ @t[2,-1,1,-2] ], [ qw(f f e e) ]; is_deeply [@t[-3,()]], ['a']; } -SKIP: { - skip "no lexical \$_", 8 unless eval q{my $_; 1}; - eval q{ - my $_; - is_deeply [ scalar @t[3,4] ], [ qw(b) ]; - is_deeply [ @t[3,4,8,9] ], [ qw(a b f), undef ]; - is_deeply [ scalar @t[@i4] ], [ qw(c) ]; - is_deeply [ @t[@i4] ], [ qw(a c a c) ]; - is_deeply [ scalar @{$r}[3,4] ], [ qw(b) ]; - is_deeply [ @{$r}[3,4,8,9] ], [ qw(a b f), undef ]; - is_deeply [ scalar @{$r}[@i4] ], [ qw(c) ]; - is_deeply [ @{$r}[@i4] ], [ qw(a c a c) ]; - }; -} - 1; diff --git a/gnu/usr.bin/perl/ext/arybase/t/lslice.t b/gnu/usr.bin/perl/ext/arybase/t/lslice.t index 828ea3ef886..08aabe9ce5a 100644 --- a/gnu/usr.bin/perl/ext/arybase/t/lslice.t +++ b/gnu/usr.bin/perl/ext/arybase/t/lslice.t @@ -1,7 +1,7 @@ -use warnings; no warnings 'deprecated', 'experimental::lexical_topic'; +use warnings; no warnings 'deprecated'; use strict; -use Test::More tests => 12; +use Test::More tests => 8; our @i4 = (3, 5, 3, 5); @@ -20,15 +20,4 @@ is_deeply [ qw(a b c d e f)[2,1] ], [ qw(f e) ]; is_deeply [qw(a b c d e f)[-3]], ['a']; } -SKIP: { - skip "no lexical \$_", 4 unless eval q{my $_; 1}; - eval q{ - my $_; - is_deeply [ scalar qw(a b c d e f)[3,4] ], [ qw(b) ]; - is_deeply [ qw(a b c d e f)[3,4,8,9] ], [ qw(a b f), undef ]; - is_deeply [ scalar qw(a b c d e f)[@i4] ], [ qw(c) ]; - is_deeply [ qw(a b c d e f)[@i4] ], [ qw(a c a c) ]; - }; -} - 1; diff --git a/gnu/usr.bin/perl/ext/attributes/attributes.pm b/gnu/usr.bin/perl/ext/attributes/attributes.pm index ebca2146085..f7af31b7b4c 100644 --- a/gnu/usr.bin/perl/ext/attributes/attributes.pm +++ b/gnu/usr.bin/perl/ext/attributes/attributes.pm @@ -1,6 +1,6 @@ package attributes; -our $VERSION = 0.23; +our $VERSION = 0.27; @EXPORT_OK = qw(get reftype); @EXPORT = (); @@ -23,6 +23,12 @@ $deprecated{CODE} = qr/\A-?(locked)\z/; $deprecated{ARRAY} = $deprecated{HASH} = $deprecated{SCALAR} = qr/\A-?(unique)\z/; +my %msg = ( + lvalue => 'lvalue attribute applied to already-defined subroutine', + -lvalue => 'lvalue attribute removed from already-defined subroutine', + const => 'Useless use of attribute "const"', +); + sub _modify_attrs_and_deprecate { my $svtype = shift; # Now that we've removed handling of locked from the XS code, we need to @@ -34,13 +40,11 @@ sub _modify_attrs_and_deprecate { require warnings; warnings::warnif('deprecated', "Attribute \"$1\" is deprecated"); 0; - } : $svtype eq 'CODE' && /^-?lvalue\z/ ? do { + } : $svtype eq 'CODE' && exists $msg{$_} ? do { require warnings; warnings::warnif( 'misc', - "lvalue attribute " - . (/^-/ ? "removed from" : "applied to") - . " already-defined subroutine" + $msg{$_} ); 0; } : 1 @@ -256,6 +260,13 @@ attribute will be sanity checked at compile time. The "locked" attribute is deprecated, and has no effect in 5.10.0 and later. It was used as part of the now-removed "Perl 5.005 threads". +=item const + +This experimental attribute, introduced in Perl 5.22, only applies to +anonymous subroutines. It causes the subroutine to be called as soon as +the C<sub> expression is evaluated. The return value is captured and +turned into a constant subroutine. + =back The following are the built-in attributes for variables: diff --git a/gnu/usr.bin/perl/ext/attributes/attributes.xs b/gnu/usr.bin/perl/ext/attributes/attributes.xs index 6b36812b13d..d98fd9e3ec2 100644 --- a/gnu/usr.bin/perl/ext/attributes/attributes.xs +++ b/gnu/usr.bin/perl/ext/attributes/attributes.xs @@ -28,7 +28,6 @@ static int modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs) { - dVAR; SV *attr; int nret; @@ -44,6 +43,20 @@ modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs) switch (SvTYPE(sv)) { case SVt_PVCV: switch ((int)len) { + case 5: + if (memEQ(name, "const", 5)) { + if (negated) + CvANONCONST_off(sv); + else { + const bool warn = (!CvANON(sv) || CvCLONED(sv)) + && !CvANONCONST(sv); + CvANONCONST_on(sv); + if (warn) + break; + } + continue; + } + break; case 6: switch (name[3]) { case 'l': @@ -236,11 +249,5 @@ usage: XSRETURN(1); /* - * Local variables: - * c-indentation-style: bsd - * c-basic-offset: 4 - * indent-tabs-mode: nil - * End: - * * ex: set ts=8 sts=4 sw=4 et: */ diff --git a/gnu/usr.bin/perl/ext/mro/mro.pm b/gnu/usr.bin/perl/ext/mro/mro.pm index 1dddd6180fa..0946fb67221 100644 --- a/gnu/usr.bin/perl/ext/mro/mro.pm +++ b/gnu/usr.bin/perl/ext/mro/mro.pm @@ -12,7 +12,7 @@ use warnings; # mro.pm versions < 1.00 reserved for MRO::Compat # for partial back-compat to 5.[68].x -our $VERSION = '1.16'; +our $VERSION = '1.18'; sub import { mro::set_mro(scalar(caller), $_[1]) if $_[1]; diff --git a/gnu/usr.bin/perl/ext/mro/mro.xs b/gnu/usr.bin/perl/ext/mro/mro.xs index fead95f759b..6d891ae7315 100644 --- a/gnu/usr.bin/perl/ext/mro/mro.xs +++ b/gnu/usr.bin/perl/ext/mro/mro.xs @@ -13,7 +13,7 @@ static const struct mro_alg c3_alg = /* =for apidoc mro_get_linear_isa_c3 -Returns the C3 linearization of @ISA +Returns the C3 linearization of C<@ISA> the given stash. The return value is a read-only AV*. C<level> should be 0 (it is used internally in this function's recursion). @@ -477,8 +477,8 @@ mro__nextcan(...) const PERL_SI *top_si = PL_curstackinfo; HV* selfstash; SV *stashname; - const char *fq_subname; - const char *subname; + const char *fq_subname = NULL; + const char *subname = NULL; bool subname_utf8 = 0; STRLEN stashname_len; STRLEN subname_len; diff --git a/gnu/usr.bin/perl/ext/re/Makefile.PL b/gnu/usr.bin/perl/ext/re/Makefile.PL index c6338c7ea2f..4a2193401a6 100644 --- a/gnu/usr.bin/perl/ext/re/Makefile.PL +++ b/gnu/usr.bin/perl/ext/re/Makefile.PL @@ -12,7 +12,7 @@ WriteMakefile( XSPROTOARG => '-noprototypes', OBJECT => $object, DEFINE => $defines, - clean => { FILES => '*$(OBJ_EXT) *.c ../../lib/re.pm' }, + clean => { FILES => '*$(OBJ_EXT) invlist_inline.h *.c ../../lib/re.pm' }, ); package MY; @@ -24,29 +24,29 @@ sub upupfile { sub postamble { my $regcomp_c = upupfile('regcomp.c'); my $regexec_c = upupfile('regexec.c'); - my $dquote_static_c = upupfile('dquote_static.c'); - my $inline_invlist_c = upupfile('inline_invlist.c'); + my $dquote_c = upupfile('dquote.c'); + my $invlist_inline_h = upupfile('invlist_inline.h'); <<EOF; re_comp.c : $regcomp_c - \$(RM_F) re_comp.c \$(CP) $regcomp_c re_comp.c -re_comp\$(OBJ_EXT) : re_comp.c dquote_static.c inline_invlist.c +re_comp\$(OBJ_EXT) : re_comp.c dquote.c invlist_inline.h re_exec.c : $regexec_c - \$(RM_F) re_exec.c \$(CP) $regexec_c re_exec.c -re_exec\$(OBJ_EXT) : re_exec.c inline_invlist.c +re_exec\$(OBJ_EXT) : re_exec.c invlist_inline.h -dquote_static.c : $dquote_static_c - - \$(RM_F) dquote_static.c - \$(CP) $dquote_static_c dquote_static.c +dquote.c : $dquote_c + - \$(RM_F) dquote.c + \$(CP) $dquote_c dquote.c -inline_invlist.c : $inline_invlist_c - - \$(RM_F) inline_invlist.c - \$(CP) $inline_invlist_c inline_invlist.c +invlist_inline.h : $invlist_inline_h + - \$(RM_F) invlist_inline.h + \$(CP) $invlist_inline_h invlist_inline.h EOF } diff --git a/gnu/usr.bin/perl/ext/re/re.pm b/gnu/usr.bin/perl/ext/re/re.pm index ea7e3d021ad..058b8aa961c 100644 --- a/gnu/usr.bin/perl/ext/re/re.pm +++ b/gnu/usr.bin/perl/ext/re/re.pm @@ -4,7 +4,7 @@ package re; use strict; use warnings; -our $VERSION = "0.26"; +our $VERSION = "0.32"; our @ISA = qw(Exporter); our @EXPORT_OK = ('regmust', qw(is_regexp regexp_pattern @@ -23,7 +23,9 @@ my %reflags = ( s => 1 << ($PMMOD_SHIFT + 1), i => 1 << ($PMMOD_SHIFT + 2), x => 1 << ($PMMOD_SHIFT + 3), - p => 1 << ($PMMOD_SHIFT + 4), + n => 1 << ($PMMOD_SHIFT + 5), + p => 1 << ($PMMOD_SHIFT + 6), + strict => 1 << ($PMMOD_SHIFT + 10), # special cases: d => 0, l => 1, @@ -57,6 +59,7 @@ my %flags = ( TRIEC => 0x000004, DUMP => 0x000008, FLAGS => 0x000010, + TEST => 0x000020, EXECUTE => 0x00FF00, INTUIT => 0x000100, @@ -108,6 +111,17 @@ sub _load_unload { sub bits { my $on = shift; my $bits = 0; + my $turning_all_off = ! @_ && ! $on; + my %seen; # Has flag already been seen? + if ($turning_all_off) { + + # Pretend were called with certain parameters, which are best dealt + # with that way. + push @_, keys %bitmask; # taint and eval + push @_, 'strict'; + } + + # Process each subpragma parameter ARG: foreach my $idx (0..$#_){ my $s=$_[$idx]; @@ -138,6 +152,31 @@ sub bits { } elsif ($EXPORT_OK{$s}) { require Exporter; re->export_to_level(2, 're', $s); + } elsif ($s eq 'strict') { + if ($on) { + $^H{reflags} |= $reflags{$s}; + warnings::warnif('experimental::re_strict', + "\"use re 'strict'\" is experimental"); + + # Turn on warnings if not already done. + if (! warnings::enabled('regexp')) { + require warnings; + warnings->import('regexp'); + $^H{re_strict} = 1; + } + } + else { + $^H{reflags} &= ~$reflags{$s} if $^H{reflags}; + + # Turn off warnings if we turned them on. + warnings->unimport('regexp') if $^H{re_strict}; + } + if ($^H{reflags}) { + $^H |= $flags_hint; + } + else { + $^H &= ~$flags_hint; + } } elsif ($s =~ s/^\///) { my $reflags = $^H{reflags} || 0; my $seen_charset; @@ -182,11 +221,12 @@ sub bits { } else { delete $^H{reflags_charset} - if defined $^H{reflags_charset} - && $^H{reflags_charset} == $reflags{$_}; + if defined $^H{reflags_charset} + && $^H{reflags_charset} == $reflags{$_}; } } elsif (exists $reflags{$_}) { - $on + $seen{$_}++; + $on ? $reflags |= $reflags{$_} : ($reflags &= ~$reflags{$_}); } else { @@ -198,8 +238,8 @@ sub bits { } } ($^H{reflags} = $reflags or defined $^H{reflags_charset}) - ? $^H |= $flags_hint - : ($^H &= ~$flags_hint); + ? $^H |= $flags_hint + : ($^H &= ~$flags_hint); } else { require Carp; Carp::carp("Unknown \"re\" subpragma '$s' (known ones are: ", @@ -207,6 +247,26 @@ sub bits { ")"); } } + if (exists $seen{'x'} && $seen{'x'} > 1 + && (warnings::enabled("deprecated") + || warnings::enabled("regexp"))) + { + my $message = "Having more than one /x regexp modifier is deprecated"; + if (warnings::enabled("deprecated")) { + warnings::warn("deprecated", $message); + } + else { + warnings::warn("regexp", $message); + } + } + + if ($turning_all_off) { + _load_unload(0); + $^H{reflags} = 0; + $^H{reflags_charset} = 0; + $^H &= ~$flags_hint; + } + $bits; } @@ -247,6 +307,8 @@ re - Perl pragma to alter regular expression behaviour # switch) } + use re 'strict'; # Raise warnings for more conditions + use re '/ix'; "FOO" =~ / foo /; # /ix implied no re '/x'; @@ -308,6 +370,54 @@ interpolation. Thus: I<is> allowed if $pat is a precompiled regular expression, even if $pat contains C<(?{ ... })> assertions or C<(??{ ... })> subexpressions. +=head2 'strict' mode + +Note that this is an experimental feature which may be changed or removed in a +future Perl release. + +When C<use re 'strict'> is in effect, stricter checks are applied than +otherwise when compiling regular expressions patterns. These may cause more +warnings to be raised than otherwise, and more things to be fatal instead of +just warnings. The purpose of this is to find and report at compile time some +things, which may be legal, but have a reasonable possibility of not being the +programmer's actual intent. This automatically turns on the C<"regexp"> +warnings category (if not already on) within its scope. + +As an example of something that is caught under C<"strict'>, but not +otherwise, is the pattern + + qr/\xABC/ + +The C<"\x"> construct without curly braces should be followed by exactly two +hex digits; this one is followed by three. This currently evaluates as +equivalent to + + qr/\x{AB}C/ + +that is, the character whose code point value is C<0xAB>, followed by the +letter C<C>. But since C<C> is a a hex digit, there is a reasonable chance +that the intent was + + qr/\x{ABC}/ + +that is the single character at C<0xABC>. Under C<'strict'> it is an error to +not follow C<\x> with exactly two hex digits. When not under C<'strict'> a +warning is generated if there is only one hex digit, and no warning is raised +if there are more than two. + +It is expected that what exactly C<'strict'> does will evolve over time as we +gain experience with it. This means that programs that compile under it in +today's Perl may not compile, or may have more or fewer warnings, in future +Perls. There is no backwards compatibility promises with regards to it. Also +there are already proposals for an alternate syntax for enabling it. For +these reasons, using it will raise a C<experimental::re_strict> class warning, +unless that category is turned off. + +Note that if a pattern compiled within C<'strict'> is recompiled, say by +interpolating into another pattern, outside of C<'strict'>, it is not checked +again for strictness. This is because if it works under strict it must work +under non-strict. + =head2 '/flags' mode When C<use re '/flags'> is specified, the given flags are automatically @@ -396,6 +506,14 @@ Detailed info about trie compilation. Dump the final program out after it is compiled and optimised. +=item FLAGS + +Dump the flags associated with the program + +=item TEST + +Print output intended for testing the internals of the compile process + =back =item Execute related options @@ -448,6 +566,10 @@ Enable debugging of the recursion stack in the engine. Enabling or disabling this option automatically does the same for debugging states as well. This output from this can be quite large. +=item GPOS + +Enable debugging of the \G modifier. + =item OPTIMISEM Enable enhanced optimisation debugging and start-point optimisations. @@ -473,6 +595,7 @@ debug options. Almost definitely only useful to people hacking on the offsets part of the debug engine. + =back =item Other useful flags diff --git a/gnu/usr.bin/perl/ext/re/re.xs b/gnu/usr.bin/perl/ext/re/re.xs index 2be0773ffbb..9545d1dba04 100644 --- a/gnu/usr.bin/perl/ext/re/re.xs +++ b/gnu/usr.bin/perl/ext/re/re.xs @@ -8,6 +8,10 @@ #include "XSUB.h" #include "re_comp.h" +#undef dXSBOOTARGSXSAPIVERCHK +/* skip API version checking due to different interp struct size but, + this hack is until #123007 is resolved */ +#define dXSBOOTARGSXSAPIVERCHK dXSBOOTARGSNOVERCHK START_EXTERN_C diff --git a/gnu/usr.bin/perl/ext/re/re_top.h b/gnu/usr.bin/perl/ext/re/re_top.h index e73550f9a86..ce4c716aa54 100644 --- a/gnu/usr.bin/perl/ext/re/re_top.h +++ b/gnu/usr.bin/perl/ext/re/re_top.h @@ -33,11 +33,5 @@ #define PERL_NO_GET_CONTEXT /* - * Local variables: - * c-indentation-style: bsd - * c-basic-offset: 4 - * indent-tabs-mode: nil - * End: - * * ex: set ts=8 sts=4 sw=4 et: */ diff --git a/gnu/usr.bin/perl/ext/re/t/lexical_debug.pl b/gnu/usr.bin/perl/ext/re/t/lexical_debug.pl index 3ec7455ba1a..0e74bf02582 100644 --- a/gnu/usr.bin/perl/ext/re/t/lexical_debug.pl +++ b/gnu/usr.bin/perl/ext/re/t/lexical_debug.pl @@ -1,6 +1,6 @@ use re 'debug'; -$_ = 'foo bar baz bop fip fop'; +$_ = 'foo bar baz bop boq bor fip fop'; /foo/ and $count++; @@ -14,6 +14,13 @@ $_ = 'foo bar baz bop fip fop'; /bop/ and $count++; } +{ + use re 'debug'; + /boq/ and $count++; + no re; + /bor/ and $count++; +} + /fip/ and $count++; no re 'debug'; diff --git a/gnu/usr.bin/perl/ext/re/t/lexical_debug.t b/gnu/usr.bin/perl/ext/re/t/lexical_debug.t index d4b7e629109..b2570f0e2da 100644 --- a/gnu/usr.bin/perl/ext/re/t/lexical_debug.t +++ b/gnu/usr.bin/perl/ext/re/t/lexical_debug.t @@ -15,7 +15,7 @@ use strict; BEGIN { require "../../t/test.pl"; } my $out = runperl(progfile => "t/lexical_debug.pl", stderr => 1 ); -print "1..10\n"; +print "1..12\n"; # Each pattern will produce an EXACT node with a specific string in # it, so we will look for that. We can't just look for the string @@ -25,11 +25,13 @@ ok( $out =~ /EXACT <foo>/, "Expect 'foo'" ); ok( $out !~ /EXACT <bar>/, "No 'bar'" ); ok( $out =~ /EXACT <baz>/, "Expect 'baz'" ); ok( $out !~ /EXACT <bop>/, "No 'bop'" ); +ok( $out =~ /EXACT <boq>/, "Expect 'boq'" ); +ok( $out !~ /EXACT <bor>/, "No 'bor'" ); ok( $out =~ /EXACT <fip>/, "Expect 'fip'" ); ok( $out !~ /EXACT <fop>/, "No 'baz'" ); ok( $out =~ /<liz>/, "Got 'liz'" ); # in a TRIE so no EXACT ok( $out =~ /<zoo>/, "Got 'zoo'" ); # in a TRIE so no EXACT ok( $out =~ /<zap>/, "Got 'zap'" ); # in a TRIE so no EXACT -ok( $out =~ /Count=7\n/, "Count is 7") +ok( $out =~ /Count=9\n/, "Count is 9") or diag($out); diff --git a/gnu/usr.bin/perl/ext/re/t/re.t b/gnu/usr.bin/perl/ext/re/t/re.t index 13498bbe2df..353ff812d47 100644 --- a/gnu/usr.bin/perl/ext/re/t/re.t +++ b/gnu/usr.bin/perl/ext/re/t/re.t @@ -10,6 +10,9 @@ BEGIN { use strict; +my $re_taint_bit = 0x00100000; +my $re_eval_bit = 0x00200000; + use Test::More tests => 15; require_ok( 're' ); @@ -42,20 +45,20 @@ isnt( $ENV{PERL_RE_COLORS}, '', re::bits(0, 'nosuchsubpragma'); like( $warn, qr/Unknown "re" subpragma/, '... should warn about unknown subpragma' ); -ok( re::bits(0, 'taint') & 0x00100000, '... should set taint bits' ); -ok( re::bits(0, 'eval') & 0x00200000, '... should set eval bits' ); +ok( re::bits(0, 'taint') & $re_taint_bit, '... should set taint bits' ); +ok( re::bits(0, 'eval') & $re_eval_bit, '... should set eval bits' ); local $^H; # import re->import('taint', 'eval'); -ok( $^H & 0x00100000, 'import should set taint bits in $^H when requested' ); -ok( $^H & 0x00200000, 'import should set eval bits in $^H when requested' ); +ok( $^H & $re_taint_bit, 'import should set taint bits in $^H when requested' ); +ok( $^H & $re_eval_bit, 'import should set eval bits in $^H when requested' ); re->unimport('taint'); -ok( !( $^H & 0x00100000 ), 'unimport should clear bits in $^H when requested' ); +ok( !( $^H & $re_taint_bit ), 'unimport should clear bits in $^H when requested' ); re->unimport('eval'); -ok( !( $^H & 0x00200000 ), '... and again' ); +ok( !( $^H & $re_eval_bit ), '... and again' ); my $reg=qr/(foo|bar|baz|blah)/; close STDERR; eval"use re Debug=>'ALL'"; diff --git a/gnu/usr.bin/perl/ext/re/t/re_funcs_u.t b/gnu/usr.bin/perl/ext/re/t/re_funcs_u.t index 706437ec18b..70820df3c39 100644 --- a/gnu/usr.bin/perl/ext/re/t/re_funcs_u.t +++ b/gnu/usr.bin/perl/ext/re/t/re_funcs_u.t @@ -6,7 +6,8 @@ BEGIN { print "1..0 # Skip -- Perl configured without re module\n"; exit 0; } - require 'test.pl'; # For watchdog + require 'test.pl'; # For watchdog + require 'loc_tools.pl'; # To see if platform has locales } use strict; @@ -33,6 +34,7 @@ use re qw(is_regexp regexp_pattern is(regexp_pattern($rx),'(?^upi:foo)', 'scalar regexp_pattern (bare REGEXP)'); ok(!regexp_pattern(''),'!regexp_pattern("")'); + is +()=regexp_pattern(''), 0, 'regexp_pattern("") in list cx'; } if ('1234'=~/(?:(?<A>\d)|(?<C>!))(?<B>\d)(?<A>\d)(?<B>\d)/){ @@ -79,7 +81,7 @@ if ('1234'=~/(?:(?<A>\d)|(?<C>!))(?<B>\d)(?<A>\d)(?<B>\d)/){ { # tests for new regexp flags - my $text = "\xE4"; + my $text = chr utf8::unicode_to_native(0xE4); my $check; { @@ -91,8 +93,7 @@ if ('1234'=~/(?:(?<A>\d)|(?<C>!))(?<B>\d)(?<A>\d)(?<B>\d)/){ } SKIP: { - skip_if_miniperl("no dynamic loading on miniperl, no POSIX", 3); - skip 'No locale testing without d_setlocale', 3 if(!$Config::Config{d_setlocale}); + skip 'No locales available', 3 unless locales_enabled('LC_CTYPE'); require POSIX; my $current_locale = POSIX::setlocale( &POSIX::LC_CTYPE, 'de_DE.ISO-8859-1' ); if ( !$current_locale || $current_locale ne 'de_DE.ISO-8859-1' ) { @@ -108,8 +109,7 @@ if ('1234'=~/(?:(?<A>\d)|(?<C>!))(?<B>\d)(?<A>\d)(?<B>\d)/){ } SKIP: { - skip_if_miniperl("no dynamic loading on miniperl, no POSIX", 3); - skip 'No locale testing without d_setlocale', 3 if(!$Config::Config{d_setlocale}); + skip 'No locales available', 3 unless locales_enabled('LC_CTYPE'); require POSIX; my $current_locale = POSIX::setlocale( &POSIX::LC_CTYPE, 'C' ); if ( !$current_locale || $current_locale ne 'C' ) { diff --git a/gnu/usr.bin/perl/ext/re/t/reflags.t b/gnu/usr.bin/perl/ext/re/t/reflags.t index 85bbdb45ec1..fd1c35a848a 100644 --- a/gnu/usr.bin/perl/ext/re/t/reflags.t +++ b/gnu/usr.bin/perl/ext/re/t/reflags.t @@ -6,11 +6,12 @@ BEGIN { print "1..0 # Skip -- Perl configured without re module\n"; exit 0; } + require 'loc_tools.pl'; } use strict; -use Test::More tests => 62; +use Test::More tests => 67; my @flags = qw( a d l u ); @@ -53,18 +54,21 @@ no re '/sm'; ok 'f r e l p' =~ /f r e l p/, "use re '/x' turns off when it drops out of scope"; +{ + use re '/i'; + ok "Foo" =~ /foo/, 'use re "/i"'; + no re; + ok "Foo" !~ /foo/, "bare 'no re' reverts to no /i"; + use re '/u'; + my $nbsp = chr utf8::unicode_to_native(0xa0); + ok $nbsp =~ /\s/, 'nbsp matches \\s under /u'; + no re; + ok $nbsp !~ /\s/, "bare 'no re' reverts to /d"; +} + SKIP: { - if ( - !$Config::Config{d_setlocale} - || $Config::Config{ccflags} =~ /\bD?NO_LOCALE(_|\b)/ - ) { - skip "no locale support", 7 - } - BEGIN { - if($Config::Config{d_setlocale}) { - require locale; import locale; - } - } + skip "no locale support", 7 unless locales_enabled('CTYPE'); + use locale; use re '/u'; is qr//, '(?^u:)', 'use re "/u" with active locale'; no re '/u'; @@ -169,9 +173,13 @@ is qr//, '(?^:)', 'no re "/aai"'; } $w = ""; - eval "use re '/axaa'"; + eval "use re '/amaa'"; like $w, qr/The "a" flag may only appear a maximum of twice/, - "warning with eval \"use re \"/axaa\""; + "warning with eval \"use re \"/amaa\""; + $w = ""; + eval "use re '/xamax'"; + like $w, qr/Having more than one \/x regexp modifier is deprecated/, + "warning with eval \"use re \"/xamax\""; } diff --git a/gnu/usr.bin/perl/ext/re/t/regop.pl b/gnu/usr.bin/perl/ext/re/t/regop.pl index 961af390c3c..86976ee0da3 100644 --- a/gnu/usr.bin/perl/ext/re/t/regop.pl +++ b/gnu/usr.bin/perl/ext/re/t/regop.pl @@ -1,4 +1,4 @@ -use re Debug=>qw(DUMP EXECUTE OFFSETS TRIEC); +use re Debug=>qw(DUMP EXECUTE OFFSETS TRIEC TEST); my @tests=( XY => 'X(A|[B]Q||C|D)Y' , foobar => '[f][o][o][b][a][r]', @@ -7,7 +7,8 @@ my @tests=( 'D:\\dev/perl/ver/28321_/perl.exe'=> '/(\\.COM|\\.EXE|\\.BAT|\\.CMD|\\.VBS|\\.VBE|\\.JS|\\.JSE|\\.WSF|\\.WSH|\\.pyo|\\.pyc|\\.pyw|\\.py)$/i', 'q'=>'[q]', - "path_sep:\t8490" => '^(\\S{1,9}):\\s*(\\d+)$' + "path_sep:\t8490" => '^(\\S{1,9}):\\s*(\\d+)$', + '' => '(?(DEFINE)(?<foo>foo))(?(DEFINE)(?<bar>(?&foo)bar))(?(DEFINE)(?<baz>(?&bar)baz))(?(DEFINE)(?<bop>(?&baz)bop))', ); while (@tests) { my ($str,$pat)=splice @tests,0,2; diff --git a/gnu/usr.bin/perl/ext/re/t/regop.t b/gnu/usr.bin/perl/ext/re/t/regop.t index 76576b12135..f75e5413fff 100644 --- a/gnu/usr.bin/perl/ext/re/t/regop.t +++ b/gnu/usr.bin/perl/ext/re/t/regop.t @@ -14,7 +14,7 @@ our $NUM_SECTS; chomp(my @strs= grep { !/^\s*\#/ } <DATA>); my $out = runperl(progfile => "t/regop.pl", stderr => 1 ); # VMS currently embeds linefeeds in the output. -$out =~ s/\cJ//g if $^O == 'VMS'; +$out =~ s/\cJ//g if $^O eq 'VMS'; my @tests = grep { /\S/ } split /(?=Compiling REx)/, $out; # on debug builds we get an EXECUTING... message in there at the top shift @tests @@ -55,7 +55,7 @@ foreach my $testout ( @tests ) { # that the tests for this result set are finished. # If you add a test make sure you update $NUM_SECTS # the commented output is just for legacy/debugging purposes -BEGIN{ $NUM_SECTS= 7 } +BEGIN{ $NUM_SECTS= 8 } __END__ #Compiling REx "X(A|[B]Q||C|D)Y" @@ -96,8 +96,8 @@ TRIE-EXACT <BQ> matched empty string Match successful! -Found floating substr "Y" at offset 1... -Found anchored substr "X" at offset 0... +Found floating substr "Y" at offset 1 (rx_origin now 0)... +Found anchored substr "X" at offset 0 (rx_origin now 0)... Successfully guessed: match at offset 0 checking floating minlen 2 @@ -261,9 +261,8 @@ Offsets: [3] Freeing REx: "[q]" --- #Compiling REx "^(\S{1,9}):\s*(\d+)$" -#synthetic stclass "ANYOF[\x{00}-\x{08}\x{0E}-\x{1F}\x{21}-\x{FF}][{utf8}0100-167F 1681-1FFF 200B-2027 202A-202E 2030-205E 2060-2FFF 3001-INFINITY]". #Final program: -# 1: BOL (2) +# 1: SBOL (2) # 2: OPEN1 (4) # 4: CURLY {1,9} (7) # 6: NPOSIXD[\s] (0) @@ -277,8 +276,59 @@ Freeing REx: "[q]" # 17: CLOSE2 (19) # 19: EOL (20) # 20: END (0) -#floating ":" at 1..9 (checking floating) stclass ANYOF[\x{00}-\x{08}\x{0E}-\x{1F}\x{21}-\x{FF}][{utf8}0100-167F 1681-1FFF 200B-2027 202A-202E 2030-205E 2060-2FFF 3001-INFINITY] anchored(BOL) minlen 3 #Freeing REx: "^(\S{1,9}):\s*(\d+)$" -floating ":" at 1..9 (checking floating) stclass ANYOF[\x{00}-\x{08}\x{0E}-\x{1F}\x{21}-\x{FF}][{utf8}0100-167F 1681-1FFF 200B-2027 202A-202E 2030-205E 2060-2FFF 3001-INFINITY] anchored(BOL) minlen 3 %MATCHED% -synthetic stclass +Freeing REx: "^(\S{1,9}):\s*(\d+)$" +--- +#Compiling REx "(?(DEFINE)(?<foo>foo))(?(DEFINE)(?<bar>(?&foo)bar))(?(DEFINE"... +#Got 532 bytes for offset annotations. +study_chunk_recursed_count: 5 +#Final program: +# 1: DEFINEP (3) +# 3: IFTHEN (14) +# 5: OPEN1 'foo' (7) +# 7: EXACT <foo> (9) +# 9: CLOSE1 'foo' (14) +# 11: LONGJMP (13) +# 13: TAIL (14) +# 14: DEFINEP (16) +# 16: IFTHEN (30) +# 18: OPEN2 'bar' (20) +# 20: GOSUB1[-15] (23) +# 23: EXACT <bar> (25) +# 25: CLOSE2 'bar' (30) +# 27: LONGJMP (29) +# 29: TAIL (30) +# 30: DEFINEP (32) +# 32: IFTHEN (46) +# 34: OPEN3 'baz' (36) +# 36: GOSUB2[-18] (39) +# 39: EXACT <baz> (41) +# 41: CLOSE3 'baz' (46) +# 43: LONGJMP (45) +# 45: TAIL (46) +# 46: DEFINEP (48) +# 48: IFTHEN (62) +# 50: OPEN4 'bop' (52) +# 52: GOSUB3[-18] (55) +# 55: EXACT <bop> (57) +# 57: CLOSE4 'bop' (62) +# 59: LONGJMP (61) +# 61: TAIL (62) +# 62: END (0) +minlen 0 +#Offsets: [66] +# 1:3[0] 3:10[0] 5:17[1] 7:18[3] 9:21[1] 11:21[0] 13:22[0] 14:25[0] 16:32[0] 18:39[1] 20:41[3] 23:47[3] 25:50[1] 27:50[0] 29:51[0] 30:54[0] 32:61[0] 34:68[1] 36:70[3] 39:76[3] 41:79[1] 43:79[0] 45:80[0] 46:83[0] 48:90[0] 50:97[1] 52:99[3] 55:105[3] 57:108[1] 59:108[0] 61:109[0] 62:110[0] +#Matching REx "(?(DEFINE)(?<foo>foo))(?(DEFINE)(?<bar>(?&foo)bar))(?(DEFINE"... against "" +# 0 <> <> | 1:DEFINEP(3) +# 0 <> <> | 3:IFTHEN(14) +# 0 <> <> | 14:DEFINEP(16) +# 0 <> <> | 16:IFTHEN(30) +# 0 <> <> | 30:DEFINEP(32) +# 0 <> <> | 32:IFTHEN(46) +# 0 <> <> | 46:DEFINEP(48) +# 0 <> <> | 48:IFTHEN(62) +# 0 <> <> | 62:END(0) +#Match successful! +%MATCHED% +#Freeing REx: "(?(DEFINE)(?<foo>foo))(?(DEFINE)(?<bar>(?&foo)bar))(?(DEFINE"... diff --git a/gnu/usr.bin/perl/ext/re/t/strict.t b/gnu/usr.bin/perl/ext/re/t/strict.t new file mode 100644 index 00000000000..6cafabbd513 --- /dev/null +++ b/gnu/usr.bin/perl/ext/re/t/strict.t @@ -0,0 +1,73 @@ +#!./perl + +# Most of the strict effects are tested for in t/re/reg_mesgs.t + +BEGIN { + require Config; + if (($Config::Config{'extensions'} !~ /\bre\b/) ){ + print "1..0 # Skip -- Perl configured without re module\n"; + exit 0; + } +} + +use strict; + +use Test::More tests => 10; +BEGIN { require_ok( 're' ); } + +{ + my @w; + no warnings; + local $SIG{__WARN__}; + BEGIN { $SIG{__WARN__} = sub { push @w, @_ } }; + qr/\b*/; + BEGIN { is(scalar @w, 0, 'No default-on warnings for qr/\b*/'); } + BEGIN {undef @w; } + + { + use re 'strict'; + qr/\b*/; + + BEGIN { is(scalar @w, 1, 'use re "strict" turns on warnings'); } + + BEGIN { undef @w; } + + no re 'strict'; + qr/\b*/; + + BEGIN { is(scalar @w, 0, 'no re "strict" restores warnings state'); } + } + + BEGIN {undef @w; } + qr/\b*/; + BEGIN { is(scalar @w, 0, 'dropping out of "strict" scope reverts warnings default'); } + + { + use re 'strict'; + qr/\b*/; + + BEGIN { is(scalar @w, 1, 'use re "strict" turns on warnings'); } + + no re 'strict'; + BEGIN {undef @w; } + qr/\b*/; + BEGIN { is(scalar @w, 0, 'turning off "strict" scope reverts warnings default'); } + } + + { + use warnings 'regexp'; + BEGIN {undef @w; } + qr/\b*/; + BEGIN { is(scalar @w, 1, 'use warnings "regexp" works'); } + + use re 'strict'; + BEGIN {undef @w; } + qr/\b*/; + BEGIN { is(scalar @w, 1, 'use re "strict" keeps warnings on'); } + + no re 'strict'; + BEGIN {undef @w; } + qr/\b*/; + BEGIN { is(scalar @w, 1, 'turning off "strict" scope doesn\'t affect warnings that were already on'); } + } +} |