*
* 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.
*/
/*
/* 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) {
/* 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)
* 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)
}
/*}}}*/
+/* 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' && !strcmp(lnm,"SYS$OUTPUT")) ||
+ (lnm[4] == 'I' && !strcmp(lnm,"SYS$INPUT")) ||
+ (lnm[4] == 'E' && !strcmp(lnm,"SYS$ERROR")) ||
+ (lnm[4] == 'C' && !strcmp(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,
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 ||
+ 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;
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;
if (sys) {
/* Impose security constraints only if tainting */
secure = PL_curinterp ? TAINTING_get : will_taint;
- saverr = errno; savvmserr = vaxc$errno;
}
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;
if (sys) {
/* Impose security constraints only if tainting */
secure = PL_curinterp ? TAINTING_get : will_taint;
- saverr = errno; savvmserr = vaxc$errno;
}
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;
}
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;
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;
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;
+ if (dirlen == 0) {
+ SETERRNO(EINVAL, SS$_BADPARAM);
+ 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--;
#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 */
/*---------------------*/
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;
} 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;
/*}}}*/
#if defined(__VAX) || !defined(NAML$C_MAXRSS)
-static int rms_free_search_context(struct FAB * fab)
+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}},
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);
}
/*}}}*/
/* 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);
+}
/*
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] == '.') {
/* 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_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;
}
}
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)) {
/* 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;
}
/*{{{ 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;
}
}
}
- /* This is already UNIX or at least nothing VMS understands */
+
+ 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) {
- my_strlcpy(rslt, spec, VMS_MAXRSS);
+ 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) {
while (*cp2) {
- if (*cp2 == '^')
- cp2++;
- else
- *(cp1++) = *(cp2++);
+ cp2 += copy_expand_vms_filename_escape(cp1, cp2, &outchars_added);
+ cp1 += outchars_added;
}
*cp1 = '\0';
if (vms_debug_fileify) {
*(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++;
}
}
/* 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);
+}
+
+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);
+}
#if __CRTL_VER >= 70200000 && !defined(__VAX)
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 */
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) {
*/
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;
+ int cmp;
unixptr += 4;
nextslash = strchr(unixptr, '/');
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;
} /* 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;
}
#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
} 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;
char *cp1;
dirend = strrchr(path,'/');
if (dirend == NULL) {
- /* If we get here with no UNIX directory delimiters, then this is
- * not a complete file specification, such as a Unix glob
- * specification, shell macro, make macro, or even a valid VMS
- * filespec but with unescaped extended characters. The safest
- * thing in all these cases is to pass it through as-is.
+ /* 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.
*/
- my_strlcpy(rslt, path, VMS_MAXRSS);
- if (vms_debug_fileify) {
- fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
+ if (strstr(path, "$(")) {
+ my_strlcpy(rslt, path, VMS_MAXRSS);
+ if (vms_debug_fileify) {
+ fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
+ }
+ return rslt;
}
- return rslt;
+ hasdir = 0;
}
else if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
if (!*(dirend+2)) dirend +=2;
}
else *(cp1++) = '.';
}
- else {
- *(cp1++) = *cp2;
- }
for (; cp2 < dirend; cp2++) {
if (*cp2 == '/') {
if (*(cp2-1) == '/') continue;
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 > 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;
*(cp1++) = '?';
cp2++;
case ' ':
- if (cp2 > path && *(cp2-1) != '^') /* not previously escaped */
+ if (cp2 >= path && (cp2 == path || *(cp2-1) != '^')) /* not previously escaped */
*(cp1)++ = '^';
*(cp1)++ = '_';
cp2++;
case '|':
case '<':
case '>':
- if (cp2 > path && *(cp2-1) != '^') /* not previously escaped */
+ 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)
}
/*{{{ 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;
} /* 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;
} /* 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)
} /* 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;
_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)
}
}
-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))
* 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/");
}
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; }
/* 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;
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 */
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);
/*
* 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;
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;
* 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;
#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 =
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;
statbufp->st_ctime = _toloc(statbufp->st_ctime);
}
# endif
+ RESTORE_ERRNO;
return 0;
}
return -1;
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_");
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;
#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
/*}}}*/
/* 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 */
+int
+Perl_vms_case_tolerant(void)
+{
#if __CRTL_VER >= 70301000 && !defined(__VAX)
-int Perl_vms_case_tolerant(void)
-{ return do_vms_case_tolerant(); }
+ return do_vms_case_tolerant();
#else
-int Perl_vms_case_tolerant(void)
-{ return vms_process_case_tolerant; }
+ return vms_process_case_tolerant;
#endif
-
+}
/* Start of DECC RTL Feature handling */
{
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(val_str[0]);
+ if (val_str[0] == 'D' || val_str[0] == '0' || val_str[0] == 'F')
+ return 0;
+ }
+ }
index = decc$feature_get_index(name);
/* 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)) {
+ if (status) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
vms_debug_on_exception = 1;
/* 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)) {
+ if (status) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
vms_debug_fileify = 1;
/* 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)) {
+ if (status) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
vms_bug_stat_filename = 1;
/* 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)) {
+ if (status) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
vms_vtf7_filenames = 1;
/* 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)) {
+ status = simple_trnlnm("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
+ if (status) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
vms_unlink_all_versions = 1;
/* 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_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;
}
/* 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);
#endif
/* 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)) {
+ if (status) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
decc_bug_devnull = 1;
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) {
#else
status = simple_trnlnm
("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
+ if (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)) {
+ if (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)) {
+ if (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)) {
+ if (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;
}
}
status = simple_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
+ if (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)) {
+ if (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;
/* 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)) {
+ status = simple_trnlnm("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
+ if (status) {
val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
vms_posix_exit = 1;
https://perl5.git.perl.org / perl5.git / blobdiff