# endif
#endif
-/* Put this after #includes because fork and vfork prototypes may conflict. */
-#ifndef HAS_VFORK
-# define vfork fork
-#endif
-
#ifdef HAS_CHSIZE
# ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
# undef my_chsize
return result;
}
-#if 0 /* XXX never used! */
-PP(pp_indread)
-{
- STRLEN n_a;
- PL_last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*PL_stack_sp--)), n_a), TRUE,SVt_PVIO);
- return do_readline();
-}
-#endif
-
PP(pp_rcatline)
{
PL_last_in_gv = cGVOP_gv;
sv_setsv(error,*PL_stack_sp--);
}
}
- DIE(aTHX_ Nullch);
+ DIE(aTHX_ Nullformat);
}
else {
if (SvPOK(error) && SvCUR(error))
dTARGET;
GV *gv;
SV *sv;
+ IO *io;
char *tmps;
STRLEN len;
MAGIC *mg;
gv = (GV *)*++MARK;
if (!isGV(gv))
DIE(aTHX_ PL_no_usym, "filehandle");
- if (GvIOp(gv))
+ if ((io = GvIOp(gv)))
IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
- if ((mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) {
+ if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
/* Method's args are same as ours ... */
/* ... except handle is replaced by the object */
- *MARK-- = SvTIED_obj((SV*)gv, mg);
+ *MARK-- = SvTIED_obj((SV*)io, mg);
PUSHMARK(MARK);
PUTBACK;
ENTER;
{
dSP;
GV *gv;
+ IO *io;
MAGIC *mg;
if (MAXARG == 0)
else
gv = (GV*)POPs;
- if ((mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) {
+ if (gv && (io = GvIO(gv))
+ && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
+ {
PUSHMARK(SP);
- XPUSHs(SvTIED_obj((SV*)gv, mg));
+ XPUSHs(SvTIED_obj((SV*)io, mg));
PUTBACK;
ENTER;
call_method("CLOSE", G_SCALAR);
RETPUSHUNDEF;
gv = (GV*)POPs;
- if (gv && (mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) {
+ if (gv && (io = GvIO(gv))
+ && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
+ {
PUSHMARK(SP);
- XPUSHs(SvTIED_obj((SV*)gv, mg));
+ XPUSHs(SvTIED_obj((SV*)io, mg));
PUTBACK;
ENTER;
call_method("FILENO", G_SCALAR);
PP(pp_umask)
{
-#ifdef HAS_UMASK
dSP; dTARGET;
+#ifdef HAS_UMASK
Mode_t anum;
if (MAXARG < 1) {
PerlIO *fp;
MAGIC *mg;
SV *discp = Nullsv;
- STRLEN len = 0;
- char *names = NULL;
if (MAXARG < 1)
RETPUSHUNDEF;
gv = (GV*)POPs;
- if (gv && (mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) {
+ if (gv && (io = GvIO(gv))
+ && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
+ {
PUSHMARK(SP);
- XPUSHs(SvTIED_obj((SV*)gv, mg));
+ XPUSHs(SvTIED_obj((SV*)io, mg));
if (discp)
XPUSHs(discp);
PUTBACK;
RETPUSHUNDEF;
}
- if (discp) {
- names = SvPV(discp,len);
- }
-
if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp),
(discp) ? SvPV_nolen(discp) : Nullch))
RETPUSHYES;
switch(SvTYPE(varsv)) {
case SVt_PVHV:
methname = "TIEHASH";
+ HvEITER((HV *)varsv) = Null(HE *);
break;
case SVt_PVAV:
methname = "TIEARRAY";
break;
case SVt_PVGV:
-#ifdef GV_SHARED_CHECK
- if (GvSHARED((GV*)varsv)) {
- Perl_croak(aTHX_ "Attempt to tie shared GV");
+#ifdef GV_UNIQUE_CHECK
+ if (GvUNIQUE((GV*)varsv)) {
+ Perl_croak(aTHX_ "Attempt to tie unique GV");
}
#endif
methname = "TIEHANDLE";
how = PERL_MAGIC_tiedscalar;
+ /* For tied filehandles, we apply tiedscalar magic to the IO
+ slot of the GP rather than the GV itself. AMS 20010812 */
+ if (!GvIOp(varsv))
+ GvIOp(varsv) = newIO();
+ varsv = (SV *)GvIOp(varsv);
break;
default:
methname = "TIESCALAR";
PP(pp_untie)
{
dSP;
+ MAGIC *mg;
SV *sv = POPs;
char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
- MAGIC * mg ;
- if ((mg = SvTIED_mg(sv, how))) {
+ if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
+ RETPUSHYES;
+
+ if ((mg = SvTIED_mg(sv, how))) {
SV *obj = SvRV(mg->mg_obj);
GV *gv;
CV *cv = NULL;
"untie attempted while %"UVuf" inner references still exist",
(UV)SvREFCNT(obj) - 1 ) ;
}
+ sv_unmagic(sv, how);
}
- sv_unmagic(sv, how);
RETPUSHYES;
}
PP(pp_tied)
{
dSP;
+ MAGIC *mg;
SV *sv = POPs;
char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
- MAGIC *mg;
+
+ if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
+ RETPUSHUNDEF;
if ((mg = SvTIED_mg(sv, how))) {
SV *osv = SvTIED_obj(sv, mg);
{
dSP; dTARGET;
GV *gv;
+ IO *io;
MAGIC *mg;
if (MAXARG == 0)
else
gv = (GV*)POPs;
- if ((mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) {
+ if (gv && (io = GvIO(gv))
+ && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
+ {
I32 gimme = GIMME_V;
PUSHMARK(SP);
- XPUSHs(SvTIED_obj((SV*)gv, mg));
+ XPUSHs(SvTIED_obj((SV*)io, mg));
PUTBACK;
ENTER;
call_method("GETC", gimme);
else
gv = PL_defoutgv;
- if ((mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) {
+ if (gv && (io = GvIO(gv))
+ && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
+ {
if (MARK == ORIGMARK) {
MEXTEND(SP, 1);
++MARK;
++SP;
}
PUSHMARK(MARK - 1);
- *MARK = SvTIED_obj((SV*)gv, mg);
+ *MARK = SvTIED_obj((SV*)io, mg);
PUTBACK;
ENTER;
call_method("PRINTF", G_SCALAR);
if (!(io = GvIO(gv))) {
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
- SETERRNO(EBADF,RMS$_IFI);
+ SETERRNO(EBADF,VMS_RMS_IFI);
goto just_say_no;
}
else if (!(fp = IoOFP(io))) {
else if (ckWARN(WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
}
- SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
+ SETERRNO(EBADF,IoIFP(io)?VMS_RMS_FAC:VMS_RMS_IFI);
goto just_say_no;
}
else {
Size_t wanted;
gv = (GV*)*++MARK;
- if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) &&
- (mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar)))
+ if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
+ && gv && (io = GvIO(gv))
+ && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
{
SV *sv;
PUSHMARK(MARK-1);
- *MARK = SvTIED_obj((SV*)gv, mg);
+ *MARK = SvTIED_obj((SV*)io, mg);
ENTER;
call_method("READ", G_SCALAR);
LEAVE;
gv = (GV*)*++MARK;
if (PL_op->op_type == OP_SYSWRITE
- && (mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar)))
+ && gv && (io = GvIO(gv))
+ && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
{
SV *sv;
PUSHMARK(MARK-1);
- *MARK = SvTIED_obj((SV*)gv, mg);
+ *MARK = SvTIED_obj((SV*)io, mg);
ENTER;
call_method("WRITE", G_SCALAR);
LEAVE;
{
dSP;
GV *gv;
+ IO *io;
MAGIC *mg;
if (MAXARG == 0) {
else
gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
- if (gv && (mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) {
+ if (gv && (io = GvIO(gv))
+ && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
+ {
PUSHMARK(SP);
- XPUSHs(SvTIED_obj((SV*)gv, mg));
+ XPUSHs(SvTIED_obj((SV*)io, mg));
PUTBACK;
ENTER;
call_method("EOF", G_SCALAR);
{
dSP; dTARGET;
GV *gv;
+ IO *io;
MAGIC *mg;
if (MAXARG == 0)
else
gv = PL_last_in_gv = (GV*)POPs;
- if (gv && (mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) {
+ if (gv && (io = GvIO(gv))
+ && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
+ {
PUSHMARK(SP);
- XPUSHs(SvTIED_obj((SV*)gv, mg));
+ XPUSHs(SvTIED_obj((SV*)io, mg));
PUTBACK;
ENTER;
call_method("TELL", G_SCALAR);
{
dSP;
GV *gv;
+ IO *io;
int whence = POPi;
#if LSEEKSIZE > IVSIZE
Off_t offset = (Off_t)SvNVx(POPs);
gv = PL_last_in_gv = (GV*)POPs;
- if (gv && (mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) {
+ if (gv && (io = GvIO(gv))
+ && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
+ {
PUSHMARK(SP);
- XPUSHs(SvTIED_obj((SV*)gv, mg));
+ XPUSHs(SvTIED_obj((SV*)io, mg));
#if LSEEKSIZE > IVSIZE
XPUSHs(sv_2mortal(newSVnv((NV) offset)));
#else
if (result)
RETPUSHYES;
if (!errno)
- SETERRNO(EBADF,RMS$_IFI);
+ SETERRNO(EBADF,VMS_RMS_IFI);
RETPUSHUNDEF;
}
#else
if (!io || !argsv || !IoIFP(io)) {
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
- SETERRNO(EBADF,RMS$_IFI); /* well, sort of... */
+ SETERRNO(EBADF,VMS_RMS_IFI); /* well, sort of... */
RETPUSHUNDEF;
}
if (SvPOK(argsv)) {
if (s[SvCUR(argsv)] != 17)
DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
- PL_op_name[optype]);
+ OP_NAME(PL_op));
s[SvCUR(argsv)] = 0; /* put our null back */
SvSETMAGIC(argsv); /* Assume it has changed */
}
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
value = 0;
- SETERRNO(EBADF,RMS$_IFI);
+ SETERRNO(EBADF,VMS_RMS_IFI);
}
PUSHi(value);
RETURN;
report_evil_fh(gv, io, PL_op->op_type);
if (IoIFP(io))
do_close(gv, FALSE);
- SETERRNO(EBADF,LIB$_INVARG);
+ SETERRNO(EBADF,VMS_LIB_INVARG);
RETPUSHUNDEF;
}
nuts:
if (ckWARN(WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
- SETERRNO(EBADF,SS$_IVCHAN);
+ SETERRNO(EBADF,VMS_SS_IVCHAN);
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_sock_func, "bind");
nuts:
if (ckWARN(WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
- SETERRNO(EBADF,SS$_IVCHAN);
+ SETERRNO(EBADF,VMS_SS_IVCHAN);
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_sock_func, "connect");
nuts:
if (ckWARN(WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
- SETERRNO(EBADF,SS$_IVCHAN);
+ SETERRNO(EBADF,VMS_SS_IVCHAN);
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_sock_func, "listen");
nuts:
if (ckWARN(WARN_CLOSED))
report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
- SETERRNO(EBADF,SS$_IVCHAN);
+ SETERRNO(EBADF,VMS_SS_IVCHAN);
badexit:
RETPUSHUNDEF;
nuts:
if (ckWARN(WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
- SETERRNO(EBADF,SS$_IVCHAN);
+ SETERRNO(EBADF,VMS_SS_IVCHAN);
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_sock_func, "shutdown");
nuts:
if (ckWARN(WARN_CLOSED))
report_evil_fh(gv, io, optype);
- SETERRNO(EBADF,SS$_IVCHAN);
+ SETERRNO(EBADF,VMS_SS_IVCHAN);
nuts2:
RETPUSHUNDEF;
nuts:
if (ckWARN(WARN_CLOSED))
report_evil_fh(gv, io, optype);
- SETERRNO(EBADF,SS$_IVCHAN);
+ SETERRNO(EBADF,VMS_SS_IVCHAN);
nuts2:
RETPUSHUNDEF;
gv = cGVOP_gv;
report_evil_fh(gv, GvIO(gv), PL_op->op_type);
}
- SETERRNO(EBADF,RMS$_IFI);
+ SETERRNO(EBADF,VMS_RMS_IFI);
RETPUSHUNDEF;
}
}
SV **svp;
STRLEN n_a;
- if (MAXARG < 1)
- tmps = Nullch;
+ if( MAXARG == 1 )
+ tmps = POPpx;
else
- tmps = POPpx;
- if (!tmps || !*tmps) {
- svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
- if (svp)
- tmps = SvPV(*svp, n_a);
- }
- if (!tmps || !*tmps) {
- svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
- if (svp)
- tmps = SvPV(*svp, n_a);
- }
+ tmps = 0;
+
+ if( !tmps || !*tmps ) {
+ if ( (svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE))
+ || (svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE))
#ifdef VMS
- if (!tmps || !*tmps) {
- svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
- if (svp)
- tmps = SvPV(*svp, n_a);
- }
+ || (svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE))
#endif
+ )
+ {
+ if( MAXARG == 1 )
+ deprecate("chdir('') or chdir(undef) as chdir()");
+ tmps = SvPV(*svp, n_a);
+ }
+ else {
+ PUSHi(0);
+ RETURN;
+ }
+ }
+
TAINT_PROPER("chdir");
PUSHi( PerlDir_chdir(tmps) >= 0 );
#ifdef VMS
char *tmps = SvPV(TOPs, n_a);
TAINT_PROPER("link");
SETi( PerlLIO_link(tmps, tmps2) >= 0 );
+ RETURN;
#else
DIE(aTHX_ PL_no_func, "link");
#endif
- RETURN;
}
PP(pp_symlink)
RETPUSHYES;
nope:
if (!errno)
- SETERRNO(EBADF,RMS$_IFI);
+ SETERRNO(EBADF,VMS_RMS_IFI);
RETPUSHUNDEF;
#else
DIE(aTHX_ PL_no_dir_func, "closedir");
EXTEND(SP, 1);
PERL_FLUSHALL_FOR_CHILD;
- childpid = fork();
+ childpid = PerlProc_fork();
if (childpid < 0)
RETSETUNDEF;
if (!childpid) {
}
PERL_FLUSHALL_FOR_CHILD;
#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
- {
- Pid_t childpid;
- int status;
- Sigsave_t ihand,qhand; /* place to save signals during system() */
-
- if (PerlProc_pipe(pp) >= 0)
- did_pipes = 1;
- while ((childpid = vfork()) == -1) {
- if (errno != EAGAIN) {
- value = -1;
- SP = ORIGMARK;
- PUSHi(value);
- if (did_pipes) {
- PerlLIO_close(pp[0]);
- PerlLIO_close(pp[1]);
- }
- RETURN;
- }
- sleep(5);
- }
- if (childpid > 0) {
- if (did_pipes)
- PerlLIO_close(pp[1]);
+ {
+ Pid_t childpid;
+ int status;
+ Sigsave_t ihand,qhand; /* place to save signals during system() */
+
+ if (PerlProc_pipe(pp) >= 0)
+ did_pipes = 1;
+ while ((childpid = PerlProc_fork()) == -1) {
+ if (errno != EAGAIN) {
+ value = -1;
+ SP = ORIGMARK;
+ PUSHi(value);
+ if (did_pipes) {
+ PerlLIO_close(pp[0]);
+ PerlLIO_close(pp[1]);
+ }
+ RETURN;
+ }
+ sleep(5);
+ }
+ if (childpid > 0) {
+ if (did_pipes)
+ PerlLIO_close(pp[1]);
#ifndef PERL_MICRO
- rsignal_save(SIGINT, SIG_IGN, &ihand);
- rsignal_save(SIGQUIT, SIG_IGN, &qhand);
+ rsignal_save(SIGINT, SIG_IGN, &ihand);
+ rsignal_save(SIGQUIT, SIG_IGN, &qhand);
#endif
- do {
- result = wait4pid(childpid, &status, 0);
- } while (result == -1 && errno == EINTR);
+ do {
+ result = wait4pid(childpid, &status, 0);
+ } while (result == -1 && errno == EINTR);
#ifndef PERL_MICRO
- (void)rsignal_restore(SIGINT, &ihand);
- (void)rsignal_restore(SIGQUIT, &qhand);
-#endif
- STATUS_NATIVE_SET(result == -1 ? -1 : status);
- do_execfree(); /* free any memory child malloced on vfork */
- SP = ORIGMARK;
- if (did_pipes) {
- int errkid;
- int n = 0, n1;
-
- while (n < sizeof(int)) {
- n1 = PerlLIO_read(pp[0],
- (void*)(((char*)&errkid)+n),
- (sizeof(int)) - n);
- if (n1 <= 0)
- break;
- n += n1;
- }
- PerlLIO_close(pp[0]);
- if (n) { /* Error */
- if (n != sizeof(int))
- DIE(aTHX_ "panic: kid popen errno read");
- errno = errkid; /* Propagate errno from kid */
- STATUS_CURRENT = -1;
- }
- }
- PUSHi(STATUS_CURRENT);
- RETURN;
- }
- if (did_pipes) {
- PerlLIO_close(pp[0]);
+ (void)rsignal_restore(SIGINT, &ihand);
+ (void)rsignal_restore(SIGQUIT, &qhand);
+#endif
+ STATUS_NATIVE_SET(result == -1 ? -1 : status);
+ do_execfree(); /* free any memory child malloced on fork */
+ SP = ORIGMARK;
+ if (did_pipes) {
+ int errkid;
+ int n = 0, n1;
+
+ while (n < sizeof(int)) {
+ n1 = PerlLIO_read(pp[0],
+ (void*)(((char*)&errkid)+n),
+ (sizeof(int)) - n);
+ if (n1 <= 0)
+ break;
+ n += n1;
+ }
+ PerlLIO_close(pp[0]);
+ if (n) { /* Error */
+ if (n != sizeof(int))
+ DIE(aTHX_ "panic: kid popen errno read");
+ errno = errkid; /* Propagate errno from kid */
+ STATUS_CURRENT = -1;
+ }
+ }
+ PUSHi(STATUS_CURRENT);
+ RETURN;
+ }
+ if (did_pipes) {
+ PerlLIO_close(pp[0]);
#if defined(HAS_FCNTL) && defined(F_SETFD)
- fcntl(pp[1], F_SETFD, FD_CLOEXEC);
- }
+ fcntl(pp[1], F_SETFD, FD_CLOEXEC);
#endif
+ }
}
if (PL_op->op_flags & OPf_STACKED) {
SV *really = *++MARK;
#endif
}
-#if !defined(HAS_FORK) && defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
- if (value >= 0)
- my_exit(value);
-#endif
-
SP = ORIGMARK;
PUSHi(value);
RETURN;
else
tmbuf = gmtime(&when);
- EXTEND(SP, 9);
- EXTEND_MORTAL(9);
if (GIMME != G_ARRAY) {
SV *tsv;
+ EXTEND(SP, 1);
+ EXTEND_MORTAL(1);
if (!tmbuf)
RETPUSHUNDEF;
tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
PUSHs(sv_2mortal(tsv));
}
else if (tmbuf) {
- PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
+ EXTEND(SP, 9);
+ EXTEND_MORTAL(9);
+ PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
projects / p5sagit/p5-mst-13.2.git / blobdiff