[blead-227-gbd2db5d] vms logical name/ feature fixes
[email protected] (John Malmberg)
| Newsgroups | perl.perl5.porters,perl.vmsperl |
|---|---|
| Message-ID | <[email protected]> |
I have locally the UNIX Report mode running. This exercise exposed many bugs in VMS.C. I will be submitting these as a series of unified diffs identifying the specific bug that is fixed to make it easier to backport into remedial streams. This first fixes are: * The checks for the feature logicals was not always case insensitive. * The check for DECC$DISABLE_POSIX_ROOT does not work in the LIB$INITIALIZE section on a threaded Perl, so I had to move it. * simple_trnlnm is used for logical name lookups that are part of the file system instead if my_trnlnm. One reason for this is that most of the routines in vms.c are called on a threaded perl before the implicit context is enabled. If an error or warning occurs during one of those calls, the error/warning handler will access violate. So as part of these fixes, I will be removing the implicit context where ever possible. * New feature / debug logical name settings that will be used in the future have been added. * Obsolete feature / debug logical name settings have been removed. -John [email protected] Personal Opinion Only
vms_trnlnm.gdiff
(text/plain, 10.7 KB)
--- /rsync_root/perl/vms/vms.c Fri Dec 5 12:13:19 2008
+++ vms/vms.c Sun Jan 4 22:26:15 2009
@@ -344,6 +344,7 @@
static int decc_disable_posix_root = 1;
int decc_efs_case_preserve = 0;
static int decc_efs_charset = 0;
+static int decc_efs_charset_index = -1;
static int decc_filename_unix_no_version = 0;
static int decc_filename_unix_only = 0;
int decc_filename_unix_report = 0;
@@ -356,12 +357,45 @@
static int vms_posix_exit = 0;
/* bug workarounds if needed */
-int decc_bug_readdir_efs1 = 0;
int decc_bug_devnull = 1;
-int decc_bug_fgetname = 0;
int decc_dir_barename = 0;
+int vms_bug_stat_filename = 0;
static int vms_debug_on_exception = 0;
+static int vms_debug_fileify = 0;
+
+/* Simple logical name translation */
+static int simple_trnlnm
+ (const char * logname,
+ char * value,
+ int value_len)
+{
+ const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
+ const unsigned long attr = LNM$M_CASE_BLIND;
+ struct dsc$descriptor_s name_dsc;
+ int status;
+ unsigned short result;
+ struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
+ {0, 0, 0, 0}};
+
+ name_dsc.dsc$w_length = strlen(logname);
+ name_dsc.dsc$a_pointer = (char *)logname;
+ name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
+ name_dsc.dsc$b_class = DSC$K_CLASS_S;
+
+ status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
+
+ if ($VMS_STATUS_SUCCESS(status)) {
+
+ /* Null terminate and return the string */
+ /*--------------------------------------*/
+ value[result] = 0;
+ return result;
+ }
+
+ return 0;
+}
+
/* Is this a UNIX file specification?
* No longer a simple check with EFS file specs
@@ -5766,7 +5800,7 @@
(!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,"/]>:") && simple_trnlnm(trndir,trndir,0)) {
trnlnm_iter_count++;
if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
}
@@ -6259,7 +6293,7 @@
trnlnm_iter_count = 0;
while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
- && my_trnlnm(trndir,trndir,0)) {
+ && simple_trnlnm(trndir,trndir,0)) {
trnlnm_iter_count++;
if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
trnlen = strlen(trndir);
@@ -6670,7 +6704,7 @@
if (cmp_rslt == 0) {
int islnm;
- islnm = my_trnlnm(tmp, "TMP", 0);
+ islnm = simple_trnlnm(tmp, "TMP", 0);
if (!islnm) {
strcpy(rslt, "/tmp");
cp1 = cp1 + 4;
@@ -7982,7 +8016,7 @@
*cp1 = '\0';
trndev = PerlMem_malloc(VMS_MAXRSS);
if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
- islnm = my_trnlnm(rslt,trndev,0);
+ islnm = simple_trnlnm(rslt,trndev,0);
/* DECC special handling */
if (!islnm) {
@@ -7990,13 +8024,13 @@
strcpy(rslt,"sys$system");
cp1 = rslt + 10;
*cp1 = 0;
- islnm = my_trnlnm(rslt,trndev,0);
+ islnm = simple_trnlnm(rslt,trndev,0);
}
else if (strcmp(rslt,"tmp") == 0) {
strcpy(rslt,"sys$scratch");
cp1 = rslt + 11;
*cp1 = 0;
- islnm = my_trnlnm(rslt,trndev,0);
+ islnm = simple_trnlnm(rslt,trndev,0);
}
else if (!decc_disable_posix_root) {
strcpy(rslt, "sys$posix_root");
@@ -8004,7 +8038,7 @@
*cp1 = 0;
cp2 = path;
while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
- islnm = my_trnlnm(rslt,trndev,0);
+ islnm = simple_trnlnm(rslt,trndev,0);
}
else if (strcmp(rslt,"dev") == 0) {
if (strncmp(cp2,"/null", 5) == 0) {
@@ -8013,7 +8047,7 @@
cp1 = rslt + 4;
*cp1 = 0;
cp2 = cp2 + 5;
- islnm = my_trnlnm(rslt,trndev,0);
+ islnm = simple_trnlnm(rslt,trndev,0);
}
}
}
@@ -8974,6 +9008,8 @@
void
vms_image_init(int *argcp, char ***argvp)
{
+ int status;
+ char val_str[10];
char eqv[LNM$C_NAMLENGTH+1] = "";
unsigned int len, tabct = 8, tabidx = 0;
unsigned long int *mask, iosb[2], i, rlst[128], rsz;
@@ -8992,6 +9028,35 @@
Perl_csighandler_init();
#endif
+ /* This was moved from the pre-image init handler because on threaded */
+ /* Perl it was always returning 0 for the default value. */
+ status = simple_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
+ if (status > 0) {
+ int s;
+ s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
+ if (s > 0) {
+ int initial;
+ initial = decc$feature_get_value(s, 4);
+ if (initial >= 0) {
+ /* initial is -1 if nothing has set the feature */
+ /* initial is 1 if the logical name is present */
+ decc_disable_posix_root = decc$feature_get_value(s, 1);
+
+ /* If the value is not valid, force the feature off */
+ if (decc_disable_posix_root < 0) {
+ decc$feature_set_value(s, 1, 1);
+ decc_disable_posix_root = 1;
+ }
+ }
+ else {
+ /* Traditionally Perl assumes this is off */
+ decc_disable_posix_root = 1;
+ decc$feature_set_value(s, 1, 1);
+ }
+ }
+ }
+
+
_ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
_ckvmssts_noperl(iosb[0]);
for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
@@ -13529,7 +13594,6 @@
{
int status;
int s;
- int dflt;
char* str;
char val_str[10];
#if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
@@ -13543,28 +13607,62 @@
vms_debug_on_exception = 0;
status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
if ($VMS_STATUS_SUCCESS(status)) {
+ val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
vms_debug_on_exception = 1;
else
vms_debug_on_exception = 0;
}
+ /* Debug unix/vms file translation routines */
+ vms_debug_fileify = 0;
+ status = sys_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
+ if ($VMS_STATUS_SUCCESS(status)) {
+ val_str[0] = _toupper(val_str[0]);
+ if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
+ vms_debug_fileify = 1;
+ else
+ vms_debug_fileify = 0;
+ }
+
+
+ /* Historically PERL has been doing vmsify / stat differently than */
+ /* the CRTL. In particular, under some conditions the CRTL will */
+ /* remove some illegal characters like spaces from filenames */
+ /* resulting in some differences. The stat()/lstat() wrapper has */
+ /* been reporting such file names as invalid and fails to stat them */
+ /* fixing this bug so that stat()/lstat() accept these like the */
+ /* CRTL does will result in several tests failing. */
+ /* This should really be fixed, but for now, set up a feature to */
+ /* enable it so that the impact can be studied. */
+ vms_bug_stat_filename = 0;
+ status = sys_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
+ if ($VMS_STATUS_SUCCESS(status)) {
+ val_str[0] = _toupper(val_str[0]);
+ if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
+ vms_bug_stat_filename = 1;
+ else
+ vms_bug_stat_filename = 0;
+ }
+
+
/* 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)) {
+ val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
vms_vtf7_filenames = 1;
else
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)) {
+ val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
vms_unlink_all_versions = 1;
else
@@ -13590,40 +13688,22 @@
/* hacks to see if known bugs are still present for testing */
- /* Readdir is returning filenames in VMS syntax always */
- decc_bug_readdir_efs1 = 1;
- status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
- if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
- decc_bug_readdir_efs1 = 1;
- else
- decc_bug_readdir_efs1 = 0;
- }
-
/* PCP mode requires creating /dev/null special device file */
decc_bug_devnull = 0;
status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
if ($VMS_STATUS_SUCCESS(status)) {
+ val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
decc_bug_devnull = 1;
else
decc_bug_devnull = 0;
}
- /* fgetname returning a VMS name in UNIX mode */
- decc_bug_fgetname = 1;
- status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
- if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
- decc_bug_fgetname = 1;
- else
- decc_bug_fgetname = 0;
- }
-
/* UNIX directory names with no paths are broken in a lot of places */
decc_dir_barename = 1;
status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
if ($VMS_STATUS_SUCCESS(status)) {
+ val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
decc_dir_barename = 1;
else
@@ -13646,6 +13726,7 @@
}
s = decc$feature_get_index("DECC$EFS_CHARSET");
+ decc_efs_charset_index = s;
if (s >= 0) {
decc_efs_charset = decc$feature_get_value(s, 1);
if (decc_efs_charset < 0)
@@ -13688,26 +13769,6 @@
decc_readdir_dropdotnotype = 0;
}
- status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
- if ($VMS_STATUS_SUCCESS(status)) {
- s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
- if (s >= 0) {
- dflt = decc$feature_get_value(s, 4);
- if (dflt > 0) {
- decc_disable_posix_root = decc$feature_get_value(s, 1);
- if (decc_disable_posix_root <= 0) {
- decc$feature_set_value(s, 1, 1);
- decc_disable_posix_root = 1;
- }
- }
- else {
- /* Traditionally Perl assumes this is off */
- decc_disable_posix_root = 1;
- decc$feature_set_value(s, 1, 1);
- }
- }
- }
-
#if __CRTL_VER >= 80200000
s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
if (s >= 0) {
@@ -13791,6 +13852,7 @@
status = sys_trnlnm
("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
if ($VMS_STATUS_SUCCESS(status)) {
+ val_str[0] = _toupper(val_str[0]);
if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
vms_posix_exit = 1;
else