diff options
| author | Jarkko Hietaniemi <jhi@iki.fi> | 2000-03-19 18:20:42 +0000 |
|---|---|---|
| committer | Jarkko Hietaniemi <jhi@iki.fi> | 2000-03-19 18:20:42 +0000 |
| commit | f6a871ab990d104bbe59c1e7e518f3d1dd6635f9 (patch) | |
| tree | 444566cdf66a83b0d76355e1c07bbd535dbdab59 | |
| parent | 41d6edb2c1acac32a0296d594f0943752d23f077 (diff) | |
| parent | 2c3c3b7c202d038a04e75a75246fb22b78df4121 (diff) | |
| download | perl-f6a871ab990d104bbe59c1e7e518f3d1dd6635f9.tar.gz | |
Integrate with Sarathy.
p4raw-id: //depot/cfgperl@5833
42 files changed, 856 insertions, 240 deletions
@@ -95,6 +95,188 @@ Version v5.6.0 -------------- ____________________________________________________________________________ +[ 5828] By: gsar on 2000/03/19 16:47:14 + Log: squelch known scalar leak due to compile failure + Branch: perl + ! t/pragma/strict-vars +____________________________________________________________________________ +[ 5827] By: gsar on 2000/03/19 09:20:22 + Log: mention how to look up perllocal.pod (from Michael G Schwern) + Branch: perl + ! pod/perlapi.pod pod/perlmodinstall.pod pod/perlmodlib.pod +____________________________________________________________________________ +[ 5826] By: gsar on 2000/03/19 08:49:27 + Log: mention need to wait for children (from Russ Allbery) + Branch: perl + ! lib/IPC/Open2.pm lib/IPC/Open3.pm pod/perldelta.pod +____________________________________________________________________________ +[ 5825] By: gsar on 2000/03/19 08:47:52 + Log: Pod::Man should strip leading lib/ for module manpages (from + Russ Allbery) + Branch: perl + ! lib/Pod/Man.pm +____________________________________________________________________________ +[ 5824] By: gsar on 2000/03/19 08:17:49 + Log: User::pwent fixups for additional fields (from Tom Christiansen); + fix bug in pw_has(); tolerate absense of pw{change,age,quota} + and pw{comment,class} (Debian 2.1 doesn't have either of these) + Branch: perl + ! lib/User/pwent.pm +____________________________________________________________________________ +[ 5823] By: gsar on 2000/03/19 07:41:46 + Log: pod typo fixes (from Marcel Grunauer <marcel.grunauer@lovely.net>) + Branch: perl + ! embed.pl embedvar.h hints/linux.sh pod/perlhack.pod + ! pod/perlnumber.pod pod/perlthrtut.pod vms/ext/Stdio/Stdio.pm +____________________________________________________________________________ +[ 5822] By: gsar on 2000/03/19 07:34:29 + Log: integrate cfgperl contents into mainline + Branch: perl + ! ext/Thread/Thread.pm pod/perlthrtut.pod + !> (integrate 41 files) +____________________________________________________________________________ +[ 5821] By: gsar on 2000/03/19 07:14:38 + Log: remove dead code + Branch: perl + ! lib/charnames.pm +____________________________________________________________________________ +[ 5820] By: gsar on 2000/03/19 07:13:01 + Log: fix typo + Branch: perl + ! pod/perldiag.pod +____________________________________________________________________________ +[ 5819] By: gsar on 2000/03/19 07:09:32 + Log: produce better error message when \N{...} is used without + "use charnames ..." + Branch: perl + ! pod/perldelta.pod pod/perldiag.pod toke.c +____________________________________________________________________________ +[ 5818] By: gsar on 2000/03/19 06:30:11 + Log: default warnLevel and dieLevel to 0 in debugger (from Tom + Christiansen); make dumpvar.pl safe against non-glob entries + in stashes + Branch: perl + ! lib/Dumpvalue.pm lib/dumpvar.pl lib/perl5db.pl + ! pod/perldebug.pod +____________________________________________________________________________ +[ 5817] By: gsar on 2000/03/19 06:18:24 + Log: better notes on s///ee (from Simon Cozens <simon@cozens.net>) + Branch: perl + ! pod/perlop.pod +____________________________________________________________________________ +[ 5816] By: gsar on 2000/03/19 05:55:52 + Log: support for C<use vmsish 'hushed'>; move VMSISH_EXIT out of + op_private (from Charles Lane <lane@DUPHY4.Physics.Drexel.Edu>) + Branch: perl + ! embed.pl op.c op.h opcode.h opcode.pl perl.h pp.sym pp_ctl.c + ! pp_proto.h vms/ext/vmsish.pm vms/ext/vmsish.t vms/vmsish.h +____________________________________________________________________________ +[ 5815] By: gsar on 2000/03/19 05:27:31 + Log: fix sort optimizer to not hang inside loops + Branch: perl + ! op.c t/op/sort.t +____________________________________________________________________________ +[ 5814] By: gsar on 2000/03/19 03:59:29 + Log: fixes for alias handling in debugger (from Tom Christiansen) + Branch: perl + ! lib/perl5db.pl +____________________________________________________________________________ +[ 5813] By: gsar on 2000/03/19 03:38:10 + Log: warn about CHECK and INIT blocks encountered at run time + Branch: perl + ! op.c pod/perldelta.pod pod/perldiag.pod t/pragma/warn/op +____________________________________________________________________________ +[ 5812] By: jhi on 2000/03/19 03:15:58 + Log: Taint msgrcv() messages; general SysV IPC cleanup. + Branch: cfgperl + ! doio.c ext/IPC/SysV/Msg.pm pod/perldelta.pod pod/perlfunc.pod + ! pod/perlipc.pod pod/perlsec.pod t/lib/ipc_sysv.t t/op/taint.t +____________________________________________________________________________ +[ 5811] By: jhi on 2000/03/19 01:48:47 + Log: Taint shmread(). + Branch: cfgperl + ! doio.c pod/perldelta.pod pod/perlfunc.pod pod/perlsec.pod + ! t/op/taint.t +____________________________________________________________________________ +[ 5810] By: jhi on 2000/03/19 01:22:47 + Log: Taint also the passwd field of the getpw*(). + Branch: cfgperl + ! pod/perldelta.pod pod/perlfunc.pod pod/perlsec.pod pp_sys.c + ! t/op/taint.t +____________________________________________________________________________ +[ 5809] By: jhi on 2000/03/18 21:44:34 + Log: Integrate with Sarathy. + Branch: cfgperl + !> t/pragma/strict-vars toke.c +____________________________________________________________________________ +[ 5808] By: jhi on 2000/03/18 21:40:55 + Log: (Re-)introduce $uidsign and $gidsign. + Branch: cfgperl + ! Configure Porting/Glossary Porting/config.sh Porting/config_H + ! config_h.SH epoc/config.sh pp_sys.c vms/subconfigure.com + ! vos/config.def vos/config.h vos/config_h.SH_orig + ! win32/config.bc win32/config.gc win32/config.vc + ! win32/config_H.bc win32/config_H.gc win32/config_H.vc + ! win32/config_h.PL win32/config_sh.PL + Branch: metaconfig + ! U/modified/groupstype.U U/typedefs/gidtype.U +____________________________________________________________________________ +[ 5807] By: jhi on 2000/03/18 20:38:12 + Log: The #5805 requires a test change, too. + Branch: cfgperl + ! t/op/taint.t +____________________________________________________________________________ +[ 5806] By: gsar on 2000/03/18 20:10:29 + Log: queued errors may not be displayed after the PL_error_count limit + Branch: perl + ! t/pragma/strict-vars toke.c +____________________________________________________________________________ +[ 5805] By: jhi on 2000/03/18 19:56:12 + Log: Taint the shell from the getpw*. + Branch: cfgperl + ! pod/perldelta.pod pod/perlfunc.pod pod/perlsec.pod pp_sys.c +____________________________________________________________________________ +[ 5804] By: jhi on 2000/03/18 19:37:01 + Log: Use the newSVuv(). + Branch: cfgperl + ! embed.h op.c pp_sys.c toke.c +____________________________________________________________________________ +[ 5803] By: jhi on 2000/03/18 19:08:40 + Log: Add newSVuv(). + Branch: cfgperl + ! Configure embed.pl global.sym objXSUB.h perlapi.c perlapi.h + ! pod/perlapi.pod proto.h sv.c +____________________________________________________________________________ +[ 5802] By: jhi on 2000/03/18 17:11:07 + Log: Configure nits: rewording from Sarathy (aka #5796), + and installation directories patch from Robin Parker. + Branch: cfgperl + ! Configure Porting/Glossary Porting/config.sh Porting/config_H + ! config_h.SH vos/config.h vos/config_h.SH_orig + ! win32/config_H.bc win32/config_H.gc win32/config_H.vc + Branch: metaconfig + ! U/modified/Getfile.U + Branch: metaconfig/U/perl + ! bincompat5005.U +____________________________________________________________________________ +[ 5801] By: jhi on 2000/03/18 16:41:31 + Log: Integrate with Sarathy. + Branch: cfgperl + !> Changes Configure hints/dos_djgpp.sh lib/ExtUtils/xsubpp + !> lib/Getopt/Long.pm mg.c pod/perlpod.pod pp_hot.c + !> t/lib/charnames.t t/pragma/utf8.t toke.c +____________________________________________________________________________ +[ 5800] By: gsar on 2000/03/18 05:16:32 + Log: force i_ieeefp=undef on dos_djgpp (it reportedly causes failures + in system includes) + Branch: perl + ! hints/dos_djgpp.sh +____________________________________________________________________________ +[ 5799] By: gsar on 2000/03/18 05:12:00 + Log: Getopt::Long 2.23 update (from Johan Vromans) + Branch: perl + ! Changes lib/Getopt/Long.pm +____________________________________________________________________________ [ 5798] By: gsar on 2000/03/18 05:03:20 Log: recognize single-line declarations in xsubpp; add switches to disable newfangled features (from Ilya Zakharevich) @@ -13881,7 +13881,7 @@ EOM esac ;; *) : no sockets, so pick relatively harmless defaults - socksizetype='char *' + socksizetype='unsigned' ;; esac @@ -1134,6 +1134,7 @@ #define ck_eval Perl_ck_eval #define ck_exec Perl_ck_exec #define ck_exists Perl_ck_exists +#define ck_exit Perl_ck_exit #define ck_ftst Perl_ck_ftst #define ck_fun Perl_ck_fun #define ck_fun_locale Perl_ck_fun_locale @@ -2568,6 +2569,7 @@ #define ck_eval(a) Perl_ck_eval(aTHX_ a) #define ck_exec(a) Perl_ck_exec(aTHX_ a) #define ck_exists(a) Perl_ck_exists(aTHX_ a) +#define ck_exit(a) Perl_ck_exit(aTHX_ a) #define ck_ftst(a) Perl_ck_ftst(aTHX_ a) #define ck_fun(a) Perl_ck_fun(aTHX_ a) #define ck_fun_locale(a) Perl_ck_fun_locale(aTHX_ a) @@ -4982,6 +4984,8 @@ #define ck_exec Perl_ck_exec #define Perl_ck_exists CPerlObj::Perl_ck_exists #define ck_exists Perl_ck_exists +#define Perl_ck_exit CPerlObj::Perl_ck_exit +#define ck_exit Perl_ck_exit #define Perl_ck_ftst CPerlObj::Perl_ck_ftst #define ck_ftst Perl_ck_ftst #define Perl_ck_fun CPerlObj::Perl_ck_fun @@ -688,7 +688,7 @@ print EM <<'END'; #endif /* PERL_GLOBAL_STRUCT */ -#ifdef PERL_POLLUTE /* disabled by default in 5.006 */ +#ifdef PERL_POLLUTE /* disabled by default in 5.6.0 */ END @@ -870,6 +870,7 @@ print CAPIH <<'EOT'; #endif /* __perlapi_h__ */ EOT +close CAPIH; print CAPI <<'EOT'; /* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! diff --git a/embedvar.h b/embedvar.h index f8387c519d..e790976a18 100644 --- a/embedvar.h +++ b/embedvar.h @@ -1666,7 +1666,7 @@ #endif /* PERL_GLOBAL_STRUCT */ -#ifdef PERL_POLLUTE /* disabled by default in 5.006 */ +#ifdef PERL_POLLUTE /* disabled by default in 5.6.0 */ #define DBsingle PL_DBsingle #define DBsub PL_DBsub diff --git a/ext/Thread/Thread.pm b/ext/Thread/Thread.pm index 3e50a99cd4..00cba8af67 100644 --- a/ext/Thread/Thread.pm +++ b/ext/Thread/Thread.pm @@ -36,16 +36,15 @@ Thread - manipulate threads in Perl (EXPERIMENTAL, subject to change) =head1 DESCRIPTION -The C<Thread> module provides multithreading support for perl. - -WARNING: Threading is an experimental feature. Both the interface -and implementation are subject to change drastically. + WARNING: Threading is an experimental feature. Both the interface + and implementation are subject to change drastically. In fact, this + documentation describes the flavor of threads that was in version + 5.005. Perl 5.6.0 and later have the beginnings of support for + interpreter threads, which (when finished) is expected to be + significantly different from what is described here. The information + contained here may therefore soon be obsolete. Use at your own risk! -In fact, this documentation describes the flavor of threads that was in -version 5.005. Perl v5.6 has the beginnings of support for interpreter -threads, which (when finished) is expected to be significantly different -from what is described here. The information contained here may therefore -soon be obsolete. Use at your own risk! +The C<Thread> module provides multithreading support for perl. =head1 FUNCTIONS diff --git a/hints/linux.sh b/hints/linux.sh index 80fda07591..4fb2f89e7c 100644 --- a/hints/linux.sh +++ b/hints/linux.sh @@ -63,7 +63,7 @@ ignore_versioned_solibs='y' # intending to replace /usr/bin/perl (at least just yet). # This change makes linux consistent with most other unix platforms # in having a default of prefix=/usr/local. -# These notes can probably safely be removed in 5.006_50 and beyond. +# These notes can probably safely be removed in 5.005_50 and beyond. # # 9 April 1999 Andy Dougherty <doughera@lafayette.edu> # diff --git a/lib/Dumpvalue.pm b/lib/Dumpvalue.pm index 94b6aa6e78..5d3a9dafc2 100644 --- a/lib/Dumpvalue.pm +++ b/lib/Dumpvalue.pm @@ -404,7 +404,8 @@ sub dumpvars { next if @vars && !grep( matchvar($key, $_), @vars ); if ($self->{usageOnly}) { $self->globUsage(\$val, $key) - unless $package eq 'Dumpvalue' and $key eq 'stab'; + if ($package ne 'Dumpvalue' or $key ne 'stab') + and ref(\$val) eq 'GLOB'; } else { $self->dumpglob($package, 0,$key, $val); } diff --git a/lib/IPC/Open2.pm b/lib/IPC/Open2.pm index 161620ba24..a5a3561794 100644 --- a/lib/IPC/Open2.pm +++ b/lib/IPC/Open2.pm @@ -55,6 +55,13 @@ failure: it just raises an exception matching C</^open2:/>. However, C<exec> failures in the child are not detected. You'll have to trap SIGPIPE yourself. +open2() does not wait for and reap the child process after it exits. +Except for short programs where it's acceptable to let the operating system +take care of this, you need to do this yourself. This is normally as +simple as calling C<waitpid $pid, 0> when you're done with the process. +Failing to do this can result in an accumulation of defunct or "zombie" +processes. See L<perlfunc/waitpid> for more information. + This whole affair is quite dangerous, as you may block forever. It assumes it's going to talk to something like B<bc>, both writing to it and reading from it. This is presumably safe because you diff --git a/lib/IPC/Open3.pm b/lib/IPC/Open3.pm index d43f1bdb4b..99709ac0ca 100644 --- a/lib/IPC/Open3.pm +++ b/lib/IPC/Open3.pm @@ -49,6 +49,13 @@ failure: it just raises an exception matching C</^open3:/>. However, C<exec> failures in the child are not detected. You'll have to trap SIGPIPE yourself. +open2() does not wait for and reap the child process after it exits. +Except for short programs where it's acceptable to let the operating system +take care of this, you need to do this yourself. This is normally as +simple as calling C<waitpid $pid, 0> when you're done with the process. +Failing to do this can result in an accumulation of defunct or "zombie" +processes. See L<perlfunc/waitpid> for more information. + If you try to read from the child's stdout writer and their stderr writer, you'll have problems with blocking, which means you'll want to use select() or the IO::Select, which means you'd best use diff --git a/lib/Pod/Man.pm b/lib/Pod/Man.pm index 11601e5072..97a382823e 100644 --- a/lib/Pod/Man.pm +++ b/lib/Pod/Man.pm @@ -1,5 +1,5 @@ # Pod::Man -- Convert POD data to formatted *roff input. -# $Id: Man.pm,v 1.1 2000/03/16 22:00:36 eagle Exp $ +# $Id: Man.pm,v 1.2 2000/03/19 07:30:13 eagle Exp $ # # Copyright 1999, 2000 by Russ Allbery <rra@stanford.edu> # @@ -38,7 +38,7 @@ use vars qw(@ISA %ESCAPES $PREAMBLE $VERSION); # Perl core and too many things could munge CVS magic revision strings. # This number should ideally be the same as the CVS revision in podlators, # however. -$VERSION = 1.01; +$VERSION = 1.02; ############################################################################ @@ -396,7 +396,8 @@ sub begin_pod { # */lib/*perl* standard or site_perl module # */*perl*/lib from -D prefix=/opt/perl # */*perl*/ random module hierarchy - # which works. Should be fixed to use File::Spec. + # which works. Should be fixed to use File::Spec. Also handle + # a leading lib/ since that's what ExtUtils::MakeMaker creates. for ($name) { s%//+%/%g; if ( s%^.*?/lib/[^/]*perl[^/]*/%%si @@ -405,6 +406,7 @@ sub begin_pod { s%^(.*-$^O|$^O-.*)/%%so; # arch s%^\d+\.\d+%%s; # version } + s%^lib/%%; s%/%::%g; } } diff --git a/lib/User/pwent.pm b/lib/User/pwent.pm index 39bfea4fe0..f41aa2ab5a 100644 --- a/lib/User/pwent.pm +++ b/lib/User/pwent.pm @@ -1,51 +1,179 @@ package User::pwent; + +use 5.006; + use strict; +use warnings; + +use Config; +use Carp; -use 5.005_64; our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); -BEGIN { +BEGIN { use Exporter (); @EXPORT = qw(getpwent getpwuid getpwnam getpw); @EXPORT_OK = qw( - $pw_name $pw_passwd $pw_uid - $pw_gid $pw_quota $pw_comment - $pw_gecos $pw_dir $pw_shell - ); - %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); + pw_has + + $pw_name $pw_passwd $pw_uid $pw_gid + $pw_gecos $pw_dir $pw_shell + $pw_expire $pw_change $pw_class + $pw_age + $pw_quota $pw_comment + $pw_expire + + ); + %EXPORT_TAGS = ( + FIELDS => [ grep(/^\$pw_/, @EXPORT_OK), @EXPORT ], + ALL => [ @EXPORT, @EXPORT_OK ], + ); } -use vars @EXPORT_OK; +use vars grep /^\$pw_/, @EXPORT_OK; + +# +# XXX: these mean somebody hacked this module's source +# without understanding the underlying assumptions. +# +my $IE = "[INTERNAL ERROR]"; # Class::Struct forbids use of @ISA sub import { goto &Exporter::import } use Class::Struct qw(struct); struct 'User::pwent' => [ - name => '$', - passwd => '$', - uid => '$', - gid => '$', - quota => '$', - comment => '$', - gecos => '$', - dir => '$', - shell => '$', + name => '$', # pwent[0] + passwd => '$', # pwent[1] + uid => '$', # pwent[2] + gid => '$', # pwent[3] + + # you'll only have one/none of these three + change => '$', # pwent[4] + age => '$', # pwent[4] + quota => '$', # pwent[4] + + # you'll only have one/none of these two + comment => '$', # pwent[5] + class => '$', # pwent[5] + + # you might not have this one + gecos => '$', # pwent[6] + + dir => '$', # pwent[7] + shell => '$', # pwent[8] + + # you might not have this one + expire => '$', # pwent[9] + ]; -sub populate (@) { + +# init our groks hash to be true if the built platform knew how +# to do each struct pwd field that perl can ever under any circumstances +# know about. we do not use /^pw_?/, but just the tails. +sub _feature_init { + our %Groks; # whether build system knew how to do this feature + for my $feep ( qw{ + pwage pwchange pwclass pwcomment + pwexpire pwgecos pwpasswd pwquota + } + ) + { + my $short = $feep =~ /^pw(.*)/ + ? $1 + : do { + # not cluck, as we know we called ourselves, + # and a confession is probably imminent anyway + warn("$IE $feep is a funny struct pwd field"); + $feep; + }; + + exists $Config{ "d_" . $feep } + || confess("$IE Configure doesn't d_$feep"); + $Groks{$short} = defined $Config{ "d_" . $feep }; + } + # assume that any that are left are always there + for my $feep (grep /^\$pw_/s, @EXPORT_OK) { + $feep =~ /^\$pw_(.*)/; + $Groks{$1} = 1 unless defined $Groks{$1}; + } +} + +# With arguments, reports whether one or more fields are all implemented +# in the build machine's struct pwd pw_*. May be whitespace separated. +# We do not use /^pw_?/, just the tails. +# +# Without arguments, returns the list of fields implemented on build +# machine, space separated in scalar context. +# +# Takes exception to being asked whether this machine's struct pwd has +# a field that Perl never knows how to provide under any circumstances. +# If the module does this idiocy to itself, the explosion is noisier. +# +sub pw_has { + our %Groks; # whether build system knew how to do this feature + my $cando = 1; + my $sploder = caller() ne __PACKAGE__ + ? \&croak + : sub { confess("$IE @_") }; + if (@_ == 0) { + my @valid = sort grep { $Groks{$_} } keys %Groks; + return wantarray ? @valid : "@valid"; + } + for my $feep (map { split } @_) { + defined $Groks{$feep} + || $sploder->("$feep is never a valid struct pwd field"); + $cando &&= $Groks{$feep}; + } + return $cando; +} + +sub _populate (@) { return unless @_; my $pwob = new(); - ( $pw_name, $pw_passwd, $pw_uid, - $pw_gid, $pw_quota, $pw_comment, - $pw_gecos, $pw_dir, $pw_shell, ) = @$pwob = @_; + # Any that haven't been pw_had are assumed on "all" platforms of + # course, this may not be so, but you can't get here otherwise, + # since the underlying core call already took exception to your + # impudence. + + $pw_name = $pwob->name ( $_[0] ); + $pw_passwd = $pwob->passwd ( $_[1] ) if pw_has("passwd"); + $pw_uid = $pwob->uid ( $_[2] ); + $pw_gid = $pwob->gid ( $_[3] ); + + if (pw_has("change")) { + $pw_change = $pwob->change ( $_[4] ); + } + elsif (pw_has("age")) { + $pw_age = $pwob->age ( $_[4] ); + } + elsif (pw_has("quota")) { + $pw_quota = $pwob->quota ( $_[4] ); + } + + if (pw_has("class")) { + $pw_class = $pwob->class ( $_[5] ); + } + elsif (pw_has("comment")) { + $pw_comment = $pwob->comment( $_[5] ); + } + + $pw_gecos = $pwob->gecos ( $_[6] ) if pw_has("gecos"); + + $pw_dir = $pwob->dir ( $_[7] ); + $pw_shell = $pwob->shell ( $_[8] ); + + $pw_expire = $pwob->expire ( $_[9] ) if pw_has("expire"); return $pwob; -} +} -sub getpwent ( ) { populate(CORE::getpwent()) } -sub getpwnam ($) { populate(CORE::getpwnam(shift)) } -sub getpwuid ($) { populate(CORE::getpwuid(shift)) } -sub getpw ($) { ($_[0] =~ /^\d+/) ? &getpwuid : &getpwnam } +sub getpwent ( ) { _populate(CORE::getpwent()) } +sub getpwnam ($) { _populate(CORE::getpwnam(shift)) } +sub getpwuid ($) { _populate(CORE::getpwuid(shift)) } +sub getpw ($) { ($_[0] =~ /^\d+\z/s) ? &getpwuid : &getpwnam } + +_feature_init(); 1; __END__ @@ -57,42 +185,95 @@ User::pwent - by-name interface to Perl's built-in getpw*() functions =head1 SYNOPSIS use User::pwent; - $pw = getpwnam('daemon') or die "No daemon user"; - if ( $pw->uid == 1 && $pw->dir =~ m#^/(bin|tmp)?$# ) { + $pw = getpwnam('daemon') || die "No daemon user"; + if ( $pw->uid == 1 && $pw->dir =~ m#^/(bin|tmp)?\z#s ) { print "gid 1 on root dir"; - } + } + + $real_shell = $pw->shell || '/bin/sh'; + + for (($fullname, $office, $workphone, $homephone) = + split /\s*,\s*/, $pw->gecos) + { + s/&/ucfirst(lc($pw->name))/ge; + } use User::pwent qw(:FIELDS); - getpwnam('daemon') or die "No daemon user"; - if ( $pw_uid == 1 && $pw_dir =~ m#^/(bin|tmp)?$# ) { + getpwnam('daemon') || die "No daemon user"; + if ( $pw_uid == 1 && $pw_dir =~ m#^/(bin|tmp)?\z#s ) { print "gid 1 on root dir"; - } + } $pw = getpw($whoever); + use User::pwent qw/:DEFAULT pw_has/; + if (pw_has(qw[gecos expire quota])) { .... } + if (pw_has("name uid gid passwd")) { .... } + print "Your struct pwd has: ", scalar pw_has(), "\n"; + =head1 DESCRIPTION This module's default exports override the core getpwent(), getpwuid(), and getpwnam() functions, replacing them with versions that return -"User::pwent" objects. This object has methods that return the similarly -named structure field name from the C's passwd structure from F<pwd.h>; -namely name, passwd, uid, gid, quota, comment, gecos, dir, and shell. +C<User::pwent> objects. This object has methods that return the +similarly named structure field name from the C's passwd structure +from F<pwd.h>, stripped of their leading "pw_" parts, namely C<name>, +C<passwd>, C<uid>, C<gid>, C<change>, C<age>, C<quota>, C<comment>, +C<class>, C<gecos>, C<dir>, C<shell>, and C<expire>. The C<passwd>, +C<gecos>, and C<shell> fields are tainted when running in taint mode. -You may also import all the structure fields directly into your namespace -as regular variables using the :FIELDS import tag. (Note that this still -overrides your core functions.) Access these fields as -variables named with a preceding C<pw_> in front their method names. -Thus, C<$passwd_obj-E<gt>shell()> corresponds to $pw_shell if you import -the fields. +You may also import all the structure fields directly into your +namespace as regular variables using the :FIELDS import tag. (Note +that this still overrides your core functions.) Access these fields +as variables named with a preceding C<pw_> in front their method +names. Thus, C<< $passwd_obj->shell >> corresponds to $pw_shell +if you import the fields. The getpw() function is a simple front-end that forwards a numeric argument to getpwuid() and the rest to getpwnam(). -To access this functionality without the core overrides, -pass the C<use> an empty import list, and then access -function functions with their full qualified names. -On the other hand, the built-ins are still available -via the C<CORE::> pseudo-package. +To access this functionality without the core overrides, pass the +C<use> an empty import list, and then access function functions +with their full qualified names. The built-ins are always still +available via the C<CORE::> pseudo-package. + +=head2 System Specifics + +Perl believes that no machine ever has more than one of C<change>, +C<age>, or C<quota> implemented, nor more than one of either +C<comment> or C<class>. Some machines do not support C<expire>, +C<gecos>, or allegedly, C<passwd>. You may call these methods +no matter what machine you're on, but they return C<undef> if +unimplemented. + +You may ask whether one of these was implemented on the system Perl +was built on by asking the importable C<pw_has> function about them. +This function returns true if all parameters are supported fields +on the build platform, false if one or more were not, and raises +and exception if you asked about a field that Perl never knows how +to provide. Parameters may be in a space-separated string, or as +separate arguments. If you pass no parameters, the function returns +the list of C<struct pwd> fields supported by your build platform's +C library, as a list in list context, or a space-separated string +in scalar context. Note that just because your C library had +a field doesn't necessarily mean that it's fully implemented on +that system. + +Interpretation of the C<gecos> field varies between systems, but +traditionally holds 4 comma-separated fields containing the user's +full name, office location, work phone number, and home phone number. +An C<&> in the gecos field should be replaced by the user's properly +capitalized login C<name>. The C<shell> field, if blank, must be +assumed to be F</bin/sh>. Perl does not do this for you. The +C<passwd> is one-way hashed garble, not clear text, and may not be +unhashed save by brute-force guessing. Secure systems use more a +more secure hashing than DES. On systems supporting shadow password +systems, Perl automatically returns the shadow password entry when +called by a suitably empowered user, even if your underlying +vendor-provided C library was too short-sighted to realize it should +do this. + +See passwd(5) and getpwent(3) for details. =head1 NOTE @@ -102,3 +283,15 @@ module to build a struct-like class, you shouldn't rely upon this. =head1 AUTHOR Tom Christiansen + +=head1 HISTORY + +=over + +=item March 18th, 2000 + +Reworked internals to support better interface to dodgey fields +than normal Perl function provides. Added pw_has() field. Improved +documentation. + +=back diff --git a/lib/charnames.pm b/lib/charnames.pm index 21b4dd61bc..7c2209b9f0 100644 --- a/lib/charnames.pm +++ b/lib/charnames.pm @@ -2,7 +2,6 @@ package charnames; use bytes (); # for $bytes::hint_bits $charnames::hint_bits = 0x20000; -my $fname = 'unicode/UnicodeData-Latest.txt'; my $txt; # This is not optimized in any way yet diff --git a/lib/dumpvar.pl b/lib/dumpvar.pl index c72781801b..4a3041a02b 100644 --- a/lib/dumpvar.pl +++ b/lib/dumpvar.pl @@ -361,7 +361,9 @@ sub main::dumpvar { return if $DB::signal; next if @vars && !grep( matchvar($key, $_), @vars ); if ($usageOnly) { - globUsage(\$val, $key) unless $package eq 'dumpvar' and $key eq 'stab'; + globUsage(\$val, $key) + if ($package ne 'dumpvar' or $key ne 'stab') + and ref(\$val) eq 'GLOB'; } else { dumpglob(0,$key, $val); } diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 50844d28f8..132e08e0bd 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -273,13 +273,13 @@ $inhibit_exit = $option{PrintRet} = 1; ); # These guys may be defined in $ENV{PERL5DB} : -$rl = 1 unless defined $rl; -$warnLevel = 1 unless defined $warnLevel; -$dieLevel = 1 unless defined $dieLevel; -$signalLevel = 1 unless defined $signalLevel; -$pre = [] unless defined $pre; -$post = [] unless defined $post; -$pretype = [] unless defined $pretype; +$rl = 1 unless defined $rl; +$warnLevel = 0 unless defined $warnLevel; +$dieLevel = 0 unless defined $dieLevel; +$signalLevel = 1 unless defined $signalLevel; +$pre = [] unless defined $pre; +$post = [] unless defined $post; +$pretype = [] unless defined $pretype; warnLevel($warnLevel); dieLevel($dieLevel); @@ -604,16 +604,19 @@ EOP $cmd =~ /^$/ && ($cmd = $laststep); push(@hist,$cmd) if length($cmd) > 1; PIPE: { + $cmd =~ s/^\s+//s; # trim annoying leading whitespace + $cmd =~ s/\s+$//s; # trim annoying trailing whitespace ($i) = split(/\s+/,$cmd); - #eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i}; if ($alias{$i}) { - print STDERR "ALIAS $cmd INTO "; + # squelch the sigmangler + local $SIG{__DIE__}; + local $SIG{__WARN__}; eval "\$cmd =~ $alias{$i}"; - print "$cmd\n"; - print $OUT $@; + if ($@) { + print $OUT "Couldn't evaluate `$i' alias: $@"; + next CMD; + } } - $cmd =~ s/^\s+//s; # trim annoying leading whitespace - $cmd =~ s/\s+$//s; # trim annoying trailing whitespace $cmd =~ /^q$/ && ($exiting = 1) && exit 0; $cmd =~ /^h$/ && do { print_help($help); @@ -1211,6 +1214,9 @@ EOP $inpat = $1; $inpat =~ s:([^\\])/$:$1:; if ($inpat ne "") { + # squelch the sigmangler + local $SIG{__DIE__}; + local $SIG{__WARN__}; eval '$inpat =~ m'."\a$inpat\a"; if ($@ ne "") { print $OUT "$@"; @@ -1240,9 +1246,12 @@ EOP $inpat = $1; $inpat =~ s:([^\\])\?$:$1:; if ($inpat ne "") { + # squelch the sigmangler + local $SIG{__DIE__}; + local $SIG{__WARN__}; eval '$inpat =~ m'."\a$inpat\a"; if ($@ ne "") { - print $OUT "$@"; + print $OUT $@; next CMD; } $pat = $inpat; @@ -1308,19 +1317,39 @@ EOP next CMD; }; $cmd =~ s/^p$/print {\$DB::OUT} \$_/; $cmd =~ s/^p\b/print {\$DB::OUT} /; - $cmd =~ /^=/ && do { - if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) { - $alias{$k}="s~$k~$v~"; - print $OUT "$k = $v\n"; - } elsif ($cmd =~ /^=\s*$/) { - foreach $k (sort keys(%alias)) { - if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) { - print $OUT "$k = $v\n"; - } else { + $cmd =~ s/^=\s*// && do { + my @keys; + if (length $cmd == 0) { + @keys = sort keys %alias; + } + elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) { + # can't use $_ or kill //g state + for my $x ($k, $v) { $x =~ s/\a/\\a/g } + $alias{$k} = "s\a$k\a$v\a"; + # squelch the sigmangler + local $SIG{__DIE__}; + local $SIG{__WARN__}; + unless (eval "sub { s\a$k\a$v\a }; 1") { + print $OUT "Can't alias $k to $v: $@\n"; + delete $alias{$k}; + next CMD; + } + @keys = ($k); + } + else { + @keys = ($cmd); + } + for my $k (@keys) { + if ((my $v = $alias{$k}) =~ ss\a$k\a(.*)\a$1) { + print $OUT "$k\t= $1\n"; + } + elsif (defined $alias{$k}) { print $OUT "$k\t$alias{$k}\n"; - }; - }; - }; + } + else { + print "No alias for $k\n"; + } + } next CMD; }; $cmd =~ /^\|\|?\s*[^|]/ && do { if ($pager =~ /^\|/) { @@ -1716,7 +1745,7 @@ sub setterm { $| = 1; select($sel); } else { - eval "require Term::Rendezvous;" or die $@; + eval "require Term::Rendezvous;" or die; my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$"; my $term_rv = new Term::Rendezvous $rv; $IN = $term_rv->IN; @@ -4656,6 +4656,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (!PL_checkav) PL_checkav = newAV(); DEBUG_x( dump_sub(gv) ); + if (PL_main_start && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block"); av_unshift(PL_checkav, 1); av_store(PL_checkav, 0, SvREFCNT_inc(cv)); GvCV(gv) = 0; @@ -4664,6 +4666,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (!PL_initav) PL_initav = newAV(); DEBUG_x( dump_sub(gv) ); + if (PL_main_start && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block"); av_push(PL_initav, SvREFCNT_inc(cv)); GvCV(gv) = 0; } @@ -4804,6 +4808,8 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) else if (strEQ(s, "CHECK")) { if (!PL_checkav) PL_checkav = newAV(); + if (PL_main_start && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block"); av_unshift(PL_checkav, 1); av_store(PL_checkav, 0, SvREFCNT_inc(cv)); GvCV(gv) = 0; @@ -4811,6 +4817,8 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) else if (strEQ(s, "INIT")) { if (!PL_initav) PL_initav = newAV(); + if (PL_main_start && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block"); av_push(PL_initav, SvREFCNT_inc(cv)); GvCV(gv) = 0; } @@ -5156,6 +5164,20 @@ Perl_ck_eval(pTHX_ OP *o) } OP * +Perl_ck_exit(pTHX_ OP *o) +{ +#ifdef VMS + HV *table = GvHV(PL_hintgv); + if (table) { + SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE); + if (svp && *svp && SvTRUE(*svp)) + o->op_private |= OPpEXIT_VMSISH; + } +#endif + return ck_fun(o); +} + +OP * Perl_ck_exec(pTHX_ OP *o) { OP *kid; @@ -5992,6 +6014,12 @@ Perl_ck_sort(pTHX_ OP *o) for (k = kLISTOP->op_first->op_next; k; k = k->op_next) { if (k->op_next == kid) k->op_next = 0; + /* don't descend into loops */ + else if (k->op_type == OP_ENTERLOOP + || k->op_type == OP_ENTERITER) + { + k = cLOOPx(k)->op_lastop; + } } } else @@ -203,6 +203,9 @@ Deprecated. Use C<GIMME_V> instead. #define OPpOPEN_OUT_RAW 64 /* binmode(F,":raw") on output fh */ #define OPpOPEN_OUT_CRLF 128 /* binmode(F,":crlf") on output fh */ +/* Private for OP_EXIT */ +#define OPpEXIT_VMSISH 128 /* exit(0) vs. exit(1) vmsish mode*/ + struct op { BASEOP }; @@ -1284,7 +1284,7 @@ EXT OP * (CPERLscope(*PL_check)[]) (pTHX_ OP *op) = { MEMBER_TO_FPTR(Perl_ck_null), /* redo */ MEMBER_TO_FPTR(Perl_ck_null), /* dump */ MEMBER_TO_FPTR(Perl_ck_null), /* goto */ - MEMBER_TO_FPTR(Perl_ck_fun), /* exit */ + MEMBER_TO_FPTR(Perl_ck_exit), /* exit */ MEMBER_TO_FPTR(Perl_ck_open), /* open */ MEMBER_TO_FPTR(Perl_ck_fun), /* close */ MEMBER_TO_FPTR(Perl_ck_fun), /* pipe_op */ @@ -597,7 +597,7 @@ next next ck_null ds} redo redo ck_null ds} dump dump ck_null ds} goto goto ck_null ds} -exit exit ck_fun ds% S? +exit exit ck_exit ds% S? # continued below #nswitch numeric switch ck_null d @@ -1652,7 +1652,7 @@ typedef pthread_key_t perl_key; #ifdef VMS # define STATUS_NATIVE PL_statusvalue_vms # define STATUS_NATIVE_EXPORT \ - ((I32)PL_statusvalue_vms == -1 ? 44 : PL_statusvalue_vms) + (((I32)PL_statusvalue_vms == -1 ? 44 : PL_statusvalue_vms) | (VMSISH_HUSHED ? 0x10000000 : 0)) # define STATUS_NATIVE_SET(n) \ STMT_START { \ PL_statusvalue_vms = (n); \ diff --git a/pod/perlapi.pod b/pod/perlapi.pod index 32e77d6f07..e0ae4cfb58 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -1597,17 +1597,17 @@ false, defined or undefined. Does not handle 'get' magic. bool SvTRUE(SV* sv) -=item svtype - -An enum of flags for Perl types. These are found in the file B<sv.h> -in the C<svtype> enum. Test these flags with the C<SvTYPE> macro. - =item SvTYPE Returns the type of the SV. See C<svtype>. svtype SvTYPE(SV* sv) +=item svtype + +An enum of flags for Perl types. These are found in the file B<sv.h> +in the C<svtype> enum. Test these flags with the C<SvTYPE> macro. + =item SVt_IV Integer type flag for scalars. See C<svtype>. diff --git a/pod/perldebug.pod b/pod/perldebug.pod index ead5414ccf..1750f1a5c0 100644 --- a/pod/perldebug.pod +++ b/pod/perldebug.pod @@ -488,16 +488,23 @@ Run Tk while prompting (with ReadLine). =item C<signalLevel>, C<warnLevel>, C<dieLevel> -Level of verbosity. By default, the debugger prints backtraces -upon receiving any kind of warning (this is often annoying) and -fatal exceptions (this is often valuable). It will attempt to print -a message when uncaught INT, BUS, or SEGV signals arrive. - -To disable this behaviour, set these values to 0. If C<dieLevel> -is 2, the debugger usurps your own exception handler and prints out -a trace of these, replacing your exceptions with its own. This may -be useful for some tracing purposes, but tends to hopelessly destroy -any program that takes its exception handling seriously. +Level of verbosity. By default, the debugger leaves your exceptions +and warnings alone, because altering them can break correctly running +programs. It will attempt to print a message when uncaught INT, BUS, or +SEGV signals arrive. (But see the mention of signals in L<BUGS> below.) + +To disable this default safe mode, set these values to something higher +than 0. At a level of 1, you get backtraces upon receiving any kind +of warning (this is often annoying) or exception (this is +often valuable). Unfortunately, the debugger cannot discern fatal +exceptions from non-fatal ones. If C<dieLevel> is even 1, then your +non-fatal exceptions are also traced and unceremoniously altered if they +came from C<eval'd> strings or from any kind of C<eval> within modules +you're attempting to load. If C<dieLevel> is 2, the debugger doesn't +care where they came from: It usurps your exception handler and prints +out a trace, then modifies all exceptions with its own embellishments. +This may perhaps be useful for some tracing purposes, but tends to hopelessly +destroy any program that takes its exception handling seriously. =item C<AutoTrace> @@ -929,3 +936,9 @@ that were not compiled by Perl, such as those from C or C++ extensions. If you alter your @_ arguments in a subroutine (such as with B<shift> or B<pop>, the stack backtrace will not show the original values. + +If you're in a slow syscall (like C<wait>ing, C<accept>ing, or C<read>ing +from your keyboard or a socket) and haven't set up your own C<$SIG{INT}> +handler, then you won't be able to CTRL-C your way back to the debugger, +because the debugger's own C<$SIG{INT}> handler doesn't understand that +it needs to raise an exception to longjmp(3) out of slow syscalls. diff --git a/pod/perldelta.pod b/pod/perldelta.pod index d4d82f3c2d..f85a819c20 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -206,18 +206,20 @@ will produce different results on platforms that have different $Config{ivsize}. For portability, be sure to mask off the excess bits in the result of unary C<~>, e.g., C<~$x & 0xffffffff>. -=head2 The passwd and shell returned by the getpwxxx() are now tainted +=head2 More builtins taint their results -Because the user can affect her own encrypted password and login shell -the password and shell returned by the getpwent(), getpwnam(), and -getpwuid() functions are tainted. +The C<passwd> and C<shell> fields returned by the getpwent(), getpwnam(), +and getpwuid() are now tainted, because the user can affect their own +encrypted password and login shell. -=head2 The msgrcv() and shmread() now taint +The variable modified by shmread(), and messages returned by msgrcv() +(and its object-oriented interface IPC::SysV::Msg::rcv) are also tainted, +because other untrusted processes can modify messages and shared memory +segments for their own nefarious purposes. -Because other (untrusted) processes can modify messages and shared -memory segments for their own nefarious purposes, the messages -returned by msgrcv() (and its object-oriented interface, -IPC::SysV::Msg::rcv) and the variable modified by shmread() are tainted. +To avoid these new tainting behaviors, you can build Perl with the +Configure option C<-Accflags=-DINCOMPLETE_TAINTS>. Beware that the +ensuing perl binary may be insecure. =back @@ -1972,7 +1974,7 @@ An introduction to Unicode support features in Perl. =item "%s" variable %s masks earlier declaration in same %s -(W) A "my" or "our" variable has been redeclared in the current scope or statement, +(W misc) A "my" or "our" variable has been redeclared in the current scope or statement, effectively eliminating all access to the previous instance. This is almost always a typographical error. Note that the earlier variable will still exist until the end of the scope or until all closure referents to it are @@ -1985,7 +1987,7 @@ yet. =item "our" variable %s redeclared -(W) You seem to have already declared the same global once before in the +(W misc) You seem to have already declared the same global once before in the current lexical scope. =item '!' allowed only after types %s @@ -2020,25 +2022,25 @@ See L<perlfunc/pack>. =item /%s/: Unrecognized escape \\%c passed through -(W) You used a backslash-character combination which is not recognized +(W regexp) You used a backslash-character combination which is not recognized by Perl. This combination appears in an interpolated variable or a C<'>-delimited regular expression. The character was understood literally. =item /%s/: Unrecognized escape \\%c in character class passed through -(W) You used a backslash-character combination which is not recognized +(W regexp) You used a backslash-character combination which is not recognized by Perl inside character classes. The character was understood literally. =item /%s/ should probably be written as "%s" -(W) You have used a pattern where Perl expected to find a string, +(W syntax) You have used a pattern where Perl expected to find a string, as in the first argument to C<join>. Perl will treat the true or false result of matching the pattern against $_ as the string, which is probably not what you had in mind. =item %s() called too early to check prototype -(W) You've called a function that has a prototype before the parser saw a +(W prototype) You've called a function that has a prototype before the parser saw a definition or declaration for it, and Perl could not check that the call conforms to the prototype. You need to either add an early prototype declaration for the subroutine in question, or move the subroutine @@ -2072,14 +2074,14 @@ name, and not a subroutine call. C<exists &sub()> will generate this error. =item %s package attribute may clash with future reserved word: %s -(W) A lowercase attribute name was used that had a package-specific handler. +(W reserved) A lowercase attribute name was used that had a package-specific handler. That name might have a meaning to Perl itself some day, even though it doesn't yet. Perhaps you should use a mixed-case attribute name, instead. See L<attributes>. =item (in cleanup) %s -(W) This prefix usually indicates that a DESTROY() method raised +(W misc) This prefix usually indicates that a DESTROY() method raised the indicated exception. Since destructors are usually called by the system at arbitrary points during execution, and often a vast number of times, the warning is issued only once for any number @@ -2114,7 +2116,7 @@ setting environment variable C<PERL_BADFREE> to 1. =item Bareword found in conditional -(W) The compiler found a bareword where it expected a conditional, +(W bareword) The compiler found a bareword where it expected a conditional, which often indicates that an || or && was parsed as part of the last argument of the previous construct, for example: @@ -2130,17 +2132,17 @@ The C<strict> pragma is useful in avoiding such errors. =item Binary number > 0b11111111111111111111111111111111 non-portable -(W) The binary number you specified is larger than 2**32-1 +(W portable) The binary number you specified is larger than 2**32-1 (4294967295) and therefore non-portable between systems. See L<perlport> for more on portability concerns. =item Bit vector size > 32 non-portable -(W) Using bit vector sizes larger than 32 is non-portable. +(W portable) Using bit vector sizes larger than 32 is non-portable. =item Buffer overflow in prime_env_iter: %s -(W) A warning peculiar to VMS. While Perl was preparing to iterate over +(W internal) A warning peculiar to VMS. While Perl was preparing to iterate over %ENV, it encountered a logical name or symbol definition which was too long, so it was truncated to the string shown. @@ -2161,7 +2163,7 @@ for other types of variables in future. =item Can't ignore signal CHLD, forcing to default -(W) Perl has detected that it is being run with the SIGCHLD signal +(W signal) Perl has detected that it is being run with the SIGCHLD signal (sometimes known as SIGCLD) disabled. Since disabling this signal will interfere with proper determination of exit status of child processes, Perl has reset the signal to its default value. @@ -2204,7 +2206,7 @@ See L<perlre>. =item Character class syntax [%s] belongs inside character classes -(W) The character class constructs [: :], [= =], and [. .] go +(W unsafe) The character class constructs [: :], [= =], and [. .] go I<inside> character classes, the [] are part of the construct, for example: /[012[:alpha:]345]/. Note that [= =] and [. .] are not currently implemented; they are simply placeholders for @@ -2218,15 +2220,12 @@ message indicates the type of reference that was expected. This usually indicates a syntax error in dereferencing the constant value. See L<perlsub/"Constant Functions"> and L<constant>. -=item constant(%s): %%^H is not localized - -(F) When setting compile-time-lexicalized hash %^H one should set the -corresponding bit of $^H as well. - =item constant(%s): %s -(F) Compile-time-substitutions (such as overloaded constants and -character names) were not correctly set up. +(F) The parser found inconsistencies either while attempting to define an +overloaded constant, or when trying to find the character name specified +in the C<\N{...}> escape. Perhaps you forgot to load the corresponding +C<overload> or C<charnames> pragma? See L<charnames> and L<overload>. =item CORE::%s is not a keyword @@ -2250,7 +2249,7 @@ See Server error. =item Did you mean "local" instead of "our"? -(W) Remember that "our" does not localize the declared global variable. +(W misc) Remember that "our" does not localize the declared global variable. You have declared it again in the same lexical scope, which seems superfluous. =item Document contains no data @@ -2264,14 +2263,14 @@ effective uids or gids failed. =item false [] range "%s" in regexp -(W) A character class range must start and end at a literal character, not +(W regexp) A character class range must start and end at a literal character, not another character class like C<\d> or C<[:alpha:]>. The "-" in your false range is interpreted as a literal "-". Consider quoting the "-", "\-". See L<perlre>. =item Filehandle %s opened only for output -(W) You tried to read from a filehandle opened only for writing. If you +(W io) You tried to read from a filehandle opened only for writing. If you intended it to be a read/write filehandle, you needed to open it with "+<" or "+>" or "+>>" instead of with "<" or nothing. If you intended only to read from the file, use "<". See @@ -2279,7 +2278,7 @@ L<perlfunc/open>. =item flock() on closed filehandle %s -(W) The filehandle you're attempting to flock() got itself closed some +(W closed) The filehandle you're attempting to flock() got itself closed some time before now. Check your logic flow. flock() operates on filehandles. Are you attempting to call flock() on a dirhandle by the same name? @@ -2292,19 +2291,19 @@ is in (using "::"). =item Hexadecimal number > 0xffffffff non-portable -(W) The hexadecimal number you specified is larger than 2**32-1 +(W portable) The hexadecimal number you specified is larger than 2**32-1 (4294967295) and therefore non-portable between systems. See L<perlport> for more on portability concerns. =item Ill-formed CRTL environ value "%s" -(W) A warning peculiar to VMS. Perl tried to read the CRTL's internal +(W internal) A warning peculiar to VMS. Perl tried to read the CRTL's internal environ array, and encountered an element without the C<=> delimiter used to spearate keys from values. The element is ignored. =item Ill-formed message in prime_env_iter: |%s| -(W) A warning peculiar to VMS. Perl tried to read a logical name +(W internal) A warning peculiar to VMS. Perl tried to read a logical name or CLI symbol definition when preparing to iterate over %ENV, and didn't see the expected delimiter between key and value, so the line was ignored. @@ -2315,7 +2314,7 @@ line was ignored. =item Illegal binary digit %s ignored -(W) You may have tried to use a digit other than 0 or 1 in a binary number. +(W digit) You may have tried to use a digit other than 0 or 1 in a binary number. Interpretation of the binary number stopped before the offending digit. =item Illegal number of bits in vec @@ -2325,7 +2324,7 @@ two from 1 to 32 (or 64, if your platform supports that). =item Integer overflow in %s number -(W) The hexadecimal, octal or binary number you have specified either +(W overflow) The hexadecimal, octal or binary number you have specified either as a literal or as an argument to hex() or oct() is too big for your architecture, and has been converted to a floating point number. On a 32-bit architecture the largest hexadecimal, octal or binary number @@ -2385,7 +2384,7 @@ double-quotish context. =item Missing command in piped open -(W) You used the C<open(FH, "| command")> or C<open(FH, "command |")> +(W pipe) You used the C<open(FH, "| command")> or C<open(FH, "command |")> construction, but the command was missing or blank. =item Missing name in "my sub" @@ -2419,7 +2418,7 @@ get local time. =item Octal number > 037777777777 non-portable -(W) The octal number you specified is larger than 2**32-1 (4294967295) +(W portable) The octal number you specified is larger than 2**32-1 (4294967295) and therefore non-portable between systems. See L<perlport> for more on portability concerns. @@ -2441,7 +2440,7 @@ references to an object. =item Parentheses missing around "%s" list -(W) You said something like +(W parenthesis) You said something like my $foo, $bar = @_; @@ -2453,12 +2452,12 @@ Remember that "my", "our", and "local" bind tighter than comma. =item Possible Y2K bug: %s -(W) You are concatenating the number 19 with another number, which +(W y2k) You are concatenating the number 19 with another number, which could be a potential Year 2000 problem. =item pragma "attrs" is deprecated, use "sub NAME : ATTRS" instead -(W) You have written somehing like this: +(W deprecated) You have written somehing like this: sub doit { @@ -2496,7 +2495,7 @@ been freed. =item Reference is already weak -(W) You have attempted to weaken a reference that is already weak. +(W misc) You have attempted to weaken a reference that is already weak. Doing so has no effect. =item setpgrp can't take arguments @@ -2506,7 +2505,7 @@ unlike POSIX setpgid(), which takes a process ID and process group ID. =item Strange *+?{} on zero-length expression -(W) You applied a regular expression quantifier in a place where it +(W regexp) You applied a regular expression quantifier in a place where it makes no sense, such as on a zero-width assertion. Try putting the quantifier inside the assertion instead. For example, the way to match "abc" provided that it is followed by three @@ -2521,13 +2520,21 @@ real and effective uids or gids. =item This Perl can't set CRTL environ elements (%s=%s) -(W) Warnings peculiar to VMS. You tried to change or delete an element +(W internal) Warnings peculiar to VMS. You tried to change or delete an element of the CRTL's internal environ array, but your copy of Perl wasn't built with a CRTL that contained the setenv() function. You'll need to rebuild Perl with a CRTL that does, or redefine F<PERL_ENV_TABLES> (see L<perlvms>) so that the environ array isn't the target of the change to %ENV which produced the warning. +=item Too late to run %s block + +(W void) A CHECK or INIT block is being defined during run time proper, +when the opportunity to run them has already passed. Perhaps you are +loading a file with C<require> or C<do> when you should be using +C<use> instead. Or perhaps you should put the C<require> or C<do> +inside a BEGIN block. + =item Unknown open() mode '%s' (F) The second argument of 3-argument open() is not among the list @@ -2543,7 +2550,7 @@ subvert Perl's population of %ENV for nefarious purposes. =item Unrecognized escape \\%c passed through -(W) You used a backslash-character combination which is not recognized +(W misc) You used a backslash-character combination which is not recognized by Perl. The character was understood literally. =item Unterminated attribute parameter in attribute list @@ -2576,7 +2583,7 @@ too soon. =item Value of CLI symbol "%s" too long -(W) A warning peculiar to VMS. Perl tried to read the value of an %ENV +(W misc) A warning peculiar to VMS. Perl tried to read the value of an %ENV element from a CLI symbol table, and found a resultant string longer than 1024 characters. The return value has been truncated to 1024 characters. @@ -2642,17 +2649,19 @@ warning. And in Perl 5.005, this special treatment will cease. =head1 Known Problems -=head2 Thread tests failing +=head2 Thread test failures -The subtests 19 and 20 of the lib/thread test are known to fail in -many platforms. +The subtests 19 and 20 of lib/thread.t test are known to fail due to +fundamental problems in the 5.005 threading implementation. These are +not new failures--Perl 5.005_0x has the same bugs, but didn't have these +tests. =head2 EBCDIC platforms not supported -In earlier releases of Perl the EBCDIC environments like OS390 (also -known as Open Edition MVS) and VM-ESA were supported. Due to the -changes required by the UTF-8 (Unicode) support in Perl 5.6 the EBCDIC -platforms are not supported in Perl 5.6.0. +In earlier releases of Perl, EBCDIC environments like OS390 (also +known as Open Edition MVS) and VM-ESA were supported. Due to changes +required by the UTF-8 (Unicode) support, the EBCDIC platforms are not +supported in Perl 5.6.0. =head2 NEXTSTEP 3.3 POSIX test failure @@ -2679,10 +2688,10 @@ these days. =head2 Many features still experimental -As discussed above, many features are still experimental, to a greater -or lesser degree. Interfaces and implementation are subject to -change, in extreme cases even subject to removal in some future -release of Perl. These features include the following: +As discussed above, many features are still experimental. Interfaces and +implementation of these features are subject to change, and in extreme cases, +even subject to removal in some future release of Perl. These features +include the following: =over 4 @@ -2698,9 +2707,9 @@ release of Perl. These features include the following: =item The Compiler suite -=item the DB module +=item The DB module -=item the regular expression constructs C<(?{ code })> and C<(??{ code })> +=item The regular expression constructs C<(?{ code })> and C<(??{ code })> =back diff --git a/pod/perldiag.pod b/pod/perldiag.pod index d57e7e57a3..a988124b5b 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -161,14 +161,14 @@ an ampersand before the name to avoid the warning. See L<perlsub>. (F) The argument to exists() must be a hash or array element, such as: $foo{$bar} - $ref->[12]->["susie"] + $ref->{"susie"}[12] =item %s argument is not a HASH or ARRAY element or slice (F) The argument to delete() must be either a hash or array element, such as: $foo{$bar} - $ref->[12]->["susie"] + $ref->{"susie"}[12] or a hash or array slice, such as: @@ -1255,15 +1255,12 @@ workarounds. inlining. See L<perlsub/"Constant Functions"> for commentary and workarounds. -=item constant(%s): %%^H is not localized - -(F) When setting compile-time-lexicalized hash %^H one should set the -corresponding bit of $^H as well. - =item constant(%s): %s -(F) Compile-time-substitutions (such as overloaded constants and -character names) were not correctly set up. +(F) The parser found inconsistencies either while attempting to define an +overloaded constant, or when trying to find the character name specified +in the C<\N{...}> escape. Perhaps you forgot to load the corresponding +C<overload> or C<charnames> pragma? See L<charnames> and L<overload>. =item Copy method did not return a reference @@ -3053,6 +3050,14 @@ B<-T> option must appear on the command line: C<perl -T scriptname>. B<-M> or B<-m> option. This is an error because B<-M> and B<-m> options are not intended for use inside scripts. Use the C<use> pragma instead. +=item Too late to run %s block + +(W void) A CHECK or INIT block is being defined during run time proper, +when the opportunity to run them has already passed. Perhaps you are +loading a file with C<require> or C<do> when you should be using +C<use> instead. Or perhaps you should put the C<require> or C<do> +inside a BEGIN block. + =item Too many ('s =item Too many )'s diff --git a/pod/perlhack.pod b/pod/perlhack.pod index 3a84e95513..c640870264 100644 --- a/pod/perlhack.pod +++ b/pod/perlhack.pod @@ -269,7 +269,7 @@ way to gain a precise understanding of the overall architecture of the language. If you build a version of the Perl interpreter with C<-DDEBUGGING>, -Perl's B<-D> commandline flag will cause copious debugging information +Perl's B<-D> command line flag will cause copious debugging information to be emitted (see the C<perlrun> manpage). If you build a version of Perl with compiler debugging information (e.g. with the C compiler's C<-g> option instead of C<-O>) then you can step through the execution diff --git a/pod/perlmodinstall.pod b/pod/perlmodinstall.pod index 5f1c62e96d..19ffac98c9 100644 --- a/pod/perlmodinstall.pod +++ b/pod/perlmodinstall.pod @@ -91,6 +91,11 @@ While still in that directory, type: Make sure you have appropriate permissions to install the module in your Perl 5 library directory. Often, you'll need to be root. +Perl maintains a record of all module installations. To look at +this list, simply type: + + perldoc perllocal + That's all you need to do on Unix systems with dynamic linking. Most Unix systems have dynamic linking--if yours doesn't, or if for another reason you have a statically-linked perl, I<and> the diff --git a/pod/perlmodlib.pod b/pod/perlmodlib.pod index c1f4aca6be..b42a2d881c 100644 --- a/pod/perlmodlib.pod +++ b/pod/perlmodlib.pod @@ -802,17 +802,22 @@ By-name interface to Perl's built-in getpw*() functions To find out I<all> modules installed on your system, including those without documentation or outside the standard release, -jus tdo this: +just do this: % find `perl -e 'print "@INC"'` -name '*.pm' -print -They should all have their own documentation installed and accessible -via your system man(1) command. If you do not have a B<find> +To get a log of all module distributions which have been installed +since perl was installed, just do: + + % perldoc perllocal + +Modules should all have their own documentation installed and accessible +via your system man(1) command, or via the C<perldoc> program. If you do +not have a B<find> program, you can use the Perl B<find2perl> program instead, which generates Perl code as output you can run through perl. If you have a B<man> program but it doesn't find your modules, you'll have -to fix your manpath. See L<perl> for details. If you have no -system B<man> command, you might try the B<perldoc> program. +to fix your manpath. See L<perl> for details. =head2 Extension Modules diff --git a/pod/perlnumber.pod b/pod/perlnumber.pod index 9f628cc9a8..c83e053203 100644 --- a/pod/perlnumber.pod +++ b/pod/perlnumber.pod @@ -36,7 +36,7 @@ The term "native" does not mean quite as much when we talk about native integers, as it does when native floating point numbers are involved. The only implication of the term "native" on integers is that the limits for the maximal and the minimal supported true integral quantities are close to -powers of 2. However, for "native" floats have a most fundamental +powers of 2. However, "native" floats have a most fundamental restriction: they may represent only those numbers which have a relatively "short" representation when converted to a binary fraction. For example, 0.9 cannot be respresented by a native float, since the binary fraction diff --git a/pod/perlop.pod b/pod/perlop.pod index db0563ce91..ce6fb66bc9 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -1140,9 +1140,10 @@ text is not evaluated as a command. If the PATTERN is delimited by bracketing quotes, the REPLACEMENT has its own pair of quotes, which may or may not be bracketing quotes, e.g., C<s(foo)(bar)> or C<< s<foo>/bar/ >>. A C</e> will cause the -replacement portion to be interpreted as a full-fledged Perl expression -and eval()ed right then and there. It is, however, syntax checked at -compile-time. +replacement portion to be treated as a full-fledged Perl expression +and evaluated right then and there. It is, however, syntax checked at +compile-time. A second C<e> modifier will cause the replacement portion +to be C<eval>ed before being run as a Perl expression. Examples: @@ -1169,8 +1170,12 @@ Examples: # symbolic dereferencing s/\$(\w+)/${$1}/g; - # /e's can even nest; this will expand - # any embedded scalar variable (including lexicals) in $_ + # Add one to the value of any numbers in the string + s/(\d+)/1 + $1/eg; + + # This will expand any embedded scalar variable + # (including lexicals) in $_ : First $1 is interpolated + # to the variable name, and then evaluated s/(\$\w+)/$1/eeg; # Delete (most) C comments. diff --git a/pod/perlthrtut.pod b/pod/perlthrtut.pod index 88849dd662..0f15d57de7 100644 --- a/pod/perlthrtut.pod +++ b/pod/perlthrtut.pod @@ -4,6 +4,14 @@ perlthrtut - tutorial on threads in Perl =head1 DESCRIPTION + WARNING: Threading is an experimental feature. Both the interface + and implementation are subject to change drastically. In fact, this + documentation describes the flavor of threads that was in version + 5.005. Perl 5.6.0 and later have the beginnings of support for + interpreter threads, which (when finished) is expected to be + significantly different from what is described here. The information + contained here may therefore soon be obsolete. Use at your own risk! + One of the most prominent new features of Perl 5.005 is the inclusion of threads. Threads make a number of things a lot easier, and are a very useful addition to your bag of programming tricks. @@ -389,7 +397,7 @@ to get them. =head2 Ignoring A Thread -join() does three things:it waits for a thread to exit, cleans up +join() does three things: it waits for a thread to exit, cleans up after it, and returns any data the thread may have produced. But what if you're not interested in the thread's return values, and you don't really care when the thread finishes? All you want is for the thread @@ -435,10 +443,10 @@ more than one thread can be accessing this data at once. Perl's scoping rules don't change because you're using threads. If a subroutine (or block, in the case of async()) could see a variable if you weren't running with threads, it can see it if you are. This is -especially important for the subroutines that create, and makes my +especially important for the subroutines that create, and makes C<my> variables even more important. Remember--if your variables aren't -lexically scoped (declared with C<my>) you're probably sharing it between -threads. +lexically scoped (declared with C<my>) you're probably sharing them +between threads. =head2 Thread Pitfall: Races @@ -13,6 +13,7 @@ Perl_ck_eof Perl_ck_eval Perl_ck_exec Perl_ck_exists +Perl_ck_exit Perl_ck_ftst Perl_ck_fun Perl_ck_fun_locale @@ -2463,8 +2463,8 @@ PP(pp_exit) anum = 0; else { anum = SvIVx(POPs); -#ifdef VMSISH_EXIT - if (anum == 1 && VMSISH_EXIT) +#ifdef VMS + if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH)) anum = 0; #endif } diff --git a/pp_proto.h b/pp_proto.h index 7f2d80b0b1..4ce9d74594 100644 --- a/pp_proto.h +++ b/pp_proto.h @@ -12,6 +12,7 @@ PERL_CKDEF(Perl_ck_eof) PERL_CKDEF(Perl_ck_eval) PERL_CKDEF(Perl_ck_exec) PERL_CKDEF(Perl_ck_exists) +PERL_CKDEF(Perl_ck_exit) PERL_CKDEF(Perl_ck_ftst) PERL_CKDEF(Perl_ck_fun) PERL_CKDEF(Perl_ck_fun_locale) diff --git a/t/op/sort.t b/t/op/sort.t index 794b1f2a6c..ba0a4c2a2d 100755 --- a/t/op/sort.t +++ b/t/op/sort.t @@ -13,6 +13,15 @@ print "1..49\n"; $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; } +# these shouldn't hang +{ + no warnings; + sort { for ($_ = 0;; $_++) {} } @a; + sort { while(1) {} } @a; + sort { while(1) { last; } } @a; + sort { while(0) { last; } } @a; +} + sub Backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 } sub Backwards_stacked($$) { my($a,$b) = @_; $a lt $b ? 1 : $a gt $b ? -1 : 0 } diff --git a/t/op/taint.t b/t/op/taint.t index c32a1c41fb..acc1c3d280 100755 --- a/t/op/taint.t +++ b/t/op/taint.t @@ -24,6 +24,11 @@ BEGIN { $ENV{PATH} = $ENV{PATH}; $ENV{TERM} = $ENV{TERM} ne ''? $ENV{TERM} : 'dummy'; } + if ($Config{d_shm} || $Config{d_msg}) { + require IPC::SysV; + IPC::SysV->import(qw(IPC_PRIVATE IPC_RMID IPC_CREAT S_IRWXU + S_IRWXG S_IRWXO)); + } } my $Is_VMS = $^O eq 'VMS'; @@ -609,8 +614,7 @@ else { # test shmread { if ($Config{d_shm}) { - use IPC::SysV qw(IPC_PRIVATE IPC_RMID S_IRWXU S_IRWXG S_IRWXO); - + no strict 'subs'; my $sent = "foobar"; my $rcvd; my $size = 2000; @@ -644,8 +648,7 @@ else { # test msgrcv { if ($Config{d_msg}) { - use IPC::SysV qw(IPC_PRIVATE IPC_RMID IPC_CREAT S_IRWXU); - + no strict 'subs'; my $id = msgget(IPC_PRIVATE, IPC_CREAT | S_IRWXU); my $sent = "message"; diff --git a/t/pragma/strict-vars b/t/pragma/strict-vars index d0e82c4b1f..3d98c54764 100644 --- a/t/pragma/strict-vars +++ b/t/pragma/strict-vars @@ -151,6 +151,8 @@ $d = 1;$i = 1;$n = 1; $e = 1;$j = 1;$o = 1; $p = 0b12; --FILE-- +# known scalar leak +BEGIN { $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; } use abc; EXPECT Global symbol "$f" requires explicit package name at abc.pm line 3. @@ -169,8 +171,8 @@ Global symbol "$o" requires explicit package name at abc.pm line 7. Global symbol "$p" requires explicit package name at abc.pm line 8. Illegal binary digit '2' at abc.pm line 8, at end of line abc.pm has too many errors. -Compilation failed in require at - line 1. -BEGIN failed--compilation aborted at - line 1. +Compilation failed in require at - line 3. +BEGIN failed--compilation aborted at - line 3. ######## # Check scope of pragma with eval diff --git a/t/pragma/warn/op b/t/pragma/warn/op index d70a333bbc..461f3f618b 100644 --- a/t/pragma/warn/op +++ b/t/pragma/warn/op @@ -808,3 +808,54 @@ joe() ; sub joe ($$) {} EXPECT main::fred() called too early to check prototype at - line 3. +######## +# op.c [Perl_newATTRSUB] +--FILE-- abc.pm +use warnings 'void' ; +BEGIN { $| = 1; print "in begin\n"; } +CHECK { print "in check\n"; } +INIT { print "in init\n"; } +END { print "in end\n"; } +print "in mainline\n"; +1; +--FILE-- +use abc; +delete $INC{"abc.pm"}; +require abc; +do "abc.pm"; +EXPECT +in begin +in mainline +in check +in init +in begin +Too late to run CHECK block at abc.pm line 3. +Too late to run INIT block at abc.pm line 4. +in mainline +in begin +Too late to run CHECK block at abc.pm line 3. +Too late to run INIT block at abc.pm line 4. +in mainline +in end +in end +in end +######## +# op.c [Perl_newATTRSUB] +--FILE-- abc.pm +no warnings 'void' ; +BEGIN { $| = 1; print "in begin\n"; } +CHECK { print "in check\n"; } +INIT { print "in init\n"; } +END { print "in end\n"; } +print "in mainline\n"; +1; +--FILE-- +require abc; +do "abc.pm"; +EXPECT +in begin +in mainline +in begin +in mainline +in end +in end @@ -5648,30 +5648,28 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, SV *res; SV **cvp; SV *cv, *typesv; - const char *why, *why1, *why2; + const char *why1, *why2, *why3; - if (!(PL_hints & HINT_LOCALIZE_HH)) { + if (!table || !(PL_hints & HINT_LOCALIZE_HH)) { SV *msg; - why = "%^H is not localized"; - report_short: - why1 = why2 = ""; + why1 = "%^H is not consistent"; + why2 = strEQ(key,"charnames") + ? " (missing \"use charnames ...\"?)" + : ""; + why3 = ""; report: msg = Perl_newSVpvf(aTHX_ "constant(%s): %s%s%s", - (type ? type: "undef"), why1, why2, why); + (type ? type: "undef"), why1, why2, why3); yyerror(SvPVX(msg)); SvREFCNT_dec(msg); return sv; } - if (!table) { - why = "%^H is not defined"; - goto report_short; - } cvp = hv_fetch(table, key, strlen(key), FALSE); if (!cvp || !SvOK(*cvp)) { - why = "} is not defined"; why1 = "$^H{"; why2 = key; + why3 = "} is not defined"; goto report; } sv_2mortal(sv); /* Parent created it permanently */ @@ -5719,9 +5717,9 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, POPSTACK; if (!SvOK(res)) { - why = "}} did not return a defined value"; why1 = "Call to &{$^H{"; why2 = key; + why3 = "}} did not return a defined value"; sv = res; goto report; } diff --git a/vms/ext/Stdio/Stdio.pm b/vms/ext/Stdio/Stdio.pm index d485e0e159..b51f2c9f15 100644 --- a/vms/ext/Stdio/Stdio.pm +++ b/vms/ext/Stdio/Stdio.pm @@ -637,6 +637,6 @@ it encounters an error. =head1 REVISION This document was last revised on 13-Oct-1998, for Perl 5.004, 5.005, and -5.006. +5.6.0. =cut diff --git a/vms/ext/vmsish.pm b/vms/ext/vmsish.pm index dfb565b326..2fc48530c0 100644 --- a/vms/ext/vmsish.pm +++ b/vms/ext/vmsish.pm @@ -11,6 +11,7 @@ vmsish - Perl pragma to control VMS-specific language features use vmsish 'status'; # or '$?' use vmsish 'exit'; use vmsish 'time'; + use vmsish 'hushed'; use vmsish; no vmsish 'time'; @@ -18,8 +19,8 @@ vmsish - Perl pragma to control VMS-specific language features =head1 DESCRIPTION If no import list is supplied, all possible VMS-specific features are -assumed. Currently, there are three VMS-specific features available: -'status' (a.k.a '$?'), 'exit', and 'time'. +assumed. Currently, there are four VMS-specific features available: +'status' (a.k.a '$?'), 'exit', 'time' and 'hushed'. =over 6 @@ -41,6 +42,16 @@ used directly as Perl's exit status. This makes all times relative to the local time zone, instead of the default of Universal Time (a.k.a Greenwich Mean Time, or GMT). +=item C<vmsish hushed> + +This supresses printing of VMS status messages to SYS$OUTPUT and SYS$ERROR +if Perl terminates with an error status. This primarily effects error +exits from things like compiler errors or "standard Perl" runtime errors, +where text error messages are also generated by Perl. + +The error exits from inside VMS.C are generally more serious, and are +not supressed. + =back See L<perlmod/Pragmatic Modules>. @@ -56,8 +67,8 @@ sub bits { my $bits = 0; my $sememe; foreach $sememe (@_) { - $bits |= 0x20000000, next if $sememe eq 'status' || $sememe eq '$?'; - $bits |= 0x40000000, next if $sememe eq 'exit'; + $bits |= 0x20000000, next if $sememe eq 'hushed'; + $bits |= 0x40000000, next if $sememe eq 'status' || $sememe eq '$?'; $bits |= 0x80000000, next if $sememe eq 'time'; } $bits; @@ -65,12 +76,22 @@ sub bits { sub import { shift; - $^H |= bits(@_ ? @_ : qw(status exit time)); + $^H |= bits(@_ ? @_ : qw(status time hushed)); + my $sememe; + + foreach $sememe (@_ ? @_ : qw(exit)) { + $^H{'vmsish_exit'} = 1 if $sememe eq 'exit'; + } } sub unimport { shift; - $^H &= ~ bits(@_ ? @_ : qw(status exit time)); + $^H &= ~ bits(@_ ? @_ : qw(status time hushed)); + my $sememe; + + foreach $sememe (@_ ? @_ : qw(exit)) { + $^H{'vmsish_exit'} = 0 if $sememe eq 'exit'; + } } 1; diff --git a/vms/ext/vmsish.t b/vms/ext/vmsish.t index 24a9f437ef..2a5b580bda 100644 --- a/vms/ext/vmsish.t +++ b/vms/ext/vmsish.t @@ -3,7 +3,7 @@ BEGIN { unshift @INC, '[-.lib]'; } my $Invoke_Perl = qq(MCR $^X "-I[-.lib]"); -print "1..16\n"; +print "1..17\n"; #========== vmsish status ========== `$Invoke_Perl -e 1`; # Avoid system() from a pipe from harness. Mutter. @@ -30,10 +30,11 @@ else { print "ok 5\n"; } else { print "ok 6\n"; } } -#========== vmsish exit ========== +#========== vmsish exit, messages ========== { use vmsish qw(status); - my $msg = `$Invoke_Perl "-I[-.lib]" -e "exit 1"`; + + $msg = do_a_perl('-e "exit 1"'); if ($msg !~ /ABORT/) { $msg =~ s/\n/\\n/g; # keep output on one line print "not ok 7 # subprocess output: |$msg|\n"; @@ -42,7 +43,7 @@ else { print "ok 5\n"; } if ($? & 1) { print "not ok 8 # subprocess VMS status: $?\n"; } else { print "ok 8\n"; } - $msg = `$Invoke_Perl "-I[-.lib]" -e "use vmsish qw(exit); exit 1"`; + $msg = do_a_perl('-e "use vmsish qw(exit); exit 1"'); if (length $msg) { $msg =~ s/\n/\\n/g; # keep output on one line print "not ok 9 # subprocess output: |$msg|\n"; @@ -51,7 +52,7 @@ else { print "ok 5\n"; } if (not ($? & 1)) { print "not ok 10 # subprocess VMS status: $?\n"; } else { print "ok 10\n"; } - $msg = `$Invoke_Perl "-I[-.lib]" -e "use vmsish qw(exit); exit 44"`; + $msg = do_a_perl('-e "use vmsish qw(exit); exit 44"'); if ($msg !~ /ABORT/) { $msg =~ s/\n/\\n/g; # keep output on one line print "not ok 11 # subprocess output: |$msg|\n"; @@ -59,6 +60,14 @@ else { print "ok 5\n"; } else { print "ok 11\n"; } if ($? & 1) { print "not ok 12 # subprocess VMS status: $?\n"; } else { print "ok 12\n"; } + + $msg = do_a_perl('-e "use vmsish qw(exit hushed); exit 44"'); + if ($msg =~ /ABORT/) { + $msg =~ s/\n/\\n/g; # keep output on one line + print "not ok 13 # subprocess output: |$msg|\n"; + } + else { print "ok 13\n"; } + } @@ -93,30 +102,44 @@ else { print "ok 5\n"; } # an amount, and it renders the test resistant to delays from # things like stat() on a file mounted over a slow network link. if ($utctime - $vmstime + $offset > 10) { - print "not ok 13 # (time) UTC: $utctime VMS: $vmstime\n"; + print "not ok 14 # (time) UTC: $utctime VMS: $vmstime\n"; } - else { print "ok 13\n"; } + else { print "ok 14\n"; } $utcval = $utclocal[5] * 31536000 + $utclocal[7] * 86400 + $utclocal[2] * 3600 + $utclocal[1] * 60 + $utclocal[0]; $vmsval = $vmslocal[5] * 31536000 + $vmslocal[7] * 86400 + $vmslocal[2] * 3600 + $vmslocal[1] * 60 + $vmslocal[0]; if ($vmsval - $utcval + $offset > 10) { - print "not ok 14 # (localtime)\n# UTC: @utclocal\n# VMS: @vmslocal\n"; + print "not ok 15 # (localtime)\n# UTC: @utclocal\n# VMS: @vmslocal\n"; } - else { print "ok 14\n"; } + else { print "ok 15\n"; } $utcval = $utcgmtime[5] * 31536000 + $utcgmtime[7] * 86400 + $utcgmtime[2] * 3600 + $utcgmtime[1] * 60 + $utcgmtime[0]; $vmsval = $vmsgmtime[5] * 31536000 + $vmsgmtime[7] * 86400 + $vmsgmtime[2] * 3600 + $vmsgmtime[1] * 60 + $vmsgmtime[0]; if ($vmsval - $utcval + $offset > 10) { - print "not ok 15 # (gmtime)\n# UTC: @utcgmtime\n# VMS: @vmsgmtime\n"; + print "not ok 16 # (gmtime)\n# UTC: @utcgmtime\n# VMS: @vmsgmtime\n"; } - else { print "ok 15\n"; } + else { print "ok 16\n"; } if ($vmsmtime - $utcmtime + $offset > 10) { - print "not ok 16 # (stat) UTC: $utcmtime VMS: $vmsmtime\n"; + print "not ok 17 # (stat) UTC: $utcmtime VMS: $vmsmtime\n"; } - else { print "ok 16\n"; } + else { print "ok 17\n"; } +} + +#====== need this to make sure error messages come out, even if +# they were turned off in invoking procedure +sub do_a_perl { + local *P; + open(P,'>vmsish_test.com') || die('not ok ?? : unable to open "vmsish_test.com" for writing'); + print P "\$ set message/facil/sever/ident/text\n"; + print P "\$ $Invoke_Perl @_\n"; + close P; + my $x = `\@vmsish_test.com`; + unlink 'vmsish_test.com'; + return $x; } + diff --git a/vms/vmsish.h b/vms/vmsish.h index 12b13696ce..e53c604d16 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -223,14 +223,14 @@ #define COMPLEX_STATUS 1 /* We track both "POSIX" and VMS values */ #define HINT_V_VMSISH 24 -#define HINT_M_VMSISH_STATUS 0x20000000 /* system, $? return VMS status */ -#define HINT_M_VMSISH_EXIT 0x40000000 /* exit(1) ==> SS$_NORMAL */ +#define HINT_M_VMSISH_HUSHED 0x20000000 /* stifle error msgs on exit */ +#define HINT_M_VMSISH_STATUS 0x40000000 /* system, $? return VMS status */ #define HINT_M_VMSISH_TIME 0x80000000 /* times are local, not UTC */ #define NATIVE_HINTS (PL_hints >> HINT_V_VMSISH) /* used in op.c */ #define TEST_VMSISH(h) (PL_curcop->op_private & ((h) >> HINT_V_VMSISH)) +#define VMSISH_HUSHED TEST_VMSISH(HINT_M_VMSISH_HUSHED) #define VMSISH_STATUS TEST_VMSISH(HINT_M_VMSISH_STATUS) -#define VMSISH_EXIT TEST_VMSISH(HINT_M_VMSISH_EXIT) #define VMSISH_TIME TEST_VMSISH(HINT_M_VMSISH_TIME) /* Flags for vmstrnenv() */ |