Change 30164 by [EMAIL PROTECTED] on 2007/02/07 21:38:12
Integrate:
[ 28339]
Make VMS-specific device name encoding routine say no more politely.
[ 28806]
declaration after code nit in vms/vms.c (from Martin Vorlaender)
[ 28843]
Define d_cplusplus on VMS when appropriate
[ 28977]
fix a doc typo and a warning typo in VMS::DCLsym
[ 29144]
When we open a file and pass it along to PerlIO, be sure to enter the
PerlIO world via Unix I/O. If you start from stdio, a Unix I/O counter
will get decremented on close even though it was never incremented (and
may not even exist). Exposed by #29065.
[ 29205]
In pipe_exit_routine in vms/vms.c, mark a subprocess we've deleted
as done. Courtesy of Scott Lepage.
[ 29326]
Subject: [EMAIL PROTECTED] perl5db.pl detecting forked debugger on VMS.
From: "John E. Malmberg" <[EMAIL PROTECTED]>
Date: Sat, 18 Nov 2006 23:07:17 -0500
Message-ID: <[EMAIL PROTECTED]>
[ 29380]
xterm debugger support for VMS from John Malmberg (with revisions)
[ 29572]
Don't try to build Win32 on VMS
[ 29573]
In vms/vms.c, don't prototype decw$term_port until after
config.h (via perl.h) is included. That's where USE_VMS_DECTERM
is defined.
[ 30041]
Subject: [EMAIL PROTECTED] blead on OpenVMS doesn't build
From: Abe Timmerman <[EMAIL PROTECTED]>
Date: Sat, 27 Jan 2007 17:26:47 +0100
Message-Id: <[EMAIL PROTECTED]>
Disable DECterm support by default, and when we enable it,
make sure the image we need is installed, not merely present.
[ 30108]
Install parser.h on VMS, plus fix some case typos in
descrip_mms.template.
[ 30111]
Install overload.h on VMS, plus more case fix-ups in
descrip_mms.template.
Affected files ...
... //depot/maint-5.8/perl/configure.com#51 integrate
... //depot/maint-5.8/perl/lib/perl5db.pl#27 integrate
... //depot/maint-5.8/perl/vms/descrip_mms.template#46 integrate
... //depot/maint-5.8/perl/vms/ext/DCLsym/DCLsym.pm#2 integrate
... //depot/maint-5.8/perl/vms/ext/Stdio/Stdio.xs#3 integrate
... //depot/maint-5.8/perl/vms/vms.c#26 integrate
Differences ...
==== //depot/maint-5.8/perl/configure.com#51 (text) ====
Index: perl/configure.com
--- perl/configure.com#50~30163~ 2007-02-07 12:48:27.000000000 -0800
+++ perl/configure.com 2007-02-07 13:38:12.000000000 -0800
@@ -50,6 +50,7 @@
$ use64bitall = "n"
$ use64bitint = "n"
$ uselargefiles = "n"
+$ usedecterm = "n"
$ usesitecustomize = "n"
$ C_Compiler_Replace = "CC="
$ thread_upcalls = "MTU="
@@ -904,7 +905,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:
@@ -2026,7 +2027,10 @@
$ echo "You are using CXX ''line'"
$ cxxversion = line
$ ccversion = line
+$ d_cplusplus = "define"
$ CALL Cxx_demangler_cleanup
+$ ELSE
+$ d_cplusplus = "undef"
$ ENDIF
$!
$Cxx_demangler_cleanup: SUBROUTINE
@@ -2552,6 +2556,45 @@
$ 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"
@@ -2688,6 +2731,7 @@
$ IF xxx .EQS. "SDBM_File/sdbm" THEN goto ext_loop ! sub extension - omit
$ IF xxx .EQS. "Devel/PPPort/harness" THEN goto ext_loop ! sub extension -
omit
$ IF F$EXTRACT(0,7,xxx) .EQS. "Encode/" THEN goto ext_loop ! sub extension
- omit
+$ IF F$EXTRACT(0,5,xxx) .EQS. "Win32" THEN goto ext_loop ! no Win32 API here
$ IF xxx .EQS. "B/C" THEN goto ext_loop ! sub extension - omit
$ IF F$EXTRACT(0,8,line) .EQS. "vms/ext/" THEN -
xxx = "VMS/" + F$EXTRACT(8,line_len - 20,line)
@@ -5694,7 +5738,7 @@
$ WC "d_cmsghdr_s='undef'"
$ WC "d_const='define'"
$ WC "d_copysignl='define'"
-$ WC "d_cplusplus='undef'"
+$ WC "d_cplusplus='" + d_cplusplus + "'"
$ WC "d_crypt='define'"
$ WC "d_csh='undef'"
$ WC "d_cuserid='define'"
@@ -6609,6 +6653,7 @@
$! 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
@@ -6684,11 +6729,23 @@
$ 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;
$!
==== //depot/maint-5.8/perl/lib/perl5db.pl#27 (text) ====
Index: perl/lib/perl5db.pl
--- perl/lib/perl5db.pl#26~26582~ 2006-01-02 11:40:28.000000000 -0800
+++ perl/lib/perl5db.pl 2007-02-07 13:38:12.000000000 -0800
@@ -1317,9 +1317,21 @@
# We're a child. Make us a label out of the current PID structure
# recorded in PERLDB_PIDS plus our (new) PID. Mark us as not having
# a term yet so the parent will give us one later via resetterm().
- $pids = "[$ENV{PERLDB_PIDS}]";
- $ENV{PERLDB_PIDS} .= "->$$";
- $term_pid = -1;
+
+ my $env_pids = $ENV{PERLDB_PIDS};
+ $pids = "[$env_pids]";
+
+ # Unless we are on OpenVMS, all programs under the DCL shell run under
+ # the same PID.
+
+ if (($^O eq 'VMS') && ($env_pids =~ /\b$$\b/)) {
+ $term_pid = $$;
+ }
+ else {
+ $ENV{PERLDB_PIDS} .= "->$$";
+ $term_pid = -1;
+ }
+
} ## end if (defined $ENV{PERLDB_PIDS...
else {
@@ -1709,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;
@@ -6718,6 +6730,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.
==== //depot/maint-5.8/perl/vms/descrip_mms.template#46 (text) ====
Index: perl/vms/descrip_mms.template
--- perl/vms/descrip_mms.template#45~30163~ 2007-02-07 12:48:27.000000000
-0800
+++ perl/vms/descrip_mms.template 2007-02-07 13:38:12.000000000 -0800
@@ -33,6 +33,7 @@
~MTU~
~FLAGS~
~LARGEFILE~
+~DECTERMLIB~
#: >>>>> Architecture-specific options <<<<<
.ifdef IXE
@@ -255,7 +256,7 @@
# object files for these extensions; the trailing comma is required if
# there are any object files specified
# These must be built separately, or you must add rules below to build them
-myextobj = [.ext.dynaloader]dl_vms$(O),
+myextobj = [.ext.DynaLoader]dl_vms$(O),
EXT = $(MYEXT)
extobj = $(myextobj)
@@ -293,7 +294,7 @@
h0 = av.h cc_runtime.h config.h cop.h cv.h embed.h embedvar.h
h1 = EXTERN.h form.h gv.h handy.h hv.h INTERN.h intrpvar.h
-h2 = iperlsys.h keywords.h mg.h nostdio.h op.h opcode.h opnames.h pad.h
+h2 = iperlsys.h keywords.h mg.h nostdio.h op.h opcode.h opnames.h overload.h
pad.h
h3 = patchlevel.h perl.h perlapi.h perlio.h perlsdio.h perlvars.h perly.h
h4 = pp.h pp_proto.h proto.h regcomp.h regexp.h regnodes.h scope.h
h5 = sv.h thrdvar.h thread.h utf8.h util.h vmsish.h warnings.h
@@ -306,7 +307,7 @@
ac3 = $(ARCHCORE)form.h $(ARCHCORE)gv.h $(ARCHCORE)handy.h $(ARCHCORE)hv.h
ac4 = $(ARCHCORE)INTERN.h $(ARCHCORE)intrpvar.h $(ARCHCORE)iperlsys.h
ac5 = $(ARCHCORE)keywords.h $(ARCHCORE)mg.h $(ARCHCORE)nostdio.h
-ac6 = $(ARCHCORE)op.h $(ARCHCORE)opcode.h $(ARCHCORE)opnames.h
+ac6 = $(ARCHCORE)op.h $(ARCHCORE)opcode.h $(ARCHCORE)opnames.h
$(ARCHCORE)overload.h
ac7 = $(ARCHCORE)pad.h $(ARCHCORE)patchlevel.h $(ARCHCORE)perl.h
ac8 = $(ARCHCORE)perlapi.h $(ARCHCORE)perlio.h $(ARCHCORE)perlsdio.h
ac9 = $(ARCHCORE)perlsfio.h $(ARCHCORE)perlvars.h $(ARCHCORE)perly.h
$(ARCHCORE)pp.h
@@ -438,7 +439,7 @@
Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST)
perlmain.c : miniperlmain.c $(MINIPERL_EXE) [.vms]writemain.pl
- $(MINIPERL) [.VMS]Writemain.pl "$(EXT)"
+ $(MINIPERL) [.vms]Writemain.pl "$(EXT)"
.ifdef __DEBUG__
# Link an extra perl that doesn't invoke the debugger
@@ -501,29 +502,29 @@
@ If F$Search("$(MMS$TARGET)").nes."" Then Delete/NoLog/NoConfirm
$(MMS$TARGET);*
@ Copy/NoConfirm _NLA0: $(MMS$TARGET)
-[.ext.dynaloader]dl_vms.c : [.ext.dynaloader]dl_vms.xs $(ARCHDIR)Config.pm
[.lib.ExtUtils]XSSymSet.pm $(MINIPERL_EXE) [.lib.VMS]Filespec.pm
+[.ext.DynaLoader]dl_vms.c : [.ext.DynaLoader]dl_vms.xs $(ARCHDIR)Config.pm
[.lib.ExtUtils]XSSymSet.pm $(MINIPERL_EXE) [.lib.VMS]Filespec.pm
$(XSUBPP) $(MMS$SOURCE) >$(MMS$TARGET)
-[.ext.dynaloader]dl_vms$(O) : [.ext.dynaloader]dl_vms.c
- $(CC) $(CFLAGS) /Include=([],[.ext.dynaloader])/Object=$(MMS$TARGET)
$(MMS$SOURCE)
+[.ext.DynaLoader]dl_vms$(O) : [.ext.DynaLoader]dl_vms.c
+ $(CC) $(CFLAGS) /Include=([],[.ext.DynaLoader])/Object=$(MMS$TARGET)
$(MMS$SOURCE)
-[.lib]DynaLoader.pm : [.ext.Dynaloader]Dynaloader.pm
+[.lib]DynaLoader.pm : [.ext.DynaLoader]DynaLoader.pm
Copy/NoConfirm/Log $(MMS$SOURCE) [.lib]
@ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
@ $(MINIPERL) -e "use AutoSplit; autosplit_lib_modules(@ARGV)"
[.lib]DynaLoader.pm
-[.lib]XSLoader.pm : [.ext.Dynaloader]XSLoader.pm
+[.lib]XSLoader.pm : [.ext.DynaLoader]XSLoader.pm
Copy/NoConfirm/Log $(MMS$SOURCE) [.lib]
@ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
@ $(MINIPERL) -e "use AutoSplit; autosplit_lib_modules(@ARGV)"
[.lib]XSLoader.pm
-[.ext.dynaloader]dynaloader.pm : [.ext.dynaloader]dynaloader_pm.pl
+[.ext.DynaLoader]DynaLoader.pm : [.ext.DynaLoader]DynaLoader_pm.PL
$(MINIPERL) $(MMS$SOURCE)
- @ Rename/Log dynaloader.pm [.ext.dynaloader]
+ @ Rename/Log DynaLoader.pm [.ext.DynaLoader]
-[.ext.dynaloader]xsloader.pm : [.ext.dynaloader]xsloader_pm.pl
+[.ext.DynaLoader]XSLoader.pm : [.ext.DynaLoader]XSLoader_pm.PL
$(MINIPERL) $(MMS$SOURCE)
- @ Rename/Log xsloader.pm [.ext.dynaloader]
+ @ Rename/Log XSLoader.pm [.ext.DynaLoader]
dynext : $(LIBPREREQ) $(DBG)perlshr$(E) preplibrary
@make_ext "$(MINIPERL_EXE)" "$(MMS)"
@@ -1268,6 +1269,7 @@
# keywords.h: keywords.pl
# opcode.h: opcode.pl
# opnames.h: opcode.pl
+# overload.h: overload.pl
# pp_proto.h: opcode.pl
# pp.sym: opcode.pl
# embed.h: embed.pl [* needs pp.sym generated by opcode.pl! *]
@@ -1285,6 +1287,7 @@
regen_headers :
$(INSTPERL) keywords.pl
$(INSTPERL) opcode.pl
+ $(INSTPERL) overload.pl
$(INSTPERL) embed.pl
$(INSTPERL) bytecode.pl
$(INSTPERL) regcomp.pl
@@ -1315,17 +1318,17 @@
test : all [.t.lib]vmsfspec.t [.t.lib]vms_dclsym.t [.t.lib]vms_stdio.t
@ PERL_TEST_DRIVER == "TEST."
- - @[.VMS]Test.Com "$(E)" "$(__DEBUG__)"
+ - @[.vms]test.com "$(E)" "$(__DEBUG__)"
@ $(MINIPERL) -e "print ""Ran tests"";" > [.t]rantests.
test_harness : all [.t.lib]vmsfspec.t [.t.lib]vms_dclsym.t [.t.lib]vms_stdio.t
@ PERL_TEST_DRIVER == "harness."
- - @[.VMS]Test.Com "$(E)" "$(__DEBUG__)"
+ - @[.vms]test.com "$(E)" "$(__DEBUG__)"
@ $(MINIPERL) -e "print ""Ran tests"";" > [.t]rantests.
minitest : $(MINITEST_EXE) [.lib]re.pm [.lib]lib.pm [.lib.VMS]Filespec.pm
unidatafiles.ts
@ PERL_TEST_DRIVER == "minitest"
- - @[.VMS]Test.Com "$(E)" "$(__DEBUG__)"
+ - @[.vms]test.com "$(E)" "$(__DEBUG__)"
# install ought not need a source, but it doesn't work if one's not
# there. Go figure...
@@ -1423,6 +1426,9 @@
$(ARCHCORE)opnames.h : opnames.h
@ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory
$(ARCHCORE)
Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
+$(ARCHCORE)overload.h : overload.h
+ @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory
$(ARCHCORE)
+ Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
$(ARCHCORE)pad.h : pad.h
@ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory
$(ARCHCORE)
Copy/NoConfirm/Log $(MMS$SOURCE) $(ARCHCORE)
@@ -1628,7 +1634,7 @@
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)"
@@ -1662,28 +1668,28 @@
- If F$Search("[...]*.Opt;-1").nes."" Then Purge/NoConfirm/Log
[...]*.Opt
- If F$Search("[...]*$(O);-1").nes."" Then Purge/NoConfirm/Log
[...]*$(O)
- If F$Search("[...]*$(E);-1").nes."" Then Purge/NoConfirm/Log
[...]*$(E)
- - If F$Search("Config.H;-1").nes."" Then Purge/NoConfirm/Log Config.H
- - If F$Search("Config.SH;-1").nes."" Then Purge/NoConfirm/Log Config.SH
- - If F$Search("VMSish.H;-1").nes."" Then Purge/NoConfirm/Log VMSish.H
- - If F$Search("VMS.C;-1") .nes."" Then Purge/NoConfirm/Log VMS.C
- - If F$Search("Perlmain.C;-1") .nes."" Then Purge/NoConfirm/Log
Perlmain.C
+ - If F$Search("config.h;-1").nes."" Then Purge/NoConfirm/Log config.h
+ - If F$Search("config.sh;-1").nes."" Then Purge/NoConfirm/Log config.sh
+ - If F$Search("vmsish.h;-1").nes."" Then Purge/NoConfirm/Log vmsish.h
+ - If F$Search("vms.c;-1") .nes."" Then Purge/NoConfirm/Log vms.c
+ - If F$Search("perlmain.c;-1") .nes."" Then Purge/NoConfirm/Log
perlmain.c
- If F$Search("Perlshr_Gbl*.Mar;-1") .nes."" Then Purge/NoConfirm/Log
Perlshr_Gbl*.Mar
- - If F$Search("[.Ext.DynaLoader]DL_VMS$(O);-1").nes."" Then
Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS$(O)
- - If F$Search("[.Ext.DynaLoader]DL_VMS.C;-1").nes."" Then
Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS.C
- - If F$Search("[.Ext.Opcode...];-1").nes."" Then Purge/NoConfirm/Log
[.Ext.Opcode]
- - If F$Search("[.VMS.Ext...]*.C;-1").nes."" Then Purge/NoConfirm/Log
[.VMS.Ext...]*.C
- - If F$Search("[.VMS.Ext...]*$(O);-1").nes."" Then Purge/NoConfirm/Log
[.VMS.Ext...]*$(O)
- - If F$Search("[.Lib.Auto...]*.al;-1").nes."" Then Purge/NoConfirm/Log
[.Lib.Auto...]*.al
- - If F$Search("[.Lib.Auto...]autosplit.ix;-1").nes."" Then
Purge/NoConfirm/Log [.Lib.Auto...]autosplit.ix
- - If F$Search("[.Lib]DynaLoader.pm;-1").nes."" Then Purge/NoConfirm/Log
[.Lib]DynaLoader.pm
- - If F$Search("[.Lib]XSLoader.pm;-1").nes."" Then Purge/NoConfirm/Log
[.Lib]XSLoader.pm
- - If F$Search("[.Lib]Config.pm;-1").nes."" Then Purge/NoConfirm/Log
[.Lib]Config.pm
+ - If F$Search("[.ext.DynaLoader]dl_vms$(O);-1").nes."" Then
Purge/NoConfirm/Log [.ext.DynaLoader]dl_vms$(O)
+ - If F$Search("[.ext.DynaLoader]dl_vms.c;-1").nes."" Then
Purge/NoConfirm/Log [.ext.DynaLoader]dl_vms.c
+ - If F$Search("[.ext.Opcode...];-1").nes."" Then Purge/NoConfirm/Log
[.ext.Opcode]
+ - If F$Search("[.vms.ext...]*.C;-1").nes."" Then Purge/NoConfirm/Log
[.vms.ext...]*.C
+ - If F$Search("[.vms.ext...]*$(O);-1").nes."" Then Purge/NoConfirm/Log
[.vms.ext...]*$(O)
+ - If F$Search("[.lib.auto...]*.al;-1").nes."" Then Purge/NoConfirm/Log
[.lib.auto...]*.al
+ - If F$Search("[.lib.auto...]autosplit.ix;-1").nes."" Then
Purge/NoConfirm/Log [.lib.auto...]autosplit.ix
+ - If F$Search("[.lib]DynaLoader.pm;-1").nes."" Then Purge/NoConfirm/Log
[.lib]DynaLoader.pm
+ - If F$Search("[.lib]XSLoader.pm;-1").nes."" Then Purge/NoConfirm/Log
[.lib]XSLoader.pm
+ - If F$Search("[.lib]Config.pm;-1").nes."" Then Purge/NoConfirm/Log
[.lib]Config.pm
- If F$Search("$(ARCHDIR)Config.pm;-1").nes."" Then Purge/NoConfirm/Log
$(ARCHDIR)Config.pm
- - If F$Search("[.Lib]Config_heavy.pl;-1").nes."" Then
Purge/NoConfirm/Log [.Lib]Config_heavy.pl
+ - If F$Search("[.lib]Config_heavy.pl;-1").nes."" Then
Purge/NoConfirm/Log [.lib]Config_heavy.pl
- If F$Search("$(ARCHDIR)Config_heavy.pl;-1").nes."" Then
Purge/NoConfirm/Log $(ARCHDIR)Config_heavy.pl
- If F$Search("[.lib.ExtUtils]Miniperl.pm").nes."" Then
Purge/NoConfirm/Log [.lib.ExtUtils]Miniperl.pm
- If F$Search("[.lib.ExtUtils]XSSymSet.pm").nes."" Then
Purge/NoConfirm/Log [.lib.ExtUtils]XSSymSet.pm
- - If F$Search("[.Lib.VMS]*.*;-1").nes."" Then Purge/NoConfirm/Log
[.Lib.VMS]*.*
+ - If F$Search("[.lib.VMS]*.*;-1").nes."" Then Purge/NoConfirm/Log
[.lib.VMS]*.*
- If F$Search("[.lib.pods]*.Pod;-1").nes."" Then Purge/NoConfirm/Log
[.lib.pods]*.Pod
- If F$Search("$(ARCHCORE)*.*").nes."" Then Purge/NoConfirm/Log
$(ARCHCORE)*.*
- If F$Search("[.lib]*.com;-1").nes."" Then Purge/NoConfirm/Log
[.lib]*.com
@@ -1698,17 +1704,17 @@
- If F$Search("[...]*$(O);*") .nes."" Then Delete/NoConfirm/Log
[...]*$(O);*
- If F$Search(F$Parse("Sys$Disk:[]","$(SOCKH)")).nes."" Then
Delete/NoConfirm/Log $(SOCKH);*
- If F$Search(F$Parse("Sys$Disk:[]","$(SOCKC)")).nes."" Then
Delete/NoConfirm/Log $(SOCKC);*
- - If F$Search("VMSish.H").nes."" Then Delete/NoConfirm/Log VMSish.H;*
- - If F$Search("VMS.C") .nes."" Then Delete/NoConfirm/Log VMS.C;*
- - If F$Search("Perlmain.C") .nes."" Then Delete/NoConfirm/Log
Perlmain.C;*
+ - If F$Search("vmsish.h").nes."" Then Delete/NoConfirm/Log vmsish.h;*
+ - If F$Search("vms.c") .nes."" Then Delete/NoConfirm/Log vms.c;*
+ - If F$Search("perlmain.c") .nes."" Then Delete/NoConfirm/Log
perlmain.c;*
- If F$Search("Perlshr_Gbl*.Mar") .nes."" Then Delete/NoConfirm/Log
Perlshr_Gbl*.Mar;*
- If F$Search("*.TS").nes."" Then Delete/NoConfirm/Log *.TS;*
- - If F$Search("[.Ext.DynaLoader]DL_VMS$(O)").nes."" Then
Delete/NoConfirm/Log [.Ext.DynaLoader]DL_VMS$(O);*
- - If F$Search("[.Ext.DynaLoader]DL_VMS.C").nes."" Then
Delete/NoConfirm/Log [.Ext.DynaLoader]DL_VMS.C;*
- - If F$Search("[.Ext.DynaLoader]DynaLoader.pm").nes."" Then
Delete/NoConfirm/Log [.Ext.DynaLoader]DynaLoader.pm;*
- - If F$Search("[.Ext.DynaLoader]XSLoader.pm").nes."" Then
Delete/NoConfirm/Log [.Ext.DynaLoader]XSLoader.pm;*
- - If F$Search("[.VMS.Ext...]*.C").nes."" Then Delete/NoConfirm/Log
[.VMS.Ext...]*.C;*
- - If F$Search("[.VMS.Ext...]*$(O)").nes."" Then Delete/NoConfirm/Log
[.VMS.Ext...]*$(O);*
+ - If F$Search("[.ext.DynaLoader]dl_vms$(O)").nes."" Then
Delete/NoConfirm/Log [.ext.DynaLoader]dl_vms$(O);*
+ - If F$Search("[.ext.DynaLoader]dl_vms.c").nes."" Then
Delete/NoConfirm/Log [.ext.DynaLoader]dl_vms.c;*
+ - If F$Search("[.ext.DynaLoader]DynaLoader.pm").nes."" Then
Delete/NoConfirm/Log [.ext.DynaLoader]DynaLoader.pm;*
+ - If F$Search("[.ext.DynaLoader]XSLoader.pm").nes."" Then
Delete/NoConfirm/Log [.ext.DynaLoader]XSLoader.pm;*
+ - If F$Search("[.vms.ext...]*.C").nes."" Then Delete/NoConfirm/Log
[.vms.ext...]*.C;*
+ - If F$Search("[.vms.ext...]*$(O)").nes."" Then Delete/NoConfirm/Log
[.vms.ext...]*$(O);*
- If F$Search("[.pod]*.com").nes."" Then Delete/NoConfirm/Log
[.pod]*.com;*
- If F$Search("[.pod]perldelta.pod").nes."" Then Delete/NoConfirm/Log
[.pod]perldelta.pod;*
- @extra_pods CLEAN
@@ -1717,8 +1723,8 @@
- @make_ext "$(MINIPERL_EXE)" "$(MMS)" realclean
- If F$Search("*$(OLB)").nes."" Then Delete/NoConfirm/Log *$(OLB);*
- If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*
- - If F$Search("Config.H").nes."" Then Delete/NoConfirm/Log Config.H;*
- - If F$Search("Config.SH").nes."" Then Delete/NoConfirm/Log Config.SH;*
+ - If F$Search("config.h").nes."" Then Delete/NoConfirm/Log config.h;*
+ - If F$Search("config.sh").nes."" Then Delete/NoConfirm/Log config.sh;*
- $(MINIPERL) -e "use File::Path; rmtree([EMAIL PROTECTED],1,0);" config
- If F$Search("[.lib.unicore]*.pl").nes."" Then Delete/NoConfirm/Log
[.lib.unicore]*.pl;*
- If F$Search("[.lib.unicore]Properties.").nes."" Then
Delete/NoConfirm/Log [.lib.unicore]Properties.;*
@@ -1729,11 +1735,11 @@
- If F$Search("extra.pods").nes."" Then Delete/NoConfirm/Log
extra.pods;*
- $(MINIPERL) -e "use File::Path;
rmtree(['lib/auto','lib/VMS','lib/$(ARCH)'],1,0);"
- If F$Search("*.TS").nes."" Then Delete/NoConfirm/Log *.TS;*
- - If F$Search("[.Lib]DynaLoader.pm").nes."" Then Delete/NoConfirm/Log
[.Lib]DynaLoader.pm;*
- - If F$Search("[.Lib]XSLoader.pm").nes."" Then Delete/NoConfirm/Log
[.Lib]XSLoader.pm;*
- - If F$Search("[.Lib]Config.pm").nes."" Then Delete/NoConfirm/Log
[.Lib]Config.pm;*
- - If F$Search("[.Lib]Config_heavy.pl").nes."" Then Delete/NoConfirm/Log
[.Lib]Config_heavy.pl;*
- - If F$Search("[.Lib]*.com").nes."" Then Delete/NoConfirm/Log
[.Lib]*.com;*
+ - If F$Search("[.lib]DynaLoader.pm").nes."" Then Delete/NoConfirm/Log
[.lib]DynaLoader.pm;*
+ - If F$Search("[.lib]XSLoader.pm").nes."" Then Delete/NoConfirm/Log
[.lib]XSLoader.pm;*
+ - If F$Search("[.lib]Config.pm").nes."" Then Delete/NoConfirm/Log
[.lib]Config.pm;*
+ - If F$Search("[.lib]Config_heavy.pl").nes."" Then Delete/NoConfirm/Log
[.lib]Config_heavy.pl;*
+ - If F$Search("[.lib]*.com").nes."" Then Delete/NoConfirm/Log
[.lib]*.com;*
- If F$Search("[.pod]*.com").nes."" Then Delete/NoConfirm/Log
[.pod]*.com;*
- If F$Search("[.utils]*.com").nes."" Then Delete/NoConfirm/Log
[.utils]*.com;*
- If F$Search("[.x2p]*.com").nes."" Then Delete/NoConfirm/Log
[.x2p]*.com;*
@@ -1755,14 +1761,14 @@
- If F$Search("[.t.lib]vms_stdio.t").nes."" Then Delete/NoConfirm/Log
[.t.lib]vms_stdio.t;*
cleansrc : clean
- - If F$Search("*.C;-1").nes."" Then Purge/NoConfirm/Log *.C
- - If F$Search("*.H;-1").nes."" Then Purge/NoConfirm/Log *.H
- - If F$Search("*.VMS;-1").nes."" Then Purge/NoConfirm/Log *.VMS
- - If F$Search("[.VMS]$(MAKEFILE);-1").nes."" Then Purge/NoConfirm/Log
[.VMS]$(MAKEFILE)
- - If F$Search("[.VMS]*.C;-1").nes."" Then Purge/NoConfirm/Log [.VMS]*.C
- - If F$Search("[.VMS]*.H;-1").nes."" Then Purge/NoConfirm/Log [.VMS]*.H
- - If F$Search("[.VMS]*.Pl;-1").nes."" Then Purge/NoConfirm/Log
[.VMS]*.Pl
- - If F$Search("[.VMS]*.VMS;-1").nes."" Then Purge/NoConfirm/Log
[.VMS]*.VMS
- - If F$Search("[.VMS...]*.pm;-1").nes."" Then Purge/NoConfirm/Log
[.VMS...]*.pm
- - If F$Search("[.VMS...]*.xs;-1").nes."" Then Purge/NoConfirm/Log
[.VMS...]*.xs
+ - If F$Search("*.c;-1").nes."" Then Purge/NoConfirm/Log *.c
+ - If F$Search("*.h;-1").nes."" Then Purge/NoConfirm/Log *.h
+ - If F$Search("*.vms;-1").nes."" Then Purge/NoConfirm/Log *.vms
+ - If F$Search("[.vms]$(MAKEFILE);-1").nes."" Then Purge/NoConfirm/Log
[.vms]$(MAKEFILE)
+ - If F$Search("[.vms]*.c;-1").nes."" Then Purge/NoConfirm/Log [.vms]*.c
+ - If F$Search("[.vms]*.h;-1").nes."" Then Purge/NoConfirm/Log [.vms]*.h
+ - If F$Search("[.vms]*.pl;-1").nes."" Then Purge/NoConfirm/Log
[.vms]*.pl
+ - If F$Search("[.vms]*.vms;-1").nes."" Then Purge/NoConfirm/Log
[.vms]*.vms
+ - If F$Search("[.vms...]*.pm;-1").nes."" Then Purge/NoConfirm/Log
[.vms...]*.pm
+ - If F$Search("[.vms...]*.xs;-1").nes."" Then Purge/NoConfirm/Log
[.vms...]*.xs
!GROK!THIS!
==== //depot/maint-5.8/perl/vms/ext/DCLsym/DCLsym.pm#2 (text) ====
Index: perl/vms/ext/DCLsym/DCLsym.pm
--- perl/vms/ext/DCLsym/DCLsym.pm#1~17645~ 2002-07-19 12:29:57.000000000
-0700
+++ perl/vms/ext/DCLsym/DCLsym.pm 2007-02-07 13:38:12.000000000 -0800
@@ -7,7 +7,7 @@
# Package globals
@ISA = ( 'DynaLoader' );
-$VERSION = '1.02';
+$VERSION = '1.03';
my(%Locsyms) = ( ':ID' => 'LOCAL' );
my(%Gblsyms) = ( ':ID' => 'GLOBAL');
my $DoCache = 1;
@@ -106,7 +106,7 @@
open(P,'Show Symbol * |');
while (<P>) {
($name,$eqs,$val) = /^\s+(\S+) (=+) (.+)/
- or carp "VMS::CLISym: unparseable line $_";
+ or carp "VMS::DCLsym: unparseable line $_";
$name =~ s#\*##;
$val =~ s/"(.*)"$/$1/ or $val =~ s/^(\S+).*/$1/;
if ($eqs eq '==') { $Gblsyms{$name} = $val; }
@@ -157,7 +157,7 @@
tie %cgisyms, VMS::DCLsym, 'GLOBAL';
- $handle = new VMS::DCLsyms;
+ $handle = new VMS::DCLsym;
$value = $handle->getsym($name);
$handle->setsym($name,$value,'GLOBAL') or die "Can't create symbol: $!\n";
$handle->delsym($name,'LOCAL') or die "Can't delete symbol: $!\n";
==== //depot/maint-5.8/perl/vms/ext/Stdio/Stdio.xs#3 (text) ====
Index: perl/vms/ext/Stdio/Stdio.xs
--- perl/vms/ext/Stdio/Stdio.xs#2~29807~ 2007-01-14 05:09:22.000000000
-0800
+++ perl/vms/ext/Stdio/Stdio.xs 2007-02-07 13:38:12.000000000 -0800
@@ -192,12 +192,13 @@
char *
getname(fp)
- PerlIO * fp
+ PerlIO * fp
PROTOTYPE: $
CODE:
+ FILE *stdio = PerlIO_exportFILE(fp,0);
char fname[NAM$C_MAXRSS+1];
ST(0) = sv_newmortal();
- if (PerlIO_getname(fp,fname) != NULL) sv_setpv(ST(0),fname);
+ if (fgetname(stdio,fname) != NULL) sv_setpv(ST(0),fname);
void
rewind(fp)
@@ -348,7 +349,7 @@
break;
}
if (fp != Null(FILE*)) {
- pio_fp = PerlIO_importFILE(fp,mode);
+ pio_fp = PerlIO_fdopen(fileno(fp),mode);
fh = newFH(pio_fp,(mode[1] ? '+' : (mode[0] == 'r' ? '<' :
(mode[0] == 'a' ? 'a' : '>'))));
ST(0) = (fh ? sv_2mortal(fh) : &PL_sv_undef);
}
@@ -363,8 +364,7 @@
CODE:
char *args[8];
int i, myargc, fd;
- FILE *fp;
- PerlIO *pio_fp;
+ PerlIO *pio_fp;
SV *fh;
STRLEN n_a;
if (!spec || !*spec) {
@@ -407,8 +407,7 @@
}
i = mode & 3;
if (fd >= 0 &&
- ((fp = fdopen(fd, &("r\000w\000r+"[2*i]))) != Null(FILE*))) {
- pio_fp = PerlIO_importFILE(fp,&("r\000w\000r+"[2*i]));
+ ((pio_fp = PerlIO_fdopen(fd, &("r\000w\000r+"[2*i]))) !=
Null(PerlIO*))) {
fh = newFH(pio_fp,"<>++"[i]);
ST(0) = (fh ? sv_2mortal(fh) : &PL_sv_undef);
}
==== //depot/maint-5.8/perl/vms/vms.c#26 (text) ====
Index: perl/vms/vms.c
--- perl/vms/vms.c#25~30163~ 2007-02-07 12:48:27.000000000 -0800
+++ perl/vms/vms.c 2007-02-07 13:38:12.000000000 -0800
@@ -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>
/* Set the maximum filespec size here as it is larger for EFS file
* specifications.
@@ -125,6 +127,21 @@
# 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
+ (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
/* gcc's header files don't #define direct access macros
* corresponding to VAXC's variant structs */
@@ -854,8 +871,9 @@
*/
char lnm[LNM$C_NAMLENGTH+1];
char eqv[LNM$C_NAMLENGTH+1];
+ int trnlen;
strncpy(lnm, key, keylen);
- int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
+ trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
sv = newSVpvn(eqv, strlen(eqv));
}
else {
@@ -2047,6 +2065,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
@@ -2180,6 +2200,7 @@
if (!info->done) { /* We tried to be nice . . . */
sts = sys$delprc(&info->pid,0);
if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
+ info->done = 1; /* sys$delprc is as done as we're going to get. */
}
_ckvmssts_noperl(sys$setast(1));
info = info->next;
@@ -2931,6 +2952,234 @@
}
+#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)
@@ -2959,7 +3208,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...
@@ -3028,7 +3291,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;
@@ -3051,6 +3314,8 @@
info->in_done = TRUE;
info->out_done = TRUE;
info->err_done = TRUE;
+ info->xchan = 0;
+ info->xchan_valid = 0;
in[0] = out[0] = err[0] = '\0';
if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
@@ -3071,7 +3336,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);
@@ -3288,6 +3553,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;
@@ -7790,7 +8056,7 @@
*
* A better method might be to use sys$device_scan on the first call, and to
* search for the device, returning an index into the cached array.
- * The number returned would be more intelligable.
+ * The number returned would be more intelligible.
* This is probably not worth it, and anyway would take quite a bit longer
* on the first call.
*/
@@ -7808,7 +8074,7 @@
#if LOCKID_MASK
{
struct dsc$descriptor_s dev_desc;
- unsigned long int status, lockid, item = DVI$_LOCKID;
+ unsigned long int status, lockid = 0, item = DVI$_LOCKID;
/* For cluster-mounted disks, the disk lock identifier is unique, so we
can try that first. */
@@ -7816,7 +8082,16 @@
dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
dev_desc.dsc$b_class = DSC$K_CLASS_S;
dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
- _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
+ status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
+ if (!(status & 1)) {
+ switch (status) {
+ case SS$_NOSUCHDEV:
+ SETERRNO(ENODEV, status);
+ return 0;
+ default:
+ _ckvmssts(status);
+ }
+ }
if (lockid) return (lockid & ~LOCKID_MASK);
}
#endif
End of Patch.
