#define PERL_IN_PP_HOT_C
#include "perl.h"
-#ifdef I_UNISTD
-#include <unistd.h>
-#endif
-
/* Hot code. */
#ifdef USE_THREADS
dPOPTOPssrl;
STRLEN len;
U8 *s;
- bool left_utf;
- bool right_utf;
+ bool left_utf8;
+ bool right_utf8;
if (TARG == right && SvGMAGICAL(right))
mg_get(right);
if (SvGMAGICAL(left))
mg_get(left);
- left_utf = DO_UTF8(left);
- right_utf = DO_UTF8(right);
-
- if (left_utf != right_utf) {
- if (TARG == right && !right_utf) {
+ left_utf8 = DO_UTF8(left);
+ right_utf8 = DO_UTF8(right);
+
+ if (left_utf8 != right_utf8) {
+ if (TARG == right && !right_utf8) {
sv_utf8_upgrade(TARG); /* Now straight binary copy */
SvUTF8_on(TARG);
}
U8 *l, *c, *olds = NULL;
STRLEN targlen;
s = (U8*)SvPV(right,len);
- right_utf |= DO_UTF8(right);
+ right_utf8 |= DO_UTF8(right);
if (TARG == right) {
/* Take a copy since we're about to overwrite TARG */
olds = s = (U8*)savepvn((char*)s, len);
}
- if (!SvOK(left) && SvTYPE(left) <= SVt_PVMG)
- sv_setpv(left, ""); /* Suppress warning. */
+ if (!SvOK(left) && SvTYPE(left) <= SVt_PVMG) {
+ if (SvREADONLY(left))
+ left = sv_2mortal(newSVsv(left));
+ else
+ sv_setpv(left, ""); /* Suppress warning. */
+ }
l = (U8*)SvPV(left, targlen);
- left_utf |= DO_UTF8(left);
+ left_utf8 |= DO_UTF8(left);
if (TARG != left)
sv_setpvn(TARG, (char*)l, targlen);
- if (!left_utf)
+ if (!left_utf8)
sv_utf8_upgrade(TARG);
/* Extend TARG to length of right (s) */
targlen = SvCUR(TARG) + len;
- if (!right_utf) {
+ if (!right_utf8) {
/* plus one for each hi-byte char if we have to upgrade */
for (c = s; c < s + len; c++) {
- if (*c & 0x80)
+ if (UTF8_IS_CONTINUED(*c))
targlen++;
}
}
SvGROW(TARG, targlen+1);
/* And now copy, maybe upgrading right to UTF8 on the fly */
- for (c = (U8*)SvEND(TARG); len--; s++) {
- if (*s & 0x80 && !right_utf)
- c = uv_to_utf8(c, *s);
- else
- *c++ = *s;
- }
+ if (right_utf8)
+ Copy(s, SvEND(TARG), len, U8);
+ else {
+ for (c = (U8*)SvEND(TARG); len--; s++)
+ c = uv_to_utf8(c, *s);
+ }
SvCUR_set(TARG, targlen);
*SvEND(TARG) = '\0';
SvUTF8_on(TARG);
}
else
sv_setpvn(TARG, (char *)s, len); /* suppress warning */
- if (left_utf)
+ if (left_utf8)
SvUTF8_on(TARG);
SETTARG;
RETURN;
RETURN;
}
if (!(io = GvIO(gv))) {
- dTHR;
if ((GvEGV(gv)) && (mg = SvTIED_mg((SV*)GvEGV(gv),'q')))
goto had_magic;
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
}
else if (!(fp = IoOFP(io))) {
if (ckWARN2(WARN_CLOSED, WARN_IO)) {
- if (IoIFP(io)) {
- /* integrate with report_evil_fh()? */
- char *name = NULL;
- if (isGV(gv)) {
- SV* sv = sv_newmortal();
- gv_efullname4(sv, gv, Nullch, FALSE);
- name = SvPV_nolen(sv);
- }
- if (name && *name)
- Perl_warner(aTHX_ WARN_IO,
- "Filehandle %s opened only for input", name);
- else
- Perl_warner(aTHX_ WARN_IO,
- "Filehandle opened only for input");
- }
+ if (IoIFP(io))
+ report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
}
}
else {
MARK++;
- if (PL_ofslen) {
+ if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
while (MARK <= SP) {
if (!do_print(*MARK, fp))
break;
MARK++;
if (MARK <= SP) {
- if (PerlIO_write(fp, PL_ofs, PL_ofslen) == 0 || PerlIO_error(fp)) {
+ if (!do_print(PL_ofs_sv, fp)) { /* $, */
MARK--;
break;
}
if (MARK <= SP)
goto just_say_no;
else {
- if (PL_orslen)
- if (PerlIO_write(fp, PL_ors, PL_orslen) == 0 || PerlIO_error(fp))
+ if (PL_ors_sv && SvOK(PL_ors_sv))
+ if (!do_print(PL_ors_sv, fp)) /* $\ */
goto just_say_no;
if (IoFLAGS(io) & IOf_FLUSH)
(void)do_close(PL_last_in_gv, FALSE); /* now it does*/
}
}
- else if (type == OP_GLOB) {
- SV *tmpcmd = NEWSV(55, 0);
- SV *tmpglob = POPs;
- ENTER;
- SAVEFREESV(tmpcmd);
-#ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
- /* since spawning off a process is a real performance hit */
- {
-#include <descrip.h>
-#include <lib$routines.h>
-#include <nam.h>
-#include <rmsdef.h>
- char rslt[NAM$C_MAXRSS+1+sizeof(unsigned short int)] = {'\0','\0'};
- char vmsspec[NAM$C_MAXRSS+1];
- char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp;
- char tmpfnam[L_tmpnam] = "SYS$SCRATCH:";
- $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
- PerlIO *tmpfp;
- STRLEN i;
- struct dsc$descriptor_s wilddsc
- = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
- struct dsc$descriptor_vs rsdsc
- = {sizeof rslt, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, rslt};
- unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0, hasver = 0, isunix = 0;
-
- /* We could find out if there's an explicit dev/dir or version
- by peeking into lib$find_file's internal context at
- ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
- but that's unsupported, so I don't want to do it now and
- have it bite someone in the future. */
- strcat(tmpfnam,PerlLIO_tmpnam(NULL));
- cp = SvPV(tmpglob,i);
- for (; i; i--) {
- if (cp[i] == ';') hasver = 1;
- if (cp[i] == '.') {
- if (sts) hasver = 1;
- else sts = 1;
- }
- if (cp[i] == '/') {
- hasdir = isunix = 1;
- break;
- }
- if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
- hasdir = 1;
- break;
- }
- }
- if ((tmpfp = PerlIO_open(tmpfnam,"w+","fop=dlt")) != NULL) {
- Stat_t st;
- if (!PerlLIO_stat(SvPVX(tmpglob),&st) && S_ISDIR(st.st_mode))
- ok = ((wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec)) != NULL);
- else ok = ((wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec)) != NULL);
- if (ok) wilddsc.dsc$w_length = (unsigned short int) strlen(wilddsc.dsc$a_pointer);
- while (ok && ((sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
- &dfltdsc,NULL,NULL,NULL))&1)) {
- end = rstr + (unsigned long int) *rslt;
- if (!hasver) while (*end != ';') end--;
- *(end++) = '\n'; *end = '\0';
- for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
- if (hasdir) {
- if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
- begin = rstr;
- }
- else {
- begin = end;
- while (*(--begin) != ']' && *begin != '>') ;
- ++begin;
- }
- ok = (PerlIO_puts(tmpfp,begin) != EOF);
- }
- if (cxt) (void)lib$find_file_end(&cxt);
- if (ok && sts != RMS$_NMF &&
- sts != RMS$_DNF && sts != RMS$_FNF) ok = 0;
- if (!ok) {
- if (!(sts & 1)) {
- SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
- }
- PerlIO_close(tmpfp);
- fp = NULL;
- }
- else {
- PerlIO_rewind(tmpfp);
- IoTYPE(io) = IoTYPE_RDONLY;
- IoIFP(io) = fp = tmpfp;
- IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
- }
- }
- }
-#else /* !VMS */
-#ifdef MACOS_TRADITIONAL
- sv_setpv(tmpcmd, "glob ");
- sv_catsv(tmpcmd, tmpglob);
- sv_catpv(tmpcmd, " |");
-#else
-#ifdef DOSISH
-#ifdef OS2
- sv_setpv(tmpcmd, "for a in ");
- sv_catsv(tmpcmd, tmpglob);
- sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |");
-#else
-#ifdef DJGPP
- sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */
- sv_catsv(tmpcmd, tmpglob);
-#else
- sv_setpv(tmpcmd, "perlglob ");
- sv_catsv(tmpcmd, tmpglob);
- sv_catpv(tmpcmd, " |");
-#endif /* !DJGPP */
-#endif /* !OS2 */
-#else /* !DOSISH */
-#if defined(CSH)
- sv_setpvn(tmpcmd, PL_cshname, PL_cshlen);
- sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
- sv_catsv(tmpcmd, tmpglob);
- sv_catpv(tmpcmd, "' 2>/dev/null |");
-#else
- sv_setpv(tmpcmd, "echo ");
- sv_catsv(tmpcmd, tmpglob);
-#if 'z' - 'a' == 25
- sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|");
-#else
- sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
-#endif
-#endif /* !CSH */
-#endif /* !DOSISH */
-#endif /* MACOS_TRADITIONAL */
- (void)do_open(PL_last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd),
- FALSE, O_RDONLY, 0, Nullfp);
- fp = IoIFP(io);
-#endif /* !VMS */
- LEAVE;
- }
+ else if (type == OP_GLOB)
+ fp = Perl_start_glob(aTHX_ POPs, io);
}
else if (type == OP_GLOB)
SP--;
else if (ckWARN(WARN_IO) /* stdout/stderr or other write fh */
&& (IoTYPE(io) == IoTYPE_WRONLY || fp == PerlIO_stdout()
|| fp == PerlIO_stderr()))
- {
- /* integrate with report_evil_fh()? */
- char *name = NULL;
- if (isGV(PL_last_in_gv)) { /* can this ever fail? */
- SV* sv = sv_newmortal();
- gv_efullname4(sv, PL_last_in_gv, Nullch, FALSE);
- name = SvPV_nolen(sv);
- }
- if (name && *name)
- Perl_warner(aTHX_ WARN_IO,
- "Filehandle %s opened only for output", name);
- else
- Perl_warner(aTHX_ WARN_IO,
- "Filehandle opened only for output");
- }
+ report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
}
if (!fp) {
if (ckWARN2(WARN_GLOB, WARN_CLOSED)
offset = 0;
}
+ /* This should not be marked tainted if the fp is marked clean */
+#define MAYBE_TAINT_LINE(io, sv) \
+ if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
+ TAINT; \
+ SvTAINTED_on(sv); \
+ }
+
/* delay EOF state for a snarfed empty file */
#define SNARF_EOF(gimme,rs,io,sv) \
(gimme != G_SCALAR || SvCUR(sv) \
(void)SvOK_off(TARG);
PUSHTARG;
}
+ MAYBE_TAINT_LINE(io, sv);
RETURN;
}
- /* This should not be marked tainted if the fp is marked clean */
- if (!(IoFLAGS(io) & IOf_UNTAINT)) {
- TAINT;
- SvTAINTED_on(sv);
- }
+ MAYBE_TAINT_LINE(io, sv);
IoLINES(io)++;
IoFLAGS(io) |= IOf_NOLINE;
SvSETMAGIC(sv);
U32 defer = PL_op->op_private & OPpLVAL_DEFER;
SV *sv;
U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
+ I32 preeminent;
if (SvTYPE(hv) == SVt_PVHV) {
+ if (PL_op->op_private & OPpLVAL_INTRO)
+ preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
svp = he ? &HeVAL(he) : 0;
}
if (PL_op->op_private & OPpLVAL_INTRO) {
if (HvNAME(hv) && isGV(*svp))
save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
- else
- save_helem(hv, keysv, svp);
+ else {
+ if (!preeminent) {
+ STRLEN keylen;
+ char *key = SvPV(keysv, keylen);
+ save_delete(hv, key, keylen);
+ } else
+ save_helem(hv, keysv, svp);
+ }
}
else if (PL_op->op_private & OPpDEREF)
vivify_ref(*svp, PL_op->op_private & OPpDEREF);
STATIC CV *
S_get_db_sub(pTHX_ SV **svp, CV *cv)
{
- dTHR;
SV *dbsv = GvSV(PL_DBsub);
if (!PERLDB_SUB_NN) {
unset_cvowner(pTHXo_ void *cvarg)
{
register CV* cv = (CV *) cvarg;
-#ifdef DEBUGGING
- dTHR;
-#endif /* DEBUGGING */
DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
thr, cv, SvPEEK((SV*)cv))));
projects / p5sagit/p5-mst-13.2.git / blobdiff