-/* 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>
#include <lib$routines.h>
#include <lnmdef.h>
#include <msgdef.h>
+#include <ossdef.h>
#if __CRTL_VER >= 70301000 && !defined(__VAX)
#include <ppropdef.h>
#endif
*/
#ifdef sys$getdviw
#undef sys$getdviw
-#endif
int sys$getdviw
(unsigned long efn,
unsigned short chan,
void * (astadr)(unsigned long),
void * astprm,
void * nullarg);
+#endif
-#ifdef USE_VMS_DECTERM
+#ifdef sys$get_security
+#undef sys$get_security
+int sys$get_security
+ (const struct dsc$descriptor_s * clsnam,
+ const struct dsc$descriptor_s * objnam,
+ const unsigned int *objhan,
+ unsigned int flags,
+ const struct item_list_3 * itmlst,
+ unsigned int * contxt,
+ const unsigned int * acmode);
+#endif
-/* Routine to create a decterm for use with the Perl debugger */
-/* No headers, this information was found in the Programming Concepts Manual */
+#ifdef sys$set_security
+#undef sys$set_security
+int sys$set_security
+ (const struct dsc$descriptor_s * clsnam,
+ const struct dsc$descriptor_s * objnam,
+ const unsigned int *objhan,
+ unsigned int flags,
+ const struct item_list_3 * itmlst,
+ unsigned int * contxt,
+ const unsigned int * acmode);
+#endif
-int decw$term_port
- (const struct dsc$descriptor_s * display,
- const struct dsc$descriptor_s * setup_file,
- const struct dsc$descriptor_s * customization,
- struct dsc$descriptor_s * result_device_name,
- unsigned short * result_device_name_length,
- void * controller,
- void * char_buffer,
- void * char_change_buffer);
+#ifdef lib$find_image_symbol
+#undef lib$find_image_symbol
+int lib$find_image_symbol
+ (const struct dsc$descriptor_s * imgname,
+ const struct dsc$descriptor_s * symname,
+ void * symval,
+ const struct dsc$descriptor_s * defspec,
+ unsigned long flag);
+#endif
+
+#ifdef lib$rename_file
+#undef lib$rename_file
+int lib$rename_file
+ (const struct dsc$descriptor_s * old_file_dsc,
+ const struct dsc$descriptor_s * new_file_dsc,
+ const struct dsc$descriptor_s * default_file_dsc,
+ const struct dsc$descriptor_s * related_file_dsc,
+ const unsigned long * flags,
+ void * (success)(const struct dsc$descriptor_s * old_dsc,
+ const struct dsc$descriptor_s * new_dsc,
+ const void *),
+ void * (error)(const struct dsc$descriptor_s * old_dsc,
+ const struct dsc$descriptor_s * new_dsc,
+ const int * rms_sts,
+ const int * rms_stv,
+ const int * error_src,
+ const void * usr_arg),
+ int (confirm)(const struct dsc$descriptor_s * old_dsc,
+ const struct dsc$descriptor_s * new_dsc,
+ const void * old_fab,
+ const void * usr_arg),
+ void * user_arg,
+ struct dsc$descriptor_s * old_result_name_dsc,
+ struct dsc$descriptor_s * new_result_name_dsc,
+ unsigned long * file_scan_context);
#endif
#if __CRTL_VER >= 70300000 && !defined(__VAX)
# define RTL_USES_UTC 1
#endif
+/* Routine to create a decterm for use with the Perl debugger */
+/* No headers, this information was found in the Programming Concepts Manual */
+
+static int (*decw_term_port)
+ (const struct dsc$descriptor_s * display,
+ const struct dsc$descriptor_s * setup_file,
+ const struct dsc$descriptor_s * customization,
+ struct dsc$descriptor_s * result_device_name,
+ unsigned short * result_device_name_length,
+ void * controller,
+ void * char_buffer,
+ void * char_change_buffer) = 0;
/* gcc's header files don't #define direct access macros
* corresponding to VAXC's variant structs */
#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)
static int vms_process_case_tolerant = 1;
int vms_vtf7_filenames = 0;
int gnv_unix_shell = 0;
+static int vms_unlink_all_versions = 0;
/* bug workarounds if needed */
int decc_bug_readdir_efs1 = 0;
}
}
- /* High bit set, but not a unicode character! */
+ /* High bit set, but not a Unicode character! */
/* Non printing DECMCS or ISO Latin-1 character? */
if (*inspec <= 0x9F) {
case ']':
case '%':
case '^':
+ /* Don't escape again if following character is
+ * already something we escape.
+ */
+ if (strchr(".~!#&\'`()+@{},;[]%^=_", *(inspec+1))) {
+ *outspec = *inspec;
+ *output_cnt = 1;
+ return 1;
+ break;
+ }
+ /* But otherwise fall through and escape it. */
case '=':
/* Assume that this is to be escaped */
outspec[0] = '^';
if (*inspec == '^') {
inspec++;
switch (*inspec) {
+ /* Spaces and non-trailing dots should just be passed through,
+ * but eat the escape character.
+ */
case '.':
- /* Non trailing dots should just be passed through */
*outspec = *inspec;
- count++;
+ count += 2;
(*output_cnt)++;
break;
case '_': /* space */
*outspec = ' ';
- inspec++;
- count++;
+ count += 2;
(*output_cnt)++;
break;
+ case '^':
+ /* Hmm. Better leave the escape escaped. */
+ outspec[0] = '^';
+ outspec[1] = '^';
+ count += 2;
+ (*output_cnt) += 2;
+ break;
case 'U': /* Unicode - FIX-ME this is wrong. */
inspec++;
count++;
return count;
}
-
-int SYS$FILESCAN
+#ifdef sys$filescan
+#undef sys$filescan
+int sys$filescan
(const struct dsc$descriptor_s * srcstr,
struct filescan_itmlst_2 * valuelist,
unsigned long * fldflags,
struct dsc$descriptor_s *auxout,
unsigned short * retlen);
+#endif
/* vms_split_path - Verify that the input file specification is a
* VMS format file specification, and provide pointers to the components of
item_list[8].length = 0;
item_list[8].component = NULL;
- status = SYS$FILESCAN
+ status = sys$filescan
((const struct dsc$descriptor_s *)&path_desc, item_list,
&flags, NULL, NULL);
_ckvmssts_noperl(status); /* All failure status values indicate a coding error */
* 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 */
return NULL;
}
+/* 8.3, remove() is now broken on symbolic links */
+static int rms_erase(const char * vmsname);
+
+
/* mp_do_kill_file
* A little hack to get around a bug in some implemenation of remove()
* that do not know how to delete a directory
static int
mp_do_kill_file(pTHX_ const char *name, int dirflag)
{
- char *vmsname, *rspec;
- char *remove_name;
+ char *vmsname;
+ char *rslt;
unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
- if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
- PerlMem_free(vmsname);
- return -1;
- }
-
- if (decc_posix_compliant_pathnames) {
- /* In POSIX mode, we prefer to remove the UNIX name */
- rspec = vmsname;
- remove_name = (char *)name;
- }
- else {
- rspec = PerlMem_malloc(NAM$C_MAXRSS+1);
- if (rspec == NULL) _ckvmssts(SS$_INSFMEM);
- if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
- PerlMem_free(rspec);
+ rslt = do_rmsexpand(name,
+ vmsname,
+ 0,
+ NULL,
+ PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
+ NULL,
+ NULL);
+ if (rslt == NULL) {
PerlMem_free(vmsname);
return -1;
}
- PerlMem_free(vmsname);
- remove_name = rspec;
- }
-
-#if defined(__CRTL_VER) && __CRTL_VER >= 70000000
- if (dirflag != 0) {
- if (decc_dir_barename && decc_posix_compliant_pathnames) {
- remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
- if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
- do_pathify_dirspec(name, remove_name, 0, NULL);
- if (!rmdir(remove_name)) {
+ /* Erase the file */
+ rmsts = rms_erase(vmsname);
- PerlMem_free(remove_name);
- PerlMem_free(rspec);
- return 0; /* Can we just get rid of it? */
- }
- }
- else {
- if (!rmdir(remove_name)) {
- PerlMem_free(rspec);
- return 0; /* Can we just get rid of it? */
- }
- }
- }
- else
-#endif
- if (!remove(remove_name)) {
- PerlMem_free(rspec);
- return 0; /* Can we just get rid of it? */
+ /* Did it succeed */
+ if ($VMS_STATUS_SUCCESS(rmsts)) {
+ PerlMem_free(vmsname);
+ return 0;
}
/* If not, can changing protections help? */
- if (vaxc$errno != RMS$_PRV) {
- PerlMem_free(rspec);
+ if (rmsts != RMS$_PRV) {
+ set_vaxc_errno(rmsts);
+ PerlMem_free(vmsname);
return -1;
}
* to delete the file.
*/
_ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
- fildsc.dsc$w_length = strlen(rspec);
- fildsc.dsc$a_pointer = rspec;
+ fildsc.dsc$w_length = strlen(vmsname);
+ fildsc.dsc$a_pointer = vmsname;
cxt = 0;
newace.myace$l_ident = oldace.myace$l_ident;
+ rmsts = -1;
if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
switch (aclsts) {
case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
_ckvmssts(aclsts);
}
set_vaxc_errno(aclsts);
- PerlMem_free(rspec);
+ PerlMem_free(vmsname);
return -1;
}
/* Grab any existing ACEs with this identifier in case we fail */
if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
goto yourroom;
-#if defined(__CRTL_VER) && __CRTL_VER >= 70000000
- if (dirflag != 0)
- if (decc_dir_barename && decc_posix_compliant_pathnames) {
- remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
- if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
-
- do_pathify_dirspec(name, remove_name, 0, NULL);
- rmsts = rmdir(remove_name);
- PerlMem_free(remove_name);
+ rmsts = rms_erase(vmsname);
+ if ($VMS_STATUS_SUCCESS(rmsts)) {
+ rmsts = 0;
}
else {
- rmsts = rmdir(remove_name);
- }
- else
-#endif
- rmsts = remove(remove_name);
- if (rmsts) {
+ rmsts = -1;
/* We blew it - dir with files in it, no write priv for
* parent directory, etc. Put things back the way they were. */
if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
if (!(aclsts & 1)) {
set_errno(EVMSERR);
set_vaxc_errno(aclsts);
- PerlMem_free(rspec);
- return -1;
}
- PerlMem_free(rspec);
+ PerlMem_free(vmsname);
return rmsts;
} /* end of kill_file() */
int
Perl_do_rmdir(pTHX_ const char *name)
{
- char dirfile[NAM$C_MAXRSS+1];
+ char * dirfile;
int retval;
Stat_t st;
- if (do_fileify_dirspec(name,dirfile,0,NULL) == NULL) return -1;
- if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
- else retval = mp_do_kill_file(aTHX_ dirfile, 1);
+ dirfile = PerlMem_malloc(VMS_MAXRSS + 1);
+ if (dirfile == NULL)
+ _ckvmssts(SS$_INSFMEM);
+
+ /* Force to a directory specification */
+ if (do_fileify_dirspec(name, dirfile, 0, NULL) == NULL) {
+ PerlMem_free(dirfile);
+ return -1;
+ }
+ if (Perl_flex_lstat(aTHX_ dirfile, &st) || !S_ISDIR(st.st_mode)) {
+ errno = ENOTDIR;
+ retval = -1;
+ }
+ else
+ retval = mp_do_kill_file(aTHX_ dirfile, 1);
+
+ PerlMem_free(dirfile);
return retval;
} /* end of do_rmdir */
{
char rspec[NAM$C_MAXRSS+1];
char *tspec;
- unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
- unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
- struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
- 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 itmlst_3
- findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
- {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
- addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
- dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
- lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
- ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
-
- /* Expand the input spec using RMS, since the CRTL remove() and
- * system services won't do this by themselves, so we may miss
- * a file "hiding" behind a logical name or search list. */
- tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
- if (tspec == NULL) return -1;
- if (!remove(rspec)) return 0; /* Can we just get rid of it? */
- /* If not, can changing protections help? */
- if (vaxc$errno != RMS$_PRV) return -1;
+ Stat_t st;
+ int rmsts;
- /* No, so we get our own UIC to use as a rights identifier,
- * and the insert an ACE at the head of the ACL which allows us
- * to delete the file.
+ /* Remove() is allowed to delete directories, according to the X/Open
+ * specifications.
+ * This may need special handling to work with the ACL hacks.
*/
- _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
- fildsc.dsc$w_length = strlen(rspec);
- fildsc.dsc$a_pointer = rspec;
- cxt = 0;
- newace.myace$l_ident = oldace.myace$l_ident;
- if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
- switch (aclsts) {
- case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
- set_errno(ENOENT); break;
- case RMS$_DIR:
- set_errno(ENOTDIR); break;
- case RMS$_DEV:
- set_errno(ENODEV); break;
- case RMS$_SYN: case SS$_INVFILFOROP:
- set_errno(EINVAL); break;
- case RMS$_PRV:
- set_errno(EACCES); break;
- default:
- _ckvmssts(aclsts);
- }
- set_vaxc_errno(aclsts);
- return -1;
- }
- /* Grab any existing ACEs with this identifier in case we fail */
- aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
- if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
- || fndsts == SS$_NOMOREACE ) {
- /* Add the new ACE . . . */
- if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
- goto yourroom;
- if ((rmsts = remove(name))) {
- /* We blew it - dir with files in it, no write priv for
- * parent directory, etc. Put things back the way they were. */
- if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
- goto yourroom;
- if (fndsts & 1) {
- addlst[0].bufadr = &oldace;
- if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
- goto yourroom;
- }
- }
+ if ((flex_lstat(name, &st) == 0) && S_ISDIR(st.st_mode)) {
+ rmsts = Perl_do_rmdir(aTHX_ name);
+ return rmsts;
}
- yourroom:
- fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
- /* We just deleted it, so of course it's not there. Some versions of
- * VMS seem to return success on the unlock operation anyhow (after all
- * the unlock is successful), but others don't.
- */
- if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
- if (aclsts & 1) aclsts = fndsts;
- if (!(aclsts & 1)) {
- set_errno(EVMSERR);
- set_vaxc_errno(aclsts);
- return -1;
- }
+ rmsts = mp_do_kill_file(aTHX_ name, 0);
return rmsts;
/*}}}*/
+/*{{{int my_chmod(char *, mode_t)*/
+int
+Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
+{
+ STRLEN speclen = strlen(file_spec);
+
+ /* zero length string sometimes gives ACCVIO */
+ if (speclen == 0) return -1;
+
+ /* some versions of CRTL chmod() doesn't tolerate trailing /, since
+ * that implies null file name/type. However, it's commonplace under Unix,
+ * so we'll allow it for a gain in portability.
+ *
+ * Tests are showing that chmod() on VMS 8.3 is only accepting directories
+ * in VMS file.dir notation.
+ */
+ if ((speclen > 1) && (file_spec[speclen-1] == '/')) {
+ char *vms_src, *vms_dir, *rslt;
+ int ret = -1;
+ errno = EIO;
+
+ /* First convert this to a VMS format specification */
+ vms_src = PerlMem_malloc(VMS_MAXRSS);
+ if (vms_src == NULL)
+ _ckvmssts(SS$_INSFMEM);
+
+ rslt = do_tovmsspec(file_spec, vms_src, 0, NULL);
+ if (rslt == NULL) {
+ /* If we fail, then not a file specification */
+ PerlMem_free(vms_src);
+ errno = EIO;
+ return -1;
+ }
+
+ /* Now make it a directory spec so chmod is happy */
+ vms_dir = PerlMem_malloc(VMS_MAXRSS + 1);
+ if (vms_dir == NULL)
+ _ckvmssts(SS$_INSFMEM);
+ rslt = do_fileify_dirspec(vms_src, vms_dir, 0, NULL);
+ PerlMem_free(vms_src);
+
+ /* Now do it */
+ if (rslt != NULL) {
+ ret = chmod(vms_dir, mode);
+ } else {
+ errno = EIO;
+ }
+ PerlMem_free(vms_dir);
+ return ret;
+ }
+ else return chmod(file_spec, mode);
+} /* end of my_chmod */
+/*}}}*/
+
+
/*{{{FILE *my_tmpfile()*/
FILE *
my_tmpfile(void)
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 */
}
}
unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
int sts, did_stuff, need_eof, j;
- /*
- flush any pending i/o
+ /*
+ * Flush any pending i/o, but since we are in process run-down, be
+ * careful about referencing PerlIO structures that may already have
+ * been deallocated. We may not even have an interpreter anymore.
*/
info = open_pipes;
while (info) {
if (info->fp) {
- if (!info->useFILE)
- PerlIO_flush(info->fp); /* first, flush data */
+ if (!info->useFILE
+#if defined(USE_ITHREADS)
+ && my_perl
+#endif
+ && PL_perlio_fd_refcnt)
+ PerlIO_flush(info->fp);
else
fflush((FILE *)info->fp);
}
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;
}
-#ifdef USE_VMS_DECTERM
-
static int vms_is_syscommand_xterm(void)
{
const static struct dsc$descriptor_s syscommand_dsc =
struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
DSC$K_CLASS_S, mbx1};
+ /* LIB$FIND_IMAGE_SIGNAL needs a handler */
+ /*---------------------------------------*/
+ VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
+
+
+ /* Make sure that this is from the Perl debugger */
ret_char = strstr(cmd," xterm ");
if (ret_char == NULL)
return NULL;
if (ret_char == NULL)
return NULL;
+ if (decw_term_port == 0) {
+ $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
+ $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
+ $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
+
+ status = lib$find_image_symbol
+ (&filename1_dsc,
+ &decw_term_port_dsc,
+ (void *)&decw_term_port,
+ NULL,
+ 0);
+
+ /* Try again with the other image name */
+ if (!$VMS_STATUS_SUCCESS(status)) {
+
+ status = lib$find_image_symbol
+ (&filename2_dsc,
+ &decw_term_port_dsc,
+ (void *)&decw_term_port,
+ NULL,
+ 0);
+
+ }
+
+ }
+
+
+ /* No decw$term_port, give it up */
+ if (!$VMS_STATUS_SUCCESS(status))
+ return NULL;
+
/* Are we on a workstation? */
/* to do: capture the rows / columns and pass their properties */
ret_stat = vms_is_syscommand_xterm();
device_name_len = 0;
/* Try to create the window */
- status = decw$term_port
+ status = (*decw_term_port)
(NULL,
NULL,
&customization_dsc,
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;
/* All done */
return info->fp;
}
-#endif
static PerlIO *
safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
$DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
$DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
-#ifdef USE_VMS_DECTERM
/* Check here for Xterm create request. This means looking for
* "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
* is possible to create an xterm.
PerlIO * xterm_fd;
xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
- if (xterm_fd != Nullfp)
+ if (xterm_fd != NULL)
return xterm_fd;
}
-#endif
if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
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 */
* the first EOF closing the pipe (and DASSGN'ing the channel)...
*/
if (info->fp) {
- if (!info->useFILE)
- PerlIO_flush(info->fp); /* first, flush data */
+ if (!info->useFILE
+#if defined(USE_ITHREADS)
+ && my_perl
+#endif
+ && PL_perlio_fd_refcnt)
+ PerlIO_flush(info->fp);
else
fflush((FILE *)info->fp);
}
0, 0, 0, 0, 0, 0));
_ckvmssts(sys$setast(1));
if (info->fp) {
- if (!info->useFILE)
+ if (!info->useFILE
+#if defined(USE_ITHREADS)
+ && my_perl
+#endif
+ && PL_perlio_fd_refcnt)
PerlIO_close(info->fp);
else
fclose((FILE *)info->fp);
#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; }
#endif
-/*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
-/* Shortcut for common case of simple calls to $PARSE and $SEARCH
- * to expand file specification. Allows for a single default file
- * specification and a simple mask of options. If outbuf is non-NULL,
- * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
- * the resultant file specification is placed. If outbuf is NULL, the
- * resultant file specification is placed into a static buffer.
- * The third argument, if non-NULL, is taken to be a default file
- * specification string. The fourth argument is unused at present.
- * rmesexpand() returns the address of the resultant string if
- * successful, and NULL on error.
- *
- * New functionality for previously unused opts value:
- * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
- * PERL_RMSEXPAND_M_LONG - Want output in long formst
- * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
+/* rms_erase
+ * The CRTL for 8.3 and later can create symbolic links in any mode,
+ * however in 8.3 the unlink/remove/delete routines will only properly handle
+ * them if one of the PCP modes is active.
*/
-static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
-
-static char *
-mp_do_rmsexpand
- (pTHX_ const char *filespec,
- char *outbuf,
- int ts,
- const char *defspec,
- unsigned opts,
- int * fs_utf8,
- int * dfs_utf8)
+static int rms_erase(const char * vmsname)
{
- static char __rmsexpand_retbuf[VMS_MAXRSS];
- char * vmsfspec, *tmpfspec;
- char * esa, *cp, *out = NULL;
- char * tbuf;
- char * esal;
- char * outbufl;
+ int status;
struct FAB myfab = cc$rms_fab;
rms_setup_nam(mynam);
- STRLEN speclen;
- unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
- int sts;
- /* temp hack until UTF8 is actually implemented */
- if (fs_utf8 != NULL)
- *fs_utf8 = 0;
+ rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
+ rms_bind_fab_nam(myfab, mynam);
- if (!filespec || !*filespec) {
- set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
- return NULL;
- }
- if (!outbuf) {
- if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
- else outbuf = __rmsexpand_retbuf;
+ /* Are we removing all versions? */
+ if (vms_unlink_all_versions == 1) {
+ const char * defspec = ";*";
+ rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
}
- vmsfspec = NULL;
- tmpfspec = NULL;
+#ifdef NAML$M_OPEN_SPECIAL
+ rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
+#endif
+
+ status = sys$erase(&myfab, 0, 0);
+
+ return status;
+}
+
+
+static int
+vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
+ const struct dsc$descriptor_s * vms_dst_dsc,
+ unsigned long flags)
+{
+ /* VMS and UNIX handle file permissions differently and the
+ * the same ACL trick may be needed for renaming files,
+ * especially if they are directories.
+ */
+
+ /* todo: get kill_file and rename to share common code */
+ /* 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, type = ACL$C_FILE;
+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}},
+ addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
+ dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
+ {0,0,0,0}};
+
+
+ /* Expand the input spec using RMS, since we do not want to put
+ * ACLs on the target of a symbolic link */
+ vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
+ if (vmsname == NULL)
+ return SS$_INSFMEM;
+
+ rslt = do_rmsexpand(vms_src_dsc->dsc$a_pointer,
+ vmsname,
+ 0,
+ NULL,
+ PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
+ NULL,
+ NULL);
+ if (rslt == NULL) {
+ PerlMem_free(vmsname);
+ return SS$_INSFMEM;
+ }
+
+ /* So we get our own UIC to use as a rights identifier,
+ * and the insert an ACE at the head of the ACL which allows us
+ * to delete the file.
+ */
+ _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
+
+ fildsc.dsc$w_length = strlen(vmsname);
+ fildsc.dsc$a_pointer = vmsname;
+ ctx = 0;
+ newace.myace$l_ident = oldace.myace$l_ident;
+ rnsts = SS$_ABORT;
+
+ /* Grab any existing ACEs with this identifier in case we fail */
+ clean_dsc = &fildsc;
+ aclsts = fndsts = sys$get_security(&obj_file_dsc,
+ &fildsc,
+ NULL,
+ OSS$M_WLOCK,
+ findlst,
+ &ctx,
+ &access_mode);
+
+ if ($VMS_STATUS_SUCCESS(fndsts) || (fndsts == SS$_ACLEMPTY)) {
+ /* Add the new ACE . . . */
+
+ /* if the sys$get_security succeeded, then ctx is valid, and the
+ * object/file descriptors will be ignored. But otherwise they
+ * are needed
+ */
+ aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
+ OSS$M_RELCTX, addlst, &ctx, &access_mode);
+ if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
+ set_errno(EVMSERR);
+ set_vaxc_errno(aclsts);
+ PerlMem_free(vmsname);
+ return aclsts;
+ }
+
+ rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
+ NULL, NULL,
+ &flags,
+ NULL, NULL, NULL, NULL, NULL, NULL, NULL);
+
+ if ($VMS_STATUS_SUCCESS(rnsts)) {
+ clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
+ }
+
+ /* Put things back the way they were. */
+ ctx = 0;
+ aclsts = sys$get_security(&obj_file_dsc,
+ clean_dsc,
+ NULL,
+ OSS$M_WLOCK,
+ findlst,
+ &ctx,
+ &access_mode);
+
+ if ($VMS_STATUS_SUCCESS(aclsts)) {
+ int sec_flags;
+
+ sec_flags = 0;
+ if (!$VMS_STATUS_SUCCESS(fndsts))
+ sec_flags = OSS$M_RELCTX;
+
+ /* Get rid of the new ACE */
+ aclsts = sys$set_security(NULL, NULL, NULL,
+ sec_flags, dellst, &ctx, &access_mode);
+
+ /* If there was an old ACE, put it back */
+ if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
+ addlst[0].bufadr = &oldace;
+ aclsts = sys$set_security(NULL, NULL, NULL,
+ OSS$M_RELCTX, addlst, &ctx, &access_mode);
+ if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
+ set_errno(EVMSERR);
+ set_vaxc_errno(aclsts);
+ rnsts = aclsts;
+ }
+ } else {
+ int aclsts2;
+
+ /* Try to clear the lock on the ACL list */
+ aclsts2 = sys$set_security(NULL, NULL, NULL,
+ OSS$M_RELCTX, NULL, &ctx, &access_mode);
+
+ /* Rename errors are most important */
+ if (!$VMS_STATUS_SUCCESS(rnsts))
+ aclsts = rnsts;
+ set_errno(EVMSERR);
+ set_vaxc_errno(aclsts);
+ rnsts = aclsts;
+ }
+ }
+ else {
+ if (aclsts != SS$_ACLEMPTY)
+ rnsts = aclsts;
+ }
+ }
+ else
+ rnsts = fndsts;
+
+ PerlMem_free(vmsname);
+ return rnsts;
+}
+
+
+/*{{{int rename(const char *, const char * */
+/* Not exactly what X/Open says to do, but doing it absolutely right
+ * and efficiently would require a lot more work. This should be close
+ * enough to pass all but the most strict X/Open compliance test.
+ */
+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;
+
+ /* Validate the source file */
+ src_sts = flex_lstat(src, &src_st);
+ if (src_sts != 0) {
+
+ /* No source file or other problem */
+ return src_sts;
+ }
+
+ dst_sts = flex_lstat(dst, &dst_st);
+ if (dst_sts == 0) {
+
+ if (dst_st.st_dev != src_st.st_dev) {
+ /* Must be on the same device */
+ errno = EXDEV;
+ return -1;
+ }
+
+ /* VMS_INO_T_COMPARE is true if the inodes are different
+ * to match the output of memcmp
+ */
+
+ if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
+ /* That was easy, the files are the same! */
+ return 0;
+ }
+
+ if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
+ /* If source is a directory, so must be dest */
+ errno = EISDIR;
+ return -1;
+ }
+
+ }
+
+
+ if ((dst_sts == 0) &&
+ (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
+
+ /* We have issues here if vms_unlink_all_versions is set
+ * If the destination exists, and is not a directory, then
+ * we must delete in advance.
+ *
+ * If the src is a directory, then we must always pre-delete
+ * the destination.
+ *
+ * If we successfully delete the dst in advance, and the rename fails
+ * X/Open requires that errno be EIO.
+ *
+ */
+
+ if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
+ int d_sts;
+ d_sts = mp_do_kill_file(aTHX_ dst, S_ISDIR(dst_st.st_mode));
+ if (d_sts != 0)
+ return d_sts;
+
+ /* We killed the destination, so only errno now is EIO */
+ pre_delete = 1;
+ }
+ }
+
+ /* Originally the idea was to call the CRTL rename() and only
+ * try the lib$rename_file if it failed.
+ * It turns out that there are too many variants in what the
+ * the CRTL rename might do, so only use lib$rename_file
+ */
+ retval = -1;
+
+ {
+ /* Is the source and dest both in VMS format */
+ /* if the source is a directory, then need to fileify */
+ /* and dest must be a directory or non-existant. */
+
+ char * vms_src;
+ char * vms_dst;
+ int sts;
+ char * ret_str;
+ unsigned long flags;
+ struct dsc$descriptor_s old_file_dsc;
+ struct dsc$descriptor_s new_file_dsc;
+
+ /* We need to modify the src and dst depending
+ * on if one or more of them are directories.
+ */
+
+ vms_src = PerlMem_malloc(VMS_MAXRSS);
+ if (vms_src == NULL)
+ _ckvmssts(SS$_INSFMEM);
+
+ /* Source is always a VMS format file */
+ ret_str = do_tovmsspec(src, vms_src, 0, NULL);
+ if (ret_str == NULL) {
+ PerlMem_free(vms_src);
+ errno = EIO;
+ return -1;
+ }
+
+ vms_dst = PerlMem_malloc(VMS_MAXRSS);
+ if (vms_dst == NULL)
+ _ckvmssts(SS$_INSFMEM);
+
+ if (S_ISDIR(src_st.st_mode)) {
+ char * ret_str;
+ char * vms_dir_file;
+
+ vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
+ if (vms_dir_file == NULL)
+ _ckvmssts(SS$_INSFMEM);
+
+ /* The source must be a file specification */
+ ret_str = do_fileify_dirspec(vms_src, vms_dir_file, 0, NULL);
+ if (ret_str == NULL) {
+ PerlMem_free(vms_src);
+ PerlMem_free(vms_dst);
+ PerlMem_free(vms_dir_file);
+ errno = EIO;
+ return -1;
+ }
+ PerlMem_free(vms_src);
+ vms_src = vms_dir_file;
+
+ /* If the dest is a directory, we must remove it
+ if (dst_sts == 0) {
+ int d_sts;
+ d_sts = mp_do_kill_file(aTHX_ dst, 1);
+ if (d_sts != 0) {
+ PerlMem_free(vms_src);
+ PerlMem_free(vms_dst);
+ errno = EIO;
+ return sts;
+ }
+
+ pre_delete = 1;
+ }
+
+ /* The dest must be a VMS file specification */
+ ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
+ if (ret_str == NULL) {
+ PerlMem_free(vms_src);
+ PerlMem_free(vms_dst);
+ errno = EIO;
+ return -1;
+ }
+
+ /* The source must be a file specification */
+ vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
+ if (vms_dir_file == NULL)
+ _ckvmssts(SS$_INSFMEM);
+
+ ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
+ if (ret_str == NULL) {
+ PerlMem_free(vms_src);
+ PerlMem_free(vms_dst);
+ PerlMem_free(vms_dir_file);
+ errno = EIO;
+ return -1;
+ }
+ PerlMem_free(vms_dst);
+ vms_dst = vms_dir_file;
+
+ } else {
+ /* File to file or file to new dir */
+
+ if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
+ /* VMS pathify a dir target */
+ ret_str = do_tovmspath(dst, vms_dst, 0, NULL);
+ if (ret_str == NULL) {
+ PerlMem_free(vms_src);
+ PerlMem_free(vms_dst);
+ errno = EIO;
+ return -1;
+ }
+ } else {
+
+ /* fileify a target VMS file specification */
+ ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
+ if (ret_str == NULL) {
+ PerlMem_free(vms_src);
+ PerlMem_free(vms_dst);
+ errno = EIO;
+ return -1;
+ }
+ }
+ }
+
+ old_file_dsc.dsc$a_pointer = vms_src;
+ old_file_dsc.dsc$w_length = strlen(vms_src);
+ old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
+ old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
+
+ new_file_dsc.dsc$a_pointer = vms_dst;
+ new_file_dsc.dsc$w_length = strlen(vms_dst);
+ new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
+ new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
+
+ flags = 0;
+#if !defined(__VAX) && defined(NAML$C_MAXRSS)
+ flags |= 2; /* LIB$M_FIL_LONG_NAMES */
+#endif
+
+ sts = lib$rename_file(&old_file_dsc,
+ &new_file_dsc,
+ NULL, NULL,
+ &flags,
+ NULL, NULL, NULL, NULL, NULL, NULL, NULL);
+ if (!$VMS_STATUS_SUCCESS(sts)) {
+
+ /* We could have failed because VMS style permissions do not
+ * permit renames that UNIX will allow. Just like the hack
+ * in for kill_file.
+ */
+ sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
+ }
+
+ PerlMem_free(vms_src);
+ PerlMem_free(vms_dst);
+ if (!$VMS_STATUS_SUCCESS(sts)) {
+ errno = EIO;
+ return -1;
+ }
+ retval = 0;
+ }
+
+ if (vms_unlink_all_versions) {
+ /* Now get rid of any previous versions of the source file that
+ * might still exist
+ */
+ int save_errno;
+ save_errno = errno;
+ src_sts = mp_do_kill_file(aTHX_ src, S_ISDIR(src_st.st_mode));
+ errno = save_errno;
+ }
+
+ /* We deleted the destination, so must force the error to be EIO */
+ if ((retval != 0) && (pre_delete != 0))
+ errno = EIO;
+
+ return retval;
+}
+/*}}}*/
+
+
+/*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
+/* Shortcut for common case of simple calls to $PARSE and $SEARCH
+ * to expand file specification. Allows for a single default file
+ * specification and a simple mask of options. If outbuf is non-NULL,
+ * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
+ * the resultant file specification is placed. If outbuf is NULL, the
+ * resultant file specification is placed into a static buffer.
+ * The third argument, if non-NULL, is taken to be a default file
+ * specification string. The fourth argument is unused at present.
+ * rmesexpand() returns the address of the resultant string if
+ * successful, and NULL on error.
+ *
+ * New functionality for previously unused opts value:
+ * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
+ * PERL_RMSEXPAND_M_LONG - Want output in long formst
+ * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
+ * PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
+ */
+static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
+
+static char *
+mp_do_rmsexpand
+ (pTHX_ const char *filespec,
+ char *outbuf,
+ int ts,
+ const char *defspec,
+ unsigned opts,
+ int * fs_utf8,
+ int * dfs_utf8)
+{
+ static char __rmsexpand_retbuf[VMS_MAXRSS];
+ char * vmsfspec, *tmpfspec;
+ char * esa, *cp, *out = NULL;
+ char * tbuf;
+ char * esal = NULL;
+ char * outbufl;
+ struct FAB myfab = cc$rms_fab;
+ rms_setup_nam(mynam);
+ STRLEN speclen;
+ unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
+ int sts;
+
+ /* temp hack until UTF8 is actually implemented */
+ if (fs_utf8 != NULL)
+ *fs_utf8 = 0;
+
+ if (!filespec || !*filespec) {
+ set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
+ return NULL;
+ }
+ if (!outbuf) {
+ if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
+ else outbuf = __rmsexpand_retbuf;
+ }
+
+ vmsfspec = NULL;
+ tmpfspec = NULL;
outbufl = NULL;
isunix = 0;
/* 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)
rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
#endif
+ /* We may not want to follow symbolic links */
+#ifdef NAML$M_OPEN_SPECIAL
+ if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
+ rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
+#endif
+
/* First attempt to parse as an existing file */
retsts = sys$parse(&myfab,0,0);
if (!(retsts & STS$K_SUCCESS)) {
if (outbufl != NULL)
PerlMem_free(outbufl);
PerlMem_free(esa);
- PerlMem_free(esal);
+ if (esal != NULL)
+ PerlMem_free(esal);
set_vaxc_errno(retsts);
if (retsts == RMS$_PRV) set_errno(EACCES);
else if (retsts == RMS$_DEV) set_errno(ENODEV);
if (outbufl != NULL)
PerlMem_free(outbufl);
PerlMem_free(esa);
- PerlMem_free(esal);
+ if (esal != NULL)
+ PerlMem_free(esal);
set_vaxc_errno(retsts);
if (retsts == RMS$_PRV) set_errno(EACCES);
else set_errno(EVMSERR);
/*------------------------------------*/
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(NAML$C_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);
if (decc_efs_case_preserve)
rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
#endif
+#ifdef NAML$M_OPEN_SPECIAL
+ if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
+ rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
+#endif
if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
if (trimver) {
trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
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(esa,outbuf,0,fs_utf8) == NULL) {
- if (out) Safefree(out);
- PerlMem_free(esal);
- PerlMem_free(esa);
- if (outbufl != 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(outbufl);
- return NULL;
+ return NULL;
+ }
}
+ else strcpy(outbuf, tbuf);
}
- else strcpy(outbuf,esa);
- }
- 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);
- PerlMem_free(esal);
+ if (esal != NULL)
+ PerlMem_free(esal);
PerlMem_free(tmpfspec);
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);
- PerlMem_free(esal);
+ if (esal != NULL)
+ PerlMem_free(esal);
if (outbufl != NULL)
PerlMem_free(outbufl);
return outbuf;
(!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
strcpy(trndir,*dir == '/' ? dir + 1: dir);
trnlnm_iter_count = 0;
- while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
+ while (!strpbrk(trndir,"/]>:") && my_trnlnm(trndir,trndir,0)) {
trnlnm_iter_count++;
if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
}
}
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. */
}
if ((*cp2 == '^')) {
/* EFS file escape, pass the next character as is */
- /* Fix me: HEX encoding for UNICODE not implemented */
+ /* Fix me: HEX encoding for Unicode not implemented */
cp2++;
}
else if ( *cp2 == '.') {
for (; cp2 <= dirend; cp2++) {
if ((*cp2 == '^')) {
/* EFS file escape, pass the next character as is */
- /* Fix me: HEX encoding for UNICODE not implemented */
- cp2++;
- *(cp1++) = *cp2;
+ /* Fix me: HEX encoding for Unicode not implemented */
+ *(cp1++) = *(++cp2);
+ /* An escaped dot stays as is -- don't convert to slash */
+ if (*cp2 == '.') cp2++;
}
if (*cp2 == ':') {
*(cp1++) = '/';
}
else *(cp1++) = *cp2;
}
- while (*cp2) *(cp1++) = *(cp2++);
+ while (*cp2) {
+ if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++; /* '^.' --> '.' */
+ *(cp1++) = *(cp2++);
+ }
*cp1 = '\0';
/* This still leaves /000000/ when working with a
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;
}
case '#':
case '%':
case '^':
+ /* Don't escape again if following character is
+ * already something we escape.
+ */
+ if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
+ *(cp1++) = *(cp2++);
+ break;
+ }
+ /* But otherwise fall through and escape it. */
case '&':
case '(':
case ')':
{ return do_tounixpath(path,buf,1,utf8_fl); }
/*
- * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
+ * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark AT infocomm DOT com)
*
*****************************************************************************
* *
- * Copyright (C) 1989-1994 by *
+ * Copyright (C) 1989-1994, 2007 by *
* Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
* *
- * Permission is hereby granted for the reproduction of this software, *
- * on condition that this copyright notice is included in the reproduction, *
- * and that such reproduction is not for purposes of profit or material *
- * gain. *
+ * Permission is hereby granted for the reproduction of this software *
+ * on condition that this copyright notice is included in source *
+ * distributions of the software. The code may be modified and *
+ * distributed under the same terms as Perl itself. *
* *
* 27-Aug-1994 Modified for inclusion in perl5 *
- * by Charles Bailey bailey@newman.upenn.edu *
+ * by Charles Bailey (bailey AT newman DOT upenn DOT edu) *
*****************************************************************************
*/
* of program. With suitable modification, it may useful for other
* portability problems as well.
*
- * Author: Mark Pizzolato mark@infocomm.com
+ * Author: Mark Pizzolato (mark AT infocomm DOT com)
*/
struct list_item
{
*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);
}
}
DIR *dd;
char *dir;
Stat_t sb;
- int unix_flag;
-
- unix_flag = 0;
- if (decc_efs_charset) {
- unix_flag = is_unix_filespec(name);
- }
Newx(dir, VMS_MAXRSS, char);
if (do_tovmspath(name,dir,0,NULL) == NULL) {
dd->context = 0;
dd->count = 0;
dd->flags = 0;
- if (unix_flag)
- dd->flags = PERL_VMSDIR_M_UNIXSPECS;
+ /* 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.
+ */
+ dd->flags = PERL_VMSDIR_M_UNIXSPECS;
dd->pat.dsc$a_pointer = dd->pattern;
dd->pat.dsc$w_length = strlen(dd->pattern);
dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
}
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
if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
/* Translate the encoded characters. */
- /* Fixme: unicode handling could result in embedded 0 characters */
+ /* Fixme: Unicode handling could result in embedded 0 characters */
if (strchr(dd->entry.d_name, '^') != NULL) {
char new_name[256];
char * q;
- int cnt;
p = dd->entry.d_name;
q = new_name;
while (*p != 0) {
- int x, y;
- x = copy_expand_vms_filename_escape(q, p, &y);
- p += x;
- q += y;
+ int inchars_read, outchars_added;
+ inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
+ p += inchars_read;
+ q += outchars_added;
/* fix-me */
- /* if y > 1, then this is a wide file specification */
+ /* if outchars_added > 1, then this is a wide file specification */
/* Wide file specifications need to be passed in Perl */
- /* counted strings apparently with a unicode flag */
+ /* counted strings apparently with a Unicode flag */
}
*q = 0;
strcpy(dd->entry.d_name, new_name);
+ dd->entry.d_namlen = strlen(dd->entry.d_name);
}
}
*
* 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));
}
Perl_cando_by_name_int
(pTHX_ I32 bit, bool effective, const char *fname, int opts)
{
- static char usrname[L_cuserid];
- static struct dsc$descriptor_s usrdsc =
+ char usrname[L_cuserid];
+ struct dsc$descriptor_s usrdsc =
{0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
- char vmsname[NAM$C_MAXRSS+1];
- char *fileified;
+ char *vmsname = NULL, *fileified = NULL;
unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
unsigned short int retlen, trnlnm_iter_count;
struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
{0,0,0,0}};
struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
+ Stat_t st;
+ static int profile_context = -1;
if (!fname || !*fname) return FALSE;
- /* Make sure we expand logical names, since sys$check_access doesn't */
- fileified = NULL;
- if ((opts & PERL_RMSEXPAND_M_VMS_IN) != 0) {
- fileified = PerlMem_malloc(VMS_MAXRSS);
- if (!strpbrk(fname,"/]>:")) {
+ /* Make sure we expand logical names, since sys$check_access doesn't */
+ fileified = PerlMem_malloc(VMS_MAXRSS);
+ if (fileified == NULL) _ckvmssts(SS$_INSFMEM);
+ if (!strpbrk(fname,"/]>:")) {
strcpy(fileified,fname);
trnlnm_iter_count = 0;
- while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
+ while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
trnlnm_iter_count++;
if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
}
fname = fileified;
- }
+ }
+
+ vmsname = PerlMem_malloc(VMS_MAXRSS);
+ if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
+ if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
+ /* Don't know if already in VMS format, so make sure */
if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
PerlMem_free(fileified);
+ PerlMem_free(vmsname);
return FALSE;
}
- retlen = namdsc.dsc$w_length = strlen(vmsname);
- namdsc.dsc$a_pointer = vmsname;
- if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
- vmsname[retlen-1] == ':') {
- if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) return FALSE;
- namdsc.dsc$w_length = strlen(fileified);
- namdsc.dsc$a_pointer = fileified;
- }
}
else {
- retlen = namdsc.dsc$w_length = strlen(fname);
- namdsc.dsc$a_pointer = (char *)fname; /* cast ok */
+ strcpy(vmsname,fname);
}
+ /* sys$check_access needs a file spec, not a directory spec.
+ * Don't use flex_stat here, as that depends on thread context
+ * having been initialized, and we may get here during startup.
+ */
+
+ retlen = namdsc.dsc$w_length = strlen(vmsname);
+ if (vmsname[retlen-1] == ']'
+ || vmsname[retlen-1] == '>'
+ || vmsname[retlen-1] == ':'
+ || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
+
+ if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
+ PerlMem_free(fileified);
+ PerlMem_free(vmsname);
+ return FALSE;
+ }
+ fname = fileified;
+ }
+ else {
+ fname = vmsname;
+ }
+
+ retlen = namdsc.dsc$w_length = strlen(fname);
+ namdsc.dsc$a_pointer = (char *)fname;
+
switch (bit) {
case S_IXUSR: case S_IXGRP: case S_IXOTH:
access = ARM$M_EXECUTE;
default:
if (fileified != NULL)
PerlMem_free(fileified);
+ if (vmsname != NULL)
+ PerlMem_free(vmsname);
return FALSE;
}
/* find out the space required for the profile */
_ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
- &usrprodsc.dsc$w_length,0));
+ &usrprodsc.dsc$w_length,&profile_context));
/* allocate space for the profile and get it filled in */
usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
_ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
- &usrprodsc.dsc$w_length,0));
+ &usrprodsc.dsc$w_length,&profile_context));
/* use the profile to check access to the file; free profile & analyze results */
- retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
+ retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
PerlMem_free(usrprodsc.dsc$a_pointer);
if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
else set_errno(ENOENT);
if (fileified != NULL)
PerlMem_free(fileified);
+ if (vmsname != NULL)
+ PerlMem_free(vmsname);
return FALSE;
}
if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
if (fileified != NULL)
PerlMem_free(fileified);
+ if (vmsname != NULL)
+ PerlMem_free(vmsname);
return TRUE;
}
_ckvmssts(retsts);
if (fileified != NULL)
PerlMem_free(fileified);
+ if (vmsname != NULL)
+ PerlMem_free(vmsname);
return FALSE; /* Should never get here */
}
*
* If we are in Posix filespec mode, accept the filename as is.
*/
+
+
+#if __CRTL_VER >= 70300000 && !defined(__VAX)
+ /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
+ * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
+ */
+ if (!decc_efs_charset)
+ decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
+#endif
+
#if __CRTL_VER >= 80200000 && !defined(__VAX)
if (decc_posix_compliant_pathnames == 0) {
#endif
retval = lstat(temp_fspec,(stat_t *) statbufp);
save_spec = temp_fspec;
}
+/*
+ * In debugging, on 8.3 Alpha, I found a case where stat was returning a
+ * file not found error for a directory named foo:[bar.t] or /foo/bar/t
+ * and lstat was working correctly for the same file.
+ * The only syntax that was working for stat was "foo:[bar]t.dir".
+ *
+ * Other directories with the same syntax worked fine.
+ * So work around the problem when it shows up here.
+ */
+ if (retval) {
+ int save_errno = errno;
+ if (do_tovmsspec(fspec, temp_fspec, 0, NULL) != NULL) {
+ if (do_fileify_dirspec(temp_fspec, fileified, 0, NULL) != NULL) {
+ retval = stat(fileified, (stat_t *) statbufp);
+ save_spec = fileified;
+ }
+ }
+ /* Restore the errno value if third stat does not succeed */
+ if (retval != 0)
+ errno = save_errno;
+ }
#if __CRTL_VER >= 80200000 && !defined(__VAX)
} else {
if (lstat_flag == 0)
save_spec = temp_fspec;
}
#endif
+
+#if __CRTL_VER >= 70300000 && !defined(__VAX)
+ /* As you were... */
+ if (!decc_efs_charset)
+ decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
+#endif
+
if (!retval) {
char * cptr;
+ 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 ((tmpfp = PerlIO_tmpfile()) != NULL) {
+ int found = 0;
Stat_t st;
int stat_sts;
stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
if (!stat_sts && S_ISDIR(st.st_mode)) {
wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
ok = (wilddsc.dsc$a_pointer != NULL);
+ /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
+ hasdir = 1;
}
else {
wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
if (!$VMS_STATUS_SUCCESS(sts))
break;
+ found++;
+
/* with varying string, 1st word of buffer contains result length */
rstr[rslt->length] = '\0';
ok = (PerlIO_puts(tmpfp,begin) != EOF);
}
if (cxt) (void)lib$find_file_end(&cxt);
+
+ if (!found) {
+ /* Be POSIXish: return the input pattern when no matches */
+ strcpy(rstr,SvPVX(tmpglob));
+ strcat(rstr,"\n");
+ ok = (PerlIO_puts(tmpfp,rstr) != EOF);
+ }
+
if (ok && sts != RMS$_NMF &&
sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
if (!ok) {
}
-#ifdef HAS_SYMLINK
static char *
-mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec, const int *utf8_fl);
+mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
+ 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,
+ 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_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
+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
vms_debug_on_exception = 0;
}
- /* Create VTF-7 filenames from UNICODE instead of UTF-8 */
+ /* Create VTF-7 filenames from Unicode instead of UTF-8 */
vms_vtf7_filenames = 0;
status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
if ($VMS_STATUS_SUCCESS(status)) {
vms_vtf7_filenames = 0;
}
+
+ /* unlink all versions on unlink() or rename() */
+ vms_unlink_all_versions = 0;
+ status = sys_trnlnm
+ ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
+ if ($VMS_STATUS_SUCCESS(status)) {
+ if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
+ vms_unlink_all_versions = 1;
+ else
+ vms_unlink_all_versions = 0;
+ }
+
/* Dectect running under GNV Bash or other UNIX like shell */
#if __CRTL_VER >= 70300000 && !defined(__VAX)
gnv_unix_shell = 0;
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;
}
else
gnv_unix_shell = 0;
}
#ifdef __DECC
-/* DECC dependent attributes */
-#if __DECC_VER < 60560002
-#define relative
-#define not_executable
-#else
-#define relative ,rel
-#define not_executable ,noexe
-#endif
#pragma nostandard
#pragma extern_model save
#pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
-#endif
const __align (LONGWORD) int spare[8] = {0};
-/* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
-/* NOWRT, LONG */
-#ifdef __DECC
-#pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
- nowrt,noshr relative not_executable
+
+/* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
+#if __DECC_VER >= 60560002
+#pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
+#else
+#pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
#endif
+#endif /* __DECC */
+
const long vms_cc_features = (const long)set_features;
/*
projects / p5sagit/p5-mst-13.2.git / blobdiff