Changes to vmsish.h and vms.c:
1. Add new routine to translate VMS error status codes into UNIX errno
values.
2. Fix routines that callers expect not to modify the input strings to
actually not modify them.
3. Put the const qualifiers on all input pointers that are not modified
so that the routines that are wrappers for standard c library routines
follow the same calling conventions.
Changes to perl.h :
Add macro for STATUS_NATIVE_CHILD_SET() for translating NATIVE child
status to Perl. VMS requires different code than other platforms.
Add VMS specific macro STATUS_NATIVE_SET_PORC(). PORC is for Parent or
Child. This macro takes a parameter that determines if it should take
the child behavior.
Fix STATUS_NATIVE_SET_PORC macro to call routine in VMS.C to translate
VMS status codes to errno status codes.
STATUS_NATIVE_SET on VMS now calls STATUS_NATIVE_SET_PORC.
On non-VMS STATUS_NATIVE_CHILD_SET calls STATUS_NATIVE_SET() to preserve
existing behavior.
STATUS_UNIX_SET fixed for VMS case.
Changes to pp_sys.c :
Calls STATUS_NATIVE_CHILD_SET so when setting the child status in the
second octet is needed on VMS.
Removed incorrect (char *) casts that were suppressing valid compiler
warnings about potential data corruption.
Changes to doio.c :
Put the required const qualifiers on several routines to match what the
callers are expecting.
Fix the Perl_do_openn routine to not modify the input string so that the
const qualifier is correct.
Fix the Perl_do_exec3 routine so that the compiler realizes that the
input string is not modified so that the const qualifier is correct.
Changes to proto.h and embed.fnc :
Fixed the prototypes to have the const qualifiers.
-John
[EMAIL PROTECTED]
Personal Opinion Only
--- vms/vmsish.h_blead Sat Aug 6 00:13:56 2005
+++ vms/vmsish.h Mon Aug 8 23:06:31 2005
@@ -347,6 +347,7 @@
* This symbol, if defined, indicates that the program is running under
* VMS. It's a symbol automagically defined by all VMS C compilers I've
seen.
* Just in case, however . . . */
+/* Note that code really should be using __VMS to comply with ANSI */
#ifndef VMS
#define VMS /**/
#endif
@@ -760,7 +761,8 @@
#endif
void prime_env_iter (void);
-void init_os_extras ();
+void init_os_extras (void);
+int vms_status_to_unix(int vms_status);
/* prototype section start marker; `typedef' passes through cpp */
typedef char __VMS_PROTOTYPES__;
int Perl_vmstrnenv (const char *, char *, unsigned long int, struct
dsc$descriptor_s **, unsigned long int);
@@ -769,8 +771,8 @@
int Perl_my_trnlnm (const char *, char *, unsigned long int);
char * Perl_tounixspec (const char *, char *);
char * Perl_tounixspec_ts (const char *, char *);
-char * Perl_tovmsspec (char *, char *);
-char * Perl_tovmsspec_ts (char *, char *);
+char * Perl_tovmsspec (const char *, char *);
+char * Perl_tovmsspec_ts (const char *, char *);
char * Perl_tounixpath (const char *, char *);
char * Perl_tounixpath_ts (const char *, char *);
char * Perl_tovmspath (const char *, char *);
@@ -780,11 +782,11 @@
char * Perl_fileify_dirspec_ts (const char *, char *);
char * Perl_pathify_dirspec (const char *, char *);
char * Perl_pathify_dirspec_ts (const char *, char *);
-char * Perl_rmsexpand (char *, char *, char *, unsigned);
-char * Perl_rmsexpand_ts (char *, char *, char *, unsigned);
-int Perl_trim_unixpath (char *, char*, int);
+char * Perl_rmsexpand (const char *, char *, const char *, unsigned);
+char * Perl_rmsexpand_ts (const char *, char *, const char *, unsigned);
+int Perl_trim_unixpath (char *, const char*, int);
DIR * Perl_opendir (const char *);
-int Perl_rmscopy (char *, char *, int);
+int Perl_rmscopy (const char *, const char *, int);
int Perl_my_mkdir (const char *, Mode_t);
bool Perl_vms_do_aexec (SV *, SV **, SV **);
#else
@@ -792,8 +794,8 @@
int Perl_my_trnlnm (pTHX_ const char *, char *, unsigned long int);
char * Perl_tounixspec (pTHX_ const char *, char *);
char * Perl_tounixspec_ts (pTHX_ const char *, char *);
-char * Perl_tovmsspec (pTHX_ char *, char *);
-char * Perl_tovmsspec_ts (pTHX_ char *, char *);
+char * Perl_tovmsspec (pTHX_ const char *, char *);
+char * Perl_tovmsspec_ts (pTHX_ const char *, char *);
char * Perl_tounixpath (pTHX_ const char *, char *);
char * Perl_tounixpath_ts (pTHX_ const char *, char *);
char * Perl_tovmspath (pTHX_ const char *, char *);
@@ -803,23 +805,23 @@
char * Perl_fileify_dirspec_ts (pTHX_ const char *, char *);
char * Perl_pathify_dirspec (pTHX_ const char *, char *);
char * Perl_pathify_dirspec_ts (pTHX_ const char *, char *);
-char * Perl_rmsexpand (pTHX_ char *, char *, char *, unsigned);
-char * Perl_rmsexpand_ts (pTHX_ char *, char *, char *, unsigned);
-int Perl_trim_unixpath (pTHX_ char *, char*, int);
+char * Perl_rmsexpand (pTHX_ const char *, char *, const char *, unsigned);
+char * Perl_rmsexpand_ts (pTHX_ const char *, char *, const char *, unsigned);
+int Perl_trim_unixpath (pTHX_ char *, const char*, int);
DIR * Perl_opendir (pTHX_ const char *);
-int Perl_rmscopy (pTHX_ char *, char *, int);
+int Perl_rmscopy (pTHX_ const char *, const char *, int);
int Perl_my_mkdir (pTHX_ const char *, Mode_t);
bool Perl_vms_do_aexec (pTHX_ SV *, SV **, SV **);
#endif
char * Perl_my_getenv_len (pTHX_ const char *, unsigned long *, bool);
int Perl_vmssetenv (pTHX_ const char *, const char *, struct
dsc$descriptor_s **);
-void Perl_vmssetuserlnm(pTHX_ char *name, char *eqv);
+void Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv);
char * Perl_my_crypt (pTHX_ const char *, const char *);
Pid_t Perl_my_waitpid (pTHX_ Pid_t, int *, int);
char * my_gconvert (double, int, int, char *);
int Perl_kill_file (pTHX_ const char *);
int Perl_my_chdir (pTHX_ const char *);
-FILE * Perl_my_tmpfile ();
+FILE * Perl_my_tmpfile (void);
#ifndef HOMEGROWN_POSIX_SIGNALS
int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct
sigaction*);
#endif
@@ -847,21 +849,21 @@
int my_sigismember (sigset_t *, int);
int my_sigprocmask (int, sigset_t *, sigset_t *);
#endif
-I32 Perl_cando_by_name (pTHX_ I32, Uid_t, char *);
+I32 Perl_cando_by_name (pTHX_ I32, Uid_t, const char *);
int Perl_flex_fstat (pTHX_ int, Stat_t *);
int Perl_flex_stat (pTHX_ const char *, Stat_t *);
-int my_vfork ();
-bool Perl_vms_do_exec (pTHX_ char *);
+int my_vfork (void);
+bool Perl_vms_do_exec (pTHX_ const char *);
unsigned long int Perl_do_aspawn (pTHX_ void *, void **, void **);
-unsigned long int Perl_do_spawn (pTHX_ char *);
+unsigned long int Perl_do_spawn (pTHX_ const char *);
FILE * my_fdopen (int, const char *);
int my_fclose (FILE *);
int my_fwrite (const void *, size_t, size_t, FILE *);
int Perl_my_flush (pTHX_ FILE *);
-struct passwd * Perl_my_getpwnam (pTHX_ char *name);
+struct passwd * Perl_my_getpwnam (pTHX_ const char *name);
struct passwd * Perl_my_getpwuid (pTHX_ Uid_t uid);
-void my_endpwent ();
-char * my_getlogin ();
+void my_endpwent (pTHX);
+char * my_getlogin (void);
typedef char __VMS_SEPYTOTORP__;
/* prototype section end marker; `typedef' passes through cpp */
--- vms/vms.c_blead Sat Aug 6 00:12:33 2005
+++ vms/vms.c Tue Aug 9 00:40:20 2005
@@ -3,6 +3,7 @@
* VMS-specific routines for perl5
* Version: 5.7.0
*
+ * August 2005 Convert VMS status code to UNIX status codes
* August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
* and Perl_cando by Craig Berry
* 29-Aug-2000 Charles Lane's piping improvements rolled in
@@ -41,6 +42,8 @@
#include <syidef.h>
#include <uaidef.h>
#include <uicdef.h>
+#include <stsdef.h>
+#include <rmsdef.h>
/* Older versions of ssdef.h don't have these */
#ifndef SS$_INVFILFOROP
@@ -923,7 +926,7 @@
* used for redirection of sys$error
*/
void
-Perl_vmssetuserlnm(pTHX_ char *name, char *eqv)
+Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
{
$DESCRIPTOR(d_tab, "LNM$PROCESS");
struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
@@ -931,11 +934,11 @@
unsigned char acmode = PSL$C_USER;
struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
{0, 0, 0, 0}};
- d_name.dsc$a_pointer = name;
+ d_name.dsc$a_pointer = (char *) name; /* Cast OK for read only parameter */
d_name.dsc$w_length = strlen(name);
lnmlst[0].buflen = strlen(eqv);
- lnmlst[0].bufadr = eqv;
+ lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
if (!(iss&1)) lib$signal(iss);
@@ -1004,7 +1007,7 @@
/*}}}*/
-static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned);
+static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *,
unsigned);
static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int);
static char *mp_do_tovmsspec(pTHX_ const char *, char *, int);
@@ -1301,7 +1304,6 @@
return sig_code[sig];
}
-
int
Perl_my_kill(int pid, int sig)
{
@@ -1340,6 +1342,161 @@
}
#endif
+/* Routine to convert a VMS status code to a UNIX status code.
+** More tricky than it appears because of conflicting conventions with
+** existing code.
+**
+** VMS status codes are a bit mask, with the least significant bit set for
+** success.
+**
+** Special UNIX status of EVMSERR indicates that no translation is currently
+** available, and programs should check the VMS status code.
+**
+** Programs compiled with _POSIX_EXIT have a special encoding that requires
+** decoding.
+*/
+
+#ifndef C_FACILITY_NO
+#define C_FACILITY_NO 0x350000
+#endif
+#ifndef DCL_IVVERB
+#define DCL_IVVERB 0x38090
+#endif
+
+int vms_status_to_unix(int vms_status)
+{
+int facility;
+int fac_sp;
+int msg_no;
+int msg_status;
+int unix_status;
+
+ /* Assume the best or the worst */
+ if (vms_status & STS$M_SUCCESS)
+ unix_status = 0;
+ else
+ unix_status = EVMSERR;
+
+ msg_status = vms_status & ~STS$M_CONTROL;
+
+ facility = vms_status & STS$M_FAC_NO;
+ fac_sp = vms_status & STS$M_FAC_SP;
+ msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
+
+ if ((facility == 0) || (fac_sp == 0)) {
+ switch(msg_no) {
+ case SS$_NORMAL:
+ unix_status = 0;
+ break;
+ case SS$_ACCVIO:
+ unix_status = EFAULT;
+ break;
+ case SS$_IVLOGNAM:
+ case SS$_BADPARAM:
+ case SS$_IVLOGTAB:
+ case SS$_NOLOGNAM:
+ case SS$_NOLOGTAB:
+ case SS$_INVFILFOROP:
+ case SS$_INVARG:
+ case SS$_NOSUCHID:
+ case SS$_IVIDENT:
+ unix_status = EINVAL;
+ break;
+ case SS$_FILACCERR:
+ case SS$_NOGRPPRV:
+ case SS$_NOSYSPRV:
+ unix_status = EACCES;
+ break;
+ case SS$_DEVICEFULL:
+ unix_status = ENOSPC;
+ break;
+ case SS$_NOSUCHDEV:
+ unix_status = ENODEV;
+ break;
+ case SS$_NOSUCHFILE:
+ case SS$_NOSUCHOBJECT:
+ unix_status = ENOENT;
+ break;
+ case SS$_ABORT:
+ unix_status = EINTR;
+ break;
+ case SS$_BUFFEROVF:
+ unix_status = E2BIG;
+ break;
+ case SS$_INSFMEM:
+ unix_status = ENOMEM;
+ break;
+ case SS$_NOPRIV:
+ unix_status = EPERM;
+ break;
+ case SS$_NOSUCHNODE:
+ case SS$_UNREACHABLE:
+ unix_status = ESRCH;
+ break;
+ case SS$_NONEXPR:
+ unix_status = ECHILD;
+ break;
+ default:
+ if ((facility == 0) && (msg_no < 8)) {
+ /* These are not real VMS status codes so assume that they are
+ ** already UNIX status codes
+ */
+ unix_status = msg_no;
+ break;
+ }
+ }
+ }
+ else {
+ /* Translate a POSIX exit code to a UNIX exit code */
+ if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
+ unix_status = (msg_no & 0x0FF0) >> 3;
+ }
+ else {
+ switch(msg_status) {
+ /* case RMS$_EOF: */ /* End of File */
+ case RMS$_FNF: /* File Not Found */
+ case RMS$_DNF: /* Dir Not Found */
+ unix_status = ENOENT;
+ break;
+ case RMS$_RNF: /* Record Not Found */
+ unix_status = ESRCH;
+ break;
+ case RMS$_DIR:
+ unix_status = ENOTDIR;
+ break;
+ case RMS$_DEV:
+ unix_status = ENODEV;
+ break;
+ case RMS$_SYN:
+ case RMS$_FNM:
+ case LIB$_INVSTRDES:
+ case LIB$_INVARG:
+ case LIB$_NOSUCHSYM:
+ case LIB$_INVSYMNAM:
+ case DCL_IVVERB:
+ unix_status = EINVAL;
+ break;
+ case CLI$_BUFOVF:
+ case RMS$_RTB:
+ case CLI$_TKNOVF:
+ case CLI$_RSLOVF:
+ unix_status = E2BIG;
+ break;
+ case RMS$_PRV: /* No privilege */
+ case RMS$_ACC: /* ACP file access failed */
+ case RMS$_WLK: /* Device write locked */
+ unix_status = EACCES;
+ break;
+ /* case RMS$_NMF: */ /* No more files */
+ }
+ }
+ }
+
+ return unix_status;
+}
+
+
+
/* default piping mailbox size */
#define PERL_BUFSIZ 512
@@ -1676,7 +1833,7 @@
}
-static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img, int
*suggest_quote, struct dsc$descriptor_s **pvmscmd);
+static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img,
int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
static void vms_execfree(struct dsc$descriptor_s *vmscmd);
/*
@@ -2337,7 +2494,7 @@
static PerlIO *
-safe_popen(pTHX_ char *cmd, char *in_mode, int *psts)
+safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
{
static int handler_set_up = FALSE;
unsigned long int sts, flags = CLI$M_NOWAIT;
@@ -2655,7 +2812,9 @@
if (!done) _ckvmssts(sys$waitfr(pipe_ef));
}
*psts = info->completion;
- my_pclose(info->fp);
+/* Caller thinks it is open and tries to close it. */
+/* This causes some problems, as it changes the error status */
+/* my_pclose(info->fp); */
} else {
*psts = SS$_NORMAL;
}
@@ -2665,7 +2824,7 @@
/*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
PerlIO *
-Perl_my_popen(pTHX_ char *cmd, char *mode)
+Perl_my_popen(pTHX_ const char *cmd, const char *mode)
{
int sts;
TAINT_ENV();
@@ -2950,7 +3109,7 @@
static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
static char *
-mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec,
unsigned opts)
+mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char
*defspec, unsigned opts)
{
static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
@@ -2973,7 +3132,7 @@
filespec = vmsfspec;
}
- myfab.fab$l_fna = filespec;
+ myfab.fab$l_fna = (char *)filespec; /* cast ok for read only pointer */
myfab.fab$b_fns = strlen(filespec);
myfab.fab$l_nam = &mynam;
@@ -2982,7 +3141,7 @@
if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
defspec = tmpfspec;
}
- myfab.fab$l_dna = defspec;
+ myfab.fab$l_dna = (char *) defspec; /* cast ok for read only pointer */
myfab.fab$b_dns = strlen(defspec);
}
@@ -3040,7 +3199,7 @@
struct NAM defnam = cc$rms_nam;
deffab.fab$l_nam = &defnam;
- deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
+ deffab.fab$l_fna = (char *)defspec; deffab.fab$b_fns = myfab.fab$b_dns;
defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
defnam.nam$b_nop = NAM$M_SYNCHK;
if (sys$parse(&deffab,0,0) & 1) {
@@ -3085,9 +3244,9 @@
}
/*}}}*/
/* External entry points */
-char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
+char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def,
unsigned opt)
{ return do_rmsexpand(spec,buf,0,def,opt); }
-char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
+char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def,
unsigned opt)
{ return do_rmsexpand(spec,buf,1,def,opt); }
@@ -3927,8 +4086,8 @@
} /* end of do_tovmsspec() */
/*}}}*/
/* External entry points */
-char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return
do_tovmsspec(path,buf,0); }
-char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return
do_tovmsspec(path,buf,1); }
+char *Perl_tovmsspec(pTHX_ const char *path, char *buf) { return
do_tovmsspec(path,buf,0); }
+char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf) { return
do_tovmsspec(path,buf,1); }
/*{{{ char *tovmspath[_ts](char *path, char *buf)*/
static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) {
@@ -4697,18 +4856,21 @@
*/
/*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
int
-Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
+Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
{
char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
*template, *base, *end, *cp1, *cp2;
register int tmplen, reslen = 0, dirs = 0;
if (!wildspec || !fspec) return 0;
+ template = unixwild;
if (strpbrk(wildspec,"]>:") != NULL) {
if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
- else template = unixwild;
}
- else template = wildspec;
+ else {
+ strncpy(unixwild, wildspec, NAM$C_MAXRSS);
+ unixwild[NAM$C_MAXRSS] = 0;
+ }
if (strpbrk(fspec,"]>:") != NULL) {
if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
else base = unixified;
@@ -5209,7 +5371,7 @@
static unsigned long int
-setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote,
+setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
struct dsc$descriptor_s **pvmscmd)
{
char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
@@ -5220,9 +5382,18 @@
struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
register char *s, *rest, *cp, *wordbreak;
+ char * cmd;
+ int cmdlen;
register int isdcl;
Newx(vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
+
+ /* Make a copy for modification */
+ cmdlen = strlen(incmd);
+ Newx(cmd, cmdlen+1, char);
+ strncpy(cmd, incmd, cmdlen);
+ cmd[cmdlen] = 0;
+
vmscmd->dsc$a_pointer = NULL;
vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
vmscmd->dsc$b_class = DSC$K_CLASS_S;
@@ -5231,9 +5402,13 @@
if (suggest_quote) *suggest_quote = 0;
- if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
+ if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
return CLI$_BUFOVF; /* continuation lines currently
unsupported */
+ Safefree(cmd);
+ }
+
s = cmd;
+
while (*s && isspace(*s)) s++;
if (*s == '@' || *s == '$') {
@@ -5323,6 +5498,7 @@
strcat(vmscmd->dsc$a_pointer,resspec);
if (rest) strcat(vmscmd->dsc$a_pointer,rest);
vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
+ Safefree(cmd);
return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF :
retsts);
}
else retsts = RMS$_PRV;
@@ -5337,6 +5513,8 @@
else */
vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
+ Safefree(cmd);
+
/* check if it's a symbol (for quoting purposes) */
if (suggest_quote && !*suggest_quote) {
int iss;
@@ -5384,7 +5562,7 @@
/* {{{bool vms_do_exec(char *cmd) */
bool
-Perl_vms_do_exec(pTHX_ char *cmd)
+Perl_vms_do_exec(pTHX_ const char *cmd)
{
struct dsc$descriptor_s *vmscmd;
@@ -5436,7 +5614,7 @@
} /* end of vms_do_exec() */
/*}}}*/
-unsigned long int Perl_do_spawn(pTHX_ char *);
+unsigned long int Perl_do_spawn(pTHX_ const char *);
/* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
unsigned long int
@@ -5450,7 +5628,7 @@
/* {{{unsigned long int do_spawn(char *cmd) */
unsigned long int
-Perl_do_spawn(pTHX_ char *cmd)
+Perl_do_spawn(pTHX_ const char *cmd)
{
unsigned long int sts, substs;
@@ -5486,7 +5664,10 @@
sts = substs;
}
else {
- (void) safe_popen(aTHX_ cmd, "nW", (int *)&sts);
+ PerlIO * fp;
+ fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
+ if (fp != NULL)
+ my_pclose(fp);
}
return sts;
} /* end of do_spawn() */
@@ -5753,7 +5934,7 @@
* Get information for a named user.
*/
/*{{{struct passwd *getpwnam(char *name)*/
-struct passwd *Perl_my_getpwnam(pTHX_ char *name)
+struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
{
struct dsc$descriptor_s name_desc;
union uicdef uic;
@@ -6774,7 +6955,7 @@
/*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
I32
-Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
+Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, const char *fname)
{
static char usrname[L_cuserid];
static struct dsc$descriptor_s usrdsc =
@@ -6985,7 +7166,7 @@
/*{{{char *my_getlogin()*/
/* VMS cuserid == Unix getlogin, except calling sequence */
char *
-my_getlogin()
+my_getlogin(void)
{
static char user[L_cuserid];
return cuserid(user);
@@ -7019,7 +7200,7 @@
*/
/*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
int
-Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
+Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int
preserve_dates)
{
char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
rsa[NAM$C_MAXRSS], ubf[32256];
--- doio.c_blead Mon Aug 8 22:28:41 2005
+++ doio.c Tue Aug 9 20:46:34 2005
@@ -59,7 +59,7 @@
#include <signal.h>
bool
-Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
+Perl_do_open(pTHX_ GV *gv, register const char *name, I32 len, int as_raw,
int rawmode, int rawperm, PerlIO *supplied_fp)
{
return do_openn(gv, name, len, as_raw, rawmode, rawperm,
@@ -67,7 +67,7 @@
}
bool
-Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
+Perl_do_open9(pTHX_ GV *gv, register const char *name, I32 len, int as_raw,
int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs,
I32 num_svs)
{
@@ -77,7 +77,7 @@
}
bool
-Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
+Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw,
int rawmode, int rawperm, PerlIO *supplied_fp, SV **svp,
I32 num_svs)
{
@@ -194,7 +194,7 @@
IoTYPE(io) = PerlIO_intmode2str(rawmode, &mode[ix], &writing);
- namesv = sv_2mortal(newSVpvn(name,strlen(name)));
+ namesv = sv_2mortal(newSVpvn(oname,strlen(oname)));
num_svs = 1;
svp = &namesv;
type = Nullch;
@@ -202,13 +202,13 @@
}
else {
/* Regular (non-sys) open */
- char *oname = name;
+ char *name;
STRLEN olen = len;
char *tend;
int dodup = 0;
PerlIO *that_fp = NULL;
- type = savepvn(name, len);
+ type = savepvn(oname, len);
tend = type+len;
SAVEFREEPV(type);
@@ -220,7 +220,7 @@
if (num_svs) {
/* New style explicit name, type is just mode and layer info */
#ifdef USE_STDIO
- if (SvROK(*svp) && !strchr(name,'&')) {
+ if (SvROK(*svp) && !strchr(oname,'&')) {
if (ckWARN(WARN_IO))
Perl_warner(aTHX_ packWARN(WARN_IO),
"Can't open a reference");
@@ -567,7 +567,7 @@
}
if (!fp) {
if (IoTYPE(io) == IoTYPE_RDONLY && ckWARN(WARN_NEWLINE)
- && strchr(name, '\n')
+ && strchr(oname, '\n')
)
Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
@@ -1509,17 +1509,25 @@
#if !defined(OS2) && !defined(WIN32) && !defined(DJGPP) && !defined(EPOC) &&
!defined(SYMBIAN) && !defined(MACOS_TRADITIONAL)
bool
-Perl_do_exec(pTHX_ char *cmd)
+Perl_do_exec(pTHX_ const char *cmd)
{
return do_exec3(cmd,0,0);
}
bool
-Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report)
+Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report)
{
dVAR;
register char **a;
register char *s;
+ char * cmd;
+ int cmdlen;
+
+ /* Make a copy so we can change it */
+ cmdlen = strlen(incmd);
+ Newx(cmd, cmdlen+1, char);
+ strncpy(cmd, incmd, cmdlen);
+ cmd[cmdlen] = 0;
while (*cmd && isSPACE(*cmd))
cmd++;
@@ -1560,6 +1568,7 @@
PerlProc_execl(PL_cshname,"csh", flags, ncmd, (char*)0);
PERL_FPU_POST_EXEC
*s = '\'';
+ Safefree(cmd);
return FALSE;
}
}
@@ -1604,6 +1613,7 @@
PERL_FPU_PRE_EXEC
PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char*)0);
PERL_FPU_POST_EXEC
+ Safefree(cmd);
return FALSE;
}
}
@@ -1640,6 +1650,7 @@
}
}
do_execfree();
+ Safefree(cmd);
return FALSE;
}
--- perl.h_blead Fri Aug 5 23:40:17 2005
+++ perl.h Mon Aug 8 20:50:02 2005
@@ -2547,17 +2547,25 @@
# define STATUS_NATIVE PL_statusvalue_vms
# define STATUS_NATIVE_EXPORT \
(((I32)PL_statusvalue_vms == -1 ? 44 : PL_statusvalue_vms) |
(VMSISH_HUSHED ? 0x10000000 : 0))
-# define STATUS_NATIVE_SET(n)
\
+# define STATUS_NATIVE_SET(n) STATUS_NATIVE_SET_PORC(n, 0)
+# define STATUS_NATIVE_CHILD_SET(n) STATUS_NATIVE_SET_PORC(n, 1)
+# define STATUS_NATIVE_SET_PORC(n, _x) \
STMT_START { \
- PL_statusvalue_vms = (n); \
- if ((I32)PL_statusvalue_vms == -1) \
+ I32 evalue = (I32)n; \
+ if (evalue == EVMSERR) { \
+ PL_statusvalue_vms = vaxc$errno; \
+ PL_statusvalue = evalue; \
+ } \
+ else { \
+ PL_statusvalue_vms = evalue; \
+ if ((I32)PL_statusvalue_vms == -1) \
PL_statusvalue = -1; \
- else if (PL_statusvalue_vms & STS$M_SUCCESS) \
- PL_statusvalue = 0; \
- else if ((PL_statusvalue_vms & STS$M_SEVERITY) == 0) \
- PL_statusvalue = 1 << 8; \
- else \
- PL_statusvalue = (PL_statusvalue_vms & STS$M_SEVERITY) << 8;
\
+ else \
+ PL_statusvalue = vms_status_to_unix(evalue); \
+ set_vaxc_errno(evalue); \
+ set_errno(PL_statusvalue); \
+ if (_x) PL_statusvalue = PL_statusvalue << 8; \
+ } \
} STMT_END
# ifdef VMSISH_STATUS
# define STATUS_CURRENT (VMSISH_STATUS ? STATUS_NATIVE : STATUS_UNIX)
@@ -2568,8 +2576,13 @@
STMT_START { \
PL_statusvalue = (n); \
if (PL_statusvalue != -1) { \
- PL_statusvalue &= 0xFFFF; \
- PL_statusvalue_vms = PL_statusvalue ? 44 : 1; \
+ if (PL_statusvalue != EVMSERR) { \
+ PL_statusvalue &= 0xFFFF; \
+ PL_statusvalue_vms = PL_statusvalue ? 44 : 1; \
+ } \
+ else { \
+ PL_statusvalue_vms = vaxc$errno; \
+ } \
} \
else PL_statusvalue_vms = -1; \
} STMT_END
@@ -2579,6 +2592,7 @@
# define STATUS_NATIVE PL_statusvalue_posix
# define STATUS_NATIVE_EXPORT STATUS_NATIVE
# if defined(WCOREDUMP)
+# define STATUS_NATIVE_CHILD_SET(n) STATUS_NATIVE_SET(n)
# define STATUS_NATIVE_SET(n) \
STMT_START { \
PL_statusvalue_posix = (n); \
@@ -2592,6 +2606,7 @@
} \
} STMT_END
# elif defined(WIFEXITED)
+# define STATUS_NATIVE_CHILD_SET(n) STATUS_NATIVE_SET(n)
# define STATUS_NATIVE_SET(n) \
STMT_START { \
PL_statusvalue_posix = (n); \
@@ -2604,6 +2619,7 @@
} \
} STMT_END
# else
+# define STATUS_NATIVE_CHILD_SET(n) STATUS_NATIVE_SET(n)
# define STATUS_NATIVE_SET(n) \
STMT_START { \
PL_statusvalue_posix = (n); \
--- pp_sys.c_blead Tue Aug 9 20:55:40 2005
+++ pp_sys.c Tue Aug 9 20:55:19 2005
@@ -339,7 +339,7 @@
mode = "rb";
else if (PL_op->op_private & OPpOPEN_IN_CRLF)
mode = "rt";
- fp = PerlProc_popen((char*)tmps, (char *)mode);
+ fp = PerlProc_popen(tmps, mode);
if (fp) {
const char *type = NULL;
if (PL_curcop->cop_io) {
@@ -378,7 +378,7 @@
SvTAINTED_on(sv);
}
}
- STATUS_NATIVE_SET(PerlProc_pclose(fp));
+ STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
TAINT; /* "I believe that this is not gratuitous!" */
}
else {
@@ -571,7 +571,7 @@
}
tmps = SvPV_const(sv, len);
- ok = do_openn(gv, (char *)tmps, len, FALSE, O_RDONLY, 0, Nullfp, MARK+1,
(SP-MARK));
+ ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp, MARK+1,
(SP-MARK));
SP = ORIGMARK;
if (ok)
PUSHi( (I32)PL_forkprocess );
@@ -1537,7 +1537,7 @@
/* Need TIEHANDLE method ? */
const char * const tmps = SvPV_const(sv, len);
/* FIXME? do_open should do const */
- if (do_open(gv, (char*)tmps, len, TRUE, mode, perm, Nullfp)) {
+ if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
IoLINES(GvIOp(gv)) = 0;
PUSHs(&PL_sv_yes);
}
@@ -1971,7 +1971,7 @@
if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
IoLINES(io) = 0;
IoFLAGS(io) &= ~IOf_START;
- do_open(gv, (char *)"-", 1, FALSE, O_RDONLY, 0, Nullfp);
+ do_open(gv, "-", 1, FALSE, O_RDONLY, 0, Nullfp);
sv_setpvn(GvSV(gv), "-", 1);
SvSETMAGIC(GvSV(gv));
}
@@ -2760,7 +2760,7 @@
static const char nowhere[] =
"\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
/* If the call succeeded, make sure we don't have a zeroed
port/addr */
if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
- !memcmp((char *)SvPVX_const(sv) + sizeof(u_short), nowhere,
+ !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
sizeof(u_short) + sizeof(struct in_addr))) {
goto nuts2;
}
@@ -4152,9 +4152,9 @@
}
# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
/* 0 and -1 are both error returns (the former applies to WNOHANG case) */
- STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
+ STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
# else
- STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
+ STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
# endif
XPUSHi(childpid);
RETURN;
@@ -4184,9 +4184,9 @@
}
# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
/* 0 and -1 are both error returns (the former applies to WNOHANG case) */
- STATUS_NATIVE_SET((result && result != -1) ? argflags : -1);
+ STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
# else
- STATUS_NATIVE_SET((result > 0) ? argflags : -1);
+ STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
# endif
SETi(result);
RETURN;
@@ -4316,7 +4316,7 @@
}
if (PL_statusvalue == -1) /* hint that value must be returned as is */
result = 1;
- STATUS_NATIVE_SET(value);
+ STATUS_NATIVE_CHILD_SET(value);
do_execfree();
SP = ORIGMARK;
PUSHi(result ? value : STATUS_CURRENT);
--- proto.h_blead Mon Aug 8 21:21:08 2005
+++ proto.h Mon Aug 8 23:30:38 2005
@@ -357,7 +357,7 @@
PERL_CALLCONV bool Perl_do_eof(pTHX_ GV* gv)
__attribute__nonnull__(pTHX_1);
-PERL_CALLCONV bool Perl_do_exec(pTHX_ char* cmd)
+PERL_CALLCONV bool Perl_do_exec(pTHX_ const char* cmd)
__attribute__nonnull__(pTHX_1);
#if defined(WIN32) || defined(SYMBIAN)
@@ -374,7 +374,7 @@
#endif
#if !defined(WIN32)
-PERL_CALLCONV bool Perl_do_exec3(pTHX_ char* cmd, int fd, int flag)
+PERL_CALLCONV bool Perl_do_exec3(pTHX_ const char* cmd, int fd, int flag)
__attribute__nonnull__(pTHX_1);
#endif
@@ -394,16 +394,16 @@
__attribute__nonnull__(pTHX_4);
PERL_CALLCONV OP* Perl_do_kv(pTHX);
-PERL_CALLCONV bool Perl_do_open(pTHX_ GV* gv, char* name, I32 len, int
as_raw, int rawmode, int rawperm, PerlIO* supplied_fp)
+PERL_CALLCONV bool Perl_do_open(pTHX_ GV* gv, const char* name, I32 len,
int as_raw, int rawmode, int rawperm, PerlIO* supplied_fp)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
-PERL_CALLCONV bool Perl_do_open9(pTHX_ GV *gv, char *name, I32 len, int
as_raw, int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs, I32 num)
+PERL_CALLCONV bool Perl_do_open9(pTHX_ GV *gv, const char *name, I32 len,
int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs, I32 num)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2)
__attribute__nonnull__(pTHX_8);
-PERL_CALLCONV bool Perl_do_openn(pTHX_ GV *gv, char *name, I32 len, int
as_raw, int rawmode, int rawperm, PerlIO *supplied_fp, SV **svp, I32 num)
+PERL_CALLCONV bool Perl_do_openn(pTHX_ GV *gv, const char *name, I32 len,
int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp, SV **svp, I32 num)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
@@ -1075,7 +1075,7 @@
#endif
PERL_CALLCONV I32 Perl_my_pclose(pTHX_ PerlIO* ptr);
-PERL_CALLCONV PerlIO* Perl_my_popen(pTHX_ char* cmd, char* mode);
+PERL_CALLCONV PerlIO* Perl_my_popen(pTHX_ const char* cmd, const char* mode);
PERL_CALLCONV PerlIO* Perl_my_popen_list(pTHX_ char* mode, int n, SV ** args);
PERL_CALLCONV void Perl_my_setenv(pTHX_ const char* nam, const char* val);
PERL_CALLCONV I32 Perl_my_stat(pTHX);
--- embed.fnc_25279 Wed Aug 10 00:15:49 2005
+++ embed.fnc Wed Aug 10 00:14:57 2005
@@ -181,14 +181,14 @@
p |void |do_chop |NN SV* asv|NN SV* sv
Ap |bool |do_close |NN GV* gv|bool not_implicit
p |bool |do_eof |NN GV* gv
-p |bool |do_exec |NN char* cmd
+p |bool |do_exec |NN const char* cmd
#if defined(WIN32) || defined(SYMBIAN)
Ap |int |do_aspawn |NN SV* really|NN SV** mark|NN SV** sp
Ap |int |do_spawn |NN char* cmd
Ap |int |do_spawn_nowait|NN char* cmd
#endif
#if !defined(WIN32)
-p |bool |do_exec3 |NN char* cmd|int fd|int flag
+p |bool |do_exec3 |NN const char* cmd|int fd|int flag
#endif
p |void |do_execfree
#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
@@ -201,12 +201,12 @@
#endif
Ap |void |do_join |NN SV* sv|NN SV* del|NN SV** mark|NN SV** sp
p |OP* |do_kv
-Ap |bool |do_open |NN GV* gv|NN char* name|I32 len|int as_raw \
+Ap |bool |do_open |NN GV* gv|NN const char* name|I32 len|int
as_raw \
|int rawmode|int rawperm|NULLOK PerlIO*
supplied_fp
-Ap |bool |do_open9 |NN GV *gv|NN char *name|I32 len|int as_raw \
+Ap |bool |do_open9 |NN GV *gv|NN const char *name|I32 len|int
as_raw \
|int rawmode|int rawperm|NULLOK PerlIO
*supplied_fp \
|NN SV *svs|I32 num
-Ap |bool |do_openn |NN GV *gv|NN char *name|I32 len|int as_raw \
+Ap |bool |do_openn |NN GV *gv|NN const char *name|I32 len|int
as_raw \
|int rawmode|int rawperm|NULLOK PerlIO
*supplied_fp \
|NULLOK SV **svp|I32 num
p |void |do_pipe |NN SV* sv|NULLOK GV* rgv|NULLOK GV* wgv
@@ -483,7 +483,7 @@
Anp |void* |my_memset |NN char* loc|I32 ch|I32 len
#endif
Ap |I32 |my_pclose |PerlIO* ptr
-Ap |PerlIO*|my_popen |char* cmd|char* mode
+Ap |PerlIO*|my_popen |const char* cmd|const char* mode
Ap |PerlIO*|my_popen_list |char* mode|int n|SV ** args
Ap |void |my_setenv |const char* nam|const char* val
Ap |I32 |my_stat
