[patch@31658] Dynamically load dbg xterm on VMS

From: "John E. Malmberg" <wb8tyw@qsl.net>
Message-ID: <46A830E4.1040708@qsl.net>

p4raw-id: //depot/perl@31661

diff --git a/configure.com b/configure.com
index 1d270a8..93e28c8 100644 (file)
--- a/configure.com
+++ b/configure.com
@@ -52,7 +52,6 @@ $ use64bitint = "n"
 $ uselongdouble = "n"
 $ uselargefiles = "n"
 $ usestdstat = "n"
-$ usedecterm = "n"
 $ usesitecustomize = "n"
 $ C_Compiler_Replace = "CC="
 $ thread_upcalls = "MTU="
@@ -907,7 +906,7 @@ $   config_symbols1 ="|installprivlib|installscript|installsitearch|installsitel
 $   config_symbols2 ="|prefix|privlib|privlibexp|scriptdir|sitearch|sitearchexp|sitebin|sitelib|sitelib_stem|sitelibexp|try_cxx|use64bitall|use64bitint|"
 $   config_symbols3 ="|usecasesensitive|usedefaulttypes|usedevel|useieee|useithreads|uselongdouble|usemultiplicity|usemymalloc|usedebugging_perl|"
 $   config_symbols4 ="|useperlio|usesecurelog|usethreads|usevmsdebug|usefaststdio|usemallocwrap|unlink_all_versions|uselargefiles|usesitecustomize|"
-$   config_symbols5 ="|buildmake|builder|usethreadupcalls|usekernelthreads|usedecterm"
+$   config_symbols5 ="|buildmake|builder|usethreadupcalls|usekernelthread"
 $!  
 $   open/read CONFIG 'config_sh'
 $   rd_conf_loop:
@@ -2586,44 +2585,6 @@ $ ELSE
 $     d_unlink_all_versions = "undef"
 $ ENDIF
 $!
-$! To avoid 'SYSTEM-F-PROTINSTALL, protected images must be installed'
-$! at run time, we must check that the DECterm image is both present
-$! and installed as a known image.
-$!
-$ decterm_capable = "FALSE"
-$ dflt = "SYS$SHARE:DECW$TERMINALSHR12.EXE"
-$ IF F$SEARCH(dflt) .NES. "" 
-$ THEN 
-$    decterm_capable = F$FILE_ATTRIBUTES(dflt, "KNOWN")
-$ ELSE
-$     dflt = "SYS$SHARE:DECW$TERMINALSHR.EXE"
-$     IF F$SEARCH(dflt) .NES. "" THEN decterm_capable = F$FILE_ATTRIBUTES(dflt, "KNOWN")
-$ ENDIF
-$!
-$ IF F$TYPE(usedecterm) .NES. ""
-$ THEN
-$       if usedecterm .or. usedecterm .eqs. "define"
-$       then
-$         bool_dflt="y"
-$       else
-$         bool_dflt="n"
-$       endif
-$ ELSE
-$       bool_dflt="n"
-$ ENDIF
-$ IF .NOT. use_debugging_perl THEN bool_dflt = "n"
-$ echo ""
-$ echo "Perl can be built to support DECterms from the Perl debugger"
-$ echo ""
-$ echo "If this does not make any sense to you, just accept the default '" + bool_dflt + "'."
-$ rp = "Build with DECterm Perl debugger support, if available? [''bool_dflt'] "
-$ GOSUB myread
-$ usedecterm=ans
-$ IF (usedecterm .OR. usedecterm .EQS. "define") .AND. .NOT. decterm_capable
-$ THEN
-$     echo4 "No installed DECterm image found, disabling..."
-$     usedecterm = "n"
-$ ENDIF
 $! CC Flags
 $ echo ""
 $ echo "Your compiler may want other flags.  For this question you should include"
@@ -6734,7 +6695,6 @@ $! Alas this does not help to build Fcntl
 $!   WC "#define PERL_IGNORE_FPUSIG SIGFPE"
 $ ENDIF
 $ IF kill_by_sigprc .EQS. "define" then WC "#define KILL_BY_SIGPRC"
-$ IF usedecterm .OR. usedecterm .EQS. "define" then WC "#define USE_VMS_DECTERM"
 $ IF unlink_all_versions .OR. unlink_all_versions .EQS. "define" THEN -
     WC "#define UNLINK_ALL_VERSIONS"
 $ CLOSE CONFIG
@@ -6809,17 +6769,6 @@ $   ENDIF
 $ ELSE
 $   LARGEFILE_REPLACE = "LARGEFILE="
 $ ENDIF
-$ IF usedecterm .OR. usedecterm .EQS. "define"
-$ THEN
-$   IF F$SEARCH("SYS$SHARE:DECW$TERMINALSHR12.EXE") .nes. ""
-$   THEN
-$      DECTERM_REPLACE = "DECTERMLIB=DECTERMLIB=DECW$TERMINALSHR12/SHARE"
-$   ELSE
-$      DECTERM_REPLACE = "DECTERMLIB=DECTERMLIB=DECW$TERMINALSHR/SHARE"
-$   ENDIF
-$ ELSE
-$   DECTERM_REPLACE = "DECTERMLIB=DECTERMLIB="
-$ ENDIF
 $!
 $! In order not to stress the tiny command buffer on pre-7.3-2 systems,
 $! we put the following substitutions in a file and pass the file to
@@ -6840,7 +6789,6 @@ $ WC "''THREAD_KERNEL'"
 $ WC "PV=''version'"
 $ WC "FLAGS=FLAGS=''extra_flags'"
 $ WC "''LARGEFILE_REPLACE'"
-$ WC "''DECTERM_REPLACE'"
 $ close CONFIG
 $!
 $ echo4 "Extracting ''defmakefile' (with variable substitutions)"

diff --git a/vms/descrip_mms.template b/vms/descrip_mms.template
index 6772a27..9bb17a1 100644 (file)
--- a/vms/descrip_mms.template
+++ b/vms/descrip_mms.template
@@ -33,7 +33,6 @@
 ~MTU~
 ~FLAGS~
 ~LARGEFILE~
-~DECTERMLIB~
 
 #: >>>>> Architecture-specific options <<<<<
 .ifdef IXE
@@ -1731,7 +1730,7 @@ vms.c : [.vms]vms.c
        Copy/Log/Noconfirm [.vms]vms.c []
 
 $(CRTL) : $(MAKEFILE)
-       @ @[.vms]genopt "$(CRTL)/Write" "|" "$(LIBS1)|$(FULLLIBS2)|$(SOCKLIB)|$(DECTERMLIB)"
+       @ @[.vms]genopt "$(CRTL)/Write" "|" "$(LIBS1)|$(FULLLIBS2)|$(SOCKLIB)"
 
 ok : $(utils)
        $(MINIPERL) lib/perlbug.com -ok -s "(UNINSTALLED)"

diff --git a/vms/vms.c b/vms/vms.c
index 27214f7..026a47d 100644 (file)
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -91,6 +91,17 @@ int sys$getdviw
        void * nullarg);
 #endif
 
+#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
+
 #if __CRTL_VER >= 70300000 && !defined(__VAX)
 
 static int set_feature_default(const char *name, int value)
@@ -144,12 +155,10 @@ return 0;
 #  define RTL_USES_UTC 1
 #endif
 
-#ifdef USE_VMS_DECTERM
-
 /* Routine to create a decterm for use with the Perl debugger */
 /* No headers, this information was found in the Programming Concepts Manual */
 
-int decw$term_port
+static int (*decw_term_port)
    (const struct dsc$descriptor_s * display,
     const struct dsc$descriptor_s * setup_file,
     const struct dsc$descriptor_s * customization,
@@ -157,8 +166,7 @@ int decw$term_port
     unsigned short * result_device_name_length,
     void * controller,
     void * char_buffer,
-    void * char_change_buffer);
-#endif
+    void * char_change_buffer) = 0;
 
 /* gcc's header files don't #define direct access macros
  * corresponding to VAXC's variant structs */
@@ -3769,8 +3777,6 @@ vmspipe_tempfile(pTHX)
 }
 
 
-#ifdef USE_VMS_DECTERM
-
 static int vms_is_syscommand_xterm(void)
 {
     const static struct dsc$descriptor_s syscommand_dsc = 
@@ -3861,6 +3867,12 @@ static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
     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;
@@ -3872,6 +3884,37 @@ static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
     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();
@@ -3917,7 +3960,7 @@ static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
     device_name_len = 0;
 
     /* Try to create the window */
-     status = decw$term_port
+     status = (*decw_term_port)
        (NULL,
        NULL,
        &customization_dsc,
@@ -3996,7 +4039,6 @@ static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
     /* All done */
     return info->fp;
 }
-#endif
 
 static PerlIO *
 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
@@ -4026,7 +4068,6 @@ 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.
@@ -4038,7 +4079,6 @@ safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
        if (xterm_fd != Nullfp)
            return xterm_fd;
     }
-#endif
 
     if (!head_PLOC) store_pipelocs(aTHX);   /* at least TRY to use a static vmspipe file */