This has been something that has been bothering me for a while since
seeing the Perl debugger complaining about being forked, and not being
able to create an xterm on VMS.
Not having this ability has made debugging some scripts more difficult
for me. So finally I am doing something about it.
In configure.com, vms/descrip.mms_template, vms/vms.c:
Add the smoke and mirrors to make the perl5db.pl xterm create request
create a decterm for debugging.
Unlike UNIX, the Decterm does not exist as a separate process, just as a
device that can be used.
[A decterm implements almost complete xterm functionality]
In vms/vms.c:
Fixed a couple of cases of an uninitialized variable "mode" being
referenced.
In lib/perl5db.pl:
OpenVMS needs to have the $term structure exist and be filled out for
sub TTY to work. I put the needed special case code in sub TTY, but
there may be a better place to put it.
Note, I do not know if this affects why OpenVMS needs special handling
here. OpenVMS does not fork(), so child processes do not inherit
variables set by the parent, so each child must run any variable
initialization required.
Using the xterms with the forked debugger is not obvious on OpenVMS, so
eventually the VMS documentation will need to be updated with something
similar to below:
Where the support has been built in for using DECTerms with the Perl
debugger, the following environment variables need to be set:
TERM needs to be set to "xterm". Case sensitive.
DISPLAY needs to be set.
OpenVMS normally does not set these values for you. The value of
DISPLAY is currently ignored, however "0:0.0" is a value that is least
likely to cause problems if it is ever honored.
TO DO: Get VMS Perl/Bash to look up the current display and set the
environment variable if it is not already set, and to also report a
DECterm terminal type as "xterm".
Note that this aliasing may enable color attributes on perl programs run
on DECTerms.
Also, it is useful to have the debugger I/O off to a new xterm or
DECTerm, even when not in a forked condition, as it avoids the debugger
covering up or modifying I/O to STDOUT and STDERR.
By setting the environment variable "PERLDB_PIDS" to a value like "XXX",
the perl debugger will create a separate terminal window.
-John
[EMAIL PROTECTED]
Personal Opinion Only
--
Need a senior system engineer? I am looking for employment.
http://encompasserve.org/~malmberg/MALMBERG_CS1_RESUME.TXT
--- /rsync_root/perl/configure.com Fri Nov 17 12:54:09 2006
+++ ./configure.com Wed Nov 22 21:00:57 2006
@@ -51,6 +51,7 @@
$ use64bitint = "n"
$ uselargefiles = "n"
$ usestdstat = "n"
+$ usedecterm = "y"
$ usesitecustomize = "n"
$ C_Compiler_Replace = "CC="
$ thread_upcalls = "MTU="
@@ -905,7 +906,7 @@
$ 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|unlink_all_versions|uselargefiles|usesitecustomize|"
-$ config_symbols5 ="|buildmake|builder|usethreadupcalls|usekernelthreads"
+$ config_symbols5
="|buildmake|builder|usethreadupcalls|usekernelthreads|usedecterm"
$!
$ open/read CONFIG 'config_sh'
$ rd_conf_loop:
@@ -2556,6 +2557,19 @@
$ ELSE
$ d_unlink_all_versions = "undef"
$ ENDIF
+$ bool_dflt = "y"
+$ IF F$TYPE(usedecterm) .NES. ""
+$ THEN
+$ dflt = f$search("SYS$SHARE:DECW$TERMINALSHR*.EXE")
+$ IF dflt .eqs. "" THEN bool_dflt = "n"
+$ ENDIF
+$ echo ""
+$ echo "Perl can be built to support using DecTerms for 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
$! CC Flags
$ echo ""
$ echo "Your compiler may want other flags. For this question you should
include"
@@ -6684,11 +6698,19 @@
$ ELSE
$ LARGEFILE_REPLACE = "LARGEFILE="
$ ENDIF
+$ if f$search("DECTERM.OPT") .nes. "" then delete DECTERM.OPT;*
+$ IF usedecterm .OR. usedecterm .EQS. "define"
+$ THEN
+$ DECTERM_REPLACE = "DECTERM=DECTERM=USE_VMS_DECTERM=1"
+$ ELSE
+$ DECTERM_REPLACE = "DECTERM="
+$ ENDIF
$ echo4 "Extracting ''defmakefile' (with variable substitutions)"
$ DEFINE/USER_MODE sys$output 'UUmakefile'
$ mcr []munchconfig 'config_sh' 'Makefile_SH' "''DECC_REPLACE'"
"''DECCXX_REPLACE'" "''ARCH_TYPE'" "''GNUC_REPLACE'" -
"''SOCKET_REPLACE'" "''THREAD_REPLACE'" "''C_Compiler_Replace'"
"''MALLOC_REPLACE'" -
-"''THREAD_UPCALLS'" "''THREAD_KERNEL'" "PV=''version'"
"FLAGS=FLAGS=''extra_flags'" "''LARGEFILE_REPLACE'"
+"''THREAD_UPCALLS'" "''THREAD_KERNEL'" "PV=''version'"
"FLAGS=FLAGS=''extra_flags'" "''LARGEFILE_REPLACE'" -
+"''DECTERM_REPLACE'"
$! Clean up after ourselves
$ DELETE/NOLOG/NOCONFIRM []munchconfig.exe;
$!
@@ -6872,6 +6894,21 @@
$ CALL Bad_environment "UTIL"
$ CALL Bad_environment "TEST" "SYMBOL"
$ IF f$search("config.msg") .eqs. "" THEN echo "OK."
+$!
+$! %Config-I-DECTERM, write decterm.opt
+$!
+$ if f$search("[-]DECTERM.OPT") .nes. "" then delete [-]DECTERM.OPT;*
+$ IF usedecterm .OR. usedecterm .EQS. "define"
+$ THEN
+$ open/write dopt [-]DECTERM.OPT
+$ if f$search("SYS$SHARE:DECW$TERMINALSHR12.EXE") .nes. ""
+$ then
+$ write dopt "SYS$SHARE:DECW$TERMINALSHR12.EXE/SHARE"
+$ else
+$ write dopt "SYS$SHARE:DECW$TERMINALSHR.EXE/SHARE"
+$ endif
+$ close dopt
+$ ENDIF
$!
$! %Config-I-VMS, write perl_setup.com here
$!
--- /rsync_root/perl/vms/descrip_mms.template Mon Oct 9 06:32:53 2006
+++ ./vms/descrip_mms.template Wed Nov 22 19:21:42 2006
@@ -33,6 +33,7 @@
~MTU~
~FLAGS~
~LARGEFILE~
+~DECTERM~
#: >>>>> Architecture-specific options <<<<<
.ifdef IXE
@@ -221,15 +222,26 @@
MTHREADLINKFLAGS =
.endif
+# Support of DECTERM for the Perl Debugger
+.IFDEF DECTERM
+DECTERM_OPT=,[]DECTERM.OPT/OPT
+DECTERM_DEF2=/Define=$(DECTERM)
+.IFDEF LARGEFILE
+DECTERM_DEF1=,$(DECTERM)
+.ELSE
+DECTERM_DEF1=$(DECTERM)
+.ENDIF
+.ENDIF
+
# C preprocessor manifest "DEBUGGING" ==> perl -D, not the VMS debugger
.IFDEF LARGEFILE
-CFLAGS = $(XTRACCFLAGS)$(DBGCCFLAGS)$(FLAGS)/Define=$(LARGEFILE)
+CFLAGS = $(XTRACCFLAGS)$(DBGCCFLAGS)$(FLAGS)/Define=($(LARGEFILE))
X2PCFLAGS =
$(XTRACCFLAGS)$(DBGCCFLAGS)$(FLAGS)/Define=(PERL_FOR_X2P,$(LARGEFILE))
-CORECFLAGS =
$(XTRACCFLAGS)$(DBGCCFLAGS)$(FLAGS)/Define=(PERL_CORE,$(LARGEFILE))
+CORECFLAGS =
$(XTRACCFLAGS)$(DBGCCFLAGS)$(FLAGS)/Define=(PERL_CORE,$(LARGEFILE)$(DECTERM_DEF1))
.ELSE
CFLAGS = $(XTRACCFLAGS)$(DBGCCFLAGS)$(FLAGS)
X2PCFLAGS = $(XTRACCFLAGS)$(DBGCCFLAGS)$(FLAGS)/Define=PERL_FOR_X2P
-CORECFLAGS = $(XTRACCFLAGS)$(DBGCCFLAGS)$(FLAGS)/Define=PERL_CORE
+CORECFLAGS = $(XTRACCFLAGS)$(DBGCCFLAGS)$(FLAGS)/Define=(PERL_CORE
$(DECTERM_DEF1)
.ENDIF
LINKFLAGS = $(DBGLINKFLAGS)
@@ -436,9 +448,13 @@
miniperl : $(DBG)miniperl$(E) vmspipe.com
@ Continue
$(MINIPERL_EXE) : miniperlmain$(O), $(DBG)libperl$(OLB) $(CRTL)
- Link $(LINKFLAGS)/NoDebug/Trace/NoMap/NoFull/NoCross/Exe=$(MMS$TARGET)
miniperlmain$(O), $(DBG)libperl$(OLB)/Library/Include=globals $(CRTLOPTS)
+ Link $(LINKFLAGS)/NoDebug/Trace/NoMap/NoFull/NoCross/Exe=$(MMS$TARGET) \
+ miniperlmain$(O), $(DBG)libperl$(OLB)/Library/Include=globals \
+ $(CRTLOPTS) $(DECTERM_OPT)
$(DBG)miniperl$(E) : miniperlmain$(O), $(DBG)libperl$(OLB) $(CRTL)
- Link $(LINKFLAGS)/Trace/Exe=$(MMS$TARGET)
miniperlmain$(O),$(DBG)libperl$(OLB)/Library/Include=globals $(CRTLOPTS)
+ Link $(LINKFLAGS)/Trace/Exe=$(MMS$TARGET) \
+ miniperlmain$(O),$(DBG)libperl$(OLB)/Library/Include=globals \
+ $(CRTLOPTS) $(DECTERM_OPT)
$(DBG)libperl$(OLB) : $(obj)
@ If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create
$(MMS$TARGET)
@@ -461,7 +477,9 @@
Link $(LINKFLAGS)$(MTHREADLINKFLAGS)/Exe=$(MMS$TARGET) perlmain$(O),
perlshr.opt/Option, perlshr_attr.opt/Option $(CRTLOPTS)
$(DBG)perlshr$(E) : $(DBG)libperl$(OLB) $(extobj) $(DBG)perlshr_xtras.ts
- Link $(LINKFLAGS)/Share=$(MMS$TARGET) $(extobj)
[]$(DBG)perlshr_bld.opt/Option, perlshr_attr.opt/Option
+ Link $(LINKFLAGS)/Share=$(MMS$TARGET) $(extobj) \
+ []$(DBG)perlshr_bld.opt/Option, \
+ perlshr_attr.opt/Option $(DECTERM_OPT)
# The following files are built in one go by gen_shrfls.pl:
# perlshr_attr.opt, $(DBG)perlshr_bld.opt - VAX and AXP
--- /rsync_root/perl/lib/perl5db.pl Mon Nov 20 09:56:00 2006
+++ ./lib/perl5db.pl Fri Nov 24 00:55:14 2006
@@ -1721,7 +1721,7 @@
if ($console) {
# If we have a console, check to see if there are separate ins and
- # outs to open. (They are assumed identiical if not.)
+ # outs to open. (They are assumed identical if not.)
my ( $i, $o ) = split /,/, $console;
$o = $i unless defined $o;
@@ -6734,6 +6734,19 @@
=cut
sub TTY {
+
+ # With VMS we can get here with $term undefined, so we do not
+ # switch to this terminal. There may be a better place to make
+ # sure that $term is defined on VMS
+ if ( @_ and ($^O eq 'VMS') and !defined($term) ) {
+ eval { require Term::ReadLine } or die $@;
+ if ( !$rl ) {
+ $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
+ }
+ else {
+ $term = new Term::ReadLine 'perldb', $IN, $OUT;
+ }
+ }
if ( @_ and $term and $term->Features->{newTTY} ) {
# This terminal supports switching to a new TTY.
--- /rsync_root/perl/vms/vms.c Sun Nov 5 20:38:13 2006
+++ ./vms/vms.c Fri Nov 24 00:08:39 2006
@@ -17,6 +17,7 @@
#include <chpdef.h>
#include <clidef.h>
#include <climsgdef.h>
+#include <dcdef.h>
#include <descrip.h>
#include <devdef.h>
#include <dvidef.h>
@@ -47,6 +48,7 @@
#include <uicdef.h>
#include <stsdef.h>
#include <rmsdef.h>
+#include <smgdef.h>
#if __CRTL_VER >= 70000000 /* FIXME to earliest version */
#include <efndef.h>
#define NO_EFN EFN$C_ENF
@@ -89,6 +91,21 @@
void * astprm,
void * nullarg);
+#ifdef USE_VMS_DECTERM
+
+/* Routine to create a decterm for use */
+/* No headers, this information was found in the Programming Concepts Manual */
+int decw$term_port
+ (const struct dsc$descriptor_s * display,
+ const struct dsc$descriptor_s * setup_file,
+ const struct dsc$descriptor_s * customization,
+ struct dsc$descriptor_s * result_device_name,
+ unsigned short * result_device_name_length,
+ void * controller,
+ void * char_buffer,
+ void * char_change_buffer);
+#endif
+
#if __CRTL_VER >= 70300000 && !defined(__VAX)
static int set_feature_default(const char *name, int value)
@@ -2759,6 +2776,8 @@
int in_done; /* true when in pipe finished */
int out_done;
int err_done;
+ unsigned short xchan; /* channel to debug xterm */
+ unsigned short xchan_valid; /* channel is assigned */
};
struct exit_control_block
@@ -3724,6 +3743,213 @@
}
+#ifdef USE_VMS_DECTERM
+
+static int vms_is_syscommand_xterm(void)
+{
+const static struct dsc$descriptor_s syscommand_dsc =
+ { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
+
+const static struct dsc$descriptor_s decwdisplay_dsc =
+ { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
+
+struct item_list_3 items[2];
+unsigned short dvi_iosb[4];
+unsigned long devchar;
+unsigned long devclass;
+int status;
+
+ /* Very simple check to guess if sys$command is a decterm? */
+ /* First see if the DECW$DISPLAY: device exists */
+ items[0].len = 4;
+ items[0].code = DVI$_DEVCHAR;
+ items[0].bufadr = &devchar;
+ items[0].retadr = NULL;
+ items[1].len = 0;
+ items[1].code = 0;
+
+ status = sys$getdviw
+ (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
+ _ckvmssts(status);
+
+ if (!$VMS_STATUS_SUCCESS(dvi_iosb[0])) {
+ if (dvi_iosb[0] == SS$_NOSUCHDEV)
+ return -1;
+ _ckvmssts(status);
+
+ }
+
+ /* If it does, then for now assume that we are on a workstation */
+ /* Now verify that SYS$COMMAND is a terminal */
+ /* for creating the debugger DECTerm */
+
+ items[0].len = 4;
+ items[0].code = DVI$_DEVCLASS;
+ items[0].bufadr = &devclass;
+ items[0].retadr = NULL;
+ items[1].len = 0;
+ items[1].code = 0;
+
+ status = sys$getdviw
+ (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
+ _ckvmssts(status);
+ if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
+ if (devclass == DC$_TERM) {
+ return 0;
+ }
+ }
+ return -1;
+}
+
+/* If we are on a DECTerm, we can pretend to fork xterms when requested */
+static PerlIO * create_forked_xterm(aTHX_ const char *cmd, const char *mode)
+{
+int status;
+int ret_stat;
+char * ret_char;
+char device_name[65];
+unsigned short device_name_len;
+struct dsc$descriptor_s customization_dsc;
+struct dsc$descriptor_s device_name_dsc;
+const char * cptr;
+char * tptr;
+char customization[200];
+char title[40];
+pInfo info = NULL;
+char mbx1[64];
+unsigned short p_chan;
+int n;
+unsigned short iosb[4];
+struct item_list_3 items[2];
+const char * cust_str =
+ "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
+struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
+ DSC$K_CLASS_S, mbx1};
+
+ ret_char = strstr(cmd," xterm ");
+ if (ret_char == NULL)
+ return Nullfp;
+ cptr = ret_char + 7;
+ ret_char = strstr(cmd,"tty");
+ if (ret_char == NULL)
+ return Nullfp;
+ ret_char = strstr(cmd,"sleep");
+ if (ret_char == NULL)
+ return Nullfp;
+
+ /* Are we on a workstation? */
+ /* to do: capture the rows / columns and pass their properties */
+ ret_stat = vms_is_syscommand_xterm();
+ if (ret_stat < 0)
+ return Nullfp;
+
+ /* Make the title: */
+ ret_char = strstr(cptr,"-title");
+ if (ret_char != NULL) {
+ while ((*cptr != 0) && (*cptr != '\"')) {
+ cptr++;
+ }
+ if (*cptr == '\"')
+ cptr++;
+ n = 0;
+ while ((*cptr != 0) && (*cptr != '\"')) {
+ title[n] = *cptr;
+ n++;
+ if (n == 39) {
+ title[39] == 0;
+ break;
+ }
+ cptr++;
+ }
+ title[n] = 0;
+ }
+ else {
+ /* Default title */
+ strcpy(title,"Perl Debug DECTerm");
+ }
+ sprintf(customization,cust_str, title);
+
+ customization_dsc.dsc$a_pointer = customization;
+ customization_dsc.dsc$w_length = strlen(customization);
+ customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
+ customization_dsc.dsc$b_class = DSC$K_CLASS_S;
+
+ device_name_dsc.dsc$a_pointer = device_name;
+ device_name_dsc.dsc$w_length = sizeof device_name -1;
+ device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
+ device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
+
+ device_name_len = 0;
+
+ /* Try to create the window */
+ status = decw$term_port
+ (NULL,
+ NULL,
+ &customization_dsc,
+ &device_name_dsc,
+ &device_name_len,
+ NULL,
+ NULL,
+ NULL);
+ if (!$VMS_STATUS_SUCCESS(status))
+ return Nullfp;
+
+ device_name[device_name_len] = '\0';
+
+ /* Need to set this up to look like a pipe for cleanup */
+ n = sizeof(Info);
+ _ckvmssts(lib$get_vm(&n, &info));
+
+ info->mode = *mode;
+ info->done = FALSE;
+ info->completion = 0;
+ info->closing = FALSE;
+ info->in = 0;
+ info->out = 0;
+ info->err = 0;
+ info->fp = Nullfp;
+ info->useFILE = 0;
+ info->waiting = 0;
+ info->in_done = TRUE;
+ info->out_done = TRUE;
+ info->err_done = TRUE;
+
+ /* Assign a channel on this so that it will persist, and not login */
+ /* We stash this channel in the info structure for reference. */
+ /* The created xterm self destructs when the last channel is removed */
+ /* and it appears that perl5db.pl (perl debugger) does this routinely */
+ /* So leave this assigned. */
+ device_name_dsc.dsc$w_length = device_name_len;
+ status = sys$assign(&device_name_dsc,&info->xchan,0,0);
+ _ckvmssts(status);
+ info->xchan_valid = 1;
+
+ /* Now create a mailbox to be read by the application */
+
+ create_mbx(aTHX_ &p_chan, &d_mbx1);
+
+ /* write the name of the created terminal to the mailbox */
+ status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
+ iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
+
+ _ckvmssts(status);
+
+ info->fp = PerlIO_open(mbx1, mode);
+
+ /* Done with this channel */
+ sys$dassgn(p_chan);
+
+ /* If any errors, then clean up */
+ if (!info->fp) {
+ n = sizeof(Info);
+ _ckvmssts(lib$free_vm(&n, &info));
+ return Nullfp;
+ }
+
+ /* All done */
+ return info->fp;
+}
+#endif
static PerlIO *
safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
@@ -3752,7 +3978,21 @@
$DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
$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.
+ */
+ if (*in_mode == 'r') {
+ PerlIO * xterm_fd;
+
+ xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
+ if (xterm_fd != Nullfp)
+ return xterm_fd;
+ }
+#endif
+
if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static
vmspipe file */
/* once-per-program initialization...
@@ -3821,7 +4061,7 @@
set_errno(EVMSERR);
}
set_vaxc_errno(sts);
- if (*mode != 'n' && ckWARN(WARN_PIPE)) {
+ if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s",
strlen(cmd), cmd, Strerror(errno));
}
*psts = sts;
@@ -3844,6 +4084,8 @@
info->in_done = TRUE;
info->out_done = TRUE;
info->err_done = TRUE;
+ info->xchan = 0;
+ info->xchan_valid = 0;
in = PerlMem_malloc(VMS_MAXRSS);
if (in == NULL) _ckvmssts(SS$_INSFMEM);
@@ -3872,7 +4114,7 @@
info->out->info = info;
}
if (!info->useFILE) {
- info->fp = PerlIO_open(mbx, mode);
+ info->fp = PerlIO_open(mbx, mode);
} else {
info->fp = (PerlIO *) freopen(mbx, mode, stdin);
Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
@@ -4094,6 +4336,7 @@
pInfo info, last = NULL;
unsigned long int retsts;
int done, iss, n;
+ int status;
for (info = open_pipes; info != NULL; last = info, info = info->next)
if (info->fp == fp) break;
@@ -11783,6 +12026,7 @@
Safefree(rslt);
return fp;
}
+
#ifdef HAS_SYMLINK
static char *
