diff options
| -rw-r--r-- | doio.c | 31 | ||||
| -rw-r--r-- | embed.fnc | 12 | ||||
| -rw-r--r-- | perl.h | 38 | ||||
| -rw-r--r-- | pp_sys.c | 22 | ||||
| -rw-r--r-- | proto.h | 12 | ||||
| -rw-r--r-- | vms/vms.c | 241 | ||||
| -rw-r--r-- | vms/vmsish.h | 46 |
7 files changed, 306 insertions, 96 deletions
@@ -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 @@ Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } 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 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } 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 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, 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 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } 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 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, 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 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, } 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 @@ Perl_do_execfree(pTHX) #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 @@ Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report) PerlProc_execl(PL_cshname,"csh", flags, ncmd, (char*)0); PERL_FPU_POST_EXEC *s = '\''; + Safefree(cmd); return FALSE; } } @@ -1604,6 +1613,7 @@ Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report) 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 @@ Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report) } } do_execfree(); + Safefree(cmd); return FALSE; } @@ -181,14 +181,14 @@ Ap |int |do_binmode |NN PerlIO *fp|int iotype|int mode 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 @@ p |I32 |do_shmio |I32 optype|SV** mark|SV** sp #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 @@ AnpP |I32 |my_memcmp |NN const char* s1|NN const char* s2|I32 len 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 @@ -2547,17 +2547,25 @@ typedef pthread_key_t perl_key; # 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 @@ typedef pthread_key_t perl_key; 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 @@ typedef pthread_key_t perl_key; # 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 @@ typedef pthread_key_t perl_key; } \ } 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 @@ typedef pthread_key_t perl_key; } \ } STMT_END # else +# define STATUS_NATIVE_CHILD_SET(n) STATUS_NATIVE_SET(n) # define STATUS_NATIVE_SET(n) \ STMT_START { \ PL_statusvalue_posix = (n); \ @@ -339,7 +339,7 @@ PP(pp_backtick) 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 @@ PP(pp_backtick) 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 @@ PP(pp_open) } 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 @@ PP(pp_sysopen) /* 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 @@ PP(pp_eof) 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 @@ PP(pp_getpeername) 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 @@ PP(pp_wait) } # 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 @@ PP(pp_waitpid) } # 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 @@ PP(pp_system) } 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); @@ -357,7 +357,7 @@ PERL_CALLCONV bool Perl_do_close(pTHX_ GV* gv, bool not_implicit) 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 @@ PERL_CALLCONV int Perl_do_spawn_nowait(pTHX_ char* cmd) #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 @@ PERL_CALLCONV void Perl_do_join(pTHX_ SV* sv, SV* del, SV** mark, SV** sp) __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 @@ PERL_CALLCONV void* Perl_my_memset(char* loc, I32 ch, I32 len) #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); @@ -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 @@ Perl_my_setenv(pTHX_ const char *lnm, const char *eqv) * 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 @@ Perl_vmssetuserlnm(pTHX_ char *name, char *eqv) 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 @@ Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname) /*}}}*/ -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 @@ Perl_sig_to_vmscondition(int sig) return sig_code[sig]; } - int Perl_my_kill(int pid, int sig) { @@ -1340,6 +1342,161 @@ Perl_my_kill(int pid, int sig) } #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 @@ popen_completion_ast(pInfo info) } -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 @@ vmspipe_tempfile(pTHX) 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 @@ safe_popen(pTHX_ char *cmd, char *in_mode, int *psts) 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 @@ safe_popen(pTHX_ char *cmd, char *in_mode, int *psts) /*{{{ 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 @@ my_gconvert(double val, int ndig, int trail, char *buf) 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 @@ mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsig 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 @@ mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsig 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 @@ mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsig 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 @@ mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsig } /*}}}*/ /* 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 @@ static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) { } /* 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 @@ vms_image_init(int *argcp, char ***argvp) */ /*{{{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 @@ setup_argstr(pTHX_ SV *really, SV **mark, SV **sp) 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 @@ setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote, 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 @@ setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote, 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 @@ setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote, 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 @@ setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote, 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 @@ Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp) /* {{{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 @@ Perl_vms_do_exec(pTHX_ char *cmd) } /* 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 @@ Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp) /* {{{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 @@ Perl_do_spawn(pTHX_ char *cmd) 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 @@ static int fillpasswd (pTHX_ const char *name, struct passwd *pwd) * 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 @@ Perl_cando(pTHX_ Mode_t bit, Uid_t effective, const Stat_t *statbufp) /*{{{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 @@ Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp) /*{{{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 @@ my_getlogin() */ /*{{{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]; diff --git a/vms/vmsish.h b/vms/vmsish.h index 45e831a226..e4e959590e 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -347,6 +347,7 @@ struct interp_intern { * 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 @@ typedef unsigned myino_t; #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 @@ char * Perl_my_getenv (const char *, bool); 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 (const char *, char *); 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 @@ char * Perl_my_getenv (pTHX_ const char *, bool); 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 (pTHX_ const char *, char *); 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_sigdelset (sigset_t *, int); 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 */ |