-/* vms.c
+/* vms.c
*
- * VMS-specific routines for perl5
- * Version: 5.7.0
+ * VMS-specific routines for perl5
*
- * August 2005 Convert VMS status code to UNIX status codes
- * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
- * and Perl_cando by Craig Berry
- * 29-Aug-2000 Charles Lane's piping improvements rolled in
- * 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu
+ * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
+ * 2002, 2003, 2004, 2005, 2006, 2007 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.
*/
+/*
+ * Yet small as was their hunted band
+ * still fell and fearless was each hand,
+ * and strong deeds they wrought yet oft,
+ * and loved the woods, whose ways more soft
+ * them seemed than thralls of that black throne
+ * to live and languish in halls of stone.
+ *
+ * The Lay of Leithian, 135-40
+ */
+
#include <acedef.h>
#include <acldef.h>
#include <armdef.h>
#define do_tovmspath(a,b,c,d) mp_do_tovmspath(aTHX_ a,b,c,d)
#define do_rmsexpand(a,b,c,d,e,f,g) mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
#define do_vms_realpath(a,b,c) mp_do_vms_realpath(aTHX_ a,b,c)
+#define do_vms_realname(a,b,c) mp_do_vms_realname(aTHX_ a,b,c)
#define do_tounixspec(a,b,c,d) mp_do_tounixspec(aTHX_ a,b,c,d)
#define do_tounixpath(a,b,c,d) mp_do_tounixpath(aTHX_ a,b,c,d)
#define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
* for an optional name, and this "error" often shows up as the
* (bogus) exit status for a die() call later on. */
if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
- return success ? eqv : Nullch;
+ return success ? eqv : NULL;
}
} /* end of my_getenv() */
* for an optional name, and this "error" often shows up as the
* (bogus) exit status for a die() call later on. */
if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
- return *len ? buf : Nullch;
+ return *len ? buf : NULL;
}
} /* end of my_getenv_len() */
static int primed = 0;
HV *seenhv = NULL, *envhv;
SV *sv = NULL;
- char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
+ char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
unsigned short int chan;
#ifndef CLI$M_TRUSTED
# define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
case RMS$_WLK: /* Device write locked */
unix_status = EACCES;
break;
+ case RMS$_MKD: /* Failed to mark for delete */
+ unix_status = EPERM;
+ break;
/* case RMS$_NMF: */ /* No more files */
}
}
temp[1] = '\0';
}
- if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
+ if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
if (p == NULL) _ckvmssts(SS$_INSFMEM);
p->next = head_PLOC;
if (SvROK(dirsv)) continue;
dir = SvPVx(dirsv,n_a);
if (strcmp(dir,".") == 0) continue;
- if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
+ if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
continue;
p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
/* most likely spot (ARCHLIB) put first in the list */
#ifdef ARCHLIB_EXP
- if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
+ if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
if (p == NULL) _ckvmssts(SS$_INSFMEM);
p->next = head_PLOC;
/* LIB$FIND_IMAGE_SIGNAL needs a handler */
/*---------------------------------------*/
- VAXC$ESTABLISH((__vms_handler)LIB$SIG_TO_RET);
+ VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
/* Make sure that this is from the Perl debugger */
$DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
$DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
- status = LIB$FIND_IMAGE_SYMBOL
+ status = lib$find_image_symbol
(&filename1_dsc,
&decw_term_port_dsc,
(void *)&decw_term_port,
/* Try again with the other image name */
if (!$VMS_STATUS_SUCCESS(status)) {
- status = LIB$FIND_IMAGE_SYMBOL
+ status = lib$find_image_symbol
(&filename2_dsc,
&decw_term_port_dsc,
(void *)&decw_term_port,
info->in = 0;
info->out = 0;
info->err = 0;
- info->fp = Nullfp;
+ info->fp = NULL;
info->useFILE = 0;
info->waiting = 0;
info->in_done = TRUE;
PerlIO * xterm_fd;
xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
- if (xterm_fd != Nullfp)
+ if (xterm_fd != NULL)
return xterm_fd;
}
if (ckWARN(WARN_PIPE)) {
Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
}
- return Nullfp;
+ return NULL;
}
fgetname(tpipe,tfilebuf+1,1);
}
Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
}
*psts = sts;
- return Nullfp;
+ return NULL;
}
n = sizeof(Info);
_ckvmssts(lib$get_vm(&n, &info));
info->in = 0;
info->out = 0;
info->err = 0;
- info->fp = Nullfp;
+ info->fp = NULL;
info->useFILE = 0;
info->waiting = 0;
info->in_done = TRUE;
n = sizeof(Info);
_ckvmssts(lib$free_vm(&n, &info));
*psts = RMS$_FNF;
- return Nullfp;
+ return NULL;
}
info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
n = sizeof(Info);
_ckvmssts(lib$free_vm(&n, &info));
*psts = RMS$_FNF;
- return Nullfp;
+ return NULL;
}
/* This causes some problems, as it changes the error status */
/* my_pclose(info->fp); */
} else {
- *psts = SS$_NORMAL;
+ *psts = info->pid;
}
return info->fp;
} /* end of safe_popen */
#define rms_set_dna(fab, nam, name, size) \
{ fab.fab$b_dns = size; fab.fab$l_dna = name; }
#define rms_nam_dns(fab, nam) fab.fab$b_dns
-#define rms_set_esa(fab, nam, name, size) \
+#define rms_set_esa(nam, name, size) \
{ nam.nam$b_ess = size; nam.nam$l_esa = name; }
#define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
{ nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
nam.naml$l_long_defname_size = size; \
nam.naml$l_long_defname = name; }
#define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
-#define rms_set_esa(fab, nam, name, size) \
+#define rms_set_esa(nam, name, size) \
{ nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
nam.naml$l_long_expand_alloc = size; \
nam.naml$l_long_expand = name; }
rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
#endif
- status = SYS$ERASE(&myfab, 0, 0);
+ status = sys$erase(&myfab, 0, 0);
return status;
}
/* Unless we are forcing to VMS format, a UNIX input means
* UNIX output, and that requires long names to be used
*/
+#if !defined(__VAX) && defined(NAML$C_MAXRSS)
if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
opts |= PERL_RMSEXPAND_M_LONG;
- else {
+ else
+#endif
isunix = 0;
}
}
- }
rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
rms_bind_fab_nam(myfab, mynam);
#endif
rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
- if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
- rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
- }
- else {
+ /* 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 (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
- rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
-#else
- rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
+ outbufl = PerlMem_malloc(VMS_MAXRSS);
+ if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
#endif
- }
+ rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
#ifdef NAM$M_NO_SHORT_UPCASE
if (decc_efs_case_preserve)
/*------------------------------------*/
if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
if (rms_nam_rsll(mynam)) {
- tbuf = outbuf;
+ tbuf = outbufl;
speclen = rms_nam_rsll(mynam);
}
else {
if (trimver || trimtype) {
if (defspec && *defspec) {
char *defesal = NULL;
- defesal = PerlMem_malloc(VMS_MAXRSS + 1);
- if (defesal != NULL) {
+ char *defesa = NULL;
+ defesa = PerlMem_malloc(VMS_MAXRSS + 1);
+ if (defesa != NULL) {
+#if !defined(__VAX) && defined(NAML$C_MAXRSS)
+ defesal = PerlMem_malloc(VMS_MAXRSS + 1);
+ if (defesal == NULL) _ckvmssts(SS$_INSFMEM);
+#endif
struct FAB deffab = cc$rms_fab;
rms_setup_nam(defnam);
rms_set_fna
(deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
- rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
+ /* RMS needs the esa/esal as a work area if wildcards are involved */
+ rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
rms_clear_nam_nop(defnam);
rms_set_nam_nop(defnam, NAM$M_SYNCHK);
trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
}
}
- PerlMem_free(defesal);
+ if (defesal != NULL)
+ PerlMem_free(defesal);
+ PerlMem_free(defesa);
}
}
if (trimver) {
/* 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 ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
!(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
speclen = rms_nam_namel(mynam) - tbuf;
}
- else {
+ else
+#endif
+ {
if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
!(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
/* Have we been working with an expanded, but not resultant, spec? */
/* Also, convert back to Unix syntax if necessary. */
+ {
+ int rsl;
- if (!rms_nam_rsll(mynam)) {
- if (isunix) {
- if (do_tounixspec(tbuf, outbuf ,0 , fs_utf8) == NULL) {
- if (out) Safefree(out);
- if (esal != NULL)
+#if !defined(__VAX) && defined(NAML$C_MAXRSS)
+ if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
+ rsl = rms_nam_rsll(mynam);
+ } else
+#endif
+ {
+ rsl = rms_nam_rsl(mynam);
+ }
+ if (!rsl) {
+ if (isunix) {
+ if (do_tounixspec(tbuf, outbuf ,0 , fs_utf8) == NULL) {
+ if (out) Safefree(out);
+ if (esal != NULL)
PerlMem_free(esal);
- PerlMem_free(esa);
- if (outbufl != NULL)
+ PerlMem_free(esa);
+ if (outbufl != NULL)
PerlMem_free(outbufl);
- return NULL;
+ return NULL;
+ }
}
+ else strcpy(outbuf, tbuf);
}
- else strcpy(outbuf, tbuf);
- }
- else if (isunix) {
- tmpfspec = PerlMem_malloc(VMS_MAXRSS);
- if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
- if (do_tounixspec(outbuf,tmpfspec,0,fs_utf8) == NULL) {
+ else if (isunix) {
+ tmpfspec = PerlMem_malloc(VMS_MAXRSS);
+ if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
+ if (do_tounixspec(tbuf,tmpfspec,0,fs_utf8) == NULL) {
if (out) Safefree(out);
PerlMem_free(esa);
if (esal != NULL)
if (outbufl != NULL)
PerlMem_free(outbufl);
return NULL;
+ }
+ strcpy(outbuf,tmpfspec);
+ PerlMem_free(tmpfspec);
}
- strcpy(outbuf,tmpfspec);
- PerlMem_free(tmpfspec);
}
-
rms_set_rsal(mynam, NULL, 0, NULL, 0);
sts = rms_free_search_context(&myfab); /* Free search context */
PerlMem_free(esa);
}
else { /* VMS-style directory spec */
- char *esa, term, *cp;
+ char *esa, *esal, term, *cp;
+ char *my_esa;
+ int my_esa_len;
unsigned long int sts, cmplen, haslower = 0;
unsigned int nam_fnb;
char * nam_type;
rms_setup_nam(savnam);
rms_setup_nam(dirnam);
- esa = PerlMem_malloc(VMS_MAXRSS + 1);
+ esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
if (esa == NULL) _ckvmssts(SS$_INSFMEM);
+ esal = NULL;
+#if !defined(__VAX) && defined(NAML$C_MAXRSS)
+ esal = PerlMem_malloc(VMS_MAXRSS);
+ if (esal == NULL) _ckvmssts(SS$_INSFMEM);
+#endif
rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
rms_bind_fab_nam(dirfab, dirnam);
rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
- rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
+ rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
#ifdef NAM$M_NO_SHORT_UPCASE
if (decc_efs_case_preserve)
rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
}
if (!sts) {
PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
PerlMem_free(trndir);
PerlMem_free(vmsdir);
set_errno(EVMSERR);
fab_sts = dirfab.fab$l_sts;
sts = rms_free_search_context(&dirfab);
PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
PerlMem_free(trndir);
PerlMem_free(vmsdir);
set_errno(EVMSERR); set_vaxc_errno(fab_sts);
}
}
}
- esa[rms_nam_esll(dirnam)] = '\0';
+
+ /* Make sure we are using the right buffer */
+ if (esal != NULL) {
+ my_esa = esal;
+ my_esa_len = rms_nam_esll(dirnam);
+ } else {
+ my_esa = esa;
+ my_esa_len = rms_nam_esl(dirnam);
+ }
+ my_esa[my_esa_len] = '\0';
if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
- cp1 = strchr(esa,']');
- if (!cp1) cp1 = strchr(esa,'>');
+ cp1 = strchr(my_esa,']');
+ if (!cp1) cp1 = strchr(my_esa,'>');
if (cp1) { /* Should always be true */
- rms_nam_esll(dirnam) -= cp1 - esa - 1;
- memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
+ my_esa_len -= cp1 - my_esa - 1;
+ memmove(my_esa, cp1 + 1, my_esa_len);
}
}
if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
/* Something other than .DIR[;1]. Bzzt. */
sts = rms_free_search_context(&dirfab);
PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
PerlMem_free(trndir);
PerlMem_free(vmsdir);
set_errno(ENOTDIR);
if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
/* They provided at least the name; we added the type, if necessary, */
if (buf) retspec = buf; /* in sys$parse() */
- else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
+ else if (ts) Newx(retspec, my_esa_len + 1, char);
else retspec = __fileify_retbuf;
- strcpy(retspec,esa);
+ strcpy(retspec,my_esa);
sts = rms_free_search_context(&dirfab);
PerlMem_free(trndir);
PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
PerlMem_free(vmsdir);
return retspec;
}
if ((cp1 = strstr(esa,".][000000]")) != NULL) {
for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
*cp1 = '\0';
- rms_nam_esll(dirnam) -= 9;
+ my_esa_len -= 9;
}
- if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
+ if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
if (cp1 == NULL) { /* should never happen */
sts = rms_free_search_context(&dirfab);
PerlMem_free(trndir);
PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
PerlMem_free(vmsdir);
return NULL;
}
term = *cp1;
*cp1 = '\0';
- retlen = strlen(esa);
- cp1 = strrchr(esa,'.');
+ retlen = strlen(my_esa);
+ cp1 = strrchr(my_esa,'.');
/* ODS-5 directory specifications can have extra "." in them. */
/* Fix-me, can not scan EFS file specifications backwards */
while (cp1 != NULL) {
- if ((cp1-1 == esa) || (*(cp1-1) != '^'))
+ if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
break;
else {
cp1--;
- while ((cp1 > esa) && (*cp1 != '.'))
+ while ((cp1 > my_esa) && (*cp1 != '.'))
cp1--;
}
- if (cp1 == esa)
+ if (cp1 == my_esa)
cp1 = NULL;
}
if (buf) retspec = buf;
else if (ts) Newx(retspec,retlen+7,char);
else retspec = __fileify_retbuf;
- strcpy(retspec,esa);
+ strcpy(retspec,my_esa);
}
else {
if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
sts = rms_free_search_context(&dirfab);
PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
PerlMem_free(trndir);
PerlMem_free(vmsdir);
set_errno(EVMSERR);
set_vaxc_errno(dirfab.fab$l_sts);
return NULL;
}
- retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
+
+ /* This changes the length of the string of course */
+ if (esal != NULL) {
+ my_esa_len = rms_nam_esll(dirnam);
+ } else {
+ my_esa_len = rms_nam_esl(dirnam);
+ }
+
+ retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
if (buf) retspec = buf;
else if (ts) Newx(retspec,retlen+16,char);
else retspec = __fileify_retbuf;
- cp1 = strstr(esa,"][");
- if (!cp1) cp1 = strstr(esa,"]<");
- dirlen = cp1 - esa;
- memcpy(retspec,esa,dirlen);
+ cp1 = strstr(my_esa,"][");
+ if (!cp1) cp1 = strstr(my_esa,"]<");
+ dirlen = cp1 - my_esa;
+ memcpy(retspec,my_esa,dirlen);
if (!strncmp(cp1+2,"000000]",7)) {
retspec[dirlen-1] = '\0';
/* fix-me Not full ODS-5, just extra dots in directories for now */
if (buf) retspec = buf;
else if (ts) Newx(retspec,retlen+16,char);
else retspec = __fileify_retbuf;
- cp1 = esa;
+ cp1 = my_esa;
cp2 = retspec;
while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
strcpy(cp2,":[000000]");
if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
PerlMem_free(trndir);
PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
PerlMem_free(vmsdir);
return retspec;
}
else retpath[retlen-1] = '\0';
}
else { /* VMS-style directory spec */
- char *esa, *cp;
+ char *esa, *esal, *cp;
+ char *my_esa;
+ int my_esa_len;
unsigned long int sts, cmplen, haslower;
struct FAB dirfab = cc$rms_fab;
int dirlen;
rms_set_fna(dirfab, dirnam, trndir, dirlen);
esa = PerlMem_malloc(VMS_MAXRSS);
if (esa == NULL) _ckvmssts(SS$_INSFMEM);
+ esal = NULL;
+#if !defined(__VAX) && defined(NAML$C_MAXRSS)
+ esal = PerlMem_malloc(VMS_MAXRSS);
+ if (esal == NULL) _ckvmssts(SS$_INSFMEM);
+#endif
rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
rms_bind_fab_nam(dirfab, dirnam);
- rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
+ rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
#ifdef NAM$M_NO_SHORT_UPCASE
if (decc_efs_case_preserve)
rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
if (!sts) {
PerlMem_free(trndir);
PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
set_errno(EVMSERR);
set_vaxc_errno(dirfab.fab$l_sts);
return NULL;
sts1 = rms_free_search_context(&dirfab);
PerlMem_free(trndir);
PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
set_errno(EVMSERR);
set_vaxc_errno(dirfab.fab$l_sts);
return NULL;
sts2 = rms_free_search_context(&dirfab);
PerlMem_free(trndir);
PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
set_errno(ENOTDIR);
set_vaxc_errno(RMS$_DIR);
return NULL;
}
}
+ /* Make sure we are using the right buffer */
+ if (esal != NULL) {
+ /* We only need one, clean up the other */
+ my_esa = esal;
+ my_esa_len = rms_nam_esll(dirnam);
+ } else {
+ my_esa = esa;
+ my_esa_len = rms_nam_esl(dirnam);
+ }
+
+ /* Null terminate the buffer */
+ my_esa[my_esa_len] = '\0';
+
/* OK, the type was fine. Now pull any file name into the
directory path. */
- if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
+ if ((cp1 = strrchr(my_esa,']'))) *(rms_nam_typel(dirnam)) = ']';
else {
- cp1 = strrchr(esa,'>');
+ cp1 = strrchr(my_esa,'>');
*(rms_nam_typel(dirnam)) = '>';
}
*cp1 = '.';
*(rms_nam_typel(dirnam) + 1) = '\0';
- retlen = (rms_nam_typel(dirnam)) - esa + 2;
+ retlen = (rms_nam_typel(dirnam)) - my_esa + 2;
if (buf) retpath = buf;
else if (ts) Newx(retpath,retlen,char);
else retpath = __pathify_retbuf;
- strcpy(retpath,esa);
+ strcpy(retpath,my_esa);
PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
sts = rms_free_search_context(&dirfab);
/* $PARSE may have upcased filespec, so convert output to lower
* case if input contained any lowercase characters. */
static int posix_root_to_vms
(char *vmspath, int vmspath_len,
const char *unixpath,
- const int * utf8_fl) {
+ const int * utf8_fl)
+{
int sts;
struct FAB myfab = cc$rms_fab;
-struct NAML mynam = cc$rms_naml;
+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;
+struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
+char * esa, * esal, * rsa, * rsal;
char *vms_delim;
int dir_flag;
int unixlen;
dir_flag = 0;
+ vmspath[0] = '\0';
unixlen = strlen(unixpath);
if (unixlen == 0) {
- vmspath[0] = '\0';
return RMS$_FNF;
}
vmspath[vmspath_len] = 0;
if (unixpath[unixlen - 1] == '/')
dir_flag = 1;
- esa = PerlMem_malloc(VMS_MAXRSS);
+ esal = PerlMem_malloc(VMS_MAXRSS);
+ if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
+ esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
- myfab.fab$l_fna = vmspath;
- myfab.fab$b_fns = strlen(vmspath);
- myfab.fab$l_naml = &mynam;
- mynam.naml$l_esa = NULL;
- mynam.naml$b_ess = 0;
- mynam.naml$l_long_expand = esa;
- mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
- mynam.naml$l_rsa = NULL;
- mynam.naml$b_rss = 0;
+ rsal = PerlMem_malloc(VMS_MAXRSS);
+ if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
+ rsa = 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);
+ rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
+ rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
if (decc_efs_case_preserve)
mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
#ifdef NAML$M_OPEN_SPECIAL
/* It failed! Try again as a UNIX filespec */
if (!(sts & 1)) {
+ PerlMem_free(esal);
PerlMem_free(esa);
+ PerlMem_free(rsal);
+ PerlMem_free(rsa);
return sts;
}
/* get the Device ID and the FID */
sts = sys$search(&myfab);
+
+ /* These are no longer needed */
+ PerlMem_free(esa);
+ PerlMem_free(rsal);
+ PerlMem_free(rsa);
+
/* on any failure, returned the POSIX ^UP^ filespec */
if (!(sts & 1)) {
- PerlMem_free(esa);
+ PerlMem_free(esal);
return sts;
}
specdsc.dsc$a_pointer = vmspath;
}
}
}
- PerlMem_free(esa);
+ PerlMem_free(esal);
return sts;
}
*p = '\0';
fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
- if (fp == Nullfp) {
+ if (fp == NULL) {
PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
}
}
}
dd->count++;
/* 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;
+ *p = '\0';
if (!decc_efs_case_preserve) {
- buff[VMS_MAXRSS - 1] = '\0';
for (p = buff; *p; p++) *p = _tolower(*p);
}
- else {
- /* we don't want to force to lowercase, just null terminate */
- buff[res.dsc$w_length] = '\0';
- }
- while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
- *p = '\0';
/* Skip any directory component and just copy the name. */
sts = vms_split_path
*
* Note on command arguments to perl 'exec' and 'system': When handled
* in 'VMSish fashion' (i.e. not after a call to vfork) The args
- * are concatenated to form a DCL command string. If the first arg
- * begins with '$' (i.e. the perl script had "\$ Type" or some such),
+ * are concatenated to form a DCL command string. If the first non-numeric
+ * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
* the command string is handed off to DCL directly. Otherwise,
* the first token of the command is taken as the filespec of an image
* to run. The filespec is expanded using a default type of '.EXE' and
static char *
setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
{
- char *junk, *tmps = Nullch;
+ char *junk, *tmps = NULL;
register size_t cmdlen = 0;
size_t rlen;
register SV **idx;
} /* end of vms_do_exec() */
/*}}}*/
-unsigned long int Perl_do_spawn(pTHX_ const char *);
+int do_spawn2(pTHX_ const char *, int);
-/* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
-unsigned long int
-Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
+int
+Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
{
unsigned long int sts;
char * cmd;
+int flags = 0;
if (sp > mark) {
- cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
- sts = do_spawn(cmd);
+
+ /* We'll copy the (undocumented?) Win32 behavior and allow a
+ * numeric first argument. But the only value we'll support
+ * through do_aspawn is a value of 1, which means spawn without
+ * waiting for completion -- other values are ignored.
+ */
+ if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
+ ++mark;
+ flags = SvIVx(*mark);
+ }
+
+ if (flags && flags == 1) /* the Win32 P_NOWAIT value */
+ flags = CLI$M_NOWAIT;
+ else
+ flags = 0;
+
+ cmd = setup_argstr(aTHX_ really, mark, sp);
+ sts = do_spawn2(aTHX_ cmd, flags);
/* pp_sys will clean up cmd */
return sts;
}
} /* end of do_aspawn() */
/*}}}*/
-/* {{{unsigned long int do_spawn(char *cmd) */
-unsigned long int
-Perl_do_spawn(pTHX_ const char *cmd)
+
+/* {{{int do_spawn(char* cmd) */
+int
+Perl_do_spawn(pTHX_ char* cmd)
+{
+ PERL_ARGS_ASSERT_DO_SPAWN;
+
+ return do_spawn2(aTHX_ cmd, 0);
+}
+/*}}}*/
+
+/* {{{int do_spawn_nowait(char* cmd) */
+int
+Perl_do_spawn_nowait(pTHX_ char* cmd)
+{
+ PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
+
+ return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
+}
+/*}}}*/
+
+/* {{{int do_spawn2(char *cmd) */
+int
+do_spawn2(pTHX_ const char *cmd, int flags)
{
unsigned long int sts, substs;
TAINT_ENV();
TAINT_PROPER("spawn");
if (!cmd || !*cmd) {
- sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
+ sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
if (!(sts & 1)) {
switch (sts) {
case RMS$_FNF: case RMS$_DNF:
sts = substs;
}
else {
+ char mode[3];
PerlIO * fp;
- fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
+ if (flags & CLI$M_NOWAIT)
+ strcpy(mode, "n");
+ else
+ strcpy(mode, "nW");
+
+ fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
if (fp != NULL)
my_pclose(fp);
+ /* sts will be the pid in the nowait case */
}
return sts;
-} /* end of do_spawn() */
+} /* end of do_spawn2() */
/*}}}*/
if ((res = fflush(fp)) == 0 && fp) {
#ifdef VMS_DO_SOCKETS
Stat_t s;
- if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
+ if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
#endif
res = fsync(fileno(fp));
}
if (!retval) {
char * cptr;
+ int rmsex_flags = PERL_RMSEXPAND_M_VMS;
+
+ /* If this is an lstat, do not follow the link */
+ if (lstat_flag)
+ rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
+
cptr = do_rmsexpand
- (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
+ (save_spec, statbufp->st_devnam, 0, NULL, rmsex_flags, NULL, NULL);
if (cptr == NULL)
statbufp->st_devnam[0] = 0;
int
Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
{
- char *vmsin, * vmsout, *esa, *esa_out,
- *rsa, *ubf;
+ char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
+ *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
unsigned long int i, sts, sts2;
int dna_len;
struct FAB fab_in, fab_out;
esa = PerlMem_malloc(VMS_MAXRSS);
if (esa == NULL) _ckvmssts(SS$_INSFMEM);
+ esal = NULL;
+#if !defined(__VAX) && defined(NAML$C_MAXRSS)
+ esal = PerlMem_malloc(VMS_MAXRSS);
+ if (esal == NULL) _ckvmssts(SS$_INSFMEM);
+#endif
fab_in = cc$rms_fab;
rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
rsa = PerlMem_malloc(VMS_MAXRSS);
if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
- rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
- rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
+ rsal = NULL;
+#if !defined(__VAX) && defined(NAML$C_MAXRSS)
+ rsal = PerlMem_malloc(VMS_MAXRSS);
+ if (rsal == NULL) _ckvmssts(SS$_INSFMEM);
+#endif
+ rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
+ rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
rms_nam_esl(nam) = 0;
rms_nam_rsl(nam) = 0;
rms_nam_esll(nam) = 0;
PerlMem_free(vmsin);
PerlMem_free(vmsout);
PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
PerlMem_free(rsa);
+ if (rsal != NULL)
+ PerlMem_free(rsal);
set_vaxc_errno(sts);
switch (sts) {
case RMS$_FNF: case RMS$_DNF:
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(VMS_MAXRSS);
+ esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
- rms_set_rsa(nam_out, NULL, 0);
- rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
+ rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
+ if (rsa_out == NULL) _ckvmssts(SS$_INSFMEM);
+ esal_out = NULL;
+ rsal_out = NULL;
+#if !defined(__VAX) && defined(NAML$C_MAXRSS)
+ esal_out = PerlMem_malloc(VMS_MAXRSS);
+ if (esal_out == NULL) _ckvmssts(SS$_INSFMEM);
+ rsal_out = PerlMem_malloc(VMS_MAXRSS);
+ if (rsal_out == NULL) _ckvmssts(SS$_INSFMEM);
+#endif
+ rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
+ rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
if (preserve_dates == 0) { /* Act like DCL COPY */
rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
PerlMem_free(vmsin);
PerlMem_free(vmsout);
PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
PerlMem_free(rsa);
+ if (rsal != NULL)
+ PerlMem_free(rsal);
PerlMem_free(esa_out);
+ if (esal_out != NULL)
+ PerlMem_free(esal_out);
+ PerlMem_free(rsa_out);
+ if (rsal_out != NULL)
+ PerlMem_free(rsal_out);
set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
set_vaxc_errno(sts);
return 0;
PerlMem_free(vmsin);
PerlMem_free(vmsout);
PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
PerlMem_free(rsa);
+ if (rsal != NULL)
+ PerlMem_free(rsal);
PerlMem_free(esa_out);
+ if (esal_out != NULL)
+ PerlMem_free(esal_out);
+ PerlMem_free(rsa_out);
+ if (rsal_out != NULL)
+ PerlMem_free(rsal_out);
set_vaxc_errno(sts);
switch (sts) {
case RMS$_DNF:
sys$close(&fab_in); sys$close(&fab_out);
PerlMem_free(vmsin);
PerlMem_free(vmsout);
- PerlMem_free(esa);
PerlMem_free(ubf);
+ PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
PerlMem_free(rsa);
+ if (rsal != NULL)
+ PerlMem_free(rsal);
PerlMem_free(esa_out);
+ if (esal_out != NULL)
+ PerlMem_free(esal_out);
+ PerlMem_free(rsa_out);
+ if (rsal_out != NULL)
+ PerlMem_free(rsal_out);
set_errno(EVMSERR); set_vaxc_errno(sts);
return 0;
}
sys$close(&fab_in); sys$close(&fab_out);
PerlMem_free(vmsin);
PerlMem_free(vmsout);
- PerlMem_free(esa);
PerlMem_free(ubf);
+ PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
PerlMem_free(rsa);
+ if (rsal != NULL)
+ PerlMem_free(rsal);
PerlMem_free(esa_out);
+ if (esal_out != NULL)
+ PerlMem_free(esal_out);
+ PerlMem_free(rsa_out);
+ if (rsal_out != NULL)
+ PerlMem_free(rsal_out);
set_errno(EVMSERR); set_vaxc_errno(sts);
return 0;
}
sys$close(&fab_in); sys$close(&fab_out);
PerlMem_free(vmsin);
PerlMem_free(vmsout);
- PerlMem_free(esa);
PerlMem_free(ubf);
+ PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
PerlMem_free(rsa);
+ if (rsal != NULL)
+ PerlMem_free(rsal);
PerlMem_free(esa_out);
+ if (esal_out != NULL)
+ PerlMem_free(esal_out);
+ PerlMem_free(rsa_out);
+ if (rsal_out != NULL)
+ PerlMem_free(rsal_out);
set_errno(EVMSERR); set_vaxc_errno(sts);
return 0;
}
fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
sys$close(&fab_in); sys$close(&fab_out);
sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
- if (!(sts & 1)) {
- PerlMem_free(vmsin);
- PerlMem_free(vmsout);
- PerlMem_free(esa);
- PerlMem_free(ubf);
- PerlMem_free(rsa);
- PerlMem_free(esa_out);
- set_errno(EVMSERR); set_vaxc_errno(sts);
- return 0;
- }
PerlMem_free(vmsin);
PerlMem_free(vmsout);
- PerlMem_free(esa);
PerlMem_free(ubf);
+ PerlMem_free(esa);
+ if (esal != NULL)
+ PerlMem_free(esal);
PerlMem_free(rsa);
+ if (rsal != NULL)
+ PerlMem_free(rsal);
PerlMem_free(esa_out);
+ if (esal_out != NULL)
+ PerlMem_free(esal_out);
+ PerlMem_free(rsa_out);
+ if (rsal_out != NULL)
+ PerlMem_free(rsal_out);
+
+ if (!(sts & 1)) {
+ set_errno(EVMSERR); set_vaxc_errno(sts);
+ return 0;
+ }
+
return 1;
} /* end of rmscopy() */
if (counter) {
strcat(work_name, "__");
}
- strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
- PL_na));
+ strcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)));
}
/* Check to see if we actually have to bother...*/
if (!found) {
/* Be POSIXish: return the input pattern when no matches */
- begin = SvPVX(tmpglob);
- strcat(begin,"\n");
- ok = (PerlIO_puts(tmpfp,begin) != EOF);
+ strcpy(rstr,SvPVX(tmpglob));
+ strcat(rstr,"\n");
+ ok = (PerlIO_puts(tmpfp,rstr) != EOF);
}
if (ok && sts != RMS$_NMF &&
}
-#ifdef HAS_SYMLINK
static char *
mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
- const int *utf8_fl);
+ int *utf8_fl);
void
-vms_realpath_fromperl(pTHX_ CV *cv)
+unixrealpath_fromperl(pTHX_ CV *cv)
{
- dXSARGS;
- char *fspec, *rslt_spec, *rslt;
- STRLEN n_a;
+ dXSARGS;
+ char *fspec, *rslt_spec, *rslt;
+ STRLEN n_a;
- if (!items || items != 1)
- Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
+ if (!items || items != 1)
+ Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
- fspec = SvPV(ST(0),n_a);
- if (!fspec || !*fspec) XSRETURN_UNDEF;
+ fspec = SvPV(ST(0),n_a);
+ if (!fspec || !*fspec) XSRETURN_UNDEF;
- Newx(rslt_spec, VMS_MAXRSS + 1, char);
- rslt = do_vms_realpath(fspec, rslt_spec, NULL);
- ST(0) = sv_newmortal();
- if (rslt != NULL)
- sv_usepvn(ST(0),rslt,strlen(rslt));
- else
- Safefree(rslt_spec);
- XSRETURN(1);
+ Newx(rslt_spec, VMS_MAXRSS + 1, char);
+ rslt = do_vms_realpath(fspec, rslt_spec, NULL);
+
+ ST(0) = sv_newmortal();
+ if (rslt != NULL)
+ sv_usepvn(ST(0),rslt,strlen(rslt));
+ else
+ Safefree(rslt_spec);
+ XSRETURN(1);
}
-#endif
-#if __CRTL_VER >= 70301000 && !defined(__VAX)
+static char *
+mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
+ int *utf8_fl);
+
+void
+vmsrealpath_fromperl(pTHX_ CV *cv)
+{
+ dXSARGS;
+ char *fspec, *rslt_spec, *rslt;
+ STRLEN n_a;
+
+ if (!items || items != 1)
+ Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
+
+ fspec = SvPV(ST(0),n_a);
+ if (!fspec || !*fspec) XSRETURN_UNDEF;
+
+ Newx(rslt_spec, VMS_MAXRSS + 1, char);
+ rslt = do_vms_realname(fspec, rslt_spec, NULL);
+
+ ST(0) = sv_newmortal();
+ if (rslt != NULL)
+ sv_usepvn(ST(0),rslt,strlen(rslt));
+ else
+ Safefree(rslt_spec);
+ XSRETURN(1);
+}
+
+#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.
+ */
+/*{{{ int my_symlink(const char *path1, const char *path2)*/
+int my_symlink(const char *path1, const char *path2) {
+ if (!path2 || !*path2) {
+ SETERRNO(ENOENT, SS$_NOSUCHFILE);
+ return -1;
+ }
+ return symlink(path1, path2);
+}
+/*}}}*/
+
+#endif /* HAS_SYMLINK */
+
int do_vms_case_tolerant(void);
void
-vms_case_tolerant_fromperl(pTHX_ CV *cv)
+case_tolerant_process_fromperl(pTHX_ CV *cv)
{
dXSARGS;
ST(0) = boolSV(do_vms_case_tolerant());
XSRETURN(1);
}
-#endif
+
+#ifdef USE_ITHREADS
void
Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
struct interp_intern *dst)
{
+ PERL_ARGS_ASSERT_SYS_INTERN_DUP;
+
memcpy(dst,src,sizeof(struct interp_intern));
}
+#endif
+
void
Perl_sys_intern_clear(pTHX)
{
newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
-#ifdef HAS_SYMLINK
- newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
-#endif
-#if __CRTL_VER >= 70301000 && !defined(__VAX)
- newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
-#endif
+ newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
+ newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
+ newXSproto("VMS::Filespec::case_tolerant_process",
+ case_tolerant_process_fromperl,file,"");
store_pipelocs(aTHX); /* will redo any earlier attempts */
return;
}
-#ifdef HAS_SYMLINK
-
#if __CRTL_VER == 80200000
/* This missed getting in to the DECC SDK for 8.2 */
char *realpath(const char *file_name, char * resolved_name, ...);
* The perl fallback routine to provide realpath() is not as efficient
* on OpenVMS.
*/
+
+/* Hack, use old stat() as fastest way of getting ino_t and device */
+int decc$stat(const char *name, void * statbuf);
+
+
+/* Realpath is fragile. In 8.3 it does not work if the feature
+ * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
+ * links are implemented in RMS, not the CRTL. It also can fail if the
+ * user does not have read/execute access to some of the directories.
+ * So in order for Do What I Mean mode to work, if realpath() fails,
+ * fall back to looking up the filename by the device name and FID.
+ */
+
+int vms_fid_to_name(char * outname, int outlen, const char * name)
+{
+struct statbuf_t {
+ char * st_dev;
+ unsigned short st_ino[3];
+ unsigned short padw;
+ unsigned long padl[30]; /* plenty of room */
+} statbuf;
+int sts;
+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};
+
+ sts = decc$stat(name, &statbuf);
+ if (sts == 0) {
+
+ dvidsc.dsc$a_pointer=statbuf.st_dev;
+ dvidsc.dsc$w_length=strlen(statbuf.st_dev);
+
+ specdsc.dsc$a_pointer = outname;
+ specdsc.dsc$w_length = outlen-1;
+
+ sts = lib$fid_to_name
+ (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
+ if ($VMS_STATUS_SUCCESS(sts)) {
+ outname[specdsc.dsc$w_length] = 0;
+ return 0;
+ }
+ }
+ return sts;
+}
+
+
+
static char *
mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
- const int *utf8_fl)
+ int *utf8_fl)
+{
+ char * rslt = NULL;
+
+#ifdef HAS_SYMLINK
+ if (decc_posix_compliant_pathnames > 0 ) {
+ /* realpath currently only works if posix compliant pathnames are
+ * enabled. It may start working when they are not, but in that
+ * case we still want the fallback behavior for backwards compatibility
+ */
+ rslt = realpath(filespec, outbuf);
+ }
+#endif
+
+ if (rslt == NULL) {
+ char * vms_spec;
+ 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;
+ int file_len;
+
+ /* Fall back to fid_to_name */
+
+ Newx(vms_spec, VMS_MAXRSS + 1, char);
+
+ sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec);
+ if (sts == 0) {
+
+
+ /* Now need to trim the version off */
+ sts = vms_split_path
+ (vms_spec,
+ &v_spec,
+ &v_len,
+ &r_spec,
+ &r_len,
+ &d_spec,
+ &d_len,
+ &n_spec,
+ &n_len,
+ &e_spec,
+ &e_len,
+ &vs_spec,
+ &vs_len);
+
+
+ if (sts == 0) {
+ int haslower = 0;
+ const char *cp;
+
+ /* Trim off the version */
+ int file_len = v_len + r_len + d_len + n_len + e_len;
+ vms_spec[file_len] = 0;
+
+ /* The result is expected to be in UNIX format */
+ rslt = do_tounixspec(vms_spec, outbuf, 0, utf8_fl);
+
+ /* Downcase if input had any lower case letters and
+ * case preservation is not in effect.
+ */
+ if (!decc_efs_case_preserve) {
+ for (cp = filespec; *cp; cp++)
+ if (islower(*cp)) { haslower = 1; break; }
+
+ if (haslower) __mystrtolower(rslt);
+ }
+ }
+ }
+
+ Safefree(vms_spec);
+ }
+ return rslt;
+}
+
+static char *
+mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
+ int *utf8_fl)
{
- return realpath(filespec, outbuf);
+ 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;
+ int file_len;
+
+ /* Fall back to fid_to_name */
+
+ sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec);
+ if (sts != 0) {
+ return NULL;
+ }
+ else {
+
+
+ /* Now need to trim the version off */
+ sts = vms_split_path
+ (outbuf,
+ &v_spec,
+ &v_len,
+ &r_spec,
+ &r_len,
+ &d_spec,
+ &d_len,
+ &n_spec,
+ &n_len,
+ &e_spec,
+ &e_len,
+ &vs_spec,
+ &vs_len);
+
+
+ if (sts == 0) {
+ int haslower = 0;
+ const char *cp;
+
+ /* Trim off the version */
+ int file_len = v_len + r_len + d_len + n_len + e_len;
+ outbuf[file_len] = 0;
+
+ /* Downcase if input had any lower case letters and
+ * case preservation is not in effect.
+ */
+ if (!decc_efs_case_preserve) {
+ for (cp = filespec; *cp; cp++)
+ if (islower(*cp)) { haslower = 1; break; }
+
+ if (haslower) __mystrtolower(outbuf);
+ }
+ }
+ }
+ return outbuf;
}
+
/*}}}*/
/* External entry points */
char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
{ return do_vms_realpath(filespec, outbuf, utf8_fl); }
-#else
-char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
-{ return NULL; }
-#endif
+char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
+{ return do_vms_realname(filespec, outbuf, utf8_fl); }
-#if __CRTL_VER >= 70301000 && !defined(__VAX)
/* case_tolerant */
/*{{{int do_vms_case_tolerant(void)*/
}
/*}}}*/
/* External entry points */
+#if __CRTL_VER >= 70301000 && !defined(__VAX)
int Perl_vms_case_tolerant(void)
{ return do_vms_case_tolerant(); }
#else
/* unlink all versions on unlink() or rename() */
- vms_vtf7_filenames = 0;
+ vms_unlink_all_versions = 0;
status = sys_trnlnm
("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
if ($VMS_STATUS_SUCCESS(status)) {
projects / p5sagit/p5-mst-13.2.git / blobdiff