From: Charles Bailey Date: Thu, 8 Feb 2001 20:59:22 +0000 (+0000) Subject: Convert fwrite()s to sockets to write()s, since some socket stacks X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=bc10a42576c48b3d87c83e97460fd8a8fbaa6859;p=p5sagit%2Fp5-mst-13.2.git Convert fwrite()s to sockets to write()s, since some socket stacks don't take kindly to stdio. Ignore "expected" SS$_NOLOGNAM when doing internal LNM lookups (for often optional LNMs) Correct a few typos (C. Bailey) p4raw-id: //depot/vmsperl@8720 --- diff --git a/vms/vms.c b/vms/vms.c index 7872bdd..43a5c22 100644 --- a/vms/vms.c +++ b/vms/vms.c @@ -293,7 +293,7 @@ Perl_my_getenv(pTHX_ const char *lnm, bool sys) 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 */ @@ -317,16 +317,25 @@ Perl_my_getenv(pTHX_ const char *lnm, bool sys) 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() */ @@ -341,6 +350,7 @@ my_getenv_len(const char *lnm, unsigned long *len, bool sys) 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 */ @@ -364,19 +374,25 @@ my_getenv_len(const char *lnm, unsigned long *len, bool sys) 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() */ @@ -707,25 +723,25 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) 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 } @@ -4734,6 +4750,57 @@ do_spawn(char *cmd) } /* 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. @@ -4747,10 +4814,18 @@ int 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'; @@ -4766,7 +4841,7 @@ my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest) 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() */ diff --git a/vms/vmsish.h b/vms/vmsish.h index 17c5a00..15cda49 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -19,10 +19,7 @@ * 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 @@ -54,16 +51,8 @@ #include #include #include /* it's not , so don't use I_SYS_FILE */ -#if defined(__DECC) && defined(__DECC_VER) && __DECC_VER > 20000000 -# include /* DECC has this; VAXC and gcc don't */ -#endif -#ifdef __DECCXX -# include /* 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 /* DECC has this; gcc doesn't */ #endif #ifdef NO_PERL_TYPEDEFS /* a2p; we don't want Perl's special routines */ @@ -176,6 +165,8 @@ #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 @@ -383,6 +374,13 @@ */ #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) @@ -392,11 +390,6 @@ /* Assorted fiddling with sigs . . . */ # include #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 { @@ -482,7 +475,7 @@ 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 /. */ @@ -743,6 +736,8 @@ bool vms_do_aexec (SV *, SV **, SV **); 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);