From: Craig A. Berry Date: Sat, 25 Nov 2006 22:19:14 +0000 (+0000) Subject: xterm debugger support for VMS from John Malmberg (with revisions) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=cd1191f1e03afafd6ab152fc2335758ab5cd3235;p=p5sagit%2Fp5-mst-13.2.git xterm debugger support for VMS from John Malmberg (with revisions) p4raw-id: //depot/perl@29380 --- diff --git a/configure.com b/configure.com index 9a9982b..67dea2a 100644 --- a/configure.com +++ b/configure.com @@ -51,6 +51,7 @@ $ use64bitall = "n" $ use64bitint = "n" $ uselargefiles = "n" $ usestdstat = "n" +$ usedecterm = "y" $ usesitecustomize = "n" $ C_Compiler_Replace = "CC=" $ thread_upcalls = "MTU=" @@ -905,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|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,20 @@ $ d_unlink_all_versions = "define" $ 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 +$ 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 $! CC Flags $ echo "" $ echo "Your compiler may want other flags. For this question you should include" @@ -6611,6 +6626,7 @@ $! 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 @@ -6685,11 +6701,23 @@ $ 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 $ 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; $! diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 2c2f923..2b022d4 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -1721,7 +1721,7 @@ and if we can. 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 @@ we go ahead and set C<$console> and C<$tty> to the file indicated. =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. diff --git a/vms/descrip_mms.template b/vms/descrip_mms.template index afb2013..7e2c323 100644 --- a/vms/descrip_mms.template +++ b/vms/descrip_mms.template @@ -33,6 +33,7 @@ ~MTU~ ~FLAGS~ ~LARGEFILE~ +~DECTERMLIB~ #: >>>>> Architecture-specific options <<<<< .ifdef IXE @@ -1682,7 +1683,7 @@ vms.c : [.vms]vms.c Copy/Log/Noconfirm [.vms]vms.c [] $(CRTL) : $(MAKEFILE) - @ @[.vms]genopt "$(CRTL)/Write" "|" "$(LIBS1)|$(FULLLIBS2)|$(SOCKLIB)" + @ @[.vms]genopt "$(CRTL)/Write" "|" "$(LIBS1)|$(FULLLIBS2)|$(SOCKLIB)|$(DECTERMLIB)" ok : $(utils) $(MINIPERL) lib/perlbug.com -ok -s "(UNINSTALLED)" diff --git a/vms/vms.c b/vms/vms.c index 89d7695..7bf252d 100644 --- a/vms/vms.c +++ b/vms/vms.c @@ -17,6 +17,7 @@ #include #include #include +#include #include #include #include @@ -47,6 +48,7 @@ #include #include #include +#include #if __CRTL_VER >= 70000000 /* FIXME to earliest version */ #include #define NO_EFN EFN$C_ENF @@ -89,6 +91,22 @@ int sys$getdviw void * astprm, void * nullarg); +#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 + (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 +2777,8 @@ struct pipe_details 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 +3744,234 @@ vmspipe_tempfile(pTHX) } +#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); + + if ($VMS_STATUS_SUCCESS(status)) { + status = dvi_iosb[0]; + } + + if (!$VMS_STATUS_SUCCESS(status)) { + SETERRNO(EVMSERR, status); + return -1; + } + + /* 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); + + if ($VMS_STATUS_SUCCESS(status)) { + status = dvi_iosb[0]; + } + + if (!$VMS_STATUS_SUCCESS(status)) { + SETERRNO(EVMSERR, status); + return -1; + } + else { + 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(pTHX_ 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 NULL; + cptr = ret_char + 7; + ret_char = strstr(cmd,"tty"); + if (ret_char == NULL) + return NULL; + ret_char = strstr(cmd,"sleep"); + if (ret_char == NULL) + return NULL; + + /* 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 NULL; + + /* 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)) { + SETERRNO(EVMSERR, status); + return NULL; + } + + device_name[device_name_len] = '\0'; + + /* Need to set this up to look like a pipe for cleanup */ + n = sizeof(Info); + status = lib$get_vm(&n, &info); + if (!$VMS_STATUS_SUCCESS(status)) { + SETERRNO(ENOMEM, status); + return NULL; + } + + 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); + if (!$VMS_STATUS_SUCCESS(status)) { + SETERRNO(EVMSERR, status); + return NULL; + } + 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); + + if (!$VMS_STATUS_SUCCESS(status)) { + SETERRNO(EVMSERR, status); + return NULL; + } + + 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 NULL; + } + + /* All done */ + return info->fp; +} +#endif static PerlIO * safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts) @@ -3752,7 +4000,21 @@ safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts) $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 +4083,7 @@ safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts) 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 +4106,8 @@ safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts) 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 +4136,7 @@ safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts) 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 +4358,7 @@ I32 Perl_my_pclose(pTHX_ PerlIO *fp) 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; @@ -11784,6 +12049,7 @@ Perl_vms_start_glob return fp; } + #ifdef HAS_SYMLINK static char * mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec, const int *utf8_fl);