*
* VMS-specific routines for perl5
*
- * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
- * 2002, 2003, 2004, 2005, 2006, 2007 by Charles Bailey and others.
+ * Copyright (C) 1993-2015 by Charles Bailey and others.
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
- *
- * Please see Changes*.* or the Perl Repository Browser for revision history.
*/
/*
#include <acedef.h>
#include <acldef.h>
#include <armdef.h>
-#if __CRTL_VER < 70300000
-/* needed for home-rolled utime() */
-#include <atrdef.h>
-#include <fibdef.h>
-#endif
#include <chpdef.h>
#include <clidef.h>
#include <climsgdef.h>
#include <lib$routines.h>
#include <lnmdef.h>
#include <ossdef.h>
-#if __CRTL_VER >= 70301000 && !defined(__VAX)
#include <ppropdef.h>
-#endif
#include <prvdef.h>
+#include <pscandef.h>
#include <psldef.h>
#include <rms.h>
#include <shrdef.h>
#include <efndef.h>
#define NO_EFN EFN$C_ENF
-#if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
-int decc$feature_get_index(const char *name);
-char* decc$feature_get_name(int index);
-int decc$feature_get_value(int index, int mode);
-int decc$feature_set_value(int index, int mode, int value);
-#else
#include <unixlib.h>
-#endif
#pragma member_alignment save
#pragma nomember_alignment longword
};
#pragma member_alignment restore
-#if __CRTL_VER >= 70300000 && !defined(__VAX)
-
-static int set_feature_default(const char *name, int value)
-{
- int status;
- int index;
-
- index = decc$feature_get_index(name);
-
- status = decc$feature_set_value(index, 1, value);
- if (index == -1 || (status == -1)) {
- return -1;
- }
-
- status = decc$feature_get_value(index, 1);
- if (status != value) {
- return -1;
- }
-
-return 0;
-}
-#endif
-
/* Older versions of ssdef.h don't have these */
#ifndef SS$_INVFILFOROP
# define SS$_INVFILFOROP 3930
#include <libfildef.h>
#endif
-#if !defined(__VAX) && __CRTL_VER >= 80200000
+#if __CRTL_VER >= 80200000
#ifdef lstat
#undef lstat
#endif
void * char_buffer,
void * char_change_buffer) = 0;
-/* gcc's header files don't #define direct access macros
- * corresponding to VAXC's variant structs */
-#ifdef __GNUC__
-# define uic$v_format uic$r_uic_form.uic$v_format
-# define uic$v_group uic$r_uic_form.uic$v_group
-# define uic$v_member uic$r_uic_form.uic$v_member
-# define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
-# define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
-# define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
-# define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
-#endif
-
#if defined(NEED_AN_H_ERRNO)
dEXT int h_errno;
#endif
-#ifdef __DECC
-#pragma message disable pragma
+#if defined(__DECC) || defined(__DECCXX)
#pragma member_alignment save
#pragma nomember_alignment longword
#pragma message save
struct vs_str_st {
unsigned short length;
- char str[65536];
+ char str[VMS_MAXRSS];
+ unsigned short pad; /* for longword struct alignment */
};
-#ifdef __DECC
+#if defined(__DECC) || defined(__DECCXX)
#pragma message restore
#pragma member_alignment restore
#endif
#define PERL_LNM_MAX_ITER 10
/* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
-#if __CRTL_VER >= 70302000 && !defined(__VAX)
#define MAX_DCL_SYMBOL (8192)
#define MAX_DCL_LINE_LENGTH (4096 - 4)
-#else
-#define MAX_DCL_SYMBOL (1024)
-#define MAX_DCL_LINE_LENGTH (1024 - 4)
-#endif
static char *__mystrtolower(char *str)
{
- if (str) for (; *str; ++str) *str= tolower(*str);
+ if (str) for (; *str; ++str) *str= toLOWER_L1(*str);
return str;
}
/* bug workarounds if needed */
int decc_bug_devnull = 1;
-int decc_dir_barename = 0;
int vms_bug_stat_filename = 0;
static int vms_debug_on_exception = 0;
static int vms_debug_fileify = 0;
/* Simple logical name translation */
-static int simple_trnlnm
- (const char * logname,
- char * value,
- int value_len)
+static int
+simple_trnlnm(const char * logname, char * value, int value_len)
{
const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
const unsigned long attr = LNM$M_CASE_BLIND;
* changes to many other conversion routines.
*/
-static int is_unix_filespec(const char *path)
+static int
+is_unix_filespec(const char *path)
{
-int ret_val;
-const char * pch1;
+ int ret_val;
+ const char * pch1;
ret_val = 0;
- if (strncmp(path,"\"^UP^",5) != 0) {
+ if (! strBEGINs(path,"\"^UP^")) {
pch1 = strchr(path, '/');
if (pch1 != NULL)
ret_val = 1;
/* If the user wants UNIX files, "." needs to be treated as in UNIX */
if (decc_filename_unix_report || decc_filename_unix_only) {
- if (strcmp(path,".") == 0)
+ if (strEQ(path,"."))
ret_val = 1;
}
}
/* This routine converts a UCS-2 character to be VTF-7 encoded.
*/
-static void ucs2_to_vtf7
- (char *outspec,
- unsigned long ucs2_char,
- int * output_cnt)
+static void
+ucs2_to_vtf7(char *outspec, unsigned long ucs2_char, int * output_cnt)
{
-unsigned char * ucs_ptr;
-int hex;
+ unsigned char * ucs_ptr;
+ int hex;
ucs_ptr = (unsigned char *)&ucs2_char;
*
* The return value is the number of characters read from the input string
*/
-static int copy_expand_unix_filename_escape
- (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
+static int
+copy_expand_unix_filename_escape(char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
{
-int count;
-int utf8_flag;
+ int count;
+ int utf8_flag;
utf8_flag = 0;
if (utf8_fl)
if ((inspec[0] == '$') && (inspec[1] == '(')) {
int tcnt;
- if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
+ if (isALPHA_L1(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
tcnt = 3;
outspec[0] = inspec[0];
outspec[1] = inspec[1];
outspec[2] = inspec[2];
- while(isalnum(inspec[tcnt]) ||
+ while(isALPHA_L1(inspec[tcnt]) ||
(inspec[2] == '.') || (inspec[2] == '_')) {
outspec[tcnt] = inspec[tcnt];
tcnt++;
return 1;
break;
case '.':
- case '~':
case '!':
case '#':
case '&':
/* Don't escape again if following character is
* already something we escape.
*/
- if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
+ if (strchr(".!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
*outspec = *inspec;
*output_cnt = 1;
return 1;
return 1;
break;
}
+ return 0;
}
* The return value is the number of characters read from the input
* string
*/
-static int copy_expand_vms_filename_escape
- (char *outspec, const char *inspec, int *output_cnt)
+static int
+copy_expand_vms_filename_escape(char *outspec, const char *inspec, int *output_cnt)
{
-int count;
-int scnt;
+ int count;
+ int scnt;
count = 0;
*output_cnt = 0;
* string, then the passed file specification is probably a UNIX style
* path.
*/
-static int vms_split_path
- (const char * path,
- char * * volume,
- int * vol_len,
- char * * root,
- int * root_len,
- char * * dir,
- int * dir_len,
- char * * name,
- int * name_len,
- char * * ext,
- int * ext_len,
- char * * version,
- int * ver_len)
-{
-struct dsc$descriptor path_desc;
-int status;
-unsigned long flags;
-int ret_stat;
-struct filescan_itmlst_2 item_list[9];
-const int filespec = 0;
-const int nodespec = 1;
-const int devspec = 2;
-const int rootspec = 3;
-const int dirspec = 4;
-const int namespec = 5;
-const int typespec = 6;
-const int verspec = 7;
+static int
+vms_split_path(const char * path, char * * volume, int * vol_len, char * * root, int * root_len,
+ char * * dir, int * dir_len, char * * name, int * name_len,
+ char * * ext, int * ext_len, char * * version, int * ver_len)
+{
+ struct dsc$descriptor path_desc;
+ int status;
+ unsigned long flags;
+ int ret_stat;
+ struct filescan_itmlst_2 item_list[9];
+ const int filespec = 0;
+ const int nodespec = 1;
+ const int devspec = 2;
+ const int rootspec = 3;
+ const int dirspec = 4;
+ const int namespec = 5;
+ const int typespec = 6;
+ const int verspec = 7;
/* Assume the worst for an easy exit */
ret_stat = -1;
}
/* Routine to determine if the file specification ends with .dir */
-static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) {
+static int
+is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len)
+{
/* e_len must be 4, and version must be <= 2 characters */
if (e_len != 4 || vs_len > 2)
/* Look for the DIR on the extension */
if (vms_process_case_tolerant) {
- if ((toupper(e_spec[1]) == 'D') &&
- (toupper(e_spec[2]) == 'I') &&
- (toupper(e_spec[3]) == 'R')) {
+ if ((toUPPER_A(e_spec[1]) == 'D') &&
+ (toUPPER_A(e_spec[2]) == 'I') &&
+ (toUPPER_A(e_spec[3]) == 'R')) {
return 1;
}
} else {
}
/*}}}*/
+/* Routine to remove the 2-byte prefix from the translation of a
+ * process-permanent file (PPF).
+ */
+static inline unsigned short int
+S_remove_ppf_prefix(const char *lnm, char *eqv, unsigned short int eqvlen)
+{
+ if (*((int *)lnm) == *((int *)"SYS$") &&
+ eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
+ ( (lnm[4] == 'O' && strEQ(lnm,"SYS$OUTPUT")) ||
+ (lnm[4] == 'I' && strEQ(lnm,"SYS$INPUT")) ||
+ (lnm[4] == 'E' && strEQ(lnm,"SYS$ERROR")) ||
+ (lnm[4] == 'C' && strEQ(lnm,"SYS$COMMAND")) ) ) {
+
+ memmove(eqv, eqv+4, eqvlen-4);
+ eqvlen -= 4;
+ }
+ return eqvlen;
+}
+
/*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
int
Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
const char *cp1;
char uplnm[LNM$C_NAMLENGTH+1], *cp2;
unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
+ bool found_in_crtlenv = 0, found_in_clisym = 0;
unsigned long int retsts, attr = LNM$M_CASE_BLIND;
int midx;
unsigned char acmode;
set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
}
for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
- *cp2 = _toupper(*cp1);
+ *cp2 = toUPPER_A(*cp1);
if (cp1 - lnm > LNM$C_NAMLENGTH) {
set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
return 0;
for (i = 0; environ[i]; i++) {
if ((eq = strchr(environ[i],'=')) &&
lnmdsc.dsc$w_length == (eq - environ[i]) &&
- !strncmp(environ[i],uplnm,eq - environ[i])) {
+ strnEQ(environ[i],lnm,eq - environ[i])) {
eq++;
for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
if (!eqvlen) continue;
break;
}
}
- if (retsts != SS$_NOLOGNAM) break;
+ if (retsts != SS$_NOLOGNAM) {
+ found_in_crtlenv = 1;
+ break;
+ }
}
}
else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
_ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
if (retsts == LIB$_NOSUCHSYM) continue;
+ found_in_clisym = 1;
break;
}
}
retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
if (retsts == SS$_NOLOGNAM) break;
- /* PPFs have a prefix */
- if (
-#if INTSIZE == 4
- *((int *)uplnm) == *((int *)"SYS$") &&
-#endif
- eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
- ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
- (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
- (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
- (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
- memmove(eqv,eqv+4,eqvlen-4);
- eqvlen -= 4;
- }
+ eqvlen = S_remove_ppf_prefix(uplnm, eqv, eqvlen);
cp2 += eqvlen;
*cp2 = '\0';
}
if ((retsts == SS$_IVLOGNAM) ||
(retsts == SS$_NOLOGNAM)) { continue; }
+ eqvlen = strlen(eqv);
}
else {
retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
if (retsts == SS$_NOLOGNAM) continue;
+ eqvlen = S_remove_ppf_prefix(uplnm, eqv, eqvlen);
eqv[eqvlen] = '\0';
}
- eqvlen = strlen(eqv);
break;
}
}
- if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
- else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
- retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
+ /* An index only makes sense for logical names, so make sure we aren't
+ * iterating over an index for an environ var or DCL symbol and getting
+ * the same answer ad infinitum.
+ */
+ if (idx > 0 && (found_in_crtlenv || found_in_clisym)) {
+ return 0;
+ }
+ else if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
+ else if (retsts == LIB$_NOSUCHSYM ||
retsts == SS$_NOLOGNAM) {
+ /* Unsuccessful lookup is normal -- no need to set errno */
+ return 0;
+ }
+ else if (retsts == LIB$_INVSYMNAM ||
+ retsts == SS$_IVLOGNAM ||
+ retsts == SS$_IVLOGTAB) {
set_errno(EINVAL); set_vaxc_errno(retsts);
}
else _ckvmssts_noperl(retsts);
/*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
/* Define as a function so we can access statics. */
-int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
+int
+Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
{
int flags = 0;
if (aTHX != NULL)
#endif
#ifdef SECURE_INTERNAL_GETENV
- flags = (PL_curinterp ? PL_tainting : will_taint) ?
+ flags = (PL_curinterp ? TAINTING_get : will_taint) ?
PERL__TRNENV_SECURE : 0;
#endif
static char *__my_getenv_eqv = NULL;
char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
unsigned long int idx = 0;
- int success, secure, saverr, savvmserr;
+ int success, secure;
int midx, flags;
SV *tmpsv;
eqv = __my_getenv_eqv;
}
- for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
- if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
+ for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = toUPPER_A(*cp1);
+ if (memEQs(eqv, cp1 - lnm, "DEFAULT")) {
int len;
getcwd(eqv,LNM$C_NAMLENGTH);
/* Impose security constraints only if tainting */
if (sys) {
/* Impose security constraints only if tainting */
- secure = PL_curinterp ? PL_tainting : will_taint;
- saverr = errno; savvmserr = vaxc$errno;
+ secure = PL_curinterp ? TAINTING_get : will_taint;
}
else {
secure = 0;
success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
- /* 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 : NULL;
}
unsigned long idx = 0;
int midx, flags;
static char *__my_getenv_len_eqv = NULL;
- int secure, saverr, savvmserr;
+ int secure;
SV *tmpsv;
midx = my_maxidx(lnm) + 1;
buf = __my_getenv_len_eqv;
}
- for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
- if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
+ for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = toUPPER_A(*cp1);
+ if (memEQs(buf, cp1 - lnm, "DEFAULT")) {
char * zeros;
getcwd(buf,LNM$C_NAMLENGTH);
else {
if (sys) {
/* Impose security constraints only if tainting */
- secure = PL_curinterp ? PL_tainting : will_taint;
- saverr = errno; savvmserr = vaxc$errno;
+ secure = PL_curinterp ? TAINTING_get : will_taint;
}
else {
secure = 0;
/* Get rid of "000000/ in rooted filespecs */
if (*len > 7) {
- char * zeros;
+ char * zeros;
zeros = strstr(buf, "/000000/");
if (zeros != NULL) {
int mlen;
}
}
- /* 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 : NULL;
}
envhv = GvHVn(PL_envgv);
/* Perform a dummy fetch as an lval to insure that the hash table is
* set up. Otherwise, the hv_store() will turn into a nullop. */
- (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
+ (void) hv_fetchs(envhv,"DEFAULT",TRUE);
for (i = 0; env_tables[i]; i++) {
if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
char *start;
int j;
- for (j = 0; environ[j]; j++) {
+ /* Start at the end, so if there is a duplicate we keep the first one. */
+ for (j = 0; environ[j]; j++);
+ for (j--; j >= 0; j--) {
if (!(start = strchr(environ[j],'='))) {
if (ckWARN(WARN_INTERNAL))
Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
my_strlcpy(cmd, "Show Logical *", sizeof(cmd));
if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
my_strlcat(cmd," /Table=", sizeof(cmd));
- cmddsc.dsc$w_length = my_strlcat(cmd, env_tables[i]->dsc$a_pointer, env_tables[i]->dsc$w_length + 1);
+ cmddsc.dsc$w_length = my_strlcat(cmd, env_tables[i]->dsc$a_pointer, sizeof(cmd));
}
else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
flags = defflags | CLI$M_NOCLISYM;
while (1) {
char *cp1, *cp2, *key;
unsigned long int sts, iosb[2], retlen, keylen;
- register U32 hash;
+ U32 hash;
sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
if (sts & 1) sts = iosb[0] & 0xffff;
if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
- for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
+ for (cp1 = buf; *cp1 && isSPACE_L1(*cp1); cp1++) ;
if (*cp1 == '(' || /* Logical name table name */
*cp1 == '=' /* Next eqv of searchlist */) continue;
if (*cp1 == '"') cp1++;
}
for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
- *cp2 = _toupper(*cp1);
+ *cp2 = toUPPER_A(*cp1);
if (cp1 - lnm > LNM$C_NAMLENGTH) {
set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
return SS$_IVLOGNAM;
for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
if ((cp1 = strchr(environ[i],'=')) &&
lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
- !strncmp(environ[i],lnm,cp1 - environ[i])) {
-#ifdef HAS_SETENV
- return setenv(lnm,"",1) ? vaxc$errno : 0;
+ strnEQ(environ[i],lnm,cp1 - environ[i])) {
+ unsetenv(lnm);
+ return 0;
}
}
ivenv = 1; retsts = SS$_NOLOGNAM;
-#else
- if (ckWARN(WARN_INTERNAL))
- Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
- ivenv = 1; retsts = SS$_NOSUCHPGM;
- break;
- }
- }
-#endif
}
else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
!str$case_blind_compare(&tmpdsc,&clisym)) {
}
else { /* we're defining a value */
if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
-#ifdef HAS_SETENV
return setenv(lnm,eqv,1) ? vaxc$errno : 0;
-#else
- if (ckWARN(WARN_INTERNAL))
- Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
- retsts = SS$_NOSUCHPGM;
-#endif
}
else {
eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
if (len == 7) {
char uplnm[8];
int i;
- for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
- if (!strcmp(uplnm,"DEFAULT")) {
+ for (i = 0; lnm[i]; i++) uplnm[i] = toUPPER_A(lnm[i]);
+ if (strEQ(uplnm,"DEFAULT")) {
if (eqv && *eqv) my_chdir(eqv);
return;
}
/* vmssetuserlnm
* sets a user-mode logical in the process logical name table
* used for redirection of sys$error
- *
- * Fix-me: The pTHX is not needed for this routine, however doio.c
- * is calling it with one instead of using a macro.
- * A macro needs to be added to vmsish.h and doio.c updated to use it.
- *
*/
void
-Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
+Perl_vmssetuserlnm(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};
static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
-/* fixup barenames that are directories for internal use.
- * There have been problems with the consistent handling of UNIX
- * style directory names when routines are presented with a name that
- * has no directory delimiters at all. So this routine will eventually
- * fix the issue.
- */
-static char * fixup_bare_dirnames(const char * name)
-{
- if (decc_disable_to_vms_logname_translation) {
-/* fix me */
- }
- return NULL;
-}
-
/* 8.3, remove() is now broken on symbolic links */
static int rms_erase(const char * vmsname);
char *vmsname;
char *rslt;
unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
- unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
+ unsigned long int cxt = 0, aclsts, fndsts;
+ int rmsts = -1;
struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
struct myacedef {
unsigned char myace$b_length;
/* Expand the input spec using RMS, since the CRTL remove() and
* system services won't do this by themselves, so we may miss
* a file "hiding" behind a logical name or search list. */
- vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
+ vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
Perl_my_chdir(pTHX_ const char *dir)
{
STRLEN dirlen = strlen(dir);
+ const char *dir1 = dir;
- /* zero length string sometimes gives ACCVIO */
- if (dirlen == 0) return -1;
- const char *dir1;
+ /* POSIX says we should set ENOENT for zero length string. */
+ if (dirlen == 0) {
+ SETERRNO(ENOENT, RMS$_DNF);
+ return -1;
+ }
/* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
* This does not work if DECC$EFS_CHARSET is active. Hack it here
* so that existing scripts do not need to be changed.
*/
- dir1 = dir;
while ((dirlen > 0) && (*dir1 == ' ')) {
dir1++;
dirlen--;
if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
char *newdir;
int ret;
- newdir = PerlMem_malloc(dirlen);
+ newdir = (char *)PerlMem_malloc(dirlen);
if (newdir ==NULL)
_ckvmssts_noperl(SS$_INSFMEM);
memcpy(newdir, dir1, dirlen-1);
if ((fp = tmpfile())) return fp;
- cp = PerlMem_malloc(L_tmpnam+24);
+ cp = (char *)PerlMem_malloc(L_tmpnam+24);
if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if (decc_filename_unix_only == 0)
}
/*}}}*/
-#ifdef KILL_BY_SIGPRC
#include <errnodef.h>
/* We implement our own kill() using the undocumented system service
SS$_BREAK, /* 5 SIGTRAP */
SS$_OPCCUS, /* 6 SIGABRT */
SS$_COMPAT, /* 7 SIGEMT */
-#ifdef __VAX
- SS$_FLTOVF, /* 8 SIGFPE VAX */
-#else
SS$_HPARITH, /* 8 SIGFPE AXP */
-#endif
SS$_ABORT, /* 9 SIGKILL */
SS$_ACCVIO, /* 10 SIGBUS */
SS$_ACCVIO, /* 11 SIGSEGV */
sig_code[16] = C$_SIGUSR1;
sig_code[17] = C$_SIGUSR2;
sig_code[20] = C$_SIGCHLD;
-#if __CRTL_VER >= 70300000
sig_code[28] = C$_SIGWINCH;
-#endif
}
if (sig < _SIG_MIN) return 0;
}
+#ifdef KILL_BY_SIGPRC
+#define sys$sigprc SYS$SIGPRC
+#ifdef __cplusplus
+extern "C" {
+#endif
+int sys$sigprc(unsigned int *pidadr,
+ struct dsc$descriptor_s *prcname,
+ unsigned int code);
+#ifdef __cplusplus
+}
+#endif
+
int
Perl_my_kill(int pid, int sig)
{
int iss;
unsigned int code;
-#define sys$sigprc SYS$SIGPRC
- int sys$sigprc(unsigned int *pidadr,
- struct dsc$descriptor_s *prcname,
- unsigned int code);
/* sig 0 means validate the PID */
/*------------------------------*/
return -1;
}
- /* Fixme: Per official UNIX specification: If pid = 0, or negative then
+ /* Per official UNIX specification: If pid = 0, or negative then
* signals are to be sent to multiple processes.
* pid = 0 - all processes in group except ones that the system exempts
* pid = -1 - all processes except ones that the system exempts
* pid = -n - all processes in group (abs(n)) except ...
- * For now, just report as not supported.
+ *
+ * Handle these via killpg, which is redundant for the -n case, since OP_KILL
+ * in doio.c already does that. killpg currently does not support the -1 case.
*/
if (pid <= 0) {
- SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
- return -1;
+ return killpg(-pid, sig);
}
iss = sys$sigprc((unsigned int *)&pid,0,code);
}
#endif
+int
+Perl_my_killpg(pid_t master_pid, int signum)
+{
+ int pid, status, i;
+ unsigned long int jpi_context;
+ unsigned short int iosb[4];
+ struct itmlst_3 il3[3];
+
+ /* All processes on the system? Seems dangerous, but it looks
+ * like we could implement this pretty easily with a wildcard
+ * input to sys$process_scan.
+ */
+ if (master_pid == -1) {
+ SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
+ return -1;
+ }
+
+ /* All processes in the current process group; find the master
+ * pid for the current process.
+ */
+ if (master_pid == 0) {
+ i = 0;
+ il3[i].buflen = sizeof( int );
+ il3[i].itmcode = JPI$_MASTER_PID;
+ il3[i].bufadr = &master_pid;
+ il3[i++].retlen = NULL;
+
+ il3[i].buflen = 0;
+ il3[i].itmcode = 0;
+ il3[i].bufadr = NULL;
+ il3[i++].retlen = NULL;
+
+ status = sys$getjpiw(EFN$C_ENF, NULL, NULL, il3, iosb, NULL, 0);
+ if ($VMS_STATUS_SUCCESS(status))
+ status = iosb[0];
+
+ switch (status) {
+ case SS$_NORMAL:
+ break;
+ case SS$_NOPRIV:
+ case SS$_SUSPENDED:
+ SETERRNO(EPERM, status);
+ break;
+ case SS$_NOMOREPROC:
+ case SS$_NONEXPR:
+ case SS$_NOSUCHNODE:
+ case SS$_UNREACHABLE:
+ SETERRNO(ESRCH, status);
+ break;
+ case SS$_ACCVIO:
+ case SS$_BADPARAM:
+ SETERRNO(EINVAL, status);
+ break;
+ default:
+ SETERRNO(EVMSERR, status);
+ }
+ if (!$VMS_STATUS_SUCCESS(status))
+ return -1;
+ }
+
+ /* Set up a process context for those processes we will scan
+ * with sys$getjpiw. Ask for all processes belonging to the
+ * master pid.
+ */
+
+ i = 0;
+ il3[i].buflen = 0;
+ il3[i].itmcode = PSCAN$_MASTER_PID;
+ il3[i].bufadr = (void *)master_pid;
+ il3[i++].retlen = NULL;
+
+ il3[i].buflen = 0;
+ il3[i].itmcode = 0;
+ il3[i].bufadr = NULL;
+ il3[i++].retlen = NULL;
+
+ status = sys$process_scan(&jpi_context, il3);
+ switch (status) {
+ case SS$_NORMAL:
+ break;
+ case SS$_ACCVIO:
+ case SS$_BADPARAM:
+ case SS$_IVBUFLEN:
+ case SS$_IVSSRQ:
+ SETERRNO(EINVAL, status);
+ break;
+ default:
+ SETERRNO(EVMSERR, status);
+ }
+ if (!$VMS_STATUS_SUCCESS(status))
+ return -1;
+
+ i = 0;
+ il3[i].buflen = sizeof(int);
+ il3[i].itmcode = JPI$_PID;
+ il3[i].bufadr = &pid;
+ il3[i++].retlen = NULL;
+
+ il3[i].buflen = 0;
+ il3[i].itmcode = 0;
+ il3[i].bufadr = NULL;
+ il3[i++].retlen = NULL;
+
+ /* Loop through the processes matching our specified criteria
+ */
+
+ while (1) {
+ /* Find the next process...
+ */
+ status = sys$getjpiw( EFN$C_ENF, &jpi_context, NULL, il3, iosb, NULL, 0);
+ if ($VMS_STATUS_SUCCESS(status)) status = iosb[0];
+
+ switch (status) {
+ case SS$_NORMAL:
+ if (kill(pid, signum) == -1)
+ break;
+
+ continue; /* next process */
+ case SS$_NOPRIV:
+ case SS$_SUSPENDED:
+ SETERRNO(EPERM, status);
+ break;
+ case SS$_NOMOREPROC:
+ break;
+ case SS$_NONEXPR:
+ case SS$_NOSUCHNODE:
+ case SS$_UNREACHABLE:
+ SETERRNO(ESRCH, status);
+ break;
+ case SS$_ACCVIO:
+ case SS$_BADPARAM:
+ SETERRNO(EINVAL, status);
+ break;
+ default:
+ SETERRNO(EVMSERR, status);
+ }
+
+ if (!$VMS_STATUS_SUCCESS(status))
+ break;
+ }
+
+ /* Release context-related resources.
+ */
+ (void) sys$process_scan(&jpi_context);
+
+ if (status != SS$_NOMOREPROC)
+ return -1;
+
+ return 0;
+}
+
/* Routine to convert a VMS status code to a UNIX status code.
** More tricky than it appears because of conflicting conventions with
** existing code.
#define DCL_IVVERB 0x38090
#endif
-int Perl_vms_status_to_unix(int vms_status, int child_flag)
+int
+Perl_vms_status_to_unix(int vms_status, int child_flag)
{
-int facility;
-int fac_sp;
-int msg_no;
-int msg_status;
-int unix_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)
* error statuses that caused the errno value to be set.
*/
-int Perl_unix_status_to_vms(int unix_status)
+int
+Perl_unix_status_to_vms(int unix_status)
{
-int test_unix_status;
+ int test_unix_status;
/* Trivial cases first */
/*---------------------*/
/* default piping mailbox size */
-#ifdef __VAX
-# define PERL_BUFSIZ 512
-#else
-# define PERL_BUFSIZ 8192
-#endif
+#define PERL_BUFSIZ 8192
static void
/* get the directory from $^X */
- unixdir = PerlMem_malloc(VMS_MAXRSS);
+ unixdir = (char *)PerlMem_malloc(VMS_MAXRSS);
if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
#ifdef PERL_IMPLICIT_CONTEXT
if (SvROK(dirsv)) continue;
dir = SvPVx(dirsv,n_a);
- if (strcmp(dir,".") == 0) continue;
+ if (strEQ(dir,".")) continue;
if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
continue;
PerlMem_free(unixdir);
}
-static I32
-Perl_cando_by_name_int
- (pTHX_ I32 bit, bool effective, const char *fname, int opts);
+static I32 Perl_cando_by_name_int(pTHX_ I32 bit, bool effective,
+ const char *fname, int opts);
#if !defined(PERL_IMPLICIT_CONTEXT)
#define cando_by_name_int Perl_cando_by_name_int
#else
}
-static int vms_is_syscommand_xterm(void)
+static int
+vms_is_syscommand_xterm(void)
{
const static struct dsc$descriptor_s syscommand_dsc =
{ 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
}
/* If we are on a DECTerm, we can pretend to fork xterms when requested */
-static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
+static PerlIO*
+create_forked_xterm(pTHX_ const char *cmd, const char *mode)
{
int status;
int ret_stat;
info->xchan = 0;
info->xchan_valid = 0;
- in = PerlMem_malloc(VMS_MAXRSS);
+ in = (char *)PerlMem_malloc(VMS_MAXRSS);
if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- out = PerlMem_malloc(VMS_MAXRSS);
+ out = (char *)PerlMem_malloc(VMS_MAXRSS);
if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- err = PerlMem_malloc(VMS_MAXRSS);
+ err = (char *)PerlMem_malloc(VMS_MAXRSS);
if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
in[0] = out[0] = err[0] = '\0';
info->fp = PerlIO_open(mbx, mode);
} else {
info->fp = (PerlIO *) freopen(mbx, mode, stdin);
- Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
+ vmssetuserlnm("SYS$INPUT", mbx);
}
if (!info->fp && info->out) {
info->fp = PerlIO_open(mbx, mode);
} else {
info->fp = (PerlIO *) freopen(mbx, mode, stdout);
- Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
+ vmssetuserlnm("SYS$OUTPUT", mbx);
}
if (info->in) {
} else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
+ /* Let the child inherit standard input, unless it's a directory. */
+ Stat_t st;
+ if (my_trnlnm("SYS$INPUT", in, 0)) {
+ if (flex_stat(in, &st) != 0 || S_ISDIR(st.st_mode))
+ *in = '\0';
+ }
+
info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
if (info->out) {
info->out->pipe_done = &info->out_done;
/* Routine to close and cleanup a pipe info structure */
-static I32 my_pclose_pinfo(pTHX_ pInfo info) {
+static I32
+my_pclose_pinfo(pTHX_ pInfo info) {
unsigned long int retsts;
int done, n;
} /* end of my_pclose() */
-#if defined(__CRTL_VER) && __CRTL_VER >= 70200000
/* Roll our own prototype because we want this regardless of whether
* _VMS_WAIT is defined.
*/
+
+#ifdef __cplusplus
+extern "C" {
+#endif
__pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
+#ifdef __cplusplus
+}
#endif
+
/* sort-of waitpid; special handling of pipe clean-up for subprocesses
created with popen(); otherwise partially emulate waitpid() unless
we have a suitable one from the CRTL that came with VMS 7.2 and later.
/* fall through if this child is not one of our own pipe children */
-#if defined(__CRTL_VER) && __CRTL_VER >= 70200000
-
/* waitpid() became available in the CRTL as of VMS 7.0, but only
* in 7.2 did we get a version that fills in the VMS completion
* status as Perl has always tried to do.
* of the current process.
*/
-#endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
-
{
$DESCRIPTOR(intdsc,"0 00:00:01");
unsigned long int ownercode = JPI$_OWNER, ownerpid;
loc = buf ? buf : __gcvtbuf;
-#ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
- if (val < 1) {
- sprintf(loc,"%.*g",ndig,val);
- return loc;
- }
-#endif
-
if (val) {
if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
return gcvt(val,ndig,loc);
}
/*}}}*/
-#if defined(__VAX) || !defined(NAML$C_MAXRSS)
-static int rms_free_search_context(struct FAB * fab)
+#if !defined(NAML$C_MAXRSS)
+static int
+rms_free_search_context(struct FAB * fab)
{
-struct NAM * nam;
+ struct NAM * nam;
nam = fab->fab$l_nam;
nam->nam$b_nop |= NAM$M_SYNCHK;
#define rms_nam_name_type_l_size(nam) \
(nam.nam$b_name + nam.nam$b_type)
#else
-static int rms_free_search_context(struct FAB * fab)
+static int
+rms_free_search_context(struct FAB * fab)
{
-struct NAML * nam;
+ struct NAML * nam;
nam = fab->fab$l_naml;
nam->naml$b_nop |= NAM$M_SYNCHK;
* however in 8.3 the unlink/remove/delete routines will only properly handle
* them if one of the PCP modes is active.
*/
-static int rms_erase(const char * vmsname)
+static int
+rms_erase(const char * vmsname)
{
int status;
struct FAB myfab = cc$rms_fab;
/* I can not find online documentation for $change_acl
* it appears to be replaced by $set_security some time ago */
-const unsigned int access_mode = 0;
-$DESCRIPTOR(obj_file_dsc,"FILE");
-char *vmsname;
-char *rslt;
-unsigned long int jpicode = JPI$_UIC;
-int aclsts, fndsts, rnsts = -1;
-unsigned int ctx = 0;
-struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
-struct dsc$descriptor_s * clean_dsc;
-
-struct myacedef {
- unsigned char myace$b_length;
- unsigned char myace$b_type;
- unsigned short int myace$w_flags;
- unsigned long int myace$l_access;
- unsigned long int myace$l_ident;
-} newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
- ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
- 0},
- oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
-
-struct item_list_3
+ const unsigned int access_mode = 0;
+ $DESCRIPTOR(obj_file_dsc,"FILE");
+ char *vmsname;
+ char *rslt;
+ unsigned long int jpicode = JPI$_UIC;
+ int aclsts, fndsts, rnsts = -1;
+ unsigned int ctx = 0;
+ struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
+ struct dsc$descriptor_s * clean_dsc;
+
+ struct myacedef {
+ unsigned char myace$b_length;
+ unsigned char myace$b_type;
+ unsigned short int myace$w_flags;
+ unsigned long int myace$l_access;
+ unsigned long int myace$l_ident;
+ } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
+ ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
+ 0},
+ oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
+
+ struct item_list_3
findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
{sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
{0,0,0,0}},
/* Expand the input spec using RMS, since we do not want to put
* ACLs on the target of a symbolic link */
- vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
+ vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1);
if (vmsname == NULL)
return SS$_INSFMEM;
int
Perl_rename(pTHX_ const char *src, const char * dst)
{
-int retval;
-int pre_delete = 0;
-int src_sts;
-int dst_sts;
-Stat_t src_st;
-Stat_t dst_st;
+ int retval;
+ int pre_delete = 0;
+ int src_sts;
+ int dst_sts;
+ Stat_t src_st;
+ Stat_t dst_st;
/* Validate the source file */
src_sts = flex_lstat(src, &src_st);
* on if one or more of them are directories.
*/
- vms_dst = PerlMem_malloc(VMS_MAXRSS);
+ vms_dst = (char *)PerlMem_malloc(VMS_MAXRSS);
if (vms_dst == NULL)
_ckvmssts_noperl(SS$_INSFMEM);
char * ret_str;
char * vms_dir_file;
- vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
+ vms_dir_file = (char *)PerlMem_malloc(VMS_MAXRSS);
if (vms_dir_file == NULL)
_ckvmssts_noperl(SS$_INSFMEM);
new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
flags = 0;
-#if !defined(__VAX) && defined(NAML$C_MAXRSS)
+#if defined(NAML$C_MAXRSS)
flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
#endif
isunix = 1;
char * ret_spec;
- vmsfspec = PerlMem_malloc(VMS_MAXRSS);
+ vmsfspec = (char *)PerlMem_malloc(VMS_MAXRSS);
if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
if (ret_spec == NULL) {
* UNIX output, and that requires long names to be used
*/
if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
-#if !defined(__VAX) && defined(NAML$C_MAXRSS)
+#if defined(NAML$C_MAXRSS)
opts |= PERL_RMSEXPAND_M_LONG;
#else
NOOP;
int t_isunix;
t_isunix = is_unix_filespec(defspec);
if (t_isunix) {
- vmsdefspec = PerlMem_malloc(VMS_MAXRSS);
+ vmsdefspec = (char *)PerlMem_malloc(VMS_MAXRSS);
if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
}
/* Now we need the expansion buffers */
- esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
+ esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
-#if !defined(__VAX) && defined(NAML$C_MAXRSS)
- esal = PerlMem_malloc(VMS_MAXRSS);
+#if defined(NAML$C_MAXRSS)
+ esal = (char *)PerlMem_malloc(VMS_MAXRSS);
if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
#endif
rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
/* If a NAML block is used RMS always writes to the long and short
* addresses unless you suppress the short name.
*/
-#if !defined(__VAX) && defined(NAML$C_MAXRSS)
- outbufl = PerlMem_malloc(VMS_MAXRSS);
+#if defined(NAML$C_MAXRSS)
+ outbufl = (char *)PerlMem_malloc(VMS_MAXRSS);
if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
#endif
rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
/* Is a long or a short name expected */
/*------------------------------------*/
spec_buf = NULL;
-#if !defined(__VAX) && defined(NAML$C_MAXRSS)
+#if defined(NAML$C_MAXRSS)
if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
if (rms_nam_rsll(mynam)) {
spec_buf = outbufl;
spec_buf = esa; /* Not esal */
speclen = rms_nam_esl(mynam);
}
-#if !defined(__VAX) && defined(NAML$C_MAXRSS)
+#if defined(NAML$C_MAXRSS)
}
#endif
spec_buf[speclen] = '\0';
if (defspec && *defspec) {
char *defesal = NULL;
char *defesa = NULL;
- defesa = PerlMem_malloc(VMS_MAXRSS + 1);
+ defesa = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
if (defesa != NULL) {
struct FAB deffab = cc$rms_fab;
-#if !defined(__VAX) && defined(NAML$C_MAXRSS)
- defesal = PerlMem_malloc(VMS_MAXRSS + 1);
+#if defined(NAML$C_MAXRSS)
+ defesal = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
#endif
rms_setup_nam(defnam);
/* If we just had a directory spec on input, $PARSE "helpfully"
* adds an empty name and type for us */
-#if !defined(__VAX) && defined(NAML$C_MAXRSS)
+#if defined(NAML$C_MAXRSS)
if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
{
int rsl;
-#if !defined(__VAX) && defined(NAML$C_MAXRSS)
+#if defined(NAML$C_MAXRSS)
if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
rsl = rms_nam_rsll(mynam);
} else
char * src;
char * new_src = NULL;
if (spec_buf == outbuf) {
- new_src = PerlMem_malloc(VMS_MAXRSS);
+ new_src = (char *)PerlMem_malloc(VMS_MAXRSS);
my_strlcpy(new_src, spec_buf, VMS_MAXRSS);
} else {
src = spec_buf;
}
/*}}}*/
/* External entry points */
-char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
-{ return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
-char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
-{ return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
-char *Perl_rmsexpand_utf8
- (pTHX_ const char *spec, char *buf, const char *def,
- unsigned opt, int * fs_utf8, int * dfs_utf8)
-{ return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
-char *Perl_rmsexpand_utf8_ts
- (pTHX_ const char *spec, char *buf, const char *def,
- unsigned opt, int * fs_utf8, int * dfs_utf8)
-{ return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
+char *
+Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
+{
+ return do_rmsexpand(spec, buf, 0, def, opt, NULL, NULL);
+}
+
+char *
+Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
+{
+ return do_rmsexpand(spec, buf, 1, def, opt, NULL, NULL);
+}
+
+char *
+Perl_rmsexpand_utf8(pTHX_ const char *spec, char *buf, const char *def,
+ unsigned opt, int * fs_utf8, int * dfs_utf8)
+{
+ return do_rmsexpand(spec, buf, 0, def, opt, fs_utf8, dfs_utf8);
+}
+
+char *
+Perl_rmsexpand_utf8_ts(pTHX_ const char *spec, char *buf, const char *def,
+ unsigned opt, int * fs_utf8, int * dfs_utf8)
+{
+ return do_rmsexpand(spec, buf, 1, def, opt, fs_utf8, dfs_utf8);
+}
/*
set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
return NULL;
}
- trndir = PerlMem_malloc(VMS_MAXRSS + 1);
+ trndir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if (!strpbrk(dir+1,"/]>:") &&
(!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
* ... do_fileify_dirspec("myroot",buf,1) ...
* does something useful.
*/
- if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
+ if (dirlen >= 2 && strEQ(trndir+dirlen-2,".]")) {
trndir[--dirlen] = '\0';
trndir[dirlen-1] = ']';
}
- if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
+ if (dirlen >= 2 && strEQ(trndir+dirlen-2,".>")) {
trndir[--dirlen] = '\0';
trndir[dirlen-1] = '>';
}
}
}
- vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
+ vmsdir = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
cp1 = strpbrk(trndir,"]:>");
+ if (cp1 && *(cp1+1) == ':') /* DECNet node spec with :: */
+ cp1 = strpbrk(cp1+2,"]:>");
+
if (hasfilename || !cp1) { /* filename present or not VMS */
if (trndir[0] == '.') {
} while ((cp1 = strstr(cp1,"/.")) != NULL);
lastdir = strrchr(trndir,'/');
}
- else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
+ else if (dirlen >= 7 && strEQ(&trndir[dirlen-7],"/000000")) {
char * ret_chr;
/* Ditto for specs that end in an MFD -- let the VMS code
* figure out whether it's a real device or a rooted logical. */
/* We've picked up everything up to the directory file name.
Now just add the type and version, and we're set. */
if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
- strcat(buf,".dir;1");
+ strcat(buf,".dir");
else
- strcat(buf,".DIR;1");
+ strcat(buf,".DIR");
+ if (!decc_filename_unix_no_version)
+ strcat(buf,";1");
PerlMem_free(trndir);
PerlMem_free(vmsdir);
return buf;
rms_setup_nam(savnam);
rms_setup_nam(dirnam);
- esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
+ esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
esal = NULL;
-#if !defined(__VAX) && defined(NAML$C_MAXRSS)
- esal = PerlMem_malloc(VMS_MAXRSS);
+#if defined(NAML$C_MAXRSS)
+ esal = (char *)PerlMem_malloc(VMS_MAXRSS);
if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
#endif
rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
}
else { /* No; just work with potential name */
- if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
+ if (dirfab.fab$l_sts == RMS$_FNF
+ || dirfab.fab$l_sts == RMS$_DNF
+ || dirfab.fab$l_sts == RMS$_FND)
+ dirnam = savnam;
else {
int fab_sts;
fab_sts = dirfab.fab$l_sts;
}
/* Make sure we are using the right buffer */
-#if !defined(__VAX) && defined(NAML$C_MAXRSS)
+#if defined(NAML$C_MAXRSS)
if (esal != NULL) {
my_esa = esal;
my_esa_len = rms_nam_esll(dirnam);
#endif
my_esa = esa;
my_esa_len = rms_nam_esl(dirnam);
-#if !defined(__VAX) && defined(NAML$C_MAXRSS)
+#if defined(NAML$C_MAXRSS)
}
#endif
my_esa[my_esa_len] = '\0';
if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
/* Yep; check version while we're at it, if it's there. */
cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
- if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
+ if (strnNE(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
/* Something other than .DIR[;1]. Bzzt. */
sts = rms_free_search_context(&dirfab);
PerlMem_free(esa);
if (!cp1) cp1 = strstr(my_esa,"]<");
dirlen = cp1 - my_esa;
memcpy(buf, my_esa, dirlen);
- if (!strncmp(cp1+2,"000000]",7)) {
+ if (strBEGINs(cp1+2,"000000]")) {
buf[dirlen-1] = '\0';
/* fix-me Not full ODS-5, just extra dots in directories for now */
cp1 = buf + dirlen - 1;
}
}
else { /* This is a top-level dir. Add the MFD to the path. */
- cp1 = my_esa;
- cp2 = buf;
- while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
- strcpy(cp2,":[000000]");
- cp1 += 2;
- strcpy(cp2+9,cp1);
+ cp1 = strrchr(my_esa, ':');
+ assert(cp1);
+ memmove(buf, my_esa, cp1 - my_esa + 1);
+ memmove(buf + (cp1 - my_esa) + 1, "[000000]", 8);
+ memmove(buf + (cp1 - my_esa) + 9, cp1 + 2, retlen - (cp1 - my_esa + 2));
+ buf[retlen + 7] = '\0'; /* We've inserted '000000]' */
}
}
sts = rms_free_search_context(&dirfab);
/*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
-static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
+static char *
+mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
{
static char __fileify_retbuf[VMS_MAXRSS];
char * fileified, *ret_spec, *ret_buf;
/*}}}*/
/* External entry points */
-char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
-{ return do_fileify_dirspec(dir,buf,0,NULL); }
-char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
-{ return do_fileify_dirspec(dir,buf,1,NULL); }
-char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
-{ return do_fileify_dirspec(dir,buf,0,utf8_fl); }
-char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
-{ return do_fileify_dirspec(dir,buf,1,utf8_fl); }
-
-static char * int_pathify_dirspec_simple(const char * dir, char * buf,
+char *
+Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
+{
+ return do_fileify_dirspec(dir, buf, 0, NULL);
+}
+
+char *
+Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
+{
+ return do_fileify_dirspec(dir, buf, 1, NULL);
+}
+
+char *
+Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
+{
+ return do_fileify_dirspec(dir, buf, 0, utf8_fl);
+}
+
+char *
+Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
+{
+ return do_fileify_dirspec(dir, buf, 1, utf8_fl);
+}
+
+static char *
+int_pathify_dirspec_simple(const char * dir, char * buf,
char * v_spec, int v_len, char * r_spec, int r_len,
char * d_spec, int d_len, char * n_spec, int n_len,
- char * e_spec, int e_len, char * vs_spec, int vs_len) {
+ char * e_spec, int e_len, char * vs_spec, int vs_len)
+{
/* VMS specification - Try to do this the simple way */
if ((v_len + r_len > 0) || (d_len > 0)) {
len += n_len;
if (e_len > 0) {
if (decc_efs_charset) {
- buf[len] = '^';
- len++;
- memcpy(&buf[len], e_spec, e_len);
- len += e_len;
- } else {
- set_vaxc_errno(RMS$_DIR);
- set_errno(ENOTDIR);
+ if (e_len == 4
+ && (toUPPER_A(e_spec[1]) == 'D')
+ && (toUPPER_A(e_spec[2]) == 'I')
+ && (toUPPER_A(e_spec[3]) == 'R')) {
+
+ /* Corner case: directory spec with invalid version.
+ * Valid would have followed is_dir path above.
+ */
+ SETERRNO(ENOTDIR, RMS$_DIR);
+ return NULL;
+ }
+ else {
+ buf[len] = '^';
+ len++;
+ memcpy(&buf[len], e_spec, e_len);
+ len += e_len;
+ }
+ }
+ else {
+ SETERRNO(ENOTDIR, RMS$_DIR);
return NULL;
}
}
/* Internal routine to make sure or convert a directory to be in a */
/* path specification. No utf8 flag because it is not changed or used */
-static char *int_pathify_dirspec(const char *dir, char *buf)
+static char *
+int_pathify_dirspec(const char *dir, char *buf)
{
char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
return NULL;
}
- trndir = PerlMem_malloc(VMS_MAXRSS);
+ trndir = (char *)PerlMem_malloc(VMS_MAXRSS);
if (trndir == NULL)
_ckvmssts_noperl(SS$_INSFMEM);
trnlen = strlen(trndir);
/* Trap simple rooted lnms, and return lnm:[000000] */
- if (!strcmp(trndir+trnlen-2,".]")) {
+ if (strEQ(trndir+trnlen-2,".]")) {
my_strlcpy(buf, dir, VMS_MAXRSS);
strcat(buf, ":[000000]");
PerlMem_free(trndir);
/* Simple way did not work, which means that a logical name */
/* was present for the directory specification. */
/* Need to use an rmsexpand variant to decode it completely */
- exp_spec = PerlMem_malloc(VMS_MAXRSS);
+ exp_spec = (char *)PerlMem_malloc(VMS_MAXRSS);
if (exp_spec == NULL)
_ckvmssts_noperl(SS$_INSFMEM);
return ret_spec;
} else {
- /* Unix specification, Could be trivial conversion */
- STRLEN dir_len;
- dir_len = strlen(trndir);
-
- /* If the extended file character set is in effect */
- /* then pathify is simple */
-
- if (!decc_efs_charset) {
- /* Have to deal with trailing '.dir' or extra '.' */
- /* that should not be there in legacy mode, but is */
-
- char * lastdot;
- char * lastslash;
- int is_dir;
-
- lastslash = strrchr(trndir, '/');
- if (lastslash == NULL)
- lastslash = trndir;
- else
- lastslash++;
+ /* Unix specification, Could be trivial conversion, */
+ /* but have to deal with trailing '.dir' or extra '.' */
- lastdot = NULL;
+ char * lastdot;
+ char * lastslash;
+ int is_dir;
+ STRLEN dir_len = strlen(trndir);
- /* '..' or '.' are valid directory components */
- is_dir = 0;
- if (lastslash[0] == '.') {
- if (lastslash[1] == '\0') {
- is_dir = 1;
- } else if (lastslash[1] == '.') {
- if (lastslash[2] == '\0') {
+ lastslash = strrchr(trndir, '/');
+ if (lastslash == NULL)
+ lastslash = trndir;
+ else
+ lastslash++;
+
+ lastdot = NULL;
+
+ /* '..' or '.' are valid directory components */
+ is_dir = 0;
+ if (lastslash[0] == '.') {
+ if (lastslash[1] == '\0') {
+ is_dir = 1;
+ } else if (lastslash[1] == '.') {
+ if (lastslash[2] == '\0') {
+ is_dir = 1;
+ } else {
+ /* And finally allow '...' */
+ if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
is_dir = 1;
- } else {
- /* And finally allow '...' */
- if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
- is_dir = 1;
- }
}
}
}
+ }
- if (!is_dir) {
- lastdot = strrchr(lastslash, '.');
- }
- if (lastdot != NULL) {
- STRLEN e_len;
-
- /* '.dir' is discarded, and any other '.' is invalid */
- e_len = strlen(lastdot);
-
- is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
+ if (!is_dir) {
+ lastdot = strrchr(lastslash, '.');
+ }
+ if (lastdot != NULL) {
+ STRLEN e_len;
+ /* '.dir' is discarded, and any other '.' is invalid */
+ e_len = strlen(lastdot);
- if (is_dir) {
- dir_len = dir_len - 4;
+ is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
- }
+ if (is_dir) {
+ dir_len = dir_len - 4;
}
}
}
/*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
-static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
+static char *
+mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
{
static char __pathify_retbuf[VMS_MAXRSS];
char * pathified, *ret_spec, *ret_buf;
/* External entry points */
-char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
-{ return do_pathify_dirspec(dir,buf,0,NULL); }
-char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
-{ return do_pathify_dirspec(dir,buf,1,NULL); }
-char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
-{ return do_pathify_dirspec(dir,buf,0,utf8_fl); }
-char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
-{ return do_pathify_dirspec(dir,buf,1,utf8_fl); }
+char *
+Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
+{
+ return do_pathify_dirspec(dir, buf, 0, NULL);
+}
+
+char *
+Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
+{
+ return do_pathify_dirspec(dir, buf, 1, NULL);
+}
+
+char *
+Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
+{
+ return do_pathify_dirspec(dir, buf, 0, utf8_fl);
+}
+
+char *
+Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
+{
+ return do_pathify_dirspec(dir, buf, 1, utf8_fl);
+}
/* Internal tounixspec routine that does not use a thread context */
/*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
-static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
+static char *
+int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
{
char *dirend, *cp1, *cp3, *tmp;
const char *cp2;
int dirlen;
unsigned short int trnlnm_iter_count;
- int cmp_rslt;
+ int cmp_rslt, outchars_added;
if (utf8_fl != NULL)
*utf8_fl = 0;
* glob passes filenames with trailing '\n' and expects this preserved.
*/
if (decc_posix_compliant_pathnames) {
- if (strncmp(spec, "\"^UP^", 5) == 0) {
+ if (! strBEGINs(spec, "\"^UP^")) {
char * uspec;
char *tunix;
int tunix_len;
int nl_flag;
- tunix = PerlMem_malloc(VMS_MAXRSS);
+ tunix = (char *)PerlMem_malloc(VMS_MAXRSS);
if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
tunix_len = my_strlcpy(tunix, spec, VMS_MAXRSS);
nl_flag = 0;
}
}
}
- /* This is already UNIX or at least nothing VMS understands */
- if (cmp_rslt) {
- my_strlcpy(rslt, spec, VMS_MAXRSS);
- if (vms_debug_fileify) {
- fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
+
+ cp1 = rslt;
+ cp2 = spec;
+
+ /* This is already UNIX or at least nothing VMS understands,
+ * so all we can reasonably do is unescape extended chars.
+ */
+ if (cmp_rslt) {
+ while (*cp2) {
+ cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
+ cp1 += outchars_added;
+ }
+ *cp1 = '\0';
+ if (vms_debug_fileify) {
+ fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
}
return rslt;
}
- cp1 = rslt;
- cp2 = spec;
dirend = strrchr(spec,']');
if (dirend == NULL) dirend = strrchr(spec,'>');
if (dirend == NULL) dirend = strchr(spec,':');
if (dirend == NULL) {
- strcpy(rslt,spec);
+ while (*cp2) {
+ cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
+ cp1 += outchars_added;
+ }
+ *cp1 = '\0';
if (vms_debug_fileify) {
fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
}
/* Also handle special case "SYS$SCRATCH:" */
cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
- tmp = PerlMem_malloc(VMS_MAXRSS);
+ tmp = (char *)PerlMem_malloc(VMS_MAXRSS);
if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if (cmp_rslt == 0) {
int islnm;
else { /* the VMS spec begins with directories */
cp2++;
if (*cp2 == ']' || *cp2 == '>') {
- *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
- PerlMem_free(tmp);
- return rslt;
+ *(cp1++) = '.';
+ *(cp1++) = '/';
}
else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
*(cp1++) = '/';
}
if ((*cp2 == '^')) {
- /* EFS file escape, pass the next character as is */
- /* Fix me: HEX encoding for Unicode not implemented */
- cp2++;
+ cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
+ cp1 += outchars_added;
}
else if ( *cp2 == '.') {
if (*(cp2+1) == '.' && *(cp2+2) == '.') {
PerlMem_free(tmp);
for (; cp2 <= dirend; cp2++) {
if ((*cp2 == '^')) {
- /* EFS file escape, pass the next character as is */
- /* Fix me: HEX encoding for Unicode not implemented */
- *(cp1++) = *(++cp2);
- /* An escaped dot stays as is -- don't convert to slash */
- if (*cp2 == '.') cp2++;
+ /* EFS file escape -- unescape it. */
+ cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added) - 1;
+ cp1 += outchars_added;
}
- if (*cp2 == ':') {
+ else if (*cp2 == ':') {
*(cp1++) = '/';
if (*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
}
if (*(cp2+1) == ']' || *(cp2+1) == '>') {
while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
*(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
- if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
+ if (memEQs(cp2,7,"[000000") && (*(cp2+7) == ']' ||
*(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
}
else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
}
/* Translate the rest of the filename. */
while (*cp2) {
- int dot_seen;
- dot_seen = 0;
+ int dot_seen = 0;
switch(*cp2) {
/* Fixme - for compatibility with the CRTL we should be removing */
/* spaces from the file specifications, but this may show that */
*(cp1++) = '?';
break;
case '^':
- /* Fix me hex expansions not implemented */
- cp2++; /* '^.' --> '.' and other. */
- if (*cp2) {
- if (*cp2 == '_') {
- cp2++;
- *(cp1++) = ' ';
- } else {
- *(cp1++) = *(cp2++);
- }
- }
+ cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
+ cp1 += outchars_added;
break;
case ';':
if (decc_filename_unix_no_version) {
* VMS device root or concealed root.
*/
{
- int ulen;
- char * zeros;
+ int ulen;
+ char * zeros;
ulen = strlen(rslt);
/*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
-static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
+static char *
+mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
{
static char __tounixspec_retbuf[VMS_MAXRSS];
char * unixspec, *ret_spec, *ret_buf;
} /* end of do_tounixspec() */
/*}}}*/
/* External entry points */
-char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
- { return do_tounixspec(spec,buf,0, NULL); }
-char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
- { return do_tounixspec(spec,buf,1, NULL); }
-char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
- { return do_tounixspec(spec,buf,0, utf8_fl); }
-char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
- { return do_tounixspec(spec,buf,1, utf8_fl); }
+char *
+Perl_tounixspec(pTHX_ const char *spec, char *buf)
+{
+ return do_tounixspec(spec, buf, 0, NULL);
+}
-#if __CRTL_VER >= 70200000 && !defined(__VAX)
+char *
+Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
+{
+ return do_tounixspec(spec,buf,1, NULL);
+}
+
+char *
+Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
+{
+ return do_tounixspec(spec,buf,0, utf8_fl);
+}
+
+char *
+Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
+{
+ return do_tounixspec(spec,buf,1, utf8_fl);
+}
/*
This procedure is used to identify if a path is based in either
It is used only internally by posix_to_vmsspec_hardway().
*/
-static int posix_root_to_vms
- (char *vmspath, int vmspath_len,
- const char *unixpath,
- const int * utf8_fl)
-{
-int sts;
-struct FAB myfab = cc$rms_fab;
-rms_setup_nam(mynam);
-struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
-struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
-char * esa, * esal, * rsa, * rsal;
-int dir_flag;
-int unixlen;
-
- dir_flag = 0;
- vmspath[0] = '\0';
- unixlen = strlen(unixpath);
- if (unixlen == 0) {
- return RMS$_FNF;
- }
+static int
+posix_root_to_vms(char *vmspath, int vmspath_len,
+ const char *unixpath, const int * utf8_fl)
+{
+ int sts;
+ struct FAB myfab = cc$rms_fab;
+ rms_setup_nam(mynam);
+ struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
+ struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
+ char * esa, * esal, * rsa, * rsal;
+ int dir_flag;
+ int unixlen;
+
+ dir_flag = 0;
+ vmspath[0] = '\0';
+ unixlen = strlen(unixpath);
+ if (unixlen == 0) {
+ return RMS$_FNF;
+ }
#if __CRTL_VER >= 80200000
/* If not a posix spec already, convert it */
if (decc_posix_compliant_pathnames) {
- if (strncmp(unixpath,"\"^UP^",5) != 0) {
+ if (! strBEGINs(unixpath,"\"^UP^")) {
sprintf(vmspath,"\"^UP^%s\"",unixpath);
}
else {
else
#endif
{
- int path_len;
- int i,j;
+ int path_len;
+ int i,j;
/* Check to see if this is under the POSIX root */
if (decc_disable_posix_root) {
vmspath[vmspath_len] = 0;
if (unixpath[unixlen - 1] == '/')
dir_flag = 1;
- esal = PerlMem_malloc(VMS_MAXRSS);
+ esal = (char *)PerlMem_malloc(VMS_MAXRSS);
if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
+ esa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- rsal = PerlMem_malloc(VMS_MAXRSS);
+ rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
+ rsa = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
rms_bind_fab_nam(myfab, mynam);
/* on any failure, returned the POSIX ^UP^ filespec */
if (!(sts & 1)) {
/* This can happen if user does not have permission to read directories */
- if (strncmp(unixpath,"\"^UP^",5) != 0)
+ if (! strBEGINs(unixpath,"\"^UP^"))
sprintf(vmspath,"\"^UP^%s\"",unixpath);
else
my_strlcpy(vmspath, unixpath, vmspath_len + 1);
*/
static int
-slash_dev_special_to_vms
- (const char * unixptr,
- char * vmspath,
- int vmspath_len)
+slash_dev_special_to_vms(const char *unixptr, char *vmspath, int vmspath_len)
{
-char * nextslash;
-int len;
-int cmp;
+ char * nextslash;
+ int len;
unixptr += 4;
nextslash = strchr(unixptr, '/');
len = strlen(unixptr);
if (nextslash != NULL)
len = nextslash - unixptr;
- cmp = strncmp("null", unixptr, 5);
- if (cmp == 0) {
+ if (strEQ(unixptr, "null")) {
if (vmspath_len >= 6) {
strcpy(vmspath, "_NLA0:");
return SS$_NORMAL;
through with out interpretation instead of being escaped.
*/
-static int posix_to_vmsspec_hardway
- (char *vmspath, int vmspath_len,
- const char *unixpath,
- int dir_flag,
- int * utf8_fl) {
-
-char *esa;
-const char *unixptr;
-const char *unixend;
-char *vmsptr;
-const char *lastslash;
-const char *lastdot;
-int unixlen;
-int vmslen;
-int dir_start;
-int dir_dot;
-int quoted;
-char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
-int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
+static int
+posix_to_vmsspec_hardway(char *vmspath, int vmspath_len, const char *unixpath,
+ int dir_flag, int * utf8_fl)
+{
+
+ char *esa;
+ const char *unixptr;
+ const char *unixend;
+ char *vmsptr;
+ const char *lastslash;
+ const char *lastdot;
+ int unixlen;
+ int vmslen;
+ int dir_start;
+ int dir_dot;
+ int quoted;
+ char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
+ int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
if (utf8_fl != NULL)
*utf8_fl = 0;
quoted = 0;
/* This could have a "^UP^ on the front */
- if (strncmp(unixptr,"\"^UP^",5) == 0) {
+ if (strBEGINs(unixptr,"\"^UP^")) {
quoted = 1;
unixptr+= 5;
unixlen-= 5;
/* Find the next slash */
nextslash = strchr(unixptr,'/');
- esa = PerlMem_malloc(vmspath_len);
+ esa = (char *)PerlMem_malloc(vmspath_len);
if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- trn = PerlMem_malloc(VMS_MAXRSS);
+ trn = (char *)PerlMem_malloc(VMS_MAXRSS);
if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if (nextslash != NULL) {
&vs_len);
while (sts == 0) {
- int cmp;
/* A logical name must be a directory or the full
specification. It is only a full specification if
/* This should not be there, but nothing is perfect */
if (r_len > 9) {
- cmp = strcmp(&r_spec[1], "000000.");
- if (cmp == 0) {
+ if (strEQ(&r_spec[1], "000000.")) {
r_spec += 7;
r_spec[7] = '[';
r_len -= 7;
d_spec[0] = '[';
d_spec[d_len - 1] = ']';
if (d_len > 9) {
- cmp = strcmp(&d_spec[1], "000000.");
- if (cmp == 0) {
+ if (strEQ(&d_spec[1], "000000.")) {
d_spec += 7;
d_spec[7] = '[';
d_len -= 7;
* here that are a VMS device name or concealed logical name instead.
* So to make things work, this procedure must be tolerant.
*/
- esa = PerlMem_malloc(vmspath_len);
+ esa = (char *)PerlMem_malloc(vmspath_len);
if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
sts = SS$_NORMAL;
nextslash = strchr(&unixptr[1],'/');
seg_len = 0;
if (nextslash != NULL) {
- int cmp;
seg_len = nextslash - &unixptr[1];
my_strlcpy(vmspath, unixptr, seg_len + 2);
- cmp = 1;
- if (seg_len == 3) {
- cmp = strncmp(vmspath, "dev", 4);
- if (cmp == 0) {
+ if (memEQs(vmspath, seg_len, "dev")) {
sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
if (sts == SS$_NORMAL)
return SS$_NORMAL;
- }
}
sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
}
dir_start = 1;
dir_dot = 1;
if (vmslen > 7) {
- int cmp;
rptr = vmsptr - 7;
- cmp = strcmp(rptr,"000000.");
- if (cmp == 0) {
+ if (strEQ(rptr,"000000.")) {
vmslen -= 7;
vmsptr -= 7;
vmsptr[1] = '\0';
}
else {
int trnend;
- int cmp;
/* now we have foo:bar or foo:[000000]bar to decide from */
islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
if (!islnm && !decc_posix_compliant_pathnames) {
-
- cmp = strncmp("bin", vmspath, 4);
- if (cmp == 0) {
+ if (strEQ(vmspath, "bin")) {
/* bin => SYS$SYSTEM: */
islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
}
else {
/* tmp => SYS$SCRATCH: */
- cmp = strncmp("tmp", vmspath, 4);
- if (cmp == 0) {
+ if (strEQ(vmspath, "tmp")) {
islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
}
}
} /* End of relative/absolute path handling */
while ((unixptr <= unixend) && (vmslen < vmspath_len)){
- int dash_flag;
- int in_cnt;
- int out_cnt;
+ int dash_flag;
+ int in_cnt;
+ int out_cnt;
dash_flag = 0;
vmsptr += out_cnt;
unixptr += in_cnt;
break;
- case '~':
case ';':
case '\\':
case '?':
*vmsptr = '\0';
return SS$_NORMAL;
}
-#endif
-
- /* Eventual routine to convert a UTF-8 specification to VTF-7. */
-static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
-{
-char * result;
-int utf8_flag;
-
- /* If a UTF8 flag is being passed, honor it */
- utf8_flag = 0;
- if (utf8_fl != NULL) {
- utf8_flag = *utf8_fl;
- *utf8_fl = 0;
- }
-
- if (utf8_flag) {
- /* If there is a possibility of UTF8, then if any UTF8 characters
- are present, then they must be converted to VTF-7
- */
- result = strcpy(rslt, path); /* FIX-ME */
- }
- else
- result = strcpy(rslt, path);
-
- return result;
-}
-
+/* A convenience macro for copying dots in filenames and escaping
+ * them when they haven't already been escaped, with guards to
+ * avoid checking before the start of the buffer or advancing
+ * beyond the end of it (allowing room for the NUL terminator).
+ */
+#define VMSEFS_DOT_WITH_ESCAPE(vmsefsdot,vmsefsbuf,vmsefsbufsiz) STMT_START { \
+ if ( ((vmsefsdot) > (vmsefsbuf) && *((vmsefsdot) - 1) != '^' \
+ || ((vmsefsdot) == (vmsefsbuf))) \
+ && (vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 3 \
+ ) { \
+ *((vmsefsdot)++) = '^'; \
+ } \
+ if ((vmsefsdot) < (vmsefsbuf) + (vmsefsbufsiz) - 2) \
+ *((vmsefsdot)++) = '.'; \
+} STMT_END
/*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
-static char *int_tovmsspec
- (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
+static char *
+int_tovmsspec(const char *path, char *rslt, int dir_flag, int * utf8_flag)
+{
char *dirend;
char *lastdot;
- register char *cp1;
+ char *cp1;
const char *cp2;
unsigned long int infront = 0, hasdir = 1;
int rslt_len;
/* Posix specifications are now a native VMS format */
/*--------------------------------------------------*/
-#if __CRTL_VER >= 80200000 && !defined(__VAX)
+#if __CRTL_VER >= 80200000
if (decc_posix_compliant_pathnames) {
- if (strncmp(path,"\"^UP^",5) == 0) {
+ if (strBEGINs(path,"\"^UP^")) {
posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
return rslt;
}
dirend = strrchr(path,'/');
if (dirend == NULL) {
- char *macro_start;
- int has_macro;
-
- /* If we get here with no UNIX directory delimiters, then this is
- not a complete file specification, either garbage a UNIX glob
- specification that can not be converted to a VMS wildcard, or
- it a UNIX shell macro. MakeMaker wants shell macros passed
- through AS-IS,
-
- utf8 flag setting needs to be preserved.
+ /* If we get here with no Unix directory delimiters, then this is an
+ * ambiguous file specification, such as a Unix glob specification, a
+ * shell or make macro, or a filespec that would be valid except for
+ * unescaped extended characters. The safest thing if it's a macro
+ * is to pass it through as-is.
*/
- hasdir = 0;
-
- has_macro = 0;
- macro_start = strchr(path,'$');
- if (macro_start != NULL) {
- if (macro_start[1] == '(') {
- has_macro = 1;
- }
- }
- if ((decc_efs_charset == 0) || (has_macro)) {
+ if (strstr(path, "$(")) {
my_strlcpy(rslt, path, VMS_MAXRSS);
if (vms_debug_fileify) {
fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
}
return rslt;
}
+ hasdir = 0;
}
-
- if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
+ else if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
if (!*(dirend+2)) dirend +=2;
if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
- if (decc_efs_charset == 0) {
- if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
- }
+ if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
}
cp1 = rslt;
}
while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
*cp1 = '\0';
- trndev = PerlMem_malloc(VMS_MAXRSS);
+ trndev = (char *)PerlMem_malloc(VMS_MAXRSS);
if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
/* DECC special handling */
if (!islnm) {
- if (strcmp(rslt,"bin") == 0) {
+ if (strEQ(rslt,"bin")) {
strcpy(rslt,"sys$system");
cp1 = rslt + 10;
*cp1 = 0;
islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
}
- else if (strcmp(rslt,"tmp") == 0) {
+ else if (strEQ(rslt,"tmp")) {
strcpy(rslt,"sys$scratch");
cp1 = rslt + 11;
*cp1 = 0;
while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
}
- else if (strcmp(rslt,"dev") == 0) {
- if (strncmp(cp2,"/null", 5) == 0) {
+ else if (strEQ(rslt,"dev")) {
+ if (strBEGINs(cp2,"/null")) {
if ((cp2[5] == 0) || (cp2[5] == '/')) {
strcpy(rslt,"NLA0");
cp1 = rslt + 4;
}
PerlMem_free(trndev);
}
- else {
+ else if (hasdir) {
*(cp1++) = '[';
if (*cp2 == '.') {
if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
for (; cp2 < dirend; cp2++) {
if (*cp2 == '/') {
if (*(cp2-1) == '/') continue;
- if (*(cp1-1) != '.') *(cp1++) = '.';
+ if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.';
infront = 0;
}
else if (!infront && *cp2 == '.') {
if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
- if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
- else if (*(cp1-2) == '[') *(cp1-1) = '-';
+ if (cp1 > rslt && (*(cp1-1) == '-' || *(cp1-1) == '[')) *(cp1++) = '-'; /* handle "../" */
+ else if (cp1 > rslt + 1 && *(cp1-2) == '[') *(cp1-1) = '-';
else {
*(cp1++) = '-';
}
}
else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
(*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
- if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
+ if (cp1 > rslt && *(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
*(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
if (!*(cp2+3)) {
*(cp1++) = '.'; /* Simulate trailing '/' */
else cp2 += 3; /* Trailing '/' was there, so skip it, too */
}
else {
- if (decc_efs_charset == 0)
+ if (decc_efs_charset == 0) {
+ if (cp1 > rslt && *(cp1-1) == '^')
+ cp1--; /* remove the escape, if any */
*(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
+ }
else {
- *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
- *(cp1++) = '.';
+ VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
}
}
}
else {
- if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
+ if (!infront && cp1 > rslt && *(cp1-1) == '-') *(cp1++) = '.';
if (*cp2 == '.') {
- if (decc_efs_charset == 0)
+ if (decc_efs_charset == 0) {
+ if (cp1 > rslt && *(cp1-1) == '^')
+ cp1--; /* remove the escape, if any */
*(cp1++) = '_';
+ }
else {
- *(cp1++) = '^';
- *(cp1++) = '.';
+ VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
}
}
- else *(cp1++) = *cp2;
+ else {
+ int out_cnt;
+ cp2 += copy_expand_unix_filename_escape(cp1, cp2, &out_cnt, utf8_flag);
+ cp2--; /* we're in a loop that will increment this */
+ cp1 += out_cnt;
+ }
infront = 1;
}
}
- if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
+ if (cp1 > rslt && *(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
if (hasdir) *(cp1++) = ']';
- if (*cp2) cp2++; /* check in case we ended with trailing '..' */
- /* fixme for ODS5 */
+ if (*cp2 && *cp2 == '/') cp2++; /* check in case we ended with trailing '/' */
no_type_seen = 0;
if (cp2 > lastdot)
no_type_seen = 1;
else
*(cp1++) = '?';
cp2++;
+ break;
case ' ':
- *(cp1)++ = '^';
+ if (cp2 >= path && (cp2 == path || *(cp2-1) != '^')) /* not previously escaped */
+ *(cp1)++ = '^';
*(cp1)++ = '_';
cp2++;
break;
case '.':
if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
decc_readdir_dropdotnotype) {
- *(cp1)++ = '^';
- *(cp1)++ = '.';
+ VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
cp2++;
/* trailing dot ==> '^..' on VMS */
/* Test through */
*(cp1++) = *(cp2++);
- if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
+ if (isALPHA_L1(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
*(cp1++) = *(cp2++);
- while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
+ while (isALPHA_L1(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
*(cp1++) = *(cp2++);
}
if (*cp2 == ')') {
}
break;
case '\"':
- case '~':
case '`':
case '!':
case '#':
/* Don't escape again if following character is
* already something we escape.
*/
- if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
+ if (strchr("\"`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
*(cp1++) = *(cp2++);
break;
}
case '|':
case '<':
case '>':
- *(cp1++) = '^';
+ if (cp2 >= path && *(cp2-1) != '^') /* not previously escaped */
+ *(cp1++) = '^';
*(cp1++) = *(cp2++);
break;
case ';':
- /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
- * which is wrong. UNIX notation should be ".dir." unless
- * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
- * changing this behavior could break more things at this time.
- * efs character set effectively does not allow "." to be a version
- * delimiter as a further complication about changing this.
- */
- if (decc_filename_unix_report != 0) {
+ /* If it doesn't look like the beginning of a version number,
+ * or we've been promised there are no version numbers, then
+ * escape it.
+ */
+ if (decc_filename_unix_no_version) {
*(cp1++) = '^';
}
+ else {
+ size_t all_nums = strspn(cp2+1, "0123456789");
+ if (all_nums > 5 || *(cp2 + all_nums + 1) != '\0')
+ *(cp1++) = '^';
+ }
*(cp1++) = *(cp2++);
break;
default:
/*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
-static char *mp_do_tovmsspec
- (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
- static char __tovmsspec_retbuf[VMS_MAXRSS];
+static char *
+mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag)
+{
+ static char __tovmsspec_retbuf[VMS_MAXRSS];
char * vmsspec, *ret_spec, *ret_buf;
vmsspec = NULL;
} /* end of mp_do_tovmsspec() */
/*}}}*/
/* External entry points */
-char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
- { return do_tovmsspec(path,buf,0,NULL); }
-char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
- { return do_tovmsspec(path,buf,1,NULL); }
-char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
- { return do_tovmsspec(path,buf,0,utf8_fl); }
-char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
- { return do_tovmsspec(path,buf,1,utf8_fl); }
+char *
+Perl_tovmsspec(pTHX_ const char *path, char *buf)
+{
+ return do_tovmsspec(path, buf, 0, NULL);
+}
+
+char *
+Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
+{
+ return do_tovmsspec(path, buf, 1, NULL);
+}
+
+char *
+Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
+{
+ return do_tovmsspec(path, buf, 0, utf8_fl);
+}
+
+char *
+Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
+{
+ return do_tovmsspec(path, buf, 1, utf8_fl);
+}
/*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
/* Internal routine for use with out an explicit context present */
-static char * int_tovmspath(const char *path, char *buf, int * utf8_fl) {
-
+static char *
+int_tovmspath(const char *path, char *buf, int * utf8_fl)
+{
char * ret_spec, *pathified;
if (path == NULL)
return NULL;
- pathified = PerlMem_malloc(VMS_MAXRSS);
+ pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
if (pathified == NULL)
_ckvmssts_noperl(SS$_INSFMEM);
}
/*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
-static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
+static char *
+mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl)
+{
static char __tovmspath_retbuf[VMS_MAXRSS];
int vmslen;
char *pathified, *vmsified, *cp;
if (path == NULL) return NULL;
- pathified = PerlMem_malloc(VMS_MAXRSS);
+ pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
if (int_pathify_dirspec(path, pathified) == NULL) {
PerlMem_free(pathified);
} /* end of do_tovmspath() */
/*}}}*/
/* External entry points */
-char *Perl_tovmspath(pTHX_ const char *path, char *buf)
- { return do_tovmspath(path,buf,0, NULL); }
-char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
- { return do_tovmspath(path,buf,1, NULL); }
-char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
- { return do_tovmspath(path,buf,0,utf8_fl); }
-char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
- { return do_tovmspath(path,buf,1,utf8_fl); }
+char *
+Perl_tovmspath(pTHX_ const char *path, char *buf)
+{
+ return do_tovmspath(path, buf, 0, NULL);
+}
+
+char *
+Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
+{
+ return do_tovmspath(path, buf, 1, NULL);
+}
+
+char *
+Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
+{
+ return do_tovmspath(path, buf, 0, utf8_fl);
+}
+
+char *
+Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
+{
+ return do_tovmspath(path, buf, 1, utf8_fl);
+}
/*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
-static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
+static char *
+mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl)
+{
static char __tounixpath_retbuf[VMS_MAXRSS];
int unixlen;
char *pathified, *unixified, *cp;
if (path == NULL) return NULL;
- pathified = PerlMem_malloc(VMS_MAXRSS);
+ pathified = (char *)PerlMem_malloc(VMS_MAXRSS);
if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
if (int_pathify_dirspec(path, pathified) == NULL) {
PerlMem_free(pathified);
} /* end of do_tounixpath() */
/*}}}*/
/* External entry points */
-char *Perl_tounixpath(pTHX_ const char *path, char *buf)
- { return do_tounixpath(path,buf,0,NULL); }
-char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
- { return do_tounixpath(path,buf,1,NULL); }
-char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
- { return do_tounixpath(path,buf,0,utf8_fl); }
-char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
- { return do_tounixpath(path,buf,1,utf8_fl); }
+char *
+Perl_tounixpath(pTHX_ const char *path, char *buf)
+{
+ return do_tounixpath(path, buf, 0, NULL);
+}
+
+char *
+Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
+{
+ return do_tounixpath(path, buf, 1, NULL);
+}
+
+char *
+Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
+{
+ return do_tounixpath(path, buf, 0, utf8_fl);
+}
+
+char *
+Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
+{
+ return do_tounixpath(path, buf, 1, utf8_fl);
+}
/*
* @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark AT infocomm DOT com)
* subprocess, so we satisfy that desire.
*/
ap = argv[argc-1];
- if (0 == strcmp("&", ap))
+ if (strEQ(ap, "&"))
exit(background_process(aTHX_ --argc, argv));
if (*ap && '&' == ap[strlen(ap)-1])
{
*/
for (j = 0; j < argc; ++j)
{
- if (0 == strcmp("<", argv[j]))
+ if (strEQ(argv[j], "<"))
{
if (j+1 >= argc)
{
in = 1 + ap;
continue;
}
- if (0 == strcmp(">", ap))
+ if (strEQ(ap, ">"))
{
if (j+1 >= argc)
{
}
continue;
}
- if (0 == strcmp("|", argv[j]))
+ if (strEQ(argv[j], "|"))
{
if (j+1 >= argc)
{
fprintf(stderr,"Can't open output file %s as stdout",out);
exit(vaxc$errno);
}
- if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
+ if (out != NULL) vmssetuserlnm("SYS$OUTPUT", out);
if (err != NULL) {
- if (strcmp(err,"&1") == 0) {
+ if (strEQ(err, "&1")) {
dup2(fileno(stdout), fileno(stderr));
- Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
+ vmssetuserlnm("SYS$ERROR", "SYS$OUTPUT");
} else {
FILE *tmperr;
if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
{
exit(vaxc$errno);
}
- Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
+ vmssetuserlnm("SYS$ERROR", err);
}
}
#ifdef ARGPROC_DEBUG
} /* end of getredirection() */
/*}}}*/
-static void add_item(struct list_item **head,
- struct list_item **tail,
- char *value,
- int *count)
+static void
+add_item(struct list_item **head, struct list_item **tail, char *value, int *count)
{
if (*head == 0)
{
++(*count);
}
-static void mp_expand_wild_cards(pTHX_ char *item,
- struct list_item **head,
- struct list_item **tail,
- int *count)
-{
-int expcount = 0;
-unsigned long int context = 0;
-int isunix = 0;
-int item_len = 0;
-char *had_version;
-char *had_device;
-int had_directory;
-char *devdir,*cp;
-char *vmsspec;
-$DESCRIPTOR(filespec, "");
-$DESCRIPTOR(defaultspec, "SYS$DISK:[]");
-$DESCRIPTOR(resultspec, "");
-unsigned long int lff_flags = 0;
-int sts;
-int rms_sts;
+static void
+mp_expand_wild_cards(pTHX_ char *item, struct list_item **head,
+ struct list_item **tail, int *count)
+{
+ int expcount = 0;
+ unsigned long int context = 0;
+ int isunix = 0;
+ int item_len = 0;
+ char *had_version;
+ char *had_device;
+ int had_directory;
+ char *devdir,*cp;
+ char *vmsspec;
+ $DESCRIPTOR(filespec, "");
+ $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
+ $DESCRIPTOR(resultspec, "");
+ unsigned long int lff_flags = 0;
+ int sts;
+ int rms_sts;
#ifdef VMS_LONGNAME_SUPPORT
lff_flags = LIB$M_FIL_LONG_NAMES;
#endif
for (cp = item; *cp; cp++) {
- if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
+ if (*cp == '*' || *cp == '%' || isSPACE_L1(*cp)) break;
if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
}
- if (!*cp || isspace(*cp))
+ if (!*cp || isSPACE_L1(*cp))
{
add_item(head, tail, item, count);
return;
resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
resultspec.dsc$b_class = DSC$K_CLASS_D;
resultspec.dsc$a_pointer = NULL;
- vmsspec = PerlMem_malloc(VMS_MAXRSS);
+ vmsspec = (char *)PerlMem_malloc(VMS_MAXRSS);
if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if ((isunix = (int) strchr(item,'/')) != (int) NULL)
filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
char *string;
char *c;
- string = PerlMem_malloc(resultspec.dsc$w_length+1);
+ string = (char *)PerlMem_malloc(resultspec.dsc$w_length+1);
if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
my_strlcpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length+1);
if (NULL == had_version)
if (!decc_efs_case_preserve) {
for (c = string; *c; ++c)
if (isupper(*c))
- *c = tolower(*c);
+ *c = toLOWER_L1(*c);
}
if (isunix) trim_unixpath(string,item,1);
add_item(head, tail, string, count);
_ckvmssts_noperl(lib$find_file_end(&context));
}
-static int child_st[2];/* Event Flag set when child process completes */
-
-static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
-
-static unsigned long int exit_handler(void)
-{
-short iosb[4];
-
- if (0 == child_st[0])
- {
-#ifdef ARGPROC_DEBUG
- PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
-#endif
- fflush(stdout); /* Have to flush pipe for binary data to */
- /* terminate properly -- <tp@mccall.com> */
- sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
- sys$dassgn(child_chan);
- fclose(stdout);
- sys$synch(0, child_st);
- }
- return(1);
-}
-
-static void sig_child(int chan)
-{
-#ifdef ARGPROC_DEBUG
- PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
-#endif
- if (child_st[0] == 0)
- child_st[0] = 1;
-}
-
-static struct exit_control_block exit_block =
- {
- 0,
- exit_handler,
- 1,
- &exit_block.exit_status,
- 0
- };
static void
pipe_and_fork(pTHX_ char **cmargv)
j = l = 0;
p = subcmd;
q = cmargv[0];
- ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
- && toupper(*(q+2)) == 'R' && !*(q+3);
+ ismcr = q && toUPPER_A(*q) == 'M' && toUPPER_A(*(q+1)) == 'C'
+ && toUPPER_A(*(q+2)) == 'R' && !*(q+3);
while (q && l < MAX_DCL_LINE_LENGTH) {
if (!*q) {
}
}
-static int background_process(pTHX_ int argc, char **argv)
-{
-char command[MAX_DCL_SYMBOL + 1] = "$";
-$DESCRIPTOR(value, "");
-static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
-static $DESCRIPTOR(null, "NLA0:");
-static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
-char pidstring[80];
-$DESCRIPTOR(pidstr, "");
-int pid;
-unsigned long int flags = 17, one = 1, retsts;
-int len;
+static int
+background_process(pTHX_ int argc, char **argv)
+{
+ char command[MAX_DCL_SYMBOL + 1] = "$";
+ $DESCRIPTOR(value, "");
+ static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
+ static $DESCRIPTOR(null, "NLA0:");
+ static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
+ char pidstring[80];
+ $DESCRIPTOR(pidstr, "");
+ int pid;
+ unsigned long int flags = 17, one = 1, retsts;
+ int len;
len = my_strlcat(command, argv[0], sizeof(command));
while (--argc && (len < MAX_DCL_SYMBOL))
Perl_csighandler_init();
#endif
-#if __CRTL_VER >= 70300000 && !defined(__VAX)
/* This was moved from the pre-image init handler because on threaded */
/* Perl it was always returning 0 for the default value. */
status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
}
}
}
-#endif
_ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
_ckvmssts_noperl(iosb[0]);
_ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
_ckvmssts_noperl(iosb[0]);
}
- mask = jpilist[1].bufadr;
+ mask = (unsigned long int *)jpilist[1].bufadr;
/* Check attribute flags for each identifier (2nd longword); protected
* subsystem identifiers trigger tainting.
*/
* directory. This needs to be removed.
*/
if (decc_filename_unix_report) {
- char * zeros;
- int ulen;
+ char * zeros;
+ int ulen;
ulen = strlen(argvp[0][0]);
if (ulen > 7) {
zeros = strstr(argvp[0][0], "/000000/");
newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
newargv[0] = oldargv[0];
- newargv[1] = PerlMem_malloc(3 * sizeof(char));
+ newargv[1] = (char *)PerlMem_malloc(3 * sizeof(char));
if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
strcpy(newargv[1], "-T");
Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
}
tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- tabvec[tabidx]->dsc$w_length = 0;
+ tabvec[tabidx]->dsc$w_length = len;
tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
- tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
- tabvec[tabidx]->dsc$a_pointer = NULL;
- _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
+ tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_S;
+ tabvec[tabidx]->dsc$a_pointer = (char *)PerlMem_malloc(len + 1);
+ if (tabvec[tabidx]->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
+ my_strlcpy(tabvec[tabidx]->dsc$a_pointer, eqv, len + 1);
}
if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
int
Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
{
- char *unixified, *unixwild,
- *template, *base, *end, *cp1, *cp2;
- register int tmplen, reslen = 0, dirs = 0;
+ char *unixified, *unixwild, *tplate, *base, *end, *cp1, *cp2;
+ int tmplen, reslen = 0, dirs = 0;
if (!wildspec || !fspec) return 0;
- unixwild = PerlMem_malloc(VMS_MAXRSS);
+ unixwild = (char *)PerlMem_malloc(VMS_MAXRSS);
if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- template = unixwild;
+ tplate = unixwild;
if (strpbrk(wildspec,"]>:") != NULL) {
if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
PerlMem_free(unixwild);
else {
my_strlcpy(unixwild, wildspec, VMS_MAXRSS);
}
- unixified = PerlMem_malloc(VMS_MAXRSS);
+ unixified = (char *)PerlMem_malloc(VMS_MAXRSS);
if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if (strpbrk(fspec,"]>:") != NULL) {
if (int_tounixspec(fspec, unixified, NULL) == NULL) {
else base = fspec;
/* No prefix or absolute path on wildcard, so nothing to remove */
- if (!*template || *template == '/') {
+ if (!*tplate || *tplate == '/') {
PerlMem_free(unixwild);
if (base == fspec) {
PerlMem_free(unixified);
}
for (end = base; *end; end++) ; /* Find end of resultant filespec */
- if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
- for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
+ if ((cp1 = strstr(tplate,".../")) == NULL) { /* No ...; just count elts */
+ for (cp1 = tplate; *cp1; cp1++) if (*cp1 == '/') dirs++;
for (cp1 = end ;cp1 >= base; cp1--)
if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
{ cp1++; break; }
while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
totells = ells;
for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
- tpl = PerlMem_malloc(VMS_MAXRSS);
+ tpl = (char *)PerlMem_malloc(VMS_MAXRSS);
if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- if (ellipsis == template && opts & 1) {
+ if (ellipsis == tplate && opts & 1) {
/* Template begins with an ellipsis. Since we can't tell how many
* directory names at the front of the resultant to keep for an
* arbitrary starting point, we arbitrarily choose the current
}
if (!decc_efs_case_preserve) {
for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
- if (_tolower(*cp1) != _tolower(*cp2)) break;
+ if (toLOWER_L1(*cp1) != toLOWER_L1(*cp2)) break;
}
segdirs = dirs - totells; /* Min # of dirs we must have left */
for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
for (front = end ; front >= base; front--)
if (*front == '/' && !dirs--) { front++; break; }
}
- lcres = PerlMem_malloc(VMS_MAXRSS);
+ lcres = (char *)PerlMem_malloc(VMS_MAXRSS);
if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
+ for (cp1=tplate,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
cp1++,cp2++) {
if (!decc_efs_case_preserve) {
- *cp2 = _tolower(*cp1); /* Make lc copy for match */
+ *cp2 = toLOWER_L1(*cp1); /* Make lc copy for match */
}
else {
*cp2 = *cp1;
lcfront = lcres + (front - base);
/* Now skip over each ellipsis and try to match the path in front of it. */
while (ells--) {
- for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
+ for (cp1 = ellipsis - 2; cp1 >= tplate; cp1--)
if (*(cp1) == '.' && *(cp1+1) == '.' &&
*(cp1+2) == '.' && *(cp1+3) == '/' ) break;
- if (cp1 < template) break; /* template started with an ellipsis */
+ if (cp1 < tplate) break; /* template started with an ellipsis */
if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
ellipsis = cp1; continue;
}
if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
else {
if (!decc_efs_case_preserve) {
- *cp2 = _tolower(*cp1); /* else lowercase for match */
+ *cp2 = toLOWER_L1(*cp1); /* else lowercase for match */
}
else {
*cp2 = *cp1; /* else preserve case for match */
}
if (!decc_efs_case_preserve) {
for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
- if (_tolower(*cp1) != _tolower(*cp2)) break;
+ if (toLOWER_L1(*cp1) != toLOWER_L1(*cp2)) break;
}
segdirs = dirs - totells; /* Min # of dirs we must have left */
for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
/* Check access before stat; otherwise stat does not
* accurately report whether it's a directory.
*/
- if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
+ if (!strstr(dir, "::") /* sys$check_access doesn't do remotes */
+ && !cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
/* cando_by_name has already set errno */
Safefree(dir);
return NULL;
dd->context = 0;
dd->count = 0;
dd->flags = 0;
- /* By saying we always want the result of readdir() in unix format, we
- * are really saying we want all the escapes removed. Otherwise the caller,
- * having no way to know whether it's already in VMS format, might send it
- * through tovmsspec again, thus double escaping.
+ /* By saying we want the result of readdir() in unix format, we are really
+ * saying we want all the escapes removed, translating characters that
+ * must be escaped in a VMS-format name to their unescaped form, which is
+ * presumably allowed in a Unix-format name.
*/
- dd->flags = PERL_VMSDIR_M_UNIXSPECS;
+ dd->flags = decc_filename_unix_report ? PERL_VMSDIR_M_UNIXSPECS : 0;
dd->pat.dsc$a_pointer = dd->pattern;
dd->pat.dsc$w_length = strlen(dd->pattern);
dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
tmpsts = lib$find_file
(&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
- if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
+ if (dd->context == 0)
+ tmpsts = RMS$_NMF; /* None left. (should be set, but make sure) */
+
if (!(tmpsts & 1)) {
- set_vaxc_errno(tmpsts);
switch (tmpsts) {
+ case RMS$_NMF:
+ break; /* no more files considered success */
case RMS$_PRV:
- set_errno(EACCES); break;
+ SETERRNO(EACCES, tmpsts); break;
case RMS$_DEV:
- set_errno(ENODEV); break;
+ SETERRNO(ENODEV, tmpsts); break;
case RMS$_DIR:
- set_errno(ENOTDIR); break;
+ SETERRNO(ENOTDIR, tmpsts); break;
case RMS$_FNF: case RMS$_DNF:
- set_errno(ENOENT); break;
+ SETERRNO(ENOENT, tmpsts); break;
default:
- set_errno(EVMSERR);
+ SETERRNO(EVMSERR, tmpsts);
}
Safefree(buff);
return NULL;
/* Force the buffer to end with a NUL, and downcase name to match C convention. */
buff[res.dsc$w_length] = '\0';
p = buff + res.dsc$w_length;
- while (--p >= buff) if (!isspace(*p)) break;
+ while (--p >= buff) if (!isSPACE_L1(*p)) break;
*p = '\0';
if (!decc_efs_case_preserve) {
- for (p = buff; *p; p++) *p = _tolower(*p);
+ for (p = buff; *p; p++) *p = toLOWER_L1(*p);
}
/* Skip any directory component and just copy the name. */
/* In Unix report mode, remove the ".dir;1" from the name */
/* if it is a real directory. */
- if (decc_filename_unix_report || decc_efs_charset) {
+ if (decc_filename_unix_report && decc_efs_charset) {
if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
Stat_t statbuf;
int ret_sts;
memcpy(dd->entry.d_name, n_spec, n_len + e_len);
dd->entry.d_name[n_len + e_len] = '\0';
- dd->entry.d_namlen = strlen(dd->entry.d_name);
+ dd->entry.d_namlen = n_len + e_len;
/* Convert the filename to UNIX format if needed */
if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
{
char *junk, *tmps = NULL;
- register size_t cmdlen = 0;
+ size_t cmdlen = 0;
size_t rlen;
- register SV **idx;
+ SV **idx;
STRLEN n_a;
idx = mark;
struct dsc$descriptor_s *vmscmd;
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 *s, *rest, *cp, *wordbreak;
char * cmd;
int cmdlen;
- register int isdcl;
+ int isdcl;
- vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
+ vmscmd = (struct dsc$descriptor_s *)PerlMem_malloc(sizeof(struct dsc$descriptor_s));
if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
/* vmsspec is a DCL command buffer, not just a filename */
- vmsspec = PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
+ vmsspec = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
if (vmsspec == NULL)
_ckvmssts_noperl(SS$_INSFMEM);
- resspec = PerlMem_malloc(VMS_MAXRSS);
+ resspec = (char *)PerlMem_malloc(VMS_MAXRSS);
if (resspec == NULL)
_ckvmssts_noperl(SS$_INSFMEM);
/* Make a copy for modification */
cmdlen = strlen(incmd);
- cmd = PerlMem_malloc(cmdlen+1);
+ cmd = (char *)PerlMem_malloc(cmdlen+1);
if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
my_strlcpy(cmd, incmd, cmdlen + 1);
image_name[0] = 0;
s = cmd;
- while (*s && isspace(*s)) s++;
+ while (*s && isSPACE_L1(*s)) s++;
if (*s == '@' || *s == '$') {
vmsspec[0] = *s; rest = s + 1;
- for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
+ for (cp = &vmsspec[1]; *rest && isSPACE_L1(*rest); rest++,cp++) *cp = *rest;
}
else { cp = vmsspec; rest = s; }
+
+ /* If the first word is quoted, then we need to unquote it and
+ * escape spaces within it. We'll expand into the resspec buffer,
+ * then copy back into the cmd buffer, expanding the latter if
+ * necessary.
+ */
+ if (*rest == '"') {
+ char *cp2;
+ char *r = rest;
+ bool in_quote = 0;
+ int clen = cmdlen;
+ int soff = s - cmd;
+
+ for (cp2 = resspec;
+ *rest && cp2 - resspec < (VMS_MAXRSS - 1);
+ rest++) {
+
+ if (*rest == ' ') { /* Escape ' ' to '^_'. */
+ *cp2 = '^';
+ *(++cp2) = '_';
+ cp2++;
+ clen++;
+ }
+ else if (*rest == '"') {
+ clen--;
+ if (in_quote) { /* Must be closing quote. */
+ rest++;
+ break;
+ }
+ in_quote = 1;
+ }
+ else {
+ *cp2 = *rest;
+ cp2++;
+ }
+ }
+ *cp2 = '\0';
+
+ /* Expand the command buffer if necessary. */
+ if (clen > cmdlen) {
+ cmd = (char *)PerlMem_realloc(cmd, clen);
+ if (cmd == NULL)
+ _ckvmssts_noperl(SS$_INSFMEM);
+ /* Where we are may have changed, so recompute offsets */
+ r = cmd + (r - s - soff);
+ rest = cmd + (rest - s - soff);
+ s = cmd + soff;
+ }
+
+ /* Shift the non-verb portion of the command (if any) up or
+ * down as necessary.
+ */
+ if (*rest)
+ memmove(rest + clen - cmdlen, rest, s - soff + cmdlen - rest);
+
+ /* Copy the unquoted and escaped command verb into place. */
+ memcpy(r, resspec, cp2 - resspec);
+ cmd[clen] = '\0';
+ cmdlen = clen;
+ rest = r; /* Rewind for subsequent operations. */
+ }
+
if (*rest == '.' || *rest == '/') {
char *cp2;
for (cp2 = resspec;
- *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
+ *rest && !isSPACE_L1(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
rest++, cp2++) *cp2 = *rest;
*cp2 = '\0';
if (int_tovmsspec(resspec, cp, 0, NULL)) {
isdcl = 1;
if (suggest_quote) *suggest_quote = 1;
} else {
- register char *filespec = strpbrk(s,":<[.;");
+ char *filespec = strpbrk(s,":<[.;");
rest = wordbreak = strpbrk(s," \"\t/");
if (!wordbreak) wordbreak = s + strlen(s);
if (*s == '$') check_img = 0;
if (retsts & 1) {
FILE *fp;
s = resspec;
- while (*s && !isspace(*s)) s++;
+ while (*s && !isSPACE_L1(*s)) s++;
*s = '\0';
/* check that it's really not DCL with no file extension */
if (fp) {
char b[256] = {0,0,0,0};
read(fileno(fp), b, 256);
- isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
+ isdcl = isPRINT_L1(b[0]) && isPRINT_L1(b[1]) && isPRINT_L1(b[2]) && isPRINT_L1(b[3]);
if (isdcl) {
int shebang_len;
shebang_len = 2;
#ifdef ALTERNATE_SHEBANG
else {
- shebang_len = strlen(ALTERNATE_SHEBANG);
- if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
+ if (strEQ(b, ALTERNATE_SHEBANG)) {
char * perlstr;
perlstr = strstr("perl",b);
if (perlstr == NULL)
shebang_len = 0;
+ else
+ shebang_len = strlen(ALTERNATE_SHEBANG);
}
else
shebang_len = 0;
i = shebang_len;
/* Image is following after white space */
/*--------------------------------------*/
- while (isprint(b[i]) && isspace(b[i]))
+ while (isPRINT_L1(b[i]) && isSPACE_L1(b[i]))
i++;
j = 0;
- while (isprint(b[i]) && !isspace(b[i])) {
+ while (isPRINT_L1(b[i]) && !isSPACE_L1(b[i])) {
tmpspec[j++] = b[i++];
if (j >= NAM$C_MAXRSS)
break;
/* There may be some default parameters to the image */
/*---------------------------------------------------*/
j = 0;
- while (isprint(b[i])) {
+ while (isPRINT_L1(b[i])) {
image_argv[j++] = b[i++];
if (j >= NAM$C_MAXRSS)
break;
}
- while ((j > 0) && !isprint(image_argv[j-1]))
+ while ((j > 0) && !isPRINT_L1(image_argv[j-1]))
j--;
image_argv[j] = 0;
}
if (cando_by_name(S_IXUSR,0,resspec)) {
- vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
+ vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH);
if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if (!isdcl) {
my_strlcpy(vmscmd->dsc$a_pointer,"$ MCR ", MAX_DCL_LINE_LENGTH);
my_strlcat(vmscmd->dsc$a_pointer, resspec, MAX_DCL_LINE_LENGTH);
else {
rest = cmd;
- while (*rest && isspace(*rest)) rest++;
+ while (*rest && isSPACE_L1(*rest)) rest++;
}
if (image_argv[0] != 0) {
/* It's either a DCL command or we couldn't find a suitable image */
vmscmd->dsc$w_length = strlen(cmd);
- vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
+ vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(vmscmd->dsc$w_length + 1);
my_strlcpy(vmscmd->dsc$a_pointer, cmd, vmscmd->dsc$w_length + 1);
PerlMem_free(cmd);
bool
Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
{
-bool exec_sts;
-char * cmd;
+ bool exec_sts;
+ char * cmd;
- if (sp > mark) {
- if (vfork_called) { /* this follows a vfork - act Unixish */
- vfork_called--;
- if (vfork_called < 0) {
- Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
- vfork_called = 0;
- }
- else return do_aexec(really,mark,sp);
+ if (vfork_called) { /* this follows a vfork - act Unixish */
+ vfork_called--;
+ if (vfork_called < 0) {
+ Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
+ vfork_called = 0;
}
+ else return do_aexec(really,mark,sp);
+ }
/* no vfork - act VMSish */
+ if (sp > mark) {
cmd = setup_argstr(aTHX_ really,mark,sp);
exec_sts = vms_do_exec(cmd);
Safefree(cmd); /* Clean up from setup_argstr() */
int
Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
{
-unsigned long int sts;
-char * cmd;
-int flags = 0;
+ unsigned long int sts;
+ char * cmd;
+ int flags = 0;
if (sp > mark) {
fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
if (fp != NULL)
my_pclose(fp);
- /* sts will be the pid in the nowait case */
+ /* sts will be the pid in the nowait case, so leave a
+ * hint saying not to do any bit shifting to it.
+ */
+ if (flags & CLI$M_NOWAIT)
+ PL_statusvalue = -1;
}
return sts;
} /* end of do_spawn2() */
* likely to be opened by a name.
*/
/*{{{ FILE *my_fdopen(int fd, const char *mode)*/
-FILE *my_fdopen(int fd, const char *mode)
+FILE *
+my_fdopen(int fd, const char *mode)
{
FILE *fp = fdopen(fd, mode);
* via freopen(). >> Todo
*/
/*{{{ int my_fclose(FILE *fp)*/
-int my_fclose(FILE *fp) {
+int
+my_fclose(FILE *fp) {
if (fp) {
unsigned int fd = fileno(fp);
unsigned int fdoff = fd / sizeof(unsigned int);
int
my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
{
- register char *cp, *end, *cpd;
+ char *cp, *end, *cpd;
char *data;
- register unsigned int fd = fileno(dest);
- register unsigned int fdoff = fd / sizeof(unsigned int);
+ unsigned int fd = fileno(dest);
+ unsigned int fdoff = fd / sizeof(unsigned int);
int retval;
int bufsize = itmsz * nitm + 1;
}
/* Convert this to Unix format */
- vms_name = PerlMem_malloc(VMS_MAXRSS);
+ vms_name = (char *)PerlMem_malloc(VMS_MAXRSS);
my_strlcpy(vms_name, retname, VMS_MAXRSS);
retname = int_tounixspec(vms_name, buf, NULL);
PerlMem_free(vms_name);
/*
* This routine does most of the work extracting the user information.
*/
-static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
+static int
+fillpasswd (pTHX_ const char *name, struct passwd *pwd)
{
static struct {
unsigned char length;
* Get information for a named user.
*/
/*{{{struct passwd *getpwnam(char *name)*/
-struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
+struct passwd *
+Perl_my_getpwnam(pTHX_ const char *name)
{
struct dsc$descriptor_s name_desc;
union uicdef uic;
* Called by my_getpwent with uid=-1 to list all users.
*/
/*{{{struct passwd *my_getpwuid(Uid_t uid)*/
-struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
+struct passwd *
+Perl_my_getpwuid(pTHX_ Uid_t uid)
{
const $DESCRIPTOR(name_desc,__pw_namecache);
unsigned short lname;
* Get information for next user.
*/
/*{{{struct passwd *my_getpwent()*/
-struct passwd *Perl_my_getpwent(pTHX)
+struct passwd *
+Perl_my_getpwent(pTHX)
{
return (my_getpwuid((unsigned int) -1));
}
* Finish searching rights database for users.
*/
/*{{{void my_endpwent()*/
-void Perl_my_endpwent(pTHX)
+void
+Perl_my_endpwent(pTHX)
{
if (contxt) {
_ckvmssts(sys$finish_rdb(&contxt));
*/
/*{{{time_t my_time(time_t *timep)*/
-time_t Perl_my_time(pTHX_ time_t *timep)
+time_t
+Perl_my_time(pTHX_ time_t *timep)
{
time_t when;
struct tm *tm_p;
struct tm *
Perl_my_localtime(pTHX_ const time_t *timep)
{
- time_t when, whenutc;
- struct tm *rsltmp;
- int dst, offset;
+ time_t when;
if (timep == NULL) {
set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
# endif
/* CRTL localtime() wants UTC as input, does tz correction itself */
return localtime(&when);
-
- /* CRTL localtime() wants local time as input, so does no tz correction */
- rsltmp = localtime(&when);
- if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
- return rsltmp;
-
} /* end of my_localtime() */
/*}}}*/
/* my_utime - update modification/access time of a file
*
- * VMS 7.3 and later implementation
* Only the UTC translation is home-grown. The rest is handled by the
* CRTL utime(), which will take into account the relevant feature
* logicals and ODS-5 volume characteristics for true access times.
*
- * pre VMS 7.3 implementation:
- * The calling sequence is identical to POSIX utime(), but under
- * VMS with ODS-2, only the modification time is changed; ODS-2 does
- * not maintain access times. Restrictions differ from the POSIX
- * definition in that the time can be changed as long as the
- * caller has permission to execute the necessary IO$_MODIFY $QIO;
- * no separate checks are made to insure that the caller is the
- * owner of the file or has special privs enabled.
- * Code here is based on Joe Meadows' FILE utility.
- *
*/
/* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
/*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
-int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
+int
+Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
{
-#if __CRTL_VER >= 70300000
struct utimbuf utc_utimes, *utc_utimesp;
if (utimes != NULL) {
return utime(file, utc_utimesp);
-#else /* __CRTL_VER < 70300000 */
-
- register int i;
- int sts;
- long int bintime[2], len = 2, lowbit, unixtime,
- secscale = 10000000; /* seconds --> 100 ns intervals */
- unsigned long int chan, iosb[2], retsts;
- char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
- struct FAB myfab = cc$rms_fab;
- struct NAM mynam = cc$rms_nam;
-#if defined (__DECC) && defined (__VAX)
- /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
- * at least through VMS V6.1, which causes a type-conversion warning.
- */
-# pragma message save
-# pragma message disable cvtdiftypes
-#endif
- struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
- struct fibdef myfib;
-#if defined (__DECC) && defined (__VAX)
- /* This should be right after the declaration of myatr, but due
- * to a bug in VAX DEC C, this takes effect a statement early.
- */
-# pragma message restore
-#endif
- /* cast ok for read only parameter */
- struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
- devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
- fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
-
- if (file == NULL || *file == '\0') {
- SETERRNO(ENOENT, LIB$_INVARG);
- return -1;
- }
-
- /* Convert to VMS format ensuring that it will fit in 255 characters */
- if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
- SETERRNO(ENOENT, LIB$_INVARG);
- return -1;
- }
- if (utimes != NULL) {
- /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
- * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
- * Since time_t is unsigned long int, and lib$emul takes a signed long int
- * as input, we force the sign bit to be clear by shifting unixtime right
- * one bit, then multiplying by an extra factor of 2 in lib$emul().
- */
- lowbit = (utimes->modtime & 1) ? secscale : 0;
- unixtime = (long int) utimes->modtime;
-# ifdef VMSISH_TIME
- /* If input was UTC; convert to local for sys svc */
- if (!VMSISH_TIME) unixtime = _toloc(unixtime);
-# endif
- unixtime >>= 1; secscale <<= 1;
- retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
- if (!(retsts & 1)) {
- SETERRNO(EVMSERR, retsts);
- return -1;
- }
- retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
- if (!(retsts & 1)) {
- SETERRNO(EVMSERR, retsts);
- return -1;
- }
- }
- else {
- /* Just get the current time in VMS format directly */
- retsts = sys$gettim(bintime);
- if (!(retsts & 1)) {
- SETERRNO(EVMSERR, retsts);
- return -1;
- }
- }
-
- myfab.fab$l_fna = vmsspec;
- myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
- myfab.fab$l_nam = &mynam;
- mynam.nam$l_esa = esa;
- mynam.nam$b_ess = (unsigned char) sizeof esa;
- mynam.nam$l_rsa = rsa;
- mynam.nam$b_rss = (unsigned char) sizeof rsa;
- if (decc_efs_case_preserve)
- mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
-
- /* Look for the file to be affected, letting RMS parse the file
- * specification for us as well. I have set errno using only
- * values documented in the utime() man page for VMS POSIX.
- */
- retsts = sys$parse(&myfab,0,0);
- if (!(retsts & 1)) {
- set_vaxc_errno(retsts);
- if (retsts == RMS$_PRV) set_errno(EACCES);
- else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
- else set_errno(EVMSERR);
- return -1;
- }
- retsts = sys$search(&myfab,0,0);
- if (!(retsts & 1)) {
- mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
- myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
- set_vaxc_errno(retsts);
- if (retsts == RMS$_PRV) set_errno(EACCES);
- else if (retsts == RMS$_FNF) set_errno(ENOENT);
- else set_errno(EVMSERR);
- return -1;
- }
-
- devdsc.dsc$w_length = mynam.nam$b_dev;
- /* cast ok for read only parameter */
- devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
-
- retsts = sys$assign(&devdsc,&chan,0,0);
- if (!(retsts & 1)) {
- mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
- myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
- set_vaxc_errno(retsts);
- if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
- else if (retsts == SS$_NOPRIV) set_errno(EACCES);
- else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
- else set_errno(EVMSERR);
- return -1;
- }
-
- fnmdsc.dsc$a_pointer = mynam.nam$l_name;
- fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
-
- memset((void *) &myfib, 0, sizeof myfib);
-#if defined(__DECC) || defined(__DECCXX)
- for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
- for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
- /* This prevents the revision time of the file being reset to the current
- * time as a result of our IO$_MODIFY $QIO. */
- myfib.fib$l_acctl = FIB$M_NORECORD;
-#else
- for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
- for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
- myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
-#endif
- retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
- mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
- myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
- _ckvmssts(sys$dassgn(chan));
- if (retsts & 1) retsts = iosb[0];
- if (!(retsts & 1)) {
- set_vaxc_errno(retsts);
- if (retsts == SS$_NOPRIV) set_errno(EACCES);
- else set_errno(EVMSERR);
- return -1;
- }
-
- return 0;
-
-#endif /* #if __CRTL_VER >= 70300000 */
-
} /* end of my_utime() */
/*}}}*/
* on the first call.
*/
#define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
-static mydev_t encode_dev (pTHX_ const char *dev)
+static mydev_t
+encode_dev (pTHX_ const char *dev)
{
int i;
unsigned long int f;
break;
if (isdigit (*q))
c= (*q) - '0';
- else if (isalpha (toupper (*q)))
+ else if (isALPHA_A(toUPPER_A(*q)))
c= toupper (*q) - 'A' + (char)10;
else
continue; /* Skip '$'s */
is_null_device(const char *name)
{
if (decc_bug_devnull != 0) {
- if (strncmp("/dev/null", name, 9) == 0)
+ if (strBEGINs(name, "/dev/null"))
return 1;
}
/* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
filename, but two consecutive colons indicates a nodename rather
than a device. [pr] */
if (*name == '_') ++name;
- if (tolower(*name++) != 'n') return 0;
- if (tolower(*name++) != 'l') return 0;
- if (tolower(*name) == 'a') ++name;
+ if (toLOWER_L1(*name++) != 'n') return 0;
+ if (toLOWER_L1(*name++) != 'l') return 0;
+ if (toLOWER_L1(*name) == 'a') ++name;
if (*name == '0') ++name;
return (*name++ == ':') && (*name != ':');
}
#define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
static I32
-Perl_cando_by_name_int
- (pTHX_ I32 bit, bool effective, const char *fname, int opts)
+Perl_cando_by_name_int(pTHX_ I32 bit, bool effective, const char *fname, int opts)
{
char usrname[L_cuserid];
struct dsc$descriptor_s usrdsc =
if (!fname || !*fname) return FALSE;
/* Make sure we expand logical names, since sys$check_access doesn't */
- fileified = PerlMem_malloc(VMS_MAXRSS);
+ fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if (!strpbrk(fname,"/]>:")) {
my_strlcpy(fileified, fname, VMS_MAXRSS);
fname = fileified;
}
- vmsname = PerlMem_malloc(VMS_MAXRSS);
+ vmsname = (char *)PerlMem_malloc(VMS_MAXRSS);
if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
/* Don't know if already in VMS format, so make sure */
&usrprodsc.dsc$w_length,&profile_context));
/* allocate space for the profile and get it filled in */
- usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
+ usrprodsc.dsc$a_pointer = (char *)PerlMem_malloc(usrprodsc.dsc$w_length);
if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
_ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
&usrprodsc.dsc$w_length,&profile_context));
}
-/* Do the permissions allow some operation? Assumes PL_statcache already set. */
+/* Do the permissions in *statbufp allow some operation? */
/* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
* subset of the applicable information.
*/
int
Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
{
+ dSAVE_ERRNO; /* fstat may set this even on success */
if (!fstat(fd, &statbufp->crtl_stat)) {
char *cptr;
char *vms_filename;
- vms_filename = PerlMem_malloc(VMS_MAXRSS);
+ vms_filename = (char *)PerlMem_malloc(VMS_MAXRSS);
if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
/* Save name for cando by name in VMS format */
statbufp->st_ctime = _toloc(statbufp->st_ctime);
}
# endif
+ RESTORE_ERRNO;
return 0;
}
return -1;
SAVE_ERRNO;
-#if __CRTL_VER >= 80200000 && !defined(__VAX)
+#if __CRTL_VER >= 80200000
/*
* If we are in POSIX filespec mode, accept the filename as is.
*/
/* In the odd case where we have write but not read access
* to a directory, stat('foo.DIR') works but stat('foo') doesn't.
*/
- fileified = PerlMem_malloc(VMS_MAXRSS);
+ fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
if (fileified == NULL)
_ckvmssts_noperl(SS$_INSFMEM);
if (retval && vms_bug_stat_filename) {
- temp_fspec = PerlMem_malloc(VMS_MAXRSS);
+ temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
if (temp_fspec == NULL)
_ckvmssts_noperl(SS$_INSFMEM);
* format unless * DECC$EFS_CHARSET is in effect, so temporarily
* enable it if it isn't already.
*/
-#if __CRTL_VER >= 70300000 && !defined(__VAX)
if (!decc_efs_charset && (decc_efs_charset_index > 0))
decc$feature_set_value(decc_efs_charset_index, 1, 1);
-#endif
if (lstat_flag == 0)
retval = stat(fspec, &statbufp->crtl_stat);
else
retval = lstat(fspec, &statbufp->crtl_stat);
save_spec = fspec;
-#if __CRTL_VER >= 70300000 && !defined(__VAX)
if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
decc$feature_set_value(decc_efs_charset_index, 1, 0);
efs_hack = 1;
}
-#endif
}
-#if __CRTL_VER >= 80200000 && !defined(__VAX)
+#if __CRTL_VER >= 80200000
} else {
if (lstat_flag == 0)
retval = stat(temp_fspec, &statbufp->crtl_stat);
}
#endif
-#if __CRTL_VER >= 70300000 && !defined(__VAX)
/* As you were... */
if (!decc_efs_charset)
decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
-#endif
if (!retval) {
char *cptr;
if (lstat_flag)
rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
-#if __CRTL_VER >= 70300000 && !defined(__VAX)
/* If we used the efs_hack above, we must also use it here for */
/* perl_cando to work */
if (efs_hack && (decc_efs_charset_index > 0)) {
decc$feature_set_value(decc_efs_charset_index, 1, 1);
}
-#endif
/* If we've got a directory, save a fileified, expanded version of it
* in st_devnam. If not a directory, just an expanded version.
*/
if (S_ISDIR(statbufp->st_mode) && !already_fileified) {
- fileified = PerlMem_malloc(VMS_MAXRSS);
+ fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
if (fileified == NULL)
_ckvmssts_noperl(SS$_INSFMEM);
0,
0);
-#if __CRTL_VER >= 70300000 && !defined(__VAX)
if (efs_hack && (decc_efs_charset_index > 0)) {
decc$feature_set_value(decc_efs_charset, 1, 0);
}
-#endif
/* Fix me: If this is NULL then stat found a file, and we could */
/* not convert the specification to VMS - Should never happen */
/*}}}*/
-/*{{{char *my_getlogin()*/
-/* VMS cuserid == Unix getlogin, except calling sequence */
-char *
-my_getlogin(void)
-{
- static char user[L_cuserid];
- return cuserid(user);
-}
-/*}}}*/
-
-
/* rmscopy - copy a file using VMS RMS routines
*
* Copies contents and attributes of spec_in to spec_out, except owner
struct XABRDT xabrdt;
struct XABSUM xabsum;
- vmsin = PerlMem_malloc(VMS_MAXRSS);
+ vmsin = (char *)PerlMem_malloc(VMS_MAXRSS);
if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- vmsout = PerlMem_malloc(VMS_MAXRSS);
+ vmsout = (char *)PerlMem_malloc(VMS_MAXRSS);
if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
if (!spec_in || !*spec_in || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
!spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
return 0;
}
- esa = PerlMem_malloc(VMS_MAXRSS);
+ esa = (char *)PerlMem_malloc(VMS_MAXRSS);
if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
esal = NULL;
-#if !defined(__VAX) && defined(NAML$C_MAXRSS)
- esal = PerlMem_malloc(VMS_MAXRSS);
+#if defined(NAML$C_MAXRSS)
+ esal = (char *)PerlMem_malloc(VMS_MAXRSS);
if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
#endif
fab_in = cc$rms_fab;
rms_bind_fab_nam(fab_in, nam);
fab_in.fab$l_xab = (void *) &xabdat;
- rsa = PerlMem_malloc(VMS_MAXRSS);
+ rsa = (char *)PerlMem_malloc(VMS_MAXRSS);
if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
rsal = NULL;
-#if !defined(__VAX) && defined(NAML$C_MAXRSS)
- rsal = PerlMem_malloc(VMS_MAXRSS);
+#if defined(NAML$C_MAXRSS)
+ rsal = (char *)PerlMem_malloc(VMS_MAXRSS);
if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
#endif
rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
- esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
+ esa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
+ rsa_out = (char *)PerlMem_malloc(NAM$C_MAXRSS + 1);
if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
esal_out = NULL;
rsal_out = NULL;
-#if !defined(__VAX) && defined(NAML$C_MAXRSS)
- esal_out = PerlMem_malloc(VMS_MAXRSS);
+#if defined(NAML$C_MAXRSS)
+ esal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- rsal_out = PerlMem_malloc(VMS_MAXRSS);
+ rsal_out = (char *)PerlMem_malloc(VMS_MAXRSS);
if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
#endif
rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
if (preserve_dates & 2) {
/* sys$close() will process xabrdt, not xabdat */
xabrdt = cc$rms_xabrdt;
-#ifndef __GNUC__
xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
-#else
- /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
- * is unsigned long[2], while DECC & VAXC use a struct */
- memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
-#endif
fab_out.fab$l_xab = (void *) &xabrdt;
}
- ubf = PerlMem_malloc(32256);
+ ubf = (char *)PerlMem_malloc(32256);
if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
rab_in = cc$rms_rab;
rab_in.rab$l_fab = &fab_in;
dXSARGS;
char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
workbuff[NAM$C_MAXRSS*1 + 1];
- int counter, num_entries;
+ SSize_t counter, num_entries;
/* ODS-5 ups this, but we want to be consistent, so... */
int max_name_len = 39;
AV *in_array = (AV *)SvRV(ST(0));
- num_entries = av_len(in_array);
+ num_entries = av_tindex(in_array);
/* All the names start with PL_. */
strcpy(ultimate_name, "PL_");
last = 0;
dest = workbuff;
for (source = work_name; *source; source++) {
- if (last == toupper(*source)) {
+ if (last == toUPPER_A(*source)) {
continue;
}
*dest++ = *source;
- last = toupper(*source);
+ last = toUPPER_A(*source);
}
my_strlcpy(work_name, workbuff, sizeof(work_name));
}
PerlIO *
-Perl_vms_start_glob
- (pTHX_ SV *tmpglob,
- IO *io)
+Perl_vms_start_glob(pTHX_ SV *tmpglob, IO *io)
{
PerlIO *fp;
struct vs_str_st *rslt;
/* In Unix report mode, remove the ".dir;1" from the name */
/* if it is a real directory */
- if (decc_filename_unix_report || decc_efs_charset) {
+ if (decc_filename_unix_report && decc_efs_charset) {
if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
Stat_t statbuf;
int ret_sts;
}
if (!decc_efs_case_preserve) {
- for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
+ for (cp = rstr; *cp; cp++) *cp = toLOWER_L1(*cp);
}
/* Find File treats a Null extension as return all extensions */
#ifdef HAS_SYMLINK
/*
* A thin wrapper around decc$symlink to make sure we follow the
- * standard and do not create a symlink with a zero-length name.
- *
- * Also in ODS-2 mode, existing tests assume that the link target
- * will be converted to UNIX format.
+ * standard and do not create a symlink with a zero-length name,
+ * and convert the target to Unix format, as the CRTL can't handle
+ * targets in VMS format.
*/
/*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
-int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) {
- if (!link_name || !*link_name) {
- SETERRNO(ENOENT, SS$_NOSUCHFILE);
- return -1;
- }
-
- if (decc_efs_charset) {
- return symlink(contents, link_name);
- } else {
- int sts;
- char * utarget;
-
- /* Unless we are in ODS-5 mode, convert the symlink target to UNIX */
- /* because in order to work, the symlink target must be in UNIX format */
-
- /* As symbolic links can hold things other than files, we will only do */
- /* the conversion in in ODS-2 mode */
-
- utarget = PerlMem_malloc(VMS_MAXRSS + 1);
- if (int_tounixspec(contents, utarget, NULL) == NULL) {
+int
+Perl_my_symlink(pTHX_ const char *contents, const char *link_name)
+{
+ int sts;
+ char * utarget;
- /* This should not fail, as an untranslatable filename */
- /* should be passed through */
- utarget = (char *)contents;
- }
- sts = symlink(utarget, link_name);
- PerlMem_free(utarget);
- return sts;
- }
+ if (!link_name || !*link_name) {
+ SETERRNO(ENOENT, SS$_NOSUCHFILE);
+ return -1;
+ }
+ utarget = (char *)PerlMem_malloc(VMS_MAXRSS + 1);
+ /* An untranslatable filename should be passed through. */
+ (void) int_tounixspec(contents, utarget, NULL);
+ sts = symlink(utarget, link_name);
+ PerlMem_free(utarget);
+ return sts;
}
/*}}}*/
* on OpenVMS.
*/
+#ifdef __cplusplus
+extern "C" {
+#endif
+
/* Hack, use old stat() as fastest way of getting ino_t and device */
int decc$stat(const char *name, void * statbuf);
-#if !defined(__VAX) && __CRTL_VER >= 80200000
+#if __CRTL_VER >= 80200000
int decc$lstat(const char *name, void * statbuf);
#else
#define decc$lstat decc$stat
#endif
+#ifdef __cplusplus
+}
+#endif
+
/* Realpath is fragile. In 8.3 it does not work if the feature
* DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
#pragma message disable MISALGNDMEM
#pragma member_alignment save
#pragma nomember_alignment
-struct statbuf_t {
- char * st_dev;
- unsigned short st_ino[3];
- unsigned short old_st_mode;
- unsigned long padl[30]; /* plenty of room */
-} statbuf;
+ struct statbuf_t {
+ char * st_dev;
+ unsigned short st_ino[3];
+ unsigned short old_st_mode;
+ unsigned long padl[30]; /* plenty of room */
+ } statbuf;
#pragma message restore
#pragma member_alignment restore
* unexpected answers
*/
- fileified = PerlMem_malloc(VMS_MAXRSS);
+ fileified = (char *)PerlMem_malloc(VMS_MAXRSS);
if (fileified == NULL)
_ckvmssts_noperl(SS$_INSFMEM);
- temp_fspec = PerlMem_malloc(VMS_MAXRSS);
+ temp_fspec = (char *)PerlMem_malloc(VMS_MAXRSS);
if (temp_fspec == NULL)
_ckvmssts_noperl(SS$_INSFMEM);
* format unless * DECC$EFS_CHARSET is in effect, so temporarily
* enable it if it isn't already.
*/
-#if __CRTL_VER >= 70300000 && !defined(__VAX)
if (!decc_efs_charset && (decc_efs_charset_index > 0))
decc$feature_set_value(decc_efs_charset_index, 1, 1);
-#endif
ret_spec = int_tovmspath(name, temp_fspec, NULL);
if (lstat_flag == 0) {
sts = decc$stat(name, &statbuf);
} else {
sts = decc$lstat(name, &statbuf);
}
-#if __CRTL_VER >= 70300000 && !defined(__VAX)
if (!decc_efs_charset && (decc_efs_charset_index > 0))
decc$feature_set_value(decc_efs_charset_index, 1, 0);
-#endif
}
/*}}}*/
/* External entry points */
-char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
-{ return do_vms_realpath(filespec, outbuf, utf8_fl); }
+char *
+Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
+{
+ return do_vms_realpath(filespec, outbuf, utf8_fl);
+}
-char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
-{ return do_vms_realname(filespec, outbuf, utf8_fl); }
+char *
+Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
+{
+ return do_vms_realname(filespec, outbuf, utf8_fl);
+}
/* case_tolerant */
/* OpenVMS provides a case sensitive implementation of ODS-5 and this is
* controlled by a process setting.
*/
-int do_vms_case_tolerant(void)
+int
+do_vms_case_tolerant(void)
{
return vms_process_case_tolerant;
}
/*}}}*/
/* External entry points */
-#if __CRTL_VER >= 70301000 && !defined(__VAX)
-int Perl_vms_case_tolerant(void)
-{ return do_vms_case_tolerant(); }
-#else
-int Perl_vms_case_tolerant(void)
-{ return vms_process_case_tolerant; }
-#endif
-
+int
+Perl_vms_case_tolerant(void)
+{
+ return do_vms_case_tolerant();
+}
/* Start of DECC RTL Feature handling */
+static int
+set_feature_default(const char *name, int value)
+{
+ int status;
+ int index;
+ char val_str[10];
+
+ /* If the feature has been explicitly disabled in the environment,
+ * then don't enable it here.
+ */
+ if (value > 0) {
+ status = simple_trnlnm(name, val_str, sizeof(val_str));
+ if (status) {
+ val_str[0] = toUPPER_A(val_str[0]);
+ if (val_str[0] == 'D' || val_str[0] == '0' || val_str[0] == 'F')
+ return 0;
+ }
+ }
+
+ index = decc$feature_get_index(name);
+
+ status = decc$feature_set_value(index, 1, value);
+ if (index == -1 || (status == -1)) {
+ return -1;
+ }
+
+ status = decc$feature_get_value(index, 1);
+ if (status != value) {
+ return -1;
+ }
+
+ /* Various things may check for an environment setting
+ * rather than the feature directly, so set that too.
+ */
+ vmssetuserlnm(name, value ? "ENABLE" : "DISABLE");
+
+ return 0;
+}
+
/* C RTL Feature settings */
-static int set_features
- (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
- int (* cli_routine)(void), /* Not documented */
- void *image_info) /* Not documented */
+#if defined(__DECC) || defined(__DECCXX)
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+extern void
+vmsperl_set_features(void)
{
int status;
int s;
char val_str[10];
-#if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
+#if defined(JPI$_CASE_LOOKUP_PERM)
const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
unsigned long case_perm;
/* Allow an exception to bring Perl into the VMS debugger */
vms_debug_on_exception = 0;
status = simple_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
- val_str[0] = _toupper(val_str[0]);
+ if (status) {
+ val_str[0] = toUPPER_A(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
vms_debug_on_exception = 1;
else
/* Debug unix/vms file translation routines */
vms_debug_fileify = 0;
status = simple_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
- val_str[0] = _toupper(val_str[0]);
+ if (status) {
+ val_str[0] = toUPPER_A(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
vms_debug_fileify = 1;
else
/* enable it so that the impact can be studied. */
vms_bug_stat_filename = 0;
status = simple_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
- val_str[0] = _toupper(val_str[0]);
+ if (status) {
+ val_str[0] = toUPPER_A(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
vms_bug_stat_filename = 1;
else
/* Create VTF-7 filenames from Unicode instead of UTF-8 */
vms_vtf7_filenames = 0;
status = simple_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
- val_str[0] = _toupper(val_str[0]);
+ if (status) {
+ val_str[0] = toUPPER_A(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
vms_vtf7_filenames = 1;
else
/* unlink all versions on unlink() or rename() */
vms_unlink_all_versions = 0;
- status = simple_trnlnm
- ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
- val_str[0] = _toupper(val_str[0]);
+ status = simple_trnlnm("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
+ if (status) {
+ val_str[0] = toUPPER_A(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
vms_unlink_all_versions = 1;
else
vms_unlink_all_versions = 0;
}
- /* Dectect running under GNV Bash or other UNIX like shell */
-#if __CRTL_VER >= 70300000 && !defined(__VAX)
+ /* The path separator in PERL5LIB is '|' unless running under a Unix shell. */
+ PL_perllib_sep = '|';
+
+ /* Detect running under GNV Bash or other UNIX like shell */
gnv_unix_shell = 0;
status = simple_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
+ if (status) {
gnv_unix_shell = 1;
- set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
- set_feature_default("DECC$EFS_CHARSET", 1);
set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
vms_unlink_all_versions = 1;
vms_posix_exit = 1;
+ /* Reverse default ordering of PERL_ENV_TABLES. */
+ defenv[0] = &crtlenvdsc;
+ defenv[1] = &fildevdsc;
+ PL_perllib_sep = ':';
}
-#endif
+ /* Some reasonable defaults that are not CRTL defaults */
+ set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
+ set_feature_default("DECC$ARGV_PARSE_STYLE", 1); /* Requires extended parse. */
+ set_feature_default("DECC$EFS_CHARSET", 1);
/* hacks to see if known bugs are still present for testing */
/* PCP mode requires creating /dev/null special device file */
decc_bug_devnull = 0;
status = simple_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
- val_str[0] = _toupper(val_str[0]);
+ if (status) {
+ val_str[0] = toUPPER_A(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
decc_bug_devnull = 1;
else
decc_bug_devnull = 0;
}
- /* UNIX directory names with no paths are broken in a lot of places */
- decc_dir_barename = 1;
- status = simple_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
- val_str[0] = _toupper(val_str[0]);
- if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
- decc_dir_barename = 1;
- else
- decc_dir_barename = 0;
- }
-
-#if __CRTL_VER >= 70300000 && !defined(__VAX)
s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
if (s >= 0) {
decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
}
#endif
-#else
- status = simple_trnlnm
- ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
- val_str[0] = _toupper(val_str[0]);
- if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
- decc_disable_to_vms_logname_translation = 1;
- }
- }
-
-#ifndef __VAX
- status = simple_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
- val_str[0] = _toupper(val_str[0]);
- if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
- decc_efs_case_preserve = 1;
- }
- }
-#endif
-
- status = simple_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
- val_str[0] = _toupper(val_str[0]);
- if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
- decc_filename_unix_report = 1;
- }
- }
- status = simple_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
- val_str[0] = _toupper(val_str[0]);
- if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
- decc_filename_unix_only = 1;
- decc_filename_unix_report = 1;
- }
- }
- status = simple_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
- val_str[0] = _toupper(val_str[0]);
- if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
- decc_filename_unix_no_version = 1;
- }
- }
- status = simple_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
- val_str[0] = _toupper(val_str[0]);
- if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
- decc_readdir_dropdotnotype = 1;
- }
- }
-#endif
-#if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
+#if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND)
/* Report true case tolerance */
/*----------------------------*/
/* USE POSIX/DCL Exit codes - Recommended, but needs to default to */
/* for strict backward compatibility */
- status = simple_trnlnm
- ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
- val_str[0] = _toupper(val_str[0]);
+ status = simple_trnlnm("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
+ if (status) {
+ val_str[0] = toUPPER_A(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
vms_posix_exit = 1;
else
vms_posix_exit = 0;
}
-
-
- /* CRTL can be initialized past this point, but not before. */
-/* DECC$CRTL_INIT(); */
-
- return SS$_NORMAL;
}
-#ifdef __DECC
-#pragma nostandard
-#pragma extern_model save
-#pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
- const __align (LONGWORD) int spare[8] = {0};
-
-/* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
-#if __DECC_VER >= 60560002
-#pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
-#else
-#pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
-#endif
-#endif /* __DECC */
-
-const long vms_cc_features = (const long)set_features;
-
-/*
-** Force a reference to LIB$INITIALIZE to ensure it
-** exists in the image.
-*/
-#define lib$initialize LIB$INITIALIZE
-int lib$initialize(void);
-#ifdef __DECC
-#pragma extern_model strict_refdef
-#endif
- int lib_init_ref = (int) lib$initialize;
-
-#ifdef __DECC
-#pragma extern_model restore
-#pragma standard
+/* Use 32-bit pointers because that's what the image activator
+ * assumes for the LIB$INITIALZE psect.
+ */
+#if __INITIAL_POINTER_SIZE
+#pragma pointer_size save
+#pragma pointer_size 32
+#endif
+
+/* Create a reference to the LIB$INITIALIZE function. */
+extern void LIB$INITIALIZE(void);
+extern void (*vmsperl_unused_global_1)(void) = LIB$INITIALIZE;
+
+/* Create an array of pointers to the init functions in the special
+ * LIB$INITIALIZE section. In our case, the array only has one entry.
+ */
+#pragma extern_model save
+#pragma extern_model strict_refdef "LIB$INITIALIZE" nopic,gbl,nowrt,noshr,long
+extern void (* const vmsperl_unused_global_2[])() =
+{
+ vmsperl_set_features,
+};
+#pragma extern_model restore
+
+#if __INITIAL_POINTER_SIZE
+#pragma pointer_size restore
+#endif
+
+#ifdef __cplusplus
+}
#endif
+#endif /* defined(__DECC) || defined(__DECCXX) */
/* End of vms.c */
https://perl5.git.perl.org / perl5.git / blobdiff