perl
view release on metacpan or search on metacpan
{
IO * const io = GvIOn(gv);
PERL_ARGS_ASSERT_OPENN_SETUP;
*saveifp = NULL;
*saveofp = NULL;
*savefd = -1;
*savetype = IoTYPE_CLOSED;
Zero(mode,sizeof(mode),char);
PL_forkprocess = 1; /* assume true if no fork */
/* If currently open - close before we re-open */
if (IoIFP(io)) {
if (IoTYPE(io) == IoTYPE_STD) {
/* This is a clone of one of STD* handles */
}
else {
const int old_fd = PerlIO_fileno(IoIFP(io));
if (inRANGE(old_fd, 0, PL_maxsysfd)) {
/* This is one of the original STD* handles */
*saveifp = IoIFP(io);
*saveofp = IoOFP(io);
*savetype = IoTYPE(io);
*savefd = old_fd;
}
else {
int result;
if (IoTYPE(io) == IoTYPE_PIPE)
result = PerlProc_pclose(IoIFP(io));
else if (IoIFP(io) != IoOFP(io)) {
if (IoOFP(io)) {
result = PerlIO_close(IoOFP(io));
PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
}
else
result = PerlIO_close(IoIFP(io));
}
else
result = PerlIO_close(IoIFP(io));
if (result == EOF && old_fd > PL_maxsysfd) {
/* Why is this not Perl_warn*() call ? */
PerlIO_printf(Perl_error_log,
"Warning: unable to close filehandle %" HEKf
" properly.\n",
HEKfARG(GvENAME_HEK(gv))
);
}
}
}
IoOFP(io) = IoIFP(io) = NULL;
}
return io;
}
bool
Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw,
int rawmode, int rawperm, PerlIO *supplied_fp, SV **svp,
I32 num_svs)
{
PERL_ARGS_ASSERT_DO_OPENN;
if (as_raw) {
/* sysopen style args, i.e. integer mode and permissions */
if (num_svs != 0) {
croak("panic: sysopen with multiple args, num_svs=%ld",
(long) num_svs);
}
return do_open_raw(gv, oname, len, rawmode, rawperm, NULL);
}
return do_open6(gv, oname, len, supplied_fp, svp, num_svs);
}
bool
Perl_do_open_raw(pTHX_ GV *gv, const char *oname, STRLEN len,
int rawmode, int rawperm, Stat_t *statbufp)
{
PerlIO *saveifp;
PerlIO *saveofp;
int savefd;
char savetype;
char mode[PERL_MODE_MAX]; /* file mode ("r\0", "rb\0", "ab\0" etc.) */
IO * const io = openn_setup(gv, mode, &saveifp, &saveofp, &savefd, &savetype);
int writing = 0;
PerlIO *fp;
PERL_ARGS_ASSERT_DO_OPEN_RAW;
/* For ease of blame back to 5.000, keep the existing indenting. */
{
/* sysopen style args, i.e. integer mode and permissions */
STRLEN ix = 0;
const int appendtrunc =
0
#ifdef O_APPEND /* Not fully portable. */
|O_APPEND
#endif
#ifdef O_TRUNC /* Not fully portable. */
|O_TRUNC
#endif
;
const int modifyingmode = O_WRONLY|O_RDWR|O_CREAT|appendtrunc;
int ismodifying;
SV *namesv;
/* It's not always
O_RDONLY 0
O_WRONLY 1
O_RDWR 2
It might be (in OS/390 and Mac OS Classic it is)
O_WRONLY 1
O_RDONLY 2
O_RDWR 3
if (!(*name == '-' && name[1] == '\0') || num_svs)
TAINT_ENV();
TAINT_PROPER("piped open");
mode[0] = 'r';
if (in_raw)
mode[1] = 'b';
else if (in_crlf)
mode[1] = 't';
if (num_svs > 1) {
fp = PerlProc_popen_list(mode,num_svs,svp);
}
else {
fp = PerlProc_popen(name,mode);
}
IoTYPE(io) = IoTYPE_PIPE;
if (num_svs) {
while (isSPACE(*type))
type++;
if (*type) {
if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) {
fp = NULL;
goto say_false;
}
}
}
}
else { /* layer(Args) */
if (num_svs)
goto unknown_open_mode;
name = type;
IoTYPE(io) = IoTYPE_RDONLY;
for (; isSPACE(*name); name++)
;
mode[0] = 'r';
if (in_raw)
mode[1] = 'b';
else if (in_crlf)
mode[1] = 't';
if (*name == '-' && name[1] == '\0') {
fp = PerlIO_stdin();
IoTYPE(io) = IoTYPE_STD;
}
else {
SV *namesv = newSVpvn_flags(type, tend - type, SVs_TEMP);
type = NULL;
fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,1,&namesv);
}
}
}
say_false:
return openn_cleanup(gv, io, fp, mode, oname, saveifp, saveofp, savefd,
savetype, writing, was_fdopen, type, NULL);
}
/* Yes, this is ugly, but it's private, and I don't see a cleaner way to
simplify the two-headed public interface of do_openn. */
static bool
S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
PerlIO *saveifp, PerlIO *saveofp, int savefd, char savetype,
int writing, bool was_fdopen, const char *type, Stat_t *statbufp)
{
int fd;
Stat_t statbuf;
PERL_ARGS_ASSERT_OPENN_CLEANUP;
Zero(&statbuf, 1, Stat_t);
if (!fp) {
if (IoTYPE(io) == IoTYPE_RDONLY && ckWARN(WARN_NEWLINE)
&& should_warn_nl(oname)
)
{
GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* PL_warn_nl is constant */
warner(packWARN(WARN_NEWLINE), PL_warn_nl, "open");
GCC_DIAG_RESTORE_STMT;
}
goto say_false;
}
if (ckWARN(WARN_IO)) {
if ((IoTYPE(io) == IoTYPE_RDONLY) &&
(fp == PerlIO_stdout() || fp == PerlIO_stderr())) {
warner(packWARN(WARN_IO),
"Filehandle STD%s reopened as %" HEKf
" only for input",
((fp == PerlIO_stdout()) ? "OUT" : "ERR"),
HEKfARG(GvENAME_HEK(gv)));
}
else if ((IoTYPE(io) == IoTYPE_WRONLY) && fp == PerlIO_stdin()) {
warner(packWARN(WARN_IO),
"Filehandle STDIN reopened as %" HEKf " only for output",
HEKfARG(GvENAME_HEK(gv)));
}
}
fd = PerlIO_fileno(fp);
/* Do NOT do: "if (fd < 0) goto say_false;" here. If there is no
* fd assume it isn't a socket - this covers PerlIO::scalar -
* otherwise unless we "know" the type probe for socket-ness.
*/
if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD && fd >= 0) {
if (PerlLIO_fstat(fd,&statbuf) < 0) {
/* If PerlIO claims to have fd we had better be able to fstat() it. */
(void) PerlIO_close(fp);
goto say_false;
}
if (S_ISSOCK(statbuf.st_mode))
IoTYPE(io) = IoTYPE_SOCKET; /* in case a socket was passed in to us */
#ifdef HAS_SOCKET
else if (
!(statbuf.st_mode & S_IFMT)
&& IoTYPE(io) != IoTYPE_WRONLY /* Dups of STD* filehandles already have */
&& IoTYPE(io) != IoTYPE_RDONLY /* type so they aren't marked as sockets */
) { /* on OS's that return 0 on fstat()ed pipe */
return TRUE;
say_false:
IoIFP(io) = saveifp;
IoOFP(io) = saveofp;
IoTYPE(io) = savetype;
return FALSE;
}
/* Open a temp file in the same directory as an original name.
*/
static bool
S_openindirtemp(pTHX_ GV *gv, SV *orig_name, SV *temp_out_name) {
int fd;
PerlIO *fp;
const char *p = SvPV_nolen(orig_name);
const char *sep;
/* look for the last directory separator */
sep = strrchr(p, '/');
#ifdef DOSISH
{
const char *sep2;
if ((sep2 = strrchr(sep ? sep : p, '\\')))
sep = sep2;
}
#endif
#ifdef VMS
if (!sep) {
const char *openp = strchr(p, '[');
if (openp)
sep = strchr(openp, ']');
else {
sep = strchr(p, ':');
}
}
#endif
if (sep) {
sv_setpvn(temp_out_name, p, sep - p + 1);
sv_catpvs(temp_out_name, "XXXXXXXX");
}
else
sv_setpvs(temp_out_name, "XXXXXXXX");
{
int old_umask = umask(0177);
fd = Perl_my_mkstemp_cloexec(SvPVX(temp_out_name));
umask(old_umask);
}
if (fd < 0)
return FALSE;
fp = PerlIO_fdopen(fd, "w+");
if (!fp)
return FALSE;
return do_openn(gv, "+>&", 3, 0, 0, 0, fp, NULL, 0);
}
#if defined(HAS_UNLINKAT) && defined(HAS_RENAMEAT) && defined(HAS_FCHMODAT) && \
(defined(HAS_DIRFD) || defined(HAS_DIR_DD_FD)) && !defined(NO_USE_ATFUNCTIONS) && \
defined(HAS_LINKAT)
# define ARGV_USE_ATFUNCTIONS
#endif
/* Win32 doesn't necessarily return useful information
* in st_dev, st_ino.
*/
#ifndef DOSISH
# define ARGV_USE_STAT_INO
#endif
#define ARGVMG_BACKUP_NAME 0
#define ARGVMG_TEMP_NAME 1
#define ARGVMG_ORIG_NAME 2
#define ARGVMG_ORIG_MODE 3
#define ARGVMG_ORIG_PID 4
/* we store the entire stat_t since the ino_t and dev_t values might
not fit in an IV. I could have created a new structure and
transferred them across, but this seemed too much effort for very
little win.
We store it even when the *at() functions are available, since
while the C runtime might have definitions for these functions, the
operating system or a specific filesystem might not implement them.
eg. NetBSD 6 implements linkat() but only where the fds are AT_FDCWD.
*/
#ifdef ARGV_USE_STAT_INO
# define ARGVMG_ORIG_CWD_STAT 5
#endif
#ifdef ARGV_USE_ATFUNCTIONS
# define ARGVMG_ORIG_DIRP 6
#endif
#ifdef ENOTSUP
#define NotSupported(e) ((e) == ENOSYS || (e) == ENOTSUP)
#else
#define NotSupported(e) ((e) == ENOSYS)
#endif
static int
S_argvout_free(pTHX_ SV *io, MAGIC *mg) {
PERL_UNUSED_ARG(io);
/* note this can be entered once the file has been
successfully deleted too */
assert(IoTYPE(io) != IoTYPE_PIPE);
/* mg_obj can be NULL if a thread is created with the handle open, in which
case we leave any clean up to the parent thread */
if (mg->mg_obj) {
#ifdef ARGV_USE_ATFUNCTIONS
SV **dir_psv;
DIR *dir;
( run in 1.058 second using v1.01-cache-2.11-cpan-98e64b0badf )