Integrate:

[ 26869]
more case tolerance for vms/ext/filespec.t

[ 27114]
Subject: patch@27082 Allow fatal exceptions to bring up VMS debugger
From: "John E. Malmberg" <wb8tyw@qsl.net>
Date: Sat, 04 Feb 2006 16:04:32 -0500
	Message-id: <43E516E0.1000508@qsl.net>

[ 27115]
Subject: Re: Configure.com issue, more quoting needed.
From: Peter Prymmer <PPrymmer@factset.com>
Date: Mon, 06 Feb 2006 13:27:14 -0500
Message-id:  <OF3536E719.A8B8D167-ON8525710D.0065011E-8525710D.00655ED0@factset.com>
p4raw-link: @27115 on //depot/perl: 7acbb8ec149b2b0481081c92fe4351d46ae0ae3a
p4raw-link: @27114 on //depot/perl: 9c1171d132d2d0b98d01b0c7b49b681bc94c3940
p4raw-link: @26869 on //depot/perl: 51078f7bc8ba938e8bb9302522fc032016e57e52

p4raw-id: //depot/maint-5.8/perl@30161
p4raw-integrated: from //depot/perl@30160 'copy in' vms/ext/filespec.t
	(@23346..)
p4raw-integrated: from //depot/perl@27115 'merge in' configure.com
	(@26844..)
p4raw-integrated: from //depot/perl@27114 'copy in' vms/perlvms.pod
	(@25851..) 'edit in' vms/vms.c (@27015..)

diff --git a/configure.com b/configure.com
index 76dc373..2b9091c 100644 (file)
--- a/configure.com
+++ b/configure.com
@@ -6966,7 +6966,7 @@ $ WRITE CONFIG "$ instmodsh  == """ + perl_setup_perl + " ''vms_prefix':[utils]i
 $ WRITE CONFIG "$ libnetcfg  == """ + perl_setup_perl + " ''vms_prefix':[utils]libnetcfg.com"""
 $ WRITE CONFIG "$ perlbug    == """ + perl_setup_perl + " ''vms_prefix':[lib]perlbug.com"""
 $ WRITE CONFIG "$!perlcc     == """ + perl_setup_perl + " ''vms_prefix':[utils]perlcc.com"""
-$ WRITE CONFIG "$ perldoc    == """ + perl_setup_perl + " ''vms_prefix':[lib.pods]perldoc.com -t"""
+$ WRITE CONFIG "$ perldoc    == """ + perl_setup_perl + " ''vms_prefix':[lib.pods]perldoc.com """"-t"""""""
 $ WRITE CONFIG "$ perlivp    == """ + perl_setup_perl + " ''vms_prefix':[utils]perlivp.com"""
 $ WRITE CONFIG "$ piconv     == """ + perl_setup_perl + " ''vms_prefix':[utils]piconv.com"""
 $ WRITE CONFIG "$ pl2pm      == """ + perl_setup_perl + " ''vms_prefix':[utils]pl2pm.com"""

diff --git a/vms/ext/filespec.t b/vms/ext/filespec.t
index b0efa4c..6c099d9 100644 (file)
--- a/vms/ext/filespec.t
+++ b/vms/ext/filespec.t
@@ -21,7 +21,7 @@ foreach $test (@tests) {
   $expect = undef if $expect eq 'undef';
   $rslt = eval "$func('$arg')";
   is($@, '', "eval ${func}('$arg')");
-  is($rslt, $expect, "${func}('$arg'): '$rslt'");
+  is(lc($rslt), lc($expect), "${func}('$arg'): '$rslt'");
 }
 
 $defwarn = <<'EOW';
@@ -32,10 +32,10 @@ $defwarn = <<'EOW';
 EOW
 
 is(uc(rmsexpand('[]')),   "\U$ENV{DEFAULT}", 'rmsexpand()') || print $defwarn;
-is(rmsexpand('from.here'),"\L$ENV{DEFAULT}from.here") || print $defwarn;
-is(rmsexpand('from'),     "\L$ENV{DEFAULT}from")      || print $defwarn;
+is(lc(rmsexpand('from.here')),"\L$ENV{DEFAULT}from.here") || print $defwarn;
+is(lc(rmsexpand('from')),     "\L$ENV{DEFAULT}from")      || print $defwarn;
 
-is(rmsexpand('from.here','cant:[get.there];2'),
+is(lc(rmsexpand('from.here','cant:[get.there];2')),
    'cant:[get.there]from.here;2')                     || print $defwarn;
 
 

diff --git a/vms/perlvms.pod b/vms/perlvms.pod
index 78655d2..8bcb8eb 100644 (file)
--- a/vms/perlvms.pod
+++ b/vms/perlvms.pod
@@ -367,6 +367,30 @@ The PERL5LIB and PERLLIB logical names work as documented in L<perl>,
 except that the element separator is '|' instead of ':'.  The
 directory specifications may use either VMS or Unix syntax.
 
+=head1 PERL_VMS_EXCEPTION_DEBUG
+
+The PERL_VMS_EXCEPTION_DEBUG being defined as "ENABLE" will cause the VMS
+debugger to be invoked if a fatal exception that is not otherwise
+handled is raised.  The purpose of this is to allow debugging of
+internal Perl problems that would cause such a condition.
+
+This allows the programmer to look at the execution stack and variables to
+find out the cause of the exception.  As the debugger is being invoked as
+the Perl interpreter is about to do a fatal exit, continuing the execution
+in debug mode is usally not practical.
+
+Starting Perl in the VMS debugger may change the program execution
+profile in a way that such problems are not reproduced.
+
+The C<kill> function can be used to test this functionality from within
+a program.
+
+In typical VMS style, only the first letter of the value of this logical
+name is actually checked in a case insensitive mode, and it is considered
+enabled if it is the value "T","1" or "E".
+
+This logical name must be defined before Perl is started.
+
 =head1 Command line
 
 =head2 I/O redirection and backgrounding

diff --git a/vms/vms.c b/vms/vms.c
index aa8287b..718714b 100644 (file)
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -226,6 +226,8 @@ int decc_posix_compliant_pathnames = 0;
 int decc_readdir_dropdotnotype = 0;
 static int vms_process_case_tolerant = 1;
 
+static int vms_debug_on_exception = 0;
+
 /* Is this a UNIX file specification?
  *   No longer a simple check with EFS file specs
  *   For now, not a full check, but need to
@@ -1452,8 +1454,8 @@ Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
 
 #define _MY_SIG_MAX 17
 
-unsigned int
-Perl_sig_to_vmscondition(int sig)
+static unsigned int
+Perl_sig_to_vmscondition_int(int sig)
 {
     static unsigned int sig_code[_MY_SIG_MAX+1] = 
     {
@@ -1495,6 +1497,17 @@ Perl_sig_to_vmscondition(int sig)
     return sig_code[sig];
 }
 
+unsigned int
+Perl_sig_to_vmscondition(int sig)
+{
+#ifdef SS$_DEBUG
+    if (vms_debug_on_exception != 0)
+       lib$signal(SS$_DEBUG);
+#endif
+    return Perl_sig_to_vmscondition_int(sig);
+}
+
+
 int
 Perl_my_kill(int pid, int sig)
 {
@@ -1530,7 +1543,7 @@ Perl_my_kill(int pid, int sig)
        return -1;
     }
 
-    code = Perl_sig_to_vmscondition(sig);
+    code = Perl_sig_to_vmscondition_int(sig);
 
     if (!code) {
        SETERRNO(EINVAL, SS$_BADPARAM);
@@ -8756,6 +8769,17 @@ static int set_features
     unsigned long case_perm;
     unsigned long case_image;
 
+    /* Allow an exception to bring Perl into the VMS debugger */
+    vms_debug_on_exception = 0;
+    status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
+    if ($VMS_STATUS_SUCCESS(status)) {
+       if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
+        vms_debug_on_exception = 1;
+       else
+        vms_debug_on_exception = 0;
+    }
+
+
 #if __CRTL_VER >= 70300000 && !defined(__VAX)
     s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
     if (s >= 0) {