In t/io/fs.t:
The tmp directory may be created with out having delete protection, so
the spawned DCL command fails to delete it. This can cause extra output
in the test.
In doio.c:
Remove the VMS specific code and replace with a subroutine call to it's
new location in VMS.C.
In vms.c:
Fine tune previous readdir() code to work better with EFS character sets.
Add new routine Perl_vms_start_glob() based on code that formerly was in
doio.c, but changed to remove the dependencies the path length, and
improve the parsing and UNIX conversion of the resulting file
specifications.
Existing bugs on the input file specifications of UNIX "./x" and "x[x]"
style file specifications not changed by this patch.
Added the return of an additional status value to the LIB$FIND_FILE
calls, to allow better diagnostics when running under debug.
Fix Perl_my_chdir() to actually use the directory specification with the
leading spaces trimmed. This is actually to compensate for what appears
to be a common bug in the test scripts.
The output of the DCL "SHOW DEFAULT" command has leading spaces. When
the DECC$EFS_CHARSET feature is disabled (default), the chdir() routine
is forgiving and ignores the leading spaces.
When DECC$EFS_CHARSET is enabled, OpenVMS file specifications can have
leading spaces, so the chdir() will fail if the leading spaces are not
trimmed.
It is unlikely that someone will create a directory in UNIX syntax with
leading spaces in the name, but it was either put this hack in
Perl_my_chdir() or require everywhere that someone spawns a "SHOW
DEFAULT" command that they clean up the output.
After this patch is applied, I need to fixup the locations in VMS.C that
are doing internal temporary conversions from UNIX to VMS to use
RMSEXPAND instead of vmsify to force the resulting VMS file
specification to fit in 255 characters.
After that, I will be able to make the long filename mode live on the
versions of OpenVMS that support it.
-John
[EMAIL PROTECTED]
Personal Opinion Only
--- /rsync_root/perl/doio.c Tue Feb 7 22:24:37 2006
+++ doio.c Sat Feb 18 15:42:09 2006
@@ -2317,89 +2317,14 @@
SAVEFREESV(tmpcmd);
#ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
/* since spawning off a process is a real performance hit */
- {
-#include <descrip.h>
-#include <lib$routines.h>
-#include <nam.h>
-#include <rmsdef.h>
- char rslt[NAM$C_MAXRSS+1+sizeof(unsigned short int)] = {'\0','\0'};
- char vmsspec[NAM$C_MAXRSS+1];
- char * const rstr = rslt + sizeof(unsigned short int);
- char *begin, *end, *cp;
- $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
- PerlIO *tmpfp;
- STRLEN i;
- struct dsc$descriptor_s wilddsc
- = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
- struct dsc$descriptor_vs rsdsc
- = {sizeof rslt, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, rslt};
- unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0, hasver = 0,
isunix = 0;
- /* We could find out if there's an explicit dev/dir or version
- by peeking into lib$find_file's internal context at
- ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
- but that's unsupported, so I don't want to do it now and
- have it bite someone in the future. */
- cp = SvPV(tmpglob,i);
- for (; i; i--) {
- if (cp[i] == ';') hasver = 1;
- if (cp[i] == '.') {
- if (sts) hasver = 1;
- else sts = 1;
- }
- if (cp[i] == '/') {
- hasdir = isunix = 1;
- break;
- }
- if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
- hasdir = 1;
- break;
- }
- }
- if ((tmpfp = PerlIO_tmpfile()) != NULL) {
- Stat_t st;
- if (!PerlLIO_stat(SvPVX_const(tmpglob),&st) && S_ISDIR(st.st_mode))
- ok = ((wilddsc.dsc$a_pointer =
tovmspath(SvPVX(tmpglob),vmsspec)) != NULL);
- else ok = ((wilddsc.dsc$a_pointer =
tovmsspec(SvPVX(tmpglob),vmsspec)) != NULL);
- if (ok) wilddsc.dsc$w_length = (unsigned short int)
strlen(wilddsc.dsc$a_pointer);
- for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
- if (*cp == '?') *cp = '%'; /* VMS style single-char wildcard */
- while (ok && ((sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
- &dfltdsc,NULL,NULL,NULL))&1)) {
- /* with varying string, 1st word of buffer contains result
length */
- end = rstr + *((unsigned short int*)rslt);
- if (!hasver) while (*end != ';' && end > rstr) end--;
- *(end++) = '\n'; *end = '\0';
- for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
- if (hasdir) {
- if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
- begin = rstr;
- }
- else {
- begin = end;
- while (*(--begin) != ']' && *begin != '>') ;
- ++begin;
- }
- ok = (PerlIO_puts(tmpfp,begin) != EOF);
- }
- if (cxt) (void)lib$find_file_end(&cxt);
- if (ok && sts != RMS$_NMF &&
- sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
- if (!ok) {
- if (!(sts & 1)) {
- SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
- }
- PerlIO_close(tmpfp);
- fp = NULL;
- }
- else {
- PerlIO_rewind(tmpfp);
- IoTYPE(io) = IoTYPE_RDONLY;
- IoIFP(io) = fp = tmpfp;
- IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
- }
- }
- }
+PerlIO *
+Perl_vms_start_glob
+ (pTHX_ SV *tmpglob,
+ IO *io);
+
+ fp = Perl_vms_start_glob(tmpglob, io);
+
#else /* !VMS */
#ifdef MACOS_TRADITIONAL
sv_setpv(tmpcmd, "glob ");
--- /rsync_root/perl/vms/vms.c Tue Feb 14 23:32:29 2006
+++ vms/vms.c Sun Feb 19 19:49:54 2006
@@ -174,6 +174,11 @@
char * component;
};
+struct vs_str_st {
+ unsigned short length;
+ char str[65536];
+};
+
#ifdef __DECC
#pragma message restore
#pragma member_alignment restore
@@ -386,17 +391,17 @@
*/
static int vms_split_path
(const char * path,
- const char ** volume,
+ char * * volume,
int * vol_len,
- const char ** root,
+ char * * root,
int * root_len,
- const char ** dir,
+ char * * dir,
int * dir_len,
- const char ** name,
+ char * * name,
int * name_len,
- const char ** ext,
+ char * * ext,
int * ext_len,
- const char ** version,
+ char * * version,
int * ver_len)
{
struct dsc$descriptor path_desc;
@@ -1822,12 +1827,12 @@
* - Preview- '/' will be valid soon on VMS
*/
if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
- char *newdir = savepvn(dir,dirlen-1);
+ char *newdir = savepvn(dir1,dirlen-1);
int ret = chdir(newdir);
Safefree(newdir);
return ret;
}
- else return chdir(dir);
+ else return chdir(dir1);
} /* end of my_chdir */
/*}}}*/
@@ -7074,6 +7079,7 @@
$DESCRIPTOR(resultspec, "");
unsigned long int lff_flags = 0;
int sts;
+int rms_sts;
#ifdef VMS_LONGNAME_SUPPORT
lff_flags = LIB$M_FIL_LONG_NAMES;
@@ -7123,7 +7129,7 @@
while ($VMS_STATUS_SUCCESS(sts = lib$find_file
(&filespec, &resultspec, &context,
- &defaultspec, 0, 0, &lff_flags)))
+ &defaultspec, 0, &rms_sts, &lff_flags)))
{
char *string;
char *c;
@@ -7917,7 +7923,7 @@
unsigned long int tmpsts;
unsigned long rsts;
unsigned long flags = 0;
- const char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_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;
/* Set up result descriptor, and get next file. */
@@ -7980,6 +7986,13 @@
&vs_spec,
&vs_len);
+ /* Drop NULL extensions on UNIX file specification */
+ if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
+ (e_len == 1) && decc_readdir_dropdotnotype)) {
+ e_len = 0;
+ e_spec[0] = '\0';
+ }
+
strncpy(dd->entry.d_name, n_spec, n_len + e_len);
dd->entry.d_name[n_len + e_len] = '\0';
dd->entry.d_namlen = strlen(dd->entry.d_name);
@@ -7996,32 +8009,18 @@
p = dd->entry.d_name;
q = new_name;
while (*p != 0) {
- if ((*p == '.') && (p[1] == 0) && decc_readdir_dropdotnotype) {
- /* Normally trailing dots should be dropped */
- p++;
- }
- else {
- int x, y;
- x = copy_expand_vms_filename_escape(q, p, &y);
- p += x;
- q += y;
- /* fix-me */
- /* if y > 1, then this is a wide file specification */
- /* Wide file specifications need to be passed in Perl */
- /* counted strings apparently with a unicode flag */
- }
+ int x, y;
+ x = copy_expand_vms_filename_escape(q, p, &y);
+ p += x;
+ q += y;
+ /* fix-me */
+ /* if y > 1, then this is a wide file specification */
+ /* Wide file specifications need to be passed in Perl */
+ /* counted strings apparently with a unicode flag */
}
*q = 0;
strcpy(dd->entry.d_name, new_name);
}
- else {
- /* Remove a trailing "." if present and not preceded by a ^ */
- if ((dd->entry.d_name[dd->entry.d_namlen-1] == '.') &&
- decc_readdir_dropdotnotype) {
- dd->entry.d_namlen--;
- dd->entry.d_name[dd->entry.d_namlen] == 0;
- }
- }
}
dd->entry.vms_verscount = 0;
@@ -8276,19 +8275,20 @@
}
if (!isdcl) {
+ int rsts;
imgdsc.dsc$a_pointer = s;
imgdsc.dsc$w_length = wordbreak - s;
- retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
+ retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
if (!(retsts&1)) {
_ckvmssts(lib$find_file_end(&cxt));
- retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
+ retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
if (!(retsts & 1) && *s == '$') {
_ckvmssts(lib$find_file_end(&cxt));
imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
- retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
+ retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
if (!(retsts&1)) {
_ckvmssts(lib$find_file_end(&cxt));
- retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
+ retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
}
}
}
@@ -10982,6 +10982,170 @@
}
ST(0) = boolSV(VMSISH_HUSHED);
XSRETURN(1);
+}
+
+
+PerlIO *
+Perl_vms_start_glob
+ (pTHX_ SV *tmpglob,
+ IO *io)
+{
+ PerlIO *fp;
+ struct vs_str_st *rslt;
+ char *vmsspec;
+ char *rstr;
+ char *begin, *cp;
+ $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
+ PerlIO *tmpfp;
+ STRLEN i;
+ struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
+ struct dsc$descriptor_vs rsdsc;
+ unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
+ unsigned long hasver = 0, isunix = 0;
+ unsigned long int lff_flags = 0;
+ int rms_sts;
+
+#ifdef VMS_LONGNAME_SUPPORT
+ lff_flags = LIB$M_FIL_LONG_NAMES;
+#endif
+ /* The Newx macro will not allow me to assign a smaller array
+ * to the rslt pointer, so we will assign it to the begin char pointer
+ * and then copy the value into the rslt pointer.
+ */
+ Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
+ rslt = (struct vs_str_st *)begin;
+ rslt->length = 0;
+ rstr = &rslt->str[0];
+ rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
+ rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
+ rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
+ rsdsc.dsc$b_class = DSC$K_CLASS_VS;
+
+ Newx(vmsspec, VMS_MAXRSS, char);
+
+ /* We could find out if there's an explicit dev/dir or version
+ by peeking into lib$find_file's internal context at
+ ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
+ but that's unsupported, so I don't want to do it now and
+ have it bite someone in the future. */
+ /* Fix-me: vms_split_path() is the only way to do this, the
+ existing method will fail with many legal EFS or UNIX specifications
+ */
+
+ cp = SvPV(tmpglob,i);
+
+ for (; i; i--) {
+ if (cp[i] == ';') hasver = 1;
+ if (cp[i] == '.') {
+ if (sts) hasver = 1;
+ else sts = 1;
+ }
+ if (cp[i] == '/') {
+ hasdir = isunix = 1;
+ break;
+ }
+ if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
+ hasdir = 1;
+ break;
+ }
+ }
+ if ((tmpfp = PerlIO_tmpfile()) != NULL) {
+ 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(SvPVX(tmpglob),vmsspec);
+ ok = (wilddsc.dsc$a_pointer != NULL);
+ }
+ else {
+ wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec);
+ ok = (wilddsc.dsc$a_pointer != NULL);
+ }
+ if (ok)
+ wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
+
+ /* If not extended character set, replace ? with % */
+ /* With extended character set, ? is a wildcard single character */
+ if (!decc_efs_case_preserve) {
+ for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
+ if (*cp == '?') *cp = '%';
+ }
+ sts = SS$_NORMAL;
+ while (ok && $VMS_STATUS_SUCCESS(sts)) {
+ char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
+ int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
+
+ sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
+ &dfltdsc,NULL,&rms_sts,&lff_flags);
+ if (!$VMS_STATUS_SUCCESS(sts))
+ break;
+
+ /* with varying string, 1st word of buffer contains result length */
+ rstr[rslt->length] = '\0';
+
+ /* Find where all the components are */
+ v_sts = vms_split_path
+ (rstr,
+ &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 no version on input, truncate the version on output */
+ if (!hasver && (vs_len > 0)) {
+ *vs_spec = '\0';
+ vs_len = 0;
+
+ /* No version & a null extension on UNIX handling */
+ if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
+ e_len = 0;
+ *e_spec = '\0';
+ }
+ }
+
+ if (!decc_efs_case_preserve) {
+ for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
+ }
+
+ if (hasdir) {
+ if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
+ begin = rstr;
+ }
+ else {
+ /* Start with the name */
+ begin = n_spec;
+ }
+ strcat(begin,"\n");
+ ok = (PerlIO_puts(tmpfp,begin) != EOF);
+ }
+ if (cxt) (void)lib$find_file_end(&cxt);
+ if (ok && sts != RMS$_NMF &&
+ sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
+ if (!ok) {
+ if (!(sts & 1)) {
+ SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
+ }
+ PerlIO_close(tmpfp);
+ fp = NULL;
+ }
+ else {
+ PerlIO_rewind(tmpfp);
+ IoTYPE(io) = IoTYPE_RDONLY;
+ IoIFP(io) = fp = tmpfp;
+ IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
+ }
+ }
+ Safefree(vmsspec);
+ Safefree(rslt);
+ return fp;
}
#ifdef HAS_SYMLINK
--- /rsync_root/perl/t/io/fs.t Tue Nov 8 09:52:28 2005
+++ t/io/fs.t Sun Feb 19 19:40:19 2006
@@ -58,6 +58,7 @@
}
elsif ($^O eq 'VMS') {
`if f\$search("[.tmp]*.*") .nes. "" then delete/nolog/noconfirm
[.tmp]*.*.*`;
+ `if f\$search("tmp.dir") .nes. "" then set file/prot=o:rwed tmp.dir;`;
`if f\$search("tmp.dir") .nes. "" then delete/nolog/noconfirm tmp.dir;`;
`create/directory [.tmp]`;
}
