"John E. Malmberg" <[EMAIL PROTECTED]> wrote on 04/11/2004 11:37:38 PM:
Case preservation sounds quite useful. For whatever it might* Case needs to be preserved. Currently Perl always lowercases filenames if any mixed case is found.
be worth perl currently has trouble not only with ODS-5's
ability to preserve case, but also at least the ^. escape
for multiple periods.
I would expect ODS-5 escape sequences and alternate notation will be present when both the DECC filename features FILENAME_REPORT_UNIX or FILENAME_UNIX_ONLY are off.
This is something that PERL will need to be modified to deal with. It is beyond the scope of what I am trying to accomplish.
* All input filespecs need to be interpreted as UNIX format
This implies that "." needs to be interpreted as the current
directory.
Hmm - how about "./" or "../" - are they still OK?
Already covered. The "/" makes perl treat them as UNIX format.
* The patch wants to use the CRTL unlink() function instead of kill_all. I do not know why. It also wants the "unlink_all_versions" defined.
My error. It wants "UNLINK_ALL_VERSIONS" defined.
You might consider whether it could (easily) be added to the vmsish.pm pragmitc module such that you could modify your scripts to say:
use vmsish qw(unlink_all_version);
to turn on the behavior.
There are two reasons that I can not do this.
1. I do not know perl at all.
2. I may not be able to modify the scripts. They may be generated on the fly by a build procedure.
I think that Craig has already pointed out that your arguments to GNU diff were reversed.
Yes, my error.
$ IF be_case_sensitive THEN WC "#define VMS_WE_ARE_CASE_SENSITIVE" -$ IF d_unlink_all_versions then wc "#define ulink_all_versions"
.............................................^^^^^ This bit looks like a typographical error. In your proposed modificaiton to vms.c the C preprocessor macro that you #ifndef branch on is then called unlink_all_versions with an "n":
No, unlink_all_versions would be either be not defined, or defined with a default value of 1.
Of course since the macro needs to be UNLINK_ALL_VERSIONS the previous patch only would break things if it even worked.
Perhaps such changes could be submitted to the vmsperl branch in Perforce?
Only after all tests have been passed and it has been reviewed by others.
As of current OpenVMS Alpha, the behavior of the unlink() function has changed if the ODS-5 volume is set to have hardlinks enabled. With out hardlinks active, it behaves the same as remove().
This apparently is significant to the building of GTK+.
With the patches that I have attached now, Perl is only failing one test.
lib/ExtUtils/t/basic.................FAILED at test 28
I do not have hard links enabled on the ODS-5 volume. I do not know if that is affecting the test results.
I also do not know how to trouble shoot this failed test to find out what is wrong, and how to make the test pass.
With only one test failing though, it looks a lot better.
Now how do get a more verbose output of the failing test?
I hope I do not need to build a debug version of perl, I have not got that to work yet on VAX.
-John [EMAIL PROTECTED] Personal Opinion Only
--- dist_root:[000000]configure.com_old Sun Apr 11 21:58:27 2004
+++ dist_root:[000000]configure.com Sat Apr 24 22:31:30 2004
@@ -44,6 +44,7 @@
$ user_c_flags = ""
$ use_ieee_math = "y"
$ be_case_sensitive = "n"
+$ unlink_all_versions = "n"
$ use_vmsdebug_perl = "n"
$ use64bitall = "n"
$ use64bitint = "n"
@@ -880,7 +881,7 @@
$ config_symbols1
="|installprivlib|installscript|installsitearch|installsitelib|most|oldarchlib|oldarchlibexp|osname|pager|perl_symbol|perl_verb|"
$ config_symbols2
="|prefix|privlib|privlibexp|scriptdir|sitearch|sitearchexp|sitebin|sitelib|sitelib_stem|sitelibexp|try_cxx|use64bitall|use64bitint|"
$ config_symbols3
="|usecasesensitive|usedefaulttypes|usedevel|useieee|useithreads|usemultiplicity|usemymalloc|usedebugging_perl|useperlio|usesecurelog|"
-$ config_symbols4 ="|usethreads|usevmsdebug|usefaststdio|usemallocwrap|"
+$ config_symbols4
="|usethreads|usevmsdebug|usefaststdio|usemallocwrap|unlink_all_versions|"
$!
$ open/read CONFIG 'config_sh'
$ rd_conf_loop:
@@ -2442,6 +2443,27 @@
$ use_ieee_math = "n"
$ ENDIF
$ useieee = "undef"
+$! Unlink all versions?
+$ echo ""
+$ echo "By default apparently Perl will only unlink (delete) the latest"
+$ echo "version of a file. This option builds PERL to delete all versions"
+$ echo "of a file"
+$ echo ""
+$ echo "If you have no idea what this means, and do not have"
+$ echo "any program requiring anything, choose the default."
+$ bool_dflt = unlink_all_versions
+$ if f$type(unlink_all_versions) .nes. ""
+$ then
+$ if unlink_all_versions .or. unlink_all_versions .eqs. "define"
+$ then
+$ bool_dflt="y"
+$ else
+$ bool_dflt="n"
+$ endif
+$ endif
+$ rp = "Build with unlink_all_versions? [''bool_dflt'] "
+$ GOSUB myread
+$ unlink_all_versions = ans
$ usecasesensitive = "undef"
$ if (use_ieee_math) then useieee = "define"
$ if (be_case_sensitive) then usecasesensitive = "define"
@@ -2912,6 +2934,12 @@
$ ELSE
$ d_vms_be_case_sensitive = "undef"
$ ENDIF
+$ IF unlink_all_versions
+$ THEN
+$ d_unlink_all_versions = "define"
+$ ELSE
+$ d_unlink_all_versions = "undef"
+$ ENDIF
$! Some constant defaults.
$ hwname = f$getsyi("HW_NAME")
$ myname = myhostname
@@ -6154,6 +6182,7 @@
$ IF use64bitall .OR. use64bitall .EQS. "define" THEN -
WC "#define USE_64_BIT_ALL"
$ IF be_case_sensitive THEN WC "#define VMS_WE_ARE_CASE_SENSITIVE"
+$ IF d_unlink_all_versions then wc "#define UNLINK_ALL_VERSIONS"
$ IF d_herrno .EQS. "undef" THEN WC "#define NEED_AN_H_ERRNO"
$ WC "#define HAS_ENVGETENV"
$ WC "#define PERL_EXTERNAL_GLOB"
@@ -6165,6 +6194,10 @@
$! WC "#define PERL_IGNORE_FPUSIG SIGFPE"
$ ENDIF
$ IF kill_by_sigprc .EQS. "define" then WC "#define KILL_BY_SIGPRC"
+$ if unlink_all_versions
+$ then
+$ WC "#define unlink_all_versions"
+$ endif
$ CLOSE CONFIG
$!
$ echo4 "Doing variable substitutions on .SH files..."
--- dist_root:[vms]vms.c_old Sun Apr 11 21:54:18 2004
+++ dist_root:[vms]vms.c Sun Apr 11 20:19:14 2004
@@ -3,6 +3,8 @@
* VMS-specific routines for perl5
* Version: 5.7.0
*
+ * April 2004 Add LIB$INITIALIZE section so DECC feature logicals will
+ * not change behavior unintentionally.
* 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
@@ -42,6 +44,13 @@
#include <uaidef.h>
#include <uicdef.h>
+#if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
+int decc$feature_get_index(const char *name);
+char* decc$feature_get_name(int index);
+int decc$feature_get_value(int index, int mode);
+int decc$feature_set_value(int index, int mode, int value);
+#endif
+
/* Older versions of ssdef.h don't have these */
#ifndef SS$_INVFILFOROP
# define SS$_INVFILFOROP 3930
@@ -85,12 +94,24 @@
dEXT int h_errno;
#endif
+#ifdef __DECC
+#pragma message disable pragma
+#pragma member_alignment save
+#pragma nomember_alignment longword
+#pragma message save
+#pragma message disable misalgndmem
+#endif
struct itmlst_3 {
unsigned short int buflen;
unsigned short int itmcode;
void *bufadr;
unsigned short int *retlen;
};
+#ifdef __DECC
+#pragma message restore
+#pragma member_alignment restore
+#endif
+
#define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c)
#define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c)
@@ -137,6 +158,13 @@
static int tz_updated = 1;
#endif
+/* DECC Features that may need to affect how Perl interprets
+ * displays filename information
+ */
+static int decc_filename_unix_report = 0;
+static int decc_efs_case_preserve = 0;
+static int decc_filename_unix_only = 0;
+
/* my_maxidx
* Routine to retrieve the maximum equivalence index for an input
* logical name. Some calls to this routine have no knowledge if
@@ -2984,7 +3012,17 @@
if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
else outbuf = __rmsexpand_retbuf;
}
- if ((isunix = (strchr(filespec,'/') != NULL))) {
+
+ isunix = strchr(filespec,'/') != NULL;
+ /* If the user wants UNIX files, "." needs to be treated as in UNIX */
+ if (!isunix) {
+ if (decc_filename_unix_report || decc_filename_unix_only) {
+ if (strcmp(filespec,".") == 0)
+ isunix = 1;
+ }
+ }
+
+ if (isunix) {
if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
filespec = vmsfspec;
}
@@ -3080,7 +3118,7 @@
!(mynam.nam$l_fnb & NAM$M_EXP_NAME))
speclen = mynam.nam$l_name - out;
out[speclen] = '\0';
- if (haslower) __mystrtolower(out);
+ if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
/* Have we been working with an expanded, but not resultant, spec? */
/* Also, convert back to Unix syntax if necessary. */
@@ -3458,7 +3496,7 @@
/* $PARSE may have upcased filespec, so convert output to lower
* case if input contained any lowercase characters. */
- if (haslower) __mystrtolower(retspec);
+ if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
return retspec;
}
} /* end of do_fileify_dirspec() */
@@ -4384,8 +4422,10 @@
* the argv items and lowercase all of these names.
*/
for (c = string; *c; ++c)
+ if (!decc_efs_case_preserve) {
if (isupper(*c))
*c = tolower(*c);
+ }
if (isunix) trim_unixpath(string,item,1);
add_item(head, tail, string, count);
++expcount;
@@ -5037,10 +5077,16 @@
}
dd->count++;
/* Force the buffer to end with a NUL, and downcase name to match C convention. */
- buff[sizeof buff - 1] = '\0';
- for (p = buff; *p; p++) *p = _tolower(*p);
- while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
- *p = '\0';
+ if (!decc_efs_case_preserve) {
+ buff[sizeof buff - 1] = '\0';
+ for (p = buff; *p; p++) *p = _tolower(*p);
+ while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
+ *p = '\0';
+ }
+ else {
+ /* we don't want to force to lowercase, just null terminate */
+ buff[res.dsc$w_length] = '\0';
+ }
/* Skip any directory component and just copy the name. */
if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
@@ -7529,4 +7575,193 @@
return;
}
+ /* Start of DECC RTL Feature handling */
+
+static int sys_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 = value_len;
+ name_dsc.dsc$a_pointer = value;
+ 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 status;
+}
+
+static int sys_crelnm
+ (const char * logname,
+ const char * value)
+{
+ int ret_val;
+ const char * proc_table = "LNM$PROCESS_TABLE";
+ struct dsc$descriptor_s proc_table_dsc;
+ struct dsc$descriptor_s logname_dsc;
+ struct itmlst_3 item_list[2];
+
+ proc_table_dsc.dsc$a_pointer = (char *) proc_table;
+ proc_table_dsc.dsc$w_length = strlen(proc_table);
+ proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
+ proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
+
+ logname_dsc.dsc$a_pointer = (char *) logname;
+ logname_dsc.dsc$w_length = strlen(logname);
+ logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
+ logname_dsc.dsc$b_class = DSC$K_CLASS_S;
+
+ item_list[0].buflen = strlen(value);
+ item_list[0].itmcode = LNM$_STRING;
+ item_list[0].bufadr = (char *)value;
+ item_list[0].retlen = NULL;
+
+ item_list[1].buflen = 0;
+ item_list[1].itmcode = 0;
+
+ ret_val = sys$crelnm
+ (NULL,
+ (const struct dsc$descriptor_s *)&proc_table_dsc,
+ (const struct dsc$descriptor_s *)&logname_dsc,
+ NULL,
+ (const struct item_list_3 *) item_list);
+
+ return ret_val;
+}
+
+#ifndef __VAX
+#if __CRTL_VER >= 70300000
+
+static int set_feature_default(const char *name, int value)
+{
+ int status;
+ int index;
+
+ index = decc$feature_get_index(name);
+
+ status = decc$feature_set_value(index, 1, value);
+ if (index == -1 || (status == -1)) {
+ return -1;
+ }
+
+ status = decc$feature_get_value(index, 1);
+ if (status != value) {
+ return -1;
+ }
+
+ return 0;
+}
+#endif
+#endif
+
+/* C RTL Feature settings */
+
+static int set_features
+ (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
+ int (* cli_routine)(void), /* Not documented */
+ void *image_info) /* Not documented */
+{
+ int status;
+ int s;
+ char* str;
+ char val_str[10];
+
+#ifndef __VAX
+#if __CRTL_VER >= 70300000
+ s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
+ decc_efs_case_preserve = decc$feature_get_value(s, 1);
+
+ s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
+ decc_filename_unix_report = decc$feature_get_value(s, 1);
+ set_feature_default("DECC$FILENAME_UNIX_REPORT", FALSE);
+
+ s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
+ decc_filename_unix_only = decc$feature_get_value(s, 1);
+ set_feature_default("DECC$FILENAME_UNIX_ONLY", FALSE);
+#else
+ status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
+ if (status) {
+ _toupper(str[0])
+ if ((str[0] == 'E') || (str[0] == 1) || (str[0] == 'T')) {
+ decc_efs_case_preserve = 1;
+ }
+ }
+ status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
+ if (status) {
+ _toupper(str[0])
+ if ((str[0] == 'E') || (str[0] == 1) || (str[0] == 'T')) {
+ decc_filename_unix_report = 1;
+ status = sys_crelnm("DECC$FILENAME_UNIX_REPORT", "DISABLE");
+ }
+ }
+ status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
+ if (status) {
+ _toupper(str[0])
+ if ((str[0] == 'E') || (str[0] == 1) || (str[0] == 'T')) {
+ decc_filename_unix_only = 1;
+ status = sys_crelnm("DECC$FILENAME_UNIX_ONLY", "ENABLE");
+ }
+ }
+#endif
+#endif
+
+
+ /* CRTL can be initialized past this point, but not before. */
+/* DECC$CRTL_INIT(); */
+
+ return SS$_NORMAL;
+}
+
+#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
+#endif
+const long vms_cc_features = (const long)set_features;
+
+/*
+** Force a reference to LIB$INITIALIZE to ensure it
+** exists in the image.
+*/
+int lib$initialize(void);
+#ifdef __DECC
+#pragma extern_model strict_refdef
+#endif
+ int lib_init_ref = (int) lib$initialize;
+
+#ifdef __DECC
+#pragma extern_model restore
+#pragma standard
+#endif
/* End of vms.c */
--- dist_root:[vms]vmsish.h_old Sun Apr 11 21:55:17 2004 +++ dist_root:[vms]vmsish.h Sat Apr 24 23:14:49 2004 @@ -2,6 +2,7 @@ * * VMS-specific C header file for perl5. * + * Hacks by J. Malmberg for testing. * Last revised: 16-Sep-1998 by Charles Bailey [EMAIL PROTECTED] * Version: 5.5.2 */ @@ -214,7 +215,14 @@ #define init_os_extras Perl_init_os_extras /* Delete if at all possible, changing protections if necessary. */ +#ifndef UNLINK_ALL_VERSIONS #define unlink kill_file +#else +#if __CRTL_VER < 70000000 +/* No unlink this early */ +#define unlink kill_file +#endif +#endif /* * Intercept calls to fork, so we know whether subsequent calls to @@ -330,7 +338,11 @@ #define PERL_SOCK_SYSWRITE_IS_SEND #endif +#if __CRTL_VER < 70000000 #define BIT_BUCKET "_NLA0:" +#else +#define BIT_BUCKET "/dev/null" +#endif #define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v) vms_image_init((c),(v)); MALLOC_INIT #define PERL_SYS_TERM() OP_REFCNT_TERM; MALLOC_TERM #define dXSUB_SYS
