troff=''
uname=''
uniq=''
+usethreads=''
uuname=''
vi=''
zcat=''
esac
rp='What is your architecture name'
. ./myread
-archname="$ans"
+case "$usethreads" in
+$define) archname="$ans-thread"
+ echo "usethreads selected... architecture name is now $archname." >&4
+ ;;
+*) archname="$ans" ;;
+esac
myarchname="$tarch"
: is AFS running?
README.os2 Notes about OS/2 port
README.plan9 Notes about Plan9 port
README.qnx Notes about QNX port
+README.threads Notes about multithreading
README.vms Notes about VMS port
README.win32 Notes about Win32 port
Todo The Wishlist
+Todo.5.005 What needs doing before 5.005 release
XSUB.h Include file for extension subroutines
av.c Array value code
av.h Array value header
ext/Socket/Makefile.PL Socket extension makefile writer
ext/Socket/Socket.pm Socket extension Perl module
ext/Socket/Socket.xs Socket extension external subroutines
+ext/attrs/Makefile.PL attrs extension makefile writer
+ext/attrs/attrs.pm attrs extension Perl module
+ext/attrs/attrs.xs attrs extension external subroutines
ext/util/make_ext Used by Makefile to execute extension Makefiles
ext/util/mkbootstrap Turns ext/*/*_BS into bootstrap info
form.h Public declarations for the above
lib/CPAN/FirstTime.pm Utility for creating CPAN config files
lib/CPAN/Nox.pm Runs CPAN while avoiding compiled extensions
lib/Carp.pm Error message base class
+lib/Class/Fields.pm Set up object field names for pseudo-hash-using classes
lib/Class/Struct.pm Declare struct-like datatypes as Perl classes
lib/Cwd.pm Various cwd routines (getcwd, fastcwd, chdir)
lib/Devel/SelfStubber.pm Generate stubs for SelfLoader.pm
lib/I18N/Collate.pm Routines to do strxfrm-based collation
lib/IPC/Open2.pm Open a two-ended pipe
lib/IPC/Open3.pm Open a three-ended pipe!
+lib/ISA.pm Initialise @ISA at compile-time
lib/Math/BigFloat.pm An arbitrary precision floating-point arithmetic package
lib/Math/BigInt.pm An arbitrary precision integer arithmetic package
lib/Math/Complex.pm A Complex package
t/pragma/warn-1global Tests of global warnings for warning.t
t/pragma/warning.t See if warning controls work
taint.c Tainting code
+thread.h Threading header
toke.c The tokener
universal.c The default UNIVERSAL package methods
unixish.h Defines that are assumed on Unix
h1 = EXTERN.h INTERN.h XSUB.h av.h config.h cop.h cv.h dosish.h
h2 = embed.h form.h gv.h handy.h hv.h keywords.h mg.h op.h
h3 = opcode.h patchlevel.h perl.h perly.h pp.h proto.h regcomp.h
-h4 = regexp.h scope.h sv.h unixish.h util.h perlio.h
+h4 = regexp.h scope.h sv.h unixish.h util.h perlio.h thread.h
h = $(h1) $(h2) $(h3) $(h4)
c1 = $(mallocsrc) av.c scope.c op.c doop.c doio.c dump.c hv.c mg.c
--- /dev/null
+Building
+
+If you want to build with multi-threading support and you are
+running Linux 2.x (with the LinuxThreads library installed:
+that's the linuxthreads and linuxthreads-devel RPMs for RedHat)
+or Digital UNIX 4.x or Solaris 2.x for recentish x (2.5 is OK)
+then you should be able to use
+ ./Configure -Dusethreads -Doptimize=-g -ders
+ make
+and ignore the rest of this "Building" section. If it doesn't
+work or you are using another platform which you believe supports
+POSIX.1c threads then read on.
+
+Omit the -e from your ./Configure arguments. For example, use
+ ./Configure -drs
+When it offers to let you change config.sh, do so. If you already
+have a config.sh then you can edit it and do
+ ./Configure -S
+to propagate the required changes.
+In ccflags, insert -DUSE_THREADS (and probably -DDEBUGGING since
+that's what I've been building with). Also insert any other
+arguments in there that your compiler needs to use POSIX threads.
+Change optimize to -g to give you better debugging information.
+Include any necessary explicit libraries in libs and change
+ldflags if you need any linker flags instead or as well.
+
+More explicitly, for Linux (when using the standard kernel-threads
+based LinuxThreads library):
+ Add -DUSE_THREADS -D_REENTRANT -DDEBUGGING to ccflags and cppflags
+ Add -lpthread to libs
+ Change optimize to -g
+For Digital Unix 4.x:
+ Add -pthread -DUSE_THREADS -DDEBUGGING to ccflags
+ Add -DUSE_THREADS -DDEBUGGING to cppflags
+ Add -pthread to ldflags
+ Change optimize to -g
+ Add -lpthread -lc_r to lddlflags
+ For some reason, the extra includes for pthreads make Digital UNIX
+ complain fatally about the sbrk() delcaration in perl's malloc.c
+ so use the native malloc as follows:
+ Change usemymalloc to n
+ Zap mallocobj and mallocsrc (foo='')
+ Change d_mymalloc to undef
+For Solaris, do the same as for Linux above.
+
+Now you can do a
+ make
+
+
+Building the Thread extension
+
+Build it away from the perl tree in the usual way. Set your PATH
+environment variable to have your perl build directory first and
+set PERL5LIB to be /your/perl/build/directory/lib (without those,
+I had problems where the config information from the ordinary perl
+on the system would end up in the Makefile). Then
+ perl Makefile.PL PERL_SRC=/your/perl/build/directory
+ make
+
+Then you can try some of the tests with
+ perl -Mblib create.t
+ perl -Mblib join.t
+ perl -Mblib lock.t
+ perl -Mblib unsync.t
+ perl -Mblib unsync2.t
+ perl -Mblib unsync3.t
+ perl -Mblib io.t
+ perl -Mblib queue.t
+The io one leaves a thread reading from the keyboard on stdin so
+as the ping messages appear you can type lines and see them echoed.
+
+Try running the main perl test suite too. There are known
+failures for po/misc test 45 (tries to do local(@_) but @_ is
+now lexical) and some tests involving backticks/system/fork
+may or may not work. Under Linux, many tests may appear to fail
+when run under the test harness but work fine when invoked
+manually.
+
+
+Bugs
+
+* cond.t hasn't been redone since condition variable changed.
+
+* FAKE_THREADS should produce a working perl but the Thread
+extension won't build with it yet.
+
+* There's a known memory leak (curstack isn't freed at the end
+of each thread because it causes refcount problems that I
+haven't tracked down yet) and there are very probably others too.
+
+* There are still races where bugs show up under contention.
+
+* Need to document "lock", Thread.pm, Queue.pm, ...
+
+* Plenty of others
+
+
+Debugging
+
+Use the -DL command-line option to turn on debugging of the
+multi-threading code. Under Linux, that also turns on a quick
+hack I did to grab a bit of extra information from segfaults.
+If you have a fancier gdb/threads setup than I do then you'll
+have to delete the lines in perl.c which say
+ #if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
+ DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv););
+ #endif
+
+
+Background
+
+Some old globals (e.g. stack_sp, op) and some old per-interpreter
+variables (e.g. tmps_stack, cxstack) move into struct thread.
+All fields of struct thread (apart from a few only applicable to
+FAKE_THREADS) are of the form Tfoo. For example, stack_sp becomes
+the field Tstack_sp of struct thread. For those fields which moved
+from original perl, thread.h does
+ #define foo (thr->Tfoo)
+This means that all functions in perl which need to use one of these
+fields need an (automatic) variable thr which points at the current
+thread's struct thread. For pp_foo functions, it is passed around as
+an argument, for other functions they do
+ dTHR;
+which declares and initialises thr from thread-specific data
+via pthread_getspecific. If a function fails to compile with an
+error about "no such variable thr", it probably just needs a dTHR
+at the top.
+
+
+Fake threads
+
+For FAKE_THREADS, thr is a global variable and perl schedules threads
+by altering thr in between appropriate ops. The next and prev fields
+of struct thread keep all fake threads on a doubly linked list and
+the next_run and prev_run fields keep all runnable threads on a
+doubly linked list. Mutexes are stubs for FAKE_THREADS. Condition
+variables are implemented as a list of waiting threads.
+
+
+Mutexes and condition variables
+
+The API is via macros MUTEX_{INIT,LOCK,UNLOCK,DESTROY} and
+COND_{INIT,WAIT,SIGNAL,BROADCAST,DESTROY}. For POSIX threads,
+perl mutexes and condition variables correspond to POSIX ones.
+For FAKE_THREADS, mutexes are stubs and condition variables are
+implmented as lists of waiting threads. For FAKE_THREADS, a thread
+waits on a condition variable by removing itself from the runnable
+list, calling SCHEDULE to change thr to the next appropriate
+runnable thread and returning op (i.e. the new threads next op).
+This means that fake threads can only block while in PP code.
+A PP function which contains a COND_WAIT must be prepared to
+handle such restarts and can use the field "private" of struct
+thread to record its state. For fake threads, COND_SIGNAL and
+COND_BROADCAST work by putting back all the threads on the
+condition variables list into the run queue. Note that a mutex
+must *not* be held while returning from a PP function.
+
+Perl locks and condition variables are both implemented as a
+condpair_t structure, containing a mutex, an "owner" condition
+variable, an owner thread field and another condition variable).
+The structure is attached by 'm' magic to any SV. pp_lock locks
+such an object by waiting on the ownercond condition variable until
+the owner field is zero and then setting the owner field to its own
+thread pointer. The lock is semantically recursive so if the owner
+field already matches the current thread then pp_lock returns
+straight away. If the owner field has to be filled in then
+unlock_condpair is queued as an end-of-block destructor and
+that function zeroes out the owner field and signals the ownercond
+condition variable, thus waking up any other thread that wants to
+lock it. When used as a condition variable, the condpair is locked
+(involving the above wait-for-ownership and setting the owner field)
+and the spare condition variable field is used for waiting on.
+
+
+Thread states
+
+
+ $t->join
+R_JOINABLE ---------------------> R_JOINED >----\
+ | \ pthread_join(t) | ^ |
+ | \ | | join | pthread_join
+ | \ | | |
+ | \ | \------/
+ | \ |
+ | \ |
+ | $t->detach\ pthread_detach |
+ | _\| |
+ends| R_DETACHED ends | unlink
+ | \ |
+ | ends \ unlink |
+ | \ |
+ | \ |
+ | \ |
+ | \ |
+ | \ |
+ V join detach _\| V
+ZOMBIE ----------------------------> DEAD
+ pthread_join pthread_detach
+ and unlink and unlink
+
+
+
+Malcolm Beattie
+mbeattie@sable.ox.ac.uk
+2 October 1997
--- /dev/null
+Merging
+ 5.004_04
+ oneperl (THIS pointer)
+
+Multi-threading
+ Fix Thread->list
+ $AUTOLOAD. Hmm.
+ without USE_THREADS, change extern variable for dTHR
+ consistent semantics for exit/die in threads
+ SvREFCNT_dec(curstack) in threadstart() in Thread.xs
+ $@ and other magic globals:
+ global lexical pool with auto-binding for magicals
+ move magicals that should be per-thread into thread.h
+ sv_magic for the necessary global lexical pool entries
+ Thread::Pool
+ check new condition variable word; fix cond.t
+ more Configure support
+
+Miscellaneous
+ rename and alter ISA.pm
+
+Compiler
+ auto-produce executable
+ typed lexicals should affect B::CC::load_pad
+ workarounds to help Win32
+ $^C to track compiler/checker status
+ END blocks need saving in compiled output
+ _AUTOLOAD prodding
+
+Documentation
+ lots
#endif
#define dXSARGS \
- dSP; dMARK; \
+ dTHR; dSP; dMARK; \
I32 ax = mark - stack_base + 1; \
I32 items = sp - mark
while (key) {
sv = AvARRAY(av)[--key];
assert(sv);
- if (sv != &sv_undef)
+ if (sv != &sv_undef) {
+ dTHR;
(void)SvREFCNT_inc(sv);
+ }
}
key = AvARRAY(av) - AvALLOC(av);
while (key)
AV *av;
I32 key;
{
+ dTHR; /* only necessary if we have to extend stack */
if (key > AvMAX(av)) {
SV** ary;
I32 tmp;
newmax = tmp - 1;
New(2,ary, newmax+1, SV*);
Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
- if (AvMAX(av) > 64 && !nice_chunk) {
- nice_chunk = (char*)AvALLOC(av);
- nice_chunk_size = (AvMAX(av) + 1) * sizeof(SV*);
- }
+ if (AvMAX(av) > 64)
+ offer_nice_chunk(AvALLOC(av), (AvMAX(av)+1) * sizeof(SV*));
else
Safefree(AvALLOC(av));
AvALLOC(av) = ary;
if (SvRMAGICAL(av)) {
if (mg_find((SV*)av,'P')) {
+ dTHR;
sv = sv_newmortal();
mg_copy((SV*)av, sv, 0, key);
Sv = sv;
ary = AvARRAY(av);
if (AvFILL(av) < key) {
if (!AvREAL(av)) {
+ dTHR;
if (av == curstack && key > stack_sp - stack_base)
stack_sp = stack_base + key; /* XPUSH in disguise */
do
else
(void)av_store(av,fill,&sv_undef);
}
+
+SV**
+avhv_fetch(av, key, klen, lval)
+AV *av;
+char *key;
+U32 klen;
+I32 lval;
+{
+ SV **keys, **indsvp;
+ I32 ind;
+
+ keys = av_fetch(av, 0, FALSE);
+ if (!keys || !SvROK(*keys) || SvTYPE(SvRV(*keys)) != SVt_PVHV)
+ croak("Can't coerce array into hash");
+ indsvp = hv_fetch((HV*)SvRV(*keys), key, klen, FALSE);
+ if (indsvp) {
+ ind = SvIV(*indsvp);
+ if (ind < 1)
+ croak("Bad index while coercing array into hash");
+ } else {
+ if (!lval)
+ return 0;
+
+ ind = AvFILL(av) + 1;
+ hv_store((HV*)SvRV(*keys), key, klen, newSViv(ind), 0);
+ }
+ return av_fetch(av, ind, lval);
+}
+
+SV**
+avhv_fetch_ent(av, keysv, lval, hash)
+AV *av;
+SV *keysv;
+I32 lval;
+U32 hash;
+{
+ SV **keys, **indsvp;
+ HE *he;
+ I32 ind;
+
+ keys = av_fetch(av, 0, FALSE);
+ if (!keys || !SvROK(*keys) || SvTYPE(SvRV(*keys)) != SVt_PVHV)
+ croak("Can't coerce array into hash");
+ he = hv_fetch_ent((HV*)SvRV(*keys), keysv, FALSE, hash);
+ if (he) {
+ ind = SvIV(HeVAL(he));
+ if (ind < 1)
+ croak("Bad index while coercing array into hash");
+ } else {
+ if (!lval)
+ return 0;
+
+ ind = AvFILL(av) + 1;
+ hv_store_ent((HV*)SvRV(*keys), keysv, newSViv(ind), 0);
+ }
+ return av_fetch(av, ind, lval);
+}
+
+SV**
+avhv_store(av, key, klen, val, hash)
+AV *av;
+char *key;
+U32 klen;
+SV *val;
+U32 hash;
+{
+ SV **keys, **indsvp;
+ I32 ind;
+
+ keys = av_fetch(av, 0, FALSE);
+ if (!keys || !SvROK(*keys) || SvTYPE(SvRV(*keys)) != SVt_PVHV)
+ croak("Can't coerce array into hash");
+ indsvp = hv_fetch((HV*)SvRV(*keys), key, klen, FALSE);
+ if (indsvp) {
+ ind = SvIV(*indsvp);
+ if (ind < 1)
+ croak("Bad index while coercing array into hash");
+ } else {
+ ind = AvFILL(av) + 1;
+ hv_store((HV*)SvRV(*keys), key, klen, newSViv(ind), hash);
+ }
+ return av_store(av, ind, val);
+}
+
+SV**
+avhv_store_ent(av, keysv, val, hash)
+AV *av;
+SV *keysv;
+SV *val;
+U32 hash;
+{
+ SV **keys;
+ HE *he;
+ I32 ind;
+
+ keys = av_fetch(av, 0, FALSE);
+ if (!keys || !SvROK(*keys) || SvTYPE(SvRV(*keys)) != SVt_PVHV)
+ croak("Can't coerce array into hash");
+ he = hv_fetch_ent((HV*)SvRV(*keys), keysv, FALSE, hash);
+ if (he) {
+ ind = SvIV(HeVAL(he));
+ if (ind < 1)
+ croak("Bad index while coercing array into hash");
+ } else {
+ ind = AvFILL(av) + 1;
+ hv_store_ent((HV*)SvRV(*keys), keysv, newSViv(ind), hash);
+ }
+ return av_store(av, ind, val);
+}
+
+bool
+avhv_exists_ent(av, keysv, hash)
+AV *av;
+SV *keysv;
+U32 hash;
+{
+ SV **keys;
+
+ keys = av_fetch(av, 0, FALSE);
+ if (!keys || !SvROK(*keys) || SvTYPE(SvRV(*keys)) != SVt_PVHV)
+ croak("Can't coerce array into hash");
+ return hv_exists_ent((HV*)SvRV(*keys), keysv, hash);
+}
+
+bool
+avhv_exists(av, key, klen)
+AV *av;
+char *key;
+U32 klen;
+{
+ SV **keys;
+
+ keys = av_fetch(av, 0, FALSE);
+ if (!keys || !SvROK(*keys) || SvTYPE(SvRV(*keys)) != SVt_PVHV)
+ croak("Can't coerce array into hash");
+ return hv_exists((HV*)SvRV(*keys), key, klen);
+}
+
+/* avhv_delete leaks. Caller can re-index and compress if so desired. */
+SV *
+avhv_delete(av, key, klen, flags)
+AV *av;
+char *key;
+U32 klen;
+I32 flags;
+{
+ SV **keys;
+ SV *sv;
+ SV **svp;
+ I32 ind;
+
+ keys = av_fetch(av, 0, FALSE);
+ if (!keys || !SvROK(*keys) || SvTYPE(SvRV(*keys)) != SVt_PVHV)
+ croak("Can't coerce array into hash");
+ sv = hv_delete((HV*)SvRV(*keys), key, klen, 0);
+ if (!sv)
+ return Nullsv;
+ ind = SvIV(sv);
+ if (ind < 1)
+ croak("Bad index while coercing array into hash");
+ svp = av_fetch(av, ind, FALSE);
+ if (!svp)
+ return Nullsv;
+ if (flags & G_DISCARD) {
+ sv = Nullsv;
+ SvREFCNT_dec(*svp);
+ } else {
+ sv = sv_2mortal(*svp);
+ }
+ *svp = &sv_undef;
+ return sv;
+}
+
+/* avhv_delete_ent leaks. Caller can re-index and compress if so desired. */
+SV *
+avhv_delete_ent(av, keysv, flags, hash)
+AV *av;
+SV *keysv;
+I32 flags;
+U32 hash;
+{
+ SV **keys;
+ SV *sv;
+ SV **svp;
+ I32 ind;
+
+ keys = av_fetch(av, 0, FALSE);
+ if (!keys || !SvROK(*keys) || SvTYPE(SvRV(*keys)) != SVt_PVHV)
+ croak("Can't coerce array into hash");
+ sv = hv_delete_ent((HV*)SvRV(*keys), keysv, 0, hash);
+ if (!sv)
+ return Nullsv;
+ ind = SvIV(sv);
+ if (ind < 1)
+ croak("Bad index while coercing array into hash");
+ svp = av_fetch(av, ind, FALSE);
+ if (!svp)
+ return Nullsv;
+ if (flags & G_DISCARD) {
+ sv = Nullsv;
+ SvREFCNT_dec(*svp);
+ } else {
+ sv = sv_2mortal(*svp);
+ }
+ *svp = &sv_undef;
+ return sv;
+}
+
+I32
+avhv_iterinit(av)
+AV *av;
+{
+ SV **keys;
+
+ keys = av_fetch(av, 0, FALSE);
+ if (!keys || !SvROK(*keys) || SvTYPE(SvRV(*keys)) != SVt_PVHV)
+ croak("Can't coerce array into hash");
+ return hv_iterinit((HV*)SvRV(*keys));
+}
+
+HE *
+avhv_iternext(av)
+AV *av;
+{
+ SV **keys;
+
+ keys = av_fetch(av, 0, FALSE);
+ if (!keys || !SvROK(*keys) || SvTYPE(SvRV(*keys)) != SVt_PVHV)
+ croak("Can't coerce array into hash");
+ return hv_iternext((HV*)SvRV(*keys));
+}
+
+SV *
+avhv_iterval(av, entry)
+AV *av;
+register HE *entry;
+{
+ SV **keys;
+ SV *sv;
+ I32 ind;
+
+ keys = av_fetch(av, 0, FALSE);
+ if (!keys || !SvROK(*keys) || SvTYPE(SvRV(*keys)) != SVt_PVHV)
+ croak("Can't coerce array into hash");
+ sv = hv_iterval((HV*)SvRV(*keys), entry);
+ ind = SvIV(sv);
+ if (ind < 1)
+ croak("Bad index while coercing array into hash");
+ return *av_fetch(av, ind, TRUE);
+}
+
+SV *
+avhv_iternextsv(av, key, retlen)
+AV *av;
+char **key;
+I32 *retlen;
+{
+ SV **keys;
+ HE *he;
+ SV *sv;
+ I32 ind;
+
+ keys = av_fetch(av, 0, FALSE);
+ if (!keys || !SvROK(*keys) || SvTYPE(SvRV(*keys)) != SVt_PVHV)
+ croak("Can't coerce array into hash");
+ if ( (he = hv_iternext((HV*)SvRV(*keys))) == NULL)
+ return NULL;
+ *key = hv_iterkey(he, retlen);
+ sv = hv_iterval((HV*)SvRV(*keys), he);
+ ind = SvIV(sv);
+ if (ind < 1)
+ croak("Bad index while coercing array into hash");
+ return *av_fetch(av, ind, TRUE);
+}
CV * cv;
GV * gv;
GV * dfoutgv;
+#ifndef USE_THREADS
AV * savearray;
+#endif /* USE_THREADS */
AV * argarray;
U16 olddepth;
U8 hasargs;
#define POPSUB1(cx) \
cxsub = cx->blk_sub; /* because DESTROY may clobber *cx */
+#ifdef USE_THREADS
+#define POPSAVEARRAY() NOOP
+#else
+#define POPSAVEARRAY() \
+ STMT_START { \
+ SvREFCNT_dec(GvAV(defgv)); \
+ GvAV(defgv) = cxsub.savearray; \
+ } STMT_END
+#endif /* USE_THREADS */
+
#define POPSUB2() \
if (cxsub.hasargs) { \
- /* put back old @_ */ \
- SvREFCNT_dec(GvAV(defgv)); \
- GvAV(defgv) = cxsub.savearray; \
+ POPSAVEARRAY(); \
/* destroy arg array */ \
av_clear(cxsub.argarray); \
AvREAL_off(cxsub.argarray); \
long xcv_depth; /* >= 2 indicates recursive call */
AV * xcv_padlist;
CV * xcv_outside;
- U8 xcv_flags;
+#ifdef USE_THREADS
+ perl_mutex *xcv_mutexp;
+ struct thread *xcv_owner; /* current owner thread */
+#endif /* USE_THREADS */
+ cv_flags_t xcv_flags;
};
#define Nullcv Null(CV*)
#define CvDEPTH(sv) ((XPVCV*)SvANY(sv))->xcv_depth
#define CvPADLIST(sv) ((XPVCV*)SvANY(sv))->xcv_padlist
#define CvOUTSIDE(sv) ((XPVCV*)SvANY(sv))->xcv_outside
+#ifdef USE_THREADS
+#define CvMUTEXP(sv) ((XPVCV*)SvANY(sv))->xcv_mutexp
+#define CvOWNER(sv) ((XPVCV*)SvANY(sv))->xcv_owner
+#endif /* USE_THREADS */
#define CvFLAGS(sv) ((XPVCV*)SvANY(sv))->xcv_flags
-#define CVf_CLONE 0x01 /* anon CV uses external lexicals */
-#define CVf_CLONED 0x02 /* a clone of one of those */
-#define CVf_ANON 0x04 /* CvGV() can't be trusted */
-#define CVf_OLDSTYLE 0x08
-#define CVf_UNIQUE 0x10 /* can't be cloned */
-#define CVf_NODEBUG 0x20 /* no DB::sub indirection for this CV
+#define CVf_CLONE 0x0001 /* anon CV uses external lexicals */
+#define CVf_CLONED 0x0002 /* a clone of one of those */
+#define CVf_ANON 0x0004 /* CvGV() can't be trusted */
+#define CVf_OLDSTYLE 0x0008
+#define CVf_UNIQUE 0x0010 /* can't be cloned */
+#define CVf_NODEBUG 0x0020 /* no DB::sub indirection for this CV
(esp. useful for special XSUBs) */
+#define CVf_METHOD 0x0040 /* CV is explicitly marked as a method */
+#define CVf_LOCKED 0x0080 /* CV locks itself or first arg on entry */
#define CvCLONE(cv) (CvFLAGS(cv) & CVf_CLONE)
#define CvCLONE_on(cv) (CvFLAGS(cv) |= CVf_CLONE)
#define CvNODEBUG(cv) (CvFLAGS(cv) & CVf_NODEBUG)
#define CvNODEBUG_on(cv) (CvFLAGS(cv) |= CVf_NODEBUG)
#define CvNODEBUG_off(cv) (CvFLAGS(cv) &= ~CVf_NODEBUG)
+
+#define CvMETHOD(cv) (CvFLAGS(cv) & CVf_METHOD)
+#define CvMETHOD_on(cv) (CvFLAGS(cv) |= CVf_METHOD)
+#define CvMETHOD_off(cv) (CvFLAGS(cv) &= ~CVf_METHOD)
+
+#define CvLOCKED(cv) (CvFLAGS(cv) & CVf_LOCKED)
+#define CvLOCKED_on(cv) (CvFLAGS(cv) |= CVf_LOCKED)
+#define CvLOCKED_off(cv) (CvFLAGS(cv) &= ~CVf_LOCKED)
deb(pat,a1,a2,a3,a4,a5,a6,a7,a8)
char *pat;
{
+ dTHR;
register I32 i;
GV* gv = curcop->cop_filegv;
+#ifdef USE_THREADS
+ PerlIO_printf(Perl_debug_log,"0x%lx (%s:%ld)\t",
+ (unsigned long) thr,
+ SvTYPE(gv) == SVt_PVGV ? SvPVX(GvSV(gv)) : "<free>",
+ (long)curcop->cop_line);
+#else
PerlIO_printf(Perl_debug_log, "(%s:%ld)\t",
SvTYPE(gv) == SVt_PVGV ? SvPVX(GvSV(gv)) : "<free>",
(long)curcop->cop_line);
+#endif /* USE_THREADS */
for (i=0; i<dlevel; i++)
PerlIO_printf(Perl_debug_log, "%c%c ",debname[i],debdelim[i]);
PerlIO_printf(Perl_debug_log, pat,a1,a2,a3,a4,a5,a6,a7,a8);
va_dcl
# endif
{
+ dTHR;
va_list args;
register I32 i;
GV* gv = curcop->cop_filegv;
+#ifdef USE_THREADS
+ PerlIO_printf(Perl_debug_log, "0x%lx (%s:%ld)\t",
+ (unsigned long) thr,
+ SvTYPE(gv) == SVt_PVGV ? SvPVX(GvSV(gv)) : "<free>",
+ (long)curcop->cop_line);
+#else
PerlIO_printf(Perl_debug_log, "(%s:%ld)\t",
SvTYPE(gv) == SVt_PVGV ? SvPVX(GvSV(gv)) : "<free>",
(long)curcop->cop_line);
+#endif /* USE_THREADS */
for (i=0; i<dlevel; i++)
PerlIO_printf(Perl_debug_log, "%c%c ",debname[i],debdelim[i]);
I32
debstackptrs()
{
+ dTHR;
PerlIO_printf(Perl_debug_log, "%8lx %8lx %8ld %8ld %8ld\n",
(unsigned long)curstack, (unsigned long)stack_base,
(long)*markstack_ptr, (long)(stack_sp-stack_base),
I32
debstack()
{
+ dTHR;
I32 top = stack_sp - stack_base;
register I32 i = top - 30;
I32 *markscan = markstack;
if (*markscan >= i)
break;
+#ifdef USE_THREADS
+ PerlIO_printf(Perl_debug_log, i ? "0x%lx => ... " : "0x%lx => ",
+ (unsigned long) thr);
+#else
PerlIO_printf(Perl_debug_log, i ? " => ... " : " => ");
+#endif /* USE_THREADS */
if (stack_base[0] != &sv_undef || stack_sp < stack_base)
PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n");
do {
}
if (IoTYPE(io) &&
IoTYPE(io) != '|' && IoTYPE(io) != '-') {
+ dTHR;
if (Fstat(PerlIO_fileno(fp),&statbuf) < 0) {
(void)PerlIO_close(fp);
goto say_false;
!statbuf.st_mode
#endif
) {
- Sock_size_t buflen = sizeof tokenbuf;
- if (getsockname(PerlIO_fileno(fp), (struct sockaddr *)tokenbuf,
+ char tmpbuf[256];
+ Sock_size_t buflen = sizeof tmpbuf;
+ if (getsockname(PerlIO_fileno(fp), (struct sockaddr *)tmpbuf,
&buflen) >= 0
|| errno != ENOTSOCK)
IoTYPE(io) = 's'; /* some OS's return 0 on fstat()ed socket */
#endif
IoIFP(io) = fp;
if (writing) {
+ dTHR;
if (IoTYPE(io) == 's'
|| (IoTYPE(io) == '>' && S_ISCHR(statbuf.st_mode)) ) {
if (!(IoOFP(io) = PerlIO_fdopen(PerlIO_fileno(fp),"w"))) {
}
filemode = 0;
while (av_len(GvAV(gv)) >= 0) {
+ dTHR;
STRLEN len;
sv = av_shift(GvAV(gv));
SAVEFREESV(sv);
do_eof(gv)
GV *gv;
{
+ dTHR;
register IO *io;
int ch;
char *tmps;
if (sp > mark) {
+ dTHR;
New(401,Argv, sp - mark + 1, char*);
a = Argv;
while (++mark <= sp) {
register SV **mark;
register SV **sp;
{
+ dTHR;
register I32 val;
register I32 val2;
register I32 tot = 0;
SV **mark;
SV **sp;
{
+ dTHR;
key_t key;
I32 n, flags;
SV **mark;
SV **sp;
{
+ dTHR;
SV *astr;
char *a;
I32 id, n, cmd, infosize, getinfo;
SV **sp;
{
#ifdef HAS_MSG
+ dTHR;
SV *mstr;
char *mbuf;
I32 id, msize, flags;
SV **sp;
{
#ifdef HAS_MSG
+ dTHR;
SV *mstr;
char *mbuf;
long mtype;
SV **sp;
{
#ifdef HAS_SEM
+ dTHR;
SV *opstr;
char *opbuf;
I32 id;
SV **sp;
{
#ifdef HAS_SHM
+ dTHR;
SV *mstr;
char *mbuf, *shm;
I32 id, mpos, msize;
SV *sv;
OP *arg;
{
+ dTHR;
register short *tbl;
register U8 *s;
register U8 *send;
I32 gimme = GIMME_V;
I32 dokeys = (op->op_type == OP_KEYS);
I32 dovalues = (op->op_type == OP_VALUES);
-
+ I32 realhv = (SvTYPE(hv) == SVt_PVHV);
+
if (op->op_type == OP_RV2HV || op->op_type == OP_PADHV)
dokeys = dovalues = TRUE;
RETURN;
}
- (void)hv_iterinit(hv); /* always reset iterator regardless */
+ if (realhv)
+ (void)hv_iterinit(hv); /* always reset iterator regardless */
+ else
+ (void)avhv_iterinit((AV*)hv);
if (gimme == G_VOID)
RETURN;
else {
i = 0;
/*SUPPRESS 560*/
- while (entry = hv_iternext(hv)) {
+ while (entry = realhv ? hv_iternext(hv) : avhv_iternext((AV*)hv)) {
i++;
}
}
EXTEND(sp, HvMAX(hv) * (dokeys + dovalues));
PUTBACK; /* hv_iternext and hv_iterval might clobber stack_sp */
- while (entry = hv_iternext(hv)) {
+ while (entry = realhv ? hv_iternext(hv) : avhv_iternext((AV*)hv)) {
SPAGAIN;
if (dokeys)
XPUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
if (dovalues) {
tmpstr = sv_newmortal();
PUTBACK;
- sv_setsv(tmpstr,hv_iterval(hv,entry));
+ sv_setsv(tmpstr,realhv ?
+ hv_iterval(hv,entry) : avhv_iterval((AV*)hv,entry));
DEBUG_H(sv_setpvf(tmpstr, "%lu%%%d=%lu",
(unsigned long)HeHASH(entry),
HvMAX(hv)+1,
}
return NORMAL;
}
-
void
dump_all()
{
+ dTHR;
PerlIO_setlinebuf(Perl_debug_log);
if (main_root)
dump_op(main_root);
dump_packsubs(stash)
HV* stash;
{
+ dTHR;
I32 i;
HE *entry;
}
void
-dump_op(op)
-register OP *op;
+dump_op(o)
+register OP *o;
{
dump("{\n");
- if (op->op_seq)
- PerlIO_printf(Perl_debug_log, "%-4d", op->op_seq);
+ if (o->op_seq)
+ PerlIO_printf(Perl_debug_log, "%-4d", o->op_seq);
else
PerlIO_printf(Perl_debug_log, " ");
- dump("TYPE = %s ===> ", op_name[op->op_type]);
- if (op->op_next) {
- if (op->op_seq)
- PerlIO_printf(Perl_debug_log, "%d\n", op->op_next->op_seq);
+ dump("TYPE = %s ===> ", op_name[o->op_type]);
+ if (o->op_next) {
+ if (o->op_seq)
+ PerlIO_printf(Perl_debug_log, "%d\n", o->op_next->op_seq);
else
- PerlIO_printf(Perl_debug_log, "(%d)\n", op->op_next->op_seq);
+ PerlIO_printf(Perl_debug_log, "(%d)\n", o->op_next->op_seq);
}
else
PerlIO_printf(Perl_debug_log, "DONE\n");
dumplvl++;
- if (op->op_targ) {
- if (op->op_type == OP_NULL)
- dump(" (was %s)\n", op_name[op->op_targ]);
+ if (o->op_targ) {
+ if (o->op_type == OP_NULL)
+ dump(" (was %s)\n", op_name[o->op_targ]);
else
- dump("TARG = %d\n", op->op_targ);
+ dump("TARG = %d\n", o->op_targ);
}
#ifdef DUMPADDR
- dump("ADDR = 0x%lx => 0x%lx\n",op, op->op_next);
+ dump("ADDR = 0x%lx => 0x%lx\n",o, o->op_next);
#endif
- if (op->op_flags) {
+ if (o->op_flags) {
SV *tmpsv = newSVpv("", 0);
- switch (op->op_flags & OPf_WANT) {
+ switch (o->op_flags & OPf_WANT) {
case OPf_WANT_VOID:
sv_catpv(tmpsv, ",VOID");
break;
sv_catpv(tmpsv, ",UNKNOWN");
break;
}
- if (op->op_flags & OPf_KIDS)
+ if (o->op_flags & OPf_KIDS)
sv_catpv(tmpsv, ",KIDS");
- if (op->op_flags & OPf_PARENS)
+ if (o->op_flags & OPf_PARENS)
sv_catpv(tmpsv, ",PARENS");
- if (op->op_flags & OPf_STACKED)
+ if (o->op_flags & OPf_STACKED)
sv_catpv(tmpsv, ",STACKED");
- if (op->op_flags & OPf_REF)
+ if (o->op_flags & OPf_REF)
sv_catpv(tmpsv, ",REF");
- if (op->op_flags & OPf_MOD)
+ if (o->op_flags & OPf_MOD)
sv_catpv(tmpsv, ",MOD");
- if (op->op_flags & OPf_SPECIAL)
+ if (o->op_flags & OPf_SPECIAL)
sv_catpv(tmpsv, ",SPECIAL");
dump("FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
SvREFCNT_dec(tmpsv);
}
- if (op->op_private) {
+ if (o->op_private) {
SV *tmpsv = newSVpv("", 0);
- if (op->op_type == OP_AASSIGN) {
- if (op->op_private & OPpASSIGN_COMMON)
+ if (o->op_type == OP_AASSIGN) {
+ if (o->op_private & OPpASSIGN_COMMON)
sv_catpv(tmpsv, ",COMMON");
}
- else if (op->op_type == OP_SASSIGN) {
- if (op->op_private & OPpASSIGN_BACKWARDS)
+ else if (o->op_type == OP_SASSIGN) {
+ if (o->op_private & OPpASSIGN_BACKWARDS)
sv_catpv(tmpsv, ",BACKWARDS");
}
- else if (op->op_type == OP_TRANS) {
- if (op->op_private & OPpTRANS_SQUASH)
+ else if (o->op_type == OP_TRANS) {
+ if (o->op_private & OPpTRANS_SQUASH)
sv_catpv(tmpsv, ",SQUASH");
- if (op->op_private & OPpTRANS_DELETE)
+ if (o->op_private & OPpTRANS_DELETE)
sv_catpv(tmpsv, ",DELETE");
- if (op->op_private & OPpTRANS_COMPLEMENT)
+ if (o->op_private & OPpTRANS_COMPLEMENT)
sv_catpv(tmpsv, ",COMPLEMENT");
}
- else if (op->op_type == OP_REPEAT) {
- if (op->op_private & OPpREPEAT_DOLIST)
+ else if (o->op_type == OP_REPEAT) {
+ if (o->op_private & OPpREPEAT_DOLIST)
sv_catpv(tmpsv, ",DOLIST");
}
- else if (op->op_type == OP_ENTERSUB ||
- op->op_type == OP_RV2SV ||
- op->op_type == OP_RV2AV ||
- op->op_type == OP_RV2HV ||
- op->op_type == OP_RV2GV ||
- op->op_type == OP_AELEM ||
- op->op_type == OP_HELEM )
+ else if (o->op_type == OP_ENTERSUB ||
+ o->op_type == OP_RV2SV ||
+ o->op_type == OP_RV2AV ||
+ o->op_type == OP_RV2HV ||
+ o->op_type == OP_RV2GV ||
+ o->op_type == OP_AELEM ||
+ o->op_type == OP_HELEM )
{
- if (op->op_type == OP_ENTERSUB) {
- if (op->op_private & OPpENTERSUB_AMPER)
+ if (o->op_type == OP_ENTERSUB) {
+ if (o->op_private & OPpENTERSUB_AMPER)
sv_catpv(tmpsv, ",AMPER");
- if (op->op_private & OPpENTERSUB_DB)
+ if (o->op_private & OPpENTERSUB_DB)
sv_catpv(tmpsv, ",DB");
}
- switch (op->op_private & OPpDEREF) {
+ switch (o->op_private & OPpDEREF) {
case OPpDEREF_SV:
sv_catpv(tmpsv, ",SV");
break;
sv_catpv(tmpsv, ",HV");
break;
}
- if (op->op_type == OP_AELEM || op->op_type == OP_HELEM) {
- if (op->op_private & OPpLVAL_DEFER)
+ if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
+ if (o->op_private & OPpLVAL_DEFER)
sv_catpv(tmpsv, ",LVAL_DEFER");
}
else {
- if (op->op_private & HINT_STRICT_REFS)
+ if (o->op_private & HINT_STRICT_REFS)
sv_catpv(tmpsv, ",STRICT_REFS");
}
}
- else if (op->op_type == OP_CONST) {
- if (op->op_private & OPpCONST_BARE)
+ else if (o->op_type == OP_CONST) {
+ if (o->op_private & OPpCONST_BARE)
sv_catpv(tmpsv, ",BARE");
}
- else if (op->op_type == OP_FLIP) {
- if (op->op_private & OPpFLIP_LINENUM)
+ else if (o->op_type == OP_FLIP) {
+ if (o->op_private & OPpFLIP_LINENUM)
sv_catpv(tmpsv, ",LINENUM");
}
- else if (op->op_type == OP_FLOP) {
- if (op->op_private & OPpFLIP_LINENUM)
+ else if (o->op_type == OP_FLOP) {
+ if (o->op_private & OPpFLIP_LINENUM)
sv_catpv(tmpsv, ",LINENUM");
}
- if (op->op_flags & OPf_MOD && op->op_private & OPpLVAL_INTRO)
+ if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
sv_catpv(tmpsv, ",INTRO");
if (SvCUR(tmpsv))
dump("PRIVATE = (%s)\n", SvPVX(tmpsv) + 1);
SvREFCNT_dec(tmpsv);
}
- switch (op->op_type) {
+ switch (o->op_type) {
case OP_GVSV:
case OP_GV:
- if (cGVOP->op_gv) {
+ if (cGVOPo->op_gv) {
SV *tmpsv = NEWSV(0,0);
ENTER;
SAVEFREESV(tmpsv);
- gv_fullname3(tmpsv, cGVOP->op_gv, Nullch);
+ gv_fullname3(tmpsv, cGVOPo->op_gv, Nullch);
dump("GV = %s\n", SvPV(tmpsv, na));
LEAVE;
}
dump("GV = NULL\n");
break;
case OP_CONST:
- dump("SV = %s\n", SvPEEK(cSVOP->op_sv));
+ dump("SV = %s\n", SvPEEK(cSVOPo->op_sv));
break;
case OP_NEXTSTATE:
case OP_DBSTATE:
- if (cCOP->cop_line)
- dump("LINE = %d\n",cCOP->cop_line);
- if (cCOP->cop_label)
- dump("LABEL = \"%s\"\n",cCOP->cop_label);
+ if (cCOPo->cop_line)
+ dump("LINE = %d\n",cCOPo->cop_line);
+ if (cCOPo->cop_label)
+ dump("LABEL = \"%s\"\n",cCOPo->cop_label);
break;
case OP_ENTERLOOP:
dump("REDO ===> ");
- if (cLOOP->op_redoop)
- PerlIO_printf(Perl_debug_log, "%d\n", cLOOP->op_redoop->op_seq);
+ if (cLOOPo->op_redoop)
+ PerlIO_printf(Perl_debug_log, "%d\n", cLOOPo->op_redoop->op_seq);
else
PerlIO_printf(Perl_debug_log, "DONE\n");
dump("NEXT ===> ");
- if (cLOOP->op_nextop)
- PerlIO_printf(Perl_debug_log, "%d\n", cLOOP->op_nextop->op_seq);
+ if (cLOOPo->op_nextop)
+ PerlIO_printf(Perl_debug_log, "%d\n", cLOOPo->op_nextop->op_seq);
else
PerlIO_printf(Perl_debug_log, "DONE\n");
dump("LAST ===> ");
- if (cLOOP->op_lastop)
- PerlIO_printf(Perl_debug_log, "%d\n", cLOOP->op_lastop->op_seq);
+ if (cLOOPo->op_lastop)
+ PerlIO_printf(Perl_debug_log, "%d\n", cLOOPo->op_lastop->op_seq);
else
PerlIO_printf(Perl_debug_log, "DONE\n");
break;
case OP_COND_EXPR:
dump("TRUE ===> ");
- if (cCONDOP->op_true)
- PerlIO_printf(Perl_debug_log, "%d\n", cCONDOP->op_true->op_seq);
+ if (cCONDOPo->op_true)
+ PerlIO_printf(Perl_debug_log, "%d\n", cCONDOPo->op_true->op_seq);
else
PerlIO_printf(Perl_debug_log, "DONE\n");
dump("FALSE ===> ");
- if (cCONDOP->op_false)
- PerlIO_printf(Perl_debug_log, "%d\n", cCONDOP->op_false->op_seq);
+ if (cCONDOPo->op_false)
+ PerlIO_printf(Perl_debug_log, "%d\n", cCONDOPo->op_false->op_seq);
else
PerlIO_printf(Perl_debug_log, "DONE\n");
break;
case OP_OR:
case OP_AND:
dump("OTHER ===> ");
- if (cLOGOP->op_other)
- PerlIO_printf(Perl_debug_log, "%d\n", cLOGOP->op_other->op_seq);
+ if (cLOGOPo->op_other)
+ PerlIO_printf(Perl_debug_log, "%d\n", cLOGOPo->op_other->op_seq);
else
PerlIO_printf(Perl_debug_log, "DONE\n");
break;
case OP_PUSHRE:
case OP_MATCH:
case OP_SUBST:
- dump_pm((PMOP*)op);
+ dump_pm(cPMOPo);
break;
default:
break;
}
- if (op->op_flags & OPf_KIDS) {
+ if (o->op_flags & OPf_KIDS) {
OP *kid;
- for (kid = cUNOP->op_first; kid; kid = kid->op_sibling)
+ for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
dump_op(kid);
}
dumplvl--;
#define av_store Perl_av_store
#define av_undef Perl_av_undef
#define av_unshift Perl_av_unshift
+#define avhv_delete Perl_avhv_delete
+#define avhv_delete_ent Perl_avhv_delete_ent
+#define avhv_exists Perl_avhv_exists
+#define avhv_exists_ent Perl_avhv_exists_ent
+#define avhv_fetch Perl_avhv_fetch
+#define avhv_fetch_ent Perl_avhv_fetch_ent
+#define avhv_iterinit Perl_avhv_iterinit
+#define avhv_iternext Perl_avhv_iternext
+#define avhv_iternextsv Perl_avhv_iternextsv
+#define avhv_iterval Perl_avhv_iterval
+#define avhv_store Perl_avhv_store
+#define avhv_store_ent Perl_avhv_store_ent
#define band_amg Perl_band_amg
#define bind_match Perl_bind_match
#define block_end Perl_block_end
#define comppad_name_fill Perl_comppad_name_fill
#define concat_amg Perl_concat_amg
#define concat_ass_amg Perl_concat_ass_amg
+#define condpair_magic Perl_condpair_magic
#define convert Perl_convert
#define cop_seqmax Perl_cop_seqmax
#define cos_amg Perl_cos_amg
#define ibcmp Perl_ibcmp
#define ibcmp_locale Perl_ibcmp_locale
#define in_my Perl_in_my
+#define in_my_stash Perl_in_my_stash
#define inc_amg Perl_inc_amg
#define ingroup Perl_ingroup
+#define init_stacks Perl_init_stacks
#define instr Perl_instr
#define intro_my Perl_intro_my
#define intuit_more Perl_intuit_more
#define magic_gettaint Perl_magic_gettaint
#define magic_getuvar Perl_magic_getuvar
#define magic_len Perl_magic_len
+#define magic_mutexfree Perl_magic_mutexfree
#define magic_nextpack Perl_magic_nextpack
#define magic_set Perl_magic_set
#define magic_set_all_env Perl_magic_set_all_env
#define op_name Perl_op_name
#define op_seqmax Perl_op_seqmax
#define opargs Perl_opargs
+#define opsave Perl_opsave
#define origalen Perl_origalen
#define origenviron Perl_origenviron
#define osname Perl_osname
#define pp_list Perl_pp_list
#define pp_listen Perl_pp_listen
#define pp_localtime Perl_pp_localtime
+#define pp_lock Perl_pp_lock
#define pp_log Perl_pp_log
#define pp_lslice Perl_pp_lslice
#define pp_lstat Perl_pp_lstat
#define save_list Perl_save_list
#define save_long Perl_save_long
#define save_nogv Perl_save_nogv
+#define save_op Perl_save_op
#define save_pptr Perl_save_pptr
#define save_scalar Perl_save_scalar
#define save_sptr Perl_save_sptr
#define sig_name Perl_sig_name
#define sig_num Perl_sig_num
#define sighandler Perl_sighandler
+#define sighandlerp Perl_sighandlerp
#define simple Perl_simple
#define sin_amg Perl_sin_amg
#define skipspace Perl_skipspace
#define too_many_arguments Perl_too_many_arguments
#define uid Perl_uid
#define unlnk Perl_unlnk
+#define unlock_condpair Perl_unlock_condpair
#define unshare_hek Perl_unshare_hek
#define unsharepvn Perl_unsharepvn
#define utilize Perl_utilize
#define vtbl_isa Perl_vtbl_isa
#define vtbl_isaelem Perl_vtbl_isaelem
#define vtbl_mglob Perl_vtbl_mglob
+#define vtbl_mutex Perl_vtbl_mutex
#define vtbl_nkeys Perl_vtbl_nkeys
#define vtbl_pack Perl_vtbl_pack
#define vtbl_packelem Perl_vtbl_packelem
#define gensym (curinterp->Igensym)
#define in_eval (curinterp->Iin_eval)
#define incgv (curinterp->Iincgv)
+#define initav (curinterp->Iinitav)
#define inplace (curinterp->Iinplace)
#define last_in_gv (curinterp->Ilast_in_gv)
#define lastfd (curinterp->Ilastfd)
#define minus_n (curinterp->Iminus_n)
#define minus_p (curinterp->Iminus_p)
#define multiline (curinterp->Imultiline)
-#define mystack_base (curinterp->Imystack_base)
-#define mystack_mark (curinterp->Imystack_mark)
-#define mystack_max (curinterp->Imystack_max)
-#define mystack_sp (curinterp->Imystack_sp)
#define mystrk (curinterp->Imystrk)
#define nrs (curinterp->Inrs)
#define ofmt (curinterp->Iofmt)
#define Igensym gensym
#define Iin_eval in_eval
#define Iincgv incgv
+#define Iinitav initav
#define Iinplace inplace
#define Ilast_in_gv last_in_gv
#define Ilastfd lastfd
#define Iminus_n minus_n
#define Iminus_p minus_p
#define Imultiline multiline
-#define Imystack_base mystack_base
-#define Imystack_mark mystack_mark
-#define Imystack_max mystack_max
-#define Imystack_sp mystack_sp
#define Imystrk mystrk
#define Inrs nrs
#define Iofmt ofmt
#define gensym Perl_gensym
#define in_eval Perl_in_eval
#define incgv Perl_incgv
+#define initav Perl_initav
#define inplace Perl_inplace
#define last_in_gv Perl_last_in_gv
#define lastfd Perl_lastfd
#define minus_n Perl_minus_n
#define minus_p Perl_minus_p
#define multiline Perl_multiline
-#define mystack_base Perl_mystack_base
-#define mystack_mark Perl_mystack_mark
-#define mystack_max Perl_mystack_max
-#define mystack_sp Perl_mystack_sp
#define mystrk Perl_mystrk
#define nrs Perl_nrs
#define ofmt Perl_ofmt
# DB_File.pm -- Perl 5 interface to Berkeley DB
#
# written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
-# 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
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 29th Jun 1997
- version 1.15
+ last modified 8th Oct 1997
+ version 1.16
All comments/suggestions/problems are welcome
database and an ordinary array to a HASH or BTREE database.
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.
*/
const DBT * key1 ;
const DBT * key2 ;
{
+ dTHR ;
dSP ;
void * data1, * data2 ;
int retval ;
const DBT * key1 ;
const DBT * key2 ;
{
+ dTHR ;
dSP ;
void * data1, * data2 ;
int retval ;
const void * data ;
size_t size ;
{
+ dTHR ;
dSP ;
int retval ;
int count ;
NAME => 'Opcode',
MAN3PODS => ' ',
VERSION_FROM => 'Opcode.pm',
- XS_VERSION => '1.02'
+ XS_VERSION => '1.03'
);
use vars qw($VERSION $XS_VERSION @ISA @EXPORT_OK);
$VERSION = "1.04";
-$XS_VERSION = "1.02";
+$XS_VERSION = "1.03";
use strict;
use Carp;
rand srand
+=item :base_thread
+
+This op is related to multi-threading.
+
+ lock
+
=item :default
A handy tag name for a I<reasonable> default set of ops. (The current ops
op_named_bits = newHV();
for(i=0; i < maxo; ++i) {
- hv_store(op_named_bits, op_name[i],strlen(op_name[i]),
- Sv=newSViv(i), 0);
- SvREADONLY_on(Sv);
+ SV *sv;
+ sv = newSViv(i);
+ SvREADONLY_on(sv);
+ hv_store(op_named_bits, op_name[i], strlen(op_name[i]), sv, 0);
}
put_op_bitspec(":none",0, sv_2mortal(new_opset(Nullsv)));
--- /dev/null
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ NAME => 'attrs',
+ VERSION_FROM => 'attrs.pm',
+ MAN3PODS => ' ', # Pods will be built by installman.
+ XSPROTOARG => '-noprototypes'
+);
--- /dev/null
+package attrs;
+require DynaLoader;
+use vars '@ISA';
+@ISA = 'DynaLoader';
+
+use vars qw($VERSION);
+$VERSION = "1.0";
+
+=head1 NAME
+
+attrs - set/get attributes of a subroutine
+
+=head1 SYNOPSIS
+
+ sub foo {
+ use attrs qw(locked method);
+ ...
+ }
+
+ @a = attrs::get(\&foo);
+
+=head1 DESCRIPTION
+
+This module lets you set and get attributes for subroutines.
+Setting attributes takes place at compile time; trying to set
+invalid attribute names causes a compile-time error. Calling
+C<attr::get> on a subroutine reference or name returns its list
+of attribute names. Notice that C<attr::get> is not exported.
+Valid attributes are as follows.
+
+=over
+
+=item method
+
+Indicates that the invoking subroutine is a method.
+
+=item locked
+
+Setting this attribute is only meaningful when the subroutine or
+method is to be called by multiple threads. When set on a method
+subroutine (i.e. one marked with the B<method> attribute above),
+perl ensures that any invocation of it implicitly locks its first
+argument before execution. When set on a non-method subroutine,
+perl ensures that a lock is taken on the subroutine itself before
+execution. The semantics of the lock are exactly those of one
+explicitly taken with the C<lock> operator immediately after the
+subroutine is entered.
+
+=back
+
+=cut
+
+bootstrap attrs $VERSION;
+
+1;
--- /dev/null
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+static cv_flags_t
+get_flag(attr)
+char *attr;
+{
+ if (strnEQ(attr, "method", 6))
+ return CVf_METHOD;
+ else if (strnEQ(attr, "locked", 6))
+ return CVf_LOCKED;
+ else
+ return 0;
+}
+
+MODULE = attrs PACKAGE = attrs
+
+void
+import(class, ...)
+char * class
+ ALIAS:
+ unimport = 1
+ PREINIT:
+ int i;
+ CV *cv;
+ PPCODE:
+ if (!compcv || !(cv = CvOUTSIDE(compcv)))
+ croak("can't set attributes outside a subroutine scope");
+ for (i = 1; i < items; i++) {
+ char *attr = SvPV(ST(i), na);
+ cv_flags_t flag = get_flag(attr);
+ if (!flag)
+ croak("invalid attribute name %s", attr);
+ if (ix)
+ CvFLAGS(cv) &= ~flag;
+ else
+ CvFLAGS(cv) |= flag;
+ }
+
+void
+get(sub)
+SV * sub
+ PPCODE:
+ if (SvROK(sub)) {
+ sub = SvRV(sub);
+ if (SvTYPE(sub) != SVt_PVCV)
+ sub = Nullsv;
+ }
+ else {
+ char *name = SvPV(sub, na);
+ sub = (SV*)perl_get_cv(name, FALSE);
+ }
+ if (!sub)
+ croak("invalid subroutine reference or name");
+ if (CvFLAGS(sub) & CVf_METHOD)
+ XPUSHs(sv_2mortal(newSVpv("method", 0)));
+ if (CvFLAGS(sub) & CVf_LOCKED)
+ XPUSHs(sv_2mortal(newSVpv("locked", 0)));
+
--- /dev/null
+typedef int perl_mutex;
+typedef int perl_key;
+
+struct perl_wait_queue {
+ struct thread * thread;
+ struct perl_wait_queue * next;
+};
+typedef struct perl_wait_queue *perl_cond;
+
+/* Ask thread.h to include our per-thread extras */
+#define HAVE_THREAD_INTERN
+struct thread_intern {
+ perl_thread next_run, prev_run; /* Linked list of runnable threads */
+ perl_cond wait_queue; /* Wait queue that we are waiting on */
+ IV private; /* Holds data across time slices */
+ I32 savemark; /* Holds MARK for thread join values */
+};
+
+#define init_thread_intern(t) \
+ STMT_START { \
+ t->Tself = (t); \
+ (t)->i.next_run = (t)->i.prev_run = (t); \
+ (t)->i.wait_queue = 0; \
+ (t)->i.private = 0; \
+ } STMT_END
+
hexdigit
hints
in_my
+in_my_stash
inc_amg
io_close
know_next
op_name
op_seqmax
opargs
+opsave
origalen
origenviron
osname
rsfp_filters
rshift_amg
rshift_ass_amg
+runops
savestack
savestack_ix
savestack_max
vtbl_isa
vtbl_isaelem
vtbl_mglob
+vtbl_mutex
vtbl_nkeys
vtbl_pack
vtbl_packelem
append_list
apply
assertref
+avhv_delete
+avhv_delete_ent
+avhv_exists
+avhv_exists_ent
+avhv_fetch
+avhv_fetch_ent
+avhv_iterinit
+avhv_iternext
+avhv_iternextsv
+avhv_iterval
+avhv_store
+avhv_store_ent
av_clear
av_extend
av_fake
ck_subr
ck_svconst
ck_trunc
+condpair_magic
convert
croak
cv_ckproto
ibcmp
ibcmp_locale
ingroup
+init_stacks
instr
intro_my
intuit_more
magic_gettaint
magic_getuvar
magic_len
+magic_mutexfree
magic_nextpack
magic_set
magic_setamagic
pp_list
pp_listen
pp_localtime
+pp_lock
pp_log
pp_lslice
pp_lstat
rsignal_save
rsignal_state
rsignal_restore
-runops
rxres_free
rxres_restore
rxres_save
save_list
save_long
save_nogv
+save_op
save_pptr
save_scalar
save_sptr
share_hek
sharepvn
sighandler
+sighandlerp
skipspace
stack_grow
start_subparse
too_few_arguments
too_many_arguments
unlnk
+unlock_condpair
unshare_hek
unsharepvn
utilize
gv_fetchfile(name)
char *name;
{
+ dTHR;
char smallbuf[256];
char *tmpbuf;
STRLEN tmplen;
STRLEN len;
int multi;
{
+ dTHR;
register GP *gp;
sv_upgrade((SV*)gv, SVt_PVGV);
basestash = gv_stashpvn(packname, packlen, TRUE);
gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) {
+ dTHR; /* just for SvREFCNT_dec */
gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
if (!gvp || !(gv = *gvp))
croak("Cannot create %s::ISA", HvNAME(stash));
(cv = GvCV(gv)) &&
(CvROOT(cv) || CvXSUB(cv)))
{
+ dTHR; /* just for SvREFCNT_inc */
if (cv = GvCV(topgv))
SvREFCNT_dec(cv);
GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
char* name;
I32 autoload;
{
+ dTHR;
register char *nend;
char *nsplit = 0;
GV* gv;
I32 add;
I32 sv_type;
{
+ dTHR;
register char *name = nambeg;
register GV *gv = 0;
GV**gvp;
IO *
newIO()
{
+ dTHR;
IO *io;
GV *iogv;
gv_check(stash)
HV* stash;
{
+ dTHR;
register HE *entry;
register I32 i;
register GV *gv;
Gv_AMupdate(stash)
HV* stash;
{
+ dTHR;
GV** gvp;
HV* hv;
GV* gv;
int method;
int flags;
{
+ dTHR;
MAGIC *mg;
CV *cv;
CV **cvp=NULL, **ocvp=NULL;
|| inc_dec_ass) RvDEEPCP(left);
}
{
+ dTHR;
dSP;
BINOP myop;
SV* res;
myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
ENTER;
- SAVESPTR(op);
+ SAVEOP();
op = (OP *) &myop;
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);
PUSHs((SV*)cv);
PUTBACK;
- if (op = pp_entersub())
+ if (op = pp_entersub(ARGS))
runops();
LEAVE;
SPAGAIN;
;;
esac
+if [ "X$usethreads" != "X" ]; then
+ ccflags="-DUSE_THREADS $ccflags"
+ optimize="-pthread $optimize"
+ ldflags="-pthread $ldflags"
+ set `echo X "$libswanted "| sed -e 's/ c / pthread c_r /'`
+ shift
+ libswanted="$*"
+ usemymalloc='n'
+fi
+
#
# Unset temporary variables no more needed.
#
# 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
# as --version or ld --version might dump core.
rm -f core
+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
+
# This is just a trick to include some useful notes.
cat > /dev/null <<'End_of_Solaris_Notes'
if (SvRMAGICAL(hv)) {
if (mg_find((SV*)hv,'P')) {
+ dTHR;
sv = sv_newmortal();
mg_copy((SV*)hv, sv, key, klen);
Sv = sv;
if (SvRMAGICAL(hv)) {
if (mg_find((SV*)hv,'P')) {
+ dTHR;
sv = sv_newmortal();
mg_copy((SV*)hv, sv, key, klen);
magic_existspack(sv, mg_find(sv, 'p'));
if (SvRMAGICAL(hv)) {
if (mg_find((SV*)hv,'P')) {
+ dTHR; /* just for SvTRUE */
sv = sv_newmortal();
keysv = sv_2mortal(newSVsv(keysv));
mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
assert(tmp >= newsize);
New(2,a, tmp, HE*);
Copy(xhv->xhv_array, a, oldsize, HE*);
- if (oldsize >= 64 && !nice_chunk) {
- nice_chunk = (char*)xhv->xhv_array;
- nice_chunk_size = oldsize * sizeof(HE*) * 2 - MALLOC_OVERHEAD;
+ if (oldsize >= 64) {
+ offer_nice_chunk(xhv->xhv_array,
+ oldsize * sizeof(HE*) * 2 - MALLOC_OVERHEAD);
}
else
Safefree(xhv->xhv_array);
assert(j >= newsize);
New(2, a, j, HE*);
Copy(xhv->xhv_array, a, oldsize, HE*);
- if (oldsize >= 64 && !nice_chunk) {
- nice_chunk = (char*)xhv->xhv_array;
- nice_chunk_size = oldsize * sizeof(HE*) * 2 - MALLOC_OVERHEAD;
+ if (oldsize >= 64) {
+ offer_nice_chunk(xhv->xhv_array,
+ oldsize * sizeof(HE*) * 2 - MALLOC_OVERHEAD);
}
else
Safefree(xhv->xhv_array);
}
magic_nextpack((SV*) hv,mg,key);
if (SvOK(key)) {
+ dTHR; /* just for SvREFCNT_inc */
/* force key to stay around until next time */
HeSVKEY_set(entry, SvREFCNT_inc(key));
return entry; /* beware, hent_val is not set */
gensym
in_eval
incgv
+initav
inplace
last_in_gv
lastfd
minus_n
minus_p
multiline
-mystack_base
-mystack_mark
-mystack_max
-mystack_sp
mystrk
nrs
ofmt
#define KEY_EQ 11
#define KEY_GE 12
#define KEY_GT 13
-#define KEY_LE 14
-#define KEY_LT 15
-#define KEY_NE 16
-#define KEY_abs 17
-#define KEY_accept 18
-#define KEY_alarm 19
-#define KEY_and 20
-#define KEY_atan2 21
-#define KEY_bind 22
-#define KEY_binmode 23
-#define KEY_bless 24
-#define KEY_caller 25
-#define KEY_chdir 26
-#define KEY_chmod 27
-#define KEY_chomp 28
-#define KEY_chop 29
-#define KEY_chown 30
-#define KEY_chr 31
-#define KEY_chroot 32
-#define KEY_close 33
-#define KEY_closedir 34
-#define KEY_cmp 35
-#define KEY_connect 36
-#define KEY_continue 37
-#define KEY_cos 38
-#define KEY_crypt 39
-#define KEY_dbmclose 40
-#define KEY_dbmopen 41
-#define KEY_defined 42
-#define KEY_delete 43
-#define KEY_die 44
-#define KEY_do 45
-#define KEY_dump 46
-#define KEY_each 47
-#define KEY_else 48
-#define KEY_elsif 49
-#define KEY_endgrent 50
-#define KEY_endhostent 51
-#define KEY_endnetent 52
-#define KEY_endprotoent 53
-#define KEY_endpwent 54
-#define KEY_endservent 55
-#define KEY_eof 56
-#define KEY_eq 57
-#define KEY_eval 58
-#define KEY_exec 59
-#define KEY_exists 60
-#define KEY_exit 61
-#define KEY_exp 62
-#define KEY_fcntl 63
-#define KEY_fileno 64
-#define KEY_flock 65
-#define KEY_for 66
-#define KEY_foreach 67
-#define KEY_fork 68
-#define KEY_format 69
-#define KEY_formline 70
-#define KEY_ge 71
-#define KEY_getc 72
-#define KEY_getgrent 73
-#define KEY_getgrgid 74
-#define KEY_getgrnam 75
-#define KEY_gethostbyaddr 76
-#define KEY_gethostbyname 77
-#define KEY_gethostent 78
-#define KEY_getlogin 79
-#define KEY_getnetbyaddr 80
-#define KEY_getnetbyname 81
-#define KEY_getnetent 82
-#define KEY_getpeername 83
-#define KEY_getpgrp 84
-#define KEY_getppid 85
-#define KEY_getpriority 86
-#define KEY_getprotobyname 87
-#define KEY_getprotobynumber 88
-#define KEY_getprotoent 89
-#define KEY_getpwent 90
-#define KEY_getpwnam 91
-#define KEY_getpwuid 92
-#define KEY_getservbyname 93
-#define KEY_getservbyport 94
-#define KEY_getservent 95
-#define KEY_getsockname 96
-#define KEY_getsockopt 97
-#define KEY_glob 98
-#define KEY_gmtime 99
-#define KEY_goto 100
-#define KEY_grep 101
-#define KEY_gt 102
-#define KEY_hex 103
-#define KEY_if 104
-#define KEY_index 105
-#define KEY_int 106
-#define KEY_ioctl 107
-#define KEY_join 108
-#define KEY_keys 109
-#define KEY_kill 110
-#define KEY_last 111
-#define KEY_lc 112
-#define KEY_lcfirst 113
-#define KEY_le 114
-#define KEY_length 115
-#define KEY_link 116
-#define KEY_listen 117
-#define KEY_local 118
-#define KEY_localtime 119
-#define KEY_log 120
-#define KEY_lstat 121
-#define KEY_lt 122
-#define KEY_m 123
-#define KEY_map 124
-#define KEY_mkdir 125
-#define KEY_msgctl 126
-#define KEY_msgget 127
-#define KEY_msgrcv 128
-#define KEY_msgsnd 129
-#define KEY_my 130
-#define KEY_ne 131
-#define KEY_next 132
-#define KEY_no 133
-#define KEY_not 134
-#define KEY_oct 135
-#define KEY_open 136
-#define KEY_opendir 137
-#define KEY_or 138
-#define KEY_ord 139
-#define KEY_pack 140
-#define KEY_package 141
-#define KEY_pipe 142
-#define KEY_pop 143
-#define KEY_pos 144
-#define KEY_print 145
-#define KEY_printf 146
-#define KEY_prototype 147
-#define KEY_push 148
-#define KEY_q 149
-#define KEY_qq 150
-#define KEY_quotemeta 151
-#define KEY_qw 152
-#define KEY_qx 153
-#define KEY_rand 154
-#define KEY_read 155
-#define KEY_readdir 156
-#define KEY_readline 157
-#define KEY_readlink 158
-#define KEY_readpipe 159
-#define KEY_recv 160
-#define KEY_redo 161
-#define KEY_ref 162
-#define KEY_rename 163
-#define KEY_require 164
-#define KEY_reset 165
-#define KEY_return 166
-#define KEY_reverse 167
-#define KEY_rewinddir 168
-#define KEY_rindex 169
-#define KEY_rmdir 170
-#define KEY_s 171
-#define KEY_scalar 172
-#define KEY_seek 173
-#define KEY_seekdir 174
-#define KEY_select 175
-#define KEY_semctl 176
-#define KEY_semget 177
-#define KEY_semop 178
-#define KEY_send 179
-#define KEY_setgrent 180
-#define KEY_sethostent 181
-#define KEY_setnetent 182
-#define KEY_setpgrp 183
-#define KEY_setpriority 184
-#define KEY_setprotoent 185
-#define KEY_setpwent 186
-#define KEY_setservent 187
-#define KEY_setsockopt 188
-#define KEY_shift 189
-#define KEY_shmctl 190
-#define KEY_shmget 191
-#define KEY_shmread 192
-#define KEY_shmwrite 193
-#define KEY_shutdown 194
-#define KEY_sin 195
-#define KEY_sleep 196
-#define KEY_socket 197
-#define KEY_socketpair 198
-#define KEY_sort 199
-#define KEY_splice 200
-#define KEY_split 201
-#define KEY_sprintf 202
-#define KEY_sqrt 203
-#define KEY_srand 204
-#define KEY_stat 205
-#define KEY_study 206
-#define KEY_sub 207
-#define KEY_substr 208
-#define KEY_symlink 209
-#define KEY_syscall 210
-#define KEY_sysopen 211
-#define KEY_sysread 212
-#define KEY_sysseek 213
-#define KEY_system 214
-#define KEY_syswrite 215
-#define KEY_tell 216
-#define KEY_telldir 217
-#define KEY_tie 218
-#define KEY_tied 219
-#define KEY_time 220
-#define KEY_times 221
-#define KEY_tr 222
-#define KEY_truncate 223
-#define KEY_uc 224
-#define KEY_ucfirst 225
-#define KEY_umask 226
-#define KEY_undef 227
-#define KEY_unless 228
-#define KEY_unlink 229
-#define KEY_unpack 230
-#define KEY_unshift 231
-#define KEY_untie 232
-#define KEY_until 233
-#define KEY_use 234
-#define KEY_utime 235
-#define KEY_values 236
-#define KEY_vec 237
-#define KEY_wait 238
-#define KEY_waitpid 239
-#define KEY_wantarray 240
-#define KEY_warn 241
-#define KEY_while 242
-#define KEY_write 243
-#define KEY_x 244
-#define KEY_xor 245
-#define KEY_y 246
+#define KEY_INIT 14
+#define KEY_LE 15
+#define KEY_LT 16
+#define KEY_NE 17
+#define KEY_abs 18
+#define KEY_accept 19
+#define KEY_alarm 20
+#define KEY_and 21
+#define KEY_atan2 22
+#define KEY_bind 23
+#define KEY_binmode 24
+#define KEY_bless 25
+#define KEY_caller 26
+#define KEY_chdir 27
+#define KEY_chmod 28
+#define KEY_chomp 29
+#define KEY_chop 30
+#define KEY_chown 31
+#define KEY_chr 32
+#define KEY_chroot 33
+#define KEY_close 34
+#define KEY_closedir 35
+#define KEY_cmp 36
+#define KEY_connect 37
+#define KEY_continue 38
+#define KEY_cos 39
+#define KEY_crypt 40
+#define KEY_dbmclose 41
+#define KEY_dbmopen 42
+#define KEY_defined 43
+#define KEY_delete 44
+#define KEY_die 45
+#define KEY_do 46
+#define KEY_dump 47
+#define KEY_each 48
+#define KEY_else 49
+#define KEY_elsif 50
+#define KEY_endgrent 51
+#define KEY_endhostent 52
+#define KEY_endnetent 53
+#define KEY_endprotoent 54
+#define KEY_endpwent 55
+#define KEY_endservent 56
+#define KEY_eof 57
+#define KEY_eq 58
+#define KEY_eval 59
+#define KEY_exec 60
+#define KEY_exists 61
+#define KEY_exit 62
+#define KEY_exp 63
+#define KEY_fcntl 64
+#define KEY_fileno 65
+#define KEY_flock 66
+#define KEY_for 67
+#define KEY_foreach 68
+#define KEY_fork 69
+#define KEY_format 70
+#define KEY_formline 71
+#define KEY_ge 72
+#define KEY_getc 73
+#define KEY_getgrent 74
+#define KEY_getgrgid 75
+#define KEY_getgrnam 76
+#define KEY_gethostbyaddr 77
+#define KEY_gethostbyname 78
+#define KEY_gethostent 79
+#define KEY_getlogin 80
+#define KEY_getnetbyaddr 81
+#define KEY_getnetbyname 82
+#define KEY_getnetent 83
+#define KEY_getpeername 84
+#define KEY_getpgrp 85
+#define KEY_getppid 86
+#define KEY_getpriority 87
+#define KEY_getprotobyname 88
+#define KEY_getprotobynumber 89
+#define KEY_getprotoent 90
+#define KEY_getpwent 91
+#define KEY_getpwnam 92
+#define KEY_getpwuid 93
+#define KEY_getservbyname 94
+#define KEY_getservbyport 95
+#define KEY_getservent 96
+#define KEY_getsockname 97
+#define KEY_getsockopt 98
+#define KEY_glob 99
+#define KEY_gmtime 100
+#define KEY_goto 101
+#define KEY_grep 102
+#define KEY_gt 103
+#define KEY_hex 104
+#define KEY_if 105
+#define KEY_index 106
+#define KEY_int 107
+#define KEY_ioctl 108
+#define KEY_join 109
+#define KEY_keys 110
+#define KEY_kill 111
+#define KEY_last 112
+#define KEY_lc 113
+#define KEY_lcfirst 114
+#define KEY_le 115
+#define KEY_length 116
+#define KEY_link 117
+#define KEY_listen 118
+#define KEY_local 119
+#define KEY_localtime 120
+#define KEY_lock 121
+#define KEY_log 122
+#define KEY_lstat 123
+#define KEY_lt 124
+#define KEY_m 125
+#define KEY_map 126
+#define KEY_mkdir 127
+#define KEY_msgctl 128
+#define KEY_msgget 129
+#define KEY_msgrcv 130
+#define KEY_msgsnd 131
+#define KEY_my 132
+#define KEY_ne 133
+#define KEY_next 134
+#define KEY_no 135
+#define KEY_not 136
+#define KEY_oct 137
+#define KEY_open 138
+#define KEY_opendir 139
+#define KEY_or 140
+#define KEY_ord 141
+#define KEY_pack 142
+#define KEY_package 143
+#define KEY_pipe 144
+#define KEY_pop 145
+#define KEY_pos 146
+#define KEY_print 147
+#define KEY_printf 148
+#define KEY_prototype 149
+#define KEY_push 150
+#define KEY_q 151
+#define KEY_qq 152
+#define KEY_quotemeta 153
+#define KEY_qw 154
+#define KEY_qx 155
+#define KEY_rand 156
+#define KEY_read 157
+#define KEY_readdir 158
+#define KEY_readline 159
+#define KEY_readlink 160
+#define KEY_readpipe 161
+#define KEY_recv 162
+#define KEY_redo 163
+#define KEY_ref 164
+#define KEY_rename 165
+#define KEY_require 166
+#define KEY_reset 167
+#define KEY_return 168
+#define KEY_reverse 169
+#define KEY_rewinddir 170
+#define KEY_rindex 171
+#define KEY_rmdir 172
+#define KEY_s 173
+#define KEY_scalar 174
+#define KEY_seek 175
+#define KEY_seekdir 176
+#define KEY_select 177
+#define KEY_semctl 178
+#define KEY_semget 179
+#define KEY_semop 180
+#define KEY_send 181
+#define KEY_setgrent 182
+#define KEY_sethostent 183
+#define KEY_setnetent 184
+#define KEY_setpgrp 185
+#define KEY_setpriority 186
+#define KEY_setprotoent 187
+#define KEY_setpwent 188
+#define KEY_setservent 189
+#define KEY_setsockopt 190
+#define KEY_shift 191
+#define KEY_shmctl 192
+#define KEY_shmget 193
+#define KEY_shmread 194
+#define KEY_shmwrite 195
+#define KEY_shutdown 196
+#define KEY_sin 197
+#define KEY_sleep 198
+#define KEY_socket 199
+#define KEY_socketpair 200
+#define KEY_sort 201
+#define KEY_splice 202
+#define KEY_split 203
+#define KEY_sprintf 204
+#define KEY_sqrt 205
+#define KEY_srand 206
+#define KEY_stat 207
+#define KEY_study 208
+#define KEY_sub 209
+#define KEY_substr 210
+#define KEY_symlink 211
+#define KEY_syscall 212
+#define KEY_sysopen 213
+#define KEY_sysread 214
+#define KEY_sysseek 215
+#define KEY_system 216
+#define KEY_syswrite 217
+#define KEY_tell 218
+#define KEY_telldir 219
+#define KEY_tie 220
+#define KEY_tied 221
+#define KEY_time 222
+#define KEY_times 223
+#define KEY_tr 224
+#define KEY_truncate 225
+#define KEY_uc 226
+#define KEY_ucfirst 227
+#define KEY_umask 228
+#define KEY_undef 229
+#define KEY_unless 230
+#define KEY_unlink 231
+#define KEY_unpack 232
+#define KEY_unshift 233
+#define KEY_untie 234
+#define KEY_until 235
+#define KEY_use 236
+#define KEY_utime 237
+#define KEY_values 238
+#define KEY_vec 239
+#define KEY_wait 240
+#define KEY_waitpid 241
+#define KEY_wantarray 242
+#define KEY_warn 243
+#define KEY_while 244
+#define KEY_write 245
+#define KEY_x 246
+#define KEY_xor 247
+#define KEY_y 248
EQ
GE
GT
+INIT
LE
LT
NE
listen
local
localtime
+lock
log
lstat
lt
--- /dev/null
+package Class::Fields;
+use Carp;
+
+sub import {
+ my $class = shift;
+ my ($package) = caller;
+ my $fields = \%{"$package\::FIELDS"};
+ my $i = $fields->{__MAX__};
+ foreach my $f (@_) {
+ if (defined($fields->{$f})) {
+ croak "Field name $f already used by a base class"
+ }
+ $fields->{$f} = ++$i;
+ }
+ $fields->{__MAX__} = $i;
+ push(@{"$package\::ISA"}, "Class::Fields");
+}
+
+sub new {
+ my $class = shift;
+ bless [\%{"$class\::FIELDS"}, @_], $class;
+}
+
+sub ISA {
+ my ($class, $package) = @_;
+ my $from_fields = \%{"$class\::FIELDS"};
+ my $to_fields = \%{"$package\::FIELDS"};
+ return unless defined %$from_fields;
+ croak "Ambiguous inheritance for %FIELDS" if defined %$to_fields;
+ %$to_fields = %$from_fields;
+}
+
+1;
--- /dev/null
+package ISA;
+use Carp;
+
+sub import {
+ my $class = shift;
+ my ($package) = caller;
+ foreach my $base (@_) {
+ croak qq(No such class "$base") unless defined %{"$base\::"};
+ eval {
+ $base->ISA($package);
+ };
+ if ($@ && $@ !~ /^Can't locate object method/) {
+ $@ =~ s/ at .*? line \d+\n$//;
+ croak $@;
+ }
+ }
+ push(@{"$package\::ISA"}, @_);
+}
+
+1;
#endif
#endif /* PERL_CORE */
+ MUTEX_LOCK(&malloc_mutex);
/*
* Convert amount of memory requested into
* closest block size stored in hash buckets
if (nextf[bucket] == NULL)
morecore(bucket);
if ((p = (union overhead *)nextf[bucket]) == NULL) {
+ MUTEX_UNLOCK(&malloc_mutex);
#ifdef PERL_CORE
if (!nomemok) {
PerlIO_puts(PerlIO_stderr(),"Out of memory!\n");
p->ov_rmagic = RMAGIC;
*((u_int *)((caddr_t)p + nbytes - RSLOP)) = RMAGIC;
#endif
+ MUTEX_UNLOCK(&malloc_mutex);
return ((Malloc_t)(p + CHUNK_SHIFT));
}
morecore(bucket)
register int bucket;
{
- register union overhead *op;
+ register union overhead *ovp;
register int rnu; /* 2^rnu bytes will be requested */
register int nblks; /* become nblks blocks of the desired size */
register MEM_SIZE siz, needed;
* make getpageize call?
*/
#ifndef atarist /* on the atari we dont have to worry about this */
- op = (union overhead *)sbrk(0);
+ ovp = (union overhead *)sbrk(0);
# ifndef I286
- if ((UV)op & (0x7FF >> CHUNK_SHIFT)) {
- slack = (0x800 >> CHUNK_SHIFT) - ((UV)op & (0x7FF >> CHUNK_SHIFT));
+ if ((UV)ovp & (0x7FF >> CHUNK_SHIFT)) {
+ slack = (0x800 >> CHUNK_SHIFT) - ((UV)ovp & (0x7FF >> CHUNK_SHIFT));
(void)sbrk(slack);
# if defined(DEBUGGING_MSTATS)
sbrk_slack += slack;
#ifdef TWO_POT_OPTIMIZE
needed += (bucket >= (FIRST_BIG_TWO_POT - 3) ? PERL_PAGESIZE : 0);
#endif
- op = (union overhead *)sbrk(needed);
+ ovp = (union overhead *)sbrk(needed);
/* no more room! */
- if (op == (union overhead *)-1) {
- op = (union overhead *)emergency_sbrk(needed);
- if (op == (union overhead *)-1)
+ if (ovp == (union overhead *)-1) {
+ ovp = (union overhead *)emergency_sbrk(needed);
+ if (ovp == (union overhead *)-1)
return;
}
#ifdef DEBUGGING_MSTATS
*/
#ifndef I286
# ifdef PACK_MALLOC
- if ((UV)op & 0x7FF)
+ if ((UV)ovp & 0x7FF)
croak("panic: Off-page sbrk");
# endif
- if ((UV)op & 7) {
- op = (union overhead *)(((UV)op + 8) & ~7);
+ if ((UV)ovp & 7) {
+ ovp = (union overhead *)(((UV)ovp + 8) & ~7);
nblks--;
}
#else
*/
siz = 1 << (bucket + 3);
#ifdef PACK_MALLOC
- *(u_char*)op = bucket; /* Fill index. */
+ *(u_char*)ovp = bucket; /* Fill index. */
if (bucket <= MAX_PACKED - 3) {
- op = (union overhead *) ((char*)op + blk_shift[bucket]);
+ ovp = (union overhead *) ((char*)ovp + blk_shift[bucket]);
nblks = n_blks[bucket];
# ifdef DEBUGGING_MSTATS
start_slack += blk_shift[bucket];
# endif
} else if (bucket <= 11 - 1 - 3) {
- op = (union overhead *) ((char*)op + blk_shift[bucket]);
+ ovp = (union overhead *) ((char*)ovp + blk_shift[bucket]);
/* nblks = n_blks[bucket]; */
siz -= sizeof(union overhead);
- } else op++; /* One chunk per block. */
+ } else ovp++; /* One chunk per block. */
#endif /* !PACK_MALLOC */
- nextf[bucket] = op;
+ nextf[bucket] = ovp;
#ifdef DEBUGGING_MSTATS
nmalloc[bucket] += nblks;
#endif
while (--nblks > 0) {
- op->ov_next = (union overhead *)((caddr_t)op + siz);
- op = (union overhead *)((caddr_t)op + siz);
+ ovp->ov_next = (union overhead *)((caddr_t)ovp + siz);
+ ovp = (union overhead *)((caddr_t)ovp + siz);
}
/* Not all sbrks return zeroed memory.*/
- op->ov_next = (union overhead *)NULL;
+ ovp->ov_next = (union overhead *)NULL;
#ifdef PACK_MALLOC
if (bucket == 7 - 3) { /* Special case, explanation is above. */
union overhead *n_op = nextf[7 - 3]->ov_next;
Malloc_t mp;
{
register MEM_SIZE size;
- register union overhead *op;
+ register union overhead *ovp;
char *cp = (char*)mp;
#ifdef PACK_MALLOC
u_char bucket;
if (cp == NULL)
return;
- op = (union overhead *)((caddr_t)cp
- - sizeof (union overhead) * CHUNK_SHIFT);
+ ovp = (union overhead *)((caddr_t)cp
+ - sizeof (union overhead) * CHUNK_SHIFT);
#ifdef PACK_MALLOC
- bucket = OV_INDEX(op);
+ bucket = OV_INDEX(ovp);
#endif
- if (OV_MAGIC(op, bucket) != MAGIC) {
+ if (OV_MAGIC(ovp, bucket) != MAGIC) {
static int bad_free_warn = -1;
if (bad_free_warn == -1) {
char *pbf = getenv("PERL_BADFREE");
return;
#ifdef RCHECK
warn("%s free() ignored",
- op->ov_rmagic == RMAGIC - 1 ? "Duplicate" : "Bad");
+ ovp->ov_rmagic == RMAGIC - 1 ? "Duplicate" : "Bad");
#else
warn("Bad free() ignored");
#endif
return; /* sanity */
}
+ MUTEX_LOCK(&malloc_mutex);
#ifdef RCHECK
- ASSERT(op->ov_rmagic == RMAGIC);
- if (OV_INDEX(op) <= MAX_SHORT_BUCKET)
- ASSERT(*(u_int *)((caddr_t)op + op->ov_size + 1 - RSLOP) == RMAGIC);
- op->ov_rmagic = RMAGIC - 1;
+ ASSERT(ovp->ov_rmagic == RMAGIC);
+ if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET)
+ ASSERT(*(u_int *)((caddr_t)ovp + ovp->ov_size + 1 - RSLOP) == RMAGIC);
+ ovp->ov_rmagic = RMAGIC - 1;
#endif
- ASSERT(OV_INDEX(op) < NBUCKETS);
- size = OV_INDEX(op);
- op->ov_next = nextf[size];
- nextf[size] = op;
+ ASSERT(OV_INDEX(ovp) < NBUCKETS);
+ size = OV_INDEX(ovp);
+ ovp->ov_next = nextf[size];
+ nextf[size] = ovp;
+ MUTEX_UNLOCK(&malloc_mutex);
}
/*
MEM_SIZE nbytes;
{
register MEM_SIZE onb;
- union overhead *op;
+ union overhead *ovp;
char *res;
register int i;
int was_alloced = 0;
#endif
#endif /* PERL_CORE */
- op = (union overhead *)((caddr_t)cp
- - sizeof (union overhead) * CHUNK_SHIFT);
- i = OV_INDEX(op);
- if (OV_MAGIC(op, i) == MAGIC) {
+ MUTEX_LOCK(&malloc_mutex);
+ ovp = (union overhead *)((caddr_t)cp
+ - sizeof (union overhead) * CHUNK_SHIFT);
+ i = OV_INDEX(ovp);
+ if (OV_MAGIC(ovp, i) == MAGIC) {
was_alloced = 1;
} else {
/*
* the memory block being realloc'd is the
* smallest possible.
*/
- if ((i = findbucket(op, 1)) < 0 &&
- (i = findbucket(op, reall_srchlen)) < 0)
+ if ((i = findbucket(ovp, 1)) < 0 &&
+ (i = findbucket(ovp, reall_srchlen)) < 0)
i = 0;
}
onb = (1L << (i + 3)) -
* Record new allocated size of block and
* bound space with magic numbers.
*/
- if (OV_INDEX(op) <= MAX_SHORT_BUCKET) {
+ if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) {
/*
* Convert amount of memory requested into
* closest block size stored in hash buckets
*/
nbytes += M_OVERHEAD;
nbytes = (nbytes + 3) &~ 3;
- op->ov_size = nbytes - 1;
- *((u_int *)((caddr_t)op + nbytes - RSLOP)) = RMAGIC;
+ ovp->ov_size = nbytes - 1;
+ *((u_int *)((caddr_t)ovp + nbytes - RSLOP)) = RMAGIC;
}
#endif
res = cp;
+ MUTEX_UNLOCK(&malloc_mutex);
}
else {
+ MUTEX_UNLOCK(&malloc_mutex);
if ((res = (char*)malloc(nbytes)) == NULL)
return (NULL);
if (cp != res) /* common optimization */
sv_setiv(sv, (IV)perldb);
break;
case '\023': /* ^S */
- if (lex_state != LEX_NOTPARSING)
- SvOK_off(sv);
- else if (in_eval)
- sv_setiv(sv, 1);
- else
- sv_setiv(sv, 0);
+ {
+ dTHR;
+ if (lex_state != LEX_NOTPARSING)
+ SvOK_off(sv);
+ else if (in_eval)
+ sv_setiv(sv, 1);
+ else
+ sv_setiv(sv, 0);
+ }
break;
case '\024': /* ^T */
#ifdef BIG_TIME
#endif
break;
case '?':
- sv_setiv(sv, (IV)STATUS_CURRENT);
+ {
+ dTHR;
+ sv_setiv(sv, (IV)STATUS_CURRENT);
#ifdef COMPLEX_STATUS
- LvTARGOFF(sv) = statusvalue;
- LvTARGLEN(sv) = statusvalue_vms;
+ LvTARGOFF(sv) = statusvalue;
+ LvTARGLEN(sv) = statusvalue_vms;
#endif
+ }
break;
case '^':
s = IoTOP_NAME(GvIOp(defoutgv));
case '/':
break;
case '[':
- sv_setiv(sv, (IV)curcop->cop_arybase);
+ WITH_THR(sv_setiv(sv, (IV)curcop->cop_arybase));
break;
case '|':
sv_setiv(sv, (IV)(IoFLAGS(GvIOp(defoutgv)) & IOf_FLUSH) != 0 );
char *strend = s + len;
while (s < strend) {
+ char tmpbuf[256];
struct stat st;
- s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf,
+ s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
s, strend, ':', &i);
s++;
- if (i >= sizeof tokenbuf /* too long -- assume the worst */
- || *tokenbuf != '/'
- || (Stat(tokenbuf, &st) == 0 && (st.st_mode & 2)) ) {
+ if (i >= sizeof tmpbuf /* too long -- assume the worst */
+ || *tmpbuf != '/'
+ || (Stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
MgTAINTEDDIR_on(mg);
return 0;
}
#if defined(VMS)
die("Can't make list assignment to %%ENV on this system");
#else
+ dTHR;
if (localizing) {
HE* entry;
magic_clear_all_env(sv,mg);
if(psig_ptr[i])
sv_setsv(sv,psig_ptr[i]);
else {
+ dTHR; /* just for SvREFCNT_inc */
Sighandler_t sigstate = rsignal_state(i);
/* cache state so we don't fetch it again */
SV* sv;
MAGIC* mg;
{
+ dTHR;
register char *s;
I32 i;
SV** svp;
}
if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
if (i)
- (void)rsignal(i, sighandler);
+ (void)rsignal(i, sighandlerp);
else
*svp = SvREFCNT_inc(sv);
return 0;
if (!strchr(s,':') && !strchr(s,'\''))
sv_setpv(sv, form("main::%s", s));
if (i)
- (void)rsignal(i, sighandler);
+ (void)rsignal(i, sighandlerp);
else
*svp = SvREFCNT_inc(sv);
}
MAGIC* mg;
char *meth;
{
+ dTHR;
dSP;
ENTER;
SV* sv;
MAGIC* mg;
{
+ dTHR;
dSP;
PUSHMARK(sp);
SV* sv;
MAGIC* mg;
{
+ dTHR;
dSP;
PUSHMARK(sp);
MAGIC* mg;
SV* key;
{
+ dTHR;
dSP;
char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
SV* sv;
MAGIC* mg;
{
+ dTHR;
OP *o;
I32 i;
GV* gv;
SV* sv;
MAGIC* mg;
{
+ dTHR;
sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + curcop->cop_arybase);
return 0;
}
SV* sv;
MAGIC* mg;
{
+ dTHR;
av_fill((AV*)mg->mg_obj, SvIV(sv) - curcop->cop_arybase);
return 0;
}
if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
mg = mg_find(lsv, 'g');
if (mg && mg->mg_len >= 0) {
+ dTHR;
sv_setiv(sv, mg->mg_len + curcop->cop_arybase);
return 0;
}
}
len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
- pos = SvIV(sv) - curcop->cop_arybase;
+ WITH_THR(pos = SvIV(sv) - curcop->cop_arybase);
if (pos < 0) {
pos += len;
if (pos < 0)
SV* sv;
MAGIC* mg;
{
+ dTHR;
if (localizing) {
if (localizing == 1)
mg->mg_len <<= 1;
targ = AvARRAY(av)[LvTARGOFF(sv)];
}
if (targ && targ != &sv_undef) {
+ dTHR; /* just for SvREFCNT_dec */
/* somebody else defined it for us */
SvREFCNT_dec(LvTARG(sv));
LvTARG(sv) = SvREFCNT_inc(targ);
vivify_defelem(sv)
SV* sv;
{
+ dTHR; /* just for SvREFCNT_inc and SvREFCNT_dec*/
MAGIC* mg;
SV* value;
SV* sv;
MAGIC* mg;
{
+ dTHR;
register char *s;
I32 i;
STRLEN len;
return 0;
}
+#ifdef USE_THREADS
+int
+magic_mutexfree(sv, mg)
+SV *sv;
+MAGIC *mg;
+{
+ dTHR;
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: magic_mutexfree 0x%lx\n",
+ (unsigned long)thr, (unsigned long)sv);)
+ if (MgOWNER(mg))
+ croak("panic: magic_mutexfree");
+ MUTEX_DESTROY(MgMUTEXP(mg));
+ COND_DESTROY(MgCONDP(mg));
+ return 0;
+}
+#endif /* USE_THREADS */
+
I32
whichsig(sig)
char *sig;
unwind_handler_stack(p)
void *p;
{
+ dTHR;
U32 flags = *(U32*)p;
if (flags & 1)
sighandler(sig)
int sig;
{
+ dTHR;
dSP;
GV *gv;
HV *st;
#include "EXTERN.h"
#include "perl.h"
-#define USE_OP_MASK /* Turned on by default in 5.002beta1h */
-
-#ifdef USE_OP_MASK
/*
- * In the following definition, the ", (OP *) op" is just to make the compiler
+ * In the following definition, the ", Nullop" is just to make the compiler
* think the expression is of the right type: croak actually does a Siglongjmp.
*/
-#define CHECKOP(type,op) \
+#define CHECKOP(type,o) \
((op_mask && op_mask[type]) \
- ? ( op_free((OP*)op), \
+ ? ( op_free((OP*)o), \
croak("%s trapped by operation mask", op_desc[type]), \
Nullop ) \
- : (*check[type])((OP*)op))
-#else
-#define CHECKOP(type,op) (*check[type])(op)
-#endif /* USE_OP_MASK */
-
-static I32 list_assignment _((OP *op));
-static OP *bad_type _((I32 n, char *t, char *name, OP *kid));
-static OP *modkids _((OP *op, I32 type));
-static OP *no_fh_allowed _((OP *op));
-static bool scalar_mod_type _((OP *op, I32 type));
-static OP *scalarboolean _((OP *op));
-static OP *too_few_arguments _((OP *op, char* name));
-static OP *too_many_arguments _((OP *op, char* name));
-static void null _((OP* op));
+ : (*check[type])((OP*)o))
+
+static I32 list_assignment _((OP *o));
+static void bad_type _((I32 n, char *t, char *name, OP *kid));
+static OP *modkids _((OP *o, I32 type));
+static OP *no_fh_allowed _((OP *o));
+static bool scalar_mod_type _((OP *o, I32 type));
+static OP *scalarboolean _((OP *o));
+static OP *too_few_arguments _((OP *o, char* name));
+static OP *too_many_arguments _((OP *o, char* name));
+static void null _((OP* o));
static PADOFFSET pad_findlex _((char* name, PADOFFSET newoff, U32 seq,
CV* startcv, I32 cx_ix));
}
static OP *
-no_fh_allowed(op)
-OP *op;
+no_fh_allowed(o)
+OP *o;
{
yyerror(form("Missing comma after first argument to %s function",
- op_desc[op->op_type]));
- return op;
+ op_desc[o->op_type]));
+ return o;
}
static OP *
-too_few_arguments(op, name)
-OP* op;
+too_few_arguments(o, name)
+OP* o;
char* name;
{
yyerror(form("Not enough arguments for %s", name));
- return op;
+ return o;
}
static OP *
-too_many_arguments(op, name)
-OP *op;
+too_many_arguments(o, name)
+OP *o;
char* name;
{
yyerror(form("Too many arguments for %s", name));
- return op;
+ return o;
}
-static OP *
+static void
bad_type(n, t, name, kid)
I32 n;
char *t;
{
yyerror(form("Type of arg %d to %s must be %s (not %s)",
(int)n, name, t, op_desc[kid->op_type]));
- return op;
}
void
-assertref(op)
-OP *op;
+assertref(o)
+OP *o;
{
- int type = op->op_type;
+ int type = o->op_type;
if (type != OP_AELEM && type != OP_HELEM) {
yyerror(form("Can't use subscript on %s", op_desc[type]));
if (type == OP_ENTERSUB || type == OP_RV2HV || type == OP_PADHV)
pad_allocmy(name)
char *name;
{
+ dTHR;
PADOFFSET off;
SV *sv;
sv = NEWSV(1102,0);
sv_upgrade(sv, SVt_PVNV);
sv_setpv(sv, name);
+ if (in_my_stash) {
+ if (*name != '$')
+ croak("Can't declare class for non-scalar %s in \"my\"",name);
+ SvOBJECT_on(sv);
+ (void)SvUPGRADE(sv, SVt_PVMG);
+ SvSTASH(sv) = (HV*)SvREFCNT_inc(in_my_stash);
+ sv_objcount++;
+ }
av_store(comppad_name, off, sv);
SvNVX(sv) = (double)999999999;
SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix)
#endif
{
+ dTHR;
CV *cv;
I32 off;
SV *sv;
pad_findmy(name)
char *name;
{
+ dTHR;
I32 off;
I32 pendoff = 0;
SV *sv;
SV **svp = AvARRAY(comppad_name);
U32 seq = cop_seqmax;
+#ifdef USE_THREADS
+ /*
+ * Special case to get lexical (and hence per-thread) @_.
+ * XXX I need to find out how to tell at parse-time whether use
+ * of @_ should refer to a lexical (from a sub) or defgv (global
+ * scope and maybe weird sub-ish things like formats). See
+ * startsub in perly.y. It's possible that @_ could be lexical
+ * (at least from subs) even in non-threaded perl.
+ */
+ if (strEQ(name, "@_"))
+ return 0; /* success. (NOT_IN_PAD indicates failure) */
+#endif /* USE_THREADS */
+
/* The one we're looking for is probably just before comppad_name_fill. */
for (off = AvFILL(comppad_name); off > 0; off--) {
if ((sv = svp[off]) &&
/* If there is a pending local definition, this new alias must die */
if (pendoff)
SvIVX(AvARRAY(comppad_name)[off]) = seq;
- return off;
+ return off; /* pad_findlex returns 0 for failure...*/
}
-
- return 0;
+ return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
}
void
I32 optype;
U32 tmptype;
{
+ dTHR;
SV *sv;
I32 retval;
}
SvFLAGS(sv) |= tmptype;
curpad = AvARRAY(comppad);
- DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad alloc %ld for %s\n", (long) retval, op_name[optype]));
+#ifdef USE_THREADS
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx alloc %ld for %s\n",
+ (unsigned long) thr, (unsigned long) curpad,
+ (long) retval, op_name[optype]));
+#else
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad alloc %ld for %s\n",
+ (long) retval, op_name[optype]));
+#endif /* USE_THREADS */
return (PADOFFSET)retval;
}
pad_sv(PADOFFSET po)
#endif /* CAN_PROTOTYPE */
{
+ dTHR;
+#ifdef USE_THREADS
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx sv %d\n",
+ (unsigned long) thr, (unsigned long) curpad, po));
+#else
if (!po)
croak("panic: pad_sv po");
- DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad sv %lu\n", (unsigned long)po));
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad sv %d\n", po));
+#endif /* USE_THREADS */
return curpad[po]; /* eventually we'll turn this into a macro */
}
pad_free(PADOFFSET po)
#endif /* CAN_PROTOTYPE */
{
+ dTHR;
if (!curpad)
return;
if (AvARRAY(comppad) != curpad)
croak("panic: pad_free curpad");
if (!po)
croak("panic: pad_free po");
- DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad free %lu\n", (unsigned long)po));
- if (curpad[po] && !SvIMMORTAL(curpad[po]))
+#ifdef USE_THREADS
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx free %d\n",
+ (unsigned long) thr, (unsigned long) curpad, po));
+#else
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad free %d\n", po));
+#endif /* USE_THREADS */
+ if (curpad[po] && curpad[po] != &sv_undef)
SvPADTMP_off(curpad[po]);
if ((I32)po < padix)
padix = po - 1;
pad_swipe(PADOFFSET po)
#endif /* CAN_PROTOTYPE */
{
+ dTHR;
if (AvARRAY(comppad) != curpad)
croak("panic: pad_swipe curpad");
if (!po)
croak("panic: pad_swipe po");
- DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad swipe %lu\n", (unsigned long)po));
+#ifdef USE_THREADS
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx swipe %d\n",
+ (unsigned long) thr, (unsigned long) curpad, po));
+#else
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad swipe %d\n", po));
+#endif /* USE_THREADS */
SvPADTMP_off(curpad[po]);
curpad[po] = NEWSV(1107,0);
SvPADTMP_on(curpad[po]);
void
pad_reset()
{
+ dTHR;
register I32 po;
if (AvARRAY(comppad) != curpad)
croak("panic: pad_reset curpad");
+#ifdef USE_THREADS
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx reset\n",
+ (unsigned long) thr, (unsigned long) curpad));
+#else
DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad reset\n"));
+#endif /* USE_THREADS */
if (!tainting) { /* Can't mix tainted and non-tainted temporaries. */
for (po = AvMAX(comppad); po > padix_floor; po--) {
if (curpad[po] && !SvIMMORTAL(curpad[po]))
/* Destructor */
void
-op_free(op)
-OP *op;
+op_free(o)
+OP *o;
{
register OP *kid, *nextkid;
- if (!op || op->op_seq == (U16)-1)
+ if (!o || o->op_seq == (U16)-1)
return;
- if (op->op_flags & OPf_KIDS) {
- for (kid = cUNOP->op_first; kid; kid = nextkid) {
+ if (o->op_flags & OPf_KIDS) {
+ for (kid = cUNOPo->op_first; kid; kid = nextkid) {
nextkid = kid->op_sibling; /* Get before next freeing kid */
op_free(kid);
}
}
- switch (op->op_type) {
+ switch (o->op_type) {
case OP_NULL:
- op->op_targ = 0; /* Was holding old type, if any. */
+ o->op_targ = 0; /* Was holding old type, if any. */
break;
case OP_ENTEREVAL:
- op->op_targ = 0; /* Was holding hints. */
+ o->op_targ = 0; /* Was holding hints. */
break;
default:
- if (!(op->op_flags & OPf_REF) || (check[op->op_type] != ck_ftst))
+ if (!(o->op_flags & OPf_REF) || (check[o->op_type] != ck_ftst))
break;
/* FALL THROUGH */
case OP_GVSV:
case OP_GV:
case OP_AELEMFAST:
- SvREFCNT_dec(cGVOP->op_gv);
+ SvREFCNT_dec(cGVOPo->op_gv);
break;
case OP_NEXTSTATE:
case OP_DBSTATE:
- Safefree(cCOP->cop_label);
- SvREFCNT_dec(cCOP->cop_filegv);
+ Safefree(cCOPo->cop_label);
+ SvREFCNT_dec(cCOPo->cop_filegv);
break;
case OP_CONST:
- SvREFCNT_dec(cSVOP->op_sv);
+ SvREFCNT_dec(cSVOPo->op_sv);
break;
case OP_GOTO:
case OP_NEXT:
case OP_LAST:
case OP_REDO:
- if (op->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
+ if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
break;
/* FALL THROUGH */
case OP_TRANS:
- Safefree(cPVOP->op_pv);
+ Safefree(cPVOPo->op_pv);
break;
case OP_SUBST:
- op_free(cPMOP->op_pmreplroot);
+ op_free(cPMOPo->op_pmreplroot);
/* FALL THROUGH */
case OP_PUSHRE:
case OP_MATCH:
- pregfree(cPMOP->op_pmregexp);
- SvREFCNT_dec(cPMOP->op_pmshort);
+ pregfree(cPMOPo->op_pmregexp);
+ SvREFCNT_dec(cPMOPo->op_pmshort);
break;
}
- if (op->op_targ > 0)
- pad_free(op->op_targ);
+ if (o->op_targ > 0)
+ pad_free(o->op_targ);
- Safefree(op);
+ Safefree(o);
}
static void
-null(op)
-OP* op;
+null(o)
+OP* o;
{
- if (op->op_type != OP_NULL && op->op_targ > 0)
- pad_free(op->op_targ);
- op->op_targ = op->op_type;
- op->op_type = OP_NULL;
- op->op_ppaddr = ppaddr[OP_NULL];
+ if (o->op_type != OP_NULL && o->op_targ > 0)
+ pad_free(o->op_targ);
+ o->op_targ = o->op_type;
+ o->op_type = OP_NULL;
+ o->op_ppaddr = ppaddr[OP_NULL];
}
/* Contextualizers */
#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
OP *
-linklist(op)
-OP *op;
+linklist(o)
+OP *o;
{
register OP *kid;
- if (op->op_next)
- return op->op_next;
+ if (o->op_next)
+ return o->op_next;
/* establish postfix order */
- if (cUNOP->op_first) {
- op->op_next = LINKLIST(cUNOP->op_first);
- for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) {
+ if (cUNOPo->op_first) {
+ o->op_next = LINKLIST(cUNOPo->op_first);
+ for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
if (kid->op_sibling)
kid->op_next = LINKLIST(kid->op_sibling);
else
- kid->op_next = op;
+ kid->op_next = o;
}
}
else
- op->op_next = op;
+ o->op_next = o;
- return op->op_next;
+ return o->op_next;
}
OP *
-scalarkids(op)
-OP *op;
+scalarkids(o)
+OP *o;
{
OP *kid;
- if (op && op->op_flags & OPf_KIDS) {
- for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling)
+ if (o && o->op_flags & OPf_KIDS) {
+ for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
scalar(kid);
}
- return op;
+ return o;
}
static OP *
-scalarboolean(op)
-OP *op;
+scalarboolean(o)
+OP *o;
{
if (dowarn &&
- op->op_type == OP_SASSIGN && cBINOP->op_first->op_type == OP_CONST) {
+ o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
+ dTHR;
line_t oldline = curcop->cop_line;
if (copline != NOLINE)
warn("Found = in conditional, should be ==");
curcop->cop_line = oldline;
}
- return scalar(op);
+ return scalar(o);
}
OP *
-scalar(op)
-OP *op;
+scalar(o)
+OP *o;
{
OP *kid;
/* assumes no premature commitment */
- if (!op || (op->op_flags & OPf_WANT) || error_count
- || op->op_type == OP_RETURN)
- return op;
+ if (!o || (o->op_flags & OPf_WANT) || error_count
+ || o->op_type == OP_RETURN)
+ return o;
- op->op_flags = (op->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
+ o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
- switch (op->op_type) {
+ switch (o->op_type) {
case OP_REPEAT:
- if (op->op_private & OPpREPEAT_DOLIST)
- null(((LISTOP*)cBINOP->op_first)->op_first);
- scalar(cBINOP->op_first);
+ if (o->op_private & OPpREPEAT_DOLIST)
+ null(((LISTOP*)cBINOPo->op_first)->op_first);
+ scalar(cBINOPo->op_first);
break;
case OP_OR:
case OP_AND:
case OP_COND_EXPR:
- for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling)
+ for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
scalar(kid);
break;
case OP_SPLIT:
- if ((kid = ((LISTOP*)op)->op_first) && kid->op_type == OP_PUSHRE) {
+ if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
if (!kPMOP->op_pmreplroot)
deprecate("implicit split to @_");
}
case OP_SUBST:
case OP_NULL:
default:
- if (op->op_flags & OPf_KIDS) {
- for (kid = cUNOP->op_first; kid; kid = kid->op_sibling)
+ if (o->op_flags & OPf_KIDS) {
+ for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
scalar(kid);
}
break;
case OP_LEAVE:
case OP_LEAVETRY:
- kid = cLISTOP->op_first;
+ kid = cLISTOPo->op_first;
scalar(kid);
while (kid = kid->op_sibling) {
if (kid->op_sibling)
else
scalar(kid);
}
- curcop = &compiling;
+ WITH_THR(curcop = &compiling);
break;
case OP_SCOPE:
case OP_LINESEQ:
case OP_LIST:
- for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) {
+ for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
if (kid->op_sibling)
scalarvoid(kid);
else
scalar(kid);
}
- curcop = &compiling;
+ WITH_THR(curcop = &compiling);
break;
}
- return op;
+ return o;
}
OP *
-scalarvoid(op)
-OP *op;
+scalarvoid(o)
+OP *o;
{
OP *kid;
char* useless = 0;
SV* sv;
/* assumes no premature commitment */
- if (!op || (op->op_flags & OPf_WANT) == OPf_WANT_LIST || error_count
- || op->op_type == OP_RETURN)
- return op;
+ if (!o || (o->op_flags & OPf_WANT) == OPf_WANT_LIST || error_count
+ || o->op_type == OP_RETURN)
+ return o;
- op->op_flags = (op->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
+ o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
- switch (op->op_type) {
+ switch (o->op_type) {
default:
- if (!(opargs[op->op_type] & OA_FOLDCONST))
+ if (!(opargs[o->op_type] & OA_FOLDCONST))
break;
/* FALL THROUGH */
case OP_REPEAT:
- if (op->op_flags & OPf_STACKED)
+ if (o->op_flags & OPf_STACKED)
break;
/* FALL THROUGH */
case OP_GVSV:
case OP_GGRNAM:
case OP_GGRGID:
case OP_GETLOGIN:
- if (!(op->op_private & OPpLVAL_INTRO))
- useless = op_desc[op->op_type];
+ if (!(o->op_private & OPpLVAL_INTRO))
+ useless = op_desc[o->op_type];
break;
case OP_RV2GV:
case OP_RV2SV:
case OP_RV2AV:
case OP_RV2HV:
- if (!(op->op_private & OPpLVAL_INTRO) &&
- (!op->op_sibling || op->op_sibling->op_type != OP_READLINE))
+ if (!(o->op_private & OPpLVAL_INTRO) &&
+ (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
useless = "a variable";
break;
case OP_NEXTSTATE:
case OP_DBSTATE:
- curcop = ((COP*)op); /* for warning below */
+ WITH_THR(curcop = ((COP*)o)); /* for warning below */
break;
case OP_CONST:
- sv = cSVOP->op_sv;
+ sv = cSVOPo->op_sv;
if (dowarn) {
useless = "a constant";
if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
useless = 0;
}
}
- null(op); /* don't execute a constant */
+ null(o); /* don't execute a constant */
SvREFCNT_dec(sv); /* don't even remember it */
break;
case OP_POSTINC:
- op->op_type = OP_PREINC; /* pre-increment is faster */
- op->op_ppaddr = ppaddr[OP_PREINC];
+ o->op_type = OP_PREINC; /* pre-increment is faster */
+ o->op_ppaddr = ppaddr[OP_PREINC];
break;
case OP_POSTDEC:
- op->op_type = OP_PREDEC; /* pre-decrement is faster */
- op->op_ppaddr = ppaddr[OP_PREDEC];
+ o->op_type = OP_PREDEC; /* pre-decrement is faster */
+ o->op_ppaddr = ppaddr[OP_PREDEC];
break;
case OP_OR:
case OP_AND:
case OP_COND_EXPR:
- for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling)
+ for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
scalarvoid(kid);
break;
case OP_NULL:
- if (op->op_targ == OP_NEXTSTATE || op->op_targ == OP_DBSTATE)
- curcop = ((COP*)op); /* for warning below */
- if (op->op_flags & OPf_STACKED)
+ if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
+ WITH_THR(curcop = ((COP*)o)); /* for warning below */
+ if (o->op_flags & OPf_STACKED)
break;
/* FALL THROUGH */
case OP_ENTERTRY:
case OP_ENTER:
case OP_SCALAR:
- if (!(op->op_flags & OPf_KIDS))
+ if (!(o->op_flags & OPf_KIDS))
break;
/* FALL THROUGH */
case OP_SCOPE:
case OP_LEAVELOOP:
case OP_LINESEQ:
case OP_LIST:
- for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling)
+ for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
scalarvoid(kid);
break;
case OP_ENTEREVAL:
- scalarkids(op);
+ scalarkids(o);
break;
case OP_REQUIRE:
/* all requires must return a boolean value */
- op->op_flags &= ~OPf_WANT;
- return scalar(op);
+ o->op_flags &= ~OPf_WANT;
+ return scalar(o);
case OP_SPLIT:
- if ((kid = ((LISTOP*)op)->op_first) && kid->op_type == OP_PUSHRE) {
+ if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
if (!kPMOP->op_pmreplroot)
deprecate("implicit split to @_");
}
}
if (useless && dowarn)
warn("Useless use of %s in void context", useless);
- return op;
+ return o;
}
OP *
-listkids(op)
-OP *op;
+listkids(o)
+OP *o;
{
OP *kid;
- if (op && op->op_flags & OPf_KIDS) {
- for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling)
+ if (o && o->op_flags & OPf_KIDS) {
+ for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
list(kid);
}
- return op;
+ return o;
}
OP *
-list(op)
-OP *op;
+list(o)
+OP *o;
{
OP *kid;
/* assumes no premature commitment */
- if (!op || (op->op_flags & OPf_WANT) || error_count
- || op->op_type == OP_RETURN)
- return op;
+ if (!o || (o->op_flags & OPf_WANT) || error_count
+ || o->op_type == OP_RETURN)
+ return o;
- op->op_flags = (op->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
+ o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
- switch (op->op_type) {
+ switch (o->op_type) {
case OP_FLOP:
case OP_REPEAT:
- list(cBINOP->op_first);
+ list(cBINOPo->op_first);
break;
case OP_OR:
case OP_AND:
case OP_COND_EXPR:
- for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling)
+ for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
list(kid);
break;
default:
case OP_MATCH:
case OP_SUBST:
case OP_NULL:
- if (!(op->op_flags & OPf_KIDS))
+ if (!(o->op_flags & OPf_KIDS))
break;
- if (!op->op_next && cUNOP->op_first->op_type == OP_FLOP) {
- list(cBINOP->op_first);
- return gen_constant_list(op);
+ if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
+ list(cBINOPo->op_first);
+ return gen_constant_list(o);
}
case OP_LIST:
- listkids(op);
+ listkids(o);
break;
case OP_LEAVE:
case OP_LEAVETRY:
- kid = cLISTOP->op_first;
+ kid = cLISTOPo->op_first;
list(kid);
while (kid = kid->op_sibling) {
if (kid->op_sibling)
else
list(kid);
}
- curcop = &compiling;
+ WITH_THR(curcop = &compiling);
break;
case OP_SCOPE:
case OP_LINESEQ:
- for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) {
+ for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
if (kid->op_sibling)
scalarvoid(kid);
else
list(kid);
}
- curcop = &compiling;
+ WITH_THR(curcop = &compiling);
break;
case OP_REQUIRE:
/* all requires must return a boolean value */
- op->op_flags &= ~OPf_WANT;
- return scalar(op);
+ o->op_flags &= ~OPf_WANT;
+ return scalar(o);
}
- return op;
+ return o;
}
OP *
-scalarseq(op)
-OP *op;
+scalarseq(o)
+OP *o;
{
OP *kid;
- if (op) {
- if (op->op_type == OP_LINESEQ ||
- op->op_type == OP_SCOPE ||
- op->op_type == OP_LEAVE ||
- op->op_type == OP_LEAVETRY)
+ if (o) {
+ if (o->op_type == OP_LINESEQ ||
+ o->op_type == OP_SCOPE ||
+ o->op_type == OP_LEAVE ||
+ o->op_type == OP_LEAVETRY)
{
- for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) {
+ dTHR;
+ for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
if (kid->op_sibling) {
scalarvoid(kid);
}
}
curcop = &compiling;
}
- op->op_flags &= ~OPf_PARENS;
+ o->op_flags &= ~OPf_PARENS;
if (hints & HINT_BLOCK_SCOPE)
- op->op_flags |= OPf_PARENS;
+ o->op_flags |= OPf_PARENS;
}
else
- op = newOP(OP_STUB, 0);
- return op;
+ o = newOP(OP_STUB, 0);
+ return o;
}
static OP *
-modkids(op, type)
-OP *op;
+modkids(o, type)
+OP *o;
I32 type;
{
OP *kid;
- if (op && op->op_flags & OPf_KIDS) {
- for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling)
+ if (o && o->op_flags & OPf_KIDS) {
+ for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
mod(kid, type);
}
- return op;
+ return o;
}
static I32 modcount;
OP *
-mod(op, type)
-OP *op;
+mod(o, type)
+OP *o;
I32 type;
{
+ dTHR;
OP *kid;
SV *sv;
- if (!op || error_count)
- return op;
+ if (!o || error_count)
+ return o;
- switch (op->op_type) {
+ switch (o->op_type) {
case OP_UNDEF:
modcount++;
- return op;
+ return o;
case OP_CONST:
- if (!(op->op_private & (OPpCONST_ARYBASE)))
+ if (!(o->op_private & (OPpCONST_ARYBASE)))
goto nomod;
if (eval_start && eval_start->op_type == OP_CONST) {
compiling.cop_arybase = (I32)SvIV(((SVOP*)eval_start)->op_sv);
croak("That use of $[ is unsupported");
break;
case OP_STUB:
- if (op->op_flags & OPf_PARENS)
+ if (o->op_flags & OPf_PARENS)
break;
goto nomod;
case OP_ENTERSUB:
if ((type == OP_UNDEF || type == OP_REFGEN) &&
- !(op->op_flags & OPf_STACKED)) {
- op->op_type = OP_RV2CV; /* entersub => rv2cv */
- op->op_ppaddr = ppaddr[OP_RV2CV];
- assert(cUNOP->op_first->op_type == OP_NULL);
- null(((LISTOP*)cUNOP->op_first)->op_first); /* disable pushmark */
+ !(o->op_flags & OPf_STACKED)) {
+ o->op_type = OP_RV2CV; /* entersub => rv2cv */
+ o->op_ppaddr = ppaddr[OP_RV2CV];
+ assert(cUNOPo->op_first->op_type == OP_NULL);
+ null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
break;
}
/* FALL THROUGH */
if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
break;
yyerror(form("Can't modify %s in %s",
- op_desc[op->op_type],
+ op_desc[o->op_type],
type ? op_desc[type] : "local"));
- return op;
+ return o;
case OP_PREINC:
case OP_PREDEC:
case OP_I_MODULO:
case OP_I_ADD:
case OP_I_SUBTRACT:
- if (!(op->op_flags & OPf_STACKED))
+ if (!(o->op_flags & OPf_STACKED))
goto nomod;
modcount++;
break;
case OP_COND_EXPR:
- for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling)
+ for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
mod(kid, type);
break;
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:
- if (scalar_mod_type(op, type))
+ if (scalar_mod_type(o, type))
goto nomod;
- ref(cUNOP->op_first, op->op_type);
+ ref(cUNOPo->op_first, o->op_type);
/* FALL THROUGH */
case OP_AASSIGN:
case OP_ASLICE:
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 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:
case OP_PADAV:
case OP_PADHV:
modcount = 10000;
- if (type == OP_REFGEN && op->op_flags & OPf_PARENS)
- return op; /* Treat \(@foo) like ordinary list. */
- if (scalar_mod_type(op, type))
+ if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
+ return o; /* Treat \(@foo) like ordinary list. */
+ if (scalar_mod_type(o, type))
goto nomod;
/* FALL THROUGH */
case OP_PADSV:
modcount++;
if (!type)
croak("Can't localize lexical variable %s",
- SvPV(*av_fetch(comppad_name, op->op_targ, 4), na));
+ SvPV(*av_fetch(comppad_name, o->op_targ, 4), na));
break;
case OP_PUSHMARK:
case OP_POS:
case OP_VEC:
case OP_SUBSTR:
- pad_free(op->op_targ);
- op->op_targ = pad_alloc(op->op_type, SVs_PADMY);
- assert(SvTYPE(PAD_SV(op->op_targ)) == SVt_NULL);
- if (op->op_flags & OPf_KIDS)
- mod(cBINOP->op_first->op_sibling, type);
+ pad_free(o->op_targ);
+ o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
+ assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
+ if (o->op_flags & OPf_KIDS)
+ mod(cBINOPo->op_first->op_sibling, type);
break;
case OP_AELEM:
case OP_HELEM:
- ref(cBINOP->op_first, op->op_type);
+ ref(cBINOPo->op_first, o->op_type);
if (type == OP_ENTERSUB &&
- !(op->op_private & (OPpLVAL_INTRO | OPpDEREF)))
- op->op_private |= OPpLVAL_DEFER;
+ !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
+ o->op_private |= OPpLVAL_DEFER;
modcount++;
break;
case OP_SCOPE:
case OP_LEAVE:
case OP_ENTER:
- if (op->op_flags & OPf_KIDS)
- mod(cLISTOP->op_last, type);
+ if (o->op_flags & OPf_KIDS)
+ mod(cLISTOPo->op_last, type);
break;
case OP_NULL:
- if (!(op->op_flags & OPf_KIDS))
+ if (!(o->op_flags & OPf_KIDS))
break;
- if (op->op_targ != OP_LIST) {
- mod(cBINOP->op_first, type);
+ if (o->op_targ != OP_LIST) {
+ mod(cBINOPo->op_first, type);
break;
}
/* FALL THROUGH */
case OP_LIST:
- for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling)
+ for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
mod(kid, type);
break;
}
- op->op_flags |= OPf_MOD;
+ o->op_flags |= OPf_MOD;
if (type == OP_AASSIGN || type == OP_SASSIGN)
- op->op_flags |= OPf_SPECIAL|OPf_REF;
+ o->op_flags |= OPf_SPECIAL|OPf_REF;
else if (!type) {
- op->op_private |= OPpLVAL_INTRO;
- op->op_flags &= ~OPf_SPECIAL;
+ o->op_private |= OPpLVAL_INTRO;
+ o->op_flags &= ~OPf_SPECIAL;
}
else if (type != OP_GREPSTART && type != OP_ENTERSUB)
- op->op_flags |= OPf_REF;
- return op;
+ o->op_flags |= OPf_REF;
+ return o;
}
static bool
-scalar_mod_type(op, type)
-OP *op;
+scalar_mod_type(o, type)
+OP *o;
I32 type;
{
switch (type) {
case OP_SASSIGN:
- if (op->op_type == OP_RV2GV)
+ if (o->op_type == OP_RV2GV)
return FALSE;
/* FALL THROUGH */
case OP_PREINC:
}
OP *
-refkids(op, type)
-OP *op;
+refkids(o, type)
+OP *o;
I32 type;
{
OP *kid;
- if (op && op->op_flags & OPf_KIDS) {
- for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling)
+ if (o && o->op_flags & OPf_KIDS) {
+ for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
ref(kid, type);
}
- return op;
+ return o;
}
OP *
-ref(op, type)
-OP *op;
+ref(o, type)
+OP *o;
I32 type;
{
OP *kid;
- if (!op || error_count)
- return op;
+ if (!o || error_count)
+ return o;
- switch (op->op_type) {
+ switch (o->op_type) {
case OP_ENTERSUB:
if ((type == OP_DEFINED) &&
- !(op->op_flags & OPf_STACKED)) {
- op->op_type = OP_RV2CV; /* entersub => rv2cv */
- op->op_ppaddr = ppaddr[OP_RV2CV];
- assert(cUNOP->op_first->op_type == OP_NULL);
- null(((LISTOP*)cUNOP->op_first)->op_first); /* disable pushmark */
- op->op_flags |= OPf_SPECIAL;
+ !(o->op_flags & OPf_STACKED)) {
+ o->op_type = OP_RV2CV; /* entersub => rv2cv */
+ o->op_ppaddr = ppaddr[OP_RV2CV];
+ assert(cUNOPo->op_first->op_type == OP_NULL);
+ null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
+ o->op_flags |= OPf_SPECIAL;
}
break;
case OP_COND_EXPR:
- for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling)
+ for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
ref(kid, type);
break;
case OP_RV2SV:
- ref(cUNOP->op_first, op->op_type);
+ ref(cUNOPo->op_first, o->op_type);
/* FALL THROUGH */
case OP_PADSV:
if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
- op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
- : type == OP_RV2HV ? OPpDEREF_HV
- : OPpDEREF_SV);
- op->op_flags |= OPf_MOD;
+ o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
+ : type == OP_RV2HV ? OPpDEREF_HV
+ : OPpDEREF_SV);
+ o->op_flags |= OPf_MOD;
}
break;
case OP_RV2AV:
case OP_RV2HV:
- op->op_flags |= OPf_REF;
+ o->op_flags |= OPf_REF;
/* FALL THROUGH */
case OP_RV2GV:
- ref(cUNOP->op_first, op->op_type);
+ ref(cUNOPo->op_first, o->op_type);
break;
case OP_PADAV:
case OP_PADHV:
- op->op_flags |= OPf_REF;
+ o->op_flags |= OPf_REF;
break;
case OP_SCALAR:
case OP_NULL:
- if (!(op->op_flags & OPf_KIDS))
+ if (!(o->op_flags & OPf_KIDS))
break;
- ref(cBINOP->op_first, type);
+ ref(cBINOPo->op_first, type);
break;
case OP_AELEM:
case OP_HELEM:
- ref(cBINOP->op_first, op->op_type);
+ ref(cBINOPo->op_first, o->op_type);
if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
- op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
- : type == OP_RV2HV ? OPpDEREF_HV
- : OPpDEREF_SV);
- op->op_flags |= OPf_MOD;
+ o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
+ : type == OP_RV2HV ? OPpDEREF_HV
+ : OPpDEREF_SV);
+ o->op_flags |= OPf_MOD;
}
break;
case OP_LEAVE:
case OP_ENTER:
case OP_LIST:
- if (!(op->op_flags & OPf_KIDS))
+ if (!(o->op_flags & OPf_KIDS))
break;
- ref(cLISTOP->op_last, type);
+ ref(cLISTOPo->op_last, type);
break;
default:
break;
}
- return scalar(op);
+ return scalar(o);
}
OP *
-my(op)
-OP *op;
+my(o)
+OP *o;
{
OP *kid;
I32 type;
- if (!op || error_count)
- return op;
+ if (!o || error_count)
+ return o;
- type = op->op_type;
+ type = o->op_type;
if (type == OP_LIST) {
- for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling)
+ for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
my(kid);
}
else if (type != OP_PADSV &&
type != OP_PADHV &&
type != OP_PUSHMARK)
{
- yyerror(form("Can't declare %s in my", op_desc[op->op_type]));
- return op;
+ yyerror(form("Can't declare %s in my", op_desc[o->op_type]));
+ return o;
}
- op->op_flags |= OPf_MOD;
- op->op_private |= OPpLVAL_INTRO;
- return op;
+ o->op_flags |= OPf_MOD;
+ o->op_private |= OPpLVAL_INTRO;
+ return o;
}
OP *
OP *left;
OP *right;
{
- OP *op;
+ OP *o;
if (dowarn &&
(left->op_type == OP_RV2AV ||
if (right->op_type != OP_MATCH)
left = mod(left, right->op_type);
if (right->op_type == OP_TRANS)
- op = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
+ o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
else
- op = prepend_elem(right->op_type, scalar(left), right);
+ o = prepend_elem(right->op_type, scalar(left), right);
if (type == OP_NOT)
- return newUNOP(OP_NOT, 0, scalar(op));
- return op;
+ return newUNOP(OP_NOT, 0, scalar(o));
+ return o;
}
else
return bind_match(type, left,
}
OP *
-invert(op)
-OP *op;
+invert(o)
+OP *o;
{
- if (!op)
- return op;
+ if (!o)
+ return o;
/* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
- return newUNOP(OP_NOT, OPf_SPECIAL, scalar(op));
+ return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
}
OP *
block_start(full)
int full;
{
+ dTHR;
int retval = savestack_ix;
SAVEI32(comppad_name_floor);
if (full) {
I32 floor;
OP* seq;
{
+ dTHR;
int needblockscope = hints & HINT_BLOCK_SCOPE;
OP* retval = scalarseq(seq);
LEAVE_SCOPE(floor);
}
void
-newPROG(op)
-OP *op;
+newPROG(o)
+OP *o;
{
+ dTHR;
if (in_eval) {
- eval_root = newUNOP(OP_LEAVEEVAL, ((in_eval & 4) ? OPf_SPECIAL : 0), op);
+ eval_root = newUNOP(OP_LEAVEEVAL, ((in_eval & 4) ? OPf_SPECIAL : 0), o);
eval_start = linklist(eval_root);
eval_root->op_next = 0;
peep(eval_start);
}
else {
- if (!op)
+ if (!o)
return;
- main_root = scope(sawparens(scalarvoid(op)));
+ main_root = scope(sawparens(scalarvoid(o)));
curcop = &compiling;
main_start = LINKLIST(main_root);
main_root->op_next = 0;
}
}
in_my = FALSE;
+ in_my_stash = Nullhv;
if (lex)
return my(o);
else
fold_constants(o)
register OP *o;
{
+ dTHR;
register OP *curop;
I32 type = o->op_type;
SV *sv;
gen_constant_list(o)
register OP *o;
{
+ dTHR;
register OP *curop;
I32 oldtmps_floor = tmps_floor;
op = curop = LINKLIST(o);
o->op_next = 0;
- pp_pushmark();
+ pp_pushmark(ARGS);
runops();
op = curop;
- pp_anonlist();
+ pp_anonlist(ARGS);
tmps_floor = oldtmps_floor;
o->op_type = OP_RV2AV;
}
OP *
-convert(type, flags, op)
+convert(type, flags, o)
I32 type;
I32 flags;
-OP* op;
+OP* o;
{
OP *kid;
OP *last = 0;
- if (!op || op->op_type != OP_LIST)
- op = newLISTOP(OP_LIST, 0, op, Nullop);
+ if (!o || o->op_type != OP_LIST)
+ o = newLISTOP(OP_LIST, 0, o, Nullop);
else
- op->op_flags &= ~OPf_WANT;
+ o->op_flags &= ~OPf_WANT;
if (!(opargs[type] & OA_MARK))
- null(cLISTOP->op_first);
+ null(cLISTOPo->op_first);
- op->op_type = type;
- op->op_ppaddr = ppaddr[type];
- op->op_flags |= flags;
+ o->op_type = type;
+ o->op_ppaddr = ppaddr[type];
+ o->op_flags |= flags;
- op = CHECKOP(type, op);
- if (op->op_type != type)
- return op;
+ o = CHECKOP(type, o);
+ if (o->op_type != type)
+ return o;
- if (cLISTOP->op_children < 7) {
+ if (cLISTOPo->op_children < 7) {
/* XXX do we really need to do this if we're done appending?? */
- for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling)
+ for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
last = kid;
- cLISTOP->op_last = last; /* in case check substituted last arg */
+ cLISTOPo->op_last = last; /* in case check substituted last arg */
}
- return fold_constants(op);
+ return fold_constants(o);
}
/* List constructors */
}
OP *
-force_list(op)
-OP* op;
+force_list(o)
+OP *o;
{
- if (!op || op->op_type != OP_LIST)
- op = newLISTOP(OP_LIST, 0, op, Nullop);
- null(op);
- return op;
+ if (!o || o->op_type != OP_LIST)
+ o = newLISTOP(OP_LIST, 0, o, Nullop);
+ null(o);
+ return o;
}
OP *
I32 type;
I32 flags;
{
- OP *op;
- Newz(1101, op, 1, OP);
- op->op_type = type;
- op->op_ppaddr = ppaddr[type];
- op->op_flags = flags;
+ OP *o;
+ Newz(1101, o, 1, OP);
+ o->op_type = type;
+ o->op_ppaddr = ppaddr[type];
+ o->op_flags = flags;
- op->op_next = op;
- op->op_private = 0 + (flags >> 8);
+ o->op_next = o;
+ o->op_private = 0 + (flags >> 8);
if (opargs[type] & OA_RETSCALAR)
- scalar(op);
+ scalar(o);
if (opargs[type] & OA_TARGET)
- op->op_targ = pad_alloc(type, SVs_PADTMP);
- return CHECKOP(type, op);
+ o->op_targ = pad_alloc(type, SVs_PADTMP);
+ return CHECKOP(type, o);
}
OP *
}
OP *
-pmtrans(op, expr, repl)
-OP *op;
+pmtrans(o, expr, repl)
+OP *o;
OP *expr;
OP *repl;
{
I32 complement;
register short *tbl;
- tbl = (short*)cPVOP->op_pv;
- complement = op->op_private & OPpTRANS_COMPLEMENT;
- delete = op->op_private & OPpTRANS_DELETE;
- /* squash = op->op_private & OPpTRANS_SQUASH; */
+ tbl = (short*)cPVOPo->op_pv;
+ complement = o->op_private & OPpTRANS_COMPLEMENT;
+ delete = o->op_private & OPpTRANS_DELETE;
+ /* squash = o->op_private & OPpTRANS_SQUASH; */
if (complement) {
Zero(tbl, 256, short);
op_free(expr);
op_free(repl);
- return op;
+ return o;
}
OP *
I32 type;
I32 flags;
{
+ dTHR;
PMOP *pmop;
Newz(1101, pmop, 1, PMOP);
}
OP *
-pmruntime(op, expr, repl)
-OP *op;
+pmruntime(o, expr, repl)
+OP *o;
OP *expr;
OP *repl;
{
PMOP *pm;
LOGOP *rcop;
- if (op->op_type == OP_TRANS)
- return pmtrans(op, expr, repl);
+ if (o->op_type == OP_TRANS)
+ return pmtrans(o, expr, repl);
hints |= HINT_BLOCK_SCOPE;
- pm = (PMOP*)op;
+ pm = (PMOP*)o;
if (expr->op_type == OP_CONST) {
STRLEN plen;
SV *pat = ((SVOP*)expr)->op_sv;
char *p = SvPV(pat, plen);
- if ((op->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
+ if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
sv_setpvn(pat, "\\s+", 3);
p = SvPV(pat, plen);
pm->op_pmflags |= PMf_SKIPWHITE;
rcop->op_first = scalar(expr);
rcop->op_flags |= OPf_KIDS;
rcop->op_private = 1;
- rcop->op_other = op;
+ rcop->op_other = o;
/* establish postfix order */
if (pm->op_pmflags & PMf_KEEP) {
expr->op_next = (OP*)rcop;
}
- prepend_elem(op->op_type, scalar((OP*)rcop), op);
+ prepend_elem(o->op_type, scalar((OP*)rcop), o);
}
if (repl) {
if (curop == repl) {
pm->op_pmflags |= PMf_CONST; /* const for long enough */
pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
- prepend_elem(op->op_type, scalar(repl), op);
+ prepend_elem(o->op_type, scalar(repl), o);
}
else {
Newz(1101, rcop, 1, LOGOP);
rcop->op_first = scalar(repl);
rcop->op_flags |= OPf_KIDS;
rcop->op_private = 1;
- rcop->op_other = op;
+ rcop->op_other = o;
/* establish postfix order */
rcop->op_next = LINKLIST(repl);
I32 flags;
GV *gv;
{
+ dTHR;
GVOP *gvop;
Newz(1101, gvop, 1, GVOP);
gvop->op_type = type;
}
void
-package(op)
-OP *op;
+package(o)
+OP *o;
{
+ dTHR;
SV *sv;
save_hptr(&curstash);
save_item(curstname);
- if (op) {
+ if (o) {
STRLEN len;
char *name;
- sv = cSVOP->op_sv;
+ sv = cSVOPo->op_sv;
name = SvPV(sv, len);
curstash = gv_stashpvn(name,len,TRUE);
sv_setpvn(curstname, name, len);
- op_free(op);
+ op_free(o);
}
else {
sv_setpv(curstname,"<none>");
}
static I32
-list_assignment(op)
-register OP *op;
+list_assignment(o)
+register OP *o;
{
- if (!op)
+ if (!o)
return TRUE;
- if (op->op_type == OP_NULL && op->op_flags & OPf_KIDS)
- op = cUNOP->op_first;
+ if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
+ o = cUNOPo->op_first;
- if (op->op_type == OP_COND_EXPR) {
- I32 t = list_assignment(cCONDOP->op_first->op_sibling);
- I32 f = list_assignment(cCONDOP->op_first->op_sibling->op_sibling);
+ if (o->op_type == OP_COND_EXPR) {
+ I32 t = list_assignment(cCONDOPo->op_first->op_sibling);
+ I32 f = list_assignment(cCONDOPo->op_first->op_sibling->op_sibling);
if (t && f)
return TRUE;
return FALSE;
}
- if (op->op_type == OP_LIST || op->op_flags & OPf_PARENS ||
- op->op_type == OP_RV2AV || op->op_type == OP_RV2HV ||
- op->op_type == OP_ASLICE || op->op_type == OP_HSLICE)
+ if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
+ o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
+ o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
return TRUE;
- if (op->op_type == OP_PADAV || op->op_type == OP_PADHV)
+ if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
return TRUE;
- if (op->op_type == OP_RV2SV)
+ if (o->op_type == OP_RV2SV)
return FALSE;
return FALSE;
I32 optype;
OP *right;
{
- OP *op;
+ OP *o;
if (optype) {
if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
op_free(right);
return Nullop;
}
- op = newBINOP(OP_AASSIGN, flags,
+ o = newBINOP(OP_AASSIGN, flags,
list(force_list(right)),
list(force_list(left)) );
- op->op_private = 0 | (flags >> 8);
+ o->op_private = 0 | (flags >> 8);
if (!(left->op_private & OPpLVAL_INTRO)) {
static int generation = 100;
OP *curop;
- OP *lastop = op;
+ OP *lastop = o;
generation++;
- for (curop = LINKLIST(op); curop != op; curop = LINKLIST(curop)) {
+ for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
if (opargs[curop->op_type] & OA_DANGEROUS) {
if (curop->op_type == OP_GV) {
GV *gv = ((GVOP*)curop)->op_gv;
}
lastop = curop;
}
- if (curop != op)
- op->op_private = OPpASSIGN_COMMON;
+ if (curop != o)
+ o->op_private = OPpASSIGN_COMMON;
}
if (right && right->op_type == OP_SPLIT) {
OP* tmpop;
PMOP *pm = (PMOP*)tmpop;
if (left->op_type == OP_RV2AV &&
!(left->op_private & OPpLVAL_INTRO) &&
- !(op->op_private & OPpASSIGN_COMMON) )
+ !(o->op_private & OPpASSIGN_COMMON) )
{
tmpop = ((UNOP*)left)->op_first;
if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
pm->op_pmreplroot = (OP*)((GVOP*)tmpop)->op_gv;
pm->op_pmflags |= PMf_ONCE;
- tmpop = ((UNOP*)op)->op_first; /* to list (nulled) */
+ tmpop = cUNOPo->op_first; /* to list (nulled) */
tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
tmpop->op_sibling = Nullop; /* don't free split */
right->op_next = tmpop->op_next; /* fix starting loc */
- op_free(op); /* blow off assign */
+ op_free(o); /* blow off assign */
right->op_flags &= ~OPf_WANT;
/* "I don't know and I don't care." */
return right;
}
}
}
- return op;
+ return o;
}
if (!right)
right = newOP(OP_UNDEF, 0);
}
else {
eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
- op = newBINOP(OP_SASSIGN, flags,
+ o = newBINOP(OP_SASSIGN, flags,
scalar(right), mod(scalar(left), OP_SASSIGN) );
if (eval_start)
eval_start = 0;
else {
- op_free(op);
+ op_free(o);
return Nullop;
}
}
- return op;
+ return o;
}
OP *
-newSTATEOP(flags, label, op)
+newSTATEOP(flags, label, o)
I32 flags;
char *label;
-OP *op;
+OP *o;
{
+ dTHR;
U32 seq = intro_my();
register COP *cop;
}
}
- return prepend_elem(OP_LINESEQ, (OP*)cop, op);
+ return prepend_elem(OP_LINESEQ, (OP*)cop, o);
}
/* "Introduce" my variables to visible status. */
OP* first;
OP* other;
{
+ dTHR;
LOGOP *logop;
- OP *op;
+ OP *o;
if (type == OP_XOR) /* Not short circuit, but here by precedence. */
return newBINOP(type, flags, scalar(first), scalar(other));
type = OP_OR;
else
type = OP_AND;
- op = first;
- first = cUNOP->op_first;
- if (op->op_next)
- first->op_next = op->op_next;
- cUNOP->op_first = Nullop;
- op_free(op);
+ o = first;
+ first = cUNOPo->op_first;
+ if (o->op_next)
+ first->op_next = o->op_next;
+ cUNOPo->op_first = Nullop;
+ op_free(o);
}
}
if (first->op_type == OP_CONST) {
first->op_next = (OP*)logop;
first->op_sibling = other;
- op = newUNOP(OP_NULL, 0, (OP*)logop);
- other->op_next = op;
+ o = newUNOP(OP_NULL, 0, (OP*)logop);
+ other->op_next = o;
- return op;
+ return o;
}
OP *
OP* trueop;
OP* falseop;
{
+ dTHR;
CONDOP *condop;
- OP *op;
+ OP *o;
if (!falseop)
return newLOGOP(OP_AND, 0, first, trueop);
first->op_sibling = trueop;
trueop->op_sibling = falseop;
- op = newUNOP(OP_NULL, 0, (OP*)condop);
+ o = newUNOP(OP_NULL, 0, (OP*)condop);
- trueop->op_next = op;
- falseop->op_next = op;
+ trueop->op_next = o;
+ falseop->op_next = o;
- return op;
+ return o;
}
OP *
OP *left;
OP *right;
{
+ dTHR;
CONDOP *condop;
OP *flip;
OP *flop;
- OP *op;
+ OP *o;
Newz(1101, condop, 1, CONDOP);
condop->op_next = (OP*)condop;
flip = newUNOP(OP_FLIP, flags, (OP*)condop);
flop = newUNOP(OP_FLOP, 0, flip);
- op = newUNOP(OP_NULL, 0, flop);
+ o = newUNOP(OP_NULL, 0, flop);
linklist(flop);
left->op_next = flip;
flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
- flip->op_next = op;
+ flip->op_next = o;
if (!flip->op_private || !flop->op_private)
- linklist(op); /* blow off optimizer unless constant */
+ linklist(o); /* blow off optimizer unless constant */
- return op;
+ return o;
}
OP *
OP *expr;
OP *block;
{
+ dTHR;
OP* listop;
- OP* op;
+ OP* o;
int once = block && block->op_flags & OPf_SPECIAL &&
(block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
}
listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
- op = newLOGOP(OP_AND, 0, expr, listop);
+ o = newLOGOP(OP_AND, 0, expr, listop);
- ((LISTOP*)listop)->op_last->op_next = LINKLIST(op);
+ ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
- if (once && op != listop)
- op->op_next = ((LOGOP*)cUNOP->op_first)->op_other;
+ if (once && o != listop)
+ o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
- if (op == listop)
- op = newUNOP(OP_NULL, 0, op); /* or do {} while 1 loses outer block */
+ if (o == listop)
+ o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
- op->op_flags |= flags;
- op = scope(op);
- op->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
- return op;
+ o->op_flags |= flags;
+ o = scope(o);
+ o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
+ return o;
}
OP *
OP *block;
OP *cont;
{
+ dTHR;
OP *redo;
OP *next = 0;
OP *listop;
- OP *op;
+ OP *o;
OP *condop;
if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
redo = LINKLIST(listop);
if (expr) {
- op = newLOGOP(OP_AND, 0, expr, scalar(listop));
- if (op == expr && op->op_type == OP_CONST && !SvTRUE(cSVOP->op_sv)) {
+ o = newLOGOP(OP_AND, 0, expr, scalar(listop));
+ if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
op_free(expr); /* oops, it's a while (0) */
op_free((OP*)loop);
return Nullop; /* (listop already freed by newLOGOP) */
}
((LISTOP*)listop)->op_last->op_next = condop =
- (op == listop ? redo : LINKLIST(op));
+ (o == listop ? redo : LINKLIST(o));
if (!next)
next = condop;
}
else
- op = listop;
+ o = listop;
if (!loop) {
Newz(1101,loop,1,LOOP);
loop->op_next = (OP*)loop;
}
- op = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, op);
+ o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
loop->op_redoop = redo;
- loop->op_lastop = op;
+ loop->op_lastop = o;
if (next)
loop->op_nextop = next;
else
- loop->op_nextop = op;
+ loop->op_nextop = o;
- op->op_flags |= flags;
- op->op_private |= (flags >> 8);
- return op;
+ o->op_flags |= flags;
+ o->op_private |= (flags >> 8);
+ return o;
}
OP *
I32 type;
OP* label;
{
- OP *op;
+ dTHR;
+ OP *o;
if (type != OP_GOTO || label->op_type == OP_CONST) {
- op = newPVOP(type, 0, savepv(
+ o = newPVOP(type, 0, savepv(
label->op_type == OP_CONST
? SvPVx(((SVOP*)label)->op_sv, na)
: "" ));
else {
if (label->op_type == OP_ENTERSUB)
label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
- op = newUNOP(type, OPf_STACKED, label);
+ o = newUNOP(type, OPf_STACKED, label);
}
hints |= HINT_BLOCK_SCOPE;
- return op;
+ return o;
}
void
cv_undef(cv)
CV *cv;
{
+ dTHR;
+#ifdef USE_THREADS
+ if (CvMUTEXP(cv)) {
+ MUTEX_DESTROY(CvMUTEXP(cv));
+ Safefree(CvMUTEXP(cv));
+ CvMUTEXP(cv) = 0;
+ }
+#endif /* USE_THREADS */
+
if (!CvXSUB(cv) && CvROOT(cv)) {
+#ifdef USE_THREADS
+ if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
+ croak("Can't undef active subroutine");
+#else
if (CvDEPTH(cv))
croak("Can't undef active subroutine");
+#endif /* USE_THREADS */
ENTER;
SAVESPTR(curpad);
CV* proto;
CV* outside;
{
+ dTHR;
AV* av;
I32 ix;
AV* protopadlist = CvPADLIST(proto);
if (CvANON(proto))
CvANON_on(cv);
+#ifdef USE_THREADS
+ New(666, CvMUTEXP(cv), 1, perl_mutex);
+ MUTEX_INIT(CvMUTEXP(cv));
+ CvOWNER(cv) = 0;
+#endif /* USE_THREADS */
CvFILEGV(cv) = CvFILEGV(proto);
CvGV(cv) = (GV*)SvREFCNT_inc(CvGV(proto));
CvSTASH(cv) = CvSTASH(proto);
if (sv)
return Nullsv;
if (type == OP_CONST)
- sv = ((SVOP*)o)->op_sv;
+ sv = cSVOPo->op_sv;
else if (type == OP_PADSV) {
- AV* pad = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
- sv = pad ? AvARRAY(pad)[o->op_targ] : Nullsv;
+ AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
+ sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
if (!sv || (!SvREADONLY(sv) && SvREFCNT(sv) > 1))
return Nullsv;
}
}
CV *
-newSUB(floor,op,proto,block)
+newSUB(floor,o,proto,block)
I32 floor;
-OP *op;
+OP *o;
OP *proto;
OP *block;
{
- char *name = op ? SvPVx(cSVOP->op_sv, na) : Nullch;
+ dTHR;
+ char *name = o ? SvPVx(cSVOPo->op_sv, na) : Nullch;
GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, na) : Nullch;
register CV *cv;
I32 ix;
- if (op)
- SAVEFREEOP(op);
+ if (o)
+ SAVEFREEOP(o);
if (proto)
SAVEFREEOP(proto);
CvGV(cv) = (GV*)SvREFCNT_inc(gv);
CvFILEGV(cv) = curcop->cop_filegv;
CvSTASH(cv) = curstash;
+#ifdef USE_THREADS
+ CvOWNER(cv) = 0;
+ New(666, CvMUTEXP(cv), 1, perl_mutex);
+ MUTEX_INIT(CvMUTEXP(cv));
+#endif /* USE_THREADS */
if (ps)
sv_setpv((SV*)cv, ps);
av_store(endav, 0, (SV *)cv);
GvCV(gv) = 0;
}
+ else if (strEQ(s, "INIT") && !error_count) {
+ if (!initav)
+ initav = newAV();
+ av_push(initav, SvREFCNT_inc(cv));
+ }
}
done:
void (*subaddr) _((CV*));
char *filename;
{
+ dTHR;
GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
register CV *cv;
}
}
CvGV(cv) = (GV*)SvREFCNT_inc(gv);
+#ifdef USE_THREADS
+ New(666, CvMUTEXP(cv), 1, perl_mutex);
+ MUTEX_INIT(CvMUTEXP(cv));
+ CvOWNER(cv) = 0;
+#endif /* USE_THREADS */
CvFILEGV(cv) = gv_fetchfile(filename);
CvXSUB(cv) = subaddr;
av_store(endav, 0, (SV *)cv);
GvCV(gv) = 0;
}
+ else if (strEQ(s, "INIT")) {
+ if (!initav)
+ initav = newAV();
+ av_push(initav, (SV *)cv);
+ }
}
else
CvANON_on(cv);
}
void
-newFORM(floor,op,block)
+newFORM(floor,o,block)
I32 floor;
-OP *op;
+OP *o;
OP *block;
{
+ dTHR;
register CV *cv;
char *name;
GV *gv;
I32 ix;
- if (op)
- name = SvPVx(cSVOP->op_sv, na);
+ if (o)
+ name = SvPVx(cSVOPo->op_sv, na);
else
name = "STDOUT";
gv = gv_fetchpv(name,TRUE, SVt_PVFM);
CvSTART(cv) = LINKLIST(CvROOT(cv));
CvROOT(cv)->op_next = 0;
peep(CvSTART(cv));
- op_free(op);
+ op_free(o);
copline = NOLINE;
LEAVE_SCOPE(floor);
}
OP *
-newANONLIST(op)
-OP* op;
+newANONLIST(o)
+OP* o;
{
return newUNOP(OP_REFGEN, 0,
- mod(list(convert(OP_ANONLIST, 0, op)), OP_REFGEN));
+ mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
}
OP *
-newANONHASH(op)
-OP* op;
+newANONHASH(o)
+OP* o;
{
return newUNOP(OP_REFGEN, 0,
- mod(list(convert(OP_ANONHASH, 0, op)), OP_REFGEN));
+ mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
}
OP *
/* Check routines. */
OP *
-ck_anoncode(op)
-OP *op;
+ck_anoncode(o)
+OP *o;
{
PADOFFSET ix;
SV* name;
sv_setpvn(name, "&", 1);
SvIVX(name) = -1;
SvNVX(name) = 1;
- ix = pad_alloc(op->op_type, SVs_PADMY);
+ ix = pad_alloc(o->op_type, SVs_PADMY);
av_store(comppad_name, ix, name);
- av_store(comppad, ix, cSVOP->op_sv);
- SvPADMY_on(cSVOP->op_sv);
- cSVOP->op_sv = Nullsv;
- cSVOP->op_targ = ix;
- return op;
+ av_store(comppad, ix, cSVOPo->op_sv);
+ SvPADMY_on(cSVOPo->op_sv);
+ cSVOPo->op_sv = Nullsv;
+ cSVOPo->op_targ = ix;
+ return o;
}
OP *
-ck_bitop(op)
-OP *op;
+ck_bitop(o)
+OP *o;
{
- op->op_private = hints;
- return op;
+ o->op_private = hints;
+ return o;
}
OP *
-ck_concat(op)
-OP *op;
+ck_concat(o)
+OP *o;
{
- if (cUNOP->op_first->op_type == OP_CONCAT)
- op->op_flags |= OPf_STACKED;
- return op;
+ if (cUNOPo->op_first->op_type == OP_CONCAT)
+ o->op_flags |= OPf_STACKED;
+ return o;
}
OP *
-ck_spair(op)
-OP *op;
+ck_spair(o)
+OP *o;
{
- if (op->op_flags & OPf_KIDS) {
+ if (o->op_flags & OPf_KIDS) {
OP* newop;
OP* kid;
- OPCODE type = op->op_type;
- op = modkids(ck_fun(op), type);
- kid = cUNOP->op_first;
+ OPCODE type = o->op_type;
+ o = modkids(ck_fun(o), type);
+ kid = cUNOPo->op_first;
newop = kUNOP->op_first->op_sibling;
if (newop &&
(newop->op_sibling ||
newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
- return op;
+ return o;
}
op_free(kUNOP->op_first);
kUNOP->op_first = newop;
}
- op->op_ppaddr = ppaddr[++op->op_type];
- return ck_fun(op);
+ o->op_ppaddr = ppaddr[++o->op_type];
+ return ck_fun(o);
}
OP *
-ck_delete(op)
-OP *op;
+ck_delete(o)
+OP *o;
{
- op = ck_fun(op);
- op->op_private = 0;
- if (op->op_flags & OPf_KIDS) {
- OP *kid = cUNOP->op_first;
+ o = ck_fun(o);
+ o->op_private = 0;
+ if (o->op_flags & OPf_KIDS) {
+ OP *kid = cUNOPo->op_first;
if (kid->op_type == OP_HSLICE)
- op->op_private |= OPpSLICE;
+ o->op_private |= OPpSLICE;
else if (kid->op_type != OP_HELEM)
croak("%s argument is not a HASH element or slice",
- op_desc[op->op_type]);
+ op_desc[o->op_type]);
null(kid);
}
- return op;
+ return o;
}
OP *
-ck_eof(op)
-OP *op;
+ck_eof(o)
+OP *o;
{
- I32 type = op->op_type;
+ I32 type = o->op_type;
- if (op->op_flags & OPf_KIDS) {
- if (cLISTOP->op_first->op_type == OP_STUB) {
- op_free(op);
- op = newUNOP(type, OPf_SPECIAL,
- newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
+ if (o->op_flags & OPf_KIDS) {
+ if (cLISTOPo->op_first->op_type == OP_STUB) {
+ op_free(o);
+ o = newUNOP(type, OPf_SPECIAL,
+ newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
}
- return ck_fun(op);
+ return ck_fun(o);
}
- return op;
+ return o;
}
OP *
-ck_eval(op)
-OP *op;
+ck_eval(o)
+OP *o;
{
hints |= HINT_BLOCK_SCOPE;
- if (op->op_flags & OPf_KIDS) {
- SVOP *kid = (SVOP*)cUNOP->op_first;
+ if (o->op_flags & OPf_KIDS) {
+ SVOP *kid = (SVOP*)cUNOPo->op_first;
if (!kid) {
- op->op_flags &= ~OPf_KIDS;
- null(op);
+ o->op_flags &= ~OPf_KIDS;
+ null(o);
}
else if (kid->op_type == OP_LINESEQ) {
LOGOP *enter;
- kid->op_next = op->op_next;
- cUNOP->op_first = 0;
- op_free(op);
+ kid->op_next = o->op_next;
+ cUNOPo->op_first = 0;
+ op_free(o);
Newz(1101, enter, 1, LOGOP);
enter->op_type = OP_ENTERTRY;
/* establish postfix order */
enter->op_next = (OP*)enter;
- op = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
- op->op_type = OP_LEAVETRY;
- op->op_ppaddr = ppaddr[OP_LEAVETRY];
- enter->op_other = op;
- return op;
+ o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
+ o->op_type = OP_LEAVETRY;
+ o->op_ppaddr = ppaddr[OP_LEAVETRY];
+ enter->op_other = o;
+ return o;
}
}
else {
- op_free(op);
- op = newUNOP(OP_ENTEREVAL, 0, newSVREF(newGVOP(OP_GV, 0, defgv)));
+ op_free(o);
+ o = newUNOP(OP_ENTEREVAL, 0, newSVREF(newGVOP(OP_GV, 0, defgv)));
}
- op->op_targ = (PADOFFSET)hints;
- return op;
+ o->op_targ = (PADOFFSET)hints;
+ return o;
}
OP *
-ck_exec(op)
-OP *op;
+ck_exec(o)
+OP *o;
{
OP *kid;
- if (op->op_flags & OPf_STACKED) {
- op = ck_fun(op);
- kid = cUNOP->op_first->op_sibling;
+ if (o->op_flags & OPf_STACKED) {
+ o = ck_fun(o);
+ kid = cUNOPo->op_first->op_sibling;
if (kid->op_type == OP_RV2GV)
null(kid);
}
else
- op = listkids(op);
- return op;
+ o = listkids(o);
+ return o;
}
OP *
-ck_exists(op)
-OP *op;
+ck_exists(o)
+OP *o;
{
- op = ck_fun(op);
- if (op->op_flags & OPf_KIDS) {
- OP *kid = cUNOP->op_first;
+ o = ck_fun(o);
+ if (o->op_flags & OPf_KIDS) {
+ OP *kid = cUNOPo->op_first;
if (kid->op_type != OP_HELEM)
- croak("%s argument is not a HASH element", op_desc[op->op_type]);
+ croak("%s argument is not a HASH element", op_desc[o->op_type]);
null(kid);
}
- return op;
+ return o;
}
OP *
}
OP *
-ck_rvconst(op)
-register OP *op;
+ck_rvconst(o)
+register OP *o;
{
- SVOP *kid = (SVOP*)cUNOP->op_first;
+ dTHR;
+ SVOP *kid = (SVOP*)cUNOPo->op_first;
- op->op_private |= (hints & HINT_STRICT_REFS);
+ o->op_private |= (hints & HINT_STRICT_REFS);
if (kid->op_type == OP_CONST) {
char *name;
int iscv;
name = SvPV(kid->op_sv, na);
if ((hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
char *badthing = Nullch;
- switch (op->op_type) {
+ switch (o->op_type) {
case OP_RV2SV:
badthing = "a SCALAR";
break;
name, badthing);
}
kid->op_type = OP_GV;
- iscv = (op->op_type == OP_RV2CV) * 2;
+ iscv = (o->op_type == OP_RV2CV) * 2;
for (gv = 0; !gv; iscv++) {
/*
* This is a little tricky. We only want to add the symbol if we
iscv | !(kid->op_private & OPpCONST_ENTERED),
iscv
? SVt_PVCV
- : op->op_type == OP_RV2SV
+ : o->op_type == OP_RV2SV
? SVt_PV
- : op->op_type == OP_RV2AV
+ : o->op_type == OP_RV2AV
? SVt_PVAV
- : op->op_type == OP_RV2HV
+ : o->op_type == OP_RV2HV
? SVt_PVHV
: SVt_PVGV);
}
SvREFCNT_dec(kid->op_sv);
kid->op_sv = SvREFCNT_inc(gv);
}
- return op;
+ return o;
}
OP *
-ck_ftst(op)
-OP *op;
+ck_ftst(o)
+OP *o;
{
- I32 type = op->op_type;
+ dTHR;
+ I32 type = o->op_type;
- if (op->op_flags & OPf_REF)
- return op;
+ if (o->op_flags & OPf_REF)
+ return o;
- if (op->op_flags & OPf_KIDS) {
- SVOP *kid = (SVOP*)cUNOP->op_first;
+ if (o->op_flags & OPf_KIDS) {
+ SVOP *kid = (SVOP*)cUNOPo->op_first;
if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
OP *newop = newGVOP(type, OPf_REF,
gv_fetchpv(SvPVx(kid->op_sv, na), TRUE, SVt_PVIO));
- op_free(op);
+ op_free(o);
return newop;
}
}
else {
- op_free(op);
+ op_free(o);
if (type == OP_FTTTY)
return newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
SVt_PVIO));
else
return newUNOP(type, 0, newSVREF(newGVOP(OP_GV, 0, defgv)));
}
- return op;
+ return o;
}
OP *
-ck_fun(op)
-OP *op;
+ck_fun(o)
+OP *o;
{
+ dTHR;
register OP *kid;
OP **tokid;
OP *sibl;
I32 numargs = 0;
- int type = op->op_type;
+ int type = o->op_type;
register I32 oa = opargs[type] >> OASHIFT;
- if (op->op_flags & OPf_STACKED) {
+ if (o->op_flags & OPf_STACKED) {
if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
oa &= ~OA_OPTIONAL;
else
- return no_fh_allowed(op);
+ return no_fh_allowed(o);
}
- if (op->op_flags & OPf_KIDS) {
- tokid = &cLISTOP->op_first;
- kid = cLISTOP->op_first;
+ if (o->op_flags & OPf_KIDS) {
+ tokid = &cLISTOPo->op_first;
+ kid = cLISTOPo->op_first;
if (kid->op_type == OP_PUSHMARK ||
kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK)
{
*tokid = kid;
}
else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
- bad_type(numargs, "array", op_desc[op->op_type], kid);
+ bad_type(numargs, "array", op_desc[o->op_type], kid);
mod(kid, type);
break;
case OA_HVREF:
*tokid = kid;
}
else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
- bad_type(numargs, "hash", op_desc[op->op_type], kid);
+ bad_type(numargs, "hash", op_desc[o->op_type], kid);
mod(kid, type);
break;
case OA_CVREF:
tokid = &kid->op_sibling;
kid = kid->op_sibling;
}
- op->op_private |= numargs;
+ o->op_private |= numargs;
if (kid)
- return too_many_arguments(op,op_desc[op->op_type]);
- listkids(op);
+ return too_many_arguments(o,op_desc[o->op_type]);
+ listkids(o);
}
else if (opargs[type] & OA_DEFGV) {
- op_free(op);
+ op_free(o);
return newUNOP(type, 0, newSVREF(newGVOP(OP_GV, 0, defgv)));
}
while (oa & OA_OPTIONAL)
oa >>= 4;
if (oa && oa != OA_LIST)
- return too_few_arguments(op,op_desc[op->op_type]);
+ return too_few_arguments(o,op_desc[o->op_type]);
}
- return op;
+ return o;
}
OP *
-ck_glob(op)
-OP *op;
+ck_glob(o)
+OP *o;
{
GV *gv;
if (gv && GvIMPORTED_CV(gv)) {
static int glob_index;
- append_elem(OP_GLOB, op,
+ append_elem(OP_GLOB, o,
newSVOP(OP_CONST, 0, newSViv(glob_index++)));
- op->op_type = OP_LIST;
- op->op_ppaddr = ppaddr[OP_LIST];
- ((LISTOP*)op)->op_first->op_type = OP_PUSHMARK;
- ((LISTOP*)op)->op_first->op_ppaddr = ppaddr[OP_PUSHMARK];
- op = newUNOP(OP_ENTERSUB, OPf_STACKED,
- append_elem(OP_LIST, op,
- scalar(newUNOP(OP_RV2CV, 0,
- newGVOP(OP_GV, 0, gv)))));
- op = newUNOP(OP_NULL, 0, ck_subr(op));
- op->op_targ = OP_GLOB; /* hint at what it used to be */
- return op;
+ o = newUNOP(OP_NULL, 0, ck_subr(o));
+ o->op_targ = OP_GLOB; /* hint at what it used to be */
+ return o;
}
gv = newGVgen("main");
gv_IOadd(gv);
- append_elem(OP_GLOB, op, newGVOP(OP_GV, 0, gv));
- scalarkids(op);
- return ck_fun(op);
+ append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
+ scalarkids(o);
+ return ck_fun(o);
}
OP *
-ck_grep(op)
-OP *op;
+ck_grep(o)
+OP *o;
{
LOGOP *gwop;
OP *kid;
- OPCODE type = op->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
+ OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
- op->op_ppaddr = ppaddr[OP_GREPSTART];
+ o->op_ppaddr = ppaddr[OP_GREPSTART];
Newz(1101, gwop, 1, LOGOP);
- if (op->op_flags & OPf_STACKED) {
+ if (o->op_flags & OPf_STACKED) {
OP* k;
- op = ck_sort(op);
- kid = cLISTOP->op_first->op_sibling;
- for (k = cLISTOP->op_first->op_sibling->op_next; k; k = k->op_next) {
+ o = ck_sort(o);
+ kid = cLISTOPo->op_first->op_sibling;
+ for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
kid = k;
}
kid->op_next = (OP*)gwop;
- op->op_flags &= ~OPf_STACKED;
+ o->op_flags &= ~OPf_STACKED;
}
- kid = cLISTOP->op_first->op_sibling;
+ kid = cLISTOPo->op_first->op_sibling;
if (type == OP_MAPWHILE)
list(kid);
else
scalar(kid);
- op = ck_fun(op);
+ o = ck_fun(o);
if (error_count)
- return op;
- kid = cLISTOP->op_first->op_sibling;
+ return o;
+ kid = cLISTOPo->op_first->op_sibling;
if (kid->op_type != OP_NULL)
croak("panic: ck_grep");
kid = kUNOP->op_first;
gwop->op_type = type;
gwop->op_ppaddr = ppaddr[type];
- gwop->op_first = listkids(op);
+ gwop->op_first = listkids(o);
gwop->op_flags |= OPf_KIDS;
gwop->op_private = 1;
gwop->op_other = LINKLIST(kid);
gwop->op_targ = pad_alloc(type, SVs_PADTMP);
kid->op_next = (OP*)gwop;
- kid = cLISTOP->op_first->op_sibling;
+ kid = cLISTOPo->op_first->op_sibling;
if (!kid || !kid->op_sibling)
- return too_few_arguments(op,op_desc[op->op_type]);
+ return too_few_arguments(o,op_desc[o->op_type]);
for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
mod(kid, OP_GREPSTART);
}
OP *
-ck_index(op)
-OP *op;
+ck_index(o)
+OP *o;
{
- if (op->op_flags & OPf_KIDS) {
- OP *kid = cLISTOP->op_first->op_sibling; /* get past pushmark */
+ if (o->op_flags & OPf_KIDS) {
+ OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
if (kid && kid->op_type == OP_CONST)
fbm_compile(((SVOP*)kid)->op_sv);
}
- return ck_fun(op);
+ return ck_fun(o);
}
OP *
-ck_lengthconst(op)
-OP *op;
+ck_lengthconst(o)
+OP *o;
{
/* XXX length optimization goes here */
- return ck_fun(op);
+ return ck_fun(o);
}
OP *
-ck_lfun(op)
-OP *op;
+ck_lfun(o)
+OP *o;
{
- OPCODE type = op->op_type;
- return modkids(ck_fun(op), type);
+ OPCODE type = o->op_type;
+ return modkids(ck_fun(o), type);
}
OP *
-ck_rfun(op)
-OP *op;
+ck_rfun(o)
+OP *o;
{
- OPCODE type = op->op_type;
- return refkids(ck_fun(op), type);
+ OPCODE type = o->op_type;
+ return refkids(ck_fun(o), type);
}
OP *
-ck_listiob(op)
-OP *op;
+ck_listiob(o)
+OP *o;
{
register OP *kid;
- kid = cLISTOP->op_first;
+ kid = cLISTOPo->op_first;
if (!kid) {
- op = force_list(op);
- kid = cLISTOP->op_first;
+ o = force_list(o);
+ kid = cLISTOPo->op_first;
}
if (kid->op_type == OP_PUSHMARK)
kid = kid->op_sibling;
- if (kid && op->op_flags & OPf_STACKED)
+ if (kid && o->op_flags & OPf_STACKED)
kid = kid->op_sibling;
else if (kid && !kid->op_sibling) { /* print HANDLE; */
if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
- op->op_flags |= OPf_STACKED; /* make it a filehandle */
+ o->op_flags |= OPf_STACKED; /* make it a filehandle */
kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
- cLISTOP->op_first->op_sibling = kid;
- cLISTOP->op_last = kid;
+ cLISTOPo->op_first->op_sibling = kid;
+ cLISTOPo->op_last = kid;
kid = kid->op_sibling;
}
}
if (!kid)
- append_elem(op->op_type, op, newSVREF(newGVOP(OP_GV, 0, defgv)) );
+ append_elem(o->op_type, o, newSVREF(newGVOP(OP_GV, 0, defgv)) );
- op = listkids(op);
+ o = listkids(o);
- op->op_private = 0;
+ o->op_private = 0;
#ifdef USE_LOCALE
if (hints & HINT_LOCALE)
- op->op_private |= OPpLOCALE;
+ o->op_private |= OPpLOCALE;
#endif
- return op;
+ return o;
}
OP *
-ck_fun_locale(op)
-OP *op;
+ck_fun_locale(o)
+OP *o;
{
- op = ck_fun(op);
+ o = ck_fun(o);
- op->op_private = 0;
+ o->op_private = 0;
#ifdef USE_LOCALE
if (hints & HINT_LOCALE)
- op->op_private |= OPpLOCALE;
+ o->op_private |= OPpLOCALE;
#endif
- return op;
+ return o;
}
OP *
-ck_scmp(op)
-OP *op;
+ck_scmp(o)
+OP *o;
{
- op->op_private = 0;
+ o->op_private = 0;
#ifdef USE_LOCALE
if (hints & HINT_LOCALE)
- op->op_private |= OPpLOCALE;
+ o->op_private |= OPpLOCALE;
#endif
- return op;
+ return o;
}
OP *
-ck_match(op)
-OP *op;
+ck_match(o)
+OP *o;
{
- op->op_private |= OPpRUNTIME;
- return op;
+ o->op_private |= OPpRUNTIME;
+ return o;
}
OP *
-ck_null(op)
-OP *op;
+ck_null(o)
+OP *o;
{
- return op;
+ return o;
}
OP *
-ck_repeat(op)
-OP *op;
+ck_repeat(o)
+OP *o;
{
- if (cBINOP->op_first->op_flags & OPf_PARENS) {
- op->op_private |= OPpREPEAT_DOLIST;
- cBINOP->op_first = force_list(cBINOP->op_first);
+ if (cBINOPo->op_first->op_flags & OPf_PARENS) {
+ o->op_private |= OPpREPEAT_DOLIST;
+ cBINOPo->op_first = force_list(cBINOPo->op_first);
}
else
- scalar(op);
- return op;
+ scalar(o);
+ return o;
}
OP *
-ck_require(op)
-OP *op;
+ck_require(o)
+OP *o;
{
- if (op->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
- SVOP *kid = (SVOP*)cUNOP->op_first;
+ if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
+ SVOP *kid = (SVOP*)cUNOPo->op_first;
if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
char *s;
sv_catpvn(kid->op_sv, ".pm", 3);
}
}
- return ck_fun(op);
+ return ck_fun(o);
}
OP *
-ck_retarget(op)
-OP *op;
+ck_retarget(o)
+OP *o;
{
croak("NOT IMPL LINE %d",__LINE__);
/* STUB */
- return op;
+ return o;
}
OP *
-ck_select(op)
-OP *op;
+ck_select(o)
+OP *o;
{
OP* kid;
- if (op->op_flags & OPf_KIDS) {
- kid = cLISTOP->op_first->op_sibling; /* get past pushmark */
+ if (o->op_flags & OPf_KIDS) {
+ kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
if (kid && kid->op_sibling) {
- op->op_type = OP_SSELECT;
- op->op_ppaddr = ppaddr[OP_SSELECT];
- op = ck_fun(op);
- return fold_constants(op);
+ o->op_type = OP_SSELECT;
+ o->op_ppaddr = ppaddr[OP_SSELECT];
+ o = ck_fun(o);
+ return fold_constants(o);
}
}
- op = ck_fun(op);
- kid = cLISTOP->op_first->op_sibling; /* get past pushmark */
+ o = ck_fun(o);
+ kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
if (kid && kid->op_type == OP_RV2GV)
kid->op_private &= ~HINT_STRICT_REFS;
- return op;
+ return o;
}
OP *
-ck_shift(op)
-OP *op;
+ck_shift(o)
+OP *o;
{
- I32 type = op->op_type;
+ I32 type = o->op_type;
- if (!(op->op_flags & OPf_KIDS)) {
- op_free(op);
- return newUNOP(type, 0,
- scalar(newUNOP(OP_RV2AV, 0,
- scalar(newGVOP(OP_GV, 0, subline
- ? defgv
- : gv_fetchpv("ARGV", TRUE, SVt_PVAV) )))));
+ if (!(o->op_flags & OPf_KIDS)) {
+ OP *argop;
+
+ op_free(o);
+#ifdef USE_THREADS
+ if (subline) {
+ argop = newOP(OP_PADAV, OPf_REF);
+ argop->op_targ = 0; /* curpad[0] is @_ */
+ }
+ else {
+ argop = newUNOP(OP_RV2AV, 0,
+ scalar(newGVOP(OP_GV, 0,
+ gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
+ }
+#else
+ argop = newUNOP(OP_RV2AV, 0,
+ scalar(newGVOP(OP_GV, 0, subline ?
+ defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
+#endif /* USE_THREADS */
+ return newUNOP(type, 0, scalar(argop));
}
- return scalar(modkids(ck_fun(op), type));
+ return scalar(modkids(ck_fun(o), type));
}
OP *
-ck_sort(op)
-OP *op;
+ck_sort(o)
+OP *o;
{
- op->op_private = 0;
+ o->op_private = 0;
#ifdef USE_LOCALE
if (hints & HINT_LOCALE)
- op->op_private |= OPpLOCALE;
+ o->op_private |= OPpLOCALE;
#endif
- if (op->op_flags & OPf_STACKED) {
- OP *kid = cLISTOP->op_first->op_sibling; /* get past pushmark */
+ if (o->op_flags & OPf_STACKED) {
+ OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
OP *k;
kid = kUNOP->op_first; /* get past rv2gv */
kid->op_next = 0;
}
else if (kid->op_type == OP_LEAVE) {
- if (op->op_type == OP_SORT) {
+ if (o->op_type == OP_SORT) {
null(kid); /* wipe out leave */
kid->op_next = kid;
}
peep(k);
- kid = cLISTOP->op_first->op_sibling; /* get past pushmark */
+ kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
null(kid); /* wipe out rv2gv */
- if (op->op_type == OP_SORT)
+ if (o->op_type == OP_SORT)
kid->op_next = kid;
else
kid->op_next = k;
- op->op_flags |= OPf_SPECIAL;
+ o->op_flags |= OPf_SPECIAL;
}
}
- return op;
+ return o;
}
OP *
-ck_split(op)
-OP *op;
+ck_split(o)
+OP *o;
{
register OP *kid;
PMOP* pm;
- if (op->op_flags & OPf_STACKED)
- return no_fh_allowed(op);
+ if (o->op_flags & OPf_STACKED)
+ return no_fh_allowed(o);
- kid = cLISTOP->op_first;
+ kid = cLISTOPo->op_first;
if (kid->op_type != OP_NULL)
croak("panic: ck_split");
kid = kid->op_sibling;
- op_free(cLISTOP->op_first);
- cLISTOP->op_first = kid;
+ op_free(cLISTOPo->op_first);
+ cLISTOPo->op_first = kid;
if (!kid) {
- cLISTOP->op_first = kid = newSVOP(OP_CONST, 0, newSVpv(" ", 1));
- cLISTOP->op_last = kid; /* There was only one element previously */
+ cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpv(" ", 1));
+ cLISTOPo->op_last = kid; /* There was only one element previously */
}
if (kid->op_type != OP_MATCH) {
OP *sibl = kid->op_sibling;
kid->op_sibling = 0;
kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
- if (cLISTOP->op_first == cLISTOP->op_last)
- cLISTOP->op_last = kid;
- cLISTOP->op_first = kid;
+ if (cLISTOPo->op_first == cLISTOPo->op_last)
+ cLISTOPo->op_last = kid;
+ cLISTOPo->op_first = kid;
kid->op_sibling = sibl;
}
pm = (PMOP*)kid;
scalar(kid);
if (!kid->op_sibling)
- append_elem(OP_SPLIT, op, newSVREF(newGVOP(OP_GV, 0, defgv)) );
+ append_elem(OP_SPLIT, o, newSVREF(newGVOP(OP_GV, 0, defgv)) );
kid = kid->op_sibling;
scalar(kid);
if (!kid->op_sibling)
- append_elem(OP_SPLIT, op, newSVOP(OP_CONST, 0, newSViv(0)));
+ append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
kid = kid->op_sibling;
scalar(kid);
if (kid->op_sibling)
- return too_many_arguments(op,op_desc[op->op_type]);
+ return too_many_arguments(o,op_desc[o->op_type]);
- return op;
+ return o;
}
OP *
-ck_subr(op)
-OP *op;
+ck_subr(o)
+OP *o;
{
- OP *prev = ((cUNOP->op_first->op_sibling)
- ? cUNOP : ((UNOP*)cUNOP->op_first))->op_first;
- OP *o = prev->op_sibling;
+ dTHR;
+ OP *prev = ((cUNOPo->op_first->op_sibling)
+ ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
+ OP *o2 = prev->op_sibling;
OP *cvop;
char *proto = 0;
CV *cv = 0;
int optional = 0;
I32 arg = 0;
- for (cvop = o; cvop->op_sibling; cvop = cvop->op_sibling) ;
+ for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
if (cvop->op_type == OP_RV2CV) {
SVOP* tmpop;
- op->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
+ o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
null(cvop); /* disable rv2cv */
tmpop = (SVOP*)((UNOP*)cvop)->op_first;
if (tmpop->op_type == OP_GV) {
cv = GvCVu(tmpop->op_sv);
- if (cv && SvPOK(cv) && !(op->op_private & OPpENTERSUB_AMPER)) {
+ if (cv && SvPOK(cv) && !(o->op_private & OPpENTERSUB_AMPER)) {
namegv = CvANON(cv) ? (GV*)tmpop->op_sv : CvGV(cv);
proto = SvPV((SV*)cv, na);
}
}
}
- op->op_private |= (hints & HINT_STRICT_REFS);
+ o->op_private |= (hints & HINT_STRICT_REFS);
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':
- return too_many_arguments(op, gv_ename(namegv));
+ return too_many_arguments(o, gv_ename(namegv));
case ';':
optional = 1;
proto++;
case '$':
proto++;
arg++;
- scalar(o);
+ scalar(o2);
break;
case '%':
case '@':
- list(o);
+ list(o2);
arg++;
break;
case '&':
proto++;
arg++;
- if (o->op_type != OP_REFGEN && o->op_type != OP_UNDEF)
- bad_type(arg, "block", gv_ename(namegv), o);
+ if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
+ bad_type(arg, "block", gv_ename(namegv), o2);
break;
case '*':
proto++;
arg++;
- if (o->op_type == OP_RV2GV)
+ if (o2->op_type == OP_RV2GV)
goto wrapref;
{
- OP* kid = o;
- o = newUNOP(OP_RV2GV, 0, kid);
- o->op_sibling = kid->op_sibling;
+ OP* kid = o2;
+ o2 = newUNOP(OP_RV2GV, 0, kid);
+ o2->op_sibling = kid->op_sibling;
kid->op_sibling = 0;
prev->op_sibling = o;
}
arg++;
switch (*proto++) {
case '*':
- if (o->op_type != OP_RV2GV)
- bad_type(arg, "symbol", gv_ename(namegv), o);
+ if (o2->op_type != OP_RV2GV)
+ bad_type(arg, "symbol", gv_ename(namegv), o2);
goto wrapref;
case '&':
- if (o->op_type != OP_RV2CV)
- bad_type(arg, "sub", gv_ename(namegv), o);
+ if (o2->op_type != OP_RV2CV)
+ bad_type(arg, "sub", gv_ename(namegv), o2);
goto wrapref;
case '$':
- if (o->op_type != OP_RV2SV && o->op_type != OP_PADSV)
- bad_type(arg, "scalar", gv_ename(namegv), o);
+ if (o2->op_type != OP_RV2SV && o2->op_type != OP_PADSV)
+ bad_type(arg, "scalar", gv_ename(namegv), o2);
goto wrapref;
case '@':
- if (o->op_type != OP_RV2AV && o->op_type != OP_PADAV)
- bad_type(arg, "array", gv_ename(namegv), o);
+ if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
+ bad_type(arg, "array", gv_ename(namegv), o2);
goto wrapref;
case '%':
- if (o->op_type != OP_RV2HV && o->op_type != OP_PADHV)
- bad_type(arg, "hash", gv_ename(namegv), o);
+ if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
+ bad_type(arg, "hash", gv_ename(namegv), o2);
wrapref:
{
- OP* kid = o;
- o = newUNOP(OP_REFGEN, 0, kid);
- o->op_sibling = kid->op_sibling;
+ OP* kid = o2;
+ o2 = newUNOP(OP_REFGEN, 0, kid);
+ o2->op_sibling = kid->op_sibling;
kid->op_sibling = 0;
- prev->op_sibling = o;
+ prev->op_sibling = o2;
}
break;
default: goto oops;
}
}
else
- list(o);
- mod(o, OP_ENTERSUB);
- prev = o;
- o = o->op_sibling;
+ list(o2);
+ mod(o2, OP_ENTERSUB);
+ prev = o2;
+ o2 = o2->op_sibling;
}
if (proto && !optional &&
(*proto && *proto != '@' && *proto != '%' && *proto != ';'))
- return too_few_arguments(op, gv_ename(namegv));
- return op;
+ return too_few_arguments(o, gv_ename(namegv));
+ return o;
}
OP *
-ck_svconst(op)
-OP *op;
+ck_svconst(o)
+OP *o;
{
- SvREADONLY_on(cSVOP->op_sv);
- return op;
+ SvREADONLY_on(cSVOPo->op_sv);
+ return o;
}
OP *
-ck_trunc(op)
-OP *op;
+ck_trunc(o)
+OP *o;
{
- if (op->op_flags & OPf_KIDS) {
- SVOP *kid = (SVOP*)cUNOP->op_first;
+ if (o->op_flags & OPf_KIDS) {
+ SVOP *kid = (SVOP*)cUNOPo->op_first;
if (kid->op_type == OP_NULL)
kid = (SVOP*)kid->op_sibling;
if (kid &&
kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE))
- op->op_flags |= OPf_SPECIAL;
+ o->op_flags |= OPf_SPECIAL;
}
- return ck_fun(op);
+ return ck_fun(o);
}
/* A peephole optimizer. We visit the ops in the order they're to execute. */
peep(o)
register OP* o;
{
+ dTHR;
register OP* oldop = 0;
if (!o || o->op_seq)
return;
ENTER;
- SAVESPTR(op);
+ SAVEOP();
SAVESPTR(curcop);
for (; o; o = o->op_next) {
if (o->op_seq)
}
}
break;
+
+ case OP_HELEM: {
+ UNOP *rop;
+ SV *lexname;
+ GV **fields;
+ SV **svp, **indsvp;
+ I32 ind;
+ char *key;
+ STRLEN keylen;
+
+ if (o->op_private & (OPpDEREF_HV|OPpDEREF_AV|OPpLVAL_INTRO)
+ || ((BINOP*)o)->op_last->op_type != OP_CONST)
+ break;
+ rop = (UNOP*)((BINOP*)o)->op_first;
+ if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
+ break;
+ lexname = *av_fetch(comppad_name, rop->op_first->op_targ, TRUE);
+ if (!SvOBJECT(lexname))
+ break;
+ fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
+ if (!fields || !GvHV(*fields))
+ break;
+ svp = &((SVOP*)((BINOP*)o)->op_last)->op_sv;
+ key = SvPV(*svp, keylen);
+ indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
+ if (!indsvp) {
+ croak("No such field \"%s\" in variable %s of type %s",
+ key, SvPV(lexname, na), HvNAME(SvSTASH(lexname)));
+ }
+ ind = SvIV(*indsvp);
+ if (ind < 1)
+ croak("Bad index while coercing array into hash");
+ rop->op_type = OP_RV2AV;
+ rop->op_ppaddr = ppaddr[OP_RV2AV];
+ o->op_type = OP_AELEM;
+ o->op_ppaddr = ppaddr[OP_AELEM];
+ SvREFCNT_dec(*svp);
+ *svp = newSViv(ind);
+ break;
+ }
+
default:
o->op_seq = op_seqmax++;
break;
*/
typedef U32 PADOFFSET;
+#define NOT_IN_PAD ((PADOFFSET) -1)
#ifdef DEBUGGING_OPS
#define OPCODE opcode
#define cCOP ((COP*)op)
#define cLOOP ((LOOP*)op)
+#define cUNOPo ((UNOP*)o)
+#define cBINOPo ((BINOP*)o)
+#define cLISTOPo ((LISTOP*)o)
+#define cLOGOPo ((LOGOP*)o)
+#define cCONDOPo ((CONDOP*)o)
+#define cPMOPo ((PMOP*)o)
+#define cSVOPo ((SVOP*)o)
+#define cGVOPo ((GVOP*)o)
+#define cPVOPo ((PVOP*)o)
+#define cCVOPo ((CVOP*)o)
+#define cCOPo ((COP*)o)
+#define cLOOPo ((LOOP*)o)
+
#define kUNOP ((UNOP*)kid)
#define kBINOP ((BINOP*)kid)
#define kLISTOP ((LISTOP*)kid)
OP_EGRENT, /* 341 */
OP_GETLOGIN, /* 342 */
OP_SYSCALL, /* 343 */
+ OP_LOCK, /* 344 */
OP_max
} opcode;
-#define MAXO 344
+#define MAXO 345
#ifndef DOINIT
EXT char *op_name[];
"egrent",
"getlogin",
"syscall",
+ "lock",
};
#endif
"endgrent",
"getlogin",
"syscall",
+ "lock",
};
#endif
-OP * ck_anoncode _((OP* op));
-OP * ck_bitop _((OP* op));
-OP * ck_concat _((OP* op));
-OP * ck_delete _((OP* op));
-OP * ck_eof _((OP* op));
-OP * ck_eval _((OP* op));
-OP * ck_exec _((OP* op));
-OP * ck_exists _((OP* op));
-OP * ck_ftst _((OP* op));
-OP * ck_fun _((OP* op));
-OP * ck_fun_locale _((OP* op));
-OP * ck_glob _((OP* op));
-OP * ck_grep _((OP* op));
-OP * ck_index _((OP* op));
-OP * ck_lengthconst _((OP* op));
-OP * ck_lfun _((OP* op));
-OP * ck_listiob _((OP* op));
-OP * ck_match _((OP* op));
-OP * ck_null _((OP* op));
-OP * ck_repeat _((OP* op));
-OP * ck_require _((OP* op));
-OP * ck_rfun _((OP* op));
-OP * ck_rvconst _((OP* op));
-OP * ck_scmp _((OP* op));
-OP * ck_select _((OP* op));
-OP * ck_shift _((OP* op));
-OP * ck_sort _((OP* op));
-OP * ck_spair _((OP* op));
-OP * ck_split _((OP* op));
-OP * ck_subr _((OP* op));
-OP * ck_svconst _((OP* op));
-OP * ck_trunc _((OP* op));
+OP * ck_anoncode _((OP* o));
+OP * ck_bitop _((OP* o));
+OP * ck_concat _((OP* o));
+OP * ck_delete _((OP* o));
+OP * ck_eof _((OP* o));
+OP * ck_eval _((OP* o));
+OP * ck_exec _((OP* o));
+OP * ck_exists _((OP* o));
+OP * ck_ftst _((OP* o));
+OP * ck_fun _((OP* o));
+OP * ck_fun_locale _((OP* o));
+OP * ck_glob _((OP* o));
+OP * ck_grep _((OP* o));
+OP * ck_index _((OP* o));
+OP * ck_lengthconst _((OP* o));
+OP * ck_lfun _((OP* o));
+OP * ck_listiob _((OP* o));
+OP * ck_match _((OP* o));
+OP * ck_null _((OP* o));
+OP * ck_repeat _((OP* o));
+OP * ck_require _((OP* o));
+OP * ck_rfun _((OP* o));
+OP * ck_rvconst _((OP* o));
+OP * ck_scmp _((OP* o));
+OP * ck_select _((OP* o));
+OP * ck_shift _((OP* o));
+OP * ck_sort _((OP* o));
+OP * ck_spair _((OP* o));
+OP * ck_split _((OP* o));
+OP * ck_subr _((OP* o));
+OP * ck_svconst _((OP* o));
+OP * ck_trunc _((OP* o));
-OP * pp_null _((void));
-OP * pp_stub _((void));
-OP * pp_scalar _((void));
-OP * pp_pushmark _((void));
-OP * pp_wantarray _((void));
-OP * pp_const _((void));
-OP * pp_gvsv _((void));
-OP * pp_gv _((void));
-OP * pp_gelem _((void));
-OP * pp_padsv _((void));
-OP * pp_padav _((void));
-OP * pp_padhv _((void));
-OP * pp_padany _((void));
-OP * pp_pushre _((void));
-OP * pp_rv2gv _((void));
-OP * pp_rv2sv _((void));
-OP * pp_av2arylen _((void));
-OP * pp_rv2cv _((void));
-OP * pp_anoncode _((void));
-OP * pp_prototype _((void));
-OP * pp_refgen _((void));
-OP * pp_srefgen _((void));
-OP * pp_ref _((void));
-OP * pp_bless _((void));
-OP * pp_backtick _((void));
-OP * pp_glob _((void));
-OP * pp_readline _((void));
-OP * pp_rcatline _((void));
-OP * pp_regcmaybe _((void));
-OP * pp_regcomp _((void));
-OP * pp_match _((void));
-OP * pp_subst _((void));
-OP * pp_substcont _((void));
-OP * pp_trans _((void));
-OP * pp_sassign _((void));
-OP * pp_aassign _((void));
-OP * pp_chop _((void));
-OP * pp_schop _((void));
-OP * pp_chomp _((void));
-OP * pp_schomp _((void));
-OP * pp_defined _((void));
-OP * pp_undef _((void));
-OP * pp_study _((void));
-OP * pp_pos _((void));
-OP * pp_preinc _((void));
-OP * pp_i_preinc _((void));
-OP * pp_predec _((void));
-OP * pp_i_predec _((void));
-OP * pp_postinc _((void));
-OP * pp_i_postinc _((void));
-OP * pp_postdec _((void));
-OP * pp_i_postdec _((void));
-OP * pp_pow _((void));
-OP * pp_multiply _((void));
-OP * pp_i_multiply _((void));
-OP * pp_divide _((void));
-OP * pp_i_divide _((void));
-OP * pp_modulo _((void));
-OP * pp_i_modulo _((void));
-OP * pp_repeat _((void));
-OP * pp_add _((void));
-OP * pp_i_add _((void));
-OP * pp_subtract _((void));
-OP * pp_i_subtract _((void));
-OP * pp_concat _((void));
-OP * pp_stringify _((void));
-OP * pp_left_shift _((void));
-OP * pp_right_shift _((void));
-OP * pp_lt _((void));
-OP * pp_i_lt _((void));
-OP * pp_gt _((void));
-OP * pp_i_gt _((void));
-OP * pp_le _((void));
-OP * pp_i_le _((void));
-OP * pp_ge _((void));
-OP * pp_i_ge _((void));
-OP * pp_eq _((void));
-OP * pp_i_eq _((void));
-OP * pp_ne _((void));
-OP * pp_i_ne _((void));
-OP * pp_ncmp _((void));
-OP * pp_i_ncmp _((void));
-OP * pp_slt _((void));
-OP * pp_sgt _((void));
-OP * pp_sle _((void));
-OP * pp_sge _((void));
-OP * pp_seq _((void));
-OP * pp_sne _((void));
-OP * pp_scmp _((void));
-OP * pp_bit_and _((void));
-OP * pp_bit_xor _((void));
-OP * pp_bit_or _((void));
-OP * pp_negate _((void));
-OP * pp_i_negate _((void));
-OP * pp_not _((void));
-OP * pp_complement _((void));
-OP * pp_atan2 _((void));
-OP * pp_sin _((void));
-OP * pp_cos _((void));
-OP * pp_rand _((void));
-OP * pp_srand _((void));
-OP * pp_exp _((void));
-OP * pp_log _((void));
-OP * pp_sqrt _((void));
-OP * pp_int _((void));
-OP * pp_hex _((void));
-OP * pp_oct _((void));
-OP * pp_abs _((void));
-OP * pp_length _((void));
-OP * pp_substr _((void));
-OP * pp_vec _((void));
-OP * pp_index _((void));
-OP * pp_rindex _((void));
-OP * pp_sprintf _((void));
-OP * pp_formline _((void));
-OP * pp_ord _((void));
-OP * pp_chr _((void));
-OP * pp_crypt _((void));
-OP * pp_ucfirst _((void));
-OP * pp_lcfirst _((void));
-OP * pp_uc _((void));
-OP * pp_lc _((void));
-OP * pp_quotemeta _((void));
-OP * pp_rv2av _((void));
-OP * pp_aelemfast _((void));
-OP * pp_aelem _((void));
-OP * pp_aslice _((void));
-OP * pp_each _((void));
-OP * pp_values _((void));
-OP * pp_keys _((void));
-OP * pp_delete _((void));
-OP * pp_exists _((void));
-OP * pp_rv2hv _((void));
-OP * pp_helem _((void));
-OP * pp_hslice _((void));
-OP * pp_unpack _((void));
-OP * pp_pack _((void));
-OP * pp_split _((void));
-OP * pp_join _((void));
-OP * pp_list _((void));
-OP * pp_lslice _((void));
-OP * pp_anonlist _((void));
-OP * pp_anonhash _((void));
-OP * pp_splice _((void));
-OP * pp_push _((void));
-OP * pp_pop _((void));
-OP * pp_shift _((void));
-OP * pp_unshift _((void));
-OP * pp_sort _((void));
-OP * pp_reverse _((void));
-OP * pp_grepstart _((void));
-OP * pp_grepwhile _((void));
-OP * pp_mapstart _((void));
-OP * pp_mapwhile _((void));
-OP * pp_range _((void));
-OP * pp_flip _((void));
-OP * pp_flop _((void));
-OP * pp_and _((void));
-OP * pp_or _((void));
-OP * pp_xor _((void));
-OP * pp_cond_expr _((void));
-OP * pp_andassign _((void));
-OP * pp_orassign _((void));
-OP * pp_method _((void));
-OP * pp_entersub _((void));
-OP * pp_leavesub _((void));
-OP * pp_caller _((void));
-OP * pp_warn _((void));
-OP * pp_die _((void));
-OP * pp_reset _((void));
-OP * pp_lineseq _((void));
-OP * pp_nextstate _((void));
-OP * pp_dbstate _((void));
-OP * pp_unstack _((void));
-OP * pp_enter _((void));
-OP * pp_leave _((void));
-OP * pp_scope _((void));
-OP * pp_enteriter _((void));
-OP * pp_iter _((void));
-OP * pp_enterloop _((void));
-OP * pp_leaveloop _((void));
-OP * pp_return _((void));
-OP * pp_last _((void));
-OP * pp_next _((void));
-OP * pp_redo _((void));
-OP * pp_dump _((void));
-OP * pp_goto _((void));
-OP * pp_exit _((void));
-OP * pp_open _((void));
-OP * pp_close _((void));
-OP * pp_pipe_op _((void));
-OP * pp_fileno _((void));
-OP * pp_umask _((void));
-OP * pp_binmode _((void));
-OP * pp_tie _((void));
-OP * pp_untie _((void));
-OP * pp_tied _((void));
-OP * pp_dbmopen _((void));
-OP * pp_dbmclose _((void));
-OP * pp_sselect _((void));
-OP * pp_select _((void));
-OP * pp_getc _((void));
-OP * pp_read _((void));
-OP * pp_enterwrite _((void));
-OP * pp_leavewrite _((void));
-OP * pp_prtf _((void));
-OP * pp_print _((void));
-OP * pp_sysopen _((void));
-OP * pp_sysseek _((void));
-OP * pp_sysread _((void));
-OP * pp_syswrite _((void));
-OP * pp_send _((void));
-OP * pp_recv _((void));
-OP * pp_eof _((void));
-OP * pp_tell _((void));
-OP * pp_seek _((void));
-OP * pp_truncate _((void));
-OP * pp_fcntl _((void));
-OP * pp_ioctl _((void));
-OP * pp_flock _((void));
-OP * pp_socket _((void));
-OP * pp_sockpair _((void));
-OP * pp_bind _((void));
-OP * pp_connect _((void));
-OP * pp_listen _((void));
-OP * pp_accept _((void));
-OP * pp_shutdown _((void));
-OP * pp_gsockopt _((void));
-OP * pp_ssockopt _((void));
-OP * pp_getsockname _((void));
-OP * pp_getpeername _((void));
-OP * pp_lstat _((void));
-OP * pp_stat _((void));
-OP * pp_ftrread _((void));
-OP * pp_ftrwrite _((void));
-OP * pp_ftrexec _((void));
-OP * pp_fteread _((void));
-OP * pp_ftewrite _((void));
-OP * pp_fteexec _((void));
-OP * pp_ftis _((void));
-OP * pp_fteowned _((void));
-OP * pp_ftrowned _((void));
-OP * pp_ftzero _((void));
-OP * pp_ftsize _((void));
-OP * pp_ftmtime _((void));
-OP * pp_ftatime _((void));
-OP * pp_ftctime _((void));
-OP * pp_ftsock _((void));
-OP * pp_ftchr _((void));
-OP * pp_ftblk _((void));
-OP * pp_ftfile _((void));
-OP * pp_ftdir _((void));
-OP * pp_ftpipe _((void));
-OP * pp_ftlink _((void));
-OP * pp_ftsuid _((void));
-OP * pp_ftsgid _((void));
-OP * pp_ftsvtx _((void));
-OP * pp_fttty _((void));
-OP * pp_fttext _((void));
-OP * pp_ftbinary _((void));
-OP * pp_chdir _((void));
-OP * pp_chown _((void));
-OP * pp_chroot _((void));
-OP * pp_unlink _((void));
-OP * pp_chmod _((void));
-OP * pp_utime _((void));
-OP * pp_rename _((void));
-OP * pp_link _((void));
-OP * pp_symlink _((void));
-OP * pp_readlink _((void));
-OP * pp_mkdir _((void));
-OP * pp_rmdir _((void));
-OP * pp_open_dir _((void));
-OP * pp_readdir _((void));
-OP * pp_telldir _((void));
-OP * pp_seekdir _((void));
-OP * pp_rewinddir _((void));
-OP * pp_closedir _((void));
-OP * pp_fork _((void));
-OP * pp_wait _((void));
-OP * pp_waitpid _((void));
-OP * pp_system _((void));
-OP * pp_exec _((void));
-OP * pp_kill _((void));
-OP * pp_getppid _((void));
-OP * pp_getpgrp _((void));
-OP * pp_setpgrp _((void));
-OP * pp_getpriority _((void));
-OP * pp_setpriority _((void));
-OP * pp_time _((void));
-OP * pp_tms _((void));
-OP * pp_localtime _((void));
-OP * pp_gmtime _((void));
-OP * pp_alarm _((void));
-OP * pp_sleep _((void));
-OP * pp_shmget _((void));
-OP * pp_shmctl _((void));
-OP * pp_shmread _((void));
-OP * pp_shmwrite _((void));
-OP * pp_msgget _((void));
-OP * pp_msgctl _((void));
-OP * pp_msgsnd _((void));
-OP * pp_msgrcv _((void));
-OP * pp_semget _((void));
-OP * pp_semctl _((void));
-OP * pp_semop _((void));
-OP * pp_require _((void));
-OP * pp_dofile _((void));
-OP * pp_entereval _((void));
-OP * pp_leaveeval _((void));
-OP * pp_entertry _((void));
-OP * pp_leavetry _((void));
-OP * pp_ghbyname _((void));
-OP * pp_ghbyaddr _((void));
-OP * pp_ghostent _((void));
-OP * pp_gnbyname _((void));
-OP * pp_gnbyaddr _((void));
-OP * pp_gnetent _((void));
-OP * pp_gpbyname _((void));
-OP * pp_gpbynumber _((void));
-OP * pp_gprotoent _((void));
-OP * pp_gsbyname _((void));
-OP * pp_gsbyport _((void));
-OP * pp_gservent _((void));
-OP * pp_shostent _((void));
-OP * pp_snetent _((void));
-OP * pp_sprotoent _((void));
-OP * pp_sservent _((void));
-OP * pp_ehostent _((void));
-OP * pp_enetent _((void));
-OP * pp_eprotoent _((void));
-OP * pp_eservent _((void));
-OP * pp_gpwnam _((void));
-OP * pp_gpwuid _((void));
-OP * pp_gpwent _((void));
-OP * pp_spwent _((void));
-OP * pp_epwent _((void));
-OP * pp_ggrnam _((void));
-OP * pp_ggrgid _((void));
-OP * pp_ggrent _((void));
-OP * pp_sgrent _((void));
-OP * pp_egrent _((void));
-OP * pp_getlogin _((void));
-OP * pp_syscall _((void));
+OP * pp_null _((ARGSproto));
+OP * pp_stub _((ARGSproto));
+OP * pp_scalar _((ARGSproto));
+OP * pp_pushmark _((ARGSproto));
+OP * pp_wantarray _((ARGSproto));
+OP * pp_const _((ARGSproto));
+OP * pp_gvsv _((ARGSproto));
+OP * pp_gv _((ARGSproto));
+OP * pp_gelem _((ARGSproto));
+OP * pp_padsv _((ARGSproto));
+OP * pp_padav _((ARGSproto));
+OP * pp_padhv _((ARGSproto));
+OP * pp_padany _((ARGSproto));
+OP * pp_pushre _((ARGSproto));
+OP * pp_rv2gv _((ARGSproto));
+OP * pp_rv2sv _((ARGSproto));
+OP * pp_av2arylen _((ARGSproto));
+OP * pp_rv2cv _((ARGSproto));
+OP * pp_anoncode _((ARGSproto));
+OP * pp_prototype _((ARGSproto));
+OP * pp_refgen _((ARGSproto));
+OP * pp_srefgen _((ARGSproto));
+OP * pp_ref _((ARGSproto));
+OP * pp_bless _((ARGSproto));
+OP * pp_backtick _((ARGSproto));
+OP * pp_glob _((ARGSproto));
+OP * pp_readline _((ARGSproto));
+OP * pp_rcatline _((ARGSproto));
+OP * pp_regcmaybe _((ARGSproto));
+OP * pp_regcomp _((ARGSproto));
+OP * pp_match _((ARGSproto));
+OP * pp_subst _((ARGSproto));
+OP * pp_substcont _((ARGSproto));
+OP * pp_trans _((ARGSproto));
+OP * pp_sassign _((ARGSproto));
+OP * pp_aassign _((ARGSproto));
+OP * pp_chop _((ARGSproto));
+OP * pp_schop _((ARGSproto));
+OP * pp_chomp _((ARGSproto));
+OP * pp_schomp _((ARGSproto));
+OP * pp_defined _((ARGSproto));
+OP * pp_undef _((ARGSproto));
+OP * pp_study _((ARGSproto));
+OP * pp_pos _((ARGSproto));
+OP * pp_preinc _((ARGSproto));
+OP * pp_i_preinc _((ARGSproto));
+OP * pp_predec _((ARGSproto));
+OP * pp_i_predec _((ARGSproto));
+OP * pp_postinc _((ARGSproto));
+OP * pp_i_postinc _((ARGSproto));
+OP * pp_postdec _((ARGSproto));
+OP * pp_i_postdec _((ARGSproto));
+OP * pp_pow _((ARGSproto));
+OP * pp_multiply _((ARGSproto));
+OP * pp_i_multiply _((ARGSproto));
+OP * pp_divide _((ARGSproto));
+OP * pp_i_divide _((ARGSproto));
+OP * pp_modulo _((ARGSproto));
+OP * pp_i_modulo _((ARGSproto));
+OP * pp_repeat _((ARGSproto));
+OP * pp_add _((ARGSproto));
+OP * pp_i_add _((ARGSproto));
+OP * pp_subtract _((ARGSproto));
+OP * pp_i_subtract _((ARGSproto));
+OP * pp_concat _((ARGSproto));
+OP * pp_stringify _((ARGSproto));
+OP * pp_left_shift _((ARGSproto));
+OP * pp_right_shift _((ARGSproto));
+OP * pp_lt _((ARGSproto));
+OP * pp_i_lt _((ARGSproto));
+OP * pp_gt _((ARGSproto));
+OP * pp_i_gt _((ARGSproto));
+OP * pp_le _((ARGSproto));
+OP * pp_i_le _((ARGSproto));
+OP * pp_ge _((ARGSproto));
+OP * pp_i_ge _((ARGSproto));
+OP * pp_eq _((ARGSproto));
+OP * pp_i_eq _((ARGSproto));
+OP * pp_ne _((ARGSproto));
+OP * pp_i_ne _((ARGSproto));
+OP * pp_ncmp _((ARGSproto));
+OP * pp_i_ncmp _((ARGSproto));
+OP * pp_slt _((ARGSproto));
+OP * pp_sgt _((ARGSproto));
+OP * pp_sle _((ARGSproto));
+OP * pp_sge _((ARGSproto));
+OP * pp_seq _((ARGSproto));
+OP * pp_sne _((ARGSproto));
+OP * pp_scmp _((ARGSproto));
+OP * pp_bit_and _((ARGSproto));
+OP * pp_bit_xor _((ARGSproto));
+OP * pp_bit_or _((ARGSproto));
+OP * pp_negate _((ARGSproto));
+OP * pp_i_negate _((ARGSproto));
+OP * pp_not _((ARGSproto));
+OP * pp_complement _((ARGSproto));
+OP * pp_atan2 _((ARGSproto));
+OP * pp_sin _((ARGSproto));
+OP * pp_cos _((ARGSproto));
+OP * pp_rand _((ARGSproto));
+OP * pp_srand _((ARGSproto));
+OP * pp_exp _((ARGSproto));
+OP * pp_log _((ARGSproto));
+OP * pp_sqrt _((ARGSproto));
+OP * pp_int _((ARGSproto));
+OP * pp_hex _((ARGSproto));
+OP * pp_oct _((ARGSproto));
+OP * pp_abs _((ARGSproto));
+OP * pp_length _((ARGSproto));
+OP * pp_substr _((ARGSproto));
+OP * pp_vec _((ARGSproto));
+OP * pp_index _((ARGSproto));
+OP * pp_rindex _((ARGSproto));
+OP * pp_sprintf _((ARGSproto));
+OP * pp_formline _((ARGSproto));
+OP * pp_ord _((ARGSproto));
+OP * pp_chr _((ARGSproto));
+OP * pp_crypt _((ARGSproto));
+OP * pp_ucfirst _((ARGSproto));
+OP * pp_lcfirst _((ARGSproto));
+OP * pp_uc _((ARGSproto));
+OP * pp_lc _((ARGSproto));
+OP * pp_quotemeta _((ARGSproto));
+OP * pp_rv2av _((ARGSproto));
+OP * pp_aelemfast _((ARGSproto));
+OP * pp_aelem _((ARGSproto));
+OP * pp_aslice _((ARGSproto));
+OP * pp_each _((ARGSproto));
+OP * pp_values _((ARGSproto));
+OP * pp_keys _((ARGSproto));
+OP * pp_delete _((ARGSproto));
+OP * pp_exists _((ARGSproto));
+OP * pp_rv2hv _((ARGSproto));
+OP * pp_helem _((ARGSproto));
+OP * pp_hslice _((ARGSproto));
+OP * pp_unpack _((ARGSproto));
+OP * pp_pack _((ARGSproto));
+OP * pp_split _((ARGSproto));
+OP * pp_join _((ARGSproto));
+OP * pp_list _((ARGSproto));
+OP * pp_lslice _((ARGSproto));
+OP * pp_anonlist _((ARGSproto));
+OP * pp_anonhash _((ARGSproto));
+OP * pp_splice _((ARGSproto));
+OP * pp_push _((ARGSproto));
+OP * pp_pop _((ARGSproto));
+OP * pp_shift _((ARGSproto));
+OP * pp_unshift _((ARGSproto));
+OP * pp_sort _((ARGSproto));
+OP * pp_reverse _((ARGSproto));
+OP * pp_grepstart _((ARGSproto));
+OP * pp_grepwhile _((ARGSproto));
+OP * pp_mapstart _((ARGSproto));
+OP * pp_mapwhile _((ARGSproto));
+OP * pp_range _((ARGSproto));
+OP * pp_flip _((ARGSproto));
+OP * pp_flop _((ARGSproto));
+OP * pp_and _((ARGSproto));
+OP * pp_or _((ARGSproto));
+OP * pp_xor _((ARGSproto));
+OP * pp_cond_expr _((ARGSproto));
+OP * pp_andassign _((ARGSproto));
+OP * pp_orassign _((ARGSproto));
+OP * pp_method _((ARGSproto));
+OP * pp_entersub _((ARGSproto));
+OP * pp_leavesub _((ARGSproto));
+OP * pp_caller _((ARGSproto));
+OP * pp_warn _((ARGSproto));
+OP * pp_die _((ARGSproto));
+OP * pp_reset _((ARGSproto));
+OP * pp_lineseq _((ARGSproto));
+OP * pp_nextstate _((ARGSproto));
+OP * pp_dbstate _((ARGSproto));
+OP * pp_unstack _((ARGSproto));
+OP * pp_enter _((ARGSproto));
+OP * pp_leave _((ARGSproto));
+OP * pp_scope _((ARGSproto));
+OP * pp_enteriter _((ARGSproto));
+OP * pp_iter _((ARGSproto));
+OP * pp_enterloop _((ARGSproto));
+OP * pp_leaveloop _((ARGSproto));
+OP * pp_return _((ARGSproto));
+OP * pp_last _((ARGSproto));
+OP * pp_next _((ARGSproto));
+OP * pp_redo _((ARGSproto));
+OP * pp_dump _((ARGSproto));
+OP * pp_goto _((ARGSproto));
+OP * pp_exit _((ARGSproto));
+OP * pp_open _((ARGSproto));
+OP * pp_close _((ARGSproto));
+OP * pp_pipe_op _((ARGSproto));
+OP * pp_fileno _((ARGSproto));
+OP * pp_umask _((ARGSproto));
+OP * pp_binmode _((ARGSproto));
+OP * pp_tie _((ARGSproto));
+OP * pp_untie _((ARGSproto));
+OP * pp_tied _((ARGSproto));
+OP * pp_dbmopen _((ARGSproto));
+OP * pp_dbmclose _((ARGSproto));
+OP * pp_sselect _((ARGSproto));
+OP * pp_select _((ARGSproto));
+OP * pp_getc _((ARGSproto));
+OP * pp_read _((ARGSproto));
+OP * pp_enterwrite _((ARGSproto));
+OP * pp_leavewrite _((ARGSproto));
+OP * pp_prtf _((ARGSproto));
+OP * pp_print _((ARGSproto));
+OP * pp_sysopen _((ARGSproto));
+OP * pp_sysseek _((ARGSproto));
+OP * pp_sysread _((ARGSproto));
+OP * pp_syswrite _((ARGSproto));
+OP * pp_send _((ARGSproto));
+OP * pp_recv _((ARGSproto));
+OP * pp_eof _((ARGSproto));
+OP * pp_tell _((ARGSproto));
+OP * pp_seek _((ARGSproto));
+OP * pp_truncate _((ARGSproto));
+OP * pp_fcntl _((ARGSproto));
+OP * pp_ioctl _((ARGSproto));
+OP * pp_flock _((ARGSproto));
+OP * pp_socket _((ARGSproto));
+OP * pp_sockpair _((ARGSproto));
+OP * pp_bind _((ARGSproto));
+OP * pp_connect _((ARGSproto));
+OP * pp_listen _((ARGSproto));
+OP * pp_accept _((ARGSproto));
+OP * pp_shutdown _((ARGSproto));
+OP * pp_gsockopt _((ARGSproto));
+OP * pp_ssockopt _((ARGSproto));
+OP * pp_getsockname _((ARGSproto));
+OP * pp_getpeername _((ARGSproto));
+OP * pp_lstat _((ARGSproto));
+OP * pp_stat _((ARGSproto));
+OP * pp_ftrread _((ARGSproto));
+OP * pp_ftrwrite _((ARGSproto));
+OP * pp_ftrexec _((ARGSproto));
+OP * pp_fteread _((ARGSproto));
+OP * pp_ftewrite _((ARGSproto));
+OP * pp_fteexec _((ARGSproto));
+OP * pp_ftis _((ARGSproto));
+OP * pp_fteowned _((ARGSproto));
+OP * pp_ftrowned _((ARGSproto));
+OP * pp_ftzero _((ARGSproto));
+OP * pp_ftsize _((ARGSproto));
+OP * pp_ftmtime _((ARGSproto));
+OP * pp_ftatime _((ARGSproto));
+OP * pp_ftctime _((ARGSproto));
+OP * pp_ftsock _((ARGSproto));
+OP * pp_ftchr _((ARGSproto));
+OP * pp_ftblk _((ARGSproto));
+OP * pp_ftfile _((ARGSproto));
+OP * pp_ftdir _((ARGSproto));
+OP * pp_ftpipe _((ARGSproto));
+OP * pp_ftlink _((ARGSproto));
+OP * pp_ftsuid _((ARGSproto));
+OP * pp_ftsgid _((ARGSproto));
+OP * pp_ftsvtx _((ARGSproto));
+OP * pp_fttty _((ARGSproto));
+OP * pp_fttext _((ARGSproto));
+OP * pp_ftbinary _((ARGSproto));
+OP * pp_chdir _((ARGSproto));
+OP * pp_chown _((ARGSproto));
+OP * pp_chroot _((ARGSproto));
+OP * pp_unlink _((ARGSproto));
+OP * pp_chmod _((ARGSproto));
+OP * pp_utime _((ARGSproto));
+OP * pp_rename _((ARGSproto));
+OP * pp_link _((ARGSproto));
+OP * pp_symlink _((ARGSproto));
+OP * pp_readlink _((ARGSproto));
+OP * pp_mkdir _((ARGSproto));
+OP * pp_rmdir _((ARGSproto));
+OP * pp_open_dir _((ARGSproto));
+OP * pp_readdir _((ARGSproto));
+OP * pp_telldir _((ARGSproto));
+OP * pp_seekdir _((ARGSproto));
+OP * pp_rewinddir _((ARGSproto));
+OP * pp_closedir _((ARGSproto));
+OP * pp_fork _((ARGSproto));
+OP * pp_wait _((ARGSproto));
+OP * pp_waitpid _((ARGSproto));
+OP * pp_system _((ARGSproto));
+OP * pp_exec _((ARGSproto));
+OP * pp_kill _((ARGSproto));
+OP * pp_getppid _((ARGSproto));
+OP * pp_getpgrp _((ARGSproto));
+OP * pp_setpgrp _((ARGSproto));
+OP * pp_getpriority _((ARGSproto));
+OP * pp_setpriority _((ARGSproto));
+OP * pp_time _((ARGSproto));
+OP * pp_tms _((ARGSproto));
+OP * pp_localtime _((ARGSproto));
+OP * pp_gmtime _((ARGSproto));
+OP * pp_alarm _((ARGSproto));
+OP * pp_sleep _((ARGSproto));
+OP * pp_shmget _((ARGSproto));
+OP * pp_shmctl _((ARGSproto));
+OP * pp_shmread _((ARGSproto));
+OP * pp_shmwrite _((ARGSproto));
+OP * pp_msgget _((ARGSproto));
+OP * pp_msgctl _((ARGSproto));
+OP * pp_msgsnd _((ARGSproto));
+OP * pp_msgrcv _((ARGSproto));
+OP * pp_semget _((ARGSproto));
+OP * pp_semctl _((ARGSproto));
+OP * pp_semop _((ARGSproto));
+OP * pp_require _((ARGSproto));
+OP * pp_dofile _((ARGSproto));
+OP * pp_entereval _((ARGSproto));
+OP * pp_leaveeval _((ARGSproto));
+OP * pp_entertry _((ARGSproto));
+OP * pp_leavetry _((ARGSproto));
+OP * pp_ghbyname _((ARGSproto));
+OP * pp_ghbyaddr _((ARGSproto));
+OP * pp_ghostent _((ARGSproto));
+OP * pp_gnbyname _((ARGSproto));
+OP * pp_gnbyaddr _((ARGSproto));
+OP * pp_gnetent _((ARGSproto));
+OP * pp_gpbyname _((ARGSproto));
+OP * pp_gpbynumber _((ARGSproto));
+OP * pp_gprotoent _((ARGSproto));
+OP * pp_gsbyname _((ARGSproto));
+OP * pp_gsbyport _((ARGSproto));
+OP * pp_gservent _((ARGSproto));
+OP * pp_shostent _((ARGSproto));
+OP * pp_snetent _((ARGSproto));
+OP * pp_sprotoent _((ARGSproto));
+OP * pp_sservent _((ARGSproto));
+OP * pp_ehostent _((ARGSproto));
+OP * pp_enetent _((ARGSproto));
+OP * pp_eprotoent _((ARGSproto));
+OP * pp_eservent _((ARGSproto));
+OP * pp_gpwnam _((ARGSproto));
+OP * pp_gpwuid _((ARGSproto));
+OP * pp_gpwent _((ARGSproto));
+OP * pp_spwent _((ARGSproto));
+OP * pp_epwent _((ARGSproto));
+OP * pp_ggrnam _((ARGSproto));
+OP * pp_ggrgid _((ARGSproto));
+OP * pp_ggrent _((ARGSproto));
+OP * pp_sgrent _((ARGSproto));
+OP * pp_egrent _((ARGSproto));
+OP * pp_getlogin _((ARGSproto));
+OP * pp_syscall _((ARGSproto));
+OP * pp_lock _((ARGSproto));
#ifndef DOINIT
EXT OP * (*ppaddr[])();
pp_egrent,
pp_getlogin,
pp_syscall,
+ pp_lock,
};
#endif
ck_null, /* egrent */
ck_null, /* getlogin */
ck_fun, /* syscall */
+ ck_null, /* lock */
};
#endif
0x00000014, /* egrent */
0x0000000c, /* getlogin */
0x0000211d, /* syscall */
+ 0x00000104, /* lock */
};
#endif
# Emit function declarations.
for (sort keys %ckname) {
- print "OP *\t", &tab(3,$_),"_((OP* op));\n";
+ print "OP *\t", &tab(3,$_),"_((OP* o));\n";
}
print "\n";
for (@ops) {
- print "OP *\t", &tab(3, "pp_\L$_"), "_((void));\n";
+ print "OP *\t", &tab(3, "pp_\L$_"), "_((ARGSproto));\n";
}
# Emit ppcode switch array.
# Miscellaneous.
syscall syscall ck_fun imst S L
+
+# For multi-threading
+lock lock ck_null s S
#define PATCHLEVEL 4
-#define SUBVERSION 4
+#define SUBVERSION 52
/*
local_patches -- list of locally applied less-than-subversion patches.
- If you're distributing such a patch, please give it a tag name and a
+ If you're distributing such a patch, please give it a name and a
one-line description, placed just before the last NULL in the array
below. If your patch fixes a bug in the perlbug database, please
mention the bugid. If your patch *IS* dependent on a prior patch,
--- patchlevel.h <date here>
*** 38,43 ***
--- 38,44 ---
- ,"MAINT_TRIAL_1 - 5.00x_0x maintenance release trial 1"
+ ,"FOO1235 - some patch"
,"BAR3141 - another patch"
,"BAZ2718 - and another patch"
+ ,"MINE001 - my new patch"
This will prevent patch from choking if someone has previously
applied different patches than you.
*/
-/* The following line and terminating '};' are read by perlbug.PL. Don't alter. */
static char *local_patches[] = {
NULL
,NULL
static void init_perllib _((void));
static void init_postdump_symbols _((int, char **, char **));
static void init_predump_symbols _((void));
-static void init_stacks _((void));
static void my_exit_jump _((void)) __attribute__((noreturn));
static void nuke_stacks _((void));
static void open_script _((char *, bool, SV *));
static int fdscript = -1;
+#if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
+#include <asm/sigcontext.h>
+static void
+catch_sigsegv(int signo, struct sigcontext_struct sc)
+{
+ signal(SIGSEGV, SIG_DFL);
+ fprintf(stderr, "Segmentation fault dereferencing 0x%lx\n"
+ "return_address = 0x%lx, eip = 0x%lx\n",
+ sc.cr2, __builtin_return_address(0), sc.eip);
+ fprintf(stderr, "thread = 0x%lx\n", (unsigned long)THR);
+}
+#endif
+
PerlInterpreter *
perl_alloc()
{
perl_construct( sv_interp )
register PerlInterpreter *sv_interp;
{
+#if defined(USE_THREADS) && !defined(FAKE_THREADS)
+ struct thread *thr;
+#endif
+
if (!(curinterp = sv_interp))
return;
Zero(sv_interp, 1, PerlInterpreter);
#endif
- /* Init the real globals? */
+ /* Init the real globals (and main thread)? */
if (!linestr) {
+#ifdef USE_THREADS
+ INIT_THREADS;
+ New(53, thr, 1, struct thread);
+ MUTEX_INIT(&malloc_mutex);
+ MUTEX_INIT(&sv_mutex);
+ MUTEX_INIT(&eval_mutex);
+ COND_INIT(&eval_cond);
+ MUTEX_INIT(&threads_mutex);
+ COND_INIT(&nthreads_cond);
+ nthreads = 1;
+ cvcache = newHV();
+ curcop = &compiling;
+ thr->flags = THRf_R_JOINABLE;
+ MUTEX_INIT(&thr->mutex);
+ thr->next = thr;
+ thr->prev = thr;
+ thr->tid = 0;
+#ifdef HAVE_THREAD_INTERN
+ init_thread_intern(thr);
+#else
+ self = pthread_self();
+ if (pthread_key_create(&thr_key, 0))
+ croak("panic: pthread_key_create");
+ if (pthread_setspecific(thr_key, (void *) thr))
+ croak("panic: pthread_setspecific");
+#endif /* FAKE_THREADS */
+#endif /* USE_THREADS */
+
linestr = NEWSV(65,80);
sv_upgrade(linestr,SVt_PVIV);
nrs = newSVpv("\n", 1);
rs = SvREFCNT_inc(nrs);
+ sighandlerp = sighandler;
pidstatus = newHV();
#ifdef MSDOS
fdpid = newAV(); /* for remembering popen pids by fd */
- init_stacks();
+ init_stacks(ARGS);
+ DEBUG( {
+ New(51,debname,128,char);
+ New(52,debdelim,128,char);
+ } )
+
ENTER;
}
perl_destruct(sv_interp)
register PerlInterpreter *sv_interp;
{
+ dTHR;
int destruct_level; /* 0=none, 1=full, 2=full with checks */
I32 last_sv_count;
HV *hv;
+ Thread t;
if (!(curinterp = sv_interp))
return;
+#ifdef USE_THREADS
+#ifndef FAKE_THREADS
+ /* Join with any remaining non-detached threads */
+ MUTEX_LOCK(&threads_mutex);
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "perl_destruct: waiting for %d threads...\n",
+ nthreads - 1));
+ for (t = thr->next; t != thr; t = t->next) {
+ MUTEX_LOCK(&t->mutex);
+ switch (ThrSTATE(t)) {
+ AV *av;
+ case THRf_ZOMBIE:
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "perl_destruct: joining zombie %p\n", t));
+ ThrSETSTATE(t, THRf_DEAD);
+ MUTEX_UNLOCK(&t->mutex);
+ nthreads--;
+ MUTEX_UNLOCK(&threads_mutex);
+ if (pthread_join(t->Tself, (void**)&av))
+ croak("panic: pthread_join failed during global destruction");
+ SvREFCNT_dec((SV*)av);
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "perl_destruct: joined zombie %p OK\n", t));
+ break;
+ case THRf_R_JOINABLE:
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "perl_destruct: detaching thread %p\n", t));
+ ThrSETSTATE(t, THRf_R_DETACHED);
+ /*
+ * We unlock threads_mutex and t->mutex in the opposite order
+ * from which we locked them just so that DETACH won't
+ * deadlock if it panics. It's only a breach of good style
+ * not a bug since they are unlocks not locks.
+ */
+ MUTEX_UNLOCK(&threads_mutex);
+ DETACH(t);
+ MUTEX_UNLOCK(&t->mutex);
+ break;
+ default:
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "perl_destruct: ignoring %p (state %u)\n",
+ t, ThrSTATE(t)));
+ MUTEX_UNLOCK(&t->mutex);
+ MUTEX_UNLOCK(&threads_mutex);
+ /* fall through and out */
+ }
+ }
+ /* Now wait for the thread count nthreads to drop to one */
+ while (nthreads > 1)
+ {
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "perl_destruct: final wait for %d threads\n",
+ nthreads - 1));
+ COND_WAIT(&nthreads_cond, &threads_mutex);
+ }
+ /* At this point, we're the last thread */
+ MUTEX_UNLOCK(&threads_mutex);
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
+ MUTEX_DESTROY(&threads_mutex);
+ COND_DESTROY(&nthreads_cond);
+#endif /* !defined(FAKE_THREADS) */
+#endif /* USE_THREADS */
+
destruct_level = perl_destruct_level;
#ifdef DEBUGGING
{
/* startup and shutdown function lists */
SvREFCNT_dec(beginav);
SvREFCNT_dec(endav);
+ SvREFCNT_dec(initav);
beginav = Nullav;
endav = Nullav;
+ initav = Nullav;
/* temp stack during pp_sort() */
SvREFCNT_dec(sortstack);
hints = 0; /* Reset hints. Should hints be per-interpreter ? */
DEBUG_P(debprofdump());
+#ifdef USE_THREADS
+ MUTEX_DESTROY(&sv_mutex);
+ MUTEX_DESTROY(&malloc_mutex);
+ MUTEX_DESTROY(&eval_mutex);
+ COND_DESTROY(&eval_cond);
+#endif /* USE_THREADS */
/* As the absolutely last thing, free the non-arena SV for mess() */
char **argv;
char **env;
{
+ dTHR;
register SV *sv;
register char *s;
char *scriptname = NULL;
comppad_name_fill = 0;
min_intro_pending = 0;
padix = 0;
+#ifdef USE_THREADS
+ av_store(comppad_name, 0, newSVpv("@_", 2));
+ curpad[0] = (SV*)newAV();
+ SvPADMY_on(curpad[0]); /* XXX Needed? */
+ CvOWNER(compcv) = 0;
+ New(666, CvMUTEXP(compcv), 1, perl_mutex);
+ MUTEX_INIT(CvMUTEXP(compcv));
+#endif /* USE_THREADS */
comppadlist = newAV();
AvREAL_off(comppadlist);
init_os_extras();
#endif
+#if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
+ DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv););
+#endif
+
init_predump_symbols();
if (!do_undump)
init_postdump_symbols(argc,argv,env);
perl_run(sv_interp)
PerlInterpreter *sv_interp;
{
+ dTHR;
I32 oldscope;
dJMPENV;
int ret;
if (!restartop) {
DEBUG_x(dump_all());
DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
+#ifdef USE_THREADS
+ DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
+ (unsigned long) thr));
+#endif /* USE_THREADS */
if (minus_c) {
PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
}
if (PERLDB_SINGLE && DBsingle)
sv_setiv(DBsingle, 1);
+ if (initav)
+ call_list(oldscope, initav);
}
/* do it */
I32 flags; /* See G_* flags in cop.h */
register char **argv; /* null terminated arg list */
{
+ dTHR;
dSP;
PUSHMARK(sp);
char *methname; /* name of the subroutine */
I32 flags; /* See G_* flags in cop.h */
{
+ dTHR;
dSP;
OP myop;
if (!op)
op = &myop;
XPUSHs(sv_2mortal(newSVpv(methname,0)));
PUTBACK;
- pp_method();
+ pp_method(ARGS);
return perl_call_sv(*stack_sp--, flags);
}
SV* sv;
I32 flags; /* See G_* flags in cop.h */
{
+ dTHR;
LOGOP myop; /* fake syntax tree node */
SV** sp = stack_sp;
I32 oldmark;
myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
(flags & G_ARRAY) ? OPf_WANT_LIST :
OPf_WANT_SCALAR);
- SAVESPTR(op);
+ SAVEOP();
op = (OP*)&myop;
EXTEND(stack_sp, 1);
CATCH_SET(TRUE);
if (op == (OP*)&myop)
- op = pp_entersub();
+ op = pp_entersub(ARGS);
if (op)
runops();
retval = stack_sp - (stack_base + oldmark);
SV* sv;
I32 flags; /* See G_* flags in cop.h */
{
+ dTHR;
UNOP myop; /* fake syntax tree node */
SV** sp = stack_sp;
I32 oldmark = sp - stack_base;
SAVETMPS;
}
- SAVESPTR(op);
+ SAVEOP();
op = (OP*)&myop;
Zero(op, 1, UNOP);
EXTEND(stack_sp, 1);
}
if (op == (OP*)&myop)
- op = pp_entereval();
+ op = pp_entereval(ARGS);
if (op)
runops();
retval = stack_sp - (stack_base + oldmark);
char* p;
I32 croak_on_error;
{
+ dTHR;
dSP;
SV* sv = newSVpv(p, 0);
forbid_setid("-m"); /* XXX ? */
if (*++s) {
char *start;
+ SV *sv;
char *use = "use ";
/* -M-foo == 'no foo' */
if (*s == '-') { use = "no "; ++s; }
- Sv = newSVpv(use,0);
+ sv = newSVpv(use,0);
start = s;
/* We allow -M'Module qw(Foo Bar)' */
while(isALNUM(*s) || *s==':') ++s;
if (*s != '=') {
- sv_catpv(Sv, start);
+ sv_catpv(sv, start);
if (*(start-1) == 'm') {
if (*s != '\0')
croak("Can't use '%c' after -mname", *s);
- sv_catpv( Sv, " ()");
+ sv_catpv( sv, " ()");
}
} else {
- sv_catpvn(Sv, start, s-start);
- sv_catpv(Sv, " split(/,/,q{");
- sv_catpv(Sv, ++s);
- sv_catpv(Sv, "})");
+ sv_catpvn(sv, start, s-start);
+ sv_catpv(sv, " split(/,/,q{");
+ sv_catpv(sv, ++s);
+ sv_catpv(sv, "})");
}
s += strlen(s);
if (preambleav == NULL)
preambleav = newAV();
- av_push(preambleav, Sv);
+ av_push(preambleav, sv);
}
else
croak("No space allowed after -%c", *(s-1));
static void
init_main_stash()
{
+ dTHR;
GV *gv;
/* Note that strtab is a rather special HV. Assumptions are made
SV *sv;
#endif
{
+ dTHR;
char *xfound = Nullch;
char *xfailed = Nullch;
register char *s;
#else /* !DOSUID */
if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
+ dTHR;
Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
||
static void
init_debugger()
{
+ dTHR;
curstash = debstash;
dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
AvREAL_off(dbargs);
curstash = defstash;
}
-static void
-init_stacks()
+void
+init_stacks(ARGS)
+dARGS
{
curstack = newAV();
mainstack = curstack; /* remember in case we switch stacks */
cxstack_ix = -1;
New(50,tmps_stack,128,SV*);
+ tmps_floor = -1;
tmps_ix = -1;
tmps_max = 128;
- DEBUG( {
- New(51,debname,128,char);
- New(52,debdelim,128,char);
- } )
-
/*
* The following stacks almost certainly should be per-interpreter,
* but for now they're not. XXX
static void
nuke_stacks()
{
+ dTHR;
Safefree(cxstack);
Safefree(tmps_stack);
DEBUG( {
static void
init_predump_symbols()
{
+ dTHR;
GV *tmpgv;
GV *othergv;
I32 oldscope;
AV* list;
{
+ dTHR;
line_t oldline = curcop->cop_line;
STRLEN len;
dJMPENV;
my_exit(status)
U32 status;
{
+ dTHR;
+
+#ifdef USE_THREADS
+ DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread 0x%lx, status %lu\n",
+ (unsigned long) thr, (unsigned long) status));
+#endif /* USE_THREADS */
switch (status) {
case 0:
STATUS_ALL_SUCCESS;
static void
my_exit_jump()
{
+ dTHR;
register CONTEXT *cx;
I32 gimme;
SV **newsp;
#include "embed.h"
+#ifdef OP_IN_REGISTER
+# ifdef __GNUC__
+# define stringify_immed(s) #s
+# define stringify(s) stringify_immed(s)
+register struct op *op asm(stringify(OP_IN_REGISTER));
+# endif
+#endif
+
/*
* STMT_START { statements; } STMT_END;
* can be used as a single statement, as in
# endif
#endif
+#define NOOP (void)0
+
+#define WITH_THR(s) do { dTHR; s; } while (0)
+#ifdef USE_THREADS
+#ifdef FAKE_THREADS
+#include "fakethr.h"
+#else
+#include <pthread.h>
+typedef pthread_mutex_t perl_mutex;
+typedef pthread_cond_t perl_cond;
+typedef pthread_key_t perl_key;
+#endif /* FAKE_THREADS */
+#endif /* USE_THREADS */
+
/*
* SOFT_CAST can be used for args to prototyped functions to retain some
* type checking; it only casts if the compiler does not know prototypes.
#endif
+/* Digital UNIX defines a typedef CONTEXT when pthreads is in use */
+#if defined(__osf__)
+# define CONTEXT PERL_CONTEXT
+#endif
+
typedef MEM_SIZE STRLEN;
typedef struct op OP;
void (*any_dptr) _((void*));
};
+#ifdef USE_THREADS
+#define ARGSproto struct thread *
+#else
+#define ARGSproto void
+#endif /* USE_THREADS */
+
/* Work around some cygwin32 problems with importing global symbols */
#if defined(CYGWIN32) && defined(DLLIMPORT)
# include "cw32imp.h"
# define register
# 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
/****************/
/* global state */
EXT PerlInterpreter * curinterp; /* currently running interpreter */
+#ifdef USE_THREADS
+EXT perl_key thr_key; /* For per-thread struct thread ptr */
+EXT perl_mutex sv_mutex; /* Mutex for allocating SVs in sv.c */
+EXT perl_mutex malloc_mutex; /* Mutex for malloc */
+EXT perl_mutex eval_mutex; /* Mutex for doeval */
+EXT perl_cond eval_cond; /* Condition variable for doeval */
+EXT struct thread * eval_owner; /* Owner thread for doeval */
+EXT int nthreads; /* Number of threads currently */
+EXT perl_mutex threads_mutex; /* Mutex for nthreads and thread list */
+EXT perl_cond nthreads_cond; /* Condition variable for nthreads */
+#ifdef FAKE_THREADS
+EXT struct thread * thr; /* Currently executing (fake) thread */
+#endif
+#endif /* USE_THREADS */
+
/* VMS doesn't use environ array and NeXT has problems with crt0.o globals */
#if !defined(VMS) && !(defined(NeXT) && defined(__DYNAMIC__))
#ifndef DONT_DECLARE_STD
EXT int maxo INIT(MAXO);/* Number of ops */
EXT char * osname; /* operating system */
EXT char * sh_path INIT(SH_PATH); /* full path of shell */
+EXT Sighandler_t sighandlerp;
EXT XPV* xiv_arenaroot; /* list of allocated xiv areas */
EXT IV ** xiv_root; /* free xiv list--shared by interpreters */
/* likewise for these */
-EXT OP * op; /* current op--oughta be in a global register */
-
+#ifdef OP_IN_REGISTER
+EXT OP * opsave; /* save current op register across longjmps */
+#else
+EXT OP * op; /* current op--when not in a global register */
+#endif
+EXT int (*runops) _((void)) INIT(RUNOPS_DEFAULT);
EXT I32 * scopestack; /* blocks we've entered */
EXT I32 scopestack_ix;
EXT I32 scopestack_max;
EXT char * last_lop; /* position of last list operator */
EXT OPCODE last_lop_op; /* last list operator */
EXT bool in_my; /* we're compiling a "my" declaration */
+EXT HV * in_my_stash; /* declared class of this "my" declaration */
#ifdef FCRYPT
EXT I32 cryptseen; /* has fast crypt() been initialized? */
#endif
IEXT SV * Icurstname; /* name of current package */
IEXT AV * Ibeginav; /* names of BEGIN subroutines */
IEXT AV * Iendav; /* names of END subroutines */
+IEXT AV * Iinitav; /* names of INIT subroutines */
IEXT HV * Istrtab; /* shared string table */
/* memory management */
/* stack stuff */
IEXT AV * Icurstack; /* THE STACK */
IEXT AV * Imainstack; /* the stack when nothing funny is happening */
-IEXT SV ** Imystack_base; /* stack->array_ary */
-IEXT SV ** Imystack_sp; /* stack pointer now */
-IEXT SV ** Imystack_max; /* stack->array_ary + stack->array_max */
/* format accumulators */
IEXT SV * Iformtarget;
};
#endif
+#include "thread.h"
#include "pp.h"
#ifdef __cplusplus
EXT MGVTBL vtbl_uvar = {magic_getuvar,
magic_setuvar,
0, 0, 0};
+#ifdef USE_THREADS
+EXT MGVTBL vtbl_mutex = {0, 0, 0, 0, magic_mutexfree};
+#endif /* USE_THREADS */
EXT MGVTBL vtbl_defelem = {magic_getdefelem,magic_setdefelem,
0, 0, magic_freedefelem};
EXT MGVTBL vtbl_bm;
EXT MGVTBL vtbl_fm;
EXT MGVTBL vtbl_uvar;
+
+#ifdef USE_THREADS
+EXT MGVTBL vtbl_mutex;
+#endif /* USE_THREADS */
+
EXT MGVTBL vtbl_defelem;
#ifdef USE_LOCALE_COLLATE
#define printf PerlIO_stdoutf
#endif
+/*
+ * nice_chunk and nice_chunk size need to be set
+ * and queried under the protection of sv_mutex
+ */
+#define offer_nice_chunk(chunk, chunk_size) do { \
+ MUTEX_LOCK(&sv_mutex); \
+ if (!nice_chunk) { \
+ nice_chunk = (char*)(chunk); \
+ nice_chunk_size = (chunk_size); \
+ } \
+ MUTEX_UNLOCK(&sv_mutex); \
+ } while (0)
+
#endif /* Include guard */
int yychar;
YYSTYPE yyval;
YYSTYPE yylval;
-#line 631 "perly.y"
+#line 632 "perly.y"
/* PROGRAM */
#line 1360 "perly.c"
#define YYABORT goto yyabort
break;
case 56:
#line 291 "perly.y"
-{ char *name = SvPVx(((SVOP*)yyvsp[0].opval)->op_sv, na);
- if (strEQ(name, "BEGIN") || strEQ(name, "END"))
+{ char *name = SvPV(((SVOP*)yyvsp[0].opval)->op_sv, na);
+ if (strEQ(name, "BEGIN") || strEQ(name, "END")
+ || strEQ(name, "INIT"))
CvUNIQUE_on(compcv);
yyval.opval = yyvsp[0].opval; }
break;
case 57:
-#line 298 "perly.y"
+#line 299 "perly.y"
{ yyval.opval = Nullop; }
break;
case 59:
-#line 302 "perly.y"
+#line 303 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 60:
-#line 303 "perly.y"
+#line 304 "perly.y"
{ yyval.opval = Nullop; expect = XSTATE; }
break;
case 61:
-#line 307 "perly.y"
+#line 308 "perly.y"
{ package(yyvsp[-1].opval); }
break;
case 62:
-#line 309 "perly.y"
+#line 310 "perly.y"
{ package(Nullop); }
break;
case 63:
-#line 313 "perly.y"
+#line 314 "perly.y"
{ CvUNIQUE_on(compcv); /* It's a BEGIN {} */ }
break;
case 64:
-#line 315 "perly.y"
+#line 316 "perly.y"
{ utilize(yyvsp[-6].ival, yyvsp[-5].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval); }
break;
case 65:
-#line 319 "perly.y"
+#line 320 "perly.y"
{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 66:
-#line 321 "perly.y"
+#line 322 "perly.y"
{ yyval.opval = newLOGOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 68:
-#line 326 "perly.y"
+#line 327 "perly.y"
{ yyval.opval = yyvsp[-1].opval; }
break;
case 69:
-#line 328 "perly.y"
+#line 329 "perly.y"
{ yyval.opval = append_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 71:
-#line 333 "perly.y"
+#line 334 "perly.y"
{ yyval.opval = convert(yyvsp[-2].ival, OPf_STACKED,
prepend_elem(OP_LIST, newGVREF(yyvsp[-2].ival,yyvsp[-1].opval), yyvsp[0].opval) ); }
break;
case 72:
-#line 336 "perly.y"
+#line 337 "perly.y"
{ yyval.opval = convert(yyvsp[-4].ival, OPf_STACKED,
prepend_elem(OP_LIST, newGVREF(yyvsp[-4].ival,yyvsp[-2].opval), yyvsp[-1].opval) ); }
break;
case 73:
-#line 339 "perly.y"
+#line 340 "perly.y"
{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, scalar(yyvsp[-5].opval), yyvsp[-1].opval),
newUNOP(OP_METHOD, 0, yyvsp[-3].opval))); }
break;
case 74:
-#line 344 "perly.y"
+#line 345 "perly.y"
{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, yyvsp[-1].opval, yyvsp[0].opval),
newUNOP(OP_METHOD, 0, yyvsp[-2].opval))); }
break;
case 75:
-#line 349 "perly.y"
+#line 350 "perly.y"
{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, yyvsp[-3].opval, yyvsp[-1].opval),
newUNOP(OP_METHOD, 0, yyvsp[-4].opval))); }
break;
case 76:
-#line 354 "perly.y"
+#line 355 "perly.y"
{ yyval.opval = convert(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
case 77:
-#line 356 "perly.y"
+#line 357 "perly.y"
{ yyval.opval = convert(yyvsp[-3].ival, 0, yyvsp[-1].opval); }
break;
case 78:
-#line 358 "perly.y"
+#line 359 "perly.y"
{ yyvsp[0].opval = newANONSUB(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
case 79:
-#line 360 "perly.y"
+#line 361 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval), yyvsp[-4].opval)); }
break;
case 82:
-#line 370 "perly.y"
+#line 371 "perly.y"
{ yyval.opval = newASSIGNOP(OPf_STACKED, yyvsp[-2].opval, yyvsp[-1].ival, yyvsp[0].opval); }
break;
case 83:
-#line 372 "perly.y"
+#line 373 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 84:
-#line 374 "perly.y"
+#line 375 "perly.y"
{ if (yyvsp[-1].ival != OP_REPEAT)
scalar(yyvsp[-2].opval);
yyval.opval = newBINOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, scalar(yyvsp[0].opval)); }
break;
case 85:
-#line 378 "perly.y"
+#line 379 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 86:
-#line 380 "perly.y"
+#line 381 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 87:
-#line 382 "perly.y"
+#line 383 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 88:
-#line 384 "perly.y"
+#line 385 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 89:
-#line 386 "perly.y"
+#line 387 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 90:
-#line 388 "perly.y"
+#line 389 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 91:
-#line 390 "perly.y"
+#line 391 "perly.y"
{ yyval.opval = newRANGE(yyvsp[-1].ival, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval));}
break;
case 92:
-#line 392 "perly.y"
+#line 393 "perly.y"
{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 93:
-#line 394 "perly.y"
+#line 395 "perly.y"
{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 94:
-#line 396 "perly.y"
+#line 397 "perly.y"
{ yyval.opval = newCONDOP(0, yyvsp[-4].opval, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 95:
-#line 398 "perly.y"
+#line 399 "perly.y"
{ yyval.opval = bind_match(yyvsp[-1].ival, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 96:
-#line 401 "perly.y"
+#line 402 "perly.y"
{ yyval.opval = newUNOP(OP_NEGATE, 0, scalar(yyvsp[0].opval)); }
break;
case 97:
-#line 403 "perly.y"
+#line 404 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 98:
-#line 405 "perly.y"
+#line 406 "perly.y"
{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); }
break;
case 99:
-#line 407 "perly.y"
+#line 408 "perly.y"
{ yyval.opval = newUNOP(OP_COMPLEMENT, 0, scalar(yyvsp[0].opval));}
break;
case 100:
-#line 409 "perly.y"
+#line 410 "perly.y"
{ yyval.opval = newUNOP(OP_REFGEN, 0, mod(yyvsp[0].opval,OP_REFGEN)); }
break;
case 101:
-#line 411 "perly.y"
+#line 412 "perly.y"
{ yyval.opval = newUNOP(OP_POSTINC, 0,
mod(scalar(yyvsp[-1].opval), OP_POSTINC)); }
break;
case 102:
-#line 414 "perly.y"
+#line 415 "perly.y"
{ yyval.opval = newUNOP(OP_POSTDEC, 0,
mod(scalar(yyvsp[-1].opval), OP_POSTDEC)); }
break;
case 103:
-#line 417 "perly.y"
+#line 418 "perly.y"
{ yyval.opval = newUNOP(OP_PREINC, 0,
mod(scalar(yyvsp[0].opval), OP_PREINC)); }
break;
case 104:
-#line 420 "perly.y"
+#line 421 "perly.y"
{ yyval.opval = newUNOP(OP_PREDEC, 0,
mod(scalar(yyvsp[0].opval), OP_PREDEC)); }
break;
case 105:
-#line 423 "perly.y"
+#line 424 "perly.y"
{ yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); }
break;
case 106:
-#line 425 "perly.y"
+#line 426 "perly.y"
{ yyval.opval = sawparens(yyvsp[-1].opval); }
break;
case 107:
-#line 427 "perly.y"
+#line 428 "perly.y"
{ yyval.opval = sawparens(newNULLLIST()); }
break;
case 108:
-#line 429 "perly.y"
+#line 430 "perly.y"
{ yyval.opval = newANONLIST(yyvsp[-1].opval); }
break;
case 109:
-#line 431 "perly.y"
+#line 432 "perly.y"
{ yyval.opval = newANONLIST(Nullop); }
break;
case 110:
-#line 433 "perly.y"
+#line 434 "perly.y"
{ yyval.opval = newANONHASH(yyvsp[-2].opval); }
break;
case 111:
-#line 435 "perly.y"
+#line 436 "perly.y"
{ yyval.opval = newANONHASH(Nullop); }
break;
case 112:
-#line 437 "perly.y"
+#line 438 "perly.y"
{ yyval.opval = newANONSUB(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); }
break;
case 113:
-#line 439 "perly.y"
+#line 440 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 114:
-#line 441 "perly.y"
+#line 442 "perly.y"
{ yyval.opval = newBINOP(OP_GELEM, 0, newGVREF(0,yyvsp[-4].opval), yyvsp[-2].opval); }
break;
case 115:
-#line 443 "perly.y"
+#line 444 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 116:
-#line 445 "perly.y"
+#line 446 "perly.y"
{ yyval.opval = newBINOP(OP_AELEM, 0, oopsAV(yyvsp[-3].opval), scalar(yyvsp[-1].opval)); }
break;
case 117:
-#line 447 "perly.y"
+#line 448 "perly.y"
{ yyval.opval = newBINOP(OP_AELEM, 0,
ref(newAVREF(yyvsp[-4].opval),OP_RV2AV),
scalar(yyvsp[-1].opval));}
break;
case 118:
-#line 451 "perly.y"
+#line 452 "perly.y"
{ assertref(yyvsp[-3].opval); yyval.opval = newBINOP(OP_AELEM, 0,
ref(newAVREF(yyvsp[-3].opval),OP_RV2AV),
scalar(yyvsp[-1].opval));}
break;
case 119:
-#line 455 "perly.y"
+#line 456 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 120:
-#line 457 "perly.y"
+#line 458 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 121:
-#line 459 "perly.y"
+#line 460 "perly.y"
{ yyval.opval = newUNOP(OP_AV2ARYLEN, 0, ref(yyvsp[0].opval, OP_AV2ARYLEN));}
break;
case 122:
-#line 461 "perly.y"
+#line 462 "perly.y"
{ yyval.opval = newBINOP(OP_HELEM, 0, oopsHV(yyvsp[-4].opval), jmaybe(yyvsp[-2].opval));
expect = XOPERATOR; }
break;
case 123:
-#line 464 "perly.y"
+#line 465 "perly.y"
{ yyval.opval = newBINOP(OP_HELEM, 0,
ref(newHVREF(yyvsp[-5].opval),OP_RV2HV),
jmaybe(yyvsp[-2].opval));
expect = XOPERATOR; }
break;
case 124:
-#line 469 "perly.y"
+#line 470 "perly.y"
{ assertref(yyvsp[-4].opval); yyval.opval = newBINOP(OP_HELEM, 0,
ref(newHVREF(yyvsp[-4].opval),OP_RV2HV),
jmaybe(yyvsp[-2].opval));
expect = XOPERATOR; }
break;
case 125:
-#line 474 "perly.y"
+#line 475 "perly.y"
{ yyval.opval = newSLICEOP(0, yyvsp[-1].opval, yyvsp[-4].opval); }
break;
case 126:
-#line 476 "perly.y"
+#line 477 "perly.y"
{ yyval.opval = newSLICEOP(0, yyvsp[-1].opval, Nullop); }
break;
case 127:
-#line 478 "perly.y"
+#line 479 "perly.y"
{ yyval.opval = prepend_elem(OP_ASLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_ASLICE, 0,
ref(yyvsp[-3].opval, OP_ASLICE))); }
break;
case 128:
-#line 484 "perly.y"
+#line 485 "perly.y"
{ yyval.opval = prepend_elem(OP_HSLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_HSLICE, 0,
expect = XOPERATOR; }
break;
case 129:
-#line 491 "perly.y"
+#line 492 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 130:
-#line 493 "perly.y"
+#line 494 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, 0, scalar(yyvsp[0].opval)); }
break;
case 131:
-#line 495 "perly.y"
+#line 496 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[-2].opval)); }
break;
case 132:
-#line 497 "perly.y"
+#line 498 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[-1].opval, scalar(yyvsp[-3].opval))); }
break;
case 133:
-#line 500 "perly.y"
+#line 501 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); }
break;
case 134:
-#line 503 "perly.y"
+#line 504 "perly.y"
{ yyval.opval = newUNOP(OP_DOFILE, 0, scalar(yyvsp[0].opval)); }
break;
case 135:
-#line 505 "perly.y"
+#line 506 "perly.y"
{ yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); }
break;
case 136:
-#line 507 "perly.y"
+#line 508 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB,
OPf_SPECIAL|OPf_STACKED,
prepend_elem(OP_LIST,
)),Nullop)); dep();}
break;
case 137:
-#line 515 "perly.y"
+#line 516 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB,
OPf_SPECIAL|OPf_STACKED,
append_elem(OP_LIST,
)))); dep();}
break;
case 138:
-#line 524 "perly.y"
+#line 525 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED,
prepend_elem(OP_LIST,
scalar(newCVREF(0,scalar(yyvsp[-2].opval))), Nullop)); dep();}
break;
case 139:
-#line 528 "perly.y"
+#line 529 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED,
prepend_elem(OP_LIST,
yyvsp[-1].opval,
scalar(newCVREF(0,scalar(yyvsp[-3].opval))))); dep();}
break;
case 140:
-#line 533 "perly.y"
+#line 534 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
newCVREF(0, scalar(yyvsp[-3].opval))); }
break;
case 141:
-#line 536 "perly.y"
+#line 537 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[-1].opval,
newCVREF(0, scalar(yyvsp[-4].opval)))); }
break;
case 142:
-#line 540 "perly.y"
+#line 541 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL);
hints |= HINT_BLOCK_SCOPE; }
break;
case 143:
-#line 543 "perly.y"
+#line 544 "perly.y"
{ yyval.opval = newLOOPEX(yyvsp[-1].ival,yyvsp[0].opval); }
break;
case 144:
-#line 545 "perly.y"
+#line 546 "perly.y"
{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); }
break;
case 145:
-#line 547 "perly.y"
+#line 548 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, 0); }
break;
case 146:
-#line 549 "perly.y"
+#line 550 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
case 147:
-#line 551 "perly.y"
+#line 552 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
case 148:
-#line 553 "perly.y"
+#line 554 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); }
break;
case 149:
-#line 556 "perly.y"
+#line 557 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, 0); }
break;
case 150:
-#line 558 "perly.y"
+#line 559 "perly.y"
{ yyval.opval = newOP(yyvsp[-2].ival, 0); }
break;
case 151:
-#line 560 "perly.y"
+#line 561 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
scalar(yyvsp[0].opval)); }
break;
case 152:
-#line 563 "perly.y"
+#line 564 "perly.y"
{ yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); }
break;
case 153:
-#line 565 "perly.y"
+#line 566 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); }
break;
case 154:
-#line 567 "perly.y"
+#line 568 "perly.y"
{ yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); }
break;
case 155:
-#line 569 "perly.y"
+#line 570 "perly.y"
{ yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); }
break;
case 158:
-#line 575 "perly.y"
+#line 576 "perly.y"
{ yyval.opval = Nullop; }
break;
case 159:
-#line 577 "perly.y"
+#line 578 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 160:
-#line 581 "perly.y"
+#line 582 "perly.y"
{ yyval.opval = Nullop; }
break;
case 161:
-#line 583 "perly.y"
+#line 584 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 162:
-#line 585 "perly.y"
+#line 586 "perly.y"
{ yyval.opval = yyvsp[-1].opval; }
break;
case 163:
-#line 588 "perly.y"
+#line 589 "perly.y"
{ yyval.ival = 0; }
break;
case 164:
-#line 589 "perly.y"
+#line 590 "perly.y"
{ yyval.ival = 1; }
break;
case 165:
-#line 593 "perly.y"
+#line 594 "perly.y"
{ in_my = 0; yyval.opval = my(yyvsp[0].opval); }
break;
case 166:
-#line 597 "perly.y"
+#line 598 "perly.y"
{ yyval.opval = newCVREF(yyvsp[-1].ival,yyvsp[0].opval); }
break;
case 167:
-#line 601 "perly.y"
+#line 602 "perly.y"
{ yyval.opval = newSVREF(yyvsp[0].opval); }
break;
case 168:
-#line 605 "perly.y"
+#line 606 "perly.y"
{ yyval.opval = newAVREF(yyvsp[0].opval); }
break;
case 169:
-#line 609 "perly.y"
+#line 610 "perly.y"
{ yyval.opval = newHVREF(yyvsp[0].opval); }
break;
case 170:
-#line 613 "perly.y"
+#line 614 "perly.y"
{ yyval.opval = newAVREF(yyvsp[0].opval); }
break;
case 171:
-#line 617 "perly.y"
+#line 618 "perly.y"
{ yyval.opval = newGVREF(0,yyvsp[0].opval); }
break;
case 172:
-#line 621 "perly.y"
+#line 622 "perly.y"
{ yyval.opval = scalar(yyvsp[0].opval); }
break;
case 173:
-#line 623 "perly.y"
+#line 624 "perly.y"
{ yyval.opval = scalar(yyvsp[0].opval); }
break;
case 174:
-#line 625 "perly.y"
+#line 626 "perly.y"
{ yyval.opval = scope(yyvsp[0].opval); }
break;
case 175:
-#line 628 "perly.y"
+#line 629 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-#line 2271 "perly.c"
+#line 2272 "perly.c"
}
yyssp -= yym;
yystate = *yyssp;
{ $$ = start_subparse(TRUE, 0); }
;
-subname : WORD { char *name = SvPVx(((SVOP*)$1)->op_sv, na);
- if (strEQ(name, "BEGIN") || strEQ(name, "END"))
+subname : WORD { char *name = SvPV(((SVOP*)$1)->op_sv, na);
+ if (strEQ(name, "BEGIN") || strEQ(name, "END")
+ || strEQ(name, "INIT"))
CvUNIQUE_on(compcv);
$$ = $1; }
;
else if (SvPADTMP(sv))
sv = newSVsv(sv);
else {
+ dTHR; /* just for SvREFCNT_inc */
SvTEMP_off(sv);
(void)SvREFCNT_inc(sv);
}
#define SEED_C3 269
#define SEED_C5 26107
+ dTHR;
U32 u;
#ifdef VMS
# include <starlet.h>
HV *hash = (HV*)POPs;
HE *entry;
I32 gimme = GIMME_V;
+ I32 realhv = (SvTYPE(hash) == SVt_PVHV);
PUTBACK;
- entry = hv_iternext(hash); /* might clobber stack_sp */
+ /* might clobber stack_sp */
+ entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
SPAGAIN;
EXTEND(SP, 2);
PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
if (gimme == G_ARRAY) {
PUTBACK;
- sv_setsv(TARG, hv_iterval(hash, entry)); /* might hit stack_sp */
+ /* might clobber stack_sp */
+ sv_setsv(TARG, realhv ?
+ hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
SPAGAIN;
PUSHs(TARG);
}
if (op->op_private & OPpSLICE) {
dMARK; dORIGMARK;
+ U32 hvtype;
hv = (HV*)POPs;
- if (SvTYPE(hv) != SVt_PVHV)
- DIE("Not a HASH reference");
+ hvtype = SvTYPE(hv);
while (++MARK <= SP) {
- sv = hv_delete_ent(hv, *MARK, discard, 0);
+ if (hvtype == SVt_PVHV)
+ sv = hv_delete_ent(hv, *MARK, discard, 0);
+ else if (hvtype == SVt_PVAV)
+ sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
+ else
+ DIE("Not a HASH reference");
*MARK = sv ? sv : &sv_undef;
}
if (discard)
else {
SV *keysv = POPs;
hv = (HV*)POPs;
- if (SvTYPE(hv) != SVt_PVHV)
+ if (SvTYPE(hv) == SVt_PVHV)
+ sv = hv_delete_ent(hv, keysv, discard, 0);
+ else if (SvTYPE(hv) == SVt_PVAV)
+ sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
+ else
DIE("Not a HASH reference");
- sv = hv_delete_ent(hv, keysv, discard, 0);
if (!sv)
sv = &sv_undef;
if (!discard)
dSP;
SV *tmpsv = POPs;
HV *hv = (HV*)POPs;
- STRLEN len;
- if (SvTYPE(hv) != SVt_PVHV) {
+ if (SvTYPE(hv) == SVt_PVHV) {
+ if (hv_exists_ent(hv, tmpsv, 0))
+ RETPUSHYES;
+ } else if (SvTYPE(hv) == SVt_PVAV) {
+ if (avhv_exists_ent((AV*)hv, tmpsv, 0))
+ RETPUSHYES;
+ } else {
DIE("Not a HASH reference");
}
- if (hv_exists_ent(hv, tmpsv, 0))
- RETPUSHYES;
RETPUSHNO;
}
register HE *he;
register HV *hv = (HV*)POPs;
register I32 lval = op->op_flags & OPf_MOD;
+ I32 realhv = (SvTYPE(hv) == SVt_PVHV);
- if (SvTYPE(hv) == SVt_PVHV) {
+ if (realhv || SvTYPE(hv) == SVt_PVAV) {
while (++MARK <= SP) {
SV *keysv = *MARK;
-
- he = hv_fetch_ent(hv, keysv, lval, 0);
+ SV **svp;
+ if (realhv) {
+ he = hv_fetch_ent(hv, keysv, lval, 0);
+ svp = he ? &HeVAL(he) : 0;
+ } else {
+ svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
+ }
if (lval) {
if (!he || HeVAL(he) == &sv_undef)
DIE(no_helem, SvPV(keysv, na));
if (pm->op_pmreplroot)
ary = GvAVn((GV*)pm->op_pmreplroot);
else if (gimme != G_ARRAY)
+#ifdef USE_THREADS
+ ary = (AV*)curpad[0];
+#else
ary = GvAVn(defgv);
+#endif /* USE_THREADS */
else
ary = Nullav;
if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
RETPUSHUNDEF;
}
+#ifdef USE_THREADS
+void
+unlock_condpair(svv)
+void *svv;
+{
+ dTHR;
+ MAGIC *mg = mg_find((SV*)svv, 'm');
+
+ if (!mg)
+ croak("panic: unlock_condpair unlocking non-mutex");
+ MUTEX_LOCK(MgMUTEXP(mg));
+ if (MgOWNER(mg) != thr)
+ croak("panic: unlock_condpair unlocking mutex that we don't own");
+ MgOWNER(mg) = 0;
+ COND_SIGNAL(MgOWNERCONDP(mg));
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
+ (unsigned long)thr, (unsigned long)svv);)
+ MUTEX_UNLOCK(MgMUTEXP(mg));
+}
+#endif /* USE_THREADS */
+
+PP(pp_lock)
+{
+ dSP;
+#ifdef USE_THREADS
+ dTOPss;
+ MAGIC *mg;
+
+ if (SvROK(sv))
+ sv = SvRV(sv);
+
+ mg = condpair_magic(sv);
+ MUTEX_LOCK(MgMUTEXP(mg));
+ if (MgOWNER(mg) == thr)
+ MUTEX_UNLOCK(MgMUTEXP(mg));
+ else {
+ while (MgOWNER(mg))
+ COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
+ MgOWNER(mg) = thr;
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
+ (unsigned long)thr, (unsigned long)sv);)
+ MUTEX_UNLOCK(MgMUTEXP(mg));
+ save_destructor(unlock_condpair, sv);
+ }
+#endif /* USE_THREADS */
+ RETURN;
+}
*
*/
+#ifdef USE_THREADS
+#define ARGS thr
+#define dARGS struct thread *thr;
+#define PP(s) OP* s(ARGS) dARGS
+#else
#define ARGS
-#define ARGSproto void
#define dARGS
#define PP(s) OP* s(ARGS) dARGS
+#endif /* USE_THREADS */
#define SP sp
#define MARK mark
static OP *docatch _((OP *o));
static OP *doeval _((int gimme));
-static OP *dofindlabel _((OP *op, char *label, OP **opstack, OP **oplimit));
+static OP *dofindlabel _((OP *o, char *label, OP **opstack, OP **oplimit));
static void doparseform _((SV *sv));
static I32 dopoptoeval _((I32 startingblock));
static I32 dopoptolabel _((char *label));
RETURNOP(op->op_next->op_next);
}
stack_sp = stack_base + *markstack_ptr + 1;
- pp_pushmark(); /* push dst */
- pp_pushmark(); /* push src */
+ pp_pushmark(ARGS); /* push dst */
+ pp_pushmark(ARGS); /* push src */
ENTER; /* enter outer scope */
SAVETMPS;
PUTBACK;
if (op->op_type == OP_MAPSTART)
- pp_pushmark(); /* push top */
+ pp_pushmark(ARGS); /* push top */
return ((LOGOP*)op->op_next)->op_other;
}
bool oldcatch = CATCH_GET;
SAVETMPS;
- SAVESPTR(op);
+ SAVEOP();
oldstack = curstack;
if (!sortstack) {
dopoptolabel(label)
char *label;
{
+ dTHR;
register I32 i;
register CONTEXT *cx;
I32
block_gimme()
{
+ dTHR;
I32 cxix;
cxix = dopoptosub(cxstack_ix);
dopoptosub(startingblock)
I32 startingblock;
{
+ dTHR;
I32 i;
register CONTEXT *cx;
for (i = startingblock; i >= 0; i--) {
dopoptoeval(startingblock)
I32 startingblock;
{
+ dTHR;
I32 i;
register CONTEXT *cx;
for (i = startingblock; i >= 0; i--) {
dopoptoloop(startingblock)
I32 startingblock;
{
+ dTHR;
I32 i;
register CONTEXT *cx;
for (i = startingblock; i >= 0; i--) {
dounwind(cxix)
I32 cxix;
{
+ dTHR;
register CONTEXT *cx;
SV **newsp;
I32 optype;
die_where(message)
char *message;
{
+ dTHR;
if (in_eval) {
I32 cxix;
register CONTEXT *cx;
mark++;
}
*sp = cv;
- return pp_entersub();
+ return pp_entersub(ARGS);
}
#endif
const void *a;
const void *b;
{
+ dTHR;
SV * const *str1 = (SV * const *)a;
SV * const *str2 = (SV * const *)b;
I32 oldsaveix = savestack_ix;
static OP* lastgotoprobe;
static OP *
-dofindlabel(op,label,opstack,oplimit)
-OP *op;
+dofindlabel(o,label,opstack,oplimit)
+OP *o;
char *label;
OP **opstack;
OP **oplimit;
if (ops >= oplimit)
croak(too_deep);
- if (op->op_type == OP_LEAVE ||
- op->op_type == OP_SCOPE ||
- op->op_type == OP_LEAVELOOP ||
- op->op_type == OP_LEAVETRY)
+ if (o->op_type == OP_LEAVE ||
+ o->op_type == OP_SCOPE ||
+ o->op_type == OP_LEAVELOOP ||
+ o->op_type == OP_LEAVETRY)
{
- *ops++ = cUNOP->op_first;
+ *ops++ = cUNOPo->op_first;
if (ops >= oplimit)
croak(too_deep);
}
*ops = 0;
- if (op->op_flags & OPf_KIDS) {
+ if (o->op_flags & OPf_KIDS) {
/* First try all the kids at this level, since that's likeliest. */
- for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) {
+ for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
kCOP->cop_label && strEQ(kCOP->cop_label, label))
return kid;
}
- for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) {
+ for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
if (kid == lastgotoprobe)
continue;
if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
(ops[-1]->op_type != OP_NEXTSTATE &&
ops[-1]->op_type != OP_DBSTATE)))
*ops++ = kid;
- if (op = dofindlabel(kid, label, ops, oplimit))
- return op;
+ if (o = dofindlabel(kid, label, ops, oplimit))
+ return o;
}
}
*ops = 0;
EXTEND(stack_sp, items); /* @_ could have been extended. */
Copy(AvARRAY(av), stack_sp, items, SV*);
stack_sp += items;
+#ifndef USE_THREADS
SvREFCNT_dec(GvAV(defgv));
GvAV(defgv) = cx->blk_sub.savearray;
+#endif /* USE_THREADS */
AvREAL_off(av);
av_clear(av);
}
svp = AvARRAY(padlist);
}
}
+#ifdef USE_THREADS
+ if (!cx->blk_sub.hasargs) {
+ AV* av = (AV*)curpad[0];
+
+ items = AvFILL(av) + 1;
+ if (items) {
+ /* Mark is at the end of the stack. */
+ EXTEND(sp, items);
+ Copy(AvARRAY(av), sp + 1, items, SV*);
+ sp += items;
+ PUTBACK ;
+ }
+ }
+#endif /* USE_THREADS */
SAVESPTR(curpad);
curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
- if (cx->blk_sub.hasargs) {
+#ifndef USE_THREADS
+ if (cx->blk_sub.hasargs)
+#endif /* USE_THREADS */
+ {
AV* av = (AV*)curpad[0];
SV** ary;
+#ifndef USE_THREADS
cx->blk_sub.savearray = GvAV(defgv);
- cx->blk_sub.argarray = av;
GvAV(defgv) = (AV*)SvREFCNT_inc(av);
+#endif /* USE_THREADS */
+ cx->blk_sub.argarray = av;
++mark;
if (items >= AvMAX(av) + 1) {
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;
}
docatch(o)
OP *o;
{
+ dTHR;
int ret;
I32 oldrunlevel = runlevel;
OP *oldop = op;
return Nullop;
}
+/* With USE_THREADS, eval_owner must be held on entry to doeval */
static OP *
doeval(gimme)
int gimme;
{
+ dTHR;
dSP;
OP *saveop = op;
HV *newstash;
compcv = (CV*)NEWSV(1104,0);
sv_upgrade((SV *)compcv, SVt_PVCV);
CvUNIQUE_on(compcv);
+#ifdef USE_THREADS
+ CvOWNER(compcv) = 0;
+ New(666, CvMUTEXP(compcv), 1, perl_mutex);
+ MUTEX_INIT(CvMUTEXP(compcv));
+#endif /* USE_THREADS */
comppad = newAV();
+ av_push(comppad, Nullsv);
+ curpad = AvARRAY(comppad);
comppad_name = newAV();
comppad_name_fill = 0;
min_intro_pending = 0;
- av_push(comppad, Nullsv);
- curpad = AvARRAY(comppad);
padix = 0;
+#ifdef USE_THREADS
+ av_store(comppad_name, 0, newSVpv("@_", 2));
+ curpad[0] = (SV*)newAV();
+ SvPADMY_on(curpad[0]); /* XXX Needed? */
+#endif /* USE_THREADS */
comppadlist = newAV();
AvREAL_off(comppadlist);
}
SvREFCNT_dec(rs);
rs = SvREFCNT_inc(nrs);
+#ifdef USE_THREADS
+ MUTEX_LOCK(&eval_mutex);
+ eval_owner = 0;
+ COND_SIGNAL(&eval_cond);
+ MUTEX_UNLOCK(&eval_mutex);
+#endif /* USE_THREADS */
RETPUSHUNDEF;
}
SvREFCNT_dec(rs);
/* compiled okay, so do it */
CvDEPTH(compcv) = 1;
-
SP = stack_base + POPMARK; /* pop original mark */
op = saveop; /* The caller may need it. */
+#ifdef USE_THREADS
+ MUTEX_LOCK(&eval_mutex);
+ eval_owner = 0;
+ COND_SIGNAL(&eval_cond);
+ MUTEX_UNLOCK(&eval_mutex);
+#endif /* USE_THREADS */
+
RETURNOP(eval_start);
}
compiling.cop_line = 0;
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 */
return DOCATCH(doeval(G_SCALAR));
}
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_INTER && was != sub_generation /* Some subs defined here. */
&& ret != op->op_next) { /* Successive compilation. */
/* Hot code. */
+#ifdef USE_THREADS
+static void
+unset_cvowner(cvarg)
+void *cvarg;
+{
+ register CV* cv = (CV *) cvarg;
+#ifdef DEBUGGING
+ dTHR;
+#endif /* DEBUGGING */
+
+ DEBUG_L((PerlIO_printf(PerlIO_stderr(), "%p unsetting CvOWNER of %p:%s\n",
+ thr, cv, SvPEEK((SV*)cv))));
+ MUTEX_LOCK(CvMUTEXP(cv));
+ DEBUG_L(if (CvDEPTH(cv) != 0)
+ PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n",
+ CvDEPTH(cv)););
+ assert(thr == CvOWNER(cv));
+ CvOWNER(cv) = 0;
+ MUTEX_UNLOCK(CvMUTEXP(cv));
+ SvREFCNT_dec(cv);
+}
+#endif /* USE_THREADS */
+
PP(pp_const)
{
dSP;
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_flags & OPf_REF) {
SETs((SV*)hv);
}
}
else {
- if (SvTYPE(sv) == SVt_PVHV) {
+ if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
hv = (HV*)sv;
if (op->op_flags & OPf_REF) {
SETs((SV*)hv);
}
else {
dTARGET;
+ /* This bit is OK even when hv is really an AV */
if (HvFILL(hv))
sv_setpvf(TARG, "%ld/%ld",
(long)HvFILL(hv), (long)HvMAX(hv) + 1);
else
sv_setiv(TARG, 0);
+
SETTARG;
RETURN;
}
OP *
do_readline()
{
+ dTHR;
dSP; dTARGETSTACKED;
register SV *sv;
STRLEN tmplen = 0;
{
dSP;
HE* he;
+ SV **svp;
SV *keysv = POPs;
HV *hv = (HV*)POPs;
U32 lval = op->op_flags & OPf_MOD;
U32 defer = op->op_private & OPpLVAL_DEFER;
- if (SvTYPE(hv) != SVt_PVHV)
+ if (SvTYPE(hv) == SVt_PVHV) {
+ he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
+ svp = he ? &HeVAL(he) : 0;
+ }
+ else if (SvTYPE(hv) == SVt_PVAV) {
+ svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, 0);
+ }
+ else {
RETPUSHUNDEF;
- he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
+ }
if (lval) {
- if (!he || HeVAL(he) == &sv_undef) {
+ if (!svp || *svp == &sv_undef) {
SV* lv;
SV* key2;
if (!defer)
RETURN;
}
if (op->op_private & OPpLVAL_INTRO) {
- if (HvNAME(hv) && isGV(HeVAL(he)))
- save_gp((GV*)HeVAL(he), !(op->op_flags & OPf_SPECIAL));
+ if (HvNAME(hv) && isGV(*svp))
+ save_gp((GV*)*svp, !(op->op_flags & OPf_SPECIAL));
else
- save_svref(&HeVAL(he));
+ save_svref(svp);
}
else if (op->op_private & OPpDEREF)
- vivify_ref(HeVAL(he), op->op_private & OPpDEREF);
+ vivify_ref(*svp, op->op_private & OPpDEREF);
}
- PUSHs(he ? HeVAL(he) : &sv_undef);
+ PUSHs(svp ? *svp : &sv_undef);
RETURN;
}
return pop_return();
}
+static CV *
+get_db_sub(sv)
+SV *sv;
+{
+ dTHR;
+ SV *oldsv = sv;
+ GV *gv;
+ CV *cv;
+
+ sv = GvSV(DBsub);
+ save_item(sv);
+ gv = CvGV(cv);
+ if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
+ || strEQ(GvNAME(gv), "END")
+ || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
+ !( (SvTYPE(oldsv) == SVt_PVGV) && (GvCV((GV*)oldsv) == cv)
+ && (gv = (GV*)oldsv) ))) {
+ /* Use GV from the stack as a fallback. */
+ /* GV is potentially non-unique, or contain different CV. */
+ sv_setsv(sv, newRV((SV*)cv));
+ }
+ else {
+ gv_efullname3(sv, gv, Nullch);
+ }
+ cv = GvCV(DBsub);
+ if (CvXSUB(cv))
+ curcopdb = curcop;
+ return cv;
+}
+
PP(pp_entersub)
{
dSP; dPOPss;
}
gimme = GIMME_V;
- if ((op->op_private & OPpENTERSUB_DB) && GvCV(DBsub) && !CvNODEBUG(cv)) {
- SV *oldsv = sv;
- sv = GvSV(DBsub);
- save_item(sv);
- gv = CvGV(cv);
- if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
- || strEQ(GvNAME(gv), "END")
- || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
- !( (SvTYPE(oldsv) == SVt_PVGV) && (GvCV((GV*)oldsv) == cv)
- && (gv = (GV*)oldsv) ))) { /* Use GV from the stack as a fallback. */
- /* GV is potentially non-unique, or contain different CV. */
- sv_setsv(sv, newRV((SV*)cv));
+ if ((op->op_private & OPpENTERSUB_DB) && GvCV(DBsub) && !CvNODEBUG(cv))
+ cv = get_db_sub(sv);
+ if (!cv)
+ DIE("No DBsub routine");
+
+#ifdef USE_THREADS
+ /*
+ * First we need to check if the sub or method requires locking.
+ * If so, we gain a lock on the CV or the first argument, as
+ * appropriate. This has to be inline because for FAKE_THREADS,
+ * COND_WAIT inlines code to reschedule by returning a new op.
+ */
+ MUTEX_LOCK(CvMUTEXP(cv));
+ if (CvFLAGS(cv) & CVf_LOCKED) {
+ MAGIC *mg;
+ if (CvFLAGS(cv) & CVf_METHOD) {
+ if (SP > stack_base + TOPMARK)
+ sv = *(stack_base + TOPMARK + 1);
+ else {
+ MUTEX_UNLOCK(CvMUTEXP(cv));
+ croak("no argument for locked method call");
+ }
+ if (SvROK(sv))
+ sv = SvRV(sv);
}
else {
- gv_efullname3(sv, gv, Nullch);
+ sv = (SV*)cv;
+ }
+ MUTEX_UNLOCK(CvMUTEXP(cv));
+ mg = condpair_magic(sv);
+ MUTEX_LOCK(MgMUTEXP(mg));
+ if (MgOWNER(mg) == thr)
+ MUTEX_UNLOCK(MgMUTEXP(mg));
+ else {
+ while (MgOWNER(mg))
+ COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
+ MgOWNER(mg) = thr;
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: pp_entersub lock %p\n",
+ thr, sv);)
+ MUTEX_UNLOCK(MgMUTEXP(mg));
+ save_destructor(unlock_condpair, sv);
+ }
+ MUTEX_LOCK(CvMUTEXP(cv));
+ }
+ /*
+ * Now we have permission to enter the sub, we must distinguish
+ * four cases. (0) It's an XSUB (in which case we don't care
+ * about ownership); (1) it's ours already (and we're recursing);
+ * (2) it's free (but we may already be using a cached clone);
+ * (3) another thread owns it. Case (1) is easy: we just use it.
+ * Case (2) means we look for a clone--if we have one, use it
+ * otherwise grab ownership of cv. Case (3) means we look for a
+ * clone (for non-XSUBs) and have to create one if we don't
+ * already have one.
+ * Why look for a clone in case (2) when we could just grab
+ * ownership of cv straight away? Well, we could be recursing,
+ * i.e. we originally tried to enter cv while another thread
+ * owned it (hence we used a clone) but it has been freed up
+ * and we're now recursing into it. It may or may not be "better"
+ * to use the clone but at least CvDEPTH can be trusted.
+ */
+ if (CvOWNER(cv) == thr || CvXSUB(cv))
+ MUTEX_UNLOCK(CvMUTEXP(cv));
+ else {
+ /* Case (2) or (3) */
+ SV **svp;
+
+ /*
+ * XXX Might it be better to release CvMUTEXP(cv) while we
+ * do the hv_fetch? We might find someone has pinched it
+ * when we look again, in which case we would be in case
+ * (3) instead of (2) so we'd have to clone. Would the fact
+ * that we released the mutex more quickly make up for this?
+ */
+ svp = hv_fetch(cvcache, (char *)cv, sizeof(cv), FALSE);
+ if (svp) {
+ /* We already have a clone to use */
+ MUTEX_UNLOCK(CvMUTEXP(cv));
+ cv = *(CV**)svp;
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "entersub: %p already has clone %p:%s\n",
+ thr, cv, SvPEEK((SV*)cv)));
+ CvOWNER(cv) = thr;
+ SvREFCNT_inc(cv);
+ if (CvDEPTH(cv) == 0)
+ SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
+ }
+ else {
+ /* (2) => grab ownership of cv. (3) => make clone */
+ if (!CvOWNER(cv)) {
+ CvOWNER(cv) = thr;
+ SvREFCNT_inc(cv);
+ MUTEX_UNLOCK(CvMUTEXP(cv));
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "entersub: %p grabbing %p:%s in stash %s\n",
+ thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
+ HvNAME(CvSTASH(cv)) : "(none)"));
+ } else {
+ /* Make a new clone. */
+ CV *clonecv;
+ SvREFCNT_inc(cv); /* don't let it vanish from under us */
+ MUTEX_UNLOCK(CvMUTEXP(cv));
+ DEBUG_L((PerlIO_printf(PerlIO_stderr(),
+ "entersub: %p cloning %p:%s\n",
+ thr, cv, SvPEEK((SV*)cv))));
+ /*
+ * We're creating a new clone so there's no race
+ * between the original MUTEX_UNLOCK and the
+ * SvREFCNT_inc since no one will be trying to undef
+ * it out from underneath us. At least, I don't think
+ * there's a race...
+ */
+ clonecv = cv_clone(cv);
+ SvREFCNT_dec(cv); /* finished with this */
+ hv_store(cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
+ CvOWNER(clonecv) = thr;
+ cv = clonecv;
+ SvREFCNT_inc(cv);
+ }
+ DEBUG_L(if (CvDEPTH(cv) != 0)
+ PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n",
+ CvDEPTH(cv)););
+ SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
}
- cv = GvCV(DBsub);
- if (CvXSUB(cv)) curcopdb = curcop;
- if (!cv)
- DIE("No DBsub routine");
}
+#endif /* USE_THREADS */
+
+ gimme = GIMME;
if (CvXSUB(cv)) {
if (CvOLDSTYLE(cv)) {
/* Need to copy @_ to stack. Alternative may be to
* switch stack to @_, and copy return values
* back. This would allow popping @_ in XSUB, e.g.. XXXX */
- AV* av = GvAV(defgv);
- I32 items = AvFILL(av) + 1;
+ AV* av;
+ I32 items;
+#ifdef USE_THREADS
+ av = (AV*)curpad[0];
+#else
+ av = GvAV(defgv);
+#endif /* USE_THREADS */
+ items = AvFILL(av) + 1;
if (items) {
/* Mark is at the end of the stack. */
svp = AvARRAY(padlist);
}
}
- SAVESPTR(curpad);
- curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
- if (hasargs) {
+#ifdef USE_THREADS
+ if (!hasargs) {
AV* av = (AV*)curpad[0];
+
+ items = AvFILL(av) + 1;
+ if (items) {
+ /* Mark is at the end of the stack. */
+ EXTEND(sp, items);
+ Copy(AvARRAY(av), sp + 1, items, SV*);
+ sp += items;
+ PUTBACK ;
+ }
+ }
+#endif /* USE_THREADS */
+ SAVESPTR(curpad);
+ curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
+#ifndef USE_THREADS
+ if (hasargs)
+#endif /* USE_THREADS */
+ {
+ AV* av;
SV** ary;
+#if 0
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "%p entersub preparing @_\n", thr));
+#endif
+ av = (AV*)curpad[0];
if (AvREAL(av)) {
av_clear(av);
AvREAL_off(av);
}
+#ifndef USE_THREADS
cx->blk_sub.savearray = GvAV(defgv);
- cx->blk_sub.argarray = av;
GvAV(defgv) = (AV*)SvREFCNT_inc(av);
+#endif /* USE_THREADS */
+ cx->blk_sub.argarray = av;
++MARK;
if (items > AvMAX(av) + 1) {
MARK++;
}
}
+#if 0
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "%p entersub returning %p\n", thr, CvSTART(cv)));
+#endif
RETURNOP(CvSTART(cv));
}
}
fp = my_popen(tmps, "r");
if (fp) {
if (gimme == G_VOID) {
- while (PerlIO_read(fp, tokenbuf, sizeof tokenbuf) > 0)
+ char tmpbuf[256];
+ while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
/*SUPPRESS 530*/
;
}
CATCH_SET(TRUE);
ENTER;
- SAVESPTR(op);
+ SAVEOP();
op = (OP *) &myop;
if (PERLDB_SUB && curstash != debstash)
op->op_private |= OPpENTERSUB_DB;
XPUSHs((SV*)GvCV(gv));
PUTBACK;
- if (op = pp_entersub())
+ if (op = pp_entersub(ARGS))
runops();
SPAGAIN;
CATCH_SET(TRUE);
ENTER;
- SAVESPTR(op);
+ SAVEOP();
op = (OP *) &myop;
if (PERLDB_SUB && curstash != debstash)
op->op_private |= OPpENTERSUB_DB;
PUTBACK;
- pp_pushmark();
+ pp_pushmark(ARGS);
EXTEND(sp, 5);
PUSHs(sv);
PUSHs((SV*)GvCV(gv));
PUTBACK;
- if (op = pp_entersub())
+ if (op = pp_entersub(ARGS))
runops();
SPAGAIN;
sp--;
op = (OP *) &myop;
PUTBACK;
- pp_pushmark();
+ pp_pushmark(ARGS);
PUSHs(sv);
PUSHs(left);
PUSHs((SV*)GvCV(gv));
PUTBACK;
- if (op = pp_entersub())
+ if (op = pp_entersub(ARGS))
runops();
SPAGAIN;
}
setdefout(gv)
GV *gv;
{
+ dTHR;
if (gv)
(void)SvREFCNT_inc(gv);
if (defoutgv)
GV *gv;
OP *retop;
{
+ dTHR;
register CONTEXT *cx;
I32 gimme = GIMME_V;
AV* padlist = CvPADLIST(cv);
OP* append_elem _((I32 optype, OP* head, OP* tail));
OP* append_list _((I32 optype, LISTOP* first, LISTOP* last));
I32 apply _((I32 type, SV** mark, SV** sp));
-void assertref _((OP* op));
+void assertref _((OP* o));
+SV* avhv_delete _((AV *ar, char* key, U32 klen, I32 flags));
+SV* avhv_delete_ent _((AV *ar, SV* keysv, I32 flags, U32 hash));
+bool avhv_exists _((AV *ar, char* key, U32 klen));
+bool avhv_exists_ent _((AV *ar, SV* keysv, U32 hash));
+SV** avhv_fetch _((AV *ar, char* key, U32 klen, I32 lval));
+SV** avhv_fetch_ent _((AV *ar, SV* keysv, I32 lval, U32 hash));
+I32 avhv_iterinit _((AV *ar));
+HE* avhv_iternext _((AV *ar));
+SV * avhv_iternextsv _((AV *ar, char** key, I32* retlen));
+SV* avhv_iterval _((AV *ar, HE* entry));
+SV** avhv_store _((AV *ar, char* key, U32 klen, SV* val, U32 hash));
void av_clear _((AV* ar));
void av_extend _((AV* ar, I32 key));
AV* av_fake _((I32 size, SV** svp));
I32 my_chsize _((int fd, Off_t length));
#endif
OP* ck_gvconst _((OP* o));
-OP* ck_retarget _((OP* op));
-OP* convert _((I32 optype, I32 flags, OP* op));
+OP* ck_retarget _((OP* o));
+#ifdef USE_THREADS
+MAGIC * condpair_magic _((SV *sv));
+#endif
+OP* convert _((I32 optype, I32 flags, OP* o));
void croak _((const char* pat,...)) __attribute__((noreturn));
void cv_ckproto _((CV* cv, GV* gv, char* p));
CV* cv_clone _((CV* proto));
I32 cxinc _((void));
void deb _((const char* pat,...)) __attribute__((format(printf,1,2)));
void deb_growlevel _((void));
-I32 debop _((OP* op));
+I32 debop _((OP* o));
I32 debstackptrs _((void));
#ifdef DEBUGGING
void debprofdump _((void));
I32 do_ipcget _((I32 optype, SV** mark, SV** sp));
#endif
void do_join _((SV* sv, SV* del, SV** mark, SV** sp));
-OP* do_kv _((void));
+OP* do_kv _((ARGSproto));
#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
I32 do_msgrcv _((SV** mark, SV** sp));
I32 do_msgsnd _((SV** mark, SV** sp));
OP* fold_constants _((OP* arg));
char* form _((const char* pat, ...));
void free_tmps _((void));
-OP* gen_constant_list _((OP* op));
+OP* gen_constant_list _((OP* o));
void gp_free _((GV* gv));
GP* gp_ref _((GP* gp));
GV* gv_AVadd _((GV* gv));
I32 ibcmp _((char* a, char* b, I32 len));
I32 ibcmp_locale _((char* a, char* b, I32 len));
I32 ingroup _((I32 testgid, I32 effective));
+void init_stacks _((ARGSproto));
U32 intro_my _((void));
char* instr _((char* big, char* little));
bool io_close _((IO* io));
void leave_scope _((I32 base));
void lex_end _((void));
void lex_start _((SV* line));
-OP* linklist _((OP* op));
+OP* linklist _((OP* o));
OP* list _((OP* o));
OP* listkids _((OP* o));
OP* localize _((OP* arg, I32 lexical));
int magic_gettaint _((SV* sv, MAGIC* mg));
int magic_getuvar _((SV* sv, MAGIC* mg));
U32 magic_len _((SV* sv, MAGIC* mg));
+#ifdef USE_THREADS
+int magic_mutexfree _((SV* sv, MAGIC* mg));
+#endif /* USE_THREADS */
int magic_nextpack _((SV* sv, MAGIC* mg, SV* key));
int magic_set _((SV* sv, MAGIC* mg));
#ifdef OVERLOAD
U32 mg_len _((SV* sv));
void mg_magical _((SV* sv));
int mg_set _((SV* sv));
-OP* mod _((OP* op, I32 type));
+OP* mod _((OP* o, I32 type));
char* moreswitches _((char* s));
-OP* my _((OP* op));
+OP* my _((OP* o));
#if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
char* my_bcopy _((char* from, char* to, I32 len));
#endif
#endif
void my_exit _((U32 status)) __attribute__((noreturn));
void my_failure_exit _((void)) __attribute__((noreturn));
-I32 my_lstat _((void));
+I32 my_lstat _((ARGSproto));
#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
I32 my_memcmp _((char* s1, char* s2, I32 len));
#endif
I32 my_pclose _((PerlIO* ptr));
PerlIO* my_popen _((char* cmd, char* mode));
void my_setenv _((char* nam, char* val));
-I32 my_stat _((void));
+I32 my_stat _((ARGSproto));
#ifdef MYSWAP
short my_swap _((short s));
long my_htonl _((long l));
long my_ntohl _((long l));
#endif
void my_unexec _((void));
-OP* newANONLIST _((OP* op));
-OP* newANONHASH _((OP* op));
+OP* newANONLIST _((OP* o));
+OP* newANONHASH _((OP* o));
OP* newANONSUB _((I32 floor, OP* proto, OP* block));
OP* newASSIGNOP _((I32 flags, OP* left, I32 optype, OP* right));
OP* newCONDOP _((I32 flags, OP* expr, OP* trueop, OP* falseop));
-void newFORM _((I32 floor, OP* op, OP* block));
+void newFORM _((I32 floor, OP* o, OP* block));
OP* newFOROP _((I32 flags, char* label, line_t forline, OP* scalar, OP* expr, OP*block, OP*cont));
OP* newLOGOP _((I32 optype, I32 flags, OP* left, OP* right));
OP* newLOOPEX _((I32 type, OP* label));
OP* newLOOPOP _((I32 flags, I32 debuggable, OP* expr, OP* block));
OP* newNULLLIST _((void));
OP* newOP _((I32 optype, I32 flags));
-void newPROG _((OP* op));
+void newPROG _((OP* o));
OP* newRANGE _((I32 flags, OP* left, OP* right));
OP* newSLICEOP _((I32 flags, OP* subscript, OP* list));
OP* newSTATEOP _((I32 flags, char* label, OP* o));
-CV* newSUB _((I32 floor, OP* op, OP* proto, OP* block));
+CV* newSUB _((I32 floor, OP* o, OP* proto, OP* block));
CV* newXS _((char* name, void (*subaddr)(CV* cv), char* filename));
#ifdef DEPRECATED
CV* newXSUB _((char* name, I32 ix, I32 (*subaddr)(int,int,int), char* filename));
char* ninstr _((char* big, char* bigend, char* little, char* lend));
OP* oopsCV _((OP* o));
void op_free _((OP* arg));
-void package _((OP* op));
+void package _((OP* o));
PADOFFSET pad_alloc _((I32 optype, U32 tmptype));
PADOFFSET pad_allocmy _((char* name));
PADOFFSET pad_findmy _((char* name));
void pad_free _((PADOFFSET po));
void pad_reset _((void));
void pad_swipe _((PADOFFSET po));
-void peep _((OP* op));
+void peep _((OP* o));
PerlInterpreter* perl_alloc _((void));
I32 perl_call_argv _((char* subname, I32 flags, char** argv));
I32 perl_call_method _((char* methname, I32 flags));
void pidgone _((int pid, int status));
void pmflag _((U16* pmfl, int ch));
OP* pmruntime _((OP* pm, OP* expr, OP* repl));
-OP* pmtrans _((OP* op, OP* expr, OP* repl));
+OP* pmtrans _((OP* o, OP* expr, OP* repl));
OP* pop_return _((void));
void pop_scope _((void));
OP* prepend_elem _((I32 optype, OP* head, OP* tail));
-void push_return _((OP* op));
+void push_return _((OP* o));
void push_scope _((void));
regexp* pregcomp _((char* exp, char* xend, PMOP* pm));
-OP* ref _((OP* op, I32 type));
-OP* refkids _((OP* op, I32 type));
+OP* ref _((OP* o, I32 type));
+OP* refkids _((OP* o, I32 type));
void regdump _((regexp* r));
I32 pregexec _((regexp* prog, char* stringarg, char* strend, char* strbeg, I32 minend, SV* screamer, I32 safebase));
void pregfree _((struct regexp* r));
char* regnext _((char* p));
-void regprop _((SV* sv, char* op));
+void regprop _((SV* sv, char* o));
void repeatcpy _((char* to, char* from, I32 len, I32 count));
char* rninstr _((char* big, char* bigend, char* little, char* lend));
Sighandler_t rsignal _((int, Sighandler_t));
int rsignal_restore _((int, Sigsave_t*));
int rsignal_save _((int, Sighandler_t, Sigsave_t*));
Sighandler_t rsignal_state _((int));
-int runops _((void));
void rxres_free _((void** rsp));
void rxres_restore _((void** rsp, REGEXP* rx));
void rxres_save _((void** rsp, REGEXP* rx));
void save_destructor _((void (*f)(void*), void* p));
#endif /* titan */
void save_freesv _((SV* sv));
-void save_freeop _((OP* op));
+void save_freeop _((OP* o));
void save_freepv _((char* pv));
void save_gp _((GV* gv, I32 empty));
HV* save_hash _((GV* gv));
void save_list _((SV** sarg, I32 maxsarg));
void save_long _((long* longp));
void save_nogv _((GV* gv));
+void save_op _((void));
SV* save_scalar _((GV* gv));
void save_pptr _((char** pptr));
void save_sptr _((SV** sptr));
SV* save_svref _((SV** sptr));
OP* sawparens _((OP* o));
OP* scalar _((OP* o));
-OP* scalarkids _((OP* op));
+OP* scalarkids _((OP* o));
OP* scalarseq _((OP* o));
-OP* scalarvoid _((OP* op));
+OP* scalarvoid _((OP* o));
UV scan_hex _((char* start, I32 len, I32* retlen));
char* scan_num _((char* s));
UV scan_oct _((char* start, I32 len, I32* retlen));
#ifdef UNLINK_ALL_VERSIONS
I32 unlnk _((char* f));
#endif
+#ifdef USE_THREADS
+void unlock_condpair _((void* svv));
+#endif
void unsharepvn _((char* sv, I32 len, U32 hash));
void unshare_hek _((HEK* hek));
void utilize _((int aver, I32 floor, OP* version, OP* id, OP* arg));
#include "INTERN.h"
#include "regcomp.h"
+#ifdef USE_THREADS
+#undef op
+#endif /* USE_THREADS */
+
#ifdef MSDOS
# if defined(BUGGY_MSC6)
/* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */
- regprop - printable representation of opcode
*/
void
-regprop(sv, op)
+regprop(sv, o)
SV *sv;
-char *op;
+char *o;
{
register char *p = 0;
sv_setpv(sv, ":");
- switch (OP(op)) {
+ switch (OP(o)) {
case BOL:
p = "BOL";
break;
p = "NBOUNDL";
break;
case CURLY:
- sv_catpvf(sv, "CURLY {%d,%d}", ARG1(op), ARG2(op));
+ sv_catpvf(sv, "CURLY {%d,%d}", ARG1(o), ARG2(o));
break;
case CURLYX:
- sv_catpvf(sv, "CURLYX {%d,%d}", ARG1(op), ARG2(op));
+ sv_catpvf(sv, "CURLYX {%d,%d}", ARG1(o), ARG2(o));
break;
case REF:
- sv_catpvf(sv, "REF%d", ARG1(op));
+ sv_catpvf(sv, "REF%d", ARG1(o));
break;
case REFF:
- sv_catpvf(sv, "REFF%d", ARG1(op));
+ sv_catpvf(sv, "REFF%d", ARG1(o));
break;
case REFFL:
- sv_catpvf(sv, "REFFL%d", ARG1(op));
+ sv_catpvf(sv, "REFFL%d", ARG1(o));
break;
case OPEN:
- sv_catpvf(sv, "OPEN%d", ARG1(op));
+ sv_catpvf(sv, "OPEN%d", ARG1(o));
break;
case CLOSE:
- sv_catpvf(sv, "CLOSE%d", ARG1(op));
+ sv_catpvf(sv, "CLOSE%d", ARG1(o));
p = NULL;
break;
case STAR:
regcppush(parenfloor)
I32 parenfloor;
{
+ dTHR;
int retval = savestack_ix;
int i = (regsize - parenfloor) * 3;
int p;
static char *
regcppop()
{
+ dTHR;
I32 i = SSPOPINT;
U32 paren = 0;
char *input;
regcppartblow(base)
I32 base;
{
+ dTHR;
I32 i = SSPOPINT;
U32 paren;
char *startp;
*reglastparen = n;
break;
case CURLYX: {
+ dTHR;
CURCUR cc;
CHECKPOINT cp = savestack_ix;
cc.oldcc = regcc;
dEXT char **watchaddr = 0;
dEXT char *watchok;
-#ifndef DEBUGGING
-
int
-runops() {
+runops_standard() {
+ dTHR;
SAVEI32(runlevel);
runlevel++;
- while ( op = (*op->op_ppaddr)() ) ;
+ while ( op = (*op->op_ppaddr)(ARGS) ) ;
TAINT_NOT;
return 0;
}
-#else
-
-static void debprof _((OP*op));
+#ifdef DEBUGGING
+static void debprof _((OP*o));
int
-runops() {
+runops_debug() {
+ dTHR;
if (!op) {
warn("NULL OP IN RUN");
return 0;
DEBUG_t(debop(op));
DEBUG_P(debprof(op));
}
- } while ( op = (*op->op_ppaddr)() );
+ } while ( op = (*op->op_ppaddr)(ARGS) );
TAINT_NOT;
return 0;
}
I32
-debop(op)
-OP *op;
+debop(o)
+OP *o;
{
SV *sv;
- deb("%s", op_name[op->op_type]);
- switch (op->op_type) {
+ deb("%s", op_name[o->op_type]);
+ switch (o->op_type) {
case OP_CONST:
- PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOP->op_sv));
+ PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo->op_sv));
break;
case OP_GVSV:
case OP_GV:
- if (cGVOP->op_gv) {
+ if (cGVOPo->op_gv) {
sv = NEWSV(0,0);
- gv_fullname3(sv, cGVOP->op_gv, Nullch);
+ gv_fullname3(sv, cGVOPo->op_gv, Nullch);
PerlIO_printf(Perl_debug_log, "(%s)", SvPV(sv, na));
SvREFCNT_dec(sv);
}
}
static void
-debprof(op)
-OP* op;
+debprof(o)
+OP* o;
{
if (!profiledata)
New(000, profiledata, MAXO, U32);
- ++profiledata[op->op_type];
+ ++profiledata[o->op_type];
}
void
SV** p;
int n;
{
+ dTHR;
stack_sp = sp;
av_extend(curstack, (p - stack_base) + (n) + 128);
return stack_sp;
I32
cxinc()
{
+ dTHR;
cxstack_max = cxstack_max * 3 / 2;
Renew(cxstack, cxstack_max + 1, CONTEXT); /* XXX should fix CXINC macro */
return cxstack_ix + 1;
push_return(retop)
OP *retop;
{
+ dTHR;
if (retstack_ix == retstack_max) {
retstack_max = retstack_max * 3 / 2;
Renew(retstack, retstack_max, OP*);
OP *
pop_return()
{
+ dTHR;
if (retstack_ix > 0)
return retstack[--retstack_ix];
else
void
push_scope()
{
+ dTHR;
if (scopestack_ix == scopestack_max) {
scopestack_max = scopestack_max * 3 / 2;
Renew(scopestack, scopestack_max, I32);
void
pop_scope()
{
+ dTHR;
I32 oldsave = scopestack[--scopestack_ix];
LEAVE_SCOPE(oldsave);
}
void
markstack_grow()
{
+ dTHR;
I32 oldmax = markstack_max - markstack;
I32 newmax = oldmax * 3 / 2;
void
savestack_grow()
{
+ dTHR;
savestack_max = savestack_max * 3 / 2;
Renew(savestack, savestack_max, ANY);
}
void
free_tmps()
{
+ dTHR;
/* XXX should tmps_floor live in cxstack? */
I32 myfloor = tmps_floor;
while (tmps_ix > myfloor) { /* clean up after last statement */
save_scalar_at(sptr)
SV **sptr;
{
+ dTHR;
register SV *sv;
SV *osv = *sptr;
save_scalar(gv)
GV *gv;
{
+ dTHR;
SSCHECK(3);
SSPUSHPTR(gv);
SSPUSHPTR(GvSV(gv));
save_svref(sptr)
SV **sptr;
{
+ dTHR;
SSCHECK(3);
SSPUSHPTR(sptr);
SSPUSHPTR(*sptr);
GV *gv;
I32 empty;
{
+ dTHR;
SSCHECK(6);
SSPUSHIV((IV)SvLEN(gv));
SvLEN(gv) = 0; /* forget that anything was allocated here */
save_ary(gv)
GV *gv;
{
+ dTHR;
AV *oav, *av;
SSCHECK(3);
save_hash(gv)
GV *gv;
{
+ dTHR;
HV *ohv, *hv;
SSCHECK(3);
save_item(item)
register SV *item;
{
+ dTHR;
register SV *sv;
SSCHECK(3);
save_int(intp)
int *intp;
{
+ dTHR;
SSCHECK(3);
SSPUSHINT(*intp);
SSPUSHPTR(intp);
save_long(longp)
long *longp;
{
+ dTHR;
SSCHECK(3);
SSPUSHLONG(*longp);
SSPUSHPTR(longp);
save_I32(intp)
I32 *intp;
{
+ dTHR;
SSCHECK(3);
SSPUSHINT(*intp);
SSPUSHPTR(intp);
save_I16(intp)
I16 *intp;
{
+ dTHR;
SSCHECK(3);
SSPUSHINT(*intp);
SSPUSHPTR(intp);
save_iv(ivp)
IV *ivp;
{
+ dTHR;
SSCHECK(3);
SSPUSHIV(*ivp);
SSPUSHPTR(ivp);
save_pptr(pptr)
char **pptr;
{
+ dTHR;
SSCHECK(3);
SSPUSHPTR(*pptr);
SSPUSHPTR(pptr);
save_sptr(sptr)
SV **sptr;
{
+ dTHR;
SSCHECK(3);
SSPUSHPTR(*sptr);
SSPUSHPTR(sptr);
save_nogv(gv)
GV *gv;
{
+ dTHR;
SSCHECK(2);
SSPUSHPTR(gv);
SSPUSHINT(SAVEt_NSTAB);
save_hptr(hptr)
HV **hptr;
{
+ dTHR;
SSCHECK(3);
SSPUSHPTR(*hptr);
SSPUSHPTR(hptr);
save_aptr(aptr)
AV **aptr;
{
+ dTHR;
SSCHECK(3);
SSPUSHPTR(*aptr);
SSPUSHPTR(aptr);
save_freesv(sv)
SV *sv;
{
+ dTHR;
SSCHECK(2);
SSPUSHPTR(sv);
SSPUSHINT(SAVEt_FREESV);
}
void
-save_freeop(op)
-OP *op;
+save_freeop(o)
+OP *o;
{
+ dTHR;
SSCHECK(2);
- SSPUSHPTR(op);
+ SSPUSHPTR(o);
SSPUSHINT(SAVEt_FREEOP);
}
save_freepv(pv)
char *pv;
{
+ dTHR;
SSCHECK(2);
SSPUSHPTR(pv);
SSPUSHINT(SAVEt_FREEPV);
save_clearsv(svp)
SV** svp;
{
+ dTHR;
SSCHECK(2);
SSPUSHLONG((long)(svp-curpad));
SSPUSHINT(SAVEt_CLEARSV);
char *key;
I32 klen;
{
+ dTHR;
SSCHECK(4);
SSPUSHINT(klen);
SSPUSHPTR(key);
register SV **sarg;
I32 maxsarg;
{
+ dTHR;
register SV *sv;
register I32 i;
void (*f) _((void*));
void* p;
{
+ dTHR;
SSCHECK(3);
SSPUSHDPTR(f);
SSPUSHPTR(p);
}
void
+save_op()
+{
+ dTHR;
+ SSCHECK(2);
+ SSPUSHPTR(op);
+ SSPUSHINT(SAVEt_OP);
+}
+
+void
leave_scope(base)
I32 base;
{
+ dTHR;
register SV *sv;
register SV *value;
register GV *gv;
stack_sp = stack_base + delta;
}
break;
+ case SAVEt_OP:
+ op = (OP*)SSPOPPTR;
+ break;
default:
croak("panic: leave_scope inconsistency");
}
cx_dump(cx)
CONTEXT* cx;
{
+ dTHR;
PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), block_type[cx->cx_type]);
if (cx->cx_type != CXt_SUBST) {
PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
#define SAVEt_REGCONTEXT 21
#define SAVEt_STACK_POS 22
#define SAVEt_I16 23
+#define SAVEt_OP 24
#define SSCHECK(need) if (savestack_ix + need > savestack_max) savestack_grow()
#define SSPUSHINT(i) (savestack[savestack_ix++].any_i32 = (I32)(i))
SSPUSHINT(stack_sp - stack_base); \
SSPUSHINT(SAVEt_STACK_POS); \
} STMT_END
-
+#define SAVEOP() save_op()
/* A jmpenv packages the state required to perform a proper non-local jump.
* Note that there is a start_env initialized when perl starts, and top_env
typedef struct jmpenv JMPENV;
+#ifdef OP_IN_REGISTER
+#define OP_REG_TO_MEM opsave = op
+#define OP_MEM_TO_REG op = opsave
+#else
+#define OP_REG_TO_MEM NOOP
+#define OP_MEM_TO_REG NOOP
+#endif
+
#define dJMPENV JMPENV cur_env
#define JMPENV_PUSH(v) \
STMT_START { \
cur_env.je_prev = top_env; \
+ OP_REG_TO_MEM; \
cur_env.je_ret = Sigsetjmp(cur_env.je_buf, 1); \
+ OP_MEM_TO_REG; \
top_env = &cur_env; \
cur_env.je_mustcatch = FALSE; \
(v) = cur_env.je_ret; \
STMT_START { top_env = cur_env.je_prev; } STMT_END
#define JMPENV_JUMP(v) \
STMT_START { \
+ OP_REG_TO_MEM; \
if (top_env->je_prev) \
Siglongjmp(top_env->je_buf, (v)); \
if ((v) == 2) \
static void del_xrv _((XRV* p));
static void sv_mortalgrow _((void));
static void sv_unglob _((SV* sv));
+static void sv_check_thinkfirst _((SV *sv));
typedef void (*SVFUNC) _((SV*));
#define new_SV(p) \
do { \
+ MUTEX_LOCK(&sv_mutex); \
(p) = (SV*)safemalloc(sizeof(SV)); \
reg_add(p); \
+ MUTEX_UNLOCK(&sv_mutex); \
} while (0)
#define del_SV(p) \
do { \
+ MUTEX_LOCK(&sv_mutex); \
reg_remove(p); \
free((char*)(p)); \
+ MUTEX_UNLOCK(&sv_mutex); \
} while (0)
static SV **registry;
--sv_count; \
} while (0)
+/* sv_mutex must be held while calling uproot_SV() */
#define uproot_SV(p) \
do { \
(p) = sv_root; \
++sv_count; \
} while (0)
-#define new_SV(p) \
- if (sv_root) \
- uproot_SV(p); \
- else \
- (p) = more_sv()
+#define new_SV(p) do { \
+ MUTEX_LOCK(&sv_mutex); \
+ if (sv_root) \
+ uproot_SV(p); \
+ else \
+ (p) = more_sv(); \
+ MUTEX_UNLOCK(&sv_mutex); \
+ } while (0)
#ifdef DEBUGGING
-#define del_SV(p) \
- if (debug & 32768) \
- del_sv(p); \
- else \
- plant_SV(p)
+#define del_SV(p) do { \
+ MUTEX_LOCK(&sv_mutex); \
+ if (debug & 32768) \
+ del_sv(p); \
+ else \
+ plant_SV(p); \
+ MUTEX_UNLOCK(&sv_mutex); \
+ } while (0)
static void
del_sv(p)
SvFLAGS(sv) = SVTYPEMASK;
}
+/* sv_mutex must be held while calling more_sv() */
static SV*
more_sv()
{
register SV *sv;
IV i;
{
- if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
- if (SvROK(sv))
- sv_unref(sv);
- }
+ sv_check_thinkfirst(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
sv_upgrade(sv, SVt_IV);
case SVt_PVCV:
case SVt_PVFM:
case SVt_PVIO:
- croak("Can't coerce %s to integer in %s", sv_reftype(sv,0),
- op_desc[op->op_type]);
+ {
+ dTHR;
+ croak("Can't coerce %s to integer in %s", sv_reftype(sv,0),
+ op_desc[op->op_type]);
+ }
}
(void)SvIOK_only(sv); /* validate number */
SvIVX(sv) = i;
register SV *sv;
double num;
{
- if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
- if (SvROK(sv))
- sv_unref(sv);
- }
+ sv_check_thinkfirst(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
case SVt_IV:
case SVt_PVCV:
case SVt_PVFM:
case SVt_PVIO:
- croak("Can't coerce %s to number in %s", sv_reftype(sv,0),
- op_name[op->op_type]);
+ {
+ dTHR;
+ croak("Can't coerce %s to number in %s", sv_reftype(sv,0),
+ op_name[op->op_type]);
+ }
}
SvNVX(sv) = num;
(void)SvNOK_only(sv); /* validate number */
not_a_number(sv)
SV *sv;
{
+ dTHR;
char tmpbuf[64];
char *d = tmpbuf;
char *s;
if (SvPOKp(sv) && SvLEN(sv))
return asIV(sv);
if (!SvROK(sv)) {
+ dTHR; /* just for localizing */
if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
warn(warn_uninit);
return 0;
SvIVX(sv) = asIV(sv);
}
else {
+ dTHR;
if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
warn(warn_uninit);
return 0;
if (SvPOKp(sv) && SvLEN(sv))
return asUV(sv);
if (!SvROK(sv)) {
+ dTHR; /* just for localizing */
if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
warn(warn_uninit);
return 0;
SvUVX(sv) = asUV(sv);
}
else {
+ dTHR; /* just for localizing */
if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
warn(warn_uninit);
return 0;
if (SvIOKp(sv))
return (double)SvIVX(sv);
if (!SvROK(sv)) {
+ dTHR; /* just for localizing */
if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
warn(warn_uninit);
return 0;
SvNVX(sv) = atof(SvPVX(sv));
}
else {
+ dTHR;
if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
warn(warn_uninit);
return 0.0;
register char *s;
int olderrno;
SV *tsv;
+ char tmpbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
if (!sv) {
*lp = 0;
return SvPVX(sv);
}
if (SvIOKp(sv)) {
- (void)sprintf(tokenbuf,"%ld",(long)SvIVX(sv));
+ (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
tsv = Nullsv;
goto tokensave;
}
if (SvNOKp(sv)) {
SET_NUMERIC_STANDARD();
- Gconvert(SvNVX(sv), DBL_DIG, 0, tokenbuf);
+ Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
tsv = Nullsv;
goto tokensave;
}
if (!SvROK(sv)) {
+ dTHR; /* just for localizing */
if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
warn(warn_uninit);
*lp = 0;
if (SvREADONLY(sv)) {
if (SvNOKp(sv)) {
SET_NUMERIC_STANDARD();
- Gconvert(SvNVX(sv), DBL_DIG, 0, tokenbuf);
+ Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
tsv = Nullsv;
goto tokensave;
}
if (SvIOKp(sv)) {
- (void)sprintf(tokenbuf,"%ld",(long)SvIVX(sv));
+ (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
tsv = Nullsv;
goto tokensave;
}
SvIOKp_on(sv);
}
else {
+ dTHR;
if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
warn(warn_uninit);
*lp = 0;
tokensaveref:
if (!tsv)
- tsv = newSVpv(tokenbuf, 0);
+ tsv = newSVpv(tmpbuf, 0);
sv_2mortal(tsv);
*lp = SvCUR(tsv);
return SvPVX(tsv);
len = SvCUR(tsv);
}
else {
- t = tokenbuf;
- len = strlen(tokenbuf);
+ t = tmpbuf;
+ len = strlen(tmpbuf);
}
#ifdef FIXNEGATIVEZERO
if (len == 2 && t[0] == '-' && t[1] == '0') {
if (SvROK(sv)) {
#ifdef OVERLOAD
{
+ dTHR;
SV* tmpsv;
if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
return SvTRUE(tmpsv);
return SvRV(sv) != 0;
}
if (SvPOKp(sv)) {
- register XPV* Xpv;
- if ((Xpv = (XPV*)SvANY(sv)) &&
- (*Xpv->xpv_pv > '0' ||
- Xpv->xpv_cur > 1 ||
- (Xpv->xpv_cur && *Xpv->xpv_pv != '0')))
+ register XPV* Xpvtmp;
+ if ((Xpvtmp = (XPV*)SvANY(sv)) &&
+ (*Xpvtmp->xpv_pv > '0' ||
+ Xpvtmp->xpv_cur > 1 ||
+ (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
return 1;
else
return 0;
SV *dstr;
register SV *sstr;
{
+ dTHR;
register U32 sflags;
register int dtype;
register int stype;
if (sstr == dstr)
return;
- if (SvTHINKFIRST(dstr)) {
- if (SvREADONLY(dstr) && curcop != &compiling)
- croak(no_modify);
- if (SvROK(dstr))
- sv_unref(dstr);
- }
+ sv_check_thinkfirst(dstr);
if (!sstr)
sstr = &sv_undef;
stype = SvTYPE(sstr);
if (sflags & SVf_ROK) {
if (dtype >= SVt_PV) {
if (dtype == SVt_PVGV) {
+ dTHR;
SV *sref = SvREFCNT_inc(SvRV(sstr));
SV *dref = 0;
int intro = GvINTRO(dstr);
{
assert(len >= 0); /* STRLEN is probably unsigned, so this may
elicit a warning, but it won't hurt. */
- if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
- if (SvROK(sv))
- sv_unref(sv);
- }
+ sv_check_thinkfirst(sv);
if (!ptr) {
(void)SvOK_off(sv);
return;
{
register STRLEN len;
- if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
- if (SvROK(sv))
- sv_unref(sv);
- }
+ sv_check_thinkfirst(sv);
if (!ptr) {
(void)SvOK_off(sv);
return;
register char *ptr;
register STRLEN len;
{
- if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
- if (SvROK(sv))
- sv_unref(sv);
- }
+ sv_check_thinkfirst(sv);
if (!SvUPGRADE(sv, SVt_PV))
return;
if (!ptr) {
SvTAINT(sv);
}
+static void
+sv_check_thinkfirst(sv)
+register SV *sv;
+{
+ if (SvTHINKFIRST(sv)) {
+ if (SvREADONLY(sv)) {
+ dTHR;
+ if (curcop != &compiling)
+ croak(no_modify);
+ }
+ if (SvROK(sv))
+ sv_unref(sv);
+ }
+}
+
void
sv_chop(sv,ptr) /* like set but assuming ptr is in sv */
register SV *sv;
if (!ptr || !SvPOKp(sv))
return;
- if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
- if (SvROK(sv))
- sv_unref(sv);
- }
+ sv_check_thinkfirst(sv);
if (SvTYPE(sv) < SVt_PVIV)
sv_upgrade(sv,SVt_PVIV);
{
MAGIC* mg;
- if (SvREADONLY(sv) && curcop != &compiling && !strchr("gBf", how))
- croak(no_modify);
+ if (SvREADONLY(sv)) {
+ dTHR;
+ if (curcop != &compiling && !strchr("gBf", how))
+ croak(no_modify);
+ }
if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
if (how == 't')
if (!obj || obj == sv || how == '#')
mg->mg_obj = obj;
else {
+ dTHR;
mg->mg_obj = SvREFCNT_inc(obj);
mg->mg_flags |= MGf_REFCOUNTED;
}
if (name)
if (namlen >= 0)
mg->mg_ptr = savepvn(name, namlen);
- else if (namlen == HEf_SVKEY)
+ else if (namlen == HEf_SVKEY) {
+ dTHR; /* just for SvREFCNT_inc */
mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
+ }
switch (how) {
case 0:
case 'l':
mg->mg_virtual = &vtbl_dbline;
break;
+#ifdef USE_THREADS
+ case 'm':
+ mg->mg_virtual = &vtbl_mutex;
+ break;
+#endif /* USE_THREADS */
#ifdef USE_LOCALE_COLLATE
case 'o':
mg->mg_virtual = &vtbl_collxfrm;
register SV *nsv;
{
U32 refcnt = SvREFCNT(sv);
- if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
- if (SvROK(sv))
- sv_unref(sv);
- }
+ sv_check_thinkfirst(sv);
if (SvREFCNT(nsv) != 1)
warn("Reference miscount in sv_replace()");
if (SvMAGICAL(sv)) {
assert(SvREFCNT(sv) == 0);
if (SvOBJECT(sv)) {
+ dTHR;
if (defstash) { /* Still have a symbol table? */
+ dTHR;
dSP;
GV* destructor;
return;
#ifdef DEBUGGING
if (SvTEMP(sv)) {
- warn("Attempt to free temp prematurely");
+ warn("Attempt to free temp prematurely: %s", SvPEEK(sv));
return;
}
#endif
register I32 cnt;
I32 i;
- if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
- if (SvROK(sv))
- sv_unref(sv);
- }
+ sv_check_thinkfirst(sv);
if (!SvUPGRADE(sv, SVt_PV))
return 0;
SvSCREAM_off(sv);
if (!sv)
return;
if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
+ if (SvREADONLY(sv)) {
+ dTHR;
+ if (curcop != &compiling)
+ croak(no_modify);
+ }
if (SvROK(sv)) {
#ifdef OVERLOAD
if (SvAMAGIC(sv) && AMG_CALLun(sv,inc)) return;
if (!sv)
return;
if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
+ if (SvREADONLY(sv)) {
+ dTHR;
+ if (curcop != &compiling)
+ croak(no_modify);
+ }
if (SvROK(sv)) {
#ifdef OVERLOAD
if (SvAMAGIC(sv) && AMG_CALLun(sv,dec)) return;
static void
sv_mortalgrow()
{
+ dTHR;
tmps_max += (tmps_max < 512) ? 128 : 512;
Renew(tmps_stack, tmps_max, SV*);
}
sv_mortalcopy(oldstr)
SV *oldstr;
{
+ dTHR;
register SV *sv;
new_SV(sv);
SV *
sv_newmortal()
{
+ dTHR;
register SV *sv;
new_SV(sv);
sv_2mortal(sv)
register SV *sv;
{
+ dTHR;
if (!sv)
return sv;
if (SvREADONLY(sv) && curcop != &compiling)
newRV(ref)
SV *ref;
{
+ dTHR;
register SV *sv;
new_SV(sv);
{
char *s;
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
+ if (SvREADONLY(sv)) {
+ dTHR;
+ if (curcop != &compiling)
+ croak(no_modify);
+ }
if (SvPOK(sv)) {
*lp = SvCUR(sv);
s = SvPVX(sv);
*lp = SvCUR(sv);
}
- else
+ else {
+ dTHR;
croak("Can't coerce %s to string in %s", sv_reftype(sv,0),
op_name[op->op_type]);
+ }
}
else
s = sv_2pv(sv, lp);
SV *rv;
char *classname;
{
+ dTHR;
SV *sv;
new_SV(sv);
SV* sv;
HV* stash;
{
+ dTHR;
SV *ref;
if (!SvROK(sv))
croak("Can't bless non-reference value");
I32 svmax;
bool *used_locale;
{
+ dTHR;
char *p;
char *q;
char *patend;
PerlIO_printf(Perl_debug_log, " DEPTH = %ld\n", (long)CvDEPTH(sv));
PerlIO_printf(Perl_debug_log, " PADLIST = 0x%lx\n", (long)CvPADLIST(sv));
PerlIO_printf(Perl_debug_log, " OUTSIDE = 0x%lx\n", (long)CvOUTSIDE(sv));
+#ifdef USE_THREADS
+ PerlIO_printf(Perl_debug_log, " MUTEXP = 0x%lx\n", (long)CvMUTEXP(sv));
+ PerlIO_printf(Perl_debug_log, " OWNER = 0x%lx\n", (long)CvOWNER(sv));
+#endif /* USE_THREADS */
+ PerlIO_printf(Perl_debug_log, " FLAGS = 0x%lx\n",
+ (unsigned long)CvFLAGS(sv));
if (type == SVt_PVFM)
PerlIO_printf(Perl_debug_log, " LINES = %ld\n", (long)FmLINES(sv));
break;
/* This structure much match XPVCV */
+typedef U16 cv_flags_t;
+
struct xpvfm {
char * xpv_pv; /* pointer to malloced string */
STRLEN xpv_cur; /* length of xpv_pv as a C string */
long xcv_depth; /* >= 2 indicates recursive call */
AV * xcv_padlist;
CV * xcv_outside;
- U8 xcv_flags;
+#ifdef USE_THREADS
+ perl_mutex *xcv_mutexp;
+ perl_cond * xcv_condp; /* signalled when owner leaves CV */
+ struct thread *xcv_owner; /* current owner thread */
+#endif /* USE_THREADS */
+ cv_flags_t xcv_flags;
I32 xfm_lines;
};
sub foo2
{
- shift(_);
+ shift;
print $_[0];
$x = 'value';
$x;
--- /dev/null
+#ifndef USE_THREADS
+#define MUTEX_LOCK(m)
+#define MUTEX_UNLOCK(m)
+#define MUTEX_INIT(m)
+#define MUTEX_DESTROY(m)
+#define COND_INIT(c)
+#define COND_SIGNAL(c)
+#define COND_BROADCAST(c)
+#define COND_WAIT(c, m)
+#define COND_DESTROY(c)
+
+#define THR
+/* Rats: if dTHR is just blank then the subsequent ";" throws an error */
+#define dTHR extern int errno
+#else
+
+#ifdef FAKE_THREADS
+typedef struct thread *perl_thread;
+/* With fake threads, thr is global(ish) so we don't need dTHR */
+#define dTHR extern int errno
+
+/*
+ * Note that SCHEDULE() is only callable from pp code (which
+ * must be expecting to be restarted). We'll have to do
+ * something a bit different for XS code.
+ */
+#define SCHEDULE() return schedule(), op
+
+#define MUTEX_LOCK(m)
+#define MUTEX_UNLOCK(m)
+#define MUTEX_INIT(m)
+#define MUTEX_DESTROY(m)
+#define COND_INIT(c) perl_cond_init(c)
+#define COND_SIGNAL(c) perl_cond_signal(c)
+#define COND_BROADCAST(c) perl_cond_broadcast(c)
+#define COND_WAIT(c, m) STMT_START { \
+ perl_cond_wait(c); \
+ SCHEDULE(); \
+ } STMT_END
+#define COND_DESTROY(c)
+#else
+/* POSIXish threads */
+typedef pthread_t perl_thread;
+#ifdef OLD_PTHREADS_API
+#define pthread_mutexattr_init(a) pthread_mutexattr_create(a)
+#define pthread_mutexattr_settype(a,t) pthread_mutexattr_setkind_np(a,t)
+#define pthread_key_create(k,d) pthread_keycreate(k,(pthread_destructor_t)(d))
+#else
+#define pthread_mutexattr_default NULL
+#define pthread_condattr_default NULL
+#endif /* OLD_PTHREADS_API */
+
+#define MUTEX_INIT(m) \
+ if (pthread_mutex_init((m), pthread_mutexattr_default)) \
+ croak("panic: MUTEX_INIT"); \
+ else 1
+#define MUTEX_LOCK(m) \
+ if (pthread_mutex_lock((m))) croak("panic: MUTEX_LOCK"); else 1
+#define MUTEX_UNLOCK(m) \
+ if (pthread_mutex_unlock((m))) croak("panic: MUTEX_UNLOCK"); else 1
+#define MUTEX_DESTROY(m) \
+ if (pthread_mutex_destroy((m))) croak("panic: MUTEX_DESTROY"); else 1
+#define COND_INIT(c) \
+ if (pthread_cond_init((c), pthread_condattr_default)) \
+ croak("panic: COND_INIT"); \
+ else 1
+#define COND_SIGNAL(c) \
+ if (pthread_cond_signal((c))) croak("panic: COND_SIGNAL"); else 1
+#define COND_BROADCAST(c) \
+ if (pthread_cond_broadcast((c))) croak("panic: COND_BROADCAST"); else 1
+#define COND_WAIT(c, m) \
+ if (pthread_cond_wait((c), (m))) croak("panic: COND_WAIT"); else 1
+#define COND_DESTROY(c) \
+ if (pthread_cond_destroy((c))) croak("panic: COND_DESTROY"); else 1
+
+/* DETACH(t) must only be called while holding t->mutex */
+#define DETACH(t) \
+ if (pthread_detach((t)->Tself)) { \
+ MUTEX_UNLOCK(&(t)->mutex); \
+ croak("panic: DETACH"); \
+ } else 1
+
+/* XXX Add "old" (?) POSIX draft interface too */
+#ifdef OLD_PTHREADS_API
+struct thread *getTHR _((void));
+#define THR getTHR()
+#else
+#define THR ((struct thread *) pthread_getspecific(thr_key))
+#endif /* OLD_PTHREADS_API */
+#define dTHR struct thread *thr = THR
+#endif /* FAKE_THREADS */
+
+#ifndef INIT_THREADS
+# ifdef NEED_PTHREAD_INIT
+# define INIT_THREADS pthread_init()
+# else
+# define INIT_THREADS NOOP
+# endif
+#endif
+
+struct thread {
+ /* The fields that used to be global */
+ /* Important ones in the first cache line (if alignment is done right) */
+ SV ** Tstack_sp;
+#ifdef OP_IN_REGISTER
+ OP * Topsave;
+#else
+ OP * Top;
+#endif
+ SV ** Tcurpad;
+ SV ** Tstack_base;
+
+ SV ** Tstack_max;
+
+ I32 * Tscopestack;
+ I32 Tscopestack_ix;
+ I32 Tscopestack_max;
+
+ ANY * Tsavestack;
+ I32 Tsavestack_ix;
+ I32 Tsavestack_max;
+
+ OP ** Tretstack;
+ I32 Tretstack_ix;
+ I32 Tretstack_max;
+
+ I32 * Tmarkstack;
+ I32 * Tmarkstack_ptr;
+ I32 * Tmarkstack_max;
+
+ SV * TSv;
+ XPV * TXpv;
+ struct stat Tstatbuf;
+ struct tms Ttimesbuf;
+
+ /* XXX What about regexp stuff? */
+
+ /* Now the fields that used to be "per interpreter" (even when global) */
+
+ /* XXX What about magic variables such as $/, $? and so on? */
+ HV * Tdefstash;
+ HV * Tcurstash;
+
+ SV ** Ttmps_stack;
+ I32 Ttmps_ix;
+ I32 Ttmps_floor;
+ I32 Ttmps_max;
+
+ int Tin_eval;
+ OP * Trestartop;
+ int Tdelaymagic;
+ bool Tdirty;
+ U8 Tlocalizing;
+ COP * Tcurcop;
+
+ CONTEXT * Tcxstack;
+ I32 Tcxstack_ix;
+ I32 Tcxstack_max;
+
+ AV * Tcurstack;
+ AV * Tmainstack;
+ JMPENV * Ttop_env;
+ I32 Trunlevel;
+
+ /* XXX Sort stuff, firstgv, secongv and so on? */
+
+ perl_thread Tself;
+ SV * Toursv;
+ HV * Tcvcache;
+ U32 flags;
+ perl_mutex mutex; /* For the fields others can change */
+ U32 tid;
+ struct thread *next, *prev; /* Circular linked list of threads */
+
+#ifdef ADD_THREAD_INTERN
+ struct thread_intern i; /* Platform-dependent internals */
+#endif
+};
+
+typedef struct thread *Thread;
+
+/* Values and macros for thr->flags */
+#define THRf_STATE_MASK 7
+#define THRf_R_JOINABLE 0
+#define THRf_R_JOINED 1
+#define THRf_R_DETACHED 2
+#define THRf_ZOMBIE 3
+#define THRf_DEAD 4
+
+#define THRf_DIE_FATAL 8
+
+/* ThrSTATE(t) and ThrSETSTATE(t) must only be called while holding t->mutex */
+#define ThrSTATE(t) ((t)->flags)
+#define ThrSETSTATE(t, s) STMT_START { \
+ (t)->flags &= ~THRf_STATE_MASK; \
+ (t)->flags |= (s); \
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(), \
+ "thread %p set to state %d\n", (t), (s))); \
+ } STMT_END
+
+typedef struct condpair {
+ perl_mutex mutex; /* Protects all other fields */
+ perl_cond owner_cond; /* For when owner changes at all */
+ perl_cond cond; /* For cond_signal and cond_broadcast */
+ Thread owner; /* Currently owning thread */
+} condpair_t;
+
+#define MgMUTEXP(mg) (&((condpair_t *)(mg->mg_ptr))->mutex)
+#define MgOWNERCONDP(mg) (&((condpair_t *)(mg->mg_ptr))->owner_cond)
+#define MgCONDP(mg) (&((condpair_t *)(mg->mg_ptr))->cond)
+#define MgOWNER(mg) ((condpair_t *)(mg->mg_ptr))->owner
+
+#undef stack_base
+#undef stack_sp
+#undef stack_max
+#undef curstack
+#undef mainstack
+#undef markstack
+#undef markstack_ptr
+#undef markstack_max
+#undef scopestack
+#undef scopestack_ix
+#undef scopestack_max
+#undef savestack
+#undef savestack_ix
+#undef savestack_max
+#undef retstack
+#undef retstack_ix
+#undef retstack_max
+#undef curcop
+#undef cxstack
+#undef cxstack_ix
+#undef cxstack_max
+#undef defstash
+#undef curstash
+#undef tmps_stack
+#undef tmps_floor
+#undef tmps_ix
+#undef tmps_max
+#undef curpad
+#undef Sv
+#undef Xpv
+#undef statbuf
+#undef timesbuf
+#undef top_env
+#undef runlevel
+#undef in_eval
+#undef restartop
+#undef delaymagic
+#undef dirty
+#undef localizing
+
+#define self (thr->Tself)
+#define oursv (thr->Toursv)
+#define stack_base (thr->Tstack_base)
+#define stack_sp (thr->Tstack_sp)
+#define stack_max (thr->Tstack_max)
+#ifdef OP_IN_REGISTER
+#define opsave (thr->Topsave)
+#else
+#undef op
+#define op (thr->Top)
+#endif
+#define curcop (thr->Tcurcop)
+#define stack (thr->Tstack)
+#define curstack (thr->Tcurstack)
+#define mainstack (thr->Tmainstack)
+#define markstack (thr->Tmarkstack)
+#define markstack_ptr (thr->Tmarkstack_ptr)
+#define markstack_max (thr->Tmarkstack_max)
+#define scopestack (thr->Tscopestack)
+#define scopestack_ix (thr->Tscopestack_ix)
+#define scopestack_max (thr->Tscopestack_max)
+
+#define savestack (thr->Tsavestack)
+#define savestack_ix (thr->Tsavestack_ix)
+#define savestack_max (thr->Tsavestack_max)
+
+#define retstack (thr->Tretstack)
+#define retstack_ix (thr->Tretstack_ix)
+#define retstack_max (thr->Tretstack_max)
+
+#define cxstack (thr->Tcxstack)
+#define cxstack_ix (thr->Tcxstack_ix)
+#define cxstack_max (thr->Tcxstack_max)
+
+#define curpad (thr->Tcurpad)
+#define Sv (thr->TSv)
+#define Xpv (thr->TXpv)
+#define statbuf (thr->Tstatbuf)
+#define timesbuf (thr->Ttimesbuf)
+#define defstash (thr->Tdefstash)
+#define curstash (thr->Tcurstash)
+
+#define tmps_stack (thr->Ttmps_stack)
+#define tmps_ix (thr->Ttmps_ix)
+#define tmps_floor (thr->Ttmps_floor)
+#define tmps_max (thr->Ttmps_max)
+
+#define in_eval (thr->Tin_eval)
+#define restartop (thr->Trestartop)
+#define delaymagic (thr->Tdelaymagic)
+#define dirty (thr->Tdirty)
+#define localizing (thr->Tlocalizing)
+
+#define top_env (thr->Ttop_env)
+#define runlevel (thr->Trunlevel)
+
+#define cvcache (thr->Tcvcache)
+#endif /* USE_THREADS */
lex_start(line)
SV *line;
{
+ dTHR;
char *s;
STRLEN len;
incline(s)
char *s;
{
+ dTHR;
char *t;
char *n;
char ch;
skipspace(s)
register char *s;
{
+ dTHR;
if (lex_formbrack && lex_brackets <= lex_formbrack) {
while (s < bufend && (*s == ' ' || *s == '\t'))
s++;
char *s;
#endif /* CAN_PROTOTYPE */
{
+ dTHR;
yylval.ival = f;
CLINE;
expect = x;
int kind;
{
if (s && *s) {
- OP* op = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
- nextval[nexttoke].opval = op;
+ OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
+ nextval[nexttoke].opval = o;
force_next(WORD);
if (kind) {
- op->op_private = OPpCONST_ENTERED;
+ dTHR; /* just for in_eval */
+ o->op_private = OPpCONST_ENTERED;
/* XXX see note in pp_entereval() for why we forgo typo
warnings if the symbol must be introduced in an eval.
GSAR 96-10-12 */
static I32
sublex_push()
{
+ dTHR;
push_scope();
lex_state = sublex_info.super_state;
register char *d = SvPVX(sv);
bool dorange = FALSE;
I32 len;
- char *leave =
+ char *leaveit =
lex_inpat
? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxc0123456789[{]} \t\n\r\f\v#"
: (lex_inwhat & OP_TRANS)
}
if (*s == '\\' && s+1 < send) {
s++;
- if (*s && strchr(leave, *s)) {
+ if (*s && strchr(leaveit, *s)) {
*d++ = '\\';
*d++ = *s++;
continue;
int
yylex()
{
+ dTHR;
register char *s;
register char *d;
register I32 tmp;
return PRIVATEREF;
}
- if (!strchr(tokenbuf,':') && (tmp = pad_findmy(tokenbuf))) {
+ if (!strchr(tokenbuf,':')
+ && (tmp = pad_findmy(tokenbuf)) != NOT_IN_PAD) {
if (last_lop_op == OP_SORT &&
tokenbuf[0] == '$' &&
(tokenbuf[1] == 'a' || tokenbuf[1] == 'b')
case KEY_DESTROY:
case KEY_BEGIN:
case KEY_END:
+ case KEY_INIT:
if (expect == XSTATE) {
s = bufptr;
goto really_sub;
case KEY_listen:
LOP(OP_LISTEN,XTERM);
+ case KEY_lock:
+ UNI(OP_LOCK);
+
case KEY_lstat:
UNI(OP_LSTAT);
case KEY_my:
in_my = TRUE;
+ s = skipspace(s);
+ if (isIDFIRST(*s)) {
+ s = scan_word(s, tokenbuf, sizeof tokenbuf, TRUE, &len);
+ in_my_stash = gv_stashpv(tokenbuf, FALSE);
+ if (!in_my_stash) {
+ char tmpbuf[1024];
+ bufptr = s;
+ sprintf(tmpbuf, "No such class %.1000s", tokenbuf);
+ yyerror(tmpbuf);
+ }
+ }
OPERATOR(MY);
case KEY_next:
case 'h':
if (strEQ(d,"hex")) return -KEY_hex;
break;
+ case 'I':
+ if (strEQ(d,"INIT")) return KEY_INIT;
+ break;
case 'i':
switch (len) {
case 2:
case 4:
if (strEQ(d,"last")) return KEY_last;
if (strEQ(d,"link")) return -KEY_link;
+ if (strEQ(d,"lock")) return -KEY_lock;
break;
case 5:
if (strEQ(d,"local")) return KEY_local;
hoistmust(pm)
register PMOP *pm;
{
+ dTHR;
if (!pm->op_pmshort && pm->op_pmregexp->regstart &&
(!pm->op_pmregexp->regmust || pm->op_pmregexp->reganch & ROPT_ANCH)
) {
char *start;
{
register char* s;
- OP *op;
+ OP *o;
short *tbl;
I32 squash;
I32 delete;
}
New(803,tbl,256,short);
- op = newPVOP(OP_TRANS, 0, (char*)tbl);
+ o = newPVOP(OP_TRANS, 0, (char*)tbl);
complement = delete = squash = 0;
while (*s == 'c' || *s == 'd' || *s == 's') {
squash = OPpTRANS_SQUASH;
s++;
}
- op->op_private = delete|squash|complement;
+ o->op_private = delete|squash|complement;
- lex_op = op;
+ lex_op = o;
yylval.ival = OP_TRANS;
return s;
}
scan_heredoc(s)
register char *s;
{
+ dTHR;
SV *herewas;
I32 op_type = OP_SCALAR;
I32 len;
(void)strcpy(d,"ARGV");
if (*d == '$') {
I32 tmp;
- if (tmp = pad_findmy(d)) {
- OP *op = newOP(OP_PADSV, 0);
- op->op_targ = tmp;
- lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, op));
+ if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
+ OP *o = newOP(OP_PADSV, 0);
+ o->op_targ = tmp;
+ lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
}
else {
GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
scan_str(start)
char *start;
{
+ dTHR;
SV *sv;
char *tmps;
register char *s = start;
scan_formline(s)
register char *s;
{
+ dTHR;
register char *eol;
register char *t;
SV *stuff = newSVpv("",0);
I32 is_format;
U32 flags;
{
+ dTHR;
I32 oldsavestack_ix = savestack_ix;
CV* outsidecv = compcv;
AV* comppadlist;
CvFLAGS(compcv) |= flags;
comppad = newAV();
+ av_push(comppad, Nullsv);
+ curpad = AvARRAY(comppad);
comppad_name = newAV();
comppad_name_fill = 0;
min_intro_pending = 0;
- av_push(comppad, Nullsv);
- curpad = AvARRAY(comppad);
padix = 0;
subline = curcop->cop_line;
+#ifdef USE_THREADS
+ av_store(comppad_name, 0, newSVpv("@_", 2));
+ curpad[0] = (SV*)newAV();
+ SvPADMY_on(curpad[0]); /* XXX Needed? */
+ CvOWNER(compcv) = 0;
+ New(666, CvMUTEXP(compcv), 1, perl_mutex);
+ MUTEX_INIT(CvMUTEXP(compcv));
+#endif /* USE_THREADS */
comppadlist = newAV();
AvREAL_off(comppadlist);
CvPADLIST(compcv) = comppadlist;
CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc((SV*)outsidecv);
+#ifdef USE_THREADS
+ CvOWNER(compcv) = 0;
+ New(666, CvMUTEXP(compcv), 1, perl_mutex);
+ MUTEX_INIT(CvMUTEXP(compcv));
+#endif /* USE_THREADS */
return oldsavestack_ix;
}
yywarn(s)
char *s;
{
+ dTHR;
--error_count;
in_eval |= 2;
yyerror(s);
yyerror(s)
char *s;
{
+ dTHR;
char *where = NULL;
char *context = NULL;
int contlen = -1;
if (++error_count >= 10)
croak("%_ has too many errors.\n", GvSV(curcop->cop_filegv));
in_my = 0;
+ in_my_stash = Nullhv;
return 0;
}
sv = mess_sv;
sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
+ dTHR;
if (dirty)
sv_catpv(sv, dgd);
else {
va_dcl
#endif
{
+ dTHR;
va_list args;
char *message;
I32 oldrunlevel = runlevel;
GV *gv;
CV *cv;
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(), "die: curstack = %p, mainstack= %p\n",
+ curstack, mainstack));/*debug*/
/* We have to switch back to mainstack or die_where may try to pop
* the eval block from the wrong stack if die is being called from a
* signal handler. - dkindred@cs.cmu.edu */
message = mess(pat, &args);
va_end(args);
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(), "die: message = %s\ndiehook = %p\n",
+ message, diehook));/*debug*/
if (diehook) {
/* sv_2cv might call croak() */
SV *olddiehook = diehook;
}
restartop = die_where(message);
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "die: restartop = %p, was_in_eval = %d, oldrunlevel = %d\n",
+ restartop, was_in_eval, oldrunlevel));/*debug*/
if ((!restartop && was_in_eval) || oldrunlevel > 1)
JMPENV_JUMP(3);
return restartop;
va_dcl
#endif
{
+ dTHR;
va_list args;
char *message;
HV *stash;
#endif
message = mess(pat, &args);
va_end(args);
+#ifdef USE_THREADS
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message));
+#endif /* USE_THREADS */
if (diehook) {
/* sv_2cv might call croak() */
SV *olddiehook = diehook;
if (warnhook) {
/* sv_2cv might call warn() */
+ dTHR;
SV *oldwarnhook = warnhook;
ENTER;
SAVESPTR(warnhook);
return retval;
}
+#ifdef USE_THREADS
+#ifdef FAKE_THREADS
+/* Very simplistic scheduler for now */
+void
+schedule(void)
+{
+ thr = thr->i.next_run;
+}
+
+void
+perl_cond_init(cp)
+perl_cond *cp;
+{
+ *cp = 0;
+}
+
+void
+perl_cond_signal(cp)
+perl_cond *cp;
+{
+ perl_thread t;
+ perl_cond cond = *cp;
+
+ if (!cond)
+ return;
+ t = cond->thread;
+ /* Insert t in the runnable queue just ahead of us */
+ t->i.next_run = thr->i.next_run;
+ thr->i.next_run->i.prev_run = t;
+ t->i.prev_run = thr;
+ thr->i.next_run = t;
+ thr->i.wait_queue = 0;
+ /* Remove from the wait queue */
+ *cp = cond->next;
+ Safefree(cond);
+}
+
+void
+perl_cond_broadcast(cp)
+perl_cond *cp;
+{
+ perl_thread t;
+ perl_cond cond, cond_next;
+
+ for (cond = *cp; cond; cond = cond_next) {
+ t = cond->thread;
+ /* Insert t in the runnable queue just ahead of us */
+ t->i.next_run = thr->i.next_run;
+ thr->i.next_run->i.prev_run = t;
+ t->i.prev_run = thr;
+ thr->i.next_run = t;
+ thr->i.wait_queue = 0;
+ /* Remove from the wait queue */
+ cond_next = cond->next;
+ Safefree(cond);
+ }
+ *cp = 0;
+}
+
+void
+perl_cond_wait(cp)
+perl_cond *cp;
+{
+ perl_cond cond;
+
+ if (thr->i.next_run == thr)
+ croak("panic: perl_cond_wait called by last runnable thread");
+
+ New(666, cond, 1, struct perl_wait_queue);
+ cond->thread = thr;
+ cond->next = *cp;
+ *cp = cond;
+ thr->i.wait_queue = cond;
+ /* Remove ourselves from runnable queue */
+ thr->i.next_run->i.prev_run = thr->i.prev_run;
+ thr->i.prev_run->i.next_run = thr->i.next_run;
+}
+#endif /* FAKE_THREADS */
+
+#ifdef OLD_PTHREADS_API
+struct thread *
+getTHR _((void))
+{
+ pthread_addr_t t;
+
+ if (pthread_getspecific(thr_key, &t))
+ croak("panic: pthread_getspecific");
+ return (struct thread *) t;
+}
+#endif /* OLD_PTHREADS_API */
+
+MAGIC *
+condpair_magic(sv)
+SV *sv;
+{
+ MAGIC *mg;
+
+ SvUPGRADE(sv, SVt_PVMG);
+ mg = mg_find(sv, 'm');
+ if (!mg) {
+ condpair_t *cp;
+
+ New(53, cp, 1, condpair_t);
+ MUTEX_INIT(&cp->mutex);
+ COND_INIT(&cp->owner_cond);
+ COND_INIT(&cp->cond);
+ cp->owner = 0;
+ MUTEX_LOCK(&sv_mutex);
+ mg = mg_find(sv, 'm');
+ if (mg) {
+ /* someone else beat us to initialising it */
+ MUTEX_UNLOCK(&sv_mutex);
+ MUTEX_DESTROY(&cp->mutex);
+ COND_DESTROY(&cp->owner_cond);
+ COND_DESTROY(&cp->cond);
+ Safefree(cp);
+ }
+ else {
+ sv_magic(sv, Nullsv, 'm', 0, 0);
+ mg = SvMAGIC(sv);
+ mg->mg_ptr = (char *)cp;
+ mg->mg_len = sizeof(cp);
+ MUTEX_UNLOCK(&sv_mutex);
+ DEBUG_L(WITH_THR(PerlIO_printf(PerlIO_stderr(),
+ "%p: condpair_magic %p\n", thr, sv));)
+ }
+ }
+ return mg;
+}
+#endif /* USE_THREADS */
#ifdef HUGE_VAL
/*
dEXT int yychar;
dEXT YYSTYPE yyval;
dEXT YYSTYPE yylval;
-#line 631 "perly.y"
+#line 632 "perly.y"
/* PROGRAM */
#line 1360 "perly.c"
#define YYABORT goto yyabort
break;
case 56:
#line 291 "perly.y"
-{ char *name = SvPVx(((SVOP*)yyvsp[0].opval)->op_sv, na);
- if (strEQ(name, "BEGIN") || strEQ(name, "END"))
+{ char *name = SvPV(((SVOP*)yyvsp[0].opval)->op_sv, na);
+ if (strEQ(name, "BEGIN") || strEQ(name, "END")
+ || strEQ(name, "INIT"))
CvUNIQUE_on(compcv);
yyval.opval = yyvsp[0].opval; }
break;
case 57:
-#line 298 "perly.y"
+#line 299 "perly.y"
{ yyval.opval = Nullop; }
break;
case 59:
-#line 302 "perly.y"
+#line 303 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 60:
-#line 303 "perly.y"
+#line 304 "perly.y"
{ yyval.opval = Nullop; expect = XSTATE; }
break;
case 61:
-#line 307 "perly.y"
+#line 308 "perly.y"
{ package(yyvsp[-1].opval); }
break;
case 62:
-#line 309 "perly.y"
+#line 310 "perly.y"
{ package(Nullop); }
break;
case 63:
-#line 313 "perly.y"
+#line 314 "perly.y"
{ CvUNIQUE_on(compcv); /* It's a BEGIN {} */ }
break;
case 64:
-#line 315 "perly.y"
+#line 316 "perly.y"
{ utilize(yyvsp[-6].ival, yyvsp[-5].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval); }
break;
case 65:
-#line 319 "perly.y"
+#line 320 "perly.y"
{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 66:
-#line 321 "perly.y"
+#line 322 "perly.y"
{ yyval.opval = newLOGOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 68:
-#line 326 "perly.y"
+#line 327 "perly.y"
{ yyval.opval = yyvsp[-1].opval; }
break;
case 69:
-#line 328 "perly.y"
+#line 329 "perly.y"
{ yyval.opval = append_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 71:
-#line 333 "perly.y"
+#line 334 "perly.y"
{ yyval.opval = convert(yyvsp[-2].ival, OPf_STACKED,
prepend_elem(OP_LIST, newGVREF(yyvsp[-2].ival,yyvsp[-1].opval), yyvsp[0].opval) ); }
break;
case 72:
-#line 336 "perly.y"
+#line 337 "perly.y"
{ yyval.opval = convert(yyvsp[-4].ival, OPf_STACKED,
prepend_elem(OP_LIST, newGVREF(yyvsp[-4].ival,yyvsp[-2].opval), yyvsp[-1].opval) ); }
break;
case 73:
-#line 339 "perly.y"
+#line 340 "perly.y"
{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, scalar(yyvsp[-5].opval), yyvsp[-1].opval),
newUNOP(OP_METHOD, 0, yyvsp[-3].opval))); }
break;
case 74:
-#line 344 "perly.y"
+#line 345 "perly.y"
{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, yyvsp[-1].opval, yyvsp[0].opval),
newUNOP(OP_METHOD, 0, yyvsp[-2].opval))); }
break;
case 75:
-#line 349 "perly.y"
+#line 350 "perly.y"
{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, yyvsp[-3].opval, yyvsp[-1].opval),
newUNOP(OP_METHOD, 0, yyvsp[-4].opval))); }
break;
case 76:
-#line 354 "perly.y"
+#line 355 "perly.y"
{ yyval.opval = convert(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
case 77:
-#line 356 "perly.y"
+#line 357 "perly.y"
{ yyval.opval = convert(yyvsp[-3].ival, 0, yyvsp[-1].opval); }
break;
case 78:
-#line 358 "perly.y"
+#line 359 "perly.y"
{ yyvsp[0].opval = newANONSUB(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
case 79:
-#line 360 "perly.y"
+#line 361 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval), yyvsp[-4].opval)); }
break;
case 82:
-#line 370 "perly.y"
+#line 371 "perly.y"
{ yyval.opval = newASSIGNOP(OPf_STACKED, yyvsp[-2].opval, yyvsp[-1].ival, yyvsp[0].opval); }
break;
case 83:
-#line 372 "perly.y"
+#line 373 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 84:
-#line 374 "perly.y"
+#line 375 "perly.y"
{ if (yyvsp[-1].ival != OP_REPEAT)
scalar(yyvsp[-2].opval);
yyval.opval = newBINOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, scalar(yyvsp[0].opval)); }
break;
case 85:
-#line 378 "perly.y"
+#line 379 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 86:
-#line 380 "perly.y"
+#line 381 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 87:
-#line 382 "perly.y"
+#line 383 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 88:
-#line 384 "perly.y"
+#line 385 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 89:
-#line 386 "perly.y"
+#line 387 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 90:
-#line 388 "perly.y"
+#line 389 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 91:
-#line 390 "perly.y"
+#line 391 "perly.y"
{ yyval.opval = newRANGE(yyvsp[-1].ival, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval));}
break;
case 92:
-#line 392 "perly.y"
+#line 393 "perly.y"
{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 93:
-#line 394 "perly.y"
+#line 395 "perly.y"
{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 94:
-#line 396 "perly.y"
+#line 397 "perly.y"
{ yyval.opval = newCONDOP(0, yyvsp[-4].opval, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 95:
-#line 398 "perly.y"
+#line 399 "perly.y"
{ yyval.opval = bind_match(yyvsp[-1].ival, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 96:
-#line 401 "perly.y"
+#line 402 "perly.y"
{ yyval.opval = newUNOP(OP_NEGATE, 0, scalar(yyvsp[0].opval)); }
break;
case 97:
-#line 403 "perly.y"
+#line 404 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 98:
-#line 405 "perly.y"
+#line 406 "perly.y"
{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); }
break;
case 99:
-#line 407 "perly.y"
+#line 408 "perly.y"
{ yyval.opval = newUNOP(OP_COMPLEMENT, 0, scalar(yyvsp[0].opval));}
break;
case 100:
-#line 409 "perly.y"
+#line 410 "perly.y"
{ yyval.opval = newUNOP(OP_REFGEN, 0, mod(yyvsp[0].opval,OP_REFGEN)); }
break;
case 101:
-#line 411 "perly.y"
+#line 412 "perly.y"
{ yyval.opval = newUNOP(OP_POSTINC, 0,
mod(scalar(yyvsp[-1].opval), OP_POSTINC)); }
break;
case 102:
-#line 414 "perly.y"
+#line 415 "perly.y"
{ yyval.opval = newUNOP(OP_POSTDEC, 0,
mod(scalar(yyvsp[-1].opval), OP_POSTDEC)); }
break;
case 103:
-#line 417 "perly.y"
+#line 418 "perly.y"
{ yyval.opval = newUNOP(OP_PREINC, 0,
mod(scalar(yyvsp[0].opval), OP_PREINC)); }
break;
case 104:
-#line 420 "perly.y"
+#line 421 "perly.y"
{ yyval.opval = newUNOP(OP_PREDEC, 0,
mod(scalar(yyvsp[0].opval), OP_PREDEC)); }
break;
case 105:
-#line 423 "perly.y"
+#line 424 "perly.y"
{ yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); }
break;
case 106:
-#line 425 "perly.y"
+#line 426 "perly.y"
{ yyval.opval = sawparens(yyvsp[-1].opval); }
break;
case 107:
-#line 427 "perly.y"
+#line 428 "perly.y"
{ yyval.opval = sawparens(newNULLLIST()); }
break;
case 108:
-#line 429 "perly.y"
+#line 430 "perly.y"
{ yyval.opval = newANONLIST(yyvsp[-1].opval); }
break;
case 109:
-#line 431 "perly.y"
+#line 432 "perly.y"
{ yyval.opval = newANONLIST(Nullop); }
break;
case 110:
-#line 433 "perly.y"
+#line 434 "perly.y"
{ yyval.opval = newANONHASH(yyvsp[-2].opval); }
break;
case 111:
-#line 435 "perly.y"
+#line 436 "perly.y"
{ yyval.opval = newANONHASH(Nullop); }
break;
case 112:
-#line 437 "perly.y"
+#line 438 "perly.y"
{ yyval.opval = newANONSUB(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); }
break;
case 113:
-#line 439 "perly.y"
+#line 440 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 114:
-#line 441 "perly.y"
+#line 442 "perly.y"
{ yyval.opval = newBINOP(OP_GELEM, 0, newGVREF(0,yyvsp[-4].opval), yyvsp[-2].opval); }
break;
case 115:
-#line 443 "perly.y"
+#line 444 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 116:
-#line 445 "perly.y"
+#line 446 "perly.y"
{ yyval.opval = newBINOP(OP_AELEM, 0, oopsAV(yyvsp[-3].opval), scalar(yyvsp[-1].opval)); }
break;
case 117:
-#line 447 "perly.y"
+#line 448 "perly.y"
{ yyval.opval = newBINOP(OP_AELEM, 0,
ref(newAVREF(yyvsp[-4].opval),OP_RV2AV),
scalar(yyvsp[-1].opval));}
break;
case 118:
-#line 451 "perly.y"
+#line 452 "perly.y"
{ assertref(yyvsp[-3].opval); yyval.opval = newBINOP(OP_AELEM, 0,
ref(newAVREF(yyvsp[-3].opval),OP_RV2AV),
scalar(yyvsp[-1].opval));}
break;
case 119:
-#line 455 "perly.y"
+#line 456 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 120:
-#line 457 "perly.y"
+#line 458 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 121:
-#line 459 "perly.y"
+#line 460 "perly.y"
{ yyval.opval = newUNOP(OP_AV2ARYLEN, 0, ref(yyvsp[0].opval, OP_AV2ARYLEN));}
break;
case 122:
-#line 461 "perly.y"
+#line 462 "perly.y"
{ yyval.opval = newBINOP(OP_HELEM, 0, oopsHV(yyvsp[-4].opval), jmaybe(yyvsp[-2].opval));
expect = XOPERATOR; }
break;
case 123:
-#line 464 "perly.y"
+#line 465 "perly.y"
{ yyval.opval = newBINOP(OP_HELEM, 0,
ref(newHVREF(yyvsp[-5].opval),OP_RV2HV),
jmaybe(yyvsp[-2].opval));
expect = XOPERATOR; }
break;
case 124:
-#line 469 "perly.y"
+#line 470 "perly.y"
{ assertref(yyvsp[-4].opval); yyval.opval = newBINOP(OP_HELEM, 0,
ref(newHVREF(yyvsp[-4].opval),OP_RV2HV),
jmaybe(yyvsp[-2].opval));
expect = XOPERATOR; }
break;
case 125:
-#line 474 "perly.y"
+#line 475 "perly.y"
{ yyval.opval = newSLICEOP(0, yyvsp[-1].opval, yyvsp[-4].opval); }
break;
case 126:
-#line 476 "perly.y"
+#line 477 "perly.y"
{ yyval.opval = newSLICEOP(0, yyvsp[-1].opval, Nullop); }
break;
case 127:
-#line 478 "perly.y"
+#line 479 "perly.y"
{ yyval.opval = prepend_elem(OP_ASLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_ASLICE, 0,
ref(yyvsp[-3].opval, OP_ASLICE))); }
break;
case 128:
-#line 484 "perly.y"
+#line 485 "perly.y"
{ yyval.opval = prepend_elem(OP_HSLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_HSLICE, 0,
expect = XOPERATOR; }
break;
case 129:
-#line 491 "perly.y"
+#line 492 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 130:
-#line 493 "perly.y"
+#line 494 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, 0, scalar(yyvsp[0].opval)); }
break;
case 131:
-#line 495 "perly.y"
+#line 496 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[-2].opval)); }
break;
case 132:
-#line 497 "perly.y"
+#line 498 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[-1].opval, scalar(yyvsp[-3].opval))); }
break;
case 133:
-#line 500 "perly.y"
+#line 501 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); }
break;
case 134:
-#line 503 "perly.y"
+#line 504 "perly.y"
{ yyval.opval = newUNOP(OP_DOFILE, 0, scalar(yyvsp[0].opval)); }
break;
case 135:
-#line 505 "perly.y"
+#line 506 "perly.y"
{ yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); }
break;
case 136:
-#line 507 "perly.y"
+#line 508 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB,
OPf_SPECIAL|OPf_STACKED,
prepend_elem(OP_LIST,
)),Nullop)); dep();}
break;
case 137:
-#line 515 "perly.y"
+#line 516 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB,
OPf_SPECIAL|OPf_STACKED,
append_elem(OP_LIST,
)))); dep();}
break;
case 138:
-#line 524 "perly.y"
+#line 525 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED,
prepend_elem(OP_LIST,
scalar(newCVREF(0,scalar(yyvsp[-2].opval))), Nullop)); dep();}
break;
case 139:
-#line 528 "perly.y"
+#line 529 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED,
prepend_elem(OP_LIST,
yyvsp[-1].opval,
scalar(newCVREF(0,scalar(yyvsp[-3].opval))))); dep();}
break;
case 140:
-#line 533 "perly.y"
+#line 534 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
newCVREF(0, scalar(yyvsp[-3].opval))); }
break;
case 141:
-#line 536 "perly.y"
+#line 537 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[-1].opval,
newCVREF(0, scalar(yyvsp[-4].opval)))); }
break;
case 142:
-#line 540 "perly.y"
+#line 541 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL);
hints |= HINT_BLOCK_SCOPE; }
break;
case 143:
-#line 543 "perly.y"
+#line 544 "perly.y"
{ yyval.opval = newLOOPEX(yyvsp[-1].ival,yyvsp[0].opval); }
break;
case 144:
-#line 545 "perly.y"
+#line 546 "perly.y"
{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); }
break;
case 145:
-#line 547 "perly.y"
+#line 548 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, 0); }
break;
case 146:
-#line 549 "perly.y"
+#line 550 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
case 147:
-#line 551 "perly.y"
+#line 552 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
case 148:
-#line 553 "perly.y"
+#line 554 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); }
break;
case 149:
-#line 556 "perly.y"
+#line 557 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, 0); }
break;
case 150:
-#line 558 "perly.y"
+#line 559 "perly.y"
{ yyval.opval = newOP(yyvsp[-2].ival, 0); }
break;
case 151:
-#line 560 "perly.y"
+#line 561 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
scalar(yyvsp[0].opval)); }
break;
case 152:
-#line 563 "perly.y"
+#line 564 "perly.y"
{ yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); }
break;
case 153:
-#line 565 "perly.y"
+#line 566 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); }
break;
case 154:
-#line 567 "perly.y"
+#line 568 "perly.y"
{ yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); }
break;
case 155:
-#line 569 "perly.y"
+#line 570 "perly.y"
{ yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); }
break;
case 158:
-#line 575 "perly.y"
+#line 576 "perly.y"
{ yyval.opval = Nullop; }
break;
case 159:
-#line 577 "perly.y"
+#line 578 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 160:
-#line 581 "perly.y"
+#line 582 "perly.y"
{ yyval.opval = Nullop; }
break;
case 161:
-#line 583 "perly.y"
+#line 584 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 162:
-#line 585 "perly.y"
+#line 586 "perly.y"
{ yyval.opval = yyvsp[-1].opval; }
break;
case 163:
-#line 588 "perly.y"
+#line 589 "perly.y"
{ yyval.ival = 0; }
break;
case 164:
-#line 589 "perly.y"
+#line 590 "perly.y"
{ yyval.ival = 1; }
break;
case 165:
-#line 593 "perly.y"
+#line 594 "perly.y"
{ in_my = 0; yyval.opval = my(yyvsp[0].opval); }
break;
case 166:
-#line 597 "perly.y"
+#line 598 "perly.y"
{ yyval.opval = newCVREF(yyvsp[-1].ival,yyvsp[0].opval); }
break;
case 167:
-#line 601 "perly.y"
+#line 602 "perly.y"
{ yyval.opval = newSVREF(yyvsp[0].opval); }
break;
case 168:
-#line 605 "perly.y"
+#line 606 "perly.y"
{ yyval.opval = newAVREF(yyvsp[0].opval); }
break;
case 169:
-#line 609 "perly.y"
+#line 610 "perly.y"
{ yyval.opval = newHVREF(yyvsp[0].opval); }
break;
case 170:
-#line 613 "perly.y"
+#line 614 "perly.y"
{ yyval.opval = newAVREF(yyvsp[0].opval); }
break;
case 171:
-#line 617 "perly.y"
+#line 618 "perly.y"
{ yyval.opval = newGVREF(0,yyvsp[0].opval); }
break;
case 172:
-#line 621 "perly.y"
+#line 622 "perly.y"
{ yyval.opval = scalar(yyvsp[0].opval); }
break;
case 173:
-#line 623 "perly.y"
+#line 624 "perly.y"
{ yyval.opval = scalar(yyvsp[0].opval); }
break;
case 174:
-#line 625 "perly.y"
+#line 626 "perly.y"
{ yyval.opval = scope(yyvsp[0].opval); }
break;
case 175:
-#line 628 "perly.y"
+#line 629 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-#line 2271 "perly.c"
+#line 2272 "perly.c"
}
yyssp -= yym;
yystate = *yyssp;
static char *
setup_argstr(SV *really, SV **mark, SV **sp)
{
+ dTHR;
char *junk, *tmps = Nullch;
register size_t cmdlen = 0;
size_t rlen;
/*{{{time_t my_time(time_t *timep)*/
time_t my_time(time_t *timep)
{
+ dTHR;
time_t when;
if (gmtime_emulation_type == 0) {
struct tm *
my_gmtime(const time_t *timep)
{
+ dTHR;
char *p;
time_t when;
struct tm *
my_localtime(const time_t *timep)
{
+ dTHR;
time_t when;
if (timep == NULL) {
/*{{{int my_utime(char *path, struct utimbuf *utimes)*/
int my_utime(char *file, struct utimbuf *utimes)
{
+ dTHR;
register int i;
long int bintime[2], len = 2, lowbit, unixtime,
secscale = 10000000; /* seconds --> 100 ns intervals */
int
flex_fstat(int fd, struct mystat *statbufp)
{
+ dTHR;
+
if (!fstat(fd,(stat_t *) statbufp)) {
if (statbufp == (struct mystat *) &statcache) *namecache == '\0';
statbufp->st_dev = encode_dev(statbufp->st_devnam);
int
flex_stat(char *fspec, struct mystat *statbufp)
{
+ dTHR;
char fileified[NAM$C_MAXRSS+1];
int retval = -1;
Perl_my_memset
Perl_cshlen
Perl_cshname
+Perl_condpair_magic
+Perl_magic_mutexfree
+Perl_opsave
+Perl_unlock_condpair
+Perl_vtbl_mutex
!END!OF!SKIP!
# All symbols have a Perl_ prefix because that's what embed.h
sed <../malloc.c >malloc.c \
-e 's/"EXTERN.h"/"..\/EXTERN.h"/' \
-e 's/"perl.h"/"..\/perl.h"/' \
- -e 's/my_exit/exit/'
+ -e 's/my_exit/exit/' \
+ -e 's/MUTEX_[A-Z_]*(&malloc_mutex);//'
# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE
$(obj):
https://perl5.git.perl.org / perl5.git / commitdiff