return PerlIO_fdopen(p[This], mode);
}
#else
-#if defined(atarist) || defined(DJGPP)
+#if defined(atarist)
FILE *popen();
PerlIO *
Perl_my_popen(pTHX_ char *cmd, char *mode)
*/
return PerlIO_importFILE(popen(cmd, mode), 0);
}
+#else
+#if defined(DJGPP)
+FILE *djgpp_popen();
+PerlIO *
+Perl_my_popen(pTHX_ char *cmd, char *mode)
+{
+ PERL_FLUSHALL_FOR_CHILD;
+ /* Call system's popen() to get a FILE *, then import it.
+ used 0 for 2nd parameter to PerlIO_importFILE;
+ apparently not used
+ */
+ return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
+}
+#endif
#endif
#endif /* !DOSISH */
return;
}
-#if defined(atarist) || defined(OS2) || defined(DJGPP)
+#if defined(atarist) || defined(OS2)
int pclose();
#ifdef HAS_FORK
int /* Cannot prototype with I32
/* Needs work for PerlIO ! */
FILE *f = PerlIO_findFILE(ptr);
I32 result = pclose(f);
+ PerlIO_releaseFILE(ptr,f);
+ return result;
+}
+#endif
+
#if defined(DJGPP)
+int djgpp_pclose();
+I32
+Perl_my_pclose(pTHX_ PerlIO *ptr)
+{
+ /* Needs work for PerlIO ! */
+ FILE *f = PerlIO_findFILE(ptr);
+ I32 result = djgpp_pclose(f);
result = (result << 8) & 0xff00;
-#endif
PerlIO_releaseFILE(ptr,f);
return result;
}
#ifdef HAS_GETCWD
{
- char* buf;
-
- SvPOK_off(sv);
- New(0, buf, MAXPATHLEN, char);
- if (buf) {
- buf[MAXPATHLEN] = 0;
- /* Yes, some getcwd()s automatically allocate a buffer
- * if given a NULL one. Portability is the problem.
- * XXX Configure probe needed. */
- if (getcwd(buf, MAXPATHLEN - 1)) {
- STRLEN len = strlen(buf);
- sv_setpvn(sv, buf, len);
- SvPOK_only(sv);
- SvCUR_set(sv, len);
- }
- else
- sv_setsv(sv, &PL_sv_undef);
- Safefree(buf);
- }
- else
- sv_setsv(sv, &PL_sv_undef);
-
- return SvPOK(sv) ? TRUE : FALSE;
+ char buf[MAXPATHLEN];
+
+ /* Some getcwd()s automatically allocate a buffer of the given
+ * size from the heap if they are given a NULL buffer pointer.
+ * The problem is that this behaviour is not portable. */
+ if (getcwd(buf, sizeof(buf) - 1)) {
+ STRLEN len = strlen(buf);
+ sv_setpvn(sv, buf, len);
+ return TRUE;
+ }
+ else {
+ sv_setsv(sv, &PL_sv_undef);
+ return FALSE;
+ }
}
#else
#endif
}
- SvCUR_set(sv, pathlen);
- *SvEND(sv) = '\0';
- SvPOK_only(sv);
+ if (pathlen) {
+ SvCUR_set(sv, pathlen);
+ *SvEND(sv) = '\0';
+ SvPOK_only(sv);
- if (PerlDir_chdir(SvPVX(sv)) < 0) {
- SV_CWD_RETURN_UNDEF;
+ if (PerlDir_chdir(SvPVX(sv)) < 0) {
+ SV_CWD_RETURN_UNDEF;
+ }
}
if (PerlLIO_stat(".", &statbuf) < 0) {
SV_CWD_RETURN_UNDEF;
#endif
}
-/*
-=for apidoc sv_realpath
-
-Emulate realpath(3).
-
-The real realpath() is not used because it's a known can of worms.
-We may have bugs but hey, they are our very own.
-
-=cut
- */
-int
-Perl_sv_realpath(pTHX_ SV *sv, char *path, STRLEN maxlen)
-{
-#ifndef PERL_MICRO
- char name[MAXPATHLEN] = { 0 };
- char dotdots[MAXPATHLEN] = { 0 };
- char *s;
- STRLEN pathlen, namelen;
- DIR *parent;
- Direntry_t *dp;
- struct stat cst, pst, tst;
-
- if (!sv || !path || !maxlen) {
- Perl_warn(aTHX_ "sv_realpath: realpath(0x%x, 0x%x, "")",
- sv, path, maxlen);
- SV_CWD_RETURN_UNDEF;
- }
-
- /* Is the source buffer too long?
- * Don't use strlen() to avoid running off the end. */
- if (maxlen >= MAXPATHLEN)
- pathlen = maxlen;
- else {
- s = memchr(path, '\0', MAXPATHLEN);
- pathlen = s ? s - path : MAXPATHLEN;
- }
- if (pathlen >= MAXPATHLEN) {
- Perl_warn(aTHX_ "sv_realpath: source too large");
- SV_CWD_RETURN_UNDEF;
- }
-
- if (PerlLIO_stat(path, &cst) < 0) {
- Perl_warn(aTHX_ "sv_realpath: stat(\"%s\"): %s",
- path, Strerror(errno));
- SV_CWD_RETURN_UNDEF;
- }
-
- (void)SvUPGRADE(sv, SVt_PV);
-
- Copy(path, dotdots, maxlen, char);
-
- pathlen = 0;
-
- for (;;) {
- strcat(dotdots, "/..");
- StructCopy(&cst, &pst, struct stat);
-
- if (PerlLIO_stat(dotdots, &cst) < 0) {
- Perl_warn(aTHX_ "sv_realpath: stat(\"%s\"): %s",
- dotdots, Strerror(errno));
- SV_CWD_RETURN_UNDEF;
- }
-
- if (pst.st_dev == cst.st_dev && pst.st_ino == cst.st_ino) {
- /* We've reached the root: previous is same as current */
- break;
- } else {
- STRLEN dotdotslen = strlen(dotdots);
-
- /* Scan through the dir looking for name of previous */
- if (!(parent = PerlDir_open(dotdots))) {
- Perl_warn(aTHX_ "sv_realpath: opendir(\"%s\"): %s",
- dotdots, Strerror(errno));
- SV_CWD_RETURN_UNDEF;
- }
-
- SETERRNO(0,SS$_NORMAL); /* for readdir() */
- while ((dp = PerlDir_read(parent)) != NULL) {
- if (SV_CWD_ISDOT(dp)) {
- continue;
- }
-
- Copy(dotdots, name, dotdotslen, char);
- name[dotdotslen] = '/';
-#ifdef DIRNAMLEN
- namelen = dp->d_namlen;
-#else
- namelen = strlen(dp->d_name);
-#endif
- Copy(dp->d_name, name + dotdotslen + 1, namelen, char);
- name[dotdotslen + 1 + namelen] = 0;
-
- if (PerlLIO_lstat(name, &tst) < 0) {
- PerlDir_close(parent);
- Perl_warn(aTHX_ "sv_realpath: lstat(\"%s\"): %s",
- name, Strerror(errno));
- SV_CWD_RETURN_UNDEF;
- }
-
- if (tst.st_dev == pst.st_dev && tst.st_ino == pst.st_ino)
- break;
-
- SETERRNO(0,SS$_NORMAL); /* for readdir() */
- }
-
- if (!dp && errno) {
- Perl_warn(aTHX_ "sv_realpath: readdir(\"%s\"): %s",
- dotdots, Strerror(errno));
- SV_CWD_RETURN_UNDEF;
- }
-
- if (pathlen + namelen + 1 >= MAXPATHLEN) {
- Perl_warn(aTHX_ "sv_realpath: too long name");
- SV_CWD_RETURN_UNDEF;
- }
-
- SvGROW(sv, pathlen + namelen + 1);
- if (pathlen) {
- /* shift down */
- Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
- }
-
- *SvPVX(sv) = '/';
- Move(dp->d_name, SvPVX(sv)+1, namelen, char);
- pathlen += (namelen + 1);
-
-#ifdef VOID_CLOSEDIR
- PerlDir_close(parent);
-#else
- if (PerlDir_close(parent) < 0) {
- Perl_warn(aTHX_ "sv_realpath: closedir(\"%s\"): %s",
- dotdots, Strerror(errno));
- SV_CWD_RETURN_UNDEF;
- }
-#endif
- }
- }
-
- SvCUR_set(sv, pathlen);
- SvPOK_only(sv);
-
- return TRUE;
-#else
- return FALSE; /* MICROPERL */
-#endif
-}
-
projects / p5sagit/p5-mst-13.2.git / blobdiff