MANIFEST is out of sync.
p4raw-id: //depot/perl@114
# DB_File.pm -- Perl 5 interface to Berkeley DB
#
# written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
- # last modified 31st May 1997
- # version 1.15
-# last modified 29th Jun 1997
-# version 1.15
++# last modified 8th Oct 1997
++# version 1.16
#
# Copyright (c) 1995, 1996, 1997 Paul Marquess. All rights reserved.
# This program is free software; you can redistribute it and/or
=item 1.15
+ Patch from Gisle Aas <gisle@aas.no> to suppress "use of undefined
+ value" warning with db_get and db_seq.
+
+ Patch from Gisle Aas <gisle@aas.no> to make DB_File export only the O_*
+ constants from Fcntl.
+
+ Removed the DESTROY method from the DB_File::HASHINFO module.
+
+ Previously DB_File hard-wired the class name of any object that it
+ created to "DB_File". This makes sub-classing difficult. Now DB_File
+ creats objects in the namespace of the package it has been inherited
+ into.
+
++=item 1.16
++
+Minor changes to DB_File.xs to support multithreaded perl.
+
=back
=head1 BUGS
DB_File.xs -- Perl 5 interface to Berkeley DB
written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
- last modified 31st May 1997
- version 1.15
- last modified 29th Jun 1997
- version 1.15
++ last modified 8th Oct 1997
++ version 1.16
All comments/suggestions/problems are welcome
1.13 - Tidied up a few casts.
1.14 - Made it illegal to tie an associative array to a RECNO
database and an ordinary array to a HASH or BTREE database.
- 1.15 - Minor additions to DB_File.xs to support multithreaded perl.
+ 1.15 - Patch from Gisle Aas <gisle@aas.no> to suppress "use of
+ undefined value" warning with db_get and db_seq.
-
++ 1.16 - Minor additions to DB_File.xs to support multithreaded perl.
*/
myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
ENTER;
- SAVESPTR(op);
+ SAVEOP();
op = (OP *) &myop;
- if (perldb && curstash != debstash)
+ if (PERLDB_SUB && curstash != debstash)
op->op_private |= OPpENTERSUB_DB;
PUTBACK;
- pp_pushmark();
+ pp_pushmark(ARGS);
EXTEND(sp, notfound + 5);
PUSHs(lr>0? right: left);
echo 'Your csh is really tcsh. Good.'
fi
+ # Shimpei Yamashita <shimpei@socrates.patnet.caltech.edu>
+ # Message-Id: <33EF1634.B36B6500@pobox.com>
+ #
+ # MkLinux (osname=linux,archname=ppc-linux), which differs slightly from other
+ # linuces, needs special flags passed in order for dynamic loading to work.
+ # instead of the recommended:
+ # ccdlflags='-rdynamic'
+ #
+ # it should be:
+ # ccdlflags='-Wl,-E'
+
+if [ "X$usethreads" != "X" ]; then
+ ccflags="-D_REENTRANT -DUSE_THREADS $ccflags"
+ cppflags="-D_REENTRANT -DUSE_THREADS $cppflags"
+ # -lpthread needs to come before -lc but after other libraries such
+ # as -lgdbm and such like. We assume here that -lc is present in
+ # libswanted. If that fails to be true in future, then this can be
+ # changed to add pthread to the very end of libswanted.
+ set `echo X "$libswanted "| sed -e 's/ c / pthread c /'`
+ shift
+ libswanted="$*"
+fi
case OP_RV2AV:
case OP_RV2HV:
- if (!type && cUNOP->op_first->op_type != OP_GV)
++ if (!type && cUNOPo->op_first->op_type != OP_GV)
+ croak("Can't localize through a reference");
- if (type == OP_REFGEN && op->op_flags & OPf_PARENS) {
+ if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
modcount = 10000;
- return op; /* Treat \(@foo) like ordinary list. */
+ return o; /* Treat \(@foo) like ordinary list. */
}
/* FALL THROUGH */
case OP_RV2GV:
modcount = 10000;
break;
case OP_RV2SV:
- if (!type && cUNOP->op_first->op_type != OP_GV)
+ if (!type && cUNOPo->op_first->op_type != OP_GV)
- croak("Can't localize a reference");
+ croak("Can't localize through a reference");
- ref(cUNOP->op_first, op->op_type);
+ ref(cUNOPo->op_first, o->op_type);
/* FALL THROUGH */
case OP_GV:
case OP_AV2ARYLEN:
}
}
}
- op->op_private |= (hints & HINT_STRICT_REFS);
+ o->op_private |= (hints & HINT_STRICT_REFS);
- if (perldb && curstash != debstash)
+ if (PERLDB_SUB && curstash != debstash)
- op->op_private |= OPpENTERSUB_DB;
- while (o != cvop) {
+ o->op_private |= OPpENTERSUB_DB;
+ while (o2 != cvop) {
if (proto) {
switch (*proto) {
case '\0':
PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
my_exit(0);
}
- if (perldb && DBsingle)
- sv_setiv(DBsingle, 1);
+ if (PERLDB_SINGLE && DBsingle)
+ sv_setiv(DBsingle, 1);
+ if (initav)
+ call_list(oldscope, initav);
}
/* do it */
# ifndef register
# define register
# endif
- # ifdef MYMALLOC
- # ifndef DEBUGGING_MSTATS
- # define DEBUGGING_MSTATS
- # endif
- # endif
# define PAD_SV(po) pad_sv(po)
+# define RUNOPS_DEFAULT runops_debug
#else
# define PAD_SV(po) curpad[po]
+# define RUNOPS_DEFAULT runops_standard
+#endif
+
+/*
+ * These need prototyping here because <proto.h> isn't
+ * included until after runops is initialised.
+ */
+
+int runops_standard _((void));
+#ifdef DEBUGGING
+int runops_debug _((void));
#endif
/****************/
OP *oldop = op;
for (ix = 1; enterops[ix]; ix++) {
op = enterops[ix];
+ /* Eventually we may want to stack the needed arguments
+ * for each op. For now, we punt on the hard ones. */
+ if (op->op_type == OP_ENTERITER)
+ DIE("Can't \"goto\" into the middle of a foreach loop",
+ label);
- (*op->op_ppaddr)();
+ (*op->op_ppaddr)(ARGS);
}
op = oldop;
}
/* prepare to compile string */
- if (perldb && curstash != debstash)
+ if (PERLDB_LINE && curstash != debstash)
save_lines(GvAV(compiling.cop_filegv), linestr);
PUTBACK;
+#ifdef USE_THREADS
+ MUTEX_LOCK(&eval_mutex);
+ if (eval_owner && eval_owner != thr)
+ while (eval_owner)
+ COND_WAIT(&eval_cond, &eval_mutex);
+ eval_owner = thr;
+ MUTEX_UNLOCK(&eval_mutex);
+#endif /* USE_THREADS */
ret = doeval(gimme);
- if (perldb && was != sub_generation) { /* Some subs defined here. */
+ if (PERLDB_INTER && was != sub_generation /* Some subs defined here. */
+ && ret != op->op_next) { /* Successive compilation. */
strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
}
return DOCATCH(ret);
if (SvROK(sv)) {
wasref:
hv = (HV*)SvRV(sv);
- if (SvTYPE(hv) != SVt_PVHV)
+ if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
DIE("Not a HASH reference");
- if (op->op_private & OPpLVAL_INTRO)
- hv = (HV*)save_svref((SV**)sv);
if (op->op_flags & OPf_REF) {
SETs((SV*)hv);
RETURN;
CATCH_SET(TRUE);
ENTER;
- SAVESPTR(op);
+ SAVEOP();
op = (OP *) &myop;
- if (perldb && curstash != debstash)
+ if (PERLDB_SUB && curstash != debstash)
op->op_private |= OPpENTERSUB_DB;
XPUSHs((SV*)GvCV(gv));
CATCH_SET(TRUE);
ENTER;
- SAVESPTR(op);
+ SAVEOP();
op = (OP *) &myop;
- if (perldb && curstash != debstash)
+ if (PERLDB_SUB && curstash != debstash)
op->op_private |= OPpENTERSUB_DB;
PUTBACK;
- pp_pushmark();
+ pp_pushmark(ARGS);
EXTEND(sp, 5);
PUSHs(sv);
return input;
}
+ /* After a successful match in WHILEM, we want to restore paren matches
+ * that have been overwritten by a failed match attempt in the process
+ * of reaching this success. We do this by restoring regstartp[i]
+ * wherever regendp[i] has not changed; if OPEN is changed to modify
+ * regendp[], the '== endp' test below should be changed to match.
+ * This corrects the error of:
+ * 0 > length [ "foobar" =~ / ( (foo) | (bar) )* /x ]->[1]
+ */
+ static void
+ regcppartblow()
+ {
++ dTHR;
+ I32 i = SSPOPINT;
+ U32 paren;
+ char *startp;
+ char *endp;
+ assert(i == SAVEt_REGCONTEXT);
+ i = SSPOPINT;
+ /* input, lastparen, size */
+ SSPOPPTR; SSPOPINT; SSPOPINT;
+ for (i -= 3; i > 0; i -= 3) {
+ paren = (U32)SSPOPINT;
+ startp = (char *) SSPOPPTR;
+ endp = (char *) SSPOPPTR;
+ if (paren <= *reglastparen && regendp[paren] == endp)
+ regstartp[paren] = startp;
+ }
+ }
+
#define regcpblow(cp) leave_scope(cp)
/*
if (SvTYPE(sv) < SVt_PVIV)
sv_upgrade(sv, SVt_PVIV);
olderrno = errno; /* some Xenix systems wipe out errno here */
- sv_setpvf(sv, "%Vd", SvIVX(sv));
+ sv_setpviv(sv, SvIVX(sv));
errno = olderrno;
s = SvEND(sv);
+ if (oldIOK)
+ SvIOK_on(sv);
+ else
+ SvIOKp_on(sv);
}
else {
+ dTHR;
if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
warn(warn_uninit);
*lp = 0;