/* pp_sys.c
*
- * Copyright (c) 1991-1997, Larry Wall
+ * Copyright (c) 1991-1999, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
#include "EXTERN.h"
#include "perl.h"
+#ifdef HAS_GETSPENT
+/* Shadow password support for solaris - pdo@cs.umd.edu*/
+#include <shadow.h>
+#endif
+
/* XXX If this causes problems, set i_unistd=undef in the hint file. */
#ifdef I_UNISTD
# include <unistd.h>
/* F_OK unused: if stat() cannot find it... */
#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
-/* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
+ /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
# define PERL_EFF_ACCESS_R_OK(p) (access((p), R_OK | EFF_ONLY_OK))
# define PERL_EFF_ACCESS_W_OK(p) (access((p), W_OK | EFF_ONLY_OK))
# define PERL_EFF_ACCESS_X_OK(p) (access((p), X_OK | EFF_ONLY_OK))
#endif
#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_EACCESS)
-/* HP SecureWare */
# if defined(I_SYS_SECURITY)
# include <sys/security.h>
# endif
-# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK, ACC_SELF))
-# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK, ACC_SELF))
-# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK, ACC_SELF))
+ /* XXX Configure test needed for eaccess */
+# ifdef ACC_SELF
+ /* HP SecureWare */
+# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK, ACC_SELF))
+# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK, ACC_SELF))
+# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK, ACC_SELF))
+# else
+ /* SCO */
+# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK))
+# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK))
+# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK))
+# endif
#endif
#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESSX) && defined(ACC_SELF)
-/* AIX */
+ /* AIX */
# define PERL_EFF_ACCESS_R_OK(p) (accessx((p), R_OK, ACC_SELF))
# define PERL_EFF_ACCESS_W_OK(p) (accessx((p), W_OK, ACC_SELF))
# define PERL_EFF_ACCESS_X_OK(p) (accessx((p), X_OK, ACC_SELF))
PL_last_in_gv = (GV*)*PL_stack_sp--;
SAVESPTR(PL_rs); /* This is not permanent, either. */
- PL_rs = sv_2mortal(newSVpv("", 1));
+ PL_rs = sv_2mortal(newSVpvn("\000", 1));
#ifndef DOSISH
#ifndef CSH
*SvPVX(PL_rs) = '\n';
PP(pp_warn)
{
djSP; dMARK;
+ SV *tmpsv;
char *tmps;
- STRLEN n_a;
+ STRLEN len;
if (SP - MARK != 1) {
dTARGET;
do_join(TARG, &PL_sv_no, MARK, SP);
- tmps = SvPV(TARG, n_a);
+ tmpsv = TARG;
SP = MARK + 1;
}
else {
- tmps = SvPV(TOPs, n_a);
+ tmpsv = TOPs;
}
- if (!tmps || !*tmps) {
+ tmps = SvPV(tmpsv, len);
+ if (!tmps || !len) {
SV *error = ERRSV;
(void)SvUPGRADE(error, SVt_PV);
if (SvPOK(error) && SvCUR(error))
sv_catpv(error, "\t...caught");
- tmps = SvPV(error, n_a);
+ tmpsv = error;
+ tmps = SvPV(tmpsv, len);
}
- if (!tmps || !*tmps)
- tmps = "Warning: something's wrong";
- warn("%s", tmps);
+ if (!tmps || !len)
+ tmpsv = sv_2mortal(newSVpvn("Warning: something's wrong", 26));
+
+ warn("%_", tmpsv);
RETSETYES;
}
{
djSP; dMARK;
char *tmps;
- SV *tmpsv = Nullsv;
- char *pat = "%s";
- STRLEN n_a;
+ SV *tmpsv;
+ STRLEN len;
+ bool multiarg = 0;
if (SP - MARK != 1) {
dTARGET;
do_join(TARG, &PL_sv_no, MARK, SP);
- tmps = SvPV(TARG, n_a);
+ tmpsv = TARG;
+ tmps = SvPV(tmpsv, len);
+ multiarg = 1;
SP = MARK + 1;
}
else {
tmpsv = TOPs;
- tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, n_a);
+ tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, len);
}
- if (!tmps || !*tmps) {
+ if (!tmps || !len) {
SV *error = ERRSV;
(void)SvUPGRADE(error, SVt_PV);
- if(tmpsv ? SvROK(tmpsv) : SvROK(error)) {
- if(tmpsv)
+ if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
+ if (!multiarg)
SvSetSV(error,tmpsv);
- else if(sv_isobject(error)) {
+ else if (sv_isobject(error)) {
HV *stash = SvSTASH(SvRV(error));
GV *gv = gv_fetchmethod(stash, "PROPAGATE");
if (gv) {
sv_setsv(error,*PL_stack_sp--);
}
}
- pat = Nullch;
+ DIE(Nullch);
}
else {
if (SvPOK(error) && SvCUR(error))
sv_catpv(error, "\t...propagated");
- tmps = SvPV(error, n_a);
+ tmpsv = error;
+ tmps = SvPV(tmpsv, len);
}
}
- if (!tmps || !*tmps)
- tmps = "Died";
- DIE(pat, tmps);
+ if (!tmps || !len)
+ tmpsv = sv_2mortal(newSVpvn("Died", 4));
+
+ DIE("%_", tmpsv);
}
/* I/O. */
SV *sv;
char *tmps;
STRLEN len;
+ MAGIC *mg;
if (MAXARG > 1)
sv = POPs;
DIE(PL_no_usym, "filehandle");
if (GvIOp(gv))
IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
+
+#if 0 /* no undef means tmpfile() yet */
+ if (sv == &PL_sv_undef) {
+#ifdef PerlIO
+ PerlIO *fp = PerlIO_tmpfile();
+#else
+ PerlIO *fp = tmpfile();
+#endif
+ if (fp != Nullfp && do_open(gv, "+>&", 3, FALSE, 0, 0, fp))
+ PUSHi( (I32)PL_forkprocess );
+ else
+ RETPUSHUNDEF;
+ RETURN;
+ }
+#endif /* no undef means tmpfile() yet */
+
+
+ if (mg = SvTIED_mg((SV*)gv, 'q')) {
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)gv, mg));
+ XPUSHs(sv);
+ PUTBACK;
+ ENTER;
+ perl_call_method("OPEN", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ RETURN;
+ }
+
tmps = SvPV(sv, len);
if (do_open(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp))
PUSHi( (I32)PL_forkprocess );
GV *gv;
IO *io;
PerlIO *fp;
+ MAGIC *mg;
+
if (MAXARG < 1)
RETPUSHUNDEF;
gv = (GV*)POPs;
+
+ if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)gv, mg));
+ PUTBACK;
+ ENTER;
+ perl_call_method("FILENO", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ RETURN;
+ }
+
if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
RETPUSHUNDEF;
PUSHi(PerlIO_fileno(fp));
PP(pp_umask)
{
djSP; dTARGET;
- int anum;
+ Mode_t anum;
#ifdef HAS_UMASK
if (MAXARG < 1) {
GV *gv;
IO *io;
PerlIO *fp;
+ MAGIC *mg;
if (MAXARG < 1)
RETPUSHUNDEF;
- gv = (GV*)POPs;
+ gv = (GV*)POPs;
+
+ if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)gv, mg));
+ PUTBACK;
+ ENTER;
+ perl_call_method("BINMODE", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ RETURN;
+ }
EXTEND(SP, 1);
if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
/* If SELECT_MIN_BITS is greater than one we most probably will want
* to align the sizes with SELECT_MIN_BITS/8 because for example
* in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
- * UNIX, Solaris, NeXT) the smallest quantum select() operates on
- * (sets bit) is 32 bits. */
+ * UNIX, Solaris, NeXT, Rhapsody) the smallest quantum select() operates
+ * on (sets/tests/clears bits) is 32 bits. */
growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
# else
growsize = sizeof(fd_set);
sv = POPs;
gv = (GV *)POPs;
+ /* Need TIEHANDLE method ? */
+
tmps = SvPV(sv, len);
if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
IoLINES(GvIOp(gv)) = 0;
{
djSP;
GV *gv;
+ MAGIC *mg;
if (MAXARG <= 0)
gv = PL_last_in_gv;
else
gv = PL_last_in_gv = (GV*)POPs;
+
+ if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)gv, mg));
+ PUTBACK;
+ ENTER;
+ perl_call_method("EOF", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ RETURN;
+ }
+
PUSHs(boolSV(!gv || do_eof(gv)));
RETURN;
}
PP(pp_tell)
{
djSP; dTARGET;
- GV *gv;
+ GV *gv;
+ MAGIC *mg;
if (MAXARG <= 0)
gv = PL_last_in_gv;
else
gv = PL_last_in_gv = (GV*)POPs;
+
+ if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)gv, mg));
+ PUTBACK;
+ ENTER;
+ perl_call_method("TELL", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ RETURN;
+ }
+
PUSHi( do_tell(gv) );
RETURN;
}
GV *gv;
int whence = POPi;
Off_t offset = POPl;
+ MAGIC *mg;
gv = PL_last_in_gv = (GV*)POPs;
+
+ if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)gv, mg));
+ XPUSHs(sv_2mortal(newSViv((IV) offset)));
+ XPUSHs(sv_2mortal(newSViv((IV) whence)));
+ PUTBACK;
+ ENTER;
+ perl_call_method("SEEK", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ RETURN;
+ }
+
if (PL_op->op_type == OP_SEEK)
PUSHs(boolSV(do_seek(gv, offset, whence)));
else {
Off_t n = do_sysseek(gv, offset, whence);
PUSHs((n < 0) ? &PL_sv_undef
: sv_2mortal(n ? newSViv((IV)n)
- : newSVpv(zero_but_true, ZBTLEN)));
+ : newSVpvn(zero_but_true, ZBTLEN)));
}
RETURN;
}
#ifdef USE_STAT_RDEV
PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_rdev)));
#else
- PUSHs(sv_2mortal(newSVpv("", 0)));
+ PUSHs(sv_2mortal(newSVpvn("", 0)));
#endif
PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_size)));
#ifdef BIG_TIME
PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_blksize)));
PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_blocks)));
#else
- PUSHs(sv_2mortal(newSVpv("", 0)));
- PUSHs(sv_2mortal(newSVpv("", 0)));
+ PUSHs(sv_2mortal(newSVpvn("", 0)));
+ PUSHs(sv_2mortal(newSVpvn("", 0)));
#endif
}
RETURN;
/*SUPPRESS 560*/
while (dp = (Direntry_t *)PerlDir_read(IoDIRP(io))) {
#ifdef DIRNAMLEN
- sv = newSVpv(dp->d_name, dp->d_namlen);
+ sv = newSVpvn(dp->d_name, dp->d_namlen);
#else
sv = newSVpv(dp->d_name, 0);
#endif
if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
goto nope;
#ifdef DIRNAMLEN
- sv = newSVpv(dp->d_name, dp->d_namlen);
+ sv = newSVpvn(dp->d_name, dp->d_namlen);
#else
sv = newSVpv(dp->d_name, 0);
#endif
{
djSP; dTARGET;
#if defined(HAS_TELLDIR) || defined(telldir)
-# ifdef NEED_TELLDIR_PROTO /* XXX does _anyone_ need this? --AD 2/20/1998 */
+ /* XXX does _anyone_ need this? --AD 2/20/1998 */
+ /* XXX netbsd still seemed to.
+ XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
+ --JHI 1999-Feb-02 */
+# if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
long telldir _((DIR *));
# endif
GV *gv = (GV*)POPs;
{
#ifdef HAS_FORK
djSP; dTARGET;
- int childpid;
+ Pid_t childpid;
GV *tmpgv;
EXTEND(SP, 1);
+ PERL_FLUSHALL_FOR_CHILD;
childpid = fork();
if (childpid < 0)
RETSETUNDEF;
PP(pp_wait)
{
-#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
+#if !defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(CYGWIN32)
djSP; dTARGET;
- int childpid;
+ Pid_t childpid;
int argflags;
childpid = wait4pid(-1, &argflags, 0);
PP(pp_waitpid)
{
-#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
+#if !defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(CYGWIN32)
djSP; dTARGET;
- int childpid;
+ Pid_t childpid;
int optype;
int argflags;
{
djSP; dMARK; dORIGMARK; dTARGET;
I32 value;
- int childpid;
+ Pid_t childpid;
int result;
int status;
Sigsave_t ihand,qhand; /* place to save signals during system() */
TAINT_PROPER("system");
}
}
+ PERL_FLUSHALL_FOR_CHILD;
#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
while ((childpid = vfork()) == -1) {
if (errno != EAGAIN) {
I32 value;
STRLEN n_a;
+ PERL_FLUSHALL_FOR_CHILD;
if (PL_op->op_flags & OPf_STACKED) {
SV *really = *++MARK;
value = (I32)do_aexec(really, MARK, SP);
register SV *sv;
struct passwd *pwent;
STRLEN n_a;
+#ifdef HAS_GETSPENT
+ struct spwd *spwent;
+#endif
if (which == OP_GPWNAM)
pwent = getpwnam(POPpx);
else
pwent = (struct passwd *)getpwent();
+#ifdef HAS_GETSPENT
+ if (which == OP_GPWNAM)
+ spwent = getspnam(pwent->pw_name);
+ else if (which == OP_GPWUID)
+ spwent = getspnam(pwent->pw_name);
+ else
+ spwent = (struct spwd *)getspent();
+#endif
+
EXTEND(SP, 10);
if (GIMME != G_ARRAY) {
PUSHs(sv = sv_newmortal());
PUSHs(sv = sv_mortalcopy(&PL_sv_no));
#ifdef PWPASSWD
+#ifdef HAS_GETSPENT
+ if (spwent)
+ sv_setpv(sv, spwent->sp_pwdp);
+ else
+ sv_setpv(sv, pwent->pw_passwd);
+#else
sv_setpv(sv, pwent->pw_passwd);
#endif
+#endif
PUSHs(sv = sv_mortalcopy(&PL_sv_no));
sv_setiv(sv, (IV)pwent->pw_uid);
djSP;
#if defined(HAS_PASSWD) && defined(HAS_SETPWENT) && !defined(CYGWIN32)
setpwent();
+#ifdef HAS_GETSPENT
+ setspent();
+#endif
RETPUSHYES;
#else
DIE(PL_no_func, "setpwent");
djSP;
#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
endpwent();
+#ifdef HAS_GETSPENT
+ endspent();
+#endif
RETPUSHYES;
#else
DIE(PL_no_func, "endpwent");
projects / p5sagit/p5-mst-13.2.git / blobdiff