----------------
+Version 5.003_91
+----------------
+
+This is (should be? must be!) the public beta of 5.004.
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Fix perl_call_*() when !G_EVAL"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199702250725.CAA09192@aatma.engin.umich.edu>,
+ <199702251925.OAA15498@aatma.engin.umich.edu>,
+ <199702252200.RAA16853@aatma.engin.umich.edu>
+ Date: Tue, 25 Feb 1997 02:25:56 -0500
+ Files: MANIFEST gv.c interp.sym perl.c perl.h pp_ctl.c pp_sys.c
+ t/op/runlevel.t
+
+ Title: "Fix taint tests for writeable dirs in $ENV{PATH}"
+ From: Chip Salzenberg
+ Files: mg.c mg.h pod/perlsec.pod taint.c
+
+ Title: "Forbid tainted parameters for truncate()"
+ From: Chip Salzenberg
+ Files: pp_sys.c
+
+ Title: "Don't taint magic hash keys unnecessarily"
+ From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>
+ Msg-ID: <01IFXL9TY74Y00661G@hmivax.humgen.upenn.edu>
+ Date: Fri, 28 Feb 1997 02:11:26 -0500 (EST)
+ Files: hv.c
+
+ CORE PORTABILITY
+
+ Title: "VMS patches post _90"
+ From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>
+ Msg-ID: <01IFYDE5ZT7O005A53@hmivax.humgen.upenn.edu>
+ Date: Fri, 28 Feb 1997 15:26:33 -0500 (EST)
+ Files: doio.c mg.c perl.h pp_hot.c t/op/rand.t t/op/taint.t taint.c
+ vms/descrip.mms vms/vms.c
+
+ Title: "Fix taint check in system() and exec() under VMS and OS/2"
+ From: Chip Salzenberg
+ Files: pp_sys.c
+
+ Title: "If _XOPEN_VERSION >= 4, socket length parameters are size_t"
+ From: Michael H. Moran <mhm@austin.ibm.com>
+ Files: perl.h pp_sys.c
+
+ Title: "Make dooneliner() compile again"
+ From: Chip Salzenberg
+ Files: pp_sys.c
+
+ OTHER CORE CHANGES
+
+ Title: "Short-circuit duplicate study() calls"
+ From: Chip Salzenberg
+ Files: pp.c
+
+ Title: "Call sv_set[iu]v() with [IU]V parameter, not [IU]32"
+ From: Chip Salzenberg
+ Files: perl.c pp.c pp_sys.c toke.c util.c
+
+ Title: "Clean up and document API for hashes"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199702251824.NAA14859@aatma.engin.umich.edu>
+ Date: Tue, 25 Feb 1997 13:24:02 -0500
+ Files: hv.c hv.h pod/perldelta.pod pod/perlguts.pod
+
+ Title: "pp_undef was not always freeing memory"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199702270653.BAA13949@monk.mps.ohio-state.edu>
+ Date: Thu, 27 Feb 1997 01:53:51 -0500 (EST)
+ Files: pp.c
+
+ Title: "Fix SEGV when debugging with foreach() lvalue patch"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199702271924.OAA14557@monk.mps.ohio-state.edu>
+ Date: Thu, 27 Feb 1997 14:24:36 -0500 (EST)
+ Files: sv.c
+
+ Title: "Don't examine rx->exec_tainted if pregexec() fails"
+ From: Chip Salzenberg
+ Files: pp_hot.c
+
+ Title: "Silence bogus typo warning on $DB::postponed"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199702271802.NAA12505@aatma.engin.umich.edu>
+ Date: Thu, 27 Feb 1997 13:02:30 -0500
+ Files: op.c
+
+ BUILD PROCESS
+
+ Title: "Sanity check linking with $libs"
+ From: Andy Dougherty <doughera@fractal.phys.lafayette.edu>
+ Msg-ID: <Pine.SOL.3.95q.970225221634.2486A-100000@fractal.lafayette.edu>
+ Date: Tue, 25 Feb 1997 14:13:45 -0500 (EST)
+ Files: Configure
+
+ Title: "Flush stdout when printing $randbits guess"
+ From: Chip Salzenberg
+ Files: Configure
+
+ Title: "Configure changes for Irix nm"
+ From: Helmut Jarausch and Fabien Tassin
+ Files: Configure
+
+ Title: "Update OS/2 Configure diff"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199702251906.OAA10608@monk.mps.ohio-state.edu>
+ Date: Tue, 25 Feb 1997 14:06:23 -0500 (EST)
+ Files: os2/diff.configure
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Don't require() in a signal handler"
+ From: Chip Salzenberg
+ Files: lib/perl5db.pl
+
+ Title: "Make IPC::Open3 work without fork()"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199702251937.OAA10718@monk.mps.ohio-state.edu>
+ Date: Tue, 25 Feb 1997 14:37:07 -0500 (EST)
+ Files: lib/IPC/Open3.pm
+
+ Title: "Follow up on elimination of $` $& $' in libraries"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0w0Sqc-00046E-00@ursa.cus.cam.ac.uk>
+ Date: Fri, 28 Feb 1997 13:59:42 +0000
+ Files: lib/Getopt/Long.pm lib/diagnostics.pm
+
+ Title: "Don't warn on use of CCFLAGS"
+ From: Andreas Koenig <k@anna.in-berlin.de>
+ Msg-ID: <199702251038.LAA13123@anna.in-berlin.de>
+ Date: Tue, 25 Feb 1997 11:38:43 +0100
+ Files: lib/ExtUtils/MakeMaker.pm
+
+ Title: "Allow explicit '-lperl' in link arguments"
+ From: Doug MacEachern <dougm@opengroup.org>
+ Msg-ID: <199702271625.LAA25402@postman.osf.org>
+ Date: Thu, 27 Feb 1997 11:25:04 -0500
+ Files: lib/ExtUtils/Embed.pm
+
+ TESTS
+
+ Title: "New test op/taint.t"
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Msg-ID: <Pine.GSO.3.95q.970225101328.18288M-100000@kelly.teleport.com
+ Date: Tue, 25 Feb 1997 11:36:53 -0800 (PST)
+ Files: MANIFEST t/op/taint.t
+
+ Title: "Patch to t/op/rand.t"
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Msg-ID: <Pine.GSO.3.95q.970225181321.13796Q-100000@kelly.teleport.com
+ Date: Tue, 25 Feb 1997 18:19:34 -0800 (PST)
+ Files: t/op/rand.t
+
+ UTILITIES
+
+ Title: "Add --lax option to pod2man; use it in perldoc"
+ From: Nat <gnat@frii.com>, Chip Salzenberg
+ Files: pod/pod2man.PL utils/perldoc.PL
+
+ Title: "Eliminate dead code in pod2man"
+ From: Chip Salzenberg
+ Files: pod/pod2man.PL
+
+ DOCUMENTATION
+
+ Title: "Warn about intrusive sfio behavior"
+ From: Andy Dougherty <doughera@fractal.phys.lafayette.edu>
+ Msg-ID: <Pine.SOL.3.95q.970228112136.24038G-100000@fractal.lafayette.
+ Date: Fri, 28 Feb 1997 11:35:49 -0500 (EST)
+ Files: INSTALL
+
+ Title: "Updates to perlfunc.pod"
+ From: Tom Phoenix (with help from M.J.T. Guy and Tom C.)
+ Files: pod/perlfunc.pod
+
+ Title: "Move ENVIRONMENT from perl.pod to perlrun.pod"
+ From: Chip Salzenberg
+ Files: pod/perl.pod pod/perlrun.pod
+
+ Title: "Describe PERL_DEBUG_MSTATS in perlrun.pod"
+ From: Nat <gnat@frii.com>
+ Files: pod/perlrun.pod
+
+ Title: "Fix references to perlbug"
+ From: Chip Salzenberg
+ Files: pod/perl.pod pod/perldelta.pod pod/perllocale.pod
+ pod/perltoc.pod
+
+
+----------------
Version 5.003_90
----------------
: coherency check
echo " "
-echo "Checking your choice of C compiler and flags for coherency..." >&4
-set X $cc $optimize $ccflags $ldflags try.c -o try
+echo "Checking your choice of C compiler, libs, and flags for coherency..." >&4
+set X $cc $optimize $ccflags $ldflags -o try try.c $libs
shift
$cat >try.msg <<EOM
I've tried to compile and run a simple program with:
main() { exit(0); }
EOF
dflt=y
-if sh -c "$cc $optimize $ccflags try.c -o try $ldflags" >>try.msg 2>&1; then
+if sh -c "$cc $optimize $ccflags -o try try.c $ldflags $libs" >>try.msg 2>&1; then
if sh -c './try' >>try.msg 2>&1; then
dflt=n
else
: nm options which may be necessary
case "$nm_opt" in
'') if $test -f /mach_boot; then
- nm_opt=''
+ nm_opt='' # Mach
elif $test -d /usr/ccs/lib; then
- nm_opt='-p'
+ nm_opt='-p' # Solaris (and SunOS?)
elif $test -f /dgux; then
- nm_opt='-p'
+ nm_opt='-p' # DG-UX
+ elif $test -x /lib64/rld; then
+ nm_opt='-p' # 64-bit Irix
else
nm_opt=''
fi;;
eval $xscan;\
$contains '^fprintf$' libc.list >/dev/null 2>&1; then
eval $xrun
+elif com="$sed -n -e 's/^.*|Proc .*|Text *| *//p'";\
+ eval $xscan;\
+ $contains '^fprintf$' libc.list >/dev/null 2>&1; then
+ eval $xrun
elif com="$sed -n -e '/Def. Text/s/.* \([^ ]*\)\$/\1/p'";\
eval $xscan;\
$contains '^fprintf$' libc.list >/dev/null 2>&1; then
for (i = 0; max; i++)
max /= 2;
printf("%d\n",i);
+ fflush(stdout);
}
EOCP
if $cc $ccflags $ldflags -o try try.c $libs >/dev/null 2>&1 ; then
t/op/ref.t See if refs and objects work
t/op/regexp.t See if regular expressions work
t/op/repeat.t See if x operator works
+t/op/runlevel.t See if die() works from perl_call_*()
t/op/sleep.t See if sleep works
t/op/sort.t See if sort works
t/op/split.t See if split works
t/op/subst.t See if substitution works
t/op/substr.t See if substr works
t/op/sysio.t See if sysread and syswrite work
+t/op/taint.t See if tainting works
t/op/tie.t See if tie/untie functions work
t/op/time.t See if time functions work
t/op/undef.t See if undef works
if cmp $0 `echo $0 | sed -e s/configure/Configure/` >/dev/null; then
echo "Your configure and Configure scripts seem to be identical."
echo "This can happen on filesystems that aren't fully case sensitive."
- echo "You'll have to explicitely extract Configure and run that."
+ echo "You'll have to explicitly extract Configure and run that."
exit 1
fi
;;
if cmp $0 `echo $0 | sed -e s/configure/Configure/` >/dev/null; then
echo "Your configure and Configure scripts seem to be identical."
echo "This can happen on filesystems that aren't fully case sensitive."
- echo "You'll have to explicitely extract Configure and run that."
+ echo "You'll have to explicitly extract Configure and run that."
exit 1
fi
;;
if (IoIFP(io)) {
if (IoTYPE(io) == '|') {
status = my_pclose(IoIFP(io));
- retval = (status == 0);
STATUS_NATIVE_SET(status);
+ retval = (STATUS_POSIX == 0);
}
else if (IoTYPE(io) == '-')
retval = TRUE;
#define minus_n (curinterp->Iminus_n)
#define minus_p (curinterp->Iminus_p)
#define multiline (curinterp->Imultiline)
+#define mustcatch (curinterp->Imustcatch)
#define mystack_base (curinterp->Imystack_base)
#define mystack_mark (curinterp->Imystack_mark)
#define mystack_max (curinterp->Imystack_max)
#define Iminus_n minus_n
#define Iminus_p minus_p
#define Imultiline multiline
+#define Imustcatch mustcatch
#define Imystack_base mystack_base
#define Imystack_mark mystack_mark
#define Imystack_max mystack_max
#define minus_n Perl_minus_n
#define minus_p Perl_minus_p
#define multiline Perl_multiline
+#define mustcatch Perl_mustcatch
#define mystack_base Perl_mystack_base
#define mystack_mark Perl_mystack_mark
#define mystack_max Perl_mystack_max
dSP;
BINOP myop;
SV* res;
+ bool oldmustcatch = mustcatch;
Zero(&myop, 1, BINOP);
myop.op_last = (OP *) &myop;
myop.op_next = Nullop;
myop.op_flags = OPf_KNOW|OPf_STACKED;
+ mustcatch = TRUE;
ENTER;
SAVESPTR(op);
op = (OP *) &myop;
res=POPs;
PUTBACK;
+ mustcatch = oldmustcatch;
if (postpr) {
int ans;
if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
char *gotenv;
- gotenv = ENV_getenv(key);
- if (gotenv != NULL) {
+ if ((gotenv = ENV_getenv(key)) != Nullch) {
sv = newSVpv(gotenv,strlen(gotenv));
+ SvTAINTED_on(sv);
return hv_store(hv,key,klen,sv,hash);
}
}
char *k;
New(54, k, HEK_BASESIZE + sizeof(SV*), char);
HeKEY_hek(&mh) = (HEK*)k;
- HeKLEN(&mh) = HEf_SVKEY; /* key will always hold an SV* */
}
HeSVKEY_set(&mh, keysv);
HeVAL(&mh) = sv;
if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
char *gotenv;
- gotenv = ENV_getenv(key);
- if (gotenv != NULL) {
+ if ((gotenv = ENV_getenv(key)) != Nullch) {
sv = newSVpv(gotenv,strlen(gotenv));
+ SvTAINTED_on(sv);
return hv_store_ent(hv,keysv,sv,hash);
}
}
xhv = (XPVHV*)SvANY(hv);
if (SvMAGICAL(hv)) {
+ bool save_taint = tainted;
+ if (tainting)
+ tainted = SvTAINTED(keysv);
keysv = sv_2mortal(newSVsv(keysv));
mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
+ TAINT_IF(save_taint);
if (!xhv->xhv_array
&& (SvMAGIC(hv)->mg_moremagic
|| (SvMAGIC(hv)->mg_type != 'E'
#define HeKLEN(he) HEK_LEN(HeKEY_hek(he))
#define HeVAL(he) (he)->hent_val
#define HeHASH(he) HEK_HASH(HeKEY_hek(he))
-#define HePV(he) ((HeKLEN(he) == HEf_SVKEY) ? \
- SvPV(HeKEY_sv(he),na) : \
- HeKEY(he))
+#define HePV(he,lp) ((HeKLEN(he) == HEf_SVKEY) ? \
+ SvPV(HeKEY_sv(he),lp) : \
+ (((lp = HeKLEN(he)) >= 0) ? \
+ HeKEY(he) : Nullch))
+
#define HeSVKEY(he) ((HeKEY(he) && \
HeKLEN(he) == HEf_SVKEY) ? \
HeKEY_sv(he) : Nullsv)
sv_2mortal(newSVpv(HeKEY(he), \
HeKLEN(he)))) : \
&sv_undef)
-#define HeSVKEY_set(he,sv) (HeKEY_sv(he) = sv)
+#define HeSVKEY_set(he,sv) ((HeKLEN(he) = HEf_SVKEY), (HeKEY_sv(he) = sv))
#define Nullhek Null(HEK*)
#define HEK_BASESIZE STRUCT_OFFSET(HEK, hek_key[0])
minus_n
minus_p
multiline
+mustcatch
mystack_base
mystack_mark
mystack_max
char *ptr;
STRLEN len;
I32 i;
+
s = SvPV(sv,len);
ptr = MgPV(mg);
my_setenv(ptr, s);
+
#ifdef DYNAMIC_ENV_FETCH
/* We just undefd an environment var. Is a replacement */
/* waiting in the wings? */
if (!len) {
HE *envhe;
SV *keysv;
- if (mg->mg_len == HEf_SVKEY) keysv = (SV *)mg->mg_ptr;
- else keysv = newSVpv(mg->mg_ptr,mg->mg_len);
- if (envhe = hv_fetch_ent(GvHVn(envgv),keysv,FALSE,0))
- s = SvPV(HeVAL(envhe),len);
- if (mg->mg_len != HEf_SVKEY) SvREFCNT_dec(keysv);
+ if (mg->mg_len == HEf_SVKEY)
+ keysv = (SV *)mg->mg_ptr;
+ else
+ keysv = newSVpv(mg->mg_ptr, mg->mg_len);
+ if ((envhe = hv_fetch_ent(GvHVn(envgv), keysv, FALSE, 0)))
+ s = SvPV(HeVAL(envhe), len);
+ if (mg->mg_len != HEf_SVKEY)
+ SvREFCNT_dec(keysv);
}
#endif
+
+#if !defined(OS2) && !defined(AMIGAOS)
/* And you'll never guess what the dog had */
/* in its mouth... */
if (tainting) {
+ MgTAINTEDDIR_off(mg);
+#ifdef VMS
+ if (s && strnEQ(ptr, "DCL$PATH", 8)) {
+ char pathbuf[256], eltbuf[256], *cp, *elt = s;
+ struct stat sbuf;
+ int i = 0, j = 0;
+
+ do { /* DCL$PATH may be a search list */
+ while (1) { /* as may dev portion of any element */
+ if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
+ if ( *(cp+1) == '.' || *(cp+1) == '-' ||
+ cando_by_name(S_IWUSR,0,elt) ) {
+ MgTAINTEDDIR_on(mg);
+ return 0;
+ }
+ }
+ if ((cp = strchr(elt, ':')) != Nullch)
+ *cp = '\0';
+ if (my_trnlnm(elt, eltbuf, j++))
+ elt = eltbuf;
+ else
+ break;
+ }
+ j = 0;
+ } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
+ }
+#endif /* VMS */
if (s && strEQ(ptr,"PATH")) {
char *strend = s + len;
while (s < strend) {
- s = cpytill(tokenbuf,s,strend,':',&i);
+ struct stat st;
+ s = cpytill(tokenbuf, s, strend, ':', &i);
s++;
if (*tokenbuf != '/'
- || (Stat(tokenbuf,&statbuf) && (statbuf.st_mode & 2)) )
+ || (Stat(tokenbuf, &st) == 0 && (st.st_mode & 2)) ) {
MgTAINTEDDIR_on(mg);
+ return 0;
+ }
}
}
}
+#endif /* neither OS2 nor AMIGAOS */
+
return 0;
}
#define MGf_MINMATCH 1
-#define MgTAINTEDDIR(mg) (mg->mg_flags & MGf_TAINTEDDIR)
-#define MgTAINTEDDIR_on(mg) (mg->mg_flags |= MGf_TAINTEDDIR)
+#define MgTAINTEDDIR(mg) (mg->mg_flags & MGf_TAINTEDDIR)
+#define MgTAINTEDDIR_on(mg) (mg->mg_flags |= MGf_TAINTEDDIR)
+#define MgTAINTEDDIR_off(mg) (mg->mg_flags &= ~MGf_TAINTEDDIR)
#define MgPV(mg) ((mg)->mg_len == HEf_SVKEY) ? \
SvPV((SV*)((mg)->mg_ptr),na) : \
#define PATCHLEVEL 3
-#define SUBVERSION 90
+#define SUBVERSION 91
/*
local_patches -- list of locally applied less-than-subversion patches.
main_cv = Nullcv;
time(&basetime);
+ mustcatch = FALSE;
switch (Sigsetjmp(top_env,1)) {
case 1:
calllist(endav);
return STATUS_NATIVE_EXPORT;
case 3:
+ mustcatch = FALSE;
PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
return 1;
}
#endif
return STATUS_NATIVE_EXPORT;
case 3:
+ mustcatch = FALSE;
if (!restartop) {
PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
FREETMPS;
Sigjmp_buf oldtop;
I32 oldscope;
static CV *DBcv;
-
+ bool oldmustcatch = mustcatch;
+
if (flags & G_DISCARD) {
ENTER;
SAVETMPS;
my_exit_jump();
/* NOTREACHED */
case 3:
+ mustcatch = FALSE;
if (restartop) {
op = restartop;
restartop = 0;
goto cleanup;
}
}
+ else
+ mustcatch = TRUE;
if (op == (OP*)&myop)
op = pp_entersub();
}
Copy(oldtop, top_env, 1, Sigjmp_buf);
}
+ else
+ mustcatch = oldmustcatch;
+
if (flags & G_DISCARD) {
stack_sp = stack_base + oldmark;
retval = 0;
my_exit_jump();
/* NOTREACHED */
case 3:
+ mustcatch = FALSE;
if (restartop) {
op = restartop;
restartop = 0;
}
TAINT_NOT;
if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
- sv_setiv(GvSV(tmpgv),(I32)getpid());
+ sv_setiv(GvSV(tmpgv), (IV)getpid());
}
static void
#define MEM_SIZE Size_t
+#if _XOPEN_VERSION >= 4
+# define Sock_size_t Size_t
+#else
+# define Sock_size_t int
+#endif
+
#if defined(STANDARD_C) && defined(I_STDDEF)
# include <stddef.h>
# define STRUCT_OFFSET(s,m) offsetof(s,m)
#else
char *crypt _((const char*, const char*));
#endif
+#ifndef getenv
char *getenv _((const char*));
+#endif
Off_t lseek _((int,Off_t,int));
char *getlogin _((void));
#endif
IEXT I32 Icxstack_max IINIT(128);
IEXT Sigjmp_buf Itop_env;
IEXT I32 Irunlevel;
+IEXT bool Imustcatch; /* doeval() must be caught locally */
/* stack stuff */
IEXT AV * Icurstack; /* THE STACK */
-p9pvers = 5.003_90
+p9pvers = 5.003_91
perlbot Perl OO tricks and examples
perlipc Perl interprocess communication
- perlbug Perl bug reports howto
perldebug Perl debugging
perldiag Perl diagnostic messages
perlsec Perl security
=head1 ENVIRONMENT
-=over 12
-
-=item HOME
-
-Used if chdir has no argument.
-
-=item LOGDIR
-
-Used if chdir has no argument and HOME is not set.
-
-=item PATH
-
-Used in executing subprocesses, and in finding the script if B<-S> is
-used.
-
-=item PERL5LIB
-
-A colon-separated list of directories in which to look for Perl library
-files before looking in the standard library and the current
-directory. If PERL5LIB is not defined, PERLLIB is used. When running
-taint checks (because the script was running setuid or setgid, or the
-B<-T> switch was used), neither variable is used. The script should
-instead say
-
- use lib "/my/directory";
-
-=item PERL5DB
-
-The command used to get the debugger code. If unset, uses
-
- BEGIN { require 'perl5db.pl' }
-
-=item PERL_DESTRUCT_LEVEL
-
-Relevant only if your perl executable was built with B<-DDEBUGGING>,
-this controls the behavior of global destruction of objects and other
-references.
-
-=item PERLLIB
-
-A colon-separated list of directories in which to look for Perl library
-files before looking in the standard library and the current
-directory. If PERL5LIB is defined, PERLLIB is not used.
-
-=back
-
-Perl also has environment variables that control how Perl handles data
-specific to particular natural languages. See L<perllocale>.
-
-Apart from these, Perl uses no other environment variables, except
-to make them available to the script being executed, and to child
-processes. However, scripts running setuid would do well to execute
-the following lines before doing anything else, just to keep people
-honest:
-
- $ENV{'PATH'} = '/bin:/usr/bin'; # or whatever you need
- $ENV{'SHELL'} = '/bin/sh' if defined $ENV{'SHELL'};
- $ENV{'IFS'} = '' if defined $ENV{'IFS'};
+See L<perlrun>.
=head1 AUTHOR
error on the I<second> call to a given method (since there is no cache
on the first call).
+=item Extended API for manipulating hashes
+
+Internal handling of hash keys has changed. The old hashtable API is
+still fully supported, and will likely remain so. The additions to the
+API allow passing keys as C<SV*>s, so that C<tied> hashes can be given
+real scalars as keys rather than plain strings (non-tied hashes still
+can only use strings as keys). New extensions must use the new hash
+access functions and macros if they wish to use C<SV*> keys. These
+additions also make it feasible to manipulate C<HE*>s (hash entries),
+which can be more efficient. See L<perlguts> for details.
+
=back
=head1 Documentation Changes
=over
-=item L<perlbug>
-
-A "howto" on reporting perl bugs.
-
=item L<perldelta>
This document.
If you believe you have an unreported bug, please run the B<perlbug>
program included with your release. Make sure you trim your bug
down to a tiny but sufficient test case. Your bug report, along
-with the output of C<perl -V>, will be sent off to perlbug@perl.com
+with the output of C<perl -V>, will be sent off to F<perlbug@perl.com>
to be analysed by the Perl porting team.
=head1 SEE ALSO
while (i--)
hash = hash * 33 + *s++;
+=head2 Hash API Extensions
+
+Beginning with version 5.004, the following functions are also supported:
+
+ HE* hv_fetch_ent (HV* tb, SV* key, I32 lval, U32 hash);
+ HE* hv_store_ent (HV* tb, SV* key, SV* val, U32 hash);
+
+ bool hv_exists_ent (HV* tb, SV* key, U32 hash);
+ SV* hv_delete_ent (HV* tb, SV* key, I32 flags, U32 hash);
+
+ SV* hv_iterkeysv (HE* entry);
+
+Note that these functions take C<SV*> keys, which simplifies writing
+of extension code that deals with hash structures. These functions
+also allow passing of C<SV*> keys to C<tie> functions without forcing
+you to stringify the keys (unlike the previous set of functions).
+
+They also return and accept whole hash entries (C<HE*>), making their
+use more efficient (since the hash number for a particular string
+doesn't have to be recomputed every time). See L<API LISTING> later in
+this document for detailed descriptions.
+
+The following macros must always be used to access the contents of hash
+entries. Note that the arguments to these macros must be simple
+variables, since they may get evaluated more than once. See
+L<API LISTING> later in this document for detailed descriptions of these
+macros.
+
+ HePV(HE* he, STRLEN len)
+ HeVAL(HE* he)
+ HeHASH(HE* he)
+ HeSVKEY(HE* he)
+ HeSVKEY_force(HE* he)
+ HeSVKEY_set(HE* he, SV* sv)
+
+These two lower level macros are defined, but must only be used when
+dealing with keys that are not C<SV*>s:
+
+ HeKEY(HE* he)
+ HeKLEN(HE* he)
+
+
=head2 References
References are a special type of scalar that point to other data types
void he_delayfree _((HV* hv, HE* hent));
+=item HEf_SVKEY
+
+This flag, used in the length slot of hash entries and magic
+structures, specifies the structure contains a C<SV*> pointer where a
+C<char*> pointer is to be expected. (For information only--not to be used).
+
=item he_free
Releases a hash entry, such as while iterating though the hash. See
void he_free _((HV* hv, HE* hent));
+=item HeHASH
+
+Returns the computed hash (type C<U32>) stored in the hash entry.
+
+ HeHASH(HE* he)
+
+=item HeKEY
+
+Returns the actual pointer stored in the key slot of the hash entry.
+The pointer may be either C<char*> or C<SV*>, depending on the value of
+C<HeKLEN()>. Can be assigned to. The C<HePV()> or C<HeSVKEY()> macros
+are usually preferable for finding the value of a key.
+
+ HeKEY(HE* he)
+
+=item HeKLEN
+
+If this is negative, and amounts to C<HEf_SVKEY>, it indicates the entry
+holds an C<SV*> key. Otherwise, holds the actual length of the key.
+Can be assigned to. The C<HePV()> macro is usually preferable for finding
+key lengths.
+
+ HeKLEN(HE* he)
+
+=item HePV
+
+Returns the key slot of the hash entry as a C<char*> value, doing any
+necessary dereferencing of possibly C<SV*> keys. The length of
+the string is placed in C<len> (this is a macro, so do I<not> use
+C<&len>). If you do not care about what the length of the key is,
+you may use the global variable C<na>. Remember though, that hash
+keys in perl are free to contain embedded nulls, so using C<strlen()>
+or similar is not a good way to find the length of hash keys.
+This is very similar to the C<SvPV()> macro described elsewhere in
+this document.
+
+ HePV(HE* he, STRLEN len)
+
+=item HeSVKEY
+
+Returns the key as an C<SV*>, or C<Nullsv> if the hash entry
+does not contain an C<SV*> key.
+
+ HeSVKEY(HE* he)
+
+=item HeSVKEY_force
+
+Returns the key as an C<SV*>. Will create and return a temporary
+mortal C<SV*> if the hash entry contains only a C<char*> key.
+
+ HeSVKEY_force(HE* he)
+
+=item HeSVKEY_set
+
+Sets the key to a given C<SV*>, taking care to set the appropriate flags
+to indicate the presence of an C<SV*> key, and returns the same C<SV*>.
+
+ HeSVKEY_set(HE* he, SV* sv)
+
+=item HeVAL
+
+Returns the value slot (type C<SV*>) stored in the hash entry.
+
+ HeVAL(HE* he)
+
=item hv_clear
Clears a hash, making it empty.
SV* hv_delete _((HV* tb, char* key, U32 klen, I32 flags));
+=item hv_delete_ent
+
+Deletes a key/value pair in the hash. The value SV is removed from the hash
+and returned to the caller. The C<flags> value will normally be zero; if set
+to G_DISCARD then null will be returned. C<hash> can be a valid pre-computed
+hash value, or 0 to ask for it to be computed.
+
+ SV* hv_delete_ent _((HV* tb, SV* key, I32 flags, U32 hash));
+
=item hv_exists
Returns a boolean indicating whether the specified hash key exists. The
bool hv_exists _((HV* tb, char* key, U32 klen));
+=item hv_exists_ent
+
+Returns a boolean indicating whether the specified hash key exists. C<hash>
+can be a valid pre-computed hash value, or 0 to ask for it to be computed.
+
+ bool hv_exists_ent _((HV* tb, SV* key, U32 hash));
+
=item hv_fetch
Returns the SV which corresponds to the specified key in the hash. The
SV** hv_fetch _((HV* tb, char* key, U32 klen, I32 lval));
+=item hv_fetch_ent
+
+Returns the hash entry which corresponds to the specified key in the hash.
+C<hash> must be a valid pre-computed hash number for the given C<key>, or
+0 if you want the function to compute it. IF C<lval> is set then the
+fetch will be part of a store. Make sure the return value is non-null
+before accessing it. The return value when C<tb> is a tied hash
+is a pointer to a static location, so be sure to make a copy of the
+structure if you need to store it somewhere.
+
+ HE* hv_fetch_ent _((HV* tb, SV* key, I32 lval, U32 hash));
+
=item hv_iterinit
Prepares a starting point to traverse a hash table.
char* hv_iterkey _((HE* entry, I32* retlen));
+=item hv_iterkeysv
+
+Returns the key as an C<SV*> from the current position of the hash
+iterator. The return value will always be a mortal copy of the
+key. Also see C<hv_iterinit>.
+
+ SV* hv_iterkeysv _((HE* entry));
+
=item hv_iternext
Returns entries from a hash iterator. See C<hv_iterinit>.
SV** hv_store _((HV* tb, char* key, U32 klen, SV* val, U32 hash));
+=item hv_store_ent
+
+Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
+parameter is the pre-computed hash value; if it is zero then Perl will
+compute it. The return value is the new hash entry so created. It will be
+null if the operation failed or if the entry was stored in a tied hash.
+Otherwise the contents of the return value can be accessed using the
+C<He???> macros described here.
+
+ HE* hv_store_ent _((HV* tb, SV* key, SV* val, U32 hash));
+
=item hv_undef
Undefines the hash.
=head1 DATE
-Version 31: 1997/1/27
+Version 31.1: 1997/2/25
is broken and cannot be fixed or used by Perl. Such deficiencies can
and will result in mysterious hangs and/or Perl core dumps when the
C<use locale> is in effect. When confronted with such a system,
-please report in excruciating detail to C<perlbug@perl.com>, and
+please report in excruciating detail to F<perlbug@perl.com>, and
complain to your vendor: maybe some bug fixes exist for these problems
in your operating system. Sometimes such bug fixes are called an
operating system upgrade.
script can process any or all of the trailing garbage via the DATA
filehandle if desired).
+=back
+
+=head1 ENVIRONMENT
+
+=over 12
+
+=item HOME
+
+Used if chdir has no argument.
+
+=item LOGDIR
+
+Used if chdir has no argument and HOME is not set.
+
+=item PATH
+
+Used in executing subprocesses, and in finding the script if B<-S> is
+used.
+
+=item PERL5LIB
+
+A colon-separated list of directories in which to look for Perl library
+files before looking in the standard library and the current
+directory. If PERL5LIB is not defined, PERLLIB is used. When running
+taint checks (because the script was running setuid or setgid, or the
+B<-T> switch was used), neither variable is used. The script should
+instead say
+
+ use lib "/my/directory";
+
+=item PERLLIB
+
+A colon-separated list of directories in which to look for Perl library
+files before looking in the standard library and the current directory.
+If PERL5LIB is defined, PERLLIB is not used.
+
+=item PERL5DB
+
+The command used to load the debugger code. The default is:
+
+ BEGIN { require 'perl5db.pl' }
+
+=item PERL_DEBUG_MSTATS
+
+Relevant only if your perl executable was built with B<-DDEBUGGING_MSTATS>,
+if set, this causes memory statistics to be dumped after execution. If set
+to an integer greater than one, also causes memory statistics to be dumped
+after compilation.
+
+=item PERL_DESTRUCT_LEVEL
+
+Relevant only if your perl executable was built with B<-DDEBUGGING>,
+this controls the behavior of global destruction of objects and other
+references.
=back
+
+Perl also has environment variables that control how Perl handles data
+specific to particular natural languages. See L<perllocale>.
+
+Apart from these, Perl uses no other environment variables, except
+to make them available to the script being executed, and to child
+processes. However, scripts running setuid would do well to execute
+the following lines before doing anything else, just to keep people
+honest:
+
+ $ENV{'PATH'} = '/bin:/usr/bin'; # or whatever you need
+ $ENV{'SHELL'} = '/bin/sh' if defined $ENV{'SHELL'};
+ $ENV{'IFS'} = '' if defined $ENV{'IFS'};
+
I<strongly> suggested for server programs and any program run on behalf of
someone else, such as a CGI script.
-While in this mode, Perl takes special precautions called I<taint checks> to
-prevent both obvious and subtle traps. Some of these checks are reasonably
-simple, such as not blindly using the PATH inherited from one's parent
-process. Other checks, however, are best supported by the language itself,
+While in this mode, Perl takes special precautions called I<taint
+checks> to prevent both obvious and subtle traps. Some of these checks
+are reasonably simple, such as verifying that path directories aren't
+writable by others; careful programmers have always used checks like
+these. Other checks, however, are best supported by the language itself,
and it is these checks especially that contribute to making a setuid Perl
program more secure than the corresponding C program.
=head2 Cleaning Up Your Path
For "Insecure C<$ENV{PATH}>" messages, you need to set C<$ENV{'PATH'}> to a
-known value. You may be surprised to get this message even if the pathname
-to your executable is fully qualified. This is I<not> generated because you
-didn't supply a full path to the program; instead, it's generated because
-you never set your PATH environment variable. Because Perl can't guarantee
-that the executable in question isn't itself going to turn around and
-execute some other program that is dependent on your PATH, it makes sure you
-set the PATH.
+known value, and each directory in the path must be non-writable by others
+than its owner and group. You may be surprised to get this message even
+if the pathname to your executable is fully qualified. This is I<not>
+generated because you didn't supply a full path to the program; instead,
+it's generated because you never set your PATH environment variable, or
+you didn't set it to something that was safe. Because Perl can't
+guarantee that the executable in question isn't itself going to turn
+around and execute some other program that is dependent on your PATH, it
+makes sure you set the PATH.
It's also possible to get into trouble with other operations that don't
care whether they use tainted values. Make judicious use of the file
=item ENVIRONMENT
-HOME, LOGDIR, PATH, PERL5LIB, PERL5DB, PERL_DESTRUCT_LEVEL, PERLLIB
-
=item AUTHOR
=item FILES
=item C Language API Changes
-C<gv_fetchmethod> and C<perl_call_sv>
+C<gv_fetchmethod> and C<perl_call_sv>, Extended API for manipulating hashes
=item Documentation Changes
-L<perlbug>, L<perldelta>, L<perllocale>, L<perltoot>, L<perlapio>,
-L<perldebug>, L<perlsec>
+L<perldelta>, L<perllocale>, L<perltoot>, L<perlapio>, L<perldebug>,
+L<perlsec>
=item New Diagnostics
=back
+=item ENVIRONMENT
+
+HOME, LOGDIR, PATH, PERL5LIB, PERLLIB, PERL5DB, PERL_DEBUG_MSTATS,
+PERL_DESTRUCT_LEVEL
+
=head2 perlfunc - Perl builtin functions
=item DESCRIPTION
=item Working with HV's
+=item Hash API Extensions
+
=item References
=item Blessed References and Class Objects
DBsingle, DBsub, DBtrace, dMARK, dORIGMARK, dowarn, dSP, dXSARGS, dXSI32,
dXSI32, ENTER, EXTEND, FREETMPS, G_ARRAY, G_DISCARD, G_EVAL, GIMME,
G_NOARGS, G_SCALAR, gv_fetchmeth, gv_fetchmethod, gv_stashpv, gv_stashsv,
-GvSV, he_delayfree, he_free, hv_clear, hv_delete, hv_exists, hv_fetch,
-hv_iterinit, hv_iterkey, hv_iternext, hv_iternextsv, hv_iterval, hv_magic,
-HvNAME, hv_store, hv_undef, isALNUM, isALPHA, isDIGIT, isLOWER, isSPACE,
-isUPPER, items, ix, LEAVE, MARK, mg_clear, mg_copy, mg_find, mg_free,
-mg_get, mg_len, mg_magical, mg_set, Move, na, New, Newc, Newz, newAV,
-newHV, newRV_inc, newRV_noinc, newSV, newSViv, newSVnv, newSVpv, newSVrv,
-newSVsv, newXS, newXSproto, Nullav, Nullch, Nullcv, Nullhv, Nullsv,
-ORIGMARK, perl_alloc, perl_call_argv, perl_call_method, perl_call_pv,
-perl_call_sv, perl_construct, perl_destruct, perl_eval_sv, perl_free,
-perl_get_av, perl_get_cv, perl_get_hv, perl_get_sv, perl_parse,
-perl_require_pv, perl_run, POPi, POPl, POPp, POPn, POPs, PUSHMARK, PUSHi,
-PUSHn, PUSHp, PUSHs, PUTBACK, Renew, Renewc, RETVAL, safefree, safemalloc,
-saferealloc, savepv, savepvn, SAVETMPS, SP, SPAGAIN, ST, strEQ, strGE,
-strGT, strLE, strLT, strNE, strnEQ, strnNE, sv_2mortal, sv_bless, sv_catpv,
-sv_catpvn, sv_catsv, sv_cmp, sv_cmp, SvCUR, SvCUR_set, sv_dec, sv_dec,
-SvEND, sv_eq, SvGROW, sv_grow, sv_inc, SvIOK, SvIOK_off, SvIOK_on,
-SvIOK_only, SvIOK_only, SvIOKp, sv_isa, SvIV, sv_isobject, SvIVX, SvLEN,
-sv_len, sv_len, sv_magic, sv_mortalcopy, SvOK, sv_newmortal, sv_no, SvNIOK,
-SvNIOK_off, SvNIOKp, SvNOK, SvNOK_off, SvNOK_on, SvNOK_only, SvNOK_only,
-SvNOKp, SvNV, SvNVX, SvPOK, SvPOK_off, SvPOK_on, SvPOK_only, SvPOK_only,
-SvPOKp, SvPV, SvPVX, SvREFCNT, SvREFCNT_dec, SvREFCNT_inc, SvROK,
-SvROK_off, SvROK_on, SvRV, sv_setiv, sv_setnv, sv_setpv, sv_setpvn,
-sv_setref_iv, sv_setref_nv, sv_setref_pv, sv_setref_pvn, sv_setsv, SvSTASH,
-SVt_IV, SVt_PV, SVt_PVAV, SVt_PVCV, SVt_PVHV, SVt_PVMG, SVt_NV, SvTRUE,
-SvTYPE, svtype, SvUPGRADE, sv_upgrade, sv_undef, sv_unref, sv_usepvn,
-sv_yes, THIS, toLOWER, toUPPER, warn, XPUSHi, XPUSHn, XPUSHp, XPUSHs, XS,
-XSRETURN, XSRETURN_EMPTY, XSRETURN_IV, XSRETURN_NO, XSRETURN_NV,
-XSRETURN_PV, XSRETURN_UNDEF, XSRETURN_YES, XST_mIV, XST_mNV, XST_mNO,
-XST_mPV, XST_mUNDEF, XST_mYES, XS_VERSION, XS_VERSION_BOOTCHECK, Zero
+GvSV, he_delayfree, HEf_SVKEY, he_free, HeHASH, HeKEY, HeKLEN, HePV,
+HeSVKEY, HeSVKEY_force, HeSVKEY_set, HeVAL, hv_clear, hv_delete,
+hv_delete_ent, hv_exists, hv_exists_ent, hv_fetch, hv_fetch_ent,
+hv_iterinit, hv_iterkey, hv_iterkeysv
+Returns the key as an C<SV*> from the current position of the hash
+iterator. The return value will always be a mortal copy of the
+key. Also see C<hv_iterinit>, hv_iternext, hv_iternextsv, hv_iterval,
+hv_magic, HvNAME, hv_store, hv_store_ent, hv_undef, isALNUM, isALPHA,
+isDIGIT, isLOWER, isSPACE, isUPPER, items, ix, LEAVE, MARK, mg_clear,
+mg_copy, mg_find, mg_free, mg_get, mg_len, mg_magical, mg_set, Move, na,
+New, Newc, Newz, newAV, newHV, newRV_inc, newRV_noinc, newSV, newSViv,
+newSVnv, newSVpv, newSVrv, newSVsv, newXS, newXSproto, Nullav, Nullch,
+Nullcv, Nullhv, Nullsv, ORIGMARK, perl_alloc, perl_call_argv,
+perl_call_method, perl_call_pv, perl_call_sv, perl_construct,
+perl_destruct, perl_eval_sv, perl_free, perl_get_av, perl_get_cv,
+perl_get_hv, perl_get_sv, perl_parse, perl_require_pv, perl_run, POPi,
+POPl, POPp, POPn, POPs, PUSHMARK, PUSHi, PUSHn, PUSHp, PUSHs, PUTBACK,
+Renew, Renewc, RETVAL, safefree, safemalloc, saferealloc, savepv, savepvn,
+SAVETMPS, SP, SPAGAIN, ST, strEQ, strGE, strGT, strLE, strLT, strNE,
+strnEQ, strnNE, sv_2mortal, sv_bless, sv_catpv, sv_catpvn, sv_catsv,
+sv_cmp, sv_cmp, SvCUR, SvCUR_set, sv_dec, sv_dec, SvEND, sv_eq, SvGROW,
+sv_grow, sv_inc, SvIOK, SvIOK_off, SvIOK_on, SvIOK_only, SvIOK_only,
+SvIOKp, sv_isa, SvIV, sv_isobject, SvIVX, SvLEN, sv_len, sv_len, sv_magic,
+sv_mortalcopy, SvOK, sv_newmortal, sv_no, SvNIOK, SvNIOK_off, SvNIOKp,
+SvNOK, SvNOK_off, SvNOK_on, SvNOK_only, SvNOK_only, SvNOKp, SvNV, SvNVX,
+SvPOK, SvPOK_off, SvPOK_on, SvPOK_only, SvPOK_only, SvPOKp, SvPV, SvPVX,
+SvREFCNT, SvREFCNT_dec, SvREFCNT_inc, SvROK, SvROK_off, SvROK_on, SvRV,
+sv_setiv, sv_setnv, sv_setpv, sv_setpvn, sv_setref_iv, sv_setref_nv,
+sv_setref_pv, sv_setref_pvn, sv_setsv, SvSTASH, SVt_IV, SVt_PV, SVt_PVAV,
+SVt_PVCV, SVt_PVHV, SVt_PVMG, SVt_NV, SvTRUE, SvTYPE, svtype, SvUPGRADE,
+sv_upgrade, sv_undef, sv_unref, sv_usepvn, sv_yes, THIS, toLOWER, toUPPER,
+warn, XPUSHi, XPUSHn, XPUSHp, XPUSHs, XS, XSRETURN, XSRETURN_EMPTY,
+XSRETURN_IV, XSRETURN_NO, XSRETURN_NV, XSRETURN_PV, XSRETURN_UNDEF,
+XSRETURN_YES, XST_mIV, XST_mNV, XST_mNO, XST_mPV, XST_mUNDEF, XST_mYES,
+XS_VERSION, XS_VERSION_BOOTCHECK, Zero
=item EDITOR
[ B<--date=>I<string> ]
[ B<--fixed=>I<font> ]
[ B<--official> ]
+[ B<--lax> ]
I<inputfile>
=head1 DESCRIPTION
F</usr/local/perl/man/>. By default, section 1 will be used
unless the file ends in F<.pm> in which case section 3 will be selected.
+=item lax
+
+Don't complain when required sections aren't present.
+
=back
=head1 Anatomy of a Proper Man Page
$DEF_CENTER = "User Contributed Perl Documentation";
$STD_CENTER = "Perl Programmers Reference Guide";
$DEF_FIXED = 'CW';
+$DEF_LAX = 0;
sub usage {
warn "$0: @_\n" if @_;
--date=string (default "$DEF_DATE")
--fixed=font (default "$DEF_FIXED")
--official (default NOT)
+ --lax (default NOT)
EOF
}
date=s
fixed=s
official
+ lax
help));
$DEF_DATE = makedate((stat($ARGV[0]))[9] || time());
$section = $opt_section || ($ARGV[0] =~ /\.pm$/ ? 3 : $DEF_SECTION);
$RP = $opt_release || $DEF_RELEASE;
$center = $opt_center || ($opt_official ? $STD_CENTER : $DEF_CENTER);
+$lax = $opt_lax || $DEF_LAX;
$CFont = $opt_fixed || $DEF_FIXED;
last FCHECK;
}
next if /^=cut\b/; # DB_File and Net::Ping have =cut before NAME
- die "$0: Invalid man page - 1st pod line is not NAME in $ARGV[0]\n";
+ die "$0: Invalid man page - 1st pod line is not NAME in $ARGV[0]\n" unless $lax;
}
- die "$0: Invalid man page - no documentation in $ARGV[0]\n";
+ die "$0: Invalid man page - no documentation in $ARGV[0]\n" unless $lax;
}
close F;
}
.rn }` ''
END
-if (%wanna_see) {
+if (%wanna_see && !$lax) {
@missing = keys %wanna_see;
warn "$0: $Filename is missing required section"
. (@missing > 1 && "s")
# make troff just be normal, but make small nroff get quoted
# decided to just put the quotes in the text; sigh;
sub ccvt {
- local($_,$prev) = @_;
- if ( /^\W+$/ && !/^\$./ ) {
- ($prev && "\n") . noremap(qq{.CQ $_ \n\\&});
- # what about $" ?
- } else {
- noremap(qq{${CFont_embed}$_\\fR});
- }
+ local($_,$prev) = @_;
noremap(qq{.CQ "$_" \n\\&});
}
register I32 ch;
register I32 *sfirst;
register I32 *snext;
- I32 retval;
STRLEN len;
- s = (unsigned char*)(SvPV(sv, len));
- pos = len;
- if (sv == lastscream)
- SvSCREAM_off(sv);
+ if (sv == lastscream) {
+ if (SvSCREAM(sv))
+ RETPUSHYES;
+ }
else {
if (lastscream) {
SvSCREAM_off(lastscream);
}
lastscream = SvREFCNT_inc(sv);
}
- if (pos <= 0) {
- retval = 0;
- goto ret;
- }
+
+ s = (unsigned char*)(SvPV(sv, len));
+ pos = len;
+ if (pos <= 0)
+ RETPUSHNO;
if (pos > maxscream) {
if (maxscream < 0) {
maxscream = pos + 80;
SvSCREAM_on(sv);
sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
- retval = 1;
- ret:
- XPUSHs(sv_2mortal(newSViv((I32)retval)));
- RETURN;
+ RETPUSHYES;
}
PP(pp_trans)
sv_setsv(sv, &sv_undef);
break;
default:
- if (SvPOK(sv) && SvLEN(sv)) {
+ if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
(void)SvOOK_off(sv);
Safefree(SvPVX(sv));
SvPV_set(sv, Nullch);
}
}
- sv_setiv(TARG, (I32)retnum);
+ sv_setiv(TARG, (IV)retnum);
PUSHs(TARG);
RETURN;
}
if (aint >= 128) /* fake up signed chars */
aint -= 256;
sv = NEWSV(36, 0);
- sv_setiv(sv, (I32)aint);
+ sv_setiv(sv, (IV)aint);
PUSHs(sv_2mortal(sv));
}
}
while (len-- > 0) {
auint = *s++ & 255;
sv = NEWSV(37, 0);
- sv_setiv(sv, (I32)auint);
+ sv_setiv(sv, (IV)auint);
PUSHs(sv_2mortal(sv));
}
}
Copy(s, &ashort, 1, I16);
s += sizeof(I16);
sv = NEWSV(38, 0);
- sv_setiv(sv, (I32)ashort);
+ sv_setiv(sv, (IV)ashort);
PUSHs(sv_2mortal(sv));
}
}
if (datumtype == 'v')
aushort = vtohs(aushort);
#endif
- sv_setiv(sv, (I32)aushort);
+ sv_setiv(sv, (IV)aushort);
PUSHs(sv_2mortal(sv));
}
}
Copy(s, &aint, 1, int);
s += sizeof(int);
sv = NEWSV(40, 0);
- sv_setiv(sv, (I32)aint);
+ sv_setiv(sv, (IV)aint);
PUSHs(sv_2mortal(sv));
}
}
Copy(s, &auint, 1, unsigned int);
s += sizeof(unsigned int);
sv = NEWSV(41, 0);
- if (auint <= I32_MAX)
- sv_setiv(sv, (I32)auint);
- else
- sv_setnv(sv, (double)auint);
+ sv_setuv(sv, (UV)auint);
PUSHs(sv_2mortal(sv));
}
}
Copy(s, &along, 1, I32);
s += sizeof(I32);
sv = NEWSV(42, 0);
- sv_setiv(sv, (I32)along);
+ sv_setiv(sv, (IV)along);
PUSHs(sv_2mortal(sv));
}
}
while (len-- > 0) {
Copy(s, &aulong, 1, U32);
s += sizeof(U32);
- sv = NEWSV(43, 0);
#ifdef HAS_NTOHL
if (datumtype == 'N')
aulong = ntohl(aulong);
if (datumtype == 'V')
aulong = vtohl(aulong);
#endif
- sv_setnv(sv, (double)aulong);
+ sv = NEWSV(43, 0);
+ sv_setuv(sv, (UV)aulong);
PUSHs(sv_2mortal(sv));
}
}
s += sizeof(unsigned Quad_t);
}
sv = NEWSV(43, 0);
- sv_setiv(sv, (IV)auquad);
+ sv_setuv(sv, (UV)auquad);
PUSHs(sv_2mortal(sv));
}
break;
#define WORD_ALIGN sizeof(U16)
#endif
+#define DOCATCH(o) (mustcatch ? docatch(o) : (o))
+
+static OP *docatch _((OP *o));
static OP *doeval _((int gimme));
static OP *dofindlabel _((OP *op, char *label, OP **opstack));
static void doparseform _((SV *sv));
AV *oldstack;
CONTEXT *cx;
SV** newsp;
+ bool oldmustcatch = mustcatch;
SAVETMPS;
SAVESPTR(op);
AvREAL_off(sortstack);
av_extend(sortstack, 32);
}
+ mustcatch = TRUE;
SWITCHSTACK(curstack, sortstack);
if (sortstash != stash) {
firstgv = gv_fetchpv("a", TRUE, SVt_PV);
POPBLOCK(cx,curpm);
SWITCHSTACK(sortstack, oldstack);
+ mustcatch = oldmustcatch;
}
LEAVE;
}
}
static OP *
+docatch(o)
+OP *o;
+{
+ int ret;
+ int oldrunlevel = runlevel;
+ OP *oldop = op;
+ Sigjmp_buf oldtop;
+
+ op = o;
+ Copy(top_env, oldtop, 1, Sigjmp_buf);
+#ifdef DEBUGGING
+ assert(mustcatch == TRUE);
+#endif
+ mustcatch = FALSE;
+ switch ((ret = Sigsetjmp(top_env,1))) {
+ default: /* topmost level handles it */
+ Copy(oldtop, top_env, 1, Sigjmp_buf);
+ runlevel = oldrunlevel;
+ mustcatch = TRUE;
+ op = oldop;
+ Siglongjmp(top_env, ret);
+ /* NOTREACHED */
+ case 3:
+ if (!restartop) {
+ PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
+ break;
+ }
+ mustcatch = FALSE;
+ op = restartop;
+ restartop = 0;
+ /* FALL THROUGH */
+ case 0:
+ runops();
+ break;
+ }
+ Copy(oldtop, top_env, 1, Sigjmp_buf);
+ runlevel = oldrunlevel;
+ mustcatch = TRUE;
+ op = oldop;
+ return Nullop;
+}
+
+static OP *
doeval(gimme)
int gimme;
{
compiling.cop_line = 0;
PUTBACK;
- return doeval(G_SCALAR);
+ return DOCATCH(doeval(G_SCALAR));
}
PP(pp_dofile)
if (perldb && was != sub_generation) { /* Some subs defined here. */
strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
}
- return ret;
+ return DOCATCH(ret);
}
PP(pp_leaveeval)
in_eval = 1;
sv_setpv(GvSV(errgv),"");
- RETURN;
+ PUTBACK;
+ return DOCATCH(op->op_next);
}
PP(pp_leavetry)
++BmUSEFUL(pm->op_pmshort);
ret_no:
- TAINT_IF(rx->exec_tainted); /* /\W/ */
LEAVE_SCOPE(oldsave);
if (gimme == G_ARRAY)
RETURN;
PerlIO_rewind(tmpfp);
IoTYPE(io) = '<';
IoIFP(io) = fp = tmpfp;
+ IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
}
}
}
if (c && clen <= rx->minlen) {
if (! pregexec(rx, s, strend, orig, 0,
SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
- TAINT_IF(rx->exec_tainted);
PUSHs(&sv_no);
LEAVE_SCOPE(oldsave);
RETURN;
RETURN;
}
- TAINT_IF(rx->exec_tainted);
PUSHs(&sv_no);
LEAVE_SCOPE(oldsave);
RETURN;
SV **mark = stack_base + ++*markstack_ptr; /* reuse in entersub */
I32 markoff = mark - stack_base - 1;
char *methname;
+ bool oldmustcatch = mustcatch;
varsv = mark[0];
if (SvTYPE(varsv) == SVt_PVHV)
myop.op_last = (OP *) &myop;
myop.op_next = Nullop;
myop.op_flags = OPf_KNOW|OPf_STACKED;
+ mustcatch = TRUE;
ENTER;
SAVESPTR(op);
runops();
SPAGAIN;
+ mustcatch = oldmustcatch;
sv = TOPs;
if (sv_isobject(sv)) {
if (SvTYPE(varsv) == SVt_PVHV || SvTYPE(varsv) == SVt_PVAV) {
GV *gv;
BINOP myop;
SV *sv;
+ bool oldmustcatch = mustcatch;
hv = (HV*)POPs;
myop.op_last = (OP *) &myop;
myop.op_next = Nullop;
myop.op_flags = OPf_KNOW|OPf_STACKED;
+ mustcatch = TRUE;
ENTER;
SAVESPTR(op);
SPAGAIN;
}
+ mustcatch = oldmustcatch;
if (sv_isobject(TOPs))
sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
LEAVE;
IO *io;
char *buffer;
int length;
- int bufsize;
+ Sock_size_t bufsize;
SV *bufsv;
STRLEN blen;
SETERRNO(0,0);
#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
if (op->op_flags & OPf_SPECIAL) {
- tmpgv = gv_fetchpv(POPp,FALSE, SVt_PVIO);
+ tmpgv = gv_fetchpv(POPp, FALSE, SVt_PVIO);
do_ftruncate:
+ TAINT_PROPER("truncate");
if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
#ifdef HAS_TRUNCATE
ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
}
else {
SV *sv = POPs;
+ char *name;
+
if (SvTYPE(sv) == SVt_PVGV) {
tmpgv = (GV*)sv; /* *main::FRED for example */
goto do_ftruncate;
tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
goto do_ftruncate;
}
+
+ name = SvPV(sv, na);
+ TAINT_PROPER("truncate");
#ifdef HAS_TRUNCATE
- if (truncate (SvPV (sv, na), len) < 0)
+ if (truncate(name, len) < 0)
result = 0;
#else
{
int tmpfd;
-
- if ((tmpfd = open(SvPV (sv, na), O_RDWR)) < 0)
+ if ((tmpfd = open(name, O_RDWR)) < 0)
result = 0;
else {
if (my_chsize(tmpfd, len) < 0)
register IO *nstio;
register IO *gstio;
struct sockaddr saddr; /* use a struct to avoid alignment problems */
- int len = sizeof saddr;
+ Sock_size_t len = sizeof saddr;
int fd;
ggv = (GV*)POPs;
unsigned int lvl;
GV *gv;
register IO *io;
- int aint;
+ Sock_size_t len;
if (optype == OP_GSOCKOPT)
sv = sv_2mortal(NEWSV(22, 257));
(void)SvPOK_only(sv);
SvCUR_set(sv,256);
*SvEND(sv) ='\0';
- aint = SvCUR(sv);
- if (getsockopt(fd, lvl, optname, SvPVX(sv), &aint) < 0)
+ len = SvCUR(sv);
+ if (getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
goto nuts2;
- SvCUR_set(sv,aint);
+ SvCUR_set(sv, len);
*SvEND(sv) ='\0';
PUSHs(sv);
break;
case OP_SSOCKOPT: {
- STRLEN len = 0;
- char *buf = 0;
- if (SvPOKp(sv))
- buf = SvPV(sv, len);
+ char *buf;
+ int aint;
+ if (SvPOKp(sv)) {
+ buf = SvPV(sv, na);
+ len = na;
+ }
else if (SvOK(sv)) {
aint = (int)SvIV(sv);
buf = (char*)&aint;
len = sizeof(int);
}
- if (setsockopt(fd, lvl, optname, buf, (int)len) < 0)
+ if (setsockopt(fd, lvl, optname, buf, len) < 0)
goto nuts2;
PUSHs(&sv_yes);
}
int fd;
GV *gv = (GV*)POPs;
register IO *io = GvIOn(gv);
- int aint;
+ Sock_size_t len;
if (!io || !IoIFP(io))
goto nuts;
sv = sv_2mortal(NEWSV(22, 257));
(void)SvPOK_only(sv);
- SvCUR_set(sv,256);
+ len = 256;
+ SvCUR_set(sv, len);
*SvEND(sv) ='\0';
- aint = SvCUR(sv);
fd = PerlIO_fileno(IoIFP(io));
switch (optype) {
case OP_GETSOCKNAME:
- if (getsockname(fd, (struct sockaddr *)SvPVX(sv), &aint) < 0)
+ if (getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
goto nuts2;
break;
case OP_GETPEERNAME:
- if (getpeername(fd, (struct sockaddr *)SvPVX(sv), &aint) < 0)
+ if (getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
goto nuts2;
break;
}
#ifdef BOGUS_GETNAME_RETURN
/* Interactive Unix, getpeername() and getsockname()
does not return valid namelen */
- if (aint == BOGUS_GETNAME_RETURN)
- aint = sizeof(struct sockaddr);
+ if (len == BOGUS_GETNAME_RETURN)
+ len = sizeof(struct sockaddr);
#endif
- SvCUR_set(sv,aint);
+ SvCUR_set(sv, len);
*SvEND(sv) ='\0';
PUSHs(sv);
RETURN;
char *cmd;
char *filename;
{
- char mybuf[8192];
- char *s,
- *save_filename = filename;
- int anum = 1;
+ char *save_filename = filename;
+ char *cmdline;
+ char *s;
PerlIO *myfp;
+ int anum = 1;
- strcpy(mybuf, cmd);
- strcat(mybuf, " ");
- for (s = mybuf+strlen(mybuf); *filename; ) {
+ New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
+ strcpy(cmdline, cmd);
+ strcat(cmdline, " ");
+ for (s = cmdline + strlen(cmdline); *filename; ) {
*s++ = '\\';
*s++ = *filename++;
}
strcpy(s, " 2>&1");
- myfp = my_popen(mybuf, "r");
+ myfp = my_popen(cmdline, "r");
+ Safefree(cmdline);
+
if (myfp) {
- *mybuf = '\0';
+ SV *tmpsv = sv_newmortal();
/* Need to save/restore 'rs' ?? */
s = sv_gets(tmpsv, myfp, 0);
(void)my_pclose(myfp);
if (s != Nullch) {
- for (errno = 1; errno < sys_nerr; errno++) {
+ int e;
+ for (e = 1;
#ifdef HAS_SYS_ERRLIST
- if (instr(mybuf, sys_errlist[errno])) /* you don't see this */
- return 0;
+ e <= sys_nerr
+#endif
+ ; e++)
+ {
+ /* you don't see this */
+ char *errmsg =
+#ifdef HAS_SYS_ERRLIST
+ sys_errlist[e]
#else
- char *errmsg; /* especially if it isn't there */
-
- if (instr(mybuf,
- (errmsg = strerror(errno)) ? errmsg : "NoErRoR"))
- return 0;
+ strerror(e)
#endif
+ ;
+ if (!errmsg)
+ break;
+ if (instr(s, errmsg)) {
+ SETERRNO(e,0);
+ return 0;
+ }
}
SETERRNO(0,0);
#ifndef EACCES
#define EACCES EPERM
#endif
- if (instr(mybuf, "cannot make"))
+ if (instr(s, "cannot make"))
SETERRNO(EEXIST,RMS$_FEX);
- else if (instr(mybuf, "existing file"))
+ else if (instr(s, "existing file"))
SETERRNO(EEXIST,RMS$_FEX);
- else if (instr(mybuf, "ile exists"))
+ else if (instr(s, "ile exists"))
SETERRNO(EEXIST,RMS$_FEX);
- else if (instr(mybuf, "non-exist"))
+ else if (instr(s, "non-exist"))
SETERRNO(ENOENT,RMS$_FNF);
- else if (instr(mybuf, "does not exist"))
+ else if (instr(s, "does not exist"))
SETERRNO(ENOENT,RMS$_FNF);
- else if (instr(mybuf, "not empty"))
+ else if (instr(s, "not empty"))
SETERRNO(EBUSY,SS$_DEVOFFLINE);
- else if (instr(mybuf, "cannot access"))
+ else if (instr(s, "cannot access"))
SETERRNO(EACCES,RMS$_PRV);
else
SETERRNO(EPERM,RMS$_PRV);
if (!childpid) {
/*SUPPRESS 560*/
if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
- sv_setiv(GvSV(tmpgv), (I32)getpid());
+ sv_setiv(GvSV(tmpgv), (IV)getpid());
hv_clear(pidstatus); /* no kids, so don't wait for 'em */
}
PUSHi(childpid);
int status;
Sigsave_t ihand,qhand; /* place to save signals during system() */
-#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
if (SP - MARK == 1) {
if (tainting) {
char *junk = SvPV(TOPs, na);
TAINT_PROPER("system");
}
}
+#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
while ((childpid = vfork()) == -1) {
if (errno != EAGAIN) {
value = -1;
sv_catpvn(sv, " ", 1);
}
PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)hent->h_addrtype);
+ sv_setiv(sv, (IV)hent->h_addrtype);
PUSHs(sv = sv_mortalcopy(&sv_no));
len = hent->h_length;
- sv_setiv(sv, (I32)len);
+ sv_setiv(sv, (IV)len);
#ifdef h_addr
for (elem = hent->h_addr_list; elem && *elem; elem++) {
XPUSHs(sv = sv_mortalcopy(&sv_no));
PUSHs(sv = sv_newmortal());
if (nent) {
if (which == OP_GNBYNAME)
- sv_setiv(sv, (I32)nent->n_net);
+ sv_setiv(sv, (IV)nent->n_net);
else
sv_setpv(sv, nent->n_name);
}
sv_catpvn(sv, " ", 1);
}
PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)nent->n_addrtype);
+ sv_setiv(sv, (IV)nent->n_addrtype);
PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)nent->n_net);
+ sv_setiv(sv, (IV)nent->n_net);
}
RETURN;
PUSHs(sv = sv_newmortal());
if (pent) {
if (which == OP_GPBYNAME)
- sv_setiv(sv, (I32)pent->p_proto);
+ sv_setiv(sv, (IV)pent->p_proto);
else
sv_setpv(sv, pent->p_name);
}
sv_catpvn(sv, " ", 1);
}
PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)pent->p_proto);
+ sv_setiv(sv, (IV)pent->p_proto);
}
RETURN;
if (sent) {
if (which == OP_GSBYNAME) {
#ifdef HAS_NTOHS
- sv_setiv(sv, (I32)ntohs(sent->s_port));
+ sv_setiv(sv, (IV)ntohs(sent->s_port));
#else
- sv_setiv(sv, (I32)(sent->s_port));
+ sv_setiv(sv, (IV)(sent->s_port));
#endif
}
else
}
PUSHs(sv = sv_mortalcopy(&sv_no));
#ifdef HAS_NTOHS
- sv_setiv(sv, (I32)ntohs(sent->s_port));
+ sv_setiv(sv, (IV)ntohs(sent->s_port));
#else
- sv_setiv(sv, (I32)(sent->s_port));
+ sv_setiv(sv, (IV)(sent->s_port));
#endif
PUSHs(sv = sv_mortalcopy(&sv_no));
sv_setpv(sv, sent->s_proto);
PUSHs(sv = sv_newmortal());
if (pwent) {
if (which == OP_GPWNAM)
- sv_setiv(sv, (I32)pwent->pw_uid);
+ sv_setiv(sv, (IV)pwent->pw_uid);
else
sv_setpv(sv, pwent->pw_name);
}
PUSHs(sv = sv_mortalcopy(&sv_no));
sv_setpv(sv, pwent->pw_passwd);
PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)pwent->pw_uid);
+ sv_setiv(sv, (IV)pwent->pw_uid);
PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)pwent->pw_gid);
+ sv_setiv(sv, (IV)pwent->pw_gid);
PUSHs(sv = sv_mortalcopy(&sv_no));
#ifdef PWCHANGE
- sv_setiv(sv, (I32)pwent->pw_change);
+ sv_setiv(sv, (IV)pwent->pw_change);
#else
#ifdef PWQUOTA
- sv_setiv(sv, (I32)pwent->pw_quota);
+ sv_setiv(sv, (IV)pwent->pw_quota);
#else
#ifdef PWAGE
sv_setpv(sv, pwent->pw_age);
sv_setpv(sv, pwent->pw_shell);
#ifdef PWEXPIRE
PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)pwent->pw_expire);
+ sv_setiv(sv, (IV)pwent->pw_expire);
#endif
}
RETURN;
PUSHs(sv = sv_newmortal());
if (grent) {
if (which == OP_GGRNAM)
- sv_setiv(sv, (I32)grent->gr_gid);
+ sv_setiv(sv, (IV)grent->gr_gid);
else
sv_setpv(sv, grent->gr_name);
}
PUSHs(sv = sv_mortalcopy(&sv_no));
sv_setpv(sv, grent->gr_passwd);
PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)grent->gr_gid);
+ sv_setiv(sv, (IV)grent->gr_gid);
PUSHs(sv = sv_mortalcopy(&sv_no));
for (elem = grent->gr_mem; *elem; elem++) {
sv_catpv(sv, *elem);
# reason that the diagnostic message might get the
# wrong value is that Config.pm is incorrect.)
#
- if ($max <= 0) { # Just in case...
+ if ($max <= 0 or $max >= (1 << $randbits)) { # Just in case...
print "not ok 1\n";
print "# This perl was compiled with randbits=$randbits\n";
print "# which is _way_ off. Or maybe your system rand is broken,\n";
print "# or your C compiler can't multiply, or maybe Martians\n";
print "# have taken over your computer. For starters, see about\n";
- print "# trying a better value for randbits.\n";
+ print "# trying a better value for randbits, probably smaller.\n";
# If that isn't the problem, we'll have
# to put d_martians into Config.pm
print "# Skipping remaining tests until randbits is fixed.\n";
my($pid, $first);
for (1..5) {
- $pid = open PERL, "./perl -e 'print rand'|";
+ if ($^O eq 'VMS') {
+ $pid = open PERL, qq[MCR $^X -e "print rand"|];
+ }
+ else {
+ $pid = open PERL, "./perl -e 'print rand'|";
+ }
die "Couldn't pipe from perl: $!" unless defined $pid;
if (defined $first) {
if ($first ne <PERL>) {
--- /dev/null
+#!./perl
+
+##
+## all of these tests are from Michael Schroeder
+## <Michael.Schroeder@informatik.uni-erlangen.de>
+##
+## The more esoteric failure modes require Michael's
+## stack-of-stacks patch (so we don't test them here,
+## and they are commented out before the __END__).
+##
+## The remaining tests pass with a simpler fix
+## intended for 5.004
+##
+## Gurusamy Sarathy <gsar@umich.edu> 97-02-24
+##
+
+chdir 't' if -d 't';
+@INC = "../lib";
+$ENV{PERL5LIB} = "../lib";
+
+$|=1;
+
+undef $/;
+@prgs = split "\n########\n", <DATA>;
+print "1..", scalar @prgs, "\n";
+
+$tmpfile = "runltmp000";
+1 while -f ++$tmpfile;
+END { unlink $tmpfile if $tmpfile; }
+
+for (@prgs){
+ my $switch;
+ if (s/^\s*-\w+//){
+ $switch = $&;
+ }
+ my($prog,$expected) = split(/\nEXPECT\n/, $_);
+ open TEST, "| sh -c './perl $switch' >$tmpfile 2>&1";
+ print TEST $prog, "\n";
+ close TEST;
+ $status = $?;
+ $results = `cat $tmpfile`;
+ $results =~ s/\n+$//;
+ $expected =~ s/\n+$//;
+ if ( $results ne $expected){
+ print STDERR "PROG: $switch\n$prog\n";
+ print STDERR "EXPECTED:\n$expected\n";
+ print STDERR "GOT:\n$results\n";
+ print "not ";
+ }
+ print "ok ", ++$i, "\n";
+}
+
+=head2 stay out of here (the real tests are after __END__)
+
+##
+## these tests don't pass yet (need the full stack-of-stacks patch)
+## GSAR 97-02-24
+##
+
+########
+# sort within sort
+sub sortfn {
+ (split(/./, 'x'x10000))[0];
+ my (@y) = ( 4, 6, 5);
+ @y = sort { $a <=> $b } @y;
+ print "sortfn ".join(', ', @y)."\n";
+ return $_[0] <=> $_[1];
+}
+@x = ( 3, 2, 1 );
+@x = sort { &sortfn($a, $b) } @x;
+print "---- ".join(', ', @x)."\n";
+EXPECT
+sortfn 4, 5, 6
+---- 1, 2, 3
+########
+# trapping eval within sort (doesn't work currently because
+# die does a SWITCHSTACK())
+@a = (3, 2, 1);
+@a = sort { eval('die("no way")') , $a <=> $b} @a;
+print join(", ", @a)."\n";
+EXPECT
+1, 2, 3
+########
+# this actually works fine, but results in a poor error message
+@a = (1, 2, 3);
+foo:
+{
+ @a = sort { last foo; } @a;
+}
+EXPECT
+cannot reach destination block at - line 2.
+########
+package TEST;
+
+sub TIESCALAR {
+ my $foo;
+ return bless \$foo;
+}
+sub FETCH {
+ next;
+ return "ZZZ";
+}
+sub STORE {
+}
+
+package main;
+
+tie $bar, TEST;
+{
+ print "- $bar\n";
+}
+print "OK\n";
+EXPECT
+cannot reach destination block at - line 8.
+########
+package TEST;
+
+sub TIESCALAR {
+ my $foo;
+ return bless \$foo;
+}
+sub FETCH {
+ goto bbb;
+ return "ZZZ";
+}
+
+package main;
+
+tie $bar, TEST;
+print "- $bar\n";
+exit;
+bbb:
+print "bbb\n";
+EXPECT
+bbb
+########
+# trapping eval within sort (doesn't work currently because
+# die does a SWITCHSTACK())
+sub foo {
+ $a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)');
+}
+@a = (3, 2, 0, 1);
+@a = sort foo @a;
+print join(', ', @a)."\n";
+EXPECT
+0, 1, 2, 3
+########
+package TEST;
+sub TIESCALAR {
+ my $foo;
+ next;
+ return bless \$foo;
+}
+package main;
+{
+tie $bar, TEST;
+}
+EXPECT
+cannot reach destination block at - line 4.
+########
+# large stack extension causes realloc, and segfault
+package TEST;
+sub TIESCALAR {
+ my $foo;
+ return bless \$foo;
+}
+sub FETCH {
+ return "fetch";
+}
+sub STORE {
+(split(/./, 'x'x10000))[0];
+}
+package main;
+tie $bar, TEST;
+$bar = "x";
+
+=cut
+
+##
+##
+## The real tests begin here
+##
+##
+
+__END__
+@a = (1, 2, 3);
+{
+ @a = sort { last ; } @a;
+}
+EXPECT
+Can't "last" outside a block at - line 3.
+########
+package TEST;
+
+sub TIESCALAR {
+ my $foo;
+ return bless \$foo;
+}
+sub FETCH {
+ eval 'die("test")';
+ print "still in fetch\n";
+ return ">$@<";
+}
+package main;
+
+tie $bar, TEST;
+print "- $bar\n";
+EXPECT
+still in fetch
+- >test at (eval 1) line 1.
+<
+########
+package TEST;
+
+sub TIESCALAR {
+ my $foo;
+ eval('die("foo\n")');
+ print "after eval\n";
+ return bless \$foo;
+}
+sub FETCH {
+ return "ZZZ";
+}
+
+package main;
+
+tie $bar, TEST;
+print "- $bar\n";
+print "OK\n";
+EXPECT
+after eval
+- ZZZ
+OK
+########
+package TEST;
+
+sub TIEHANDLE {
+ my $foo;
+ return bless \$foo;
+}
+sub PRINT {
+print STDERR "PRINT CALLED\n";
+(split(/./, 'x'x10000))[0];
+eval('die("test\n")');
+}
+
+package main;
+
+open FH, ">&STDOUT";
+tie *FH, TEST;
+print FH "OK\n";
+print "DONE\n";
+EXPECT
+PRINT CALLED
+DONE
+########
+sub warnhook {
+ print "WARNHOOK\n";
+ eval('die("foooo\n")');
+}
+$SIG{'__WARN__'} = 'warnhook';
+warn("dfsds\n");
+print "END\n";
+EXPECT
+WARNHOOK
+END
+########
+package TEST;
+
+use overload
+ "\"\"" => \&str
+;
+
+sub str {
+ eval('die("test\n")');
+ return "STR";
+}
+
+package main;
+
+$bar = bless {}, TEST;
+print "$bar\n";
+print "OK\n";
+EXPECT
+STR
+OK
+########
+sub foo {
+ $a <=> $b unless eval('$a == 0 ? bless undef : ($a <=> $b)');
+}
+@a = (3, 2, 0, 1);
+@a = sort foo @a;
+print join(', ', @a)."\n";
+EXPECT
+0, 1, 2, 3
+########
+sub foo {
+ goto bar if $a == 0;
+ $a <=> $b;
+}
+@a = (3, 2, 0, 1);
+@a = sort foo @a;
+print join(', ', @a)."\n";
+exit;
+bar:
+print "bar reached\n";
+EXPECT
+Can't "goto" outside a block at - line 2.
--- /dev/null
+#!./perl -T
+#
+# Taint tests by Tom Phoenix <rootbeer@teleport.com>.
+#
+# I don't claim to know all about tainting. If anyone sees
+# tests that I've missed here, please add them. But this is
+# better than having no tests at all, right?
+#
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+}
+
+use strict;
+use Config;
+
+my $Is_VMS = $^O eq 'VMS';
+my $Invoke_Perl = $Is_VMS ? 'MCR Sys$Disk:[]Perl.' : './perl';
+if ($Is_VMS) {
+ eval <<EndOfCleanup;
+ END {
+ \$ENV{PATH} = '';
+ warn "# Note: logical name 'PATH' may have been deleted\n";
+ \$ENV{IFS} = "$ENV{IFS}";
+ \$ENV{'DCL\$PATH'} = "$ENV{'DCL$PATH'}";
+ }
+EndOfCleanup
+}
+
+# Sources of taint:
+# The empty tainted value, for tainting strings
+my $TAINT = substr($^X, 0, 0);
+# A tainted zero, useful for tainting numbers
+my $TAINT0 = 0 + $TAINT;
+
+# This taints each argument passed. All must be lvalues.
+# Side effect: It also stringifies them. :-(
+sub taint_these (@) {
+ for (@_) { $_ .= $TAINT }
+}
+
+# How to identify taint when you see it
+sub any_tainted (@) {
+ not eval { join("",@_), kill 0; 1 };
+}
+sub tainted ($) {
+ any_tainted @_;
+}
+sub all_tainted (@) {
+ for (@_) { return 0 unless tainted $_ }
+ 1;
+}
+
+sub test ($$;$) {
+ my($serial, $boolean, $diag) = @_;
+ if ($boolean) {
+ print "ok $serial\n";
+ } else {
+ print "not ok $serial\n";
+ for (split m/^/m, $diag) {
+ print "# $_";
+ }
+ print "\n" unless
+ $diag eq ''
+ or substr($diag, -1) eq "\n";
+ }
+}
+
+# We need an external program to call.
+my $ECHO = "./echo$$";
+END { unlink $ECHO }
+open PROG, "> $ECHO" or die "Can't create $ECHO: $!";
+print PROG 'print "@ARGV\n"', "\n";
+close PROG;
+my $echo = "$Invoke_Perl $ECHO";
+
+print "1..96\n";
+
+# First, let's make sure that Perl is checking the dangerous
+# environment variables. Maybe they aren't set yet, so we'll
+# taint them ourselves.
+{
+ $ENV{'DCL$PATH'} = '' if $Is_VMS;
+
+ $ENV{PATH} = $TAINT;
+ $ENV{IFS} = '';
+ test 1, eval { `$echo 1` } eq '';
+ test 2, $@ =~ /^Insecure \$ENV{PATH}/, $@;
+
+ $ENV{PATH} = '';
+ $ENV{IFS} = $TAINT;
+ test 3, eval { `$echo 1` } eq '';
+ test 4, $@ =~ /^Insecure \$ENV{IFS}/, $@;
+
+ my ($tmp) = grep { (stat)[2] & 2 } '/tmp', '/var/tmp', '/usr/tmp';
+ if ($tmp) {
+ $ENV{PATH} = $tmp;
+ test 5, eval { `$echo 1` } eq '';
+ test 6, $@ =~ /^Insecure directory in \$ENV{PATH}/, $@;
+ }
+ else {
+ print "# can't find writeable directory to test PATH tainting\n";
+ for (5..6) { print "ok $_\n" }
+ }
+
+ $ENV{PATH} = '';
+ $ENV{IFS} = '';
+ test 7, eval { `$echo 1` } eq "1\n";
+ test 8, $@ eq '', $@;
+
+ if ($Is_VMS) {
+ $ENV{'DCL$PATH'} = $TAINT;
+ test 9, eval { `$echo 1` } eq '';
+ test 10, $@ =~ /^Insecure \$ENV{DCL\$PATH}/, $@;
+ $ENV{'DCL$PATH'} = '';
+ }
+ else {
+ print "# This is not VMS\n";
+ for (9..10) { print "ok $_\n"; }
+ }
+}
+
+# Let's see that we can taint and untaint as needed.
+{
+ my $foo = $TAINT;
+ test 11, tainted $foo;
+
+ $foo = "foo";
+ test 12, not tainted $foo;
+
+ taint_these($foo);
+ test 13, tainted $foo;
+
+ my @list = 1..10;
+ test 14, not any_tainted @list;
+ taint_these @list[1,3,5,7,9];
+ test 15, any_tainted @list;
+ test 16, all_tainted @list[1,3,5,7,9];
+ test 17, not any_tainted @list[0,2,4,6,8];
+
+ ($foo) = $foo =~ /(.+)/;
+ test 18, not tainted $foo;
+
+ $foo = $1 if ('bar' . $TAINT) =~ /(.+)/;
+ test 19, not tainted $foo;
+ test 20, $foo eq 'bar';
+
+ my $pi = 4 * atan2(1,1) + $TAINT0;
+ test 21, tainted $pi;
+
+ ($pi) = $pi =~ /(\d+\.\d+)/;
+ test 22, not tainted $pi;
+ test 23, sprintf("%.5f", $pi) eq '3.14159';
+}
+
+# How about command-line arguments? The problem is that we don't
+# always get some, so we'll run another process with some.
+{
+ my $arg = "./arg$$";
+ open PROG, "> $arg" or die "Can't create $arg: $!";
+ print PROG q{
+ eval { join('', @ARGV), kill 0 };
+ exit 0 if $@ =~ /^Insecure dependency/;
+ print "# Oops: \$@ was [$@]\n";
+ exit 1;
+ };
+ close PROG;
+ print `$Invoke_Perl "-T" $arg and some suspect arguments`;
+ test 24, !$?, "Exited with status $?";
+ unlink $arg;
+}
+
+# Reading from a file should be tainted
+{
+ my $file = './perl' . $Config{exe_ext};
+ test 25, open(FILE, $file), "Couldn't open '$file': $!";
+
+ my $block;
+ sysread(FILE, $block, 100);
+ my $line = <FILE>; # Should "work"
+ close FILE;
+ test 26, tainted $block;
+ test 27, tainted $line;
+}
+
+# Globs should be tainted.
+{
+ my @globs = <*>;
+ test 28, all_tainted @globs;
+
+ @globs = glob '*';
+ test 29, all_tainted @globs;
+}
+
+# Output of commands should be tainted
+{
+ my $foo = `$echo abc`;
+ test 30, tainted $foo;
+}
+
+# Certain system variables should be tainted
+{
+ test 31, all_tainted $^X, $0;
+}
+
+# Results of matching should all be untainted
+{
+ my $foo = "abcdefghi" . $TAINT;
+ test 32, tainted $foo;
+
+ $foo =~ /def/;
+ test 33, not any_tainted $`, $&, $';
+
+ $foo =~ /(...)(...)(...)/;
+ test 34, not any_tainted $1, $2, $3, $+;
+
+ my @bar = $foo =~ /(...)(...)(...)/;
+ test 35, not any_tainted @bar;
+
+ test 36, tainted $foo; # $foo should still be tainted!
+ test 37, $foo eq "abcdefghi";
+}
+
+# Operations which affect files can't use tainted data.
+{
+ test 38, eval { chmod 0, $TAINT } eq '', 'chmod';
+ test 39, $@ =~ /^Insecure dependency/, $@;
+
+ test 40, eval { truncate 'NoSuChFiLe', $TAINT0 } eq '', 'truncate';
+ test 41, $@ =~ /^Insecure dependency/, $@;
+
+ test 42, eval { rename '', $TAINT } eq '', 'rename';
+ test 43, $@ =~ /^Insecure dependency/, $@;
+
+ test 44, eval { unlink $TAINT } eq '', 'unlink';
+ test 45, $@ =~ /^Insecure dependency/, $@;
+
+ test 46, eval { utime $TAINT } eq '', 'utime';
+ test 47, $@ =~ /^Insecure dependency/, $@;
+
+ if ($Config{d_chown}) {
+ test 48, eval { chown -1, -1, $TAINT } eq '', 'chown';
+ test 49, $@ =~ /^Insecure dependency/, $@;
+ }
+ else {
+ print "# chown() is not available\n";
+ for (48..49) { print "ok $_\n" }
+ }
+
+ if ($Config{d_link}) {
+ test 50, eval { link $TAINT, '' } eq '', 'link';
+ test 51, $@ =~ /^Insecure dependency/, $@;
+ }
+ else {
+ print "# link() is not available\n";
+ for (50..51) { print "ok $_\n" }
+ }
+
+ if ($Config{d_symlink}) {
+ test 52, eval { symlink $TAINT, '' } eq '', 'symlink';
+ test 53, $@ =~ /^Insecure dependency/, $@;
+ }
+ else {
+ print "# symlink() is not available\n";
+ for (52..53) { print "ok $_\n" }
+ }
+}
+
+# Operations which affect directories can't use tainted data.
+{
+ test 54, eval { mkdir $TAINT0, $TAINT } eq '', 'mkdir';
+ test 55, $@ =~ /^Insecure dependency/, $@;
+
+ test 56, eval { rmdir $TAINT } eq '', 'rmdir';
+ test 57, $@ =~ /^Insecure dependency/, $@;
+
+ test 58, eval { chdir $TAINT } eq '', 'chdir';
+ test 59, $@ =~ /^Insecure dependency/, $@;
+
+ if ($Config{d_chroot}) {
+ test 60, eval { chroot $TAINT } eq '', 'chroot';
+ test 61, $@ =~ /^Insecure dependency/, $@;
+ }
+ else {
+ print "# chroot() is not available\n";
+ for (60..61) { print "ok $_\n" }
+ }
+}
+
+# Some operations using files can't use tainted data.
+{
+ my $foo = "imaginary library" . $TAINT;
+ test 62, eval { require $foo } eq '', 'require';
+ test 63, $@ =~ /^Insecure dependency/, $@;
+
+ my $filename = "./taintB$$"; # NB: $filename isn't tainted!
+ END { unlink $filename if defined $filename }
+ $foo = $filename . $TAINT;
+ unlink $filename; # in any case
+
+ test 64, eval { open FOO, $foo } eq '', 'open for read';
+ test 65, $@ eq '', $@; # NB: This should be allowed
+ test 66, $! == 2; # File not found
+
+ test 67, eval { open FOO, "> $foo" } eq '', 'open for write';
+ test 68, $@ =~ /^Insecure dependency/, $@;
+}
+
+# Commands to the system can't use tainted data
+{
+ my $foo = $TAINT;
+
+ if ($^O eq 'amigaos') {
+ print "# open(\"|\") is not available\n";
+ for (69..72) { print "ok $_\n" }
+ }
+ else {
+ test 69, eval { open FOO, "| $foo" } eq '', 'popen to';
+ test 70, $@ =~ /^Insecure dependency/, $@;
+
+ test 71, eval { open FOO, "$foo |" } eq '', 'popen from';
+ test 72, $@ =~ /^Insecure dependency/, $@;
+ }
+
+ test 73, eval { exec $TAINT } eq '', 'exec';
+ test 74, $@ =~ /^Insecure dependency/, $@;
+
+ test 75, eval { system $TAINT } eq '', 'system';
+ test 76, $@ =~ /^Insecure dependency/, $@;
+
+ $foo = "*";
+ taint_these $foo;
+
+ test 77, eval { `$echo 1$foo` } eq '', 'backticks';
+ test 78, $@ =~ /^Insecure dependency/, $@;
+
+ if ($Is_VMS) { # wildcard expansion doesn't invoke shell, so is safe
+ test 79, join('', eval { glob $foo } ) ne '', 'globbing';
+ test 80, $@ eq '', $@;
+ }
+ else {
+ test 79, join('', eval { glob $foo } ) eq '', 'globbing';
+ test 80, $@ =~ /^Insecure dependency/, $@;
+ }
+}
+
+# Operations which affect processes can't use tainted data.
+{
+ test 81, eval { kill 0, $TAINT } eq '', 'kill';
+ test 82, $@ =~ /^Insecure dependency/, $@;
+
+ if ($Config{d_setpgrp}) {
+ test 83, eval { setpgrp 0, $TAINT } eq '', 'setpgrp';
+ test 84, $@ =~ /^Insecure dependency/, $@;
+ }
+ else {
+ print "# setpgrp() is not available\n";
+ for (83..84) { print "ok $_\n" }
+ }
+
+ if ($Config{d_setprior}) {
+ test 85, eval { setpriority 0, $TAINT, $TAINT } eq '', 'setpriority';
+ test 86, $@ =~ /^Insecure dependency/, $@;
+ }
+ else {
+ print "# setpriority() is not available\n";
+ for (85..86) { print "ok $_\n" }
+ }
+}
+
+# Some miscellaneous operations can't use tainted data.
+{
+ if ($Config{d_syscall}) {
+ test 87, eval { syscall $TAINT } eq '', 'syscall';
+ test 88, $@ =~ /^Insecure dependency/, $@;
+ }
+ else {
+ print "# syscall() is not available\n";
+ for (87..88) { print "ok $_\n" }
+ }
+
+ {
+ my $foo = "x" x 979;
+ taint_these $foo;
+ local *FOO;
+ my $temp = "./taintC$$";
+ END { unlink $temp }
+ test 89, open(FOO, "> $temp"), "Couldn't open $temp for write: $!";
+
+ test 90, eval { ioctl FOO, $TAINT, $foo } eq '', 'ioctl';
+ test 91, $@ =~ /^Insecure dependency/, $@;
+
+ if ($Config{d_fcntl}) {
+ test 92, eval { fcntl FOO, $TAINT, $foo } eq '', 'fcntl';
+ test 93, $@ =~ /^Insecure dependency/, $@;
+ }
+ else {
+ print "# fcntl() is not available\n";
+ for (92..93) { print "ok $_\n" }
+ }
+
+ close FOO;
+ }
+}
+
+# Some tests involving references
+{
+ my $foo = 'abc' . $TAINT;
+ my $fooref = \$foo;
+ test 94, not tainted $fooref;
+ test 95, tainted $$fooref;
+ test 96, tainted $foo;
+}
{
char *ug;
+ DEBUG_u(PerlIO_printf(PerlIO_stderr(),
+ "%s %d %d %d\n", s, tainted, uid, euid));
+
if (tainted) {
- DEBUG_u(PerlIO_printf(PerlIO_stderr(),
- "%s %d %d %d\n", s, tainted, uid, euid));
if (euid != uid)
ug = " while running setuid";
else if (egid != gid)
taint_env()
{
SV** svp;
- MAGIC *mg = 0;
+ MAGIC *mg;
+
+#ifdef VMS
+ int i = 0;
+ char name[14] = "DCL$PATH";
+
+ while (1) {
+ if (i)
+ (void)sprintf(name,"DCL$PATH;%d", i);
+ svp = hv_fetch(GvHVn(envgv), name, strlen(name), FALSE);
+ if (!svp || *svp == &sv_undef)
+ break;
+ if (SvTAINTED(*svp)) {
+ TAINT;
+ taint_proper("Insecure %s%s", "$ENV{DCL$PATH}");
+ }
+ if ((mg = mg_find(*svp, 'e')) && MgTAINTEDDIR(mg)) {
+ TAINT;
+ taint_proper("Insecure directory in %s%s", "$ENV{DCL$PATH}");
+ }
+ i++;
+ }
+#endif /* VMS */
svp = hv_fetch(GvHVn(envgv),"PATH",4,FALSE);
- if (!svp || *svp == &sv_undef ||
- ((mg = mg_find(*svp, 't')) && mg->mg_len & 1))
- {
- TAINT;
- if (mg && MgTAINTEDDIR(mg))
- taint_proper("Insecure directory in %s%s", "$ENV{PATH}");
- else
+ if (svp && *svp) {
+ if (SvTAINTED(*svp)) {
+ TAINT;
taint_proper("Insecure %s%s", "$ENV{PATH}");
+ }
+ if ((mg = mg_find(*svp, 'e')) && MgTAINTEDDIR(mg)) {
+ TAINT;
+ taint_proper("Insecure directory in %s%s", "$ENV{PATH}");
+ }
}
svp = hv_fetch(GvHVn(envgv),"IFS",3,FALSE);
- if (svp && *svp != &sv_undef &&
- (mg = mg_find(*svp, 't')) && mg->mg_len & 1)
- {
+ if (svp && *svp != &sv_undef && SvTAINTED(*svp)) {
TAINT;
taint_proper("Insecure %s%s", "$ENV{IFS}");
}
{
register char *s = start;
register char *d;
- I32 tryi32;
+ I32 tryiv;
double value;
SV *sv;
I32 floatit;
sv = NEWSV(92,0);
SET_NUMERIC_STANDARD();
value = atof(tokenbuf);
- tryi32 = I_32(value);
- if (!floatit && (double)tryi32 == value)
- sv_setiv(sv,tryi32);
+ tryiv = I_V(value);
+ if (!floatit && (double)tryiv == value)
+ sv_setiv(sv, tryiv);
else
- sv_setnv(sv,value);
+ sv_setnv(sv, value);
break;
}
}
/*SUPPRESS 560*/
if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
- sv_setiv(GvSV(tmpgv),(I32)getpid());
+ sv_setiv(GvSV(tmpgv), (IV)getpid());
forkprocess = 0;
hv_clear(pidstatus); /* we have no children */
return Nullfp;
unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
if ($opt_m) {
- foreach $pager (@pagers) {
- my($sts) = system("$pager @found");
- exit 0 if ($Is_VMS ? ($sts & 1) : !$sts);
- }
- exit $Is_VMS ? $sts : 1;
+ foreach $pager (@pagers) {
+ system("$pager @found") or exit;
+ }
+ if ($Is_VMS) { eval 'use vmsish qw(status exit); exit $?' }
+ exit 1;
}
if ($opt_f) {
Pod::Text::pod2text($_,*TMP);
close(TMP);
} elsif(not $opt_u) {
- open(TMP,">>$tmp");
- if($^O =~ /hpux/) {
- $rslt = `pod2man $_ | nroff -man | col -x`;
- } else {
- $rslt = `pod2man $_ | nroff -man`;
+ my $cmd = "pod2man --lax $_ | nroff -man";
+ $cmd .= " | col -x" if $^O =~ /hpux/;
+ $rslt = `$cmd`;
+ unless(($err = $?)) {
+ open(TMP,">>$tmp");
+ print TMP $rslt;
+ close TMP;
}
- if ($Is_VMS) { $err = !($? % 2) || $rslt =~ /IVVERB/; }
- else { $err = $?; }
- print TMP $rslt unless $err;
- close TMP;
}
if( $opt_u or $err or -z $tmp) {
close(TMP);
} else {
foreach $pager (@pagers) {
- $sts = system("$pager $tmp");
- last if $Is_VMS && ($sts & 1);
- last unless $sts;
+ system("$pager $tmp") or last;
}
}
* when Perl is built. Please do not change it by hand; make
* any changes to FndVers.Com instead.
*/
-#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_00390" /**/
+#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_00391" /**/
#define ARCHLIB ARCHLIB_EXP /*config-skip*/
/* ARCHNAME:
.endif
# Updated by fndvers.com -- do not edit by hand
-PERL_VERSION = 5_00390#
+PERL_VERSION = 5_00391#
ARCHDIR = [.lib.$(ARCH).$(PERL_VERSION)]
test : all [.t.lib]vmsfspec.t
- @[.VMS]Test.Com "$(E)"
+archify : all
+ @ Write Sys$Output "Moving files to architecture-specific locations for $(ARCH)"
+ archroot = "$(ARCHAUTO)" - "]" + "...]"
+ Backup/Log/Verify [.lib.auto...]*.*;/Exclude=(*.al,*.ix) 'archroot'
+ Delete/Log/NoConfirm [.lib.auto...]*.*;*/exclude=(*.al,*.ix)
+ Delete/Log/NoConfirm [.lib]Config.pm;*
+ Copy/Log/NoConfirm *$(E);,[.x2p]a2p$(E); $(ARCHDIR)
+ Delete/Log/NoConfirm Perl*$(E);*,[.x2p]a2p$(E);*
+ @ Write Sys$Output "Architecture-specific setup completed."
+ @ Write Sys$Output "Before building for another architecture, be sure to"
+ @ Write Sys$Output " 1. $(MMS)$(MMSQUALIFIERS) clean"
+ @ Write Sys$Output " 2. Delete Miniperl$(E)"
+
# CORE subset for MakeMaker, so we can build Perl without sources
# Should move to VMS installperl when we get one
$(ARCHCORE)EXTERN.h : EXTERN.h
} /* end of my_getenv() */
/*}}}*/
+static FILE *safe_popen(char *, char *);
+
/*{{{ void prime_env_iter() */
void
prime_env_iter(void)
(void) hv_fetch(envhv,"USER",4,TRUE);
/* Now, go get the logical names */
- if ((sholog = my_popen("$ Show Logical *","r")) == Nullfp)
+ if ((sholog = safe_popen("$ Show Logical *","r")) == Nullfp)
_ckvmssts(vaxc$errno);
- /* We use Perl's sv_gets to read from the pipe, since my_popen is
+ /* We use Perl's sv_gets to read from the pipe, since safe_popen is
* tied to Perl's I/O layer, so it may not return a simple FILE * */
oldrs = rs;
rs = newSVpv("\n",1);
static unsigned long int
pipe_exit_routine()
{
- unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT, sts;
+ unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
+ int sts;
while (open_pipes != NULL) {
if (!open_pipes->done) { /* Tap them gently on the shoulder . . .*/
}
if (!open_pipes->done) /* We tried to be nice . . . */
_ckvmssts(sys$delprc(&open_pipes->pid,0));
- if (!((sts = my_pclose(open_pipes->fp))&1)) retsts = sts;
+ if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
+ else if (!(sts & 1)) retsts = sts;
}
return retsts;
}
}
}
-/*{{{ FILE *my_popen(char *cmd, char *mode)*/
-FILE *
-my_popen(char *cmd, char *mode)
+static FILE *
+safe_popen(char *cmd, char *mode)
{
static int handler_set_up = FALSE;
char mbxname[64];
forkprocess = info->pid;
return info->fp;
+} /* end of safe_popen */
+
+
+/*{{{ FILE *my_popen(char *cmd, char *mode)*/
+FILE *
+my_popen(char *cmd, char *mode)
+{
+ TAINT_ENV();
+ TAINT_PROPER("popen");
+ return safe_popen(cmd,mode);
}
+
/*}}}*/
/*{{{ I32 my_pclose(FILE *fp)*/
for (info = open_pipes; info != NULL; last = info, info = info->next)
if (info->fp == fp) break;
- if (info == NULL)
- /* get here => no such pipe open */
- croak("No such pipe open");
+ if (info == NULL) { /* no such pipe open */
+ set_errno(ECHILD); /* quoth POSIX */
+ set_vaxc_errno(SS$_NONEXPR);
+ return -1;
+ }
/* If we were writing to a subprocess, insure that someone reading from
* the mailbox gets an EOF. It looks like a simple fclose() doesn't
{ /* no vfork - act VMSish */
unsigned long int retsts;
+ TAINT_ENV();
+ TAINT_PROPER("exec");
if ((retsts = setup_cmddsc(cmd,1)) & 1)
retsts = lib$do_command(&VMScmd);
{
unsigned long int substs, hadcmd = 1;
+ TAINT_ENV();
+ TAINT_PROPER("spawn");
if (!cmd || !*cmd) {
hadcmd = 0;
_ckvmssts(lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0));
projects / p5sagit/p5-mst-13.2.git / commitdiff