static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
unsigned long int idx = 0;
- int trnsuccess;
+ int trnsuccess, success, secure, saverr, savvmserr;
SV *tmpsv;
if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
lnm = uplnm;
}
/* Impose security constraints only if tainting */
- if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
- if (vmstrnenv(lnm,eqv,idx,
- sys ? fildev : NULL,
+ if (sys) {
+ /* Impose security constraints only if tainting */
+ secure = PL_curinterp ? PL_tainting : will_taint;
+ saverr = errno; savvmserr = vaxc$errno;
+ }
+ else secure = 0;
+ success = vmstrnenv(lnm,eqv,idx,
+ secure ? fildev : NULL,
#ifdef SECURE_INTERNAL_GETENV
- sys ? PERL__TRNENV_SECURE : 0
+ secure ? PERL__TRNENV_SECURE : 0
#else
- 0
+ 0
#endif
- )) return eqv;
- else return Nullch;
+ );
+ /* Discard NOLOGNAM on internal calls since we're often looking
+ * for an optional name, and this "error" often shows up as the
+ * (bogus) exit status for a die() call later on. */
+ if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
+ return success ? eqv : Nullch;
}
} /* end of my_getenv() */
char *buf, *cp1, *cp2;
unsigned long idx = 0;
static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
+ int secure, saverr, savvmserr;
SV *tmpsv;
if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
idx = strtoul(cp2+1,NULL,0);
lnm = buf;
}
- /* Impose security constraints only if tainting */
- if (sys) sys = PL_curinterp ? PL_tainting : will_taint;
- if ((*len = vmstrnenv(lnm,buf,idx,
- sys ? fildev : NULL,
+ if (sys) {
+ /* Impose security constraints only if tainting */
+ secure = PL_curinterp ? PL_tainting : will_taint;
+ saverr = errno; savvmserr = vaxc$errno;
+ }
+ else secure = 0;
+ *len = vmstrnenv(lnm,buf,idx,
+ secure ? fildev : NULL,
#ifdef SECURE_INTERNAL_GETENV
- sys ? PERL__TRNENV_SECURE : 0
+ secure ? PERL__TRNENV_SECURE : 0
#else
- 0
+ 0
#endif
- )))
- return buf;
- else
- return Nullch;
+ );
+ /* Discard NOLOGNAM on internal calls since we're often looking
+ * for an optional name, and this "error" often shows up as the
+ * (bogus) exit status for a die() call later on. */
+ if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
+ return *len ? buf : Nullch;
}
} /* end of my_getenv_len() */
void
Perl_my_setenv(pTHX_ char *lnm,char *eqv)
{
- if (lnm && *lnm) {
- int len = strlen(lnm);
- if (len == 7) {
- char uplnm[8];
- int i;
- for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
- if (!strcmp(uplnm,"DEFAULT")) {
- if (eqv && *eqv) chdir(eqv);
- return;
- }
- }
-#ifndef RTL_USES_UTC
- if (len == 6 || len == 2) {
- char uplnm[7];
+ if (lnm && *lnm) {
+ int len = strlen(lnm);
+ if (len == 7) {
+ char uplnm[8];
int i;
for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
- uplnm[len] = '\0';
- if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
- if (!strcmp(uplnm,"TZ")) tz_updated = 1;
+ if (!strcmp(uplnm,"DEFAULT")) {
+ if (eqv && *eqv) chdir(eqv);
+ return;
+ }
+ }
+#ifndef RTL_USES_UTC
+ if (len == 6 || len == 2) {
+ char uplnm[7];
+ int i;
+ for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
+ uplnm[len] = '\0';
+ if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
+ if (!strcmp(uplnm,"TZ")) tz_updated = 1;
}
#endif
}
} /* end of do_spawn() */
/*}}}*/
+
+static unsigned int *sockflags, sockflagsize;
+
+/*
+ * Shim fdopen to identify sockets for my_fwrite later, since the stdio
+ * routines found in some versions of the CRTL can't deal with sockets.
+ * We don't shim the other file open routines since a socket isn't
+ * likely to be opened by a name.
+ */
+/*{{{ FILE *my_fdopen(int fd, char *mode)*/
+FILE *my_fdopen(int fd, char *mode)
+{
+ FILE *fp = fdopen(fd,mode);
+
+ if (fp) {
+ unsigned int fdoff = fd / sizeof(unsigned int);
+ struct stat sbuf; /* native stat; we don't need flex_stat */
+ if (!sockflagsize || fdoff > sockflagsize) {
+ if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
+ else New (1324,sockflags,fdoff+2,unsigned int);
+ memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
+ sockflagsize = fdoff + 2;
+ }
+ if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
+ sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
+ }
+ return fp;
+
+}
+/*}}}*/
+
+
+/*
+ * Clear the corresponding bit when the (possibly) socket stream is closed.
+ * There still a small hole: we miss an implicit close which might occur
+ * via freopen(). >> Todo
+ */
+/*{{{ int my_fclose(FILE *fp)*/
+int my_fclose(FILE *fp) {
+ if (fp) {
+ unsigned int fd = fileno(fp);
+ unsigned int fdoff = fd / sizeof(unsigned int);
+
+ if (sockflagsize && fdoff <= sockflagsize)
+ sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
+ }
+ return fclose(fp);
+}
+/*}}}*/
+
+
/*
* A simple fwrite replacement which outputs itmsz*nitm chars without
* introducing record boundaries every itmsz chars.
my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
{
register char *cp, *end, *cpd, *data;
+ register unsigned int fd = fileno(dest);
+ register unsigned int fdoff = fd / sizeof(unsigned int);
int retval;
- int bufsize = itmsz*nitm+1;
+ int bufsize = itmsz * nitm + 1;
+
+ if (fdoff < sockflagsize &&
+ (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
+ if (write(fd, src, itmsz * nitm) == EOF) return EOF;
+ return nitm;
+ }
- _ckvmssts_noperl(lib$get_vm( &bufsize, &data ));
+ _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
memcpy( data, src, itmsz*nitm );
data[itmsz*nitm] = '\0';
cpd = cp + 1;
}
- if (data) _ckvmssts_noperl(lib$free_vm( &bufsize, &data ));
+ if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
return retval;
} /* end of my_fwrite() */
* ADDRCONSTEXT,NEEDCONSTEXT: initialization of data with non-constant values
* (e.g. pointer fields of descriptors)
*/
-#ifdef __DECC
-# pragma message disable (ADDRCONSTEXT,NEEDCONSTEXT)
-#endif
-#ifdef __DECCXX
+#if defined(__DECC) || defined(__DECCXX)
# pragma message disable (ADDRCONSTEXT,NEEDCONSTEXT)
#endif
#include <unixio.h>
#include <unixlib.h>
#include <file.h> /* it's not <sys/file.h>, so don't use I_SYS_FILE */
-#if defined(__DECC) && defined(__DECC_VER) && __DECC_VER > 20000000
-# include <unistd.h> /* DECC has this; VAXC and gcc don't */
-#endif
-#ifdef __DECCXX
-# include <unistd.h> /* DECC has this; VAXC and gcc don't */
-#endif
-
-/* VAXC doesn't have a unary plus operator, so we need to get there indirectly */
-#if defined(VAXC) && !defined(__DECC)
-# define NO_UNARY_PLUS
+#if (defined(__DECC) && defined(__DECC_VER) && __DECC_VER > 20000000) || defined(__DECCXX)
+# include <unistd.h> /* DECC has this; gcc doesn't */
#endif
#ifdef NO_PERL_TYPEDEFS /* a2p; we don't want Perl's special routines */
#define vms_do_exec Perl_vms_do_exec
#define do_aspawn Perl_do_aspawn
#define do_spawn Perl_do_spawn
+#define my_fdopen Perl_my_fdopen
+#define my_fclose Perl_my_fclose
#define my_fwrite Perl_my_fwrite
#define my_flush Perl_my_flush
#define my_getpwnam Perl_my_getpwnam
*/
#define fwrite1 my_fwrite
+
+#ifndef DONT_MASK_RTL_CALLS
+# define fdopen my_fdopen
+# define fclose my_fclose
+#endif
+
+
/* By default, flush data all the way to disk, not just to RMS buffers */
#define Fflush(fp) my_flush(fp)
/* Assorted fiddling with sigs . . . */
# include <signal.h>
#define ABORT() abort()
- /* VAXC's signal.h doesn't #define SIG_ERR, but provides BADSIG instead. */
-#if !defined(SIG_ERR) && defined(BADSIG)
-# define SIG_ERR BADSIG
-#endif
-
/* Used with our my_utime() routine in vms.c */
struct utimbuf {
/* Thin jacket around cuserid() to match Unix' calling sequence */
#define getlogin my_getlogin
-/* Ditto for sys$hash_passwrod() . . . */
+/* Ditto for sys$hash_password() . . . */
#define crypt my_crypt
/* Tweak arg to mkdir & chdir first, so we can tolerate trailing /. */
bool vms_do_exec (char *);
unsigned long int do_aspawn (void *, void **, void **);
unsigned long int do_spawn (char *);
+FILE * my_fdopen (int, char *);
+int my_fclose (FILE *);
int my_fwrite (void *, size_t, size_t, FILE *);
int my_flush (FILE *);
struct passwd * my_getpwnam (char *name);
projects / p5sagit/p5-mst-13.2.git / commitdiff