summaryrefslogtreecommitdiff
path: root/vms
diff options
context:
space:
mode:
authorLarry Wall <lwall@netlabs.com>1995-03-12 22:32:14 -0800
committerLarry Wall <lwall@netlabs.com>1995-03-12 22:32:14 -0800
commit748a93069b3d16374a9859d1456065dd3ae11394 (patch)
tree308ca14de9933a313dceacce8be77db67d9368c7 /vms
parentfec02dd38faf8f83471b031857d89cb76fea1ca0 (diff)
downloadperl-748a93069b3d16374a9859d1456065dd3ae11394.tar.gz
Perl 5.001perl-5.001
[See the Changes file for a list of changes]
Diffstat (limited to 'vms')
-rw-r--r--vms/Makefile (renamed from vms/makefile.)395
-rw-r--r--vms/config.vms31
-rw-r--r--vms/descrip.mms435
-rw-r--r--vms/ext/Filespec.pm323
-rw-r--r--vms/ext/MM_VMS.pm812
-rw-r--r--vms/ext/VMS/stdio/Makefile.PL3
-rw-r--r--vms/ext/VMS/stdio/stdio.pm78
-rw-r--r--vms/ext/VMS/stdio/stdio.xs109
-rw-r--r--vms/gen_shrfls.pl90
-rw-r--r--vms/genconfig.pl66
-rw-r--r--vms/mms2make.pl18
-rw-r--r--vms/perlvms.pod373
-rw-r--r--vms/sockadapt.c15
-rw-r--r--vms/sockadapt.h65
-rw-r--r--vms/test.com9
-rw-r--r--vms/vms.c1732
-rw-r--r--vms/vmsish.h158
-rw-r--r--vms/writemain.pl41
18 files changed, 3856 insertions, 897 deletions
diff --git a/vms/makefile. b/vms/Makefile
index bc5a58c46f..9a953106a6 100644
--- a/vms/makefile.
+++ b/vms/Makefile
@@ -3,7 +3,7 @@
#> conversion process. For more information, see mms2make.pl
#>
# Makefile. for perl5 on VMS
-# Last revised 30-Sep-1994 by Charles Bailey bailey@genetics.upenn.edu
+# Last revised 10-Mar-1995 by Charles Bailey bailey@genetics.upenn.edu
#
#
# tidy -- purge files generated by executing this file
@@ -15,20 +15,24 @@
#### Start of system configuration section. ####
+
# File type to use for object files
+# File type to use for object libraries
# File type to use for executable images
# File type to use for object files
O = .obj
+# File type to use for object libraries
+OLB = .olb
# File type to use for executable images
E = .exe
-# used to incorporate 'custom' malloc routines
-mallocsrc =
-mallocobj =
+ARCHCORE = [.lib.VMS_VAX.CORE]
+ARCHAUTO = [.lib.auto.VMS_VAX]
-# We need separate MACRO files declaring global symbols
-SYMOPT = ,perlshr_gbl.opt/Option
+# -fno-builtin avoids bug in gcc up to version 2.6.2 which can destroy
+# data when memcpy() is called on large (>64 kB) blocks of memory
+# (fixed in gcc 2.6.3)
.first:
@ If f$$TrnLnm("Sys").eqs."" Then Define/NoLog SYS sys$$Library
XTRAOBJS =
@@ -38,11 +42,11 @@ XTRACCFLAGS = /Include=[]/Object=$(O)
XTRADEF =
LIBS2 = sys$$Share:VAXCRTL.Exe/Shareable
+
DBGCCFLAGS = /NoList
DBGLINKFLAGS = /NoMap
DBG =
-# Process option macros
# N.B. the targets for $(SOCKC) and $(SOCKH) assume that the permanent
# copies live in [.vms], and the `clean' target will delete copies of
# these files in the current default directory.
@@ -54,20 +58,26 @@ SOCKCLIS =
SOCKHLIS =
SOCKOBJ =
-# DEBUGGING ==> perl -D, not the VMS debugger
+# C preprocessor manifest "DEBUGGING" ==> perl -D, not the VMS debugger
CFLAGS = /Define=(DEBUGGING$(SOCKDEF)$(XTRADEF))$(XTRACCFLAGS)$(DBGCCFLAGS)
LINKFLAGS = $(DBGLINKFLAGS)
+MAKE = MMK
MAKEFILE = [.VMS]Makefile. # this file
NOOP = continue
-XSUBPP = MCR sys$$Disk:[]Miniperl$(E) [.ext]xsubpp -typemap [-]typemap
-# List of extensions to build into perlmain; enclose each in quotes and
-# separate by spaces.
-EXT = "DynaLoader"
-# Source and object files for these extensions; leading comma is required
+# Macros to invoke a copy of miniperl during the build. Targets which
+# are built using these macros should depend on $(MINIPERL_EXE)
+MINIPERL_EXE = sys$$Disk:[]miniperl$(E)
+MINIPERL = MCR $(MINIPERL_EXE)
+XSUBPP = $(MINIPERL) [.lib.extutils]xsubpp
+
+# Space-separated list of "static" extensions to build into perlshr (case counts).
+EXT = DynaLoader
+# 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
-extobj = , [.ext.dynaloader]dl_vms$(O)
+extobj = [.ext.dynaloader]dl_vms$(O),
#### End of system configuration section. ####
@@ -78,87 +88,113 @@ h3 = opcode.h, patchlevel.h, perl.h, perly.h, pp.h, proto.h, regcomp.h
h4 = regexp.h, scope.h, sv.h, vmsish.h, util.h
h = $(h1), $(h2), $(h3), $(h4) $(SOCKHLIS)
-c1 = av.c, scope.c, op.c, doop.c, doio.c, dump.c, hv.c $(mallocsrc)
-c2 = mg.c, perly.c, pp.c, pp_ctl.c, pp_hot.c, pp_sys.c, regcomp.c, regexec.c
-c3 = gv.c, sv.c, taint.c, toke.c, util.c, deb.c, run.c, vms.c $(SOCKCLIS)
+c1 = av.c, scope.c, op.c, doop.c, doio.c, dump.c, hv.c, mg.c
+c2 = perl.c, perly.c, pp.c, pp_hot.c, pp_ctl.c, pp_sys.c, regcomp.c, regexec.c
+c3 = gv.c, sv.c, taint.c, toke.c, util.c, deb.c, run.c, globals.c, vms.c $(SOCKCLIS)
-c = $(c1), $(c2), $(c3), perl.c, miniperlmain.c, perlmain.c
+c = $(c1), $(c2), $(c3), miniperlmain.c, perlmain.c
-obj1 = av$(O), scope$(O), op$(O), doop$(O), doio$(O), dump$(O), hv$(O) $(mallocobj)
-obj2 = mg$(O), perly$(O), pp$(O), pp_ctl$(O), pp_hot$(O), pp_sys$(O), regcomp$(O), regexec$(O)
-obj3 = gv$(O), sv$(O), taint$(O), toke$(O), util$(O), deb$(O), run$(O), vms$(O) $(SOCKOBJ)
+obj1 = perl$(O), gv$(O), toke$(O), perly$(O), op$(O), regcomp$(O), dump$(O), util$(O), mg$(O)
+obj2 = hv$(O), av$(O), run$(O), pp_hot$(O), sv$(O), pp$(O), scope$(O), pp_ctl$(O), pp_sys$(O)
+obj3 = doop$(O), doio$(O), regexec$(O), taint$(O), deb$(O), globals$(O), vms$(O) $(SOCKOBJ)
obj = $(obj1), $(obj2), $(obj3)
+ac1 = $(ARCHCORE)EXTERN.h $(ARCHCORE)INTERN.h $(ARCHCORE)XSUB.h $(ARCHCORE)av.h
+ac2 = $(ARCHCORE)config.h $(ARCHCORE)cop.h $(ARCHCORE)cv.h $(ARCHCORE)embed.h
+ac3 = $(ARCHCORE)form.h $(ARCHCORE)gv.h $(ARCHCORE)handy.h $(ARCHCORE)hv.h
+ac4 = $(ARCHCORE)keywords.h $(ARCHCORE)mg.h $(ARCHCORE)op.h $(ARCHCORE)opcode.h
+ac5 = $(ARCHCORE)patchlevel.h $(ARCHCORE)perl.h $(ARCHCORE)perly.h
+ac6 = $(ARCHCORE)pp.h $(ARCHCORE)proto.h $(ARCHCORE)regcomp.h
+ac7 = $(ARCHCORE)regexp.h $(ARCHCORE)scope.h $(ARCHCORE)sv.h $(ARCHCORE)util.h
+ac8 = $(ARCHCORE)vmsish.h $(ARCHCORE)$(DBG)libperl$(OLB) $(ARCHCORE)perlshr_attr.opt
+ac9 = $(ARCHCORE)$(DBG)perlshr_bld.opt
+acs =
+
CRTL = []crtl.opt
CRTLOPTS =,$(CRTL)/Options
.suffixes:
-.suffixes: $(O) .c
+.suffixes: $(O) .c .xs
+
+.xs.c :
+ $(XSUBPP) $< >$@
+
.c$(O) :
$(CC) $(CFLAGS) $<
-all : base extras
+.xs$(O) :
+ $(XSUBPP) $< >$(MMS$SOURCE_NAME).c
+ $(CC) $(CFLAGS) $(MMS$SOURCE_NAME).c
+
+all : base extras archcorefiles preplibrary
@ $(NOOP)
-base : $(DBG)miniperl$(E) perl$(E) [.lib]Config.pm
+base : miniperl$(E) perl$(E) [.lib]Config.pm
@ $(NOOP)
-extras : [.lib]DynaLoader.pm
+extras : [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm [.lib.extutils]MM_VMS.pm
+ @ $(NOOP)
+archcorefiles : $(ac1) $(ac2) $(ac3) $(ac4) $(ac5) $(ac6) $(ac7) $(ac8) $(ac9) $(acs) $(ARCHAUTO)time.stamp
@ $(NOOP)
-miniperl_objs = miniperlmain$(O), perl$(O), $(obj)
-miniperl$(E) : $(miniperl_objs) , coreobjs.opt $(CRTL)
- Link $(LINKFLAGS)/NoDebug/Exe=$@ miniperlmain$(O), perl$(O), coreobjs.opt/Option $(CRTLOPTS)
+miniperl_objs = miniperlmain$(O), $(obj)
+$(MINIPERL_EXE) : miniperlmain$(O), $(DBG)libperl$(OLB) $(CRTL)
+ Link $(LINKFLAGS)/NoDebug/Exe=$@ miniperlmain$(O), $(DBG)libperl$(OLB)/Library/Include=globals $(CRTLOPTS)
+miniperl$(E) : $(miniperl_objs), $(DBG)libperl$(OLB) $(CRTL)
+ Link $(LINKFLAGS)/Exe=$(DBG)$@ miniperlmain$(O),$(DBG)libperl$(OLB)/Library/Include=globals $(CRTLOPTS)
-# Use an options file to list object files since some Makes don't feed
-# long lines to DCL properly
-coreobjs.opt : $(MAKEFILE)
- @ $$@[.vms]genopt "$@/Write" "|" "$(obj1)"
- @ $$@[.vms]genopt "$@/Append" "|" "$(obj2)"
- @ $$@[.vms]genopt "$@/Append" "|" "$(obj3)"
+$(DBG)libperl$(OLB) : $(obj)
+ @ If f$$Search("$@").eqs."" Then Library/Object/Create $(MMS$TARGET)
+ Library/Object/Replace $@ $(obj1)
+ Library/Object/Replace $@ $(obj2)
+ Library/Object/Replace $@ $(obj3)
-perlmain.c : miniperlmain.c miniperl$(E)
- MCR sys$$Disk:[]Miniperl$(E) [.VMS]Writemain.pl $(EXT)
+perlmain.c : miniperlmain.c $(MINIPERL_EXE) [.vms]writemain.pl
+ $(MINIPERL) [.VMS]Writemain.pl "$(EXT)"
-perl$(E) : perlmain$(O) $(extobj), perlshr$(E), perlshr_attr.opt $(CRTL)
+perl$(E) : perlmain$(O), perlshr$(E), perlshr_attr.opt $(MINIPERL_EXE)
@ $$@[.vms]genopt "PerlShr.Opt/Write" "|" "''f$$Environment("Default")'$(DBG)PerlShr$(E)/Share"
- Link $(LINKFLAGS)/Exe=$(DBG)$@ perlmain$(O) $(extobj),[]perlshr.opt/Option,perlshr_attr.opt/Option
-shr_objs = perlshr$(O) ,perl$(O), $(obj)
-perlshr$(E) : $(shr_objs) ,perlshr_xtras.ts ,coreobjs.opt ,$(CRTL)
- Link $(LINKFLAGS)/Share/Exe=$(DBG)$@ perlshr$(O), perl$(O), coreobjs.opt/Option $(SYMOPT) , perlshr_attr.opt/Option, perlshr_sym.opt/Option $(CRTLOPTS)
-perlshr$(O) : [.vms]perlshr.c
- $(CC) $(CFLAGS)/NoOptimize/Object=$@ [.vms]perlshr.c
+ Link $(LINKFLAGS)/Exe=$(DBG)$@ perlmain$(O), perlshr.opt/Option, perlshr_attr.opt/Option
+perlshr$(E) : $(DBG)libperl$(OLB) $(extobj) $(DBG)perlshr_xtras.ts
+ Link $(LINKFLAGS)/Share=$(DBG)$@ $(extobj) []$(DBG)perlshr_bld.opt/Option, perlshr_attr.opt/Option
# The following files are built in one go by gen_shrfls.pl:
-# perlshr_attr.opt, perlshr_sym.opt - VAX and AXP
-# perlshr_gbl*.mar, perlshr_gbl*$(O), perlshr_gbl.opt - VAX only
+# perlshr_attr.opt, $(DBG)perlshr_bld.opt - VAX and AXP
+# perlshr_gbl*.mar, perlshr_gbl*$(O) - VAX only
# This is a backup target used only with older versions of the DECCRTL which
# can't deal with pipes properly. See ReadMe.VMS for details.
-perlshr_xtras.ts : perl.h config.h vmsish.h proto.h [.vms]gen_shrfls.pl miniperl$(E) $(MAKEFILE)
- MCR sys$$Disk:[]Miniperl$(E) [.vms]gen_shrfls.pl "$(CC)$(CFLAGS)" $(O)
- @ Copy NLA0: perlshr_xtras.ts
- @ Purge/NoLog/NoConfirm perlshr_xtras.ts
+$(DBG)perlshr_xtras.ts : perl.h config.h vmsish.h proto.h [.vms]gen_shrfls.pl $(MINIPERL_EXE) $(MAKEFILE) $(CRTL)
+ $(MINIPERL) [.vms]gen_shrfls.pl "$(CC)$(CFLAGS)" "$(O)" "$(DBG)" "$(OLB)" "$(EXT)" "$(CRTL)"
+ @ If f$$Search("$(DBG)perlshr_xtras.ts").nes."" Then Delete/NoLog/NoConfirm $(DBG)perlshr_xtras.ts;*
+ @ Copy NLA0: $(DBG)perlshr_xtras.ts
-[.lib]config.pm : [.vms]config.vms [.vms]genconfig.pl miniperl$(E)
- MCR sys$$Disk:[]Miniperl$(E) [.VMS]GenConfig.Pl
- MCR sys$$Disk:[]Miniperl$(E) ConfigPM.
+[.lib]config.pm : [.vms]config.vms [.vms]genconfig.pl $(MINIPERL_EXE)
+ $(MINIPERL) [.VMS]GenConfig.Pl cc=$(CC)$(CFLAGS) ldflags=$(LINKFLAGS)
+ $(MINIPERL) ConfigPM.
-[.ext.dynaloader]dl_vms.c : [.ext.dynaloader]dl_vms.xs miniperl$(E)
+[.ext.dynaloader]dl_vms.c : [.ext.dynaloader]dl_vms.xs $(MINIPERL_EXE)
$(XSUBPP) [.ext.dynaloader]dl_vms.xs >$@
[.ext.dynaloader]dl_vms$(O) : [.ext.dynaloader]dl_vms.c
$(CC) $(CFLAGS) /Object=$@ [.ext.dynaloader]dl_vms.c
-preplibrary : miniperl$(E) [.lib]Config.pm
- @ Create/Directory [.lib.auto]
- MCR sys$$Disk:[]Miniperl$(E) "-Ilib" -e "use AutoSplit; autosplit_lib_modules(@ARGV)" [.lib]*.pm [.lib.*]*.pm
-
-[.lib]DynaLoader.pm : [.ext.dynaloader]dynaloader.pm preplibrary
+[.lib]DynaLoader.pm : [.ext.dynaloader]dynaloader.pm
Copy/Log/NoConfirm [.ext.dynaloader]dynaloader.pm [.lib]DynaLoader.pm
- MCR sys$$Disk:[]Miniperl$(E) autosplit DynaLoader
+
+[.lib.VMS]Filespec.pm : [.vms.ext]Filespec.pm
+ @ Create/Directory [.lib.VMS]
+ Copy/Log/NoConfirm [.vms.ext]Filespec.pm $@
+
+[.lib.ExtUtils]MM_VMS.pm : [.vms.ext]MM_VMS.pm
+ Copy/Log/NoConfirm [.vms.ext]MM_VMS.pm $@
+
+preplibrary : $(MINIPERL_EXE) [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm [.lib.ExtUtils]MM_VMS.pm
+ @ Write sys$$Output "Autosplitting Perl library . . ."
+ @ Create/Directory [.lib.auto]
+ @ $(MINIPERL) "-Ilib" -e "use AutoSplit; autosplit_lib_modules(@ARGV)" [.lib]*.pm [.lib.*]*.pm
-#opcode.h : opcode.pl
-# MCR Sys$Disk:[]Miniperl$(E) opcode.pl
+#opcode.h : opcode.pl $(MINIPERL_EXE)
+# $(MINIPERL) opcode.pl
perly.h : perly.c # Quick and dirty 'touch'
Copy/Log/NoConfirm perly.h; ;
@@ -180,8 +216,103 @@ perly$(O) : perly.c, perly.h, $(h)
test : perl$(E)
- @[.VMS]Test.Com
+# CORE subset for MakeMaker, so we can build Perl without sources
+# Should move to VMS installperl when we get one
+$(ARCHCORE)EXTERN.h : EXTERN.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log EXTERN.h $@
+$(ARCHCORE)INTERN.h : INTERN.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log INTERN.h $@
+$(ARCHCORE)XSUB.h : XSUB.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log XSUB.h $@
+$(ARCHCORE)av.h : av.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log av.h $@
+$(ARCHCORE)config.h : config.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log config.h $@
+$(ARCHCORE)cop.h : cop.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log cop.h $@
+$(ARCHCORE)cv.h : cv.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log cv.h $@
+$(ARCHCORE)embed.h : embed.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log embed.h $@
+$(ARCHCORE)form.h : form.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log form.h $@
+$(ARCHCORE)gv.h : gv.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log gv.h $@
+$(ARCHCORE)handy.h : handy.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log handy.h $@
+$(ARCHCORE)hv.h : hv.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log hv.h $@
+$(ARCHCORE)keywords.h : keywords.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log keywords.h $@
+$(ARCHCORE)mg.h : mg.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log mg.h $@
+$(ARCHCORE)op.h : op.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log op.h $@
+$(ARCHCORE)opcode.h : opcode.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log opcode.h $@
+$(ARCHCORE)patchlevel.h : patchlevel.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log patchlevel.h $@
+$(ARCHCORE)perl.h : perl.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log perl.h $@
+$(ARCHCORE)perly.h : perly.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log perly.h $@
+$(ARCHCORE)pp.h : pp.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log pp.h $@
+$(ARCHCORE)proto.h : proto.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log proto.h $@
+$(ARCHCORE)regcomp.h : regcomp.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log regcomp.h $@
+$(ARCHCORE)regexp.h : regexp.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log regexp.h $@
+$(ARCHCORE)scope.h : scope.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log scope.h $@
+$(ARCHCORE)sv.h : sv.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log sv.h $@
+$(ARCHCORE)util.h : util.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log util.h $@
+$(ARCHCORE)vmsish.h : vmsish.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log vmsish.h $@
+$(ARCHCORE)$(DBG)libperl$(OLB) : $(DBG)libperl$(OLB) $(DBG)perlshr_xtras.ts
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(DBG)libperl$(OLB) $@
+$(ARCHCORE)perlshr_attr.opt : $(DBG)perlshr_xtras.ts
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log perlshr_attr.opt $@
+$(ARCHCORE)$(DBG)perlshr_bld.opt : $(DBG)perlshr_xtras.ts
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(DBG)perlshr_bld.opt $@
+$(ARCHAUTO)time.stamp :
+ @ Create/Directory $(ARCHAUTO)
+ @ If f$$Search("$@").eqs."" Then Copy/NoConfirm _NLA0: $(MMS$TARGET)
+
# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE
-# If this runs make out of memory, delete /usr/include lines.
av$(O) : EXTERN.h
av$(O) : av.c
av$(O) : av.h
@@ -336,28 +467,6 @@ hv$(O) : scope.h
hv$(O) : sv.h
hv$(O) : vmsish.h
hv$(O) : util.h
-malloc$(O) : EXTERN.h
-malloc$(O) : av.h
-malloc$(O) : config.h
-malloc$(O) : cop.h
-malloc$(O) : cv.h
-malloc$(O) : embed.h
-malloc$(O) : form.h
-malloc$(O) : gv.h
-malloc$(O) : handy.h
-malloc$(O) : hv.h
-malloc$(O) : malloc.c
-malloc$(O) : mg.h
-malloc$(O) : op.h
-malloc$(O) : opcode.h
-malloc$(O) : perl.h
-malloc$(O) : pp.h
-malloc$(O) : proto.h
-malloc$(O) : regexp.h
-malloc$(O) : scope.h
-malloc$(O) : sv.h
-malloc$(O) : vmsish.h
-malloc$(O) : util.h
mg$(O) : EXTERN.h
mg$(O) : av.h
mg$(O) : config.h
@@ -380,6 +489,28 @@ mg$(O) : scope.h
mg$(O) : sv.h
mg$(O) : vmsish.h
mg$(O) : util.h
+perl$(O) : EXTERN.h
+perl$(O) : av.h
+perl$(O) : config.h
+perl$(O) : cop.h
+perl$(O) : cv.h
+perl$(O) : embed.h
+perl$(O) : form.h
+perl$(O) : gv.h
+perl$(O) : handy.h
+perl$(O) : hv.h
+perl$(O) : mg.h
+perl$(O) : op.h
+perl$(O) : opcode.h
+perl$(O) : perl.c
+perl$(O) : perl.h
+perl$(O) : pp.h
+perl$(O) : proto.h
+perl$(O) : regexp.h
+perl$(O) : scope.h
+perl$(O) : sv.h
+perl$(O) : vmsish.h
+perl$(O) : util.h
perly$(O) : EXTERN.h
perly$(O) : av.h
perly$(O) : config.h
@@ -424,6 +555,72 @@ pp$(O) : scope.h
pp$(O) : sv.h
pp$(O) : vmsish.h
pp$(O) : util.h
+pp_ctl$(O) : EXTERN.h
+pp_ctl$(O) : av.h
+pp_ctl$(O) : config.h
+pp_ctl$(O) : cop.h
+pp_ctl$(O) : cv.h
+pp_ctl$(O) : embed.h
+pp_ctl$(O) : form.h
+pp_ctl$(O) : gv.h
+pp_ctl$(O) : handy.h
+pp_ctl$(O) : hv.h
+pp_ctl$(O) : mg.h
+pp_ctl$(O) : op.h
+pp_ctl$(O) : opcode.h
+pp_ctl$(O) : perl.h
+pp_ctl$(O) : pp_ctl.c
+pp_ctl$(O) : pp.h
+pp_ctl$(O) : proto.h
+pp_ctl$(O) : regexp.h
+pp_ctl$(O) : scope.h
+pp_ctl$(O) : sv.h
+pp_ctl$(O) : vmsish.h
+pp_ctl$(O) : util.h
+pp_hot$(O) : EXTERN.h
+pp_hot$(O) : av.h
+pp_hot$(O) : config.h
+pp_hot$(O) : cop.h
+pp_hot$(O) : cv.h
+pp_hot$(O) : embed.h
+pp_hot$(O) : form.h
+pp_hot$(O) : gv.h
+pp_hot$(O) : handy.h
+pp_hot$(O) : hv.h
+pp_hot$(O) : mg.h
+pp_hot$(O) : op.h
+pp_hot$(O) : opcode.h
+pp_hot$(O) : perl.h
+pp_hot$(O) : pp_hot.c
+pp_hot$(O) : pp.h
+pp_hot$(O) : proto.h
+pp_hot$(O) : regexp.h
+pp_hot$(O) : scope.h
+pp_hot$(O) : sv.h
+pp_hot$(O) : vmsish.h
+pp_hot$(O) : util.h
+pp_sys$(O) : EXTERN.h
+pp_sys$(O) : av.h
+pp_sys$(O) : config.h
+pp_sys$(O) : cop.h
+pp_sys$(O) : cv.h
+pp_sys$(O) : embed.h
+pp_sys$(O) : form.h
+pp_sys$(O) : gv.h
+pp_sys$(O) : handy.h
+pp_sys$(O) : hv.h
+pp_sys$(O) : mg.h
+pp_sys$(O) : op.h
+pp_sys$(O) : opcode.h
+pp_sys$(O) : perl.h
+pp_sys$(O) : pp_sys.c
+pp_sys$(O) : pp.h
+pp_sys$(O) : proto.h
+pp_sys$(O) : regexp.h
+pp_sys$(O) : scope.h
+pp_sys$(O) : sv.h
+pp_sys$(O) : vmsish.h
+pp_sys$(O) : util.h
regcomp$(O) : EXTERN.h
regcomp$(O) : INTERN.h
regcomp$(O) : av.h
@@ -710,6 +907,7 @@ $(CRTL) : $(MAKEFILE)
cleanlis :
- If f$$Search("*.Lis").nes."" Then Delete/NoConfirm/Log *.Lis;*
+ - If f$$Search("*.CPP").nes."" Then Delete/NoConfirm/Log *.CPP;*
- If f$$Search("*.Map").nes."" Then Delete/NoConfirm/Log *.Map;*
tidy : cleanlis
@@ -724,11 +922,17 @@ tidy : cleanlis
- 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("[.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.ts;-1").nes."" Then Purge/NoConfirm/Log [.Lib.Auto...]autosplit.ts
+ - 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.VMS]*.*;-1").nes."" Then Purge/NoConfirm/Log [.Lib.VMS]*.*
+ - If f$$Search("[.Lib.ExtUtils]MM_VMS.pm;-1").nes."" Then Purge/NoConfirm/Log [.Lib.ExtUtils]MM_VMS.pm
+ - If f$$Search("$(ARCHCORE)*.*").nes."" Then Purge/NoConfirm/Log $(ARCHCORE)*.*
clean : tidy
- - If f$$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*/Exclude=PerlShr_Attr.Opt
+ - If f$$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*/Exclude=PerlShr_*.Opt
- If f$$Search("*$(O);*") .nes."" Then Delete/NoConfirm/Log *$(O);*
- If f$$Search("Config.H").nes."" Then Delete/NoConfirm/Log Config.H;*
- If f$$Search("Config.SH").nes."" Then Delete/NoConfirm/Log Config.SH;*
@@ -741,24 +945,31 @@ clean : tidy
- 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("[.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);*
realclean : clean
- If f$$Search("*$(E)").nes."" Then Delete/NoConfirm/Log *$(E);*
+ - If f$$Search("*$(OLB)").nes."" Then Delete/NoConfirm/Log *$(OLB);*
- If f$$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*
- - If f$$Search("[.Lib.Auto...]*.al;-1").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]*.al;*
- - If f$$Search("[.Lib.Auto...]autosplit.ts;-1").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]autosplit.ts;*
+ - If f$$Search("[.Lib.Auto...]*.al").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]*.al;*
+ - If f$$Search("[.Lib.Auto...]autosplit.ix;-1").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]autosplit.ix;*
+ - If f$$Search("[.Lib]DynaLoader.pm").nes."" Then Delete/NoConfirm/Log [.Lib]DynaLoader.pm;*
+ - If f$$Search("[.Lib.VMS]*.*").nes."" Then Delete/NoConfirm/Log [.Lib.VMS...]*.*;*
+ - If f$$Search("[.Lib.ExtUtils]MM_VMS.pm").nes."" Then Delete/NoConfirm/Log [.Lib.ExtUtils]MM_VMS.pm;*
+ - If f$$Search("$(ARCHCORE)*.*").nes."" Then Delete/NoConfirm/Log $(ARCHCORE)*.*;*
cleansrc : clean
- - If f$$Search("*$(E)").nes."" Then Delete/NoConfirm/Log *$(E);*
- 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("$(MAKEFILE);-1").nes."" Then Purge/NoConfirm/Log $(MAKEFILE)
- 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("[.Lib.Auto...]*.al").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]*.al;*
- - If f$$Search("[.Lib.Auto...]autosplit.ts;").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]autosplit.ts;*
- - If f$$Search("[.Lib]Config.pm;").nes."" Then Delete/NoConfirm/Log [.Lib]Config.pm;*
+ - If f$$Search("[.Lib.Auto...]autosplit.ts").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]autosplit.ts;*
+ - If f$$Search("[.Lib]Config.pm").nes."" Then Delete/NoConfirm/Log [.Lib]Config.pm;*
diff --git a/vms/config.vms b/vms/config.vms
index 0c2c4f494c..74afb23dc7 100644
--- a/vms/config.vms
+++ b/vms/config.vms
@@ -39,7 +39,11 @@
* same as PRIVLIB_EXP, it is not defined, since presumably the
* program already searches PRIVLIB_EXP.
*/
-#undef ARCHLIB_EXP /**/
+#ifndef __ALPHA
+#define ARCHLIB_EXP "/perl_root/lib/VMS_AXP" /* config-skip */
+#else
+#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX" /* config-skip */
+#endif
/* CAT2:
* This macro catenates 2 tokens together.
@@ -538,6 +542,14 @@
*/
#define HAS_VFORK /**/
+/* Signal_t:
+ * This symbol's value is either "void" or "int", corresponding to the
+ * appropriate return type of a signal handler. Thus, you can declare
+ * a signal handler using "Signal_t (*handler)()", and define the
+ * handler using "Signal_t handler(sig)".
+ */
+#define Signal_t void /* Signal handler's return type */
+
/* HASVOLATILE:
* This symbol, if defined, indicates that this C compiler knows about
* the volatile declaration.
@@ -570,7 +582,7 @@
* This symbol, if defined, indicates that the waitpid routine is
* available to wait for child process.
*/
-#undef HAS_WAITPID /**/
+#define HAS_WAITPID /**/
/* HAS_WCSTOMBS:
* This symbol, if defined, indicates that the wcstombs routine is
@@ -663,7 +675,7 @@
#undef PWCHANGE /**/
#undef PWCLASS /**/
#undef PWEXPIRE /**/
-#undef PWCOMMENT /**/
+#define PWCOMMENT /**/
/* I_STDDEF:
* This symbol, if defined, indicates that <stddef.h> exists and should
@@ -789,7 +801,7 @@
* This symbol, if defined, indicates that the routine utime() is
* available to update the access and modification times of files.
*/
-#undef HAS_UTIME /**/
+#define HAS_UTIME /**/
/* I_STDARG:
* This symbol, if defined, indicates that <stdarg.h> exists and should
@@ -1030,7 +1042,7 @@
* getpwuid(), and getpwent() routines are available to
* get password entries.
*/
-#undef HAS_PASSWD /**/
+#define HAS_PASSWD /**/
/* HAS_PAUSE:
* This symbol, if defined, indicates that the pause routine is
@@ -1161,6 +1173,13 @@
*/
#define I_MATH /**/
+/* I_SYS_STAT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/stat.h>.
+ */
+#define I_SYS_STAT /**/
+
+
/* Off_t:
* This symbol holds the type used to declare offsets in the kernel.
* It can be int, long, off_t, etc... It may be necessary to include
@@ -1251,7 +1270,7 @@
/* VMS: true for gcc, undef for VAXC/DECC. This is handled in Descrip.MMS
* C. Bailey 26-Aug-1994
*/
-/*#define GNUC_ATTRIBUTE_CHECK /* */
+/*#define GNUC_ATTRIBUTE_CHECK */
/* VOID_CLOSEDIR:
* This symbol, if defined, indicates that the closedir() routine
diff --git a/vms/descrip.mms b/vms/descrip.mms
index bd30a87095..1af44baa6c 100644
--- a/vms/descrip.mms
+++ b/vms/descrip.mms
@@ -1,5 +1,5 @@
# Descrip.MMS for perl5 on VMS
-# Last revised 12-Oct-1994 by Charles Bailey bailey@genetics.upenn.edu
+# Last revised 10-Mar-1995 by Charles Bailey bailey@genetics.upenn.edu
#
#: This file uses MMS syntax, and can be processed using DEC's MMS product,
#: or the free MMK clone (available by ftp at ftp.spc.edu). If you want to
@@ -39,37 +39,43 @@
#### Start of system configuration section. ####
+
+#: >>>>> Architecture-specific options <<<<<
.ifdef AXE
# File type to use for object files
O = .abj
+# File type to use for object libraries
+OLB = .alb
# File type to use for executable images
E = .axe
.else
# File type to use for object files
O = .obj
+# File type to use for object libraries
+OLB = .olb
# File type to use for executable images
E = .exe
.endif
-# used to incorporate 'custom' malloc routines
-mallocsrc =
-mallocobj =
-
-#: Process hardware architecture macros
.ifdef __AXP__
-SYMOPT =
DECC = 1
+ARCHCORE = [.lib.VMS_AXP.CORE]
+ARCHAUTO = [.lib.auto.VMS_AXP]
.else
-# We need separate MACRO files declaring global symbols
-SYMOPT = ,perlshr_gbl.opt/Option
+ARCHCORE = [.lib.VMS_VAX.CORE]
+ARCHAUTO = [.lib.auto.VMS_VAX]
.endif
-#: Process compiler selection macros
+
+#: >>>>>Compiler-specific options <<<<<
.ifdef GNUC
.first
@ If F$TrnLnm("Sys").eqs."" Then Define/NoLog SYS GNU_CC_Include:[VMS]
CC = gcc
-XTRACCFLAGS = /Obj=$(MMS$TARGET_NAME)$(O)
+# -fno-builtin avoids bug in gcc up to version 2.6.2 which can destroy
+# data when memcpy() is called on large (>64 kB) blocks of memory
+# (fixed in gcc 2.6.3)
+XTRACCFLAGS = /Obj=$(MMS$TARGET_NAME)$(O)/NoCase_Hack/Optimize=2/CC1="""""-fno-builtin"""""
DBGSPECFLAGS =
XTRADEF = ,GNUC_ATTRIBUTE_CHECK
XTRAOBJS =
@@ -83,7 +89,7 @@ LIBS1 = $(XTRAOBJS)
DBGSPECFLAGS = /Show=(Source,Include,Expansion)
.ifdef decc
LIBS2 =
-XTRACCFLAGS = /Standard=VAXC/Include=[]/Prefix=All/Obj=$(MMS$TARGET_NAME)$(O)
+XTRACCFLAGS = /Warning=Disable=(ADDRCONSTEXT,MISSINGRETURN)/Include=[]/Prefix=All/Obj=$(MMS$TARGET_NAME)$(O)
XTRADEF =
.else # VAXC
XTRACCFLAGS = /Include=[]/Object=$(O)
@@ -92,6 +98,9 @@ LIBS2 = Sys$Share:VAXCRTL.Exe/Shareable
.endif
.endif
+
+#: >>>>> Configuration options <<<<<
+#: __DEBUG__: builds images with full VMS debugger support
.ifdef __DEBUG__
DBGCCFLAGS = /List/Debug/NoOpt$(DBGSPECFLAGS)
DBGLINKFLAGS = /Debug/Map/Full/Cross
@@ -102,7 +111,9 @@ DBGLINKFLAGS = /NoMap
DBG =
.endif
-# Process option macros
+#: SOCKET: build in support for TCP/IP sockets
+#: By default, used SOCKETSHR library; see ReadMe.VMS
+#: for information on changing socket support
.ifdef SOCKET
SOCKDEF = ,VMS_DO_SOCKETS
SOCKLIB = SocketShr/Share
@@ -124,20 +135,26 @@ SOCKHLIS =
SOCKOBJ =
.endif
-# DEBUGGING ==> perl -D, not the VMS debugger
+# C preprocessor manifest "DEBUGGING" ==> perl -D, not the VMS debugger
CFLAGS = /Define=(DEBUGGING$(SOCKDEF)$(XTRADEF))$(XTRACCFLAGS)$(DBGCCFLAGS)
LINKFLAGS = $(DBGLINKFLAGS)
+MAKE = MMK
MAKEFILE = [.VMS]Descrip.MMS # this file
NOOP = continue
-XSUBPP = MCR Sys$Disk:[]Miniperl$(E) [.ext]xsubpp -typemap [-]typemap
-# List of extensions to build into perlmain; enclose each in quotes and
-# separate by spaces.
-EXT = "DynaLoader"
-# Source and object files for these extensions; leading comma is required
+# Macros to invoke a copy of miniperl during the build. Targets which
+# are built using these macros should depend on $(MINIPERL_EXE)
+MINIPERL_EXE = Sys$Disk:[]miniperl$(E)
+MINIPERL = MCR $(MINIPERL_EXE)
+XSUBPP = $(MINIPERL) [.lib.extutils]xsubpp
+
+# Space-separated list of "static" extensions to build into perlshr (case counts).
+EXT = DynaLoader
+# 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
-extobj = , [.ext.dynaloader]dl_vms$(O)
+extobj = [.ext.dynaloader]dl_vms$(O),
#### End of system configuration section. ####
@@ -148,96 +165,122 @@ h3 = opcode.h, patchlevel.h, perl.h, perly.h, pp.h, proto.h, regcomp.h
h4 = regexp.h, scope.h, sv.h, vmsish.h, util.h
h = $(h1), $(h2), $(h3), $(h4) $(SOCKHLIS)
-c1 = av.c, scope.c, op.c, doop.c, doio.c, dump.c, hv.c $(mallocsrc)
-c2 = mg.c, perly.c, pp.c, pp_ctl.c, pp_hot.c, pp_sys.c, regcomp.c, regexec.c
-c3 = gv.c, sv.c, taint.c, toke.c, util.c, deb.c, run.c, vms.c $(SOCKCLIS)
+c1 = av.c, scope.c, op.c, doop.c, doio.c, dump.c, hv.c, mg.c
+c2 = perl.c, perly.c, pp.c, pp_hot.c, pp_ctl.c, pp_sys.c, regcomp.c, regexec.c
+c3 = gv.c, sv.c, taint.c, toke.c, util.c, deb.c, run.c, globals.c, vms.c $(SOCKCLIS)
-c = $(c1), $(c2), $(c3), perl.c, miniperlmain.c, perlmain.c
+c = $(c1), $(c2), $(c3), miniperlmain.c, perlmain.c
-obj1 = av$(O), scope$(O), op$(O), doop$(O), doio$(O), dump$(O), hv$(O) $(mallocobj)
-obj2 = mg$(O), perly$(O), pp$(O), pp_ctl$(O), pp_hot$(O), pp_sys$(O), regcomp$(O), regexec$(O)
-obj3 = gv$(O), sv$(O), taint$(O), toke$(O), util$(O), deb$(O), run$(O), vms$(O) $(SOCKOBJ)
+obj1 = perl$(O), gv$(O), toke$(O), perly$(O), op$(O), regcomp$(O), dump$(O), util$(O), mg$(O)
+obj2 = hv$(O), av$(O), run$(O), pp_hot$(O), sv$(O), pp$(O), scope$(O), pp_ctl$(O), pp_sys$(O)
+obj3 = doop$(O), doio$(O), regexec$(O), taint$(O), deb$(O), globals$(O), vms$(O) $(SOCKOBJ)
obj = $(obj1), $(obj2), $(obj3)
+ac1 = $(ARCHCORE)EXTERN.h $(ARCHCORE)INTERN.h $(ARCHCORE)XSUB.h $(ARCHCORE)av.h
+ac2 = $(ARCHCORE)config.h $(ARCHCORE)cop.h $(ARCHCORE)cv.h $(ARCHCORE)embed.h
+ac3 = $(ARCHCORE)form.h $(ARCHCORE)gv.h $(ARCHCORE)handy.h $(ARCHCORE)hv.h
+ac4 = $(ARCHCORE)keywords.h $(ARCHCORE)mg.h $(ARCHCORE)op.h $(ARCHCORE)opcode.h
+ac5 = $(ARCHCORE)patchlevel.h $(ARCHCORE)perl.h $(ARCHCORE)perly.h
+ac6 = $(ARCHCORE)pp.h $(ARCHCORE)proto.h $(ARCHCORE)regcomp.h
+ac7 = $(ARCHCORE)regexp.h $(ARCHCORE)scope.h $(ARCHCORE)sv.h $(ARCHCORE)util.h
+ac8 = $(ARCHCORE)vmsish.h $(ARCHCORE)$(DBG)libperl$(OLB) $(ARCHCORE)perlshr_attr.opt
+ac9 = $(ARCHCORE)$(DBG)perlshr_bld.opt
+.ifdef SOCKET
+acs = $(ARCHCORE)$(SOCKH)
+.else
+acs =
+.endif
+
CRTL = []crtl.opt
CRTLOPTS =,$(CRTL)/Options
.SUFFIXES
-.SUFFIXES $(O) .c
+.SUFFIXES $(O) .c .xs
+
+.xs.c :
+ $(XSUBPP) $(MMS$SOURCE) >$(MMS$TARGET)
+
.c$(O) :
$(CC) $(CFLAGS) $(MMS$SOURCE)
-all : base extras
+.xs$(O) :
+ $(XSUBPP) $(MMS$SOURCE) >$(MMS$SOURCE_NAME).c
+ $(CC) $(CFLAGS) $(MMS$SOURCE_NAME).c
+
+all : base extras archcorefiles preplibrary
@ $(NOOP)
-base : $(DBG)miniperl$(E) perl$(E) [.lib]Config.pm
+base : miniperl$(E) perl$(E) [.lib]Config.pm
@ $(NOOP)
-extras : [.lib]DynaLoader.pm
+extras : [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm [.lib.extutils]MM_VMS.pm
+ @ $(NOOP)
+archcorefiles : $(ac1) $(ac2) $(ac3) $(ac4) $(ac5) $(ac6) $(ac7) $(ac8) $(ac9) $(acs) $(ARCHAUTO)time.stamp
@ $(NOOP)
-miniperl_objs = miniperlmain$(O), perl$(O), $(obj)
-miniperl$(E) : $(miniperl_objs) , coreobjs.opt $(CRTL)
- Link $(LINKFLAGS)/NoDebug/Exe=$(MMS$TARGET) miniperlmain$(O), perl$(O), coreobjs.opt/Option $(CRTLOPTS)
-.ifdef DBG
-$(DBG)miniperl$(E) : $(miniperl_objs) , coreobjs.opt $(CRTL)
- Link $(LINKFLAGS)/Exe=$(MMS$TARGET) miniperlmain$(O), perl$(O), coreobjs.opt/Option $(CRTLOPTS)
-.endif
+miniperl_objs = miniperlmain$(O), $(obj)
+$(MINIPERL_EXE) : miniperlmain$(O), $(DBG)libperl$(OLB) $(CRTL)
+ Link $(LINKFLAGS)/NoDebug/Exe=$(MMS$TARGET) miniperlmain$(O), $(DBG)libperl$(OLB)/Library/Include=globals $(CRTLOPTS)
+miniperl$(E) : $(miniperl_objs), $(DBG)libperl$(OLB) $(CRTL)
+ Link $(LINKFLAGS)/Exe=$(DBG)$(MMS$TARGET) miniperlmain$(O),$(DBG)libperl$(OLB)/Library/Include=globals $(CRTLOPTS)
-# Use an options file to list object files since some Makes don't feed
-# long lines to DCL properly
-coreobjs.opt : $(MAKEFILE)
- @ @[.vms]genopt "$(MMS$TARGET)/Write" "|" "$(obj1)"
- @ @[.vms]genopt "$(MMS$TARGET)/Append" "|" "$(obj2)"
- @ @[.vms]genopt "$(MMS$TARGET)/Append" "|" "$(obj3)"
+$(DBG)libperl$(OLB) : $(obj)
+ @ If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET)
+ Library/Object/Replace $(MMS$TARGET) $(obj1)
+ Library/Object/Replace $(MMS$TARGET) $(obj2)
+ Library/Object/Replace $(MMS$TARGET) $(obj3)
-perlmain.c : miniperlmain.c miniperl$(E)
- MCR Sys$Disk:[]Miniperl$(E) [.VMS]Writemain.pl $(EXT)
+perlmain.c : miniperlmain.c $(MINIPERL_EXE) [.vms]writemain.pl
+ $(MINIPERL) [.VMS]Writemain.pl "$(EXT)"
-perl$(E) : perlmain$(O) $(extobj), perlshr$(E), perlshr_attr.opt $(CRTL)
+perl$(E) : perlmain$(O), perlshr$(E), perlshr_attr.opt $(MINIPERL_EXE)
@ @[.vms]genopt "PerlShr.Opt/Write" "|" "''F$Environment("Default")'$(DBG)PerlShr$(E)/Share"
- Link $(LINKFLAGS)/Exe=$(DBG)$(MMS$TARGET) perlmain$(O) $(extobj),[]perlshr.opt/Option,perlshr_attr.opt/Option
-shr_objs = perlshr$(O) ,perl$(O), $(obj)
-perlshr$(E) : $(shr_objs) ,perlshr_xtras.ts ,coreobjs.opt ,$(CRTL)
- Link $(LINKFLAGS)/Share/Exe=$(DBG)$(MMS$TARGET) perlshr$(O), perl$(O), coreobjs.opt/Option $(SYMOPT) , perlshr_attr.opt/Option, perlshr_sym.opt/Option $(CRTLOPTS)
-perlshr$(O) : [.vms]perlshr.c
- $(CC) $(CFLAGS)/NoOptimize/Object=$(MMS$TARGET) $(MMS$SOURCE)
+ Link $(LINKFLAGS)/Exe=$(DBG)$(MMS$TARGET) perlmain$(O), perlshr.opt/Option, perlshr_attr.opt/Option
+perlshr$(E) : $(DBG)libperl$(OLB) $(extobj) $(DBG)perlshr_xtras.ts
+ Link $(LINKFLAGS)/Share=$(DBG)$(MMS$TARGET) $(extobj) []$(DBG)perlshr_bld.opt/Option, perlshr_attr.opt/Option
# The following files are built in one go by gen_shrfls.pl:
-# perlshr_attr.opt, perlshr_sym.opt - VAX and AXP
-# perlshr_gbl*.mar, perlshr_gbl*$(O), perlshr_gbl.opt - VAX only
+# perlshr_attr.opt, $(DBG)perlshr_bld.opt - VAX and AXP
+# perlshr_gbl*.mar, perlshr_gbl*$(O) - VAX only
.ifdef DECC_PIPES_BROKEN
# This is a backup target used only with older versions of the DECCRTL which
# can't deal with pipes properly. See ReadMe.VMS for details.
-perlshr_xtras.ts : perl.h config.h vmsish.h proto.h [.vms]gen_shrfls.pl miniperl$(E) $(MAKEFILE)
+$(DBG)perlshr_xtras.ts : perl.h config.h vmsish.h proto.h [.vms]gen_shrfls.pl $(MINIPERL_EXE) $(MAKEFILE) $(CRTL)
$(CC) $(CFLAGS)/NoObject/NoList/PreProcess=perl.i perl.h
- MCR Sys$Disk:[]Miniperl$(E) [.vms]gen_shrfls.pl "~~NOCC~~perl.i" $(O)
+ $(MINIPERL) [.vms]gen_shrfls.pl "~~NOCC~~perl.i" "$(O)" "$(DBG)" "$(OLB)" "$(EXT)" "$(CRTL)"
@ Delete/NoLog/NoConfirm perl.i;
- @ Copy NLA0: perlshr_xtras.ts
- @ Purge/NoLog/NoConfirm perlshr_xtras.ts
+ @ If F$Search("$(DBG)perlshr_xtras.ts").nes."" Then Delete/NoLog/NoConfirm $(DBG)perlshr_xtras.ts;*
+ @ Copy NLA0: $(DBG)perlshr_xtras.ts
.else
-perlshr_xtras.ts : perl.h config.h vmsish.h proto.h [.vms]gen_shrfls.pl miniperl$(E) $(MAKEFILE)
- MCR Sys$Disk:[]Miniperl$(E) [.vms]gen_shrfls.pl "$(CC)$(CFLAGS)" $(O)
- @ Copy NLA0: perlshr_xtras.ts
- @ Purge/NoLog/NoConfirm perlshr_xtras.ts
+$(DBG)perlshr_xtras.ts : perl.h config.h vmsish.h proto.h [.vms]gen_shrfls.pl $(MINIPERL_EXE) $(MAKEFILE) $(CRTL)
+ $(MINIPERL) [.vms]gen_shrfls.pl "$(CC)$(CFLAGS)" "$(O)" "$(DBG)" "$(OLB)" "$(EXT)" "$(CRTL)"
+ @ If F$Search("$(DBG)perlshr_xtras.ts").nes."" Then Delete/NoLog/NoConfirm $(DBG)perlshr_xtras.ts;*
+ @ Copy NLA0: $(DBG)perlshr_xtras.ts
.endif
-[.lib]config.pm : [.vms]config.vms [.vms]genconfig.pl miniperl$(E)
- MCR Sys$Disk:[]Miniperl$(E) [.VMS]GenConfig.Pl
- MCR Sys$Disk:[]Miniperl$(E) ConfigPM.
+[.lib]config.pm : [.vms]config.vms [.vms]genconfig.pl $(MINIPERL_EXE)
+ $(MINIPERL) [.VMS]GenConfig.Pl cc=$(CC)$(CFLAGS) ldflags=$(LINKFLAGS)
+ $(MINIPERL) ConfigPM.
-[.ext.dynaloader]dl_vms.c : [.ext.dynaloader]dl_vms.xs miniperl$(E)
+[.ext.dynaloader]dl_vms.c : [.ext.dynaloader]dl_vms.xs $(MINIPERL_EXE)
$(XSUBPP) $(MMS$SOURCE) >$(MMS$TARGET)
[.ext.dynaloader]dl_vms$(O) : [.ext.dynaloader]dl_vms.c
$(CC) $(CFLAGS) /Object=$(MMS$TARGET) $(MMS$SOURCE)
-preplibrary : miniperl$(E) [.lib]Config.pm
- @ Create/Directory [.lib.auto]
- MCR Sys$Disk:[]Miniperl$(E) "-Ilib" -e "use AutoSplit; autosplit_lib_modules(@ARGV)" [.lib]*.pm [.lib.*]*.pm
-
-[.lib]DynaLoader.pm : [.ext.dynaloader]dynaloader.pm preplibrary
+[.lib]DynaLoader.pm : [.ext.dynaloader]dynaloader.pm
Copy/Log/NoConfirm [.ext.dynaloader]dynaloader.pm [.lib]DynaLoader.pm
- MCR Sys$Disk:[]Miniperl$(E) autosplit DynaLoader
+
+[.lib.VMS]Filespec.pm : [.vms.ext]Filespec.pm
+ @ Create/Directory [.lib.VMS]
+ Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET)
+
+[.lib.ExtUtils]MM_VMS.pm : [.vms.ext]MM_VMS.pm
+ Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET)
+
+preplibrary : $(MINIPERL_EXE) [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm [.lib.ExtUtils]MM_VMS.pm
+ @ Write Sys$Output "Autosplitting Perl library . . ."
+ @ Create/Directory [.lib.auto]
+ @ $(MINIPERL) "-Ilib" -e "use AutoSplit; autosplit_lib_modules(@ARGV)" [.lib]*.pm [.lib.*]*.pm
.ifdef SOCKET
$(SOCKOBJ) : $(SOCKC) $(SOCKH)
@@ -251,8 +294,8 @@ $(SOCKH) : [.vms]$(SOCKH)
Copy/Log/NoConfirm [.vms]$(SOCKH) []$(SOCKH)
.endif
-#opcode.h : opcode.pl
-# MCR Sys$Disk:[]Miniperl$(E) opcode.pl
+#opcode.h : opcode.pl $(MINIPERL_EXE)
+# $(MINIPERL) opcode.pl
perly.h : perly.c # Quick and dirty 'touch'
Copy/Log/NoConfirm perly.h; ;
@@ -274,8 +317,108 @@ perly$(O) : perly.c, perly.h, $(h)
test : perl$(E)
- @[.VMS]Test.Com
+# CORE subset for MakeMaker, so we can build Perl without sources
+# Should move to VMS installperl when we get one
+$(ARCHCORE)EXTERN.h : EXTERN.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)INTERN.h : INTERN.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)XSUB.h : XSUB.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)av.h : av.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)config.h : config.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)cop.h : cop.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)cv.h : cv.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)embed.h : embed.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)form.h : form.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)gv.h : gv.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)handy.h : handy.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)hv.h : hv.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)keywords.h : keywords.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)mg.h : mg.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)op.h : op.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)opcode.h : opcode.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)patchlevel.h : patchlevel.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)perl.h : perl.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)perly.h : perly.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)pp.h : pp.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)proto.h : proto.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)regcomp.h : regcomp.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)regexp.h : regexp.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)scope.h : scope.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)sv.h : sv.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)util.h : util.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)vmsish.h : vmsish.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+.ifdef SOCKET
+$(ARCHCORE)$(SOCKH) : $(SOCKH)
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+.endif
+$(ARCHCORE)$(DBG)libperl$(OLB) : $(DBG)libperl$(OLB) $(DBG)perlshr_xtras.ts
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)perlshr_attr.opt : $(DBG)perlshr_xtras.ts
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log perlshr_attr.opt $(MMS$TARGET)
+$(ARCHCORE)$(DBG)perlshr_bld.opt : $(DBG)perlshr_xtras.ts
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(DBG)perlshr_bld.opt $(MMS$TARGET)
+$(ARCHAUTO)time.stamp :
+ @ Create/Directory $(ARCHAUTO)
+ @ If F$Search("$(MMS$TARGET)").eqs."" Then Copy/NoConfirm _NLA0: $(MMS$TARGET)
+
# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE
-# If this runs make out of memory, delete /usr/include lines.
av$(O) : EXTERN.h
av$(O) : av.c
av$(O) : av.h
@@ -430,28 +573,6 @@ hv$(O) : scope.h
hv$(O) : sv.h
hv$(O) : vmsish.h
hv$(O) : util.h
-malloc$(O) : EXTERN.h
-malloc$(O) : av.h
-malloc$(O) : config.h
-malloc$(O) : cop.h
-malloc$(O) : cv.h
-malloc$(O) : embed.h
-malloc$(O) : form.h
-malloc$(O) : gv.h
-malloc$(O) : handy.h
-malloc$(O) : hv.h
-malloc$(O) : malloc.c
-malloc$(O) : mg.h
-malloc$(O) : op.h
-malloc$(O) : opcode.h
-malloc$(O) : perl.h
-malloc$(O) : pp.h
-malloc$(O) : proto.h
-malloc$(O) : regexp.h
-malloc$(O) : scope.h
-malloc$(O) : sv.h
-malloc$(O) : vmsish.h
-malloc$(O) : util.h
mg$(O) : EXTERN.h
mg$(O) : av.h
mg$(O) : config.h
@@ -474,6 +595,28 @@ mg$(O) : scope.h
mg$(O) : sv.h
mg$(O) : vmsish.h
mg$(O) : util.h
+perl$(O) : EXTERN.h
+perl$(O) : av.h
+perl$(O) : config.h
+perl$(O) : cop.h
+perl$(O) : cv.h
+perl$(O) : embed.h
+perl$(O) : form.h
+perl$(O) : gv.h
+perl$(O) : handy.h
+perl$(O) : hv.h
+perl$(O) : mg.h
+perl$(O) : op.h
+perl$(O) : opcode.h
+perl$(O) : perl.c
+perl$(O) : perl.h
+perl$(O) : pp.h
+perl$(O) : proto.h
+perl$(O) : regexp.h
+perl$(O) : scope.h
+perl$(O) : sv.h
+perl$(O) : vmsish.h
+perl$(O) : util.h
perly$(O) : EXTERN.h
perly$(O) : av.h
perly$(O) : config.h
@@ -518,6 +661,72 @@ pp$(O) : scope.h
pp$(O) : sv.h
pp$(O) : vmsish.h
pp$(O) : util.h
+pp_ctl$(O) : EXTERN.h
+pp_ctl$(O) : av.h
+pp_ctl$(O) : config.h
+pp_ctl$(O) : cop.h
+pp_ctl$(O) : cv.h
+pp_ctl$(O) : embed.h
+pp_ctl$(O) : form.h
+pp_ctl$(O) : gv.h
+pp_ctl$(O) : handy.h
+pp_ctl$(O) : hv.h
+pp_ctl$(O) : mg.h
+pp_ctl$(O) : op.h
+pp_ctl$(O) : opcode.h
+pp_ctl$(O) : perl.h
+pp_ctl$(O) : pp_ctl.c
+pp_ctl$(O) : pp.h
+pp_ctl$(O) : proto.h
+pp_ctl$(O) : regexp.h
+pp_ctl$(O) : scope.h
+pp_ctl$(O) : sv.h
+pp_ctl$(O) : vmsish.h
+pp_ctl$(O) : util.h
+pp_hot$(O) : EXTERN.h
+pp_hot$(O) : av.h
+pp_hot$(O) : config.h
+pp_hot$(O) : cop.h
+pp_hot$(O) : cv.h
+pp_hot$(O) : embed.h
+pp_hot$(O) : form.h
+pp_hot$(O) : gv.h
+pp_hot$(O) : handy.h
+pp_hot$(O) : hv.h
+pp_hot$(O) : mg.h
+pp_hot$(O) : op.h
+pp_hot$(O) : opcode.h
+pp_hot$(O) : perl.h
+pp_hot$(O) : pp_hot.c
+pp_hot$(O) : pp.h
+pp_hot$(O) : proto.h
+pp_hot$(O) : regexp.h
+pp_hot$(O) : scope.h
+pp_hot$(O) : sv.h
+pp_hot$(O) : vmsish.h
+pp_hot$(O) : util.h
+pp_sys$(O) : EXTERN.h
+pp_sys$(O) : av.h
+pp_sys$(O) : config.h
+pp_sys$(O) : cop.h
+pp_sys$(O) : cv.h
+pp_sys$(O) : embed.h
+pp_sys$(O) : form.h
+pp_sys$(O) : gv.h
+pp_sys$(O) : handy.h
+pp_sys$(O) : hv.h
+pp_sys$(O) : mg.h
+pp_sys$(O) : op.h
+pp_sys$(O) : opcode.h
+pp_sys$(O) : perl.h
+pp_sys$(O) : pp_sys.c
+pp_sys$(O) : pp.h
+pp_sys$(O) : proto.h
+pp_sys$(O) : regexp.h
+pp_sys$(O) : scope.h
+pp_sys$(O) : sv.h
+pp_sys$(O) : vmsish.h
+pp_sys$(O) : util.h
regcomp$(O) : EXTERN.h
regcomp$(O) : INTERN.h
regcomp$(O) : av.h
@@ -804,6 +1013,7 @@ $(CRTL) : $(MAKEFILE)
cleanlis :
- If F$Search("*.Lis").nes."" Then Delete/NoConfirm/Log *.Lis;*
+ - If F$Search("*.CPP").nes."" Then Delete/NoConfirm/Log *.CPP;*
- If F$Search("*.Map").nes."" Then Delete/NoConfirm/Log *.Map;*
tidy : cleanlis
@@ -818,11 +1028,17 @@ tidy : cleanlis
- 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("[.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.ts;-1").nes."" Then Purge/NoConfirm/Log [.Lib.Auto...]autosplit.ts
+ - 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.VMS]*.*;-1").nes."" Then Purge/NoConfirm/Log [.Lib.VMS]*.*
+ - If F$Search("[.Lib.ExtUtils]MM_VMS.pm;-1").nes."" Then Purge/NoConfirm/Log [.Lib.ExtUtils]MM_VMS.pm
+ - If F$Search("$(ARCHCORE)*.*").nes."" Then Purge/NoConfirm/Log $(ARCHCORE)*.*
clean : tidy
- - If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*/Exclude=PerlShr_Attr.Opt
+ - If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*/Exclude=PerlShr_*.Opt
- If F$Search("*$(O);*") .nes."" Then Delete/NoConfirm/Log *$(O);*
- If F$Search("Config.H").nes."" Then Delete/NoConfirm/Log Config.H;*
- If F$Search("Config.SH").nes."" Then Delete/NoConfirm/Log Config.SH;*
@@ -835,24 +1051,31 @@ clean : tidy
- 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("[.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);*
realclean : clean
- If F$Search("*$(E)").nes."" Then Delete/NoConfirm/Log *$(E);*
+ - If F$Search("*$(OLB)").nes."" Then Delete/NoConfirm/Log *$(OLB);*
- If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*
- - If F$Search("[.Lib.Auto...]*.al;-1").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]*.al;*
- - If F$Search("[.Lib.Auto...]autosplit.ts;-1").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]autosplit.ts;*
+ - If F$Search("[.Lib.Auto...]*.al").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]*.al;*
+ - If F$Search("[.Lib.Auto...]autosplit.ix;-1").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]autosplit.ix;*
+ - If F$Search("[.Lib]DynaLoader.pm").nes."" Then Delete/NoConfirm/Log [.Lib]DynaLoader.pm;*
+ - If F$Search("[.Lib.VMS]*.*").nes."" Then Delete/NoConfirm/Log [.Lib.VMS...]*.*;*
+ - If F$Search("[.Lib.ExtUtils]MM_VMS.pm").nes."" Then Delete/NoConfirm/Log [.Lib.ExtUtils]MM_VMS.pm;*
+ - If F$Search("$(ARCHCORE)*.*").nes."" Then Delete/NoConfirm/Log $(ARCHCORE)*.*;*
cleansrc : clean
- - If F$Search("*$(E)").nes."" Then Delete/NoConfirm/Log *$(E);*
- 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("$(MAKEFILE);-1").nes."" Then Purge/NoConfirm/Log $(MAKEFILE)
- 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("[.Lib.Auto...]*.al").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]*.al;*
- - If F$Search("[.Lib.Auto...]autosplit.ts;").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]autosplit.ts;*
- - If F$Search("[.Lib]Config.pm;").nes."" Then Delete/NoConfirm/Log [.Lib]Config.pm;*
+ - If F$Search("[.Lib.Auto...]autosplit.ts").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]autosplit.ts;*
+ - If F$Search("[.Lib]Config.pm").nes."" Then Delete/NoConfirm/Log [.Lib]Config.pm;*
diff --git a/vms/ext/Filespec.pm b/vms/ext/Filespec.pm
new file mode 100644
index 0000000000..35c8365c4c
--- /dev/null
+++ b/vms/ext/Filespec.pm
@@ -0,0 +1,323 @@
+# Perl hooks into the routines in vms.c for interconversion
+# of VMS and Unix file specification syntax.
+#
+# Version: 1.1
+# Author: Charles Bailey bailey@genetics.upenn.edu
+# Revised: 08-Mar-1995
+
+=head1 NAME
+
+VMS::Filespec - convert between VMS and Unix file specification syntax
+
+=head1 SYNOPSIS
+
+use VMS::Filespec;
+$vmsspec = vmsify('/my/Unix/file/specification');
+$unixspec = unixify('my:[VMS]file.specification');
+$path = pathify('my:[VMS.or.Unix.directory]specification.dir');
+$dirfile = fileify('my:[VMS.or.Unix.directory.specification]');
+$vmsdir = vmspath('my/VMS/or/Unix/directory/specification.dir');
+$unixdir = unixpath('my:[VMS.or.Unix.directory]specification.dir');
+candelete('my:[VMS.or.Unix]file.specification');
+
+=head1 DESCRIPTION
+
+This package provides routines to simplify conversion between VMS and
+Unix syntax when processing file specifications. This is useful when
+porting scripts designed to run under either OS, and also allows you
+to take advantage of conveniences provided by either syntax (e.g.
+ability to easily concatenate Unix-style specifications). In
+addition, it provides an additional file test routine, C<candelete>,
+which determines whether you have delete access to a file.
+
+If you're running under VMS, the routines in this package are special,
+in that they're automatically made available to any Perl script,
+whether you're running F<miniperl> or the full F<perl>. The C<use
+VMS::Filespec> or C<require VMS::Filespec; import VMS::Filespec ...>
+statement can be used to import the function names into the current
+package, but they're always available if you use the fully qualified
+name, whether or not you've mentioned the F<.pm> file in your script.
+If you're running under another OS and have installed this package, it
+behaves like a normal Perl extension (in fact, you're using Perl
+substitutes to emulate the necessary VMS system calls).
+
+Each of these routines accepts a file specification in either VMS or
+Unix syntax, and returns the converted file specification, ir undef if
+an error occurs. The conversions are, for the most part, simply
+string manipulations; the routines do not check the details of syntax
+(e.g. that only legal characters are used). There is one exception:
+when running under VMS, conversions from VMS syntax use the $PARSE
+service to expand specifications, so illegal syntax, or a relative
+directory specification which extends above the tope of the current
+directory path (e.g [---.foo] when in dev:[dir.sub]) will cause
+errors. In general, any legal file specification will be converted
+properly, but garbage input tends to produce garbage output.
+
+The routines provided are:
+
+=head2 vmsify
+
+Converts a file specification to VMS syntax.
+
+=head2 unixify
+
+Converts a file specification to Unix syntax.
+
+=head2 pathify
+
+Converts a directory specification to a path - that is, a string you
+can prepend to a file name to form a valid file specification. If the
+input file specification uses VMS syntax, the returned path does, too;
+likewise for Unix syntax (Unix paths are guaranteed to end with '/').
+
+=head2 fileify
+
+Converts a directory specification to the file specification of the
+directory file - that is, a string you can pass to functions like
+C<stat> or C<rmdir> to manipulate the directory file. If the
+input directory specification uses VMS syntax, the returned file
+specification does, too; likewise for Unix syntax.
+
+=head2 vmspath
+
+Acts like C<pathify>, but insures the returned path uses VMS syntax.
+
+=head2 unixpath
+
+Acts like C<pathify>, but insures the returned path uses Unix syntax.
+
+=head2 candelete
+
+Determines whether you have delete access to a file. If you do, C<candelete>
+returns true. If you don't, or its argument isn't a legal file specification,
+C<candelete> returns FALSE. Unlike other file tests, the argument to
+C<candelete> must be a file name (not a FileHandle), and, since it's an XSUB,
+it's a list operator, so you need to be careful about parentheses. Both of
+these restrictions may be removed in the future if the functionality of
+C<candelete> becomes part of the Perl core.
+
+=head1 REVISION
+
+This document was last revised 08-Mar-1995, for Perl 5.001.
+
+=cut
+
+package VMS::Filespec;
+
+# If you want to use this package on a non-VMS system, uncomment
+# the following line, and add AutoLoader to @ISA.
+# require AutoLoader;
+require Exporter;
+
+@ISA = qw( Exporter );
+@EXPORT = qw( &rmsexpand &vmsify &unixify &pathify
+ &fileify &vmspath &unixpath &candelete);
+
+1;
+
+
+__END__
+
+
+# The autosplit routines here are provided for use by non-VMS systems
+# They are not guaranteed to function identically to the XSUBs of the
+# same name, since they do not have access to the RMS system routine
+# sys$parse() (in particular, no real provision is made for handling
+# of complex DECnet node specifications). However, these routines
+# should be adequate for most purposes.
+
+# A sort-of sys$parse() replacement
+sub rmsexpand {
+ my($fspec,$defaults) = @_;
+ if (!$fspec) { return undef }
+ my($node,$dev,$dir,$name,$type,$ver,$dnode,$ddev,$ddir,$dname,$dtype,$dver);
+
+ $fspec =~ s/:$//;
+ $defaults = [] unless $defaults;
+ $defaults = [ $defaults ] unless ref($defaults) && ref($defaults) eq 'ARRAY';
+
+ while ($fspec !~ m#[:>\]]# && $ENV{$fspec}) { $fspec = $ENV{$fspec} }
+
+ if ($fspec =~ /:/) {
+ my($dev,$devtrn,$base);
+ ($dev,$base) = split(/:/,$fspec);
+ $devtrn = $dev;
+ while ($devtrn = $ENV{$devtrn}) {
+ if ($devtrn =~ /(.)([:>\]])$/) {
+ $dev .= ':', last if $1 eq '.';
+ $dev = $devtrn, last;
+ }
+ }
+ $fspec = $dev . $base;
+ }
+
+ ($node,$dev,$dir,$name,$type,$ver) = $fspec =~
+ /([^:]*::)?([^:]*:)?([^>\]]*[>\]])?([^.;]*)(\.?[^.;]*)([.;]?\d*)/;
+ foreach ((@$defaults,$ENV{'DEFAULT'})) {
+ last if $node && $ver && $type && $dev && $dir && $name;
+ ($dnode,$ddev,$ddir,$dname,$dtype,$dver) =
+ /([^:]*::)?([^:]*:)?([^>\]]*[>\]])?([^.;]*)(\.?[^.;]*)([.;]?\d*)/;
+ $node = $dnode if $dnode && !$node;
+ $dev = $ddev if $ddev && !$dev;
+ $dir = $ddir if $ddir && !$dir;
+ $name = $dname if $dname && !$name;
+ $type = $dtype if $dtype && !$type;
+ $ver = $dver if $dver && !$ver;
+ }
+ # do this the long way to keep -w happy
+ $fspec = '';
+ $fspec .= $node if $node;
+ $fspec .= $dev if $dev;
+ $fspec .= $dir if $dir;
+ $fspec .= $name if $name;
+ $fspec .= $type if $type;
+ $fspec .= $ver if $ver;
+ $fspec;
+}
+
+sub vmsify {
+ my($fspec) = @_;
+ my($hasdev,$dev,$defdirs,$dir,$base,@dirs,@realdirs);
+
+ if ($fspec =~ m#^\.(\.?)/?$#) { return $1 ? '[-]' : '[]'; }
+ return $fspec if $fspec !~ m#/#;
+ ($hasdev,$dir,$base) = $fspec =~ m#(/?)(.*)/(.*)#;
+ @dirs = split(m#/#,$dir);
+ if ($base eq '.') { $base = ''; }
+ elsif ($base eq '..') {
+ push @dirs,$base;
+ $base = '';
+ }
+ foreach (@dirs) {
+ next unless $_; # protect against // in input
+ next if $_ eq '.';
+ if ($_ eq '..') {
+ if (@realdirs && $realdirs[$#realdirs] ne '-') { pop @realdirs }
+ else { push @realdirs, '-' }
+ }
+ else { push @realdirs, $_; }
+ }
+ if ($hasdev) {
+ $dev = shift @realdirs;
+ @realdirs = ('000000') unless @realdirs;
+ $base = '' unless $base; # keep -w happy
+ $dev . ':[' . join('.',@realdirs) . "]$base";
+ }
+ else {
+ '[' . join('',map($_ eq '-' ? $_ : ".$_",@realdirs)) . "]$base";
+ }
+}
+
+sub unixify {
+ my($fspec) = @_;
+
+ return $fspec if $fspec !~ m#[:>\]]#;
+ return '.' if ($fspec eq '[]' || $fspec eq '<>');
+ if ($fspec =~ m#^[<\[](\.|-+)(.*)# ) {
+ $fspec = ($1 eq '.' ? '' : "$1.") . $2;
+ my($dir,$base) = split(/[\]>]/,$fspec);
+ my(@dirs) = grep($_,split(m#\.#,$dir));
+ if ($dirs[0] =~ /^-/) {
+ my($steps) = shift @dirs;
+ for (1..length($steps)) { unshift @dirs, '..'; }
+ }
+ join('/',@dirs) . "/$base";
+ }
+ else {
+ $fspec = rmsexpand($fspec,'_N_O_T_:[_R_E_A_L_]');
+ $fspec =~ s/.*_N_O_T_:(?:\[_R_E_A_L_\])?//;
+ my($dev,$dir,$base) = $fspec =~ m#([^:<\[]*):?[<\[](.*)[>\]](.*)#;
+ my(@dirs) = split(m#\.#,$dir);
+ if ($dirs[0] && $dirs[0] =~ /^-/) {
+ my($steps) = shift @dirs;
+ for (1..length($steps)) { unshift @dirs, '..'; }
+ }
+ "/$dev/" . join('/',@dirs) . "/$base";
+ }
+}
+
+
+sub fileify {
+ my($path) = @_;
+
+ if (!$path) { return undef }
+ if ($path =~ /(.+)\.([^:>\]]*)$/) {
+ $path = $1;
+ if ($2 !~ /^dir(?:;1)?$/i) { return undef }
+ }
+
+ if ($path !~ m#[/>\]]#) {
+ $path =~ s/:$//;
+ while ($ENV{$path}) {
+ ($path = $ENV{$path}) =~ s/:$//;
+ last if $path =~ m#[/>\]]#;
+ }
+ }
+ if ($path =~ m#[>\]]#) {
+ my($dir,$sep,$base) = $path =~ /(.*)([>\]])(.*)/;
+ $sep =~ tr/<[/>]/;
+ if ($base) {
+ "$dir$sep$base.dir;1";
+ }
+ else {
+ if ($dir !~ /\./) { $dir =~ s/([<\[])/${1}000000./; }
+ $dir =~ s#\.(\w+)$#$sep$1#;
+ $dir =~ s/^.$sep//;
+ "$dir.dir;1";
+ }
+ }
+ else {
+ $path =~ s#/$##;
+ "$path.dir;1";
+ }
+}
+
+sub pathify {
+ my($fspec) = @_;
+
+ if (!$fspec) { return undef }
+ if ($fspec =~ m#[/>\]]$#) { return $fspec; }
+ if ($fspec =~ m#(.+)\.([^/>\]]*)$# && $2 && $2 ne '.') {
+ $fspec = $1;
+ if ($2 !~ /^dir(?:;1)?$/i) { return undef }
+ }
+
+ if ($fspec !~ m#[/>\]]#) {
+ $fspec =~ s/:$//;
+ while ($ENV{$fspec}) {
+ if ($ENV{$fspec} =~ m#[>\]]$#) { return $ENV{$fspec} }
+ else { $fspec = $ENV{$fspec} =~ s/:$// }
+ }
+ }
+
+ if ($fspec !~ m#[>\]]#) { "$fspec/"; }
+ else {
+ if ($fspec =~ /([^>\]]+)([>\]])(.+)/) { "$1.$3$2"; }
+ else { $fspec; }
+ }
+}
+
+sub vmspath {
+ pathify(vmsify($_[0]));
+}
+
+sub unixpath {
+ pathify(unixify($_[0]));
+}
+
+sub candelete {
+ my($fspec) = @_;
+ my($parent);
+
+ return '' unless -w $fspec;
+ $fspec =~ s#/$##;
+ if ($fspec =~ m#/#) {
+ ($parent = $fspec) =~ s#/[^/]+$#;
+ return (-w $parent);
+ }
+ elsif ($parent = fileify($fspec)) { # fileify() here to expand lnms
+ $parent =~ s/[>\]][^>\]]+//;
+ return (-w fileify($parent));
+ }
+ else { return (-w '[-]'); }
+}
diff --git a/vms/ext/MM_VMS.pm b/vms/ext/MM_VMS.pm
index 3ef0233d9a..f861d83021 100644
--- a/vms/ext/MM_VMS.pm
+++ b/vms/ext/MM_VMS.pm
@@ -11,6 +11,818 @@ package ExtUtils::MM_VMS;
use Config;
require Exporter;
+use VMS::Filespec;
+use File::Basename;
+
+Exporter::import('ExtUtils::MakeMaker',
+ qw(%att %skip %Recognized_Att_Keys $Verbose &neatvalue));
+
+
+sub fixpath {
+ my($path) = @_;
+ my($head,$macro,$tail);
+
+ while (($head,$macro,$tail) = ($path =~ m#(.*?)\$\((\S+?)\)/(.*)#)) {
+ ($macro = unixify($att{$macro})) =~ s#/$##;
+ $path = "$head$macro/$tail";
+ }
+ vmsify($path);
+}
+
+
+sub init_others {
+ &MM_Unix::init_others;
+ $att{NOOP} = "\tContinue";
+ $att{MAKEFILE} = '$(MAKEFILE)';
+ $att{RM_F} = '$(PERL) -e "foreach (@ARGV) { -d $_ ? rmdir $_ : unlink $_}"';
+ $att{RM_RF} = '$(PERL) -e "use File::Path; use VMS::Filespec; @dirs = map(unixify($_),@ARGV); rmtree(\@dirs,0,0)"';
+ $att{TOUCH} = '$(PERL) -e "$t=time; utime $t,$t,@ARGV"';
+ $att{CP} = 'Copy/NoConfirm';
+ $att{MV} = 'Rename/NoConfirm';
+}
+
+sub constants {
+ my(@m,$def);
+ push @m, "
+NAME = $att{NAME}
+DISTNAME = $att{DISTNAME}
+VERSION = $att{VERSION}
+
+# In which library should we install this extension?
+# This is typically the same as PERL_LIB.
+# (also see INST_LIBDIR and relationship to ROOTEXT)
+INST_LIB = ",vmspath($att{INST_LIB}),"
+INST_ARCHLIB = ",vmspath($att{INST_ARCHLIB}),"
+INST_EXE = ",vmspath($att{INST_EXE}),"
+
+# Perl library to use when building the extension
+PERL_LIB = ",vmspath($att{PERL_LIB}),"
+PERL_ARCHLIB = ",vmspath($att{PERL_ARCHLIB}),"
+LIBPERL_A = ",vmsify($att{LIBPERL_A}),"
+";
+
+# Define I_PERL_LIBS to include the required -Ipaths
+# To be cute we only include PERL_ARCHLIB if different
+# To be portable we add quotes for VMS
+my(@i_perl_libs) = qw{-I$(PERL_ARCHLIB) -I$(PERL_LIB)};
+shift(@i_perl_libs) if ($att{PERL_ARCHLIB} eq $att{PERL_LIB});
+push @m, "I_PERL_LIBS = \"".join('" "',@i_perl_libs)."\"\n";
+
+if ($att{PERL_SRC}) {
+ push @m, "
+# Where is the perl source code located?
+PERL_SRC = ",vmspath($att{PERL_SRC});
+}
+ push @m,"
+# Perl header files (will eventually be under PERL_LIB)
+PERL_INC = ",vmspath($att{PERL_INC}),"
+# Perl binaries
+PERL = $att{PERL}
+FULLPERL = $att{FULLPERL}
+
+# FULLEXT = Pathname for extension directory (eg DBD/Oracle).
+# BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT.
+# ROOTEXT = Directory part of FULLEXT with leading slash (e.g /DBD)
+FULLEXT = ",vmsify($att{FULLEXT}),"
+BASEEXT = $att{BASEEXT}
+ROOTEXT = ",($att{ROOTEXT} eq '') ? '[]' : vmspath($att{ROOTEXT}),"
+
+INC = ";
+
+ if ($att{'INC'}) {
+ push @m,'/Include=(';
+ my(@includes) = split(/\s+/,$att{INC});
+ foreach (@includes) {
+ s/^-I//;
+ push @m,vmspath($_);
+ }
+ push @m, ")\n";
+ }
+
+ if ($att{DEFINE} ne '') {
+ my(@defs) = split(/\s+/,$att{DEFINE});
+ foreach $def (@defs) {
+ $def =~ s/^-D//;
+ $def = "\"$def\"" if $def =~ /=/;
+ }
+ $att{DEFINE} = join ',',@defs;
+ }
+
+ push @m,"
+DEFINE = $att{DEFINE}
+OBJECT = ",vmsify($att{OBJECT}),"
+LDFROM = ",vmsify($att{LDFROM}),"
+LINKTYPE = $att{LINKTYPE}
+
+# Handy lists of source code files:
+XS_FILES = ",join(', ', sort keys %{$att{XS}}),"
+C_FILES = ",join(', ', @{$att{C}}),"
+O_FILES = ",join(', ', @{$att{O_FILES}}),"
+H_FILES = ",join(', ', @{$att{H}}),"
+
+.SUFFIXES : .xs
+
+# This extension may link to it's own library (see SDBM_File)";
+ push @m,"
+MYEXTLIB = ",vmsify($att{MYEXTLIB}),"
+
+# Here is the Config.pm that we are using/depend on
+CONFIGDEP = \$(PERL_ARCHLIB)Config.pm, \$(PERL_INC)config.h
+
+# Where to put things:
+INST_LIBDIR = ",($att{'INST_LIBDIR'} = vmspath(unixpath($att{INST_LIB}) . unixpath($att{ROOTEXT}))),"
+INST_ARCHLIBDIR = ",($att{'INST_ARCHLIBDIR'} = vmspath(unixpath($att{INST_ARCHLIB}) . unixpath($att{ROOTEXT}))),"
+
+INST_AUTODIR = ",($att{'INST_AUTODIR'} = vmspath(unixpath($att{INST_LIB}) . 'auto/' . unixpath($att{FULLEXT}))),'
+INST_ARCHAUTODIR = ',($att{'INST_ARCHAUTODIR'} = vmspath(unixpath($att{INST_ARCHLIB}) . 'auto/' . unixpath($att{FULLEXT}))),'
+
+INST_STATIC = $(INST_ARCHAUTODIR)$(BASEEXT).olb
+INST_DYNAMIC = $(INST_ARCHAUTODIR)$(BASEEXT).$(DLEXT)
+INST_BOOT = $(INST_ARCHAUTODIR)$(BASEEXT).bs
+INST_PM = ',join(', ',map(fixpath($_),sort values %{$att{PM}})),'
+';
+
+ join('',@m);
+}
+
+
+sub const_cccmd {
+ my($cmd) = $Config{'cc'};
+ my($name,$sys,@m);
+
+ ( $name = $att{NAME} . "_cflags" ) =~ s/:/_/g ;
+ print STDOUT "Unix shell script ".$Config{"$att{'BASEEXT'}_cflags"}.
+ " required to modify CC command for $att{'BASEEXT'}\n"
+ if ($Config{$name});
+
+ # Deal with $att{DEFINE} here since some C compilers pay attention
+ # to only one /Define clause on command line, so we have to
+ # conflate the ones from $Config{'cc'} and $att{DEFINE}
+ if ($att{DEFINE} ne '') {
+ if ($cmd =~ m:/define=\(?([^\(\/\)]+)\)?:i) {
+ $cmd = $` . "/Define=(" . $1 . ",$att{DEFINE})" . $';
+ }
+ else { $cmd .= "/Define=($att{DEFINE})" }
+ }
+
+ $sys = ($cmd =~ /^gcc/i) ? 'GNU_CC_Include:[VMS]' : 'Sys$Library';
+ push @m,'
+.FIRST
+ @ If F$TrnLnm("Sys").eqs."" Then Define/NoLog SYS ',$sys,'
+
+';
+ push(@m, "CCCMD = $cmd\n");
+
+ join('',@m);
+}
+
+
+
+sub const_loadlibs{
+ my (@m);
+ push @m, "
+# $att{NAME} might depend on some other libraries.
+#
+# Dependent libraries are linked in either by the Link command
+# at build time or by the DynaLoader at bootstrap time.
+#
+# These comments may need revising:
+#
+# EXTRALIBS = Full list of libraries needed for static linking.
+# Only those libraries that actually exist are included.
+#
+# BSLOADLIBS = List of those libraries that are needed but can be
+# linked in dynamically.
+#
+# LDLOADLIBS = List of those libraries which must be statically
+# linked into the shared library.
+#
+EXTRALIBS = ",map(vmsify($_) . ' ',$att{'EXTRALIBS'}),"
+BSLOADLIBS = ",map(vmsify($_) . ' ',$att{'BSLOADLIBS'}),"
+LDLOADLIBS = ",map(vmsify($_) . ' ',$att{'LDLOADLIBS'}),"\n";
+
+ join('',@m);
+}
+
+# --- Tool Sections ---
+
+sub tool_autosplit{
+ my($self, %attribs) = @_;
+ my($asl) = "";
+ $asl = "\$AutoSplit::Maxlen=$attribs{MAXLEN};" if $attribs{MAXLEN};
+ q{
+# Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto
+AUTOSPLITFILE = $(PERL) $(I_PERL_LIBS) -e "use AutoSplit;}.$asl.q{ AutoSplit::autosplit($ARGV[0], $ARGV[1], 0, 1, 1) ;"
+};
+}
+
+sub tool_xsubpp{
+ my($xsdir) = unixpath($att{PERL_LIB}).'ExtUtils';
+ # drop back to old location if xsubpp is not in new location yet
+ $xsdir = unixpath($att{PERL_SRC}).'ext' unless (-f "$xsdir/xsubpp");
+ my(@tmdeps) = '$(XSUBPPDIR)typemap';
+ push(@tmdeps, "typemap") if -f "typemap";
+ my(@tmargs) = map("-typemap $_", @tmdeps);
+ "
+XSUBPPDIR = ".vmspath($xsdir)."
+XSUBPP = \$(PERL) \$(XSUBPPDIR)xsubpp
+XSUBPPDEPS = @tmdeps
+XSUBPPARGS = @tmargs
+";
+}
+
+sub tools_other {
+ "
+# Assumes \$(MMS) invokes MMS or MMK
+USEMAKEFILE = /Descrip=
+USEMACROS = /Macro=(
+MACROEND = )
+MAKEFILE = Descrip.MMS
+SHELL = Posix
+LD = $att{LD}
+TOUCH = $att{TOUCH}
+CP = $att{CP}
+RM_F = $att{RM_F}
+RM_RF = $att{RM_RF}
+MKPATH = Create/Directory
+";
+}
+
+
+# --- Translation Sections ---
+
+sub c_o {
+ '
+.c.obj :
+ $(CCCMD) $(CCCDLFLAGS) /Include=($(PERL_INC)) $(INC) $(MMS$TARGET_NAME).c
+';
+}
+
+sub xs_c {
+ '
+.xs.c :
+ $(XSUBPP) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET)
+';
+}
+
+sub xs_o { # many makes are too dumb to use xs_c then c_o
+ '
+.xs.obj :
+ $(XSUBPP) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET_NAME).c
+ $(CCCMD) $(CCCDLFLAGS) /Include=($(PERL_INC)) $(INC) $(MMS$TARGET_NAME).c
+';
+}
+
+
+# --- Target Sections ---
+
+sub top_targets{
+ my(@m);
+ push @m, '
+all :: config linkext $(INST_PM)
+'.$att{NOOP}.'
+
+config :: '.$att{MAKEFILE}.'
+ @ $(MKPATH) $(INST_LIBDIR), $(INST_ARCHAUTODIR)
+';
+ push @m, '
+$(O_FILES) : $(H_FILES)
+' if @{$att{O_FILES} || []} && @{$att{H} || []};
+ join('',@m);
+}
+
+sub dlsyms {
+ my($self,%attribs) = @_;
+ my($funcs) = $attribs{DL_FUNCS} || $att{DL_FUNCS} || {};
+ my($vars) = $attribs{DL_VARS} || $att{DL_VARS} || [];
+ my(@m);
+
+ push(@m,'
+dynamic :: perlshr.opt $(BASEEXT).opt
+ ',$att{NOOP},'
+
+perlshr.opt : makefile.PL
+ $(PERL) -e "open O,\'>perlshr.opt\'; print O ""PerlShr/Share\n""; close O"
+') unless $skip{'dynamic'};
+
+ push(@m,'
+static :: $(BASEEXT).opt
+ ',$att{NOOP},'
+') unless $skip{'static'};
+
+ push(@m,'
+$(BASEEXT).opt : makefile.PL
+ $(PERL) $(I_PERL_LIBS) -e "use ExtUtils::MakeMaker; mksymlists(DL_FUNCS => ',neatvalue($att{DL_FUNCS}),', DL_VARS => ',neatvalue($att{DL_VARS}),',NAME => ',$att{NAME},')"
+ $(PERL) $(I_PERL_LIBS) -e "open OPT,\'>>$(MMS$TARGET)\'; print OPT ""$(INST_STATIC)/Include=$(BASEEXT)\n$(INST_STATIC)/Library\n"";close OPT"
+');
+
+ join('',@m);
+}
+
+
+# --- Dynamic Loading Sections ---
+
+sub dynamic_lib {
+ my($self, %attribs) = @_;
+ my($otherldflags) = $attribs{OTHERLDFLAGS} || "";
+ my(@m);
+ push @m,"
+
+OTHERLDFLAGS = $otherldflags
+
+";
+ push @m, '
+$(INST_DYNAMIC) : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt perlshr.opt $(BASEEXT).opt
+ @ $(MKPATH) $(INST_ARCHAUTODIR)
+ Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) $(BASEEXT).opt/Option,perlshr.opt/Option,$(PERL_INC)perlshr_attr.opt/Option
+';
+
+ join('',@m);
+}
+
+sub dynamic_bs {
+ my($self, %attribs) = @_;
+ '
+BOOTSTRAP = '."$att{BASEEXT}.bs".'
+
+# As MakeMaker mkbootstrap might not write a file (if none is required)
+# we use touch to prevent make continually trying to remake it.
+# The DynaLoader only reads a non-empty file.
+$(BOOTSTRAP): '."$att{MAKEFILE} $att{BOOTDEP}".'
+ @ Write Sys$Output "Running mkbootstrap for $(NAME) ($(BSLOADLIBS))"
+ @ $(PERL) $(I_PERL_LIBS) -e "use ExtUtils::MakeMaker; &mkbootstrap(""$(BSLOADLIBS)"");" "INST_LIB=$(INST_LIB)" "INST_ARCHLIB=$(INST_ARCHLIB)" "PERL_SRC=$(PERL_SRC)" "NAME=$(NAME)"
+ @ $(TOUCH) $(BOOTSTRAP)
+
+$(INST_BOOT): $(BOOTSTRAP)
+ @ '.$att{RM_RF}.' $(INST_BOOT)
+ - '.$att{CP}.' $(BOOTSTRAP) $(INST_BOOT)
+';
+}
+# --- Static Loading Sections ---
+
+sub static_lib {
+ '
+$(INST_STATIC) : $(OBJECT), $(MYEXTLIB)
+ @ $(MKPATH) $(INST_ARCHAUTODIR)
+ If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET)
+ Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST)
+';
+}
+
+
+sub installpm_x { # called by installpm perl file
+ my($self, $dist, $inst, $splitlib) = @_;
+ $inst = fixpath($inst);
+ $dist = vmsify($dist);
+ my($instdir) = dirname($inst);
+ my(@m);
+
+ push(@m, "
+$inst : $dist $att{MAKEFILE}
+",' @ ',$att{RM_F},' $(MMS$TARGET);*
+ @ $(MKPATH) ',$instdir,'
+ @ ',$att{CP},' $(MMS$SOURCE) $(MMS$TARGET)
+');
+ if ($splitlib and $inst =~ /\.pm$/) {
+ my($attdir) = $splitlib;
+ $attdir =~ s/\$\((.*)\)/$1/;
+ $attdir = $att{$attdir} if $att{$attdir};
+
+ push(@m, ' $(AUTOSPLITFILE) $(MMS$TARGET) ',
+ vmspath(unixpath($attdir) . 'auto')."\n");
+ push(@m,"\n");
+ }
+
+ join('',@m);
+}
+
+
+# --- Sub-directory Sections ---
+
+sub exescan {
+ vmsify($_);
+}
+
+sub subdir_x {
+ my($self, $subdir) = @_;
+ my(@m);
+ # The intention is that the calling Makefile.PL should define the
+ # $(SUBDIR_MAKEFILE_PL_ARGS) make macro to contain whatever
+ # information needs to be passed down to the other Makefile.PL scripts.
+ # If this does not suit your needs you'll need to write your own
+ # MY::subdir_x() method to override this one.
+ push @m, '
+config :: ',vmspath($subdir) . '$(MAKEFILE)
+ $(MMS) $(USEMAKEFILE) $(MMS$SOURCE) config $(USEMACROS)(INST_LIB=$(INST_LIB),INST_ARCHLIB=$(INST_ARCHLIB), \\
+ LINKTYPE=$(LINKTYPE),INST_EXE=$(INST_EXE),LIBPERL_A=$(LIBPERL_A)$(MACROEND) $(SUBDIR_MAKEFILE_PL_ARGS)
+
+',vmspath($subdir),'$(MAKEFILE) : ',vmspath($subdir),'Makefile.PL, $(CONFIGDEP)
+ @Write Sys$Output "Rebuilding $(MMS$TARGET) ..."
+ $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e "use ExtUtils::MakeMaker; MM->runsubdirpl(qw('.$subdir.'))" \\
+ $(SUBDIR_MAKEFILE_PL_ARGS) INST_LIB=$(INST_LIB) INST_ARCHLIB=$(INST_ARCHLIB) \\
+ INST_EXE=$(INST_EXE) LIBPERL_A=$(LIBPERL_A) LINKTYPE=$(LINKTYPE)
+ @Write Sys$Output "Rebuild of $(MMS$TARGET) complete."
+
+# The default clean, realclean and test targets in this Makefile
+# have automatically been given entries for $subdir.
+
+subdirs ::
+ Set Default ',vmspath($subdir),'
+ $(MMS) all $(USEMACROS)LINKTYPE=$(LINKTYPE)$(MACROEND)
+';
+ join('',@m);
+}
+
+
+# --- Cleanup and Distribution Sections ---
+
+sub clean {
+ my($self, %attribs) = @_;
+ my(@m);
+ push @m, '
+# Delete temporary files but do not touch installed files
+# We don\'t delete the Makefile here so that a
+# later make realclean still has a makefile to work from
+clean ::
+';
+ foreach (@{$att{DIR}}) { # clean subdirectories first
+ my($vmsdir) = vmspath($_);
+ push( @m, ' If F$Search("'.$vmsdir.'$(MAKEFILE)") Then $(MMS) $(USEMAKEFILE)'.$vmsdir.'$(MAKEFILE) clean'."\n");
+ }
+ push @m, "
+ $att{RM_F} *.Map;* *.lis;* *.cpp;* *.Obj;* *.Olb;* \$(BOOTSTRAP);* \$(BASEEXT).bso;*
+";
+
+ my(@otherfiles) = values %{$att{XS}}; # .c files from *.xs files
+ push(@otherfiles, $attribs{FILES}) if $attribs{FILES};
+ push(@otherfiles, "blib.dir");
+ push(@m, " $att{RM_F} ".join(";* ", map(fixpath($_),@otherfiles)),";*\n");
+ # See realclean and ext/utils/make_ext for usage of Makefile.old
+ push(@m, " $att{MV} $att{MAKEFILE} $att{MAKEFILE}_old");
+ push(@m, " $attribs{POSTOP}\n") if $attribs{POSTOP};
+ join('', @m);
+}
+
+
+sub realclean {
+ my($self, %attribs) = @_;
+ my(@m);
+ push(@m,'
+# Delete temporary files (via clean) and also delete installed files
+realclean :: clean
+');
+ foreach(@{$att{DIR}}){
+ my($vmsdir) = vmspath($_);
+ push(@m, ' If F$Search("'."$vmsdir$att{MAKEFILE}".'").nes."" Then $(MMS) $(USEMAKEFILE)'."$vmsdir$att{MAKEFILE}".' realclean'."\n");
+ push(@m, ' If F$Search("'."$vmsdir$att{MAKEFILE}".'_old").nes."" Then $(MMS) $(USEMAKEFILE)'."$vmsdir$att{MAKEFILE}".'_old realclean'."\n");
+ }
+ push @m,'
+ ',$att{RM_RF},' $(INST_AUTODIR) $(INST_ARCHAUTODIR)
+ ',$att{RM_F},' *.Opt;* $(INST_DYNAMIC);* $(INST_STATIC);* $(INST_BOOT);* $(INST_PM);*
+ ',$att{RM_F},' $(OBJECT);* $(MAKEFILE);* $(MAKEFILE)_old;*
+';
+ push(@m, " $att{RM_RF} ".join(";* ", map(fixpath($_),$attribs{'FILES'})),";*\n") if $attribs{'FILES'};
+ push(@m, " $attribs{POSTOP}\n") if $attribs{POSTOP};
+ join('', @m);
+}
+
+
+sub distclean {
+ my($self, %attribs) = @_;
+ my($preop) = $attribs{PREOP} || '@ !'; # e.g., update MANIFEST
+ my($zipname) = $attribs{TARNAME} || '$(DISTNAME)-$(VERSION)';
+ my($zipflags) = $attribs{ZIPFLAGS} || '-Vu';
+ my($postop) = $attribs{POSTOP} || "";
+ my($mkfiles) = join(' ', map("$_\$(MAKEFILE) $_\$(MAKEFILE)_old",map(vmspath($_),@{$att{'DIR'}})));
+
+ "
+distclean : clean
+ $preop
+ $att{RM_F} $mkfiles
+ Zip \"$zipflags\" $zipname \$(BASEEXT).* Makefile.PL
+ $postop
+";
+}
+
+
+# --- Test and Installation Sections ---
+
+sub test {
+ my($self, %attribs) = @_;
+ my($tests) = $attribs{TESTS} || ( -d 't' ? 't/*.t' : '');
+ my(@m);
+ push @m,'
+test : all
+';
+ push(@m,' $(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" $(I_PERL_LIBS) -e "use Test::Harness; runtests @ARGV;" '.$tests."\n")
+ if $tests;
+ push(@m,' $(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" $(I_PERL_LIBS) test.pl',"\n")
+ if -f 'test.pl';
+ foreach(@{$att{DIR}}){
+ my($vmsdir) = vmspath($_);
+ push(@m, ' If F$Search("',$vmsdir,'$(MAKEFILE)").nes."" Then $(PERL) -e "chdir \'',$vmsdir,
+ '\'; print `$(MMS) $(USEMAKEFILE)$(MAKEFILE) $(USEMACRO)LINKTYPE=$(LINKTYPE)$(MACROEND) test`'."\n");
+ }
+ push(@m, "\t\@echo 'No tests defined for \$(NAME) extension.'\n") unless @m > 1;
+
+ join('',@m);
+}
+
+sub install {
+ my($self, %attribs) = @_;
+ my(@m);
+ push @m, q{
+doc_install ::
+ @ $(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" $(I_PERL_LIBS) \\
+ -e "use ExtUtils::MakeMaker; MM->writedoc('Module', '$(NAME)', \\
+ 'LINKTYPE=$(LINKTYPE)', 'VERSION=$(VERSION)', 'EXE_FILES=$(EXE_FILES)')"
+};
+
+ push(@m, "
+install :: pure_install doc_install
+
+pure_install :: all
+");
+ # install subdirectories first
+ foreach(@{$att{DIR}}){
+ my($vmsdir) = vmspath($_);
+ push(@m, ' If F$Search("',$vmsdir,'$(MAKEFILE)").nes."" Then $(PERL) -e "chdir \'',$vmsdir,
+ '\'; print `$(MMS) $(USEMAKEFILE)$(MAKEFILE) install`'."\n");
+ }
+
+ push(@m, "\t! perl5.000 used to autosplit into INST_ARCHLIB, we delete these old files here
+ $att{RM_F} ",fixpath(unixpath($Config{'installarchlib'}).'auto/$(FULLEXT)/*.al'),';* ',
+ fixpath(unixpath($Config{'installarchlib'}).'auto/$(FULLEXT)/*.ix'),";*
+ \$(MMS) \$(USEMACROS)INST_LIB=$Config{'installprivlib'},INST_ARCHLIB=$Config{'installarchlib'},INST_EXE=$Config{'installbin'}\$(MACROEND)
+");
+
+ join("",@m);
+}
+
+sub perldepend {
+ my(@m);
+
+ push @m, '
+$(OBJECT) : $(PERL_INC)EXTERN.h, $(PERL_INC)INTERN.h, $(PERL_INC)XSUB.h, $(PERL_INC)av.h
+$(OBJECT) : $(PERL_INC)cop.h, $(PERL_INC)cv.h, $(PERL_INC)embed.h, $(PERL_INC)form.h
+$(OBJECT) : $(PERL_INC)gv.h, $(PERL_INC)handy.h, $(PERL_INC)hv.h, $(PERL_INC)keywords.h
+$(OBJECT) : $(PERL_INC)mg.h, $(PERL_INC)op.h, $(PERL_INC)opcode.h, $(PERL_INC)patchlevel.h
+$(OBJECT) : $(PERL_INC)perl.h, $(PERL_INC)perly.h, $(PERL_INC)pp.h, $(PERL_INC)proto.h
+$(OBJECT) : $(PERL_INC)regcomp.h, $(PERL_INC)regexp.h, $(PERL_INC)scope.h, $(PERL_INC)sv.h
+$(OBJECT) : $(PERL_INC)vmsish.h, $(PERL_INC)util.h, $(PERL_INC)config.h
+
+';
+ push(@m,'
+
+$(PERL_ARCHLIB)/Config.pm: $(PERL_SRC)/config.sh
+ @ Write Sys$Error "$(PERL_ARCHLIB)/Config.pm may be out of date with $(PERL_SRC)/config.sh"
+ Set Default $(PERL_SRC)
+ $(MMS) $(USEMAKEFILE)[.VMS]$(MAKEFILE) [.lib]config.pm
+');
+
+ push(@m, join(" ", map(vmsify($_),values %{$att{XS}}))." : \$(XSUBPPDEPS)\n")
+ if %{$att{XS}};
+
+ join('',@m);
+}
+
+sub makefile {
+ my(@m,@cmd);
+ push(@m,'
+
+# We take a very conservative approach here, but it\'s worth it.
+# We move $(MAKEFILE) to $(MAKEFILE)_old here to avoid gnu make looping.
+$(MAKEFILE) : Makefile.PL $(CONFIGDEP)
+ @ Write Sys$Output "',$att{MAKEFILE},' out-of-date with respect to $(MMS$SOURCE_LIST)"
+ @ Write Sys$Output "Cleaning current config before rebuilding ',$att{MAKEFILE},'...
+ - ',"$att{MV} $att{MAKEFILE} $att{MAKEFILE}_old",'
+ - $(MMS) $(USEMAKEFILE)',$att{MAKEFILE},'_old clean
+ $(PERL) $(I_PERL_LIBS) Makefile.PL
+ @ Write Sys$Output "Now you must rerun $(MMS)."
+');
+
+ join('',@m);
+}
+
+
+# --- Determine libraries to use and how to use them ---
+
+sub makeaperl {
+ my($self, %attribs) = @_;
+ my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmp, $libperl) =
+ @attribs{qw(MAKE DIRS STAT EXTRA INCL TARGET TMP LIBPERL)};
+ my(@m);
+ my($linkcmd,@staticopts,@staticpkgs,$extralist,$target,$targdir,$libperldir);
+
+ # The front matter of the linkcommand...
+ $linkcmd = join ' ', $Config{'ld'},
+ grep($_, @Config{qw(large split ldflags ccdlflags)});
+ $linkcmd =~ s/\s+/ /g;
+
+ # Which *.olb files could we make use of...
+ local(%olbs);
+ File::Find::find(sub {
+ return unless m/\.olb$/;
+ return if m/^libperl/;
+ $olbs{$ENV{DEFAULT}} = $_;
+ }, grep( -d $_, @{$searchdirs || []}), grep( -f $_, @{$static || []}) );
+
+ $extra = [] unless $extra && ref $extra eq 'ARRAY';
+ # Sort the object libraries in inverse order of
+ # filespec length to try to insure that dependent extensions
+ # will appear before their parents, so the linker will
+ # search the parent library to resolve references.
+ # (e.g. Intuit::DWIM will precede Intuit, so unresolved
+ # references from [.intuit.dwim]dwim.obj can be found
+ # in [.intuit]intuit.olb).
+ for (sort keys %olbs) {
+ next unless $olbs{$_} =~ /\.olb$/;
+ my($dir) = vmspath($_);
+ my($extralibs) = $dir . "extralibs.ld";
+ my($extopt) = $dir . $olbs{$_};
+ $extopt =~ s/\.olb$/.opt/;
+ if (-f $extralibs ) {
+ open LIST,$extralibs or warn $!,next;
+ push @$extra, <LIST>;
+ close LIST;
+ }
+ if (-f $extopt) {
+ open OPT,$extopt or die $!;
+ while (<OPT>) {
+ next unless /(?:UNIVERSAL|VECTOR)=boot_([\w_]+)/;
+ # ExtUtils::Miniperl expects Unix paths
+ (my($pkg) = "$2_$2.a") =~ s#_*#/#g;
+ push @staticpkgs,$pkg;
+ }
+ push @staticopts, $extopt;
+ }
+ }
+
+ $target = "Perl.Exe" unless $target;
+ ($shrtarget,$targdir) = fileparse($target);
+ $shrtarget =~ s/^([^.]*)/$1Shr/;
+ $shrtarget = $targdir . $shrtarget;
+ $target = "Perlshr$Config{'dlext'}" unless $target;
+ $tmp = "[]" unless $tmp;
+ $tmp = unixpath($tmp);
+ if (@$extra) {
+ $extralist = join(' ',@$extra);
+ $extralist =~ s/[,\s\n]+/, /g;
+ }
+ else { $extralist = ''; }
+ if ($libperl) {
+ unless (-f $libperl || -f ($libperl = unixpath($Config{'installarchlib'})."CORE/$libperl")){
+ print STDOUT "Warning: $libperl not found";
+ undef $libperl;
+ }
+ }
+ unless ($libperl) {
+ if (defined $att{PERL_SRC}) {
+ $libperl = "$att{PERL_SRC}/libperl.olb";
+ } elsif ( -f ( $libperl = unixpath($Config{'installarchlib'}).'CORE/libperl.olb' )) {
+ } else {
+ print STDOUT "Warning: $libperl not found";
+ }
+ }
+ $libperldir = vmspath((fileparse($libperl))[1]);
+
+ push @m, '
+# Fill in the target you want to produce if it\'s not perl
+MAP_TARGET = ',vmsify($target),'
+MAP_SHRTARGET = ',vmsify($shrtarget),"
+FULLPERL = $att{'FULLPERL'}
+MAP_LINKCMD = $linkcmd
+MAP_PERLINC = ", $perlinc ? map('"-I'.vmspath($_).'" ',@{$perlinc}) : '$(I_PERL_LIB)','
+# We use the linker options files created with each extension, rather than
+#specifying the object files directly on the command line.
+MAP_STATIC = ',@staticopts ? join(' ', @staticopts) : '','
+MAP_OPTS = ',@staticopts ? ','.join(',', map($_.'/Option', @staticopts)) : '',"
+MAP_EXTRA = $extralist
+MAP_LIBPERL = ",vmsify($libperl),'
+';
+
+
+ push @m,'
+$(MAP_SHRTARGET) : $(MAP_LIBPERL) $(MAP_STATIC) ',"${libperldir}Perlshr_Attr.Opt",'
+ $(MAP_LINKCMD)/Shareable=$(MMS$TARGET) $(MAP_OPTS), $(MAP_EXTRA), $(MAP_LIBPERL) ',"${libperldir}Perlshr_Attr.Opt",'
+$(MAP_TARGET) : $(MAP_SHRTARGET) ',vmsify("${tmp}perlmain.obj"),' ',vmsify("${tmp}PerlShr.Opt"),'
+ $(MAP_LINKCMD) ',vmsify("${tmp}perlmain.obj"),', PerlShr.Opt/Option
+ @ Write Sys$Output "To install the new ""$(MAP_TARGET)"" binary, say"
+ @ Write Sys$Output " $(MMS)$(USEMAKEFILE)$(MAKEFILE) inst_perl $(USEMACROS)MAP_TARGET=$(MAP_TARGET)$(ENDMACRO)"
+ @ Write Sys$Output "To remove the intermediate files, say
+ @ Write Sys$Output " $(MMS)$(USEMAKEFILE)$(MAKEFILE) map_clean"
+';
+ push @m,'
+',vmsify("${tmp}perlmain.c"),' : $(MAKEFILE)
+ @ $(PERL) $(MAP_PERLINC) -e "use ExtUtils::Miniperl; writemain(qw|',@staticpkgs,'|)" >$(MMS$TARGET)
+';
+
+ push @m, q{
+doc_inst_perl :
+ @ $(PERL) -e "use ExtUtils::MakeMaker; MM->writedoc('Perl binary','$(MAP_TARGET)','MAP_STATIC=$(MAP_STATIC)','MAP_EXTRA=$(MAP_EXTRA)','MAP_LIBPERL=$(MAP_LIBPERL)')"
+};
+
+ push @m, "
+inst_perl : pure_inst_perl doc_inst_perl
+
+pure_inst_perl : \$(MAP_TARGET)
+ $att{CP} \$(MAP_SHRTARGET) ",vmspath($Config{'installbin'}),"
+ $att{CP} \$(MAP_TARGET) ",vmspath($Config{'installbin'}),"
+
+map_clean :
+ $att{RM_F} ",vmsify("${tmp}perlmain.obj"),vmsify("${tmp}perlmain.c"),
+ vmsify("${tmp}PerlShr.Opt")," $makefilename
+";
+
+ join '', @m;
+}
+
+sub extliblist {
+ '','','';
+}
+
+sub old_extliblist {
+ '','',''
+}
+
+sub new_extliblist {
+ '','',''
+}
+
+# --- Write a DynaLoader bootstrap file if required
+
+# VMS doesn't require a bootstrap file as a rule
+sub mkbootstrap {
+ 1;
+}
+
+sub mksymlists {
+ my($self,%attribs) = @_;
+
+ MY->init_main() unless $att{BASEEXT};
+
+ my($vars) = $attribs{DL_VARS} || $att{DL_VARS} || [];
+ my($procs) = $attribs{DL_FUNCS} || $att{DL_FUNCS};
+ my($package,$packprefix,$sym);
+ if (!%$procs) {
+ $package = $attribs{NAME} || $att{NAME};
+ $package =~ s/\W/_/g;
+ $procs = { $package => ["boot_$package"] };
+ }
+ my($isvax) = $Config{'arch'} =~ /VAX/i;
+
+ # Options file declaring universal symbols
+ # Used when linking shareable image for dynamic extension,
+ # or when linking PerlShr into which we've added this package
+ # as a static extension
+ # We don't do anything to preserve order, so we won't relax
+ # the GSMATCH criteria for a dynamic extension
+ open OPT, ">$att{BASEEXT}.opt";
+ foreach $package (keys %$procs) {
+ ($packprefix = $package) =~ s/\W/_/g;
+ foreach $sym (@{$$procs{$package}}) {
+ $sym = "XS_${packprefix}_$sym" unless $sym =~ /^boot_/;
+ if ($isvax) { print OPT "UNIVERSAL=$sym\n" }
+ else { print OPT "SYMBOL_VECTOR=($sym=PROCEDURE)\n"; }
+ }
+ }
+ foreach $sym (@$vars) {
+ print OPT "PSECT_ATTR=${sym},PIC,OVR,RD,NOEXE,WRT,NOSHR\n";
+ if ($isvax) { print OPT "UNIVERSAL=$sym\n" }
+ else { print OPT "SYMBOL_VECTOR=($sym=DATA)\n"; }
+ }
+ close OPT;
+}
+
+# --- Output postprocessing section ---
+
+sub nicetext {
+ # Insure that colons marking targets are preceded by space -
+ # most Unix Makes don't need this, but it's necessary under VMS
+ # to distinguish the target delimiter from a colon appearing as
+ # part of a filespec.
+
+ my($self,$text) = @_;
+ $text =~ s/([^\s:])(:+\s)/$1 $2/gs;
+ $text;
+}
+
+1;
+
+__END__
+# MM_VMS.pm
+# MakeMaker default methods for VMS
+# This package is inserted into @ISA of MakeMaker's MM before the
+# built-in MM_Unix methods if MakeMaker.pm is run under VMS.
+#
+# Version: 4.03
+# Author: Charles Bailey bailey@genetics.upenn.edu
+# Revised: 30-Jan-1995
+
+package ExtUtils::MM_VMS;
+
+use Config;
+require Exporter;
use File::VMSspec;
use File::Basename;
diff --git a/vms/ext/VMS/stdio/Makefile.PL b/vms/ext/VMS/stdio/Makefile.PL
new file mode 100644
index 0000000000..d6683b4af6
--- /dev/null
+++ b/vms/ext/VMS/stdio/Makefile.PL
@@ -0,0 +1,3 @@
+use ExtUtils::MakeMaker;
+
+WriteMakefile( 'VERSION' => '1.0' );
diff --git a/vms/ext/VMS/stdio/stdio.pm b/vms/ext/VMS/stdio/stdio.pm
new file mode 100644
index 0000000000..d8b4ec21ec
--- /dev/null
+++ b/vms/ext/VMS/stdio/stdio.pm
@@ -0,0 +1,78 @@
+# VMS::stdio - VMS extensions to Perl's stdio calls
+#
+# Author: Charles Bailey bailey@genetics.upenn.edu
+# Version: 1.0
+# Revised: 29-Nov-1994
+#
+# Revision History:
+# 1.0 29-Nov-1994 Charles Bailey bailey@genetics.upenn.edu
+# original version
+# 1.1 09-Mar-1995 Charles Bailey bailey@genetics.upenn.edu
+# changed calling sequence to return FH/undef - like POSIX::open
+# added fgetname and tmpnam
+
+=head1 NAME
+
+VMS::stdio
+
+=head1 SYNOPSIS
+
+use VMS::stdio;
+$name = fgetname(FH);
+$uniquename = &tmpnam;
+$fh = vmsfopen("my.file","rfm=var","alq=100",...) or die $!;
+
+=head1 DESCRIPTION
+
+This package gives Perl scripts access to VMS extensions to the
+C stdio routines, such as optional arguments to C<fopen()>.
+The specific routines are described below.
+
+=head2 fgetname
+
+The C<fgetname> function returns the file specification associated
+with a Perl FileHandle. If an error occurs, it returns C<undef>.
+
+=head2 tmpnam
+
+The C<tmpnam> function returns a unique string which can be used
+as a filename when creating temporary files. If, for some
+reason, it is unable to generate a name, it returns C<undef>.
+
+=head2 vmsfopen
+
+The C<vmsfopen> function provides access to the VMS CRTL
+C<fopen()> function. It is similar to the built-in Perl C<open>
+function (see L<perlfunc> for a complete description), but will
+only open normal files; it cannot open pipes or duplicate
+existing FileHandles. Up to 8 optional arguments may follow the
+file name. These arguments should be strings which specify
+optional file characteristics as allowed by the CRTL C<fopen()>
+routine. (See the CRTL reference manual for details.)
+
+You can use the FileHandle returned by C<vmsfopen> just as you
+would any other Perl FileHandle.
+
+C<vmsfopen> is a temporary solution to problems which arise in
+handling VMS-specific file formats; in the long term, we hope to
+provide more transparent access to VMS file I/O through routines
+which replace standard Perl C<open> function, or through tied
+FileHandles. When this becomes possible, C<vmsfopen> may be
+replaced.
+
+=head1 REVISION
+
+This document was last revised on 09-Mar-1995, for Perl 5.001.
+
+=cut
+
+package VMS::stdio;
+
+require DynaLoader;
+require Exporter;
+
+@ISA = qw( Exporter DynaLoader);
+@EXPORT = qw( &fgetname &tmpfile &tmpnam &vmsfopen );
+
+bootstrap VMS::stdio;
+1;
diff --git a/vms/ext/VMS/stdio/stdio.xs b/vms/ext/VMS/stdio/stdio.xs
new file mode 100644
index 0000000000..367f489bf5
--- /dev/null
+++ b/vms/ext/VMS/stdio/stdio.xs
@@ -0,0 +1,109 @@
+/* VMS::stdio - VMS extensions to stdio routines
+ *
+ * Version: 1.1
+ * Author: Charles Bailey bailey@genetics.upenn.edu
+ * Revised: 09-Mar-1995
+ *
+ *
+ * Revision History:
+ *
+ * 1.0 29-Nov-1994 Charles Bailey bailey@genetics.upenn.edu
+ * original version - vmsfopen
+ * 1.1 09-Mar-1995 Charles Bailey bailey@genetics.upenn.edu
+ * changed calling sequence to return FH/undef - like POSIX::open
+ * added fgetname and tmpnam
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+/* Use type for FILE * from Perl's XSUB typemap. This is a bit
+ * of a hack, since all Perl filehandles using this type will permit
+ * both read & write operations, but it saves to write the PPCODE
+ * directly for updating the Perl filehandles.
+ */
+typedef FILE * InOutStream;
+
+MODULE = VMS::stdio PACKAGE = VMS::stdio
+
+void
+vmsfopen(name,...)
+ char * name
+ CODE:
+ char *args[8],mode[5] = {'r','\0','\0','\0','\0'}, c;
+ register int i, myargc;
+ FILE *fp;
+ if (items > 9) {
+ croak("File::VMSfopen::vmsfopen - too many args");
+ }
+ /* First, set up name and mode args from perl's string */
+ if (*name == '+') {
+ mode[1] = '+';
+ name++;
+ }
+ if (*name == '>') {
+ if (*(name+1) == '>') *mode = 'a', name += 2;
+ else *mode = 'w', name++;
+ }
+ myargc = items - 1;
+ for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+1),na);
+ /* This hack brought to you by C's opaque arglist management */
+ switch (myargc) {
+ case 0:
+ fp = fopen(name,mode);
+ break;
+ case 1:
+ fp = fopen(name,mode,args[0]);
+ break;
+ case 2:
+ fp = fopen(name,mode,args[0],args[1]);
+ break;
+ case 3:
+ fp = fopen(name,mode,args[0],args[1],args[2]);
+ break;
+ case 4:
+ fp = fopen(name,mode,args[0],args[1],args[2],args[3]);
+ break;
+ case 5:
+ fp = fopen(name,mode,args[0],args[1],args[2],args[3],args[4]);
+ break;
+ case 6:
+ fp = fopen(name,mode,args[0],args[1],args[2],args[3],args[4],args[5]);
+ break;
+ case 7:
+ fp = fopen(name,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6]);
+ break;
+ case 8:
+ fp = fopen(name,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
+ break;
+ }
+ ST(0) = sv_newmortal();
+ if (fp != NULL) {
+ GV *gv = newGVgen("VMS::stdio");
+ c = mode[0]; name = mode;
+ if (mode[1]) *(name++) = '+';
+ if (c == 'r') *(name++) = '<';
+ else {
+ *(name++) = '>';
+ if (c == 'a') *(name++) = '>';
+ }
+ *(name++) = '&';
+ if (do_open(gv,mode,name - mode,fp))
+ sv_setsv(ST(0),newRV((SV*)gv));
+ }
+
+char *
+fgetname(fp)
+ FILE * fp
+ CODE:
+ char fname[257];
+ ST(0) = sv_newmortal();
+ if (fgetname(fp,fname) != NULL) sv_setpv(ST(0),fname);
+
+char *
+tmpnam()
+ CODE:
+ char fname[L_tmpnam];
+ ST(0) = sv_newmortal();
+ if (tmpnam(fname) != NULL) sv_setpv(ST(0),fname);
diff --git a/vms/gen_shrfls.pl b/vms/gen_shrfls.pl
index 120c355cd7..043faccb09 100644
--- a/vms/gen_shrfls.pl
+++ b/vms/gen_shrfls.pl
@@ -6,13 +6,18 @@
# Note: A rather simple-minded attempt is made to restore quotes to
# a /Define clause - use with care.
# $objsuffix - file type (including '.') used for object files.
+# $libperl - Perl object library.
+# $extnames - package names for static extensions (used to generate
+# linker options file entries for boot functions)
+# $rtlopt - name of options file specifying RTLs to which PerlShr.Exe
+# must be linked
#
# Output:
# PerlShr_Attr.Opt - linker options file which speficies that global vars
# be placed in NOSHR,WRT psects. Use when linking any object files
# against PerlShr.Exe, since cc places global vars in SHR,WRT psects
# by default.
-# PerlShr_Sym.Opt - declares universal symbols for PerlShr.Exe
+# PerlShr_Bld.Opt - declares universal symbols for PerlShr.Exe
# Perlshr_Gbl*.Mar, Perlshr_Gbl*.Obj (VAX only) - declares global symbols
# for global vars (done here because gcc can't globaldef) and creates
# transfer vectors for routines on a VAX.
@@ -29,7 +34,7 @@
# (i.e. /Define=DEBUGGING,EMBED,MULTIPLICITY)?
#
# Author: Charles Bailey bailey@genetics.upenn.edu
-# Revised: 21-Sep-1994
+# Revised: 01-Mar-1995
require 5.000;
@@ -58,6 +63,15 @@ else { ($cpp_file) = ($cc_cmd =~ /~~NOCC~~(.*)/) }
$objsuffix = shift @ARGV;
print "\$objsuffix: \\$objsuffix\\\n" if $debug;
+$dbgprefix = shift @ARGV;
+print "\$dbgprefix: \\$dbgprefix\\\n" if $debug;
+$olbsuffix = shift @ARGV;
+print "\$olbsuffix: \\$olbsuffix\\\n" if $debug;
+$libperl = "${dbgprefix}libperl$olbsuffix";
+$extnames = shift @ARGV;
+print "\$extnames: \\$extnames\\\n" if $debug;
+$rtlopt = shift @ARGV;
+print "\$rtlopt: \\$rtlopt\\\n" if $debug;
# Someday, we'll have $GetSyI built into perl . . .
$isvax = `\$ Write Sys\$Output F\$GetSyI(\"HW_MODEL\")` <= 1024;
@@ -66,14 +80,14 @@ print "\$isvax: \\$isvax\\\n" if $debug;
sub scan_var {
my($line) = @_;
- print "\tchecking for global variable\n" if $debug;
+ print "\tchecking for global variable\n" if $debug > 1;
$line =~ s/INIT\(.*\)//;
$line =~ s/\[.*//;
$line =~ s/=.*//;
$line =~ s/\W*;?\s*$//;
- print "\tfiltered to \\$line\\\n" if $debug;
+ print "\tfiltered to \\$line\\\n" if $debug > 1;
if ($line =~ /(\w+)$/) {
- print "\tvar name is \\$1\\\n" if $debug;
+ print "\tvar name is \\$1\\\n" if $debug > 1;
$vars{$1}++;
}
}
@@ -81,11 +95,11 @@ sub scan_var {
sub scan_func {
my($line) = @_;
- print "\tchecking for global routine\n" if $debug;
+ print "\tchecking for global routine\n" if $debug > 1;
if ( /(\w+)\s+\(/ ) {
- print "\troutine name is \\$1\\\n" if $debug;
+ print "\troutine name is \\$1\\\n" if $debug > 1;
if ($1 eq 'main' || $1 eq 'perl_init_ext') {
- print "\tskipped\n" if $debug;
+ print "\tskipped\n" if $debug > 1;
}
else { $funcs{$1}++ }
}
@@ -101,28 +115,28 @@ else {
LINE: while (<CPP>) {
while (/^#.*vmsish\.h/i .. /^#.*perl\.h/i) {
while (/__VMS_PROTOTYPES__/i .. /__VMS_SEPYTOTORP__/i) {
- print "vms_proto>> $_" if $debug;
+ print "vms_proto>> $_" if $debug > 2;
&scan_func($_);
if (/^EXT/) { &scan_var($_); }
last LINE unless $_ = <CPP>;
}
- print "vmsish.h>> $_" if $debug;
+ print "vmsish.h>> $_" if $debug > 2;
if (/^EXT/) { &scan_var($_); }
last LINE unless $_ = <CPP>;
}
while (/^#.*opcode\.h/i .. /^#.*perl\.h/i) {
- print "opcode.h>> $_" if $debug;
+ print "opcode.h>> $_" if $debug > 2;
if (/^OP \*\s/) { &scan_func($_); }
if (/^EXT/) { &scan_var($_); }
last LINE unless $_ = <CPP>;
}
while (/^#.*proto\.h/i .. /^#.*perl\.h/i) {
- print "proto.h>> $_" if $debug;
+ print "proto.h>> $_" if $debug > 2;
&scan_func($_);
if (/^EXT/) { &scan_var($_); }
last LINE unless $_ = <CPP>;
}
- print $_ if $debug;
+ print $_ if $debug > 3;
if (/^EXT/) { &scan_var($_); }
}
close CPP;
@@ -130,27 +144,34 @@ while (<DATA>) {
next if /^#/;
s/\s+#.*\n//;
($key,$array) = split('=',$_);
- print "Adding $key to \%$array list\n" if $debug;
+ print "Adding $key to \%$array list\n" if $debug > 1;
${$array}{$key}++;
}
+foreach (split /\s+/, $extnames) {
+ my($pkgname) = $_;
+ $pkgname =~ s/::/__/g;
+ $funcs{"boot_$pkgname"}++;
+ print "Adding boot_$pkgname to \%funcs (for extension $_)\n" if $debug;
+}
# Eventually, we'll check against existing copies here, so we can add new
# symbols to an existing options file in an upwardly-compatible manner.
$marord++;
-open(OPTSYM,">${dir}perlshr_sym.opt")
- or die "$0: Can't write to ${dir}perlshr_sym.opt: $!\n";
+open(OPTBLD,">${dir}${dbgprefix}perlshr_bld.opt")
+ or die "$0: Can't write to ${dir}${dbgprefix}perlshr_bld.opt: $!\n";
open(OPTATTR,">${dir}perlshr_attr.opt")
or die "$0: Can't write to ${dir}perlshr_attr.opt: $!\n";
if ($isvax) {
open(MAR,">${dir}perlshr_gbl${marord}.mar")
or die "$0: Can't write to ${dir}perlshr_gbl${marord}.mar: $!\n";
+ print MAR "\t.title perlshr_gbl$marord\n";
}
print OPTATTR "PSECT_ATTR=\$CHAR_STRING_CONSTANTS,PIC,SHR,NOEXE,RD,NOWRT\n";
foreach $var (sort keys %vars) {
print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,WRT,NOSHR\n";
- if ($isvax) { print OPTSYM "UNIVERSAL=$var\n"; }
- else { print OPTSYM "SYMBOL_VECTOR=($var=DATA)\n"; }
+ if ($isvax) { print OPTBLD "UNIVERSAL=$var\n"; }
+ else { print OPTBLD "SYMBOL_VECTOR=($var=DATA)\n"; }
if ($isvax) {
if ($count++ > 200) { # max 254 psects/file
print MAR "\t.end\n";
@@ -158,6 +179,7 @@ foreach $var (sort keys %vars) {
$marord++;
open(MAR,">${dir}perlshr_gbl${marord}.mar")
or die "$0: Can't write to ${dir}perlshr_gbl${marord}.mar: $!\n";
+ print MAR "\t.title perlshr_gbl$marord\n";
$count = 0;
}
# This hack brought to you by the lack of a globaldef in gcc.
@@ -173,31 +195,51 @@ foreach $func (sort keys %funcs) {
print MAR "\t.mask $func\n";
print MAR "\tjmp L\^${func}+2\n";
}
- else { print OPTSYM "SYMBOL_VECTOR=($func=PROCEDURE)\n"; }
+ else { print OPTBLD "SYMBOL_VECTOR=($func=PROCEDURE)\n"; }
}
-close OPTSYM;
close OPTATTR;
+$incstr = 'perl,globals';
if ($isvax) {
print MAR "\t.end\n";
close MAR;
- open (GBLOPT,">PerlShr_Gbl.Opt") or die "$0: Can't write to PerlShr_Gbl.Opt: $!\n";
$drvrname = "Compile_shrmars.tmp_".time;
open (DRVR,">$drvrname") or die "$0: Can't write to $drvrname: $!\n";
print DRVR "\$ Set NoOn\n";
print DRVR "\$ Delete/NoLog/NoConfirm $drvrname;\n";
print DRVR "\$ old_proc_vfy = F\$Environment(\"VERIFY_PROCEDURE\")\n";
print DRVR "\$ old_img_vfy = F\$Environment(\"VERIFY_IMAGE\")\n";
+ print DRVR "\$ MCR $^X -e \"\$ENV{'LIBPERL_RDT'} = (stat('$libperl'))[9]\"\n";
print DRVR "\$ Set Verify\n";
+ print DRVR "\$ If F\$Search(\"$libperl\").eqs.\"\" Then Library/Object/Create $libperl\n";
do {
- print GBLOPT "PerlShr_Gbl${marord}$objsuffix\n";
+ $incstr .= ",perlshr_gbl$marord";
print DRVR "\$ Macro/NoDebug/Object=PerlShr_Gbl${marord}$objsuffix PerlShr_Gbl$marord.Mar\n";
+ print DRVR "\$ Library/Object/Replace/Log $libperl PerlShr_Gbl${marord}$objsuffix\n";
} while (--$marord);
+ # We had to have a working miniperl to run this program; it's probably the
+ # one we just built. It depended on LibPerl, which will be changed when
+ # the PerlShr_Gbl* modules get inserted, so miniperl will be out of date,
+ # and so, therefore, will all of its dependents . . .
+ # We touch LibPerl here so it'll be back 'in date', and we won't rebuild
+ # miniperl etc., and therefore LibPerl, the next time we invoke MM[KS].
print DRVR "\$ old_proc_vfy = F\$Verify(old_proc_vfy,old_img_vfy)\n";
+ print DRVR "\$ MCR $^X -e \"utime 0, \$ENV{'LIBPERL_RDT'}, '$libperl'\"\n";
close DRVR;
- close GBLOPT;
- exec "\$ \@$drvrname";
}
+
+# Include object modules and RTLs in options file
+# Linker wants /Include and /Library on different lines
+print OPTBLD "$libperl/Include=($incstr)\n";
+print OPTBLD "$libperl/Library\n";
+open(RTLOPT,$rtlopt) or die "$0: Can't read $rtlopt: $!\n";
+while (<RTLOPT>) { print OPTBLD; }
+close RTLOPT;
+close OPTBLD;
+
+exec "\$ \@$drvrname" if $isvax;
+
+
__END__
# Oddball cases, so we can keep the perl.h scan above simple
diff --git a/vms/genconfig.pl b/vms/genconfig.pl
index 18bc9851db..ca15aa7943 100644
--- a/vms/genconfig.pl
+++ b/vms/genconfig.pl
@@ -3,9 +3,10 @@
#
# Extract info from Config.VMS, and add extra data here, to generate Config.sh
# Edit the static information after __END__ to reflect your site and options
-# that went into your perl binary.
+# that went into your perl binary. In addition, values which change from run
+# to run may be supplied on the command line as key=val pairs.
#
-# Rev. 30-Sep-1994 Charles Bailey bailey@genetics.upenn.edu
+# Rev. 08-Mar-1995 Charles Bailey bailey@genetics.upenn.edu
#
unshift(@INC,'lib'); # In case someone didn't define Perl_Root
@@ -26,11 +27,9 @@ EndOfGasp
$outdir = '';
open(IN,"$infile") || die "Can't open $infile: $!\n";
open(OUT,">${outdir}Config.sh") || die "Can't open ${outdir}Config.sh: $!\n";
-select OUT;
-
$time = &ctime(time());
-print <<EndOfIntro;
+print OUT <<EndOfIntro;
# This file generated by GenConfig.pl on a VMS system.
# Input obtained from:
# $infile
@@ -39,6 +38,12 @@ print <<EndOfIntro;
EndOfIntro
+foreach (@ARGV) {
+ ($key,$val) = split('=',$_,2);
+ print OUT "$key=\'$val\'\n";
+ if ($val =~/VMS_DO_SOCKETS/) { $dosock = 1; }
+}
+
while (<IN>) { # roll through the comment header in Config.VMS
last if /^#define _config_h_/;
}
@@ -59,10 +64,11 @@ while (<IN>) {
$val =~ s%/\*.*\*/\s*%%g; $val =~ s/\s*$//; # strip off trailing comment
$val =~ s/^"//; $val =~ s/"$//; # remove end quotes
$val =~ s/","/ /g; # make signal list look nice
- if ($val) { print "$token=\'$val\'\n"; }
+ if ($val) { print OUT "$token=\'$val\'\n"; }
else {
$token = "d_$token" unless $token =~ /^i_/;
- print "$token=\'$state\'\n"; }
+ print OUT "$token=\'$state\'\n";
+ }
}
close IN;
@@ -70,8 +76,34 @@ while (<DATA>) {
next if /^\s*#/ or /^\s*$/;
s/#.*$//; s/\s*$//;
($key,$val) = split('=',$_,2);
- print "$key=\'$val\'\n";
+ print OUT "$key='$val'\n";
+ eval "\$$key = '$val'";
+}
+# Add in some of the architecture-dependent stuff which has to be consistent
+print OUT "d_vms_do_sockets=",$dosock ? "'define'\n" : "'undef'\n";
+print OUT "d_has_sockets=",$dosock ? "'define'\n" : "'undef'\n";
+$osvers = `Write Sys\$Output F\$GetSyi("VERSION")`;
+chomp $osvers;
+$osvers =~ s/^V//;
+print OUT "osvers='$osvers'\n";
+$hw_model = `Write Sys\$Output F\$GetSyi("HW_MODEL")`;
+chomp $hw_model;
+if ($hw_model > 1024) {
+ print OUT "arch='VMS_AXP'\n";
+ print OUT "archname='VMS_AXP'\n";
+ $archsufx = "AXP";
+}
+else {
+ print OUT "arch='VMS_VAX'\n";
+ print OUT "archname='VMS_VAX'\n";
+ $archsufx = 'VAX';
}
+$archlib = &VMS::Filespec::vmspath($privlib);
+$archlib =~ s#\]#.VMS_$archsufx\]#;
+$installarchlib = &VMS::Filespec::vmspath($installprivlib);
+$installarchlib =~ s#\]#.VMS_$archsufx\]#;
+print OUT "archlib='$archlib'\n";
+print OUT "installarchlib='$installarchlib'\n";
__END__
@@ -85,7 +117,15 @@ __END__
osname=VMS # DO NOT CHANGE THIS! Tests elsewhere depend on this to identify
# VMS. Use the 'arch' item below to specify hardware version.
CONFIG=true
-PATCHLEVEL=0
+PATCHLEVEL=001
+ld=Link
+lddlflags=/Share
+ccdlflags=
+cccdlflags=
+libc=
+ranlib=
+eunicefix=:
+usedl=true
dldir=/ext/dl
dlobj=dl_vms.obj
dlsrc=dl_vms.c
@@ -100,13 +140,11 @@ signal_t=void
timetype=long
usemymalloc=n
builddir=perl_root:[000000]
+installprivlib=perl_root:[lib]
+privlib=perl_root:[lib]
+installbin=perl_root:[000000]
# The definitions in this block are site-specific, and will probably need to
# be changed on most systems.
myhostname=nowhere.loopback.edu
-arch=VAX
-osvers=5.5-2
-cppflags=/Define=(DEBUGGING)
-d_vms_do_sockets=undef #=define if perl5 built with socket support
-d_has_sockets=undef # This should have the same value as d_vms_do_sockets
libs= # This should list RTLs other than the C RTL and IMAGELIB (e.g. socket RTL)
diff --git a/vms/mms2make.pl b/vms/mms2make.pl
index 54db616c86..6fdc924081 100644
--- a/vms/mms2make.pl
+++ b/vms/mms2make.pl
@@ -16,6 +16,8 @@
# we deselect any other line if $conditions[0] is 0
# I'm being very lazy - push a 1 at start, then dont need to check for
# an empty @conditions [assume nesting in descrip.mms is correct]
+# 2.1 26-Feb-1995 Charles Bailey bailey@genetics.upenn.edu
+# - handle MMS macros generated by MakeMaker
if ($#ARGV > -1 && $ARGV[0] =~ /^[\-\/]trim/i) {
$do_trim = 1;
@@ -83,6 +85,22 @@ while (<INFIL>) {
else { $firstsrc = "\$<" }
}
+#convert macros we expect to see in MakeMaker-generated Descrip.MMSs
+ s#/Descrip=\s*\n#-f \nMMS = make\n#;
+ s#/Macro=\(# #;
+ s#MACROEND = \)#MACROEND = #;
+ if (m#\$\(USEMACROS\)(.*)(\$\(MACROEND\))?#) {
+ while (1) {
+ my($macros,$end) = ($1,$2);
+ $macros =~ s/,/ /g; # We're hosed if there're commas within a macro -
+ # someday, check for "" and skip contents
+ last if $end;
+ print OUTFIL $conditions[0] ? "#> " : "",$_;
+ $_ = <INFIL>;
+ m#(.*)(\$\(MACROEND\))?#;
+ }
+ }
+
s/^ +/\t/;
s/^\.first/\.first:/i;
s/^\.suffixes/\.suffixes:/i;
diff --git a/vms/perlvms.pod b/vms/perlvms.pod
index 77ec503f61..e7f811e0a8 100644
--- a/vms/perlvms.pod
+++ b/vms/perlvms.pod
@@ -1,84 +1,203 @@
-=head1 Notes on Perl5 for VMS
+=head1 Notes on Perl 5 for VMS
-Gathered below are notes describing details of perl 5's
-behavior on VMS. They are a supplement to the regular perl 5
-documentation, so we have focussed on the ways in which perl
-5 functions differently under VMS thatn it does under Unix,
-and on teh interactions between perl and the rest of the
+Gathered below are notes describing details of Perl 5's
+behavior on VMS. They are a supplement to the regular Perl 5
+documentation, so we have focussed on the ways in which Perl
+5 functions differently under VMS than it does under Unix,
+and on the interactions between Perl and the rest of the
operating system. We haven't tried to duplicate complete
-descriptions of perl5 features from the main perl
+descriptions of Perl features from the main Perl
documentation, which can be found in the F<[.pod]>
-subdirectory of the perl 5 distribution.
+subdirectory of the Perl distribution.
We hope these notes will save you from confusion and lost
-sleep when writing perl scripts on VMS. If you find we've
+sleep when writing Perl scripts on VMS. If you find we've
missed something you think should appear here, please don't
hesitate to drop a line to vmsperl@genetics.upenn.edu.
-=head2 Installation
-
-Directions for building and installing perl 5 can be found in
+=head1 Organization of Perl
+
+=head2 Perl Images
+
+During the installation process, three Perl images are produced.
+F<Miniperl.Exe> is an executable image which contains all of
+the basic functionality of Perl, but cannot take advantage of
+Perl extensions. It is used to generate several files needed
+to build the complete Perl and various extensions. Once you've
+finished installing Perl, you can delete this image.
+
+Most of the complete Perl resides in the shareable image
+F<PerlShr.Exe>, which provides a core to which the Perl executable
+image and all Perl extensions are linked. You should place this
+image in F<Sys$Share>, or define the logical name F<PerlShr> to
+translate to the full file specification of this image. It should
+be world readable. (Remember that if a user has execute only access
+to F<PerlShr>, VMS will treat it as if it were a privileged shareable
+image, and will therefore require all downstream shareable images to be
+INSTALLed, etc.)
+
+
+Finally, F<Perl.Exe> is an executable image containing the main
+entry point for Perl, as well as some initialization code. It
+should be placed in a public directory, and made world executable.
+In order to run Perl with command line arguments, you should
+define a foreign command to invoke this image.
+
+=head2 Perl Extensions
+
+Perl extensions are packages which provide both XS and Perl code
+to add new functionality to perl. (XS is a meta-language which
+simplifies writing C code which interacts with Perl, see
+L<perlapi> for more details.) The Perl code for an
+extension is treated like any other library module - it's
+made available in your script through the appropriate
+C<use> or C<require> statement, and usually defines a Perl
+package containing the extension.
+
+The portion of the extension provided by the XS code may be
+connected to the rest of Perl in either of two ways. In the
+B<static> configuration, the object code for the extension is
+linked directly into F<PerlShr.Exe>, and is initialized whenever
+Perl is invoked. In the B<dynamic> configuration, the extension's
+machine code is placed into a separate shareable image, which is
+mapped by Perl's DynaLoader when the extension is C<use>d or
+C<require>d in your script. This allows you to maintain the
+extension as a separate entity, at the cost of keeping track of the
+additional shareable image. Most extensions can be set up as either
+static or dynamic.
+
+The source code for an extension usually resides in its own
+directory. At least three files are generally provided:
+I<Extshortname>F<.xs> (where I<Extshortname> is the portion of
+the extension's name following the last C<::>), containing
+the XS code, I<Extshortname>F<.pm>, the Perl library module
+for the extension, and F<Makefile.PL>, a Perl script which uses
+the C<MakeMaker> library modules supplied with Perl to generate
+a F<Descrip.MMS> file for the extension.
+
+=head3 Installing static extensions
+
+Since static extensions are incorporated directly into
+F<PerlShr.Exe>, you'll have to rebuild Perl to incorporate a
+new extension. You should edit the main F<Descrip.MMS> or F<Makefile>
+you use to build Perl, adding the extension's name to the C<ext>
+macro, and the extension's object file to the C<extobj> macro.
+You'll also need to build the extension's object file, either
+by adding dependencies to the main F<Descrip.MMS>, or using a
+separate F<Descrip.MMS> for the extension. Then, rebuild
+F<PerlShr.Exe> to incorporate the new code.
+
+Finally, you'll need to copy the extension's Perl library
+module to the F<[.>I<Extname>F<]> subdirectory under one
+of the directories in C<@INC>, where I<Extname> is the name
+of the extension, with all C<::> replaced by C<.> (e.g.
+the library module for extension Foo::Bar would be copied
+to a F<[.Foo.Bar]> subdirectory).
+
+=head3 Installic dynamic extensions
+
+First, you'll need to compile the XS code into a shareable image,
+either by hand or using the F<Descrip.MMS> supplied with the
+extension. If you're building the shareable image by hand, please
+note the following points:
+ - The shareable image must be linked to F<PerlShr.Exe>, so it
+ has access to Perl's global variables and routines. In
+ order to specify the correct attributes for psects in
+ F<PerlShr.Exe>, you should include the linker options file
+ F<PerlShr_Attr.Opt> in the Link command. (This file is
+ generated when F<PerlShr.Exe> is built, and is found in the
+ main Perl source directory.
+ - The entry point for the C<boot_>I<Extname> routine (where
+ I<Extname> is the name of the extension, with all C<::>
+ replaced by C<__>) must be a universal symbol. No other
+ universal symbols are required to use the shareable image
+ with Perl, though you may want to include additional
+ universal symbols if you plan to share code or data among
+ different extensions.
+The shareable image can be placed in any of several locations:
+ - the F<[.Auto.>I<Extname>F<]> subdirectory of one of
+ the directories in C<@INC>, where I<Extname> is the
+ name of the extension, with each C<::> translated to C<.>
+ (e.g. for extension Foo::Bar, you would use the
+ F<[.Auto.Foo.Bar]> subdirectory), or
+ - one of the directories in C<@INC>, or
+ - a directory which the extensions Perl library module
+ passes to the DynaLoader when asking it to map
+ the shareable image, or
+ - F<Sys$Share> or F<Sys$Library>.
+If the shareable image isn't in any of these places, you'll need
+to define a logical name I<Extshortname>, where I<Extshortname>
+is the portion of the extension's name after the last C<::>, which
+translates to the full file specification of the shareable image.
+
+Once you've got the shareable image set up, you should copy the
+extension's Perl library module to the appropriate library directory
+(see the section above on installing static extensions).
+
+=head1 Installation
+
+Directions for building and installing Perl 5 can be found in
the file F<ReadMe.VMS> in the main source directory of the
-perl5 distribution..
+Perl distribution..
-=head2 File specifications
+=head1 File specifications
-We have tried to make perl aware of both VMS-style and Unix-
+We have tried to make Perl aware of both VMS-style and Unix-
style file specifications wherever possible. You may use
either style, or both, on the command line and in scripts,
but you may not combine the two styles within a single fle
specfication. Filenames are, of course, still case-
-insensitive. For consistency, most perl5 routines return
+insensitive. For consistency, most Perl routines return
filespecs using lower case latters only, regardless of the
case used in the arguments passed to them. (This is true
-only when running under VMS; perl5 respects the case-
+only when running under VMS; Perl respects the case-
sensitivity of OSs like Unix.)
-We've tried to minimize the dependence of perl library
+We've tried to minimize the dependence of Perl library
modules on Unix syntax, but you may find that some of these,
as well as some scripts written for Unix systems, will
require that you use Unix syntax, since they will assume that
'/' is the directory separator, etc. If you find instances
-of this in the perl distribution itself, please let us know,
+of this in the Perl distribution itself, please let us know,
so we can try to work around them.
-=head2 Command line redirection
+=head1 Command line redirection
Perl for VMS supports redirection of input and output on the
command line, using a subset of Bourne shell syntax:
<F<file> reads stdin from F<file>,
>F<file> writes stdout to F<file>,
>>F<file> appends stdout to F<file>,
- 2>F<file> wrtits stderr to F<file>, and
+ 2>F<file> writes stderr to F<file>, and
2>>F<file> appends stderr to F<file>.
In addition, output may be piped to a subprocess, using the
character '|'. Anything after this character on the command
line is passed to a subprocess for execution; the subprocess
-takes the output of perl as its input.
+takes the output of Perl as its input.
Finally, if the command line ends with '&', the entire
command is run in the background as an asynchronous
subprocess.
-=head2 Pipes
+=head1 Pipes
-Input and output pipes to perl filehandles are supported; the
+Input and output pipes to Perl filehandles are supported; the
"file name" is passed to lib$spawn() for asynchronous
execution. You should be careful to close any pipes you have
-opened in a perl script, lest you leave any "orphaned"
-subprocesses around when perl exits.
+opened in a Perl script, lest you leave any "orphaned"
+subprocesses around when Perl exits.
You may also use backticks to invoke a DCL subprocess, whose
output is used as the return value of the expression. The
string between the backticks is passed directly to lib$spawn
-as the command to execute. In this case, perl will wait for
+as the command to execute. In this case, Perl will wait for
the subprocess to complete before continuing.
-=head2 Wildcard expansion
+=head1 Wildcard expansion
File specifications containing wildcards are allowed both on
-the command line and within perl globs (e.g. <C<*.c>>). If
+the command line and within Perl globs (e.g. <C<*.c>>). If
the wildcard filespec uses VMS syntax, the resultant
filespecs will follow VMS syntax; if a Unix-style filespec is
passed in, Unix-style filespecs will be returned..
@@ -99,7 +218,14 @@ the behavior of glob expansion performed by Unix shells.)
Similarly, the resultant filespec will the file version only
if one was present in the input filespec.
-=head2 %ENV
+=head1 PERL5LIB and PERLLIB
+
+The PERL5LIB and PERLLIB logical names work as
+documented L<perl>, except that the element
+separator is '|' instead of ':'. The directory
+specifications may use either VMS or Unix syntax.
+
+=head1 %ENV
Reading the elements of the %ENV array returns the
translation of the logical name specified by the key,
@@ -110,30 +236,31 @@ variables" of the same names. The key C<default> returns the
current default device and directory specification.
Setting an element of %ENV defines a supervisor-mode logical
-name in the process logical name table. B<Undef>ing or
-B<delete>ing an element of %ENV deletes the equivalent user-
+name in the process logical name table. C<Undef>ing or
+C<delete>ing an element of %ENV deletes the equivalent user-
mode or supervisor-mode logical name from the process logical
-name table. If you use B<undef>, the %ENV element remains
-empty. If you use B<delete>, another attempt is made at
+name table. If you use C<undef>, the %ENV element remains
+empty. If you use C<delete>, another attempt is made at
logical name translation after the deletion, so an inner-mode
logical name or a name in another logical name table will
replace the logical name just deleted.
In all operations on %ENV, the key string is treated as if it
were entirely uppercase, regardless of the case actually
-specified in the perl expression.
+specified in the Perl expression.
-=head2 Perl functions
+=head1 Perl functions
As of the time this document was last revised, the following
-perl functions were implemented in the VMS port of perl
+Perl functions were implemented in the VMS port of Perl
(functions marked with * are discussed in more detail below):
file tests*, abs, alarm, atan, binmode*, bless,
caller, chdir, chmod, chown, chomp, chop, chr,
close, closedir, cos, defined, delete, die, do,
- each, eof, eval, exec*, exists, exit, exp, fileno,
- fork*, getc, glob, goto, grep, hex, import, index,
+ each, endpwent, eof, eval, exec*, exists, exit,
+ exp, fileno, fork*, getc, getpwent*, getpwnam*,
+ getpwuid*, glob, goto, grep, hex, import, index,
int, join, keys, kill, last, lc, lcfirst, length,
local, localtime, log, m//, map, mkdir, my, next,
no, oct, open, opendir, ord, pack, pipe, pop, pos,
@@ -141,12 +268,12 @@ perl functions were implemented in the VMS port of perl
quotemeta, rand, read, readdir, redo, ref, rename,
require, reset, return, reverse, rewinddir, rindex,
rmdir, s///, scalar, seek, seekdir, select(internal)*,
- shift, sin, sleep, sort, splice, split, sprintf,
- sqrt, srand, stat, study, substr, sysread, system*,
- syswrite, tell, telldir, tie, time, times*, tr///,
- uc, ucfirst, umask, undef, unlink, unpack, untie,
- unshift, use, values, vec, wait, wantarray, warn,
- write, y///
+ setpwent, shift, sin, sleep, sort, splice, split,
+ sprintf, sqrt, srand, stat, study, substr, sysread,
+ system*, syswrite, tell, telldir, tie, time, times*,
+ tr///, uc, ucfirst, umask, undef, unlink, unpack,
+ untie, unshift, use, utime*, values, vec, wait,
+ waitpid*, wantarray, warn, write, y///
The following functions were not implemented in the VMS port,
and calling them produces a fatal error (usually) or
@@ -154,18 +281,16 @@ undefined behavior (rarely, we hope):
chroot, crypt, dbmclose, dbmopen, dump, fcntl,
flock, getlogin, getpgrp, getppid, getpriority,
- getpwent, getgrent, kill, getgrgid, getgrnam,
- getpwnam, getpwuid, setpwent, setgrent,
- endpwent, endgrent, gmtime, ioctl, link, lstst,
- msgctl, msgget, msgsend, msgrcv, readlink,
+ getgrent, kill, getgrgid, getgrnam, setgrent,
+ endgrent, gmtime, ioctl, link, lstst, msgctl,
+ msgget, msgsend, msgrcv, readlink,
select(system call), semctl, semget, semop,
setpgrp, setpriority, shmctl, shmget, shmread,
- shmwrite, socketpair, symlink, syscall, truncate,
- utime, waitpid
+ shmwrite, socketpair, symlink, syscall, truncate
The following functions may or may not be implemented,
depending on what type of socket support you've built into
-your copy of perl:
+your copy of Perl:
accept, bind, connect, getpeername,
gethostbyname, getnetbyname, getprotobyname,
getservbyname, gethostbyaddr, getnetbyaddr,
@@ -179,86 +304,136 @@ your copy of perl:
=item File tests
-The tests -b, -B, -c, -C, -d, -e, -f, -o, -M, -s, -S, -t, -T,
-and -z work as advertised. The return values for -r, -w, and
--x tell you whether you can actually access the file; this
-may mot reflect the UIC-based file protections. Since real
-and effective UIC don't differ under VMS, -O, -R, -W, and -X
-are equivalent to -o, -r, -w, and -x. Similarly, several
-other tests, including -A, -g, -k, -l,-p, and -u, aren't
-particularly meaningful under VMS, and the values returned by
-these tests reflect whatever your CRTL stat() routine does to
-the equivalent bits in the st_mode field.
-
-=item binmode
-
-The B<binmode> operator has no effect under VMS. It will
+The tests C<-b>, C<-B>, C<-c>, C<-C>, C<-d>, C<-e>, C<-f>,
+C<-o>, C<-M>, C<-s>, C<-S>, C<-t>, C<-T>, and C<-z> work as
+advertised. The return values for C<-r>, C<-w>, and C<-x>
+tell you whether you can actually access the file; this may
+not reflect the UIC-based file protections. Since real and
+effective UIC don't differ under VMS, C<-O>, C<-R>, C<-W>,
+and C<-X> are equivalent to C<-o>, C<-r>, C<-w>, and C<-x>.
+Similarly, several other tests, including C<-A>, C<-g>, C<-k>,
+C<-l>, C<-p>, and C<-u>, aren't particularly meaningful under
+VMS, and the values returned by these tests reflect whatever
+your CRTL C<stat()> routine does to the equivalent bits in the
+st_mode field. Finally, C<-d> returns true if passed a device
+specification without an explicit directory (e.g. C<DUA1:>), as
+well as if passed a directory.
+
+=item binmode FILEHANDLE
+
+The C<binmode> operator has no effect under VMS. It will
return TRUE whenever called, but will not affect I/O
operations on the filehandle given as its argument.
-=item exec
+=item exec LIST
-The B<exec> operator behaves in one of two different ways.
-If called after a call to B<fork>, it will invoke the CRTL
-L<execv()> routine, passing its arguments to the subprocess
-created by B<fork> for execution. In this case, it is
-subject to all limitation that affect L<execv>. (In
+The C<exec> operator behaves in one of two different ways.
+If called after a call to C<fork>, it will invoke the CRTL
+C<execv()> routine, passing its arguments to the subprocess
+created by C<fork> for execution. In this case, it is
+subject to all limitations that affect C<execv()>. (In
particular, this usually means that the command executed in
the subprocess must be an image compiled from C source code,
and that your options for passing file descriptors and signal
handlers to the subprocess are limited.)
-If the call to B<exec> does not follow a call to B<fork>, it
-will cause perl to exit, and to invoke the command given as
-an argument to B<exec> via lib$do_command. If the argument
+If the call to C<exec> does not follow a call to C<fork>, it
+will cause Perl to exit, and to invoke the command given as
+an argument to C<exec> via C<lib$do_command>. If the argument
begins with a '$' (other than as part of a filespec), then it
is executed as a DCL command. Otherwise, the first token on
the command line is treated as the filespec of an image to
run, and an attempt is made to invoke it (using F<.Exe> and
the process defaults to expand the filespec) and pass the
-rest of B<exec>'s argument to it as parameters.
+rest of C<exec>'s argument to it as parameters.
-You can use B<exec> in both ways within the same script, as
-long as you call B<fork> and B<exec> in pairs. Perl only
-keeps track of whether B<fork> has been called since the last
-call to B<exec> when figuring out what to do, so multiple
-calls to B<fork> do not generate multiple levels of "fork
-context".
+You can use C<exec> in both ways within the same script, as
+long as you call C<fork> and C<exec> in pairs. Perl
+keeps track of how many times C<fork> and C<exec> have been
+called, and will call the CRTL C<execv()> routine if there have
+previously been more calls to C<fork> than to C<exec>.
=item fork
-The B<fork> operator works in the same way as the CRTL
-L<fork()> routine, which is quite different under VMS than
-under Unix. Sepcifically, while B<fork> returns 0 after it
-is called and the subprocess PID after B<exec> is called, in
+The C<fork> operator works in the same way as the CRTL
+C<vfork()> routine, which is quite different under VMS than
+under Unix. Specifically, while C<fork> returns 0 after it
+is called and the subprocess PID after C<exec> is called, in
both cases the thread of execution is within the parent
process, so there is no opportunity to perform operations in
-the subprocess before calling B<exec>.
+the subprocess before calling C<exec>.
-In general, the use of B<fork> and B<exec> to create
+In general, the use of C<fork> and C<exec> to create
subprocess is not recommended under VMS; wherever possible,
-use the B<system> operator or piped filehandles instead.
+use the C<system> operator or piped filehandles instead.
+
+=item getpwent
+=item getpwnam
+=item getpwuid
+
+These operators obtain the information described in L<perlfunc>,
+if you have the privileges necessary to retrieve the named user's
+UAF information via C<sys$getuai>. If not, then only the C<$name>,
+C<$uid>, and C<$gid> items are returned. The C<$dir> item contains
+the login directory in VMS syntax, while the C<$comment> item
+contains the login directory in Unix syntax. The C<$gcos> item
+contains the owner field from the UAF record. The C<$quota>
+item is not used.
-=item system
+=item stat EXPR
-The B<system> operator creates a subprocess, and passes its
+Since VMS keeps track of files according to a different scheme
+than Unix, it's not really possible to represent the file's ID
+in the C<st_dev> and C<st_ino> fields of a C<struct stat>. Perl
+tries its best, though, and the values it uses are pretty unlikely
+to be the same for two different files. We can't guarantee this,
+though, so caveat scriptor.
+
+=item system LIST
+
+The C<system> operator creates a subprocess, and passes its
arguments to the subprocess for execution as a DCL command.
Since the subprocess is created directly via lib$spawn, any
-valid DCL command string may be specified. Perl waits for
-the subprocess to complete before continuing execution in the
-current process.
+valid DCL command string may be specified. If LIST consists
+of the empty string, C<system> spawns an interactive DCL subprocess,
+in the same fashion as typiing B<SPAWN> at the DCL prompt.
+Perl waits for the subprocess to complete before continuing
+execution in the current process.
=item times
-The array returned by the B<times> operator is divided up
-according to the same rules the CRTL L<times()> routine.
+The array returned by the C<times> operator is divided up
+according to the same rules the CRTL C<times()> routine.
Therefore, the "system time" elements will always be 0, since
there is no difference between "user time" and "system" time
under VMS, and the time accumulated by subprocess may or may
not appear separately in the "child time" field, depending on
-whether L<times> keeps track of subprocesses separately.
+whether L<times> keeps track of subprocesses separately. Note
+especially that the VAXCRTL (at least) keeps track only of
+subprocesses spawned using L<fork> and L<exec>; it will not
+accumulate the times of suprocesses spawned via pipes, L<system>,
+or backticks.
+
+=item utime LIST
+
+Since ODS-2, the VMS file structure for disk files, does not keep
+track of access times, this operator changes only the modification
+time of the file (VMS revision date).
+
+=item waitpid PID,FLAGS
+
+If PID is a subprocess started by a piped L<open>, C<waitpid>
+will wait for that subprocess, and return its final
+status value. If PID is a subprocess created in some other way
+(e.g. SPAWNed before Perl was invoked), or is not a subprocess of
+the current process, C<waitpid> will check once per second whether
+the process has completed, and when it has, will return 0. (If PID
+specifies a process that isn't a subprocess of the current process,
+and you invoked Perl with the C<-w> switch, a warning will be issued.)
+
+The FLAGS argument is ignored in all cases.
-=head2 Revision date
+=head1 Revision date
-This document was last updated on 16-Oct-1994, for perl 5,
+This document was last updated on 16-Dec-1994, for Perl 5,
patchlevel 0.
diff --git a/vms/sockadapt.c b/vms/sockadapt.c
index fc42bcc5a4..9867d536a1 100644
--- a/vms/sockadapt.c
+++ b/vms/sockadapt.c
@@ -1,14 +1,14 @@
/* sockadapt.c
*
* Author: Charles Bailey bailey@genetics.upenn.edu
- * Last Revised: 05-Oct-1994
+ * Last Revised: 08-Feb-1995
*
* This file should contain stubs for any of the TCP/IP functions perl5
* requires which are not supported by your TCP/IP stack. These stubs
* can attempt to emulate the routine in question, or can just return
* an error status or cause perl to die.
*
- * This version is set up for perl5 with socketshr 0.9A TCP/IP support.
+ * This version is set up for perl5 with socketshr 0.9D TCP/IP support.
*/
#include "sockadapt.h"
@@ -25,19 +25,8 @@
STRINGIFY(func));\
}
-FATALSTUB(endhostent);
FATALSTUB(endnetent);
-FATALSTUB(endprotoent);
-FATALSTUB(endservent);
-FATALSTUB(gethostent);
FATALSTUB(getnetbyaddr);
FATALSTUB(getnetbyname);
FATALSTUB(getnetent);
-FATALSTUB(getprotobyname);
-FATALSTUB(getprotobynumber);
-FATALSTUB(getprotoent);
-FATALSTUB(getservent);
-FATALSTUB(sethostent);
FATALSTUB(setnetent);
-FATALSTUB(setprotoent);
-FATALSTUB(setservent);
diff --git a/vms/sockadapt.h b/vms/sockadapt.h
index 60890bddce..0d56285750 100644
--- a/vms/sockadapt.h
+++ b/vms/sockadapt.h
@@ -2,35 +2,57 @@
*
* Authors: Charles Bailey bailey@genetics.upenn.edu
* David Denholm denholm@conmat.phys.soton.ac.uk
- * Last Revised: 05-Oct-1994
+ * Last Revised: 24-Feb-1995
*
* This file should include any other header files and procide any
* declarations, typedefs, and prototypes needed by perl for TCP/IP
* operations.
*
- * This version is set up for perl5 with socketshr 0.9A TCP/IP support.
+ * This version is set up for perl5 with socketshr 0.9D TCP/IP support.
*/
#include <socketshr.h>
-/* we may not have socket.h etc, so lets just do these here - div */
-/* built up from a variety of sources */
+/* we may not have netdb.h etc, so lets just do this here - div */
/* no harm doing this for all .c files - needed only by pp_sys.c */
-struct hostent {
- char *h_name;
- char *h_aliases;
- int h_addrtype;
- int h_length;
- char **h_addr_list;
+struct hostent {
+ char *h_name; /* official name of host */
+ char **h_aliases; /* alias list */
+ int h_addrtype; /* host address type */
+ int h_length; /* length of address */
+ char **h_addr_list; /* address */
};
+#ifdef h_addr
+# undef h_addr
+#endif
#define h_addr h_addr_list[0]
-struct sockaddr_in {
- short sin_family;
- unsigned short sin_port;
- unsigned long sin_addr;
- char sin_zero[8];
+struct protoent {
+ char *p_name; /* official protocol name */
+ char **p_aliases; /* alias list */
+ int p_proto; /* protocol # */
+};
+
+struct servent {
+ char *s_name; /* official service name */
+ char **s_aliases; /* alias list */
+ int s_port; /* port # */
+ char *s_proto; /* protocol to use */
+};
+
+struct in_addr {
+ unsigned long s_addr;
+};
+
+struct sockaddr {
+ unsigned short sa_family; /* address family */
+ char sa_data[14]; /* up to 14 bytes of direct address */
+};
+
+struct timeval {
+ long tv_sec;
+ long tv_usec;
};
struct netent {
@@ -39,16 +61,3 @@ struct netent {
int n_addrtype;
long n_net;
};
-
-struct servent {
- char *s_name; /* official service name */
- char **s_aliases; /* alias list */
- int s_port; /* port # */
- char *s_proto; /* protocol to use */
-};
-
-struct protoent {
- char *p_name; /* official protocol name */
- char **p_aliases; /* alias list */
- int p_proto; /* protocol # */
-};
diff --git a/vms/test.com b/vms/test.com
index 3e42a11474..a23245057f 100644
--- a/vms/test.com
+++ b/vms/test.com
@@ -6,7 +6,12 @@ $
$! A little basic setup
$ On Error Then Goto wrapup
$ olddef = F$Environment("Default")
-$ Set Default Perl_Root:[t]
+$ If F$TrnLNm("Perl_Root").nes.""
+$ Then
+$ Set Default Perl_Root:[t]
+$ Else
+$ Set Default [.t]
+$ EndIf
$
$! Pick up a copy of perl to use for the tests
$ Delete/Log/NoConfirm Perl.;*
@@ -56,7 +61,7 @@ $ Macro/NoDebug/Object=Echo.Obj Sys$Input
.end echo
$ Link/NoTrace Echo.Obj;
$ Delete/Log/NoConfirm Echo.Obj;*
-$ echo = "$Perl_Root:[T]Echo.Exe"
+$ echo = "$" + F$Parse("Echo.Exe")
$
$! And do it
$ MCR Sys$Disk:[]Perl.
diff --git a/vms/vms.c b/vms/vms.c
index 26aeecb4a5..ae4f608fcf 100644
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -1,14 +1,18 @@
-/* VMS-specific routines for perl5
+/* vms.c
*
- * Last revised: 09-Oct-1994
+ * VMS-specific routines for perl5
+ *
+ * Last revised: 09-Mar-1995 by Charles Bailey bailey@genetics.upenn.edu
*/
#include <acedef.h>
#include <acldef.h>
#include <armdef.h>
+#include <atrdef.h>
#include <chpdef.h>
#include <descrip.h>
#include <dvidef.h>
+#include <fibdef.h>
#include <float.h>
#include <fscndef.h>
#include <iodef.h>
@@ -16,6 +20,7 @@
#include <libdef.h>
#include <lib$routines.h>
#include <lnmdef.h>
+#include <prvdef.h>
#include <psldef.h>
#include <rms.h>
#include <shrdef.h>
@@ -23,25 +28,44 @@
#include <starlet.h>
#include <stsdef.h>
#include <syidef.h>
-
+#include <uaidef.h>
+#include <uicdef.h>
#include "EXTERN.h"
#include "perl.h"
+#include "XSUB.h"
struct itmlst_3 {
unsigned short int buflen;
unsigned short int itmcode;
void *bufadr;
- unsigned long int retlen;
+ unsigned short int *retlen;
};
-static unsigned long int sts;
-
-#define _cksts(call) \
- if (!(sts=(call))&1) { \
- errno = EVMSERR; vaxc$errno = sts; \
- croak("fatal error at %s, line %d",__FILE__,__LINE__); \
- } else { 1; }
+static char *
+my_trnlnm(char *lnm, char *eqv)
+{
+ static char __my_trnlnm_eqv[LNM$C_NAMLENGTH+1];
+ unsigned short int eqvlen;
+ unsigned long int retsts, attr = LNM$M_CASE_BLIND;
+ $DESCRIPTOR(tabdsc,"LNM$FILE_DEV");
+ struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
+ struct itmlst_3 lnmlst[2] = {{LNM$C_NAMLENGTH, LNM$_STRING,0, &eqvlen},
+ {0, 0, 0, 0}};
+
+ if (!eqv) eqv = __my_trnlnm_eqv;
+ lnmlst[0].bufadr = (void *)eqv;
+ lnmdsc.dsc$a_pointer = lnm;
+ lnmdsc.dsc$w_length = strlen(lnm);
+ retsts = sys$trnlnm(&attr,&tabdsc,&lnmdsc,0,lnmlst);
+ if (retsts == SS$_NOLOGNAM || retsts == SS$_IVLOGNAM) return Nullch;
+ else if (retsts & 1) {
+ eqv[eqvlen] = '\0';
+ return eqv;
+ }
+ _ckvmssts(retsts); /* Must be an error */
+ return Nullch; /* Not reached, assuming _ckvmssts() bails out */
+}
/* my_getenv
* Translate a logical name. Substitute for CRTL getenv() to avoid
@@ -57,47 +81,33 @@ my_getenv(char *lnm)
{
static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
- unsigned short int eqvlen;
- unsigned long int retsts, attr = LNM$M_CASE_BLIND;
- $DESCRIPTOR(sysdiskdsc,"SYS$DISK");
- $DESCRIPTOR(tabdsc,"LNM$FILE_DEV");
- struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
- eqvdsc = {sizeof __my_getenv_eqv,DSC$K_DTYPE_T,
- DSC$K_CLASS_S, __my_getenv_eqv};
- struct itmlst_3 lnmlst[2] = {sizeof __my_getenv_eqv - 1, LNM$_STRING,
- __my_getenv_eqv, &eqvlen, 0, 0, 0, 0};
for (cp1 = lnm, cp2= uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
*cp2 = '\0';
- lnmdsc.dsc$w_length = cp1 - lnm;
- if (lnmdsc.dsc$w_length = 7 && !strncmp(uplnm,"DEFAULT",7)) {
- _cksts(sys$trnlnm(&attr,&tabdsc,&sysdiskdsc,0,lnmlst));
- eqvdsc.dsc$a_pointer += eqvlen;
- eqvdsc.dsc$w_length = sizeof __my_getenv_eqv - eqvlen - 1;
- _cksts(sys$setddir(0,&eqvlen,&eqvdsc));
- eqvdsc.dsc$a_pointer[eqvlen] = '\0';
+ if (cp1 - lnm == 7 && !strncmp(uplnm,"DEFAULT",7)) {
+ getcwd(__my_getenv_eqv,sizeof __my_getenv_eqv);
+ return __my_getenv_eqv;
+ }
+ else if (my_trnlnm(uplnm,__my_getenv_eqv) != NULL) {
return __my_getenv_eqv;
}
else {
- retsts = sys$trnlnm(&attr,&tabdsc,&lnmdsc,0,lnmlst);
- if (retsts != SS$_NOLOGNAM) {
- if (retsts & 1) {
- __my_getenv_eqv[eqvlen] = '\0';
- return __my_getenv_eqv;
- }
- _cksts(retsts);
- }
- else {
- retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&(eqvdsc.dsc$w_length),0);
- if (retsts != LIB$_NOSUCHSYM) {
- /* We want to return only logical names or CRTL Unix emulations */
- if (retsts & 1) return Nullch;
- _cksts(retsts);
- }
- else return getenv(lnm); /* Try for CRTL emulation of a Unix/POSIX name */
+ unsigned long int retsts;
+ struct dsc$descriptor_s symdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
+ valdsc = {sizeof __my_getenv_eqv,DSC$K_DTYPE_T,
+ DSC$K_CLASS_S, __my_getenv_eqv};
+ symdsc.dsc$w_length = cp1 - lnm;
+ symdsc.dsc$a_pointer = uplnm;
+ retsts = lib$get_symbol(&symdsc,&valdsc,&(valdsc.dsc$w_length),0);
+ if (retsts == LIB$_INVSYMNAM) return Nullch;
+ if (retsts != LIB$_NOSUCHSYM) {
+ /* We want to return only logical names or CRTL Unix emulations */
+ if (retsts & 1) return Nullch;
+ _ckvmssts(retsts);
}
+ else return getenv(lnm); /* Try for CRTL emulation of a Unix/POSIX name */
}
- return NULL;
+ return Nullch;
} /* end of my_getenv() */
/*}}}*/
@@ -121,17 +131,18 @@ my_setenv(char *lnm,char *eqv)
if (!eqv || !*eqv) { /* we're deleting a logical name */
retsts = sys$dellnm(&tabdsc,&lnmdsc,&usermode); /* try user mode first */
- if (retsts != SS$_NOLOGNAM) _cksts(retsts);
+ if (retsts == SS$_IVLOGNAM) return;
+ if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
if (!(retsts & 1)) {
retsts = lib$delete_logical(&lnmdsc,&tabdsc); /* then supervisor mode */
- if (retsts != SS$_NOLOGNAM) _cksts(retsts);
+ if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
}
}
else {
eqvdsc.dsc$w_length = strlen(eqv);
eqvdsc.dsc$a_pointer = eqv;
- _cksts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0));
+ _ckvmssts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0));
}
} /* end of my_setenv() */
@@ -146,7 +157,7 @@ do_rmdir(char *name)
{
char dirfile[NAM$C_MAXRSS+1];
int retval;
- stat_t st;
+ struct stat st;
if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
@@ -170,24 +181,24 @@ kill_file(char *name)
{
char vmsname[NAM$C_MAXRSS+1];
unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
- unsigned long int uics[2] = {0,0}, cxt = 0, aclsts, fndsts, rmsts = -1;
+ unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
struct myacedef {
- unsigned char ace$b_length;
- unsigned char ace$b_type;
- unsigned short int ace$w_flags;
- unsigned long int ace$l_access;
- unsigned long int ace$l_ident;
+ unsigned char myace$b_length;
+ unsigned char myace$b_type;
+ unsigned short int myace$w_flags;
+ unsigned long int myace$l_access;
+ unsigned long int myace$l_ident;
} newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
struct itmlst_3
- findlst[3] = {sizeof oldace, ACL$C_FNDACLENT, &oldace, 0,
- sizeof oldace, ACL$C_READACE, &oldace, 0, 0, 0, 0, 0},
- addlst[2] = {sizeof newace, ACL$C_ADDACLENT, &newace, 0, 0, 0, 0, 0},
- dellst[2] = {sizeof newace, ACL$C_DELACLENT, &newace, 0, 0, 0, 0, 0},
- lcklst[2] = {sizeof newace, ACL$C_WLOCK_ACL, &newace, 0, 0, 0, 0, 0},
- ulklst[2] = {sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0, 0, 0, 0, 0};
+ findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
+ {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
+ addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
+ dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
+ lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
+ ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
if (!remove(name)) return 0; /* Can we just get rid of it? */
@@ -195,15 +206,15 @@ kill_file(char *name)
* and the insert an ACE at the head of the ACL which allows us
* to delete the file.
*/
- _cksts(lib$getjpi(&jpicode,0,0,&(oldace.ace$l_ident),0,0));
+ _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
fildsc.dsc$w_length = strlen(vmsname);
fildsc.dsc$a_pointer = vmsname;
cxt = 0;
- newace.ace$l_ident = oldace.ace$l_ident;
+ newace.myace$l_ident = oldace.myace$l_ident;
if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
- errno = EVMSERR;
- vaxc$errno = aclsts;
+ set_errno(EVMSERR);
+ set_vaxc_errno(aclsts);
return -1;
}
/* Grab any existing ACEs with this identifier in case we fail */
@@ -212,7 +223,7 @@ kill_file(char *name)
/* Add the new ACE . . . */
if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
goto yourroom;
- if (rmsts = remove(name)) {
+ if ((rmsts = remove(name))) {
/* We blew it - dir with files in it, no write priv for
* parent directory, etc. Put things back the way they were. */
if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
@@ -231,8 +242,8 @@ kill_file(char *name)
if (aclsts & 1) aclsts = fndsts;
}
if (!(aclsts & 1)) {
- errno = EVMSERR;
- vaxc$errno = aclsts;
+ set_errno(EVMSERR);
+ set_vaxc_errno(aclsts);
return -1;
}
@@ -241,6 +252,149 @@ kill_file(char *name)
} /* end of kill_file() */
/*}}}*/
+/* my_utime - update modification time of a file
+ * calling sequence is identical to POSIX utime(), but under
+ * VMS only the modification time is changed; ODS-2 does not
+ * maintain access times. Restrictions differ from the POSIX
+ * definition in that the time can be changed as long as the
+ * caller has permission to execute the necessary IO$_MODIFY $QIO;
+ * no separate checks are made to insure that the caller is the
+ * owner of the file or has special privs enabled.
+ * Code here is based on Joe Meadows' FILE utility.
+ */
+
+/* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
+ * to VMS epoch (01-JAN-1858 00:00:00.00)
+ * in 100 ns intervals.
+ */
+static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
+
+/*{{{int my_utime(char *path, struct utimbuf *utimes)*/
+int my_utime(char *file, struct utimbuf *utimes)
+{
+ register int i;
+ long int bintime[2], len = 2, lowbit, unixtime,
+ secscale = 10000000; /* seconds --> 100 ns intervals */
+ unsigned long int chan, iosb[2], retsts;
+ char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
+ struct FAB myfab = cc$rms_fab;
+ struct NAM mynam = cc$rms_nam;
+ struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
+ struct fibdef myfib;
+ struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
+ devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
+ fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
+
+ if (file == NULL || *file == '\0') {
+ set_errno(ENOENT);
+ set_vaxc_errno(LIB$_INVARG);
+ return -1;
+ }
+ if (tovmsspec(file,vmsspec) == NULL) return -1;
+
+ if (utimes != NULL) {
+ /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
+ * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
+ * Since time_t is unsigned long int, and lib$emul takes a signed long int
+ * as input, we force the sign bit to be clear by shifting unixtime right
+ * one bit, then multiplying by an extra factor of 2 in lib$emul().
+ */
+ lowbit = (utimes->modtime & 1) ? secscale : 0;
+ unixtime = (long int) utimes->modtime;
+ unixtime >> 1; secscale << 1;
+ retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
+ if (!(retsts & 1)) {
+ set_errno(EVMSERR);
+ set_vaxc_errno(retsts);
+ return -1;
+ }
+ retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
+ if (!(retsts & 1)) {
+ set_errno(EVMSERR);
+ set_vaxc_errno(retsts);
+ return -1;
+ }
+ }
+ else {
+ /* Just get the current time in VMS format directly */
+ retsts = sys$gettim(bintime);
+ if (!(retsts & 1)) {
+ set_errno(EVMSERR);
+ set_vaxc_errno(retsts);
+ return -1;
+ }
+ }
+
+ myfab.fab$l_fna = vmsspec;
+ myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
+ myfab.fab$l_nam = &mynam;
+ mynam.nam$l_esa = esa;
+ mynam.nam$b_ess = (unsigned char) sizeof esa;
+ mynam.nam$l_rsa = rsa;
+ mynam.nam$b_rss = (unsigned char) sizeof rsa;
+
+ /* Look for the file to be affected, letting RMS parse the file
+ * specification for us as well. I have set errno using only
+ * values documented in the utime() man page for VMS POSIX.
+ */
+ retsts = sys$parse(&myfab,0,0);
+ if (!(retsts & 1)) {
+ set_vaxc_errno(retsts);
+ if (retsts == RMS$_PRV) set_errno(EACCES);
+ else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
+ else set_errno(EVMSERR);
+ return -1;
+ }
+ retsts = sys$search(&myfab,0,0);
+ if (!(retsts & 1)) {
+ set_vaxc_errno(retsts);
+ if (retsts == RMS$_PRV) set_errno(EACCES);
+ else if (retsts == RMS$_FNF) set_errno(ENOENT);
+ else set_errno(EVMSERR);
+ return -1;
+ }
+
+ devdsc.dsc$w_length = mynam.nam$b_dev;
+ devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
+
+ retsts = sys$assign(&devdsc,&chan,0,0);
+ if (!(retsts & 1)) {
+ set_vaxc_errno(retsts);
+ if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
+ else if (retsts == SS$_NOPRIV) set_errno(EACCES);
+ else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
+ else set_errno(EVMSERR);
+ return -1;
+ }
+
+ fnmdsc.dsc$a_pointer = mynam.nam$l_name;
+ fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
+
+ memset((void *) &myfib, 0, sizeof myfib);
+#ifdef __DECC
+ for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
+ for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
+ /* This prevents the revision time of the file being reset to the current
+ * time as a reqult of our IO$_MODIFY $QIO. */
+ myfib.fib$l_acctl = FIB$M_NORECORD;
+#else
+ for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
+ for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
+ myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
+#endif
+ retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
+ if (retsts & 1) retsts = iosb[0];
+ if (!(retsts & 1)) {
+ set_vaxc_errno(retsts);
+ if (retsts == SS$_NOPRIV) set_errno(EACCES);
+ else set_errno(EVMSERR);
+ return -1;
+ }
+
+ return 0;
+} /* end of my_utime() */
+/*}}}*/
+
static void
create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
{
@@ -253,12 +407,12 @@ create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
* preprocessor consant BUFSIZ from stdio.h as the size of the
* 'pipe' mailbox.
*/
- _cksts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
+ _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
}
- _cksts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
+ _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
- _cksts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
+ _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
} /* end of create_mbx() */
@@ -267,18 +421,52 @@ create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
struct pipe_details
{
struct pipe_details *next;
- FILE *fp;
- int pid;
- unsigned long int completion;
+ FILE *fp; /* stdio file pointer to pipe mailbox */
+ int pid; /* PID of subprocess */
+ int mode; /* == 'r' if pipe open for reading */
+ int done; /* subprocess has completed */
+ unsigned long int completion; /* termination status of subprocess */
};
+struct exit_control_block
+{
+ struct exit_control_block *flink;
+ unsigned long int (*exit_routine)();
+ unsigned long int arg_count;
+ unsigned long int *status_address;
+ unsigned long int exit_status;
+};
+
static struct pipe_details *open_pipes = NULL;
static $DESCRIPTOR(nl_desc, "NL:");
static int waitpid_asleep = 0;
+static unsigned long int
+pipe_exit_routine()
+{
+ unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT, sts;
+
+ while (open_pipes != NULL) {
+ if (!open_pipes->done) { /* Tap them gently on the shoulder . . .*/
+ _ckvmssts(sys$forcex(&open_pipes->pid,0,&abort));
+ sleep(1);
+ }
+ if (!open_pipes->done) /* We tried to be nice . . . */
+ _ckvmssts(sys$delprc(&open_pipes->pid,0));
+ if (!((sts = my_pclose(open_pipes->fp))&1)) retsts = sts;
+ }
+ return retsts;
+}
+
+static struct exit_control_block pipe_exitblock =
+ {(struct exit_control_block *) 0,
+ pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
+
+
static void
-popen_completion_ast(unsigned long int unused)
+popen_completion_ast(struct pipe_details *thispipe)
{
+ thispipe->done = TRUE;
if (waitpid_asleep) {
waitpid_asleep = 0;
sys$wake(0,0);
@@ -289,6 +477,7 @@ popen_completion_ast(unsigned long int unused)
FILE *
my_popen(char *cmd, char *mode)
{
+ static int handler_set_up = FALSE;
char mbxname[64];
unsigned short int chan;
unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
@@ -301,8 +490,6 @@ my_popen(char *cmd, char *mode)
New(7001,info,1,struct pipe_details);
- info->completion=0; /* I assume this will remain 0 until terminates */
-
/* create mailbox */
create_mbx(&chan,&namdsc);
@@ -310,7 +497,7 @@ my_popen(char *cmd, char *mode)
info->fp=fopen(mbxname, mode);
/* give up other channel onto it */
- _cksts(sys$dassgn(chan));
+ _ckvmssts(sys$dassgn(chan));
if (!info->fp)
return Nullfp;
@@ -318,16 +505,25 @@ my_popen(char *cmd, char *mode)
cmddsc.dsc$w_length=strlen(cmd);
cmddsc.dsc$a_pointer=cmd;
- if (strcmp(mode,"r")==0) {
- _cksts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
+ info->mode = *mode;
+ info->done = FALSE;
+ info->completion=0;
+
+ if (*mode == 'r') {
+ _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
0 /* name */, &info->pid, &info->completion,
- 0, popen_completion_ast,0,0,0,0));
+ 0, popen_completion_ast,info,0,0,0));
}
else {
- _cksts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */,
- 0 /* name */, &info->pid, &info->completion));
+ _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
+ 0 /* name */, &info->pid, &info->completion,
+ 0, popen_completion_ast,info,0,0,0));
}
+ if (!handler_set_up) {
+ _ckvmssts(sys$dclexh(&pipe_exitblock));
+ handler_set_up = TRUE;
+ }
info->next=open_pipes; /* prepend to list */
open_pipes=info;
@@ -339,46 +535,41 @@ my_popen(char *cmd, char *mode)
I32 my_pclose(FILE *fp)
{
struct pipe_details *info, *last = NULL;
- unsigned long int abort = SS$_TIMEOUT, retsts;
+ unsigned long int retsts;
for (info = open_pipes; info != NULL; last = info, info = info->next)
if (info->fp == fp) break;
if (info == NULL)
/* get here => no such pipe open */
- croak("my_pclose() - no such pipe open ???");
+ croak("No such pipe open");
+
+ if (info->done) retsts = info->completion;
+ else waitpid(info->pid,(int *) &retsts,0);
- if (!info->completion) { /* Tap them gently on the shoulder . . .*/
- _cksts(sys$forcex(&info->pid,0,&abort));
- sleep(1);
- }
- if (!info->completion) /* We tried to be nice . . . */
- _cksts(sys$delprc(&info->pid));
-
fclose(info->fp);
+
/* remove from list of open pipes */
if (last) last->next = info->next;
else open_pipes = info->next;
- retsts = info->completion;
Safefree(info);
return retsts;
+
} /* end of my_pclose() */
-#ifndef HAS_WAITPID
/* sort-of waitpid; use only with popen() */
/*{{{unsigned long int waitpid(unsigned long int pid, int *statusp, int flags)*/
unsigned long int
waitpid(unsigned long int pid, int *statusp, int flags)
{
struct pipe_details *info;
- unsigned long int abort = SS$_TIMEOUT;
for (info = open_pipes; info != NULL; info = info->next)
if (info->pid == pid) break;
if (info != NULL) { /* we know about this child */
- while (!info->completion) {
+ while (!info->done) {
waitpid_asleep = 1;
sys$hiber();
}
@@ -389,19 +580,21 @@ waitpid(unsigned long int pid, int *statusp, int flags)
else { /* we haven't heard of this child */
$DESCRIPTOR(intdsc,"0 00:00:01");
unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
- unsigned long int interval[2];
+ unsigned long int interval[2],sts;
- _cksts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
- _cksts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
- if (ownerpid != mypid)
- croak("pid %d not a child",pid);
+ if (dowarn) {
+ _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
+ _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
+ if (ownerpid != mypid)
+ warn("pid %d not a child",pid);
+ }
- _cksts(sys$bintim(&intdsc,interval));
+ _ckvmssts(sys$bintim(&intdsc,interval));
while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
- _cksts(sys$schdwk(0,0,interval,0));
- _cksts(sys$hiber());
+ _ckvmssts(sys$schdwk(0,0,interval,0));
+ _ckvmssts(sys$hiber());
}
- _cksts(sts);
+ _ckvmssts(sts);
/* There's no easy way to find the termination status a child we're
* not aware of beforehand. If we're really interested in the future,
@@ -413,7 +606,6 @@ waitpid(unsigned long int pid, int *statusp, int flags)
}
} /* end of waitpid() */
-#endif
/*}}}*/
/*}}}*/
/*}}}*/
@@ -443,7 +635,7 @@ my_gconvert(double val, int ndig, int trail, char *buf)
** converting among VMS-style and Unix-style directory specifications.
** All will take input specifications in either VMS or Unix syntax. On
** failure, all return NULL. If successful, the routines listed below
-** return a pointer to a static buffer containing the appropriately
+** return a pointer to a buffer containing the appropriately
** reformatted spec (and, therefore, subsequent calls to that routine
** will clobber the result), while the routines of the same names with
** a _ts suffix appended will return a pointer to a mallocd string
@@ -466,21 +658,41 @@ my_gconvert(double val, int ndig, int trail, char *buf)
** tovmsspec() - convert any file spec into a VMS-style spec.
*/
+static char *do_tounixspec(char *, char *, int);
+
/*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
static char *do_fileify_dirspec(char *dir,char *buf,int ts)
{
static char __fileify_retbuf[NAM$C_MAXRSS+1];
unsigned long int dirlen, retlen, addmfd = 0;
char *retspec, *cp1, *cp2, *lastdir;
+ char trndir[NAM$C_MAXRSS+1], vmsdir[NAM$C_MAXRSS+1];
if (dir == NULL) return NULL;
+ strcpy(trndir,dir);
+ while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir) != NULL) ;
+ dir = trndir;
dirlen = strlen(dir);
if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */
+ if (dir[0] == '.') {
+ if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
+ return do_fileify_dirspec("[]",buf,ts);
+ else if (dir[1] == '.' &&
+ (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
+ return do_fileify_dirspec("[-]",buf,ts);
+ }
if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
dirlen -= 1; /* to last element */
lastdir = strrchr(dir,'/');
}
+ else if (strstr(trndir,"..") != NULL) {
+ /* If we have a relative path, let do_tovmsspec figure it out,
+ * rather than repeating the code here */
+ if (do_tovmsspec(trndir,vmsdir,0) == NULL) return NULL;
+ if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
+ return do_tounixspec(trndir,buf,ts);
+ }
else {
if (!(lastdir = cp1 = strrchr(dir,'/'))) cp1 = dir;
if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
@@ -489,42 +701,44 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
toupper(*(cp2+3)) == 'R') {
if ((cp1 = strchr(cp2,';')) || (cp1 = strchr(cp2+1,'.'))) {
if (*(cp1+1) != '1' || *(cp1+2) != '\0') { /* Version is not ;1 */
- errno = ENOTDIR; /* Bzzt. */
+ set_errno(ENOTDIR); /* Bzzt. */
+ set_vaxc_errno(RMS$_DIR);
return NULL;
}
}
dirlen = cp2 - dir;
}
else { /* There's a type, and it's not .dir. Bzzt. */
- errno = ENOTDIR;
+ set_errno(ENOTDIR);
+ set_vaxc_errno(RMS$_DIR);
return NULL;
}
}
- /* If we lead off with a device or rooted logical, add the MFD
- if we're specifying a top-level directory. */
- if (lastdir && *dir == '/') {
- addmfd = 1;
- for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
- if (*cp1 == '/') {
- addmfd = 0;
- break;
- }
+ }
+ /* If we lead off with a device or rooted logical, add the MFD
+ if we're specifying a top-level directory. */
+ if (lastdir && *dir == '/') {
+ addmfd = 1;
+ for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
+ if (*cp1 == '/') {
+ addmfd = 0;
+ break;
}
}
- retlen = dirlen + addmfd ? 13 : 6;
- if (buf) retspec = buf;
- else if (ts) New(7009,retspec,retlen+6,char);
- else retspec = __fileify_retbuf;
- if (addmfd) {
- dirlen = lastdir - dir;
- memcpy(retspec,dir,dirlen);
- strcpy(&retspec[dirlen],"/000000");
- strcpy(&retspec[dirlen+7],lastdir);
- }
- else {
- memcpy(retspec,dir,dirlen);
- retspec[dirlen] = '\0';
- }
+ }
+ retlen = dirlen + addmfd ? 13 : 6;
+ if (buf) retspec = buf;
+ else if (ts) New(7009,retspec,retlen+6,char);
+ else retspec = __fileify_retbuf;
+ if (addmfd) {
+ dirlen = lastdir - dir;
+ memcpy(retspec,dir,dirlen);
+ strcpy(&retspec[dirlen],"/000000");
+ strcpy(&retspec[dirlen+7],lastdir);
+ }
+ else {
+ memcpy(retspec,dir,dirlen);
+ retspec[dirlen] = '\0';
}
/* We've picked up everything up to the directory file name.
Now just add the type and version, and we're set. */
@@ -533,19 +747,20 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
}
else { /* VMS-style directory spec */
char esa[NAM$C_MAXRSS+1], term;
- unsigned long int sts, cmplen;
+ unsigned long int cmplen, hasdev, hasdir, hastype, hasver;
struct FAB dirfab = cc$rms_fab;
struct NAM savnam, dirnam = cc$rms_nam;
dirfab.fab$b_fns = strlen(dir);
dirfab.fab$l_fna = dir;
dirfab.fab$l_nam = &dirnam;
+ dirfab.fab$l_dna = ".DIR;1";
+ dirfab.fab$b_dns = 6;
dirnam.nam$b_ess = NAM$C_MAXRSS;
dirnam.nam$l_esa = esa;
- dirnam.nam$b_nop = NAM$M_SYNCHK;
if (!(sys$parse(&dirfab)&1)) {
- errno = EVMSERR;
- vaxc$errno = dirfab.fab$l_sts;
+ set_errno(EVMSERR);
+ set_vaxc_errno(dirfab.fab$l_sts);
return NULL;
}
savnam = dirnam;
@@ -555,51 +770,82 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
}
else {
if (dirfab.fab$l_sts != RMS$_FNF) {
- errno = EVMSERR;
- vaxc$errno = dirfab.fab$l_sts;
+ set_errno(EVMSERR);
+ set_vaxc_errno(dirfab.fab$l_sts);
return NULL;
}
dirnam = savnam; /* No; just work with potential name */
}
-
+ if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
+ cp1 = strchr(esa,']');
+ if (!cp1) cp1 = strchr(esa,'>');
+ if (cp1) { /* Should always be true */
+ dirnam.nam$b_esl -= cp1 - esa - 1;
+ memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
+ }
+ }
if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
/* Yep; check version while we're at it, if it's there. */
cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
/* Something other than .DIR[;1]. Bzzt. */
- errno = ENOTDIR;
+ set_errno(ENOTDIR);
+ set_vaxc_errno(RMS$_DIR);
return NULL;
}
- else { /* Ok, it was .DIR[;1]; copy over everything up to the */
- retlen = dirnam.nam$l_type - esa; /* file name. */
- if (buf) retspec = buf;
- else if (ts) New(7010,retspec,retlen+6,char);
- else retspec = __fileify_retbuf;
- strncpy(retspec,esa,retlen);
- retspec[retlen] = '\0';
- }
+ }
+ esa[dirnam.nam$b_esl] = '\0';
+ if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
+ /* They provided at least the name; we added the type, if necessary, */
+ if (buf) retspec = buf; /* in sys$parse() */
+ else if (ts) New(7011,retspec,dirnam.nam$b_esl,char);
+ else retspec = __fileify_retbuf;
+ strcpy(retspec,esa);
+ return retspec;
+ }
+ if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
+ if (cp1 == NULL) return NULL; /* should never happen */
+ term = *cp1;
+ *cp1 = '\0';
+ retlen = strlen(esa);
+ if ((cp1 = strrchr(esa,'.')) != NULL) {
+ /* There's more than one directory in the path. Just roll back. */
+ *cp1 = term;
+ if (buf) retspec = buf;
+ else if (ts) New(7011,retspec,retlen+6,char);
+ else retspec = __fileify_retbuf;
+ strcpy(retspec,esa);
}
else {
- /* They didn't explicitly specify the directory file. Ignore
- any file names in the input, pull off the last element of the
- directory path, and make it the file name. If you want to
- pay attention to filenames without .dir in the input, just use
- ".DIR;1" as a default filespec for the $PARSE */
- esa[dirnam.nam$b_esl] = '\0';
- if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
- if (cp1 == NULL) return NULL; /* should never happen */
- term = *cp1;
- *cp1 = '\0';
- retlen = strlen(esa);
- if ((cp1 = strrchr(esa,'.')) != NULL) {
- /* There's more than one directory in the path. Just roll back. */
- *cp1 = term;
+ if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
+ /* Go back and expand rooted logical name */
+ dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
+ if (!(sys$parse(&dirfab) & 1)) {
+ set_errno(EVMSERR);
+ set_vaxc_errno(dirfab.fab$l_sts);
+ return NULL;
+ }
+ retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
if (buf) retspec = buf;
- else if (ts) New(7011,retspec,retlen+6,char);
+ else if (ts) New(7012,retspec,retlen+7,char);
else retspec = __fileify_retbuf;
- strcpy(retspec,esa);
+ cp1 = strstr(esa,"][");
+ dirlen = cp1 - esa;
+ memcpy(retspec,esa,dirlen);
+ if (!strncmp(cp1+2,"000000]",7)) {
+ retspec[dirlen-1] = '\0';
+ for (cp1 = retspec+dirlen-1; *cp1 != '.'; cp1--) ;
+ *cp1 = ']';
+ }
+ else {
+ memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
+ retspec[retlen] = '\0';
+ /* Convert last '.' to ']' */
+ for (cp1 = retspec+retlen-1; *cp1 != '.'; cp1--) ;
+ *cp1 = ']';
+ }
}
- else { /* This is a top-level dir. Add the MFD to the path. */
+ else { /* This is a top-level dir. Add the MFD to the path. */
if (buf) retspec = buf;
else if (ts) New(7012,retspec,retlen+14,char);
else retspec = __fileify_retbuf;
@@ -610,8 +856,8 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
cp1 += 2;
strcpy(cp2+9,cp1);
}
- }
- /* Again, we've set up the string up through the filename. Add the
+ }
+ /* We've set up the string up through the filename. Add the
type and version, and we're done. */
strcat(retspec,".DIR;1");
return retspec;
@@ -629,26 +875,36 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts)
{
static char __pathify_retbuf[NAM$C_MAXRSS+1];
unsigned long int retlen;
- char *retpath, *cp1, *cp2;
+ char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
if (dir == NULL) return NULL;
+ strcpy(trndir,dir);
+ while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir) != NULL) ;
+ dir = trndir;
+
if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */
- if (!(cp1 = strrchr(dir,'/'))) cp1 = dir;
- if (cp2 = strchr(cp1,'.')) {
- if (toupper(*(cp2+1)) == 'D' && /* They specified .dir. */
- toupper(*(cp2+2)) == 'I' && /* Trim it off. */
- toupper(*(cp2+3)) == 'R') {
- retlen = cp2 - dir + 1;
+ if (*dir == '.' && (*(dir+1) == '\0' ||
+ (*(dir+1) == '.' && *(dir+2) == '\0')))
+ retlen = 2 + (*(dir+1) != '\0');
+ else {
+ if (!(cp1 = strrchr(dir,'/'))) cp1 = dir;
+ if ((cp2 = strchr(cp1,'.')) && *(cp2+1) != '.') {
+ if (toupper(*(cp2+1)) == 'D' && /* They specified .dir. */
+ toupper(*(cp2+2)) == 'I' && /* Trim it off. */
+ toupper(*(cp2+3)) == 'R') {
+ retlen = cp2 - dir + 1;
+ }
+ else { /* Some other file type. Bzzt. */
+ set_errno(ENOTDIR);
+ set_vaxc_errno(RMS$_DIR);
+ return NULL;
+ }
}
- else { /* Some other file type. Bzzt. */
- errno = ENOTDIR;
- return NULL;
+ else { /* No file type present. Treat the filename as a directory. */
+ retlen = strlen(dir) + 1;
}
}
- else { /* No file type present. Treat the filename as a directory. */
- retlen = strlen(dir) + 1;
- }
if (buf) retpath = buf;
else if (ts) New(7013,retpath,retlen,char);
else retpath = __pathify_retbuf;
@@ -661,30 +917,36 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts)
}
else { /* VMS-style directory spec */
char esa[NAM$C_MAXRSS+1];
- unsigned long int sts, cmplen;
+ unsigned long int cmplen;
struct FAB dirfab = cc$rms_fab;
struct NAM savnam, dirnam = cc$rms_nam;
dirfab.fab$b_fns = strlen(dir);
dirfab.fab$l_fna = dir;
+ if (dir[dirfab.fab$b_fns-1] == ']' ||
+ dir[dirfab.fab$b_fns-1] == '>' ||
+ dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
+ if (buf) retpath = buf;
+ else if (ts) New(7014,retpath,strlen(dir),char);
+ else retpath = __pathify_retbuf;
+ strcpy(retpath,dir);
+ return retpath;
+ }
+ dirfab.fab$l_dna = ".DIR;1";
+ dirfab.fab$b_dns = 6;
dirfab.fab$l_nam = &dirnam;
- dirnam.nam$b_ess = sizeof esa;
+ dirnam.nam$b_ess = (unsigned char) sizeof esa;
dirnam.nam$l_esa = esa;
- dirnam.nam$b_nop = NAM$M_SYNCHK;
if (!(sys$parse(&dirfab)&1)) {
- errno = EVMSERR;
- vaxc$errno = dirfab.fab$l_sts;
+ set_errno(EVMSERR);
+ set_vaxc_errno(dirfab.fab$l_sts);
return NULL;
}
savnam = dirnam;
- if (sys$search(&dirfab)&1) { /* Does the file really exist? */
- /* Yes; fake the fnb bits so we'll check type below */
- dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
- }
- else {
+ if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
if (dirfab.fab$l_sts != RMS$_FNF) {
- errno = EVMSERR;
- vaxc$errno = dirfab.fab$l_sts;
+ set_errno(EVMSERR);
+ set_vaxc_errno(dirfab.fab$l_sts);
return NULL;
}
dirnam = savnam; /* No; just work with potential name */
@@ -695,30 +957,21 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts)
cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
/* Something other than .DIR[;1]. Bzzt. */
- errno = ENOTDIR;
+ set_errno(ENOTDIR);
+ set_vaxc_errno(RMS$_DIR);
return NULL;
}
- /* OK, the type was fine. Now pull any file name into the
- directory path. */
- if (cp1 = strrchr(esa,']')) *dirnam.nam$l_type = ']';
- else {
- cp1 = strrchr(esa,'>');
- *dirnam.nam$l_type = '>';
- }
- *cp1 = '.';
- *(dirnam.nam$l_type + 1) = '\0';
- retlen = dirnam.nam$l_type - esa + 2;
}
+ /* OK, the type was fine. Now pull any file name into the
+ directory path. */
+ if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
else {
- /* There wasn't a type on the input, so ignore any file names as
- well. If you want to pay attention to filenames without .dir
- in the input, just use ".DIR;1" as a default filespec for
- the $PARSE and set retlen thus
- retlen = (dirnam.nam$b_rsl ? dirnam.nam$b_rsl : dirnam.nam$b_esl);
- */
- retlen = dirnam.nam$l_name - esa;
- esa[retlen] = '\0';
+ cp1 = strrchr(esa,'>');
+ *dirnam.nam$l_type = '>';
}
+ *cp1 = '.';
+ *(dirnam.nam$l_type + 1) = '\0';
+ retlen = dirnam.nam$l_type - esa + 2;
if (buf) retpath = buf;
else if (ts) New(7014,retpath,retlen,char);
else retpath = __pathify_retbuf;
@@ -741,7 +994,7 @@ static char *do_tounixspec(char *spec, char *buf, int ts)
char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
int devlen, dirlen;
- if (spec == NULL || *spec == '\0') return NULL;
+ if (spec == NULL) return NULL;
if (buf) rslt = buf;
else if (ts) New(7015,rslt,NAM$C_MAXRSS+1,char);
else rslt = __tounixspec_retbuf;
@@ -771,7 +1024,7 @@ static char *do_tounixspec(char *spec, char *buf, int ts)
}
if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
if (ts) Safefree(rslt); /* filespecs like */
- errno = EVMSERR; vaxc$errno = RMS$_SYN; /* [--foo.bar] */
+ set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [--foo.bar] */
return NULL;
}
cp2++;
@@ -793,7 +1046,8 @@ static char *do_tounixspec(char *spec, char *buf, int ts)
*(cp1++) = '/';
if ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > NAM$C_MAXRSS) {
if (ts) Safefree(rslt);
- errno = ERANGE;
+ set_errno(ERANGE);
+ set_errno(RMS$_SYN);
return NULL;
}
}
@@ -818,7 +1072,7 @@ static char *do_tounixspec(char *spec, char *buf, int ts)
}
if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
if (ts) Safefree(rslt); /* filespecs like */
- errno = EVMSERR; vaxc$errno = RMS$_SYN; /* [--foo.bar] */
+ set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [--foo.bar] */
return NULL;
}
cp2++;
@@ -841,32 +1095,84 @@ char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
/*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
static char *do_tovmsspec(char *path, char *buf, int ts) {
static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
- char *rslt, *dirend, *cp1, *cp2;
+ register char *rslt, *dirend, *cp1, *cp2;
+ register unsigned long int infront = 0;
- if (path == NULL || *path == '\0') return NULL;
+ if (path == NULL) return NULL;
if (buf) rslt = buf;
else if (ts) New(7016,rslt,strlen(path)+1,char);
else rslt = __tovmsspec_retbuf;
- if (strchr(path,']') != NULL || strchr(path,'>') != NULL ||
+ if (strpbrk(path,"]:>") ||
(dirend = strrchr(path,'/')) == NULL) {
- strcpy(rslt,path);
+ if (path[0] == '.') {
+ if (path[1] == '\0') strcpy(rslt,"[]");
+ else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
+ else strcpy(rslt,path); /* probably garbage */
+ }
+ else strcpy(rslt,path);
return rslt;
}
+ if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.."? */
+ if (!*(dirend+2)) dirend +=2;
+ if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
+ }
cp1 = rslt;
cp2 = path;
if (*cp2 == '/') {
while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
*(cp1++) = ':';
*(cp1++) = '[';
- cp2++;
- }
+ if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
+ else cp2++;
+ }
else {
*(cp1++) = '[';
- *(cp1++) = '.';
+ if (*cp2 == '.') {
+ if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
+ cp2 += 2; /* skip over "./" - it's redundant */
+ *(cp1++) = '.'; /* but it does indicate a relative dirspec */
+ }
+ else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
+ *(cp1++) = '-'; /* "../" --> "-" */
+ cp2 += 3;
+ }
+ if (cp2 > dirend) cp2 = dirend;
+ }
+ else *(cp1++) = '.';
+ }
+ for (; cp2 < dirend; cp2++) {
+ if (*cp2 == '/') {
+ if (*(cp1-1) != '.') *(cp1++) = '.';
+ infront = 0;
+ }
+ else if (!infront && *cp2 == '.') {
+ if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
+ else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
+ if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
+ else if (*(cp1-2) == '[') *(cp1-1) = '-';
+ else { /* back up over previous directory name */
+ cp1--;
+ while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
+ }
+ cp2 += 2;
+ if (cp2 == dirend) {
+ if (*(cp1-1) == '.') cp1--;
+ break;
+ }
+ }
+ else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
+ }
+ else {
+ if (*(cp1-1) == '-') *(cp1++) = '.';
+ if (*cp2 == '/') *(cp1++) = '.';
+ else if (*cp2 == '.') *(cp1++) = '_';
+ else *(cp1++) = *cp2;
+ infront = 1;
+ }
}
- for (; cp2 < dirend; cp2++) *(cp1++) = (*cp2 == '/') ? '.' : *cp2;
+ if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
*(cp1++) = ']';
- cp2++;
+ if (*cp2) cp2++; /* check in case we ended with trailing '..' */
while (*cp2) *(cp1++) = *(cp2++);
*cp1 = '\0';
@@ -884,7 +1190,7 @@ static char *do_tovmspath(char *path, char *buf, int ts) {
int vmslen;
char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
- if (path == NULL || *path == '\0') return NULL;
+ if (path == NULL) return NULL;
if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
if (buf) return buf;
@@ -913,7 +1219,7 @@ static char *do_tounixpath(char *path, char *buf, int ts) {
int unixlen;
char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
- if (path == NULL || *path == '\0') return NULL;
+ if (path == NULL) return NULL;
if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
if (buf) return buf;
@@ -1025,7 +1331,6 @@ getredirection(int *ac, char ***av)
char *errmode = "w"; /* Mode to Open Error File */
int cmargc = 0; /* Piped Command Arg Count */
char **cmargv = NULL;/* Piped Command Arg Vector */
- stat_t statbuf; /* fstat buffer */
/*
* First handle the case where the last thing on the line ends with
@@ -1050,8 +1355,8 @@ getredirection(int *ac, char ***av)
{
if (j+1 >= argc)
{
- errno = EINVAL;
- croak("No input file");
+ fprintf(stderr,"No input file after < on command line");
+ exit(LIB$_WRONUMARG);
}
in = argv[++j];
continue;
@@ -1065,8 +1370,8 @@ getredirection(int *ac, char ***av)
{
if (j+1 >= argc)
{
- errno = EINVAL;
- croak("No input file");
+ fprintf(stderr,"No output file after > on command line");
+ exit(LIB$_WRONUMARG);
}
out = argv[++j];
continue;
@@ -1085,8 +1390,8 @@ getredirection(int *ac, char ***av)
out = 1 + ap;
if (j >= argc)
{
- errno = EINVAL;
- croak("No output file");
+ fprintf(stderr,"No output file after > or >> on command line");
+ exit(LIB$_WRONUMARG);
}
continue;
}
@@ -1104,11 +1409,11 @@ getredirection(int *ac, char ***av)
if ('\0' == ap[2])
err = argv[++j];
else
- err = 1 + ap;
+ err = 2 + ap;
if (j >= argc)
{
- errno = EINVAL;
- croak("No error file");
+ fprintf(stderr,"No output file after 2> or 2>> on command line");
+ exit(LIB$_WRONUMARG);
}
continue;
}
@@ -1116,8 +1421,8 @@ getredirection(int *ac, char ***av)
{
if (j+1 >= argc)
{
- errno = EPIPE;
- croak("No command into which to pipe");
+ fprintf(stderr,"No command into which to pipe on command line");
+ exit(LIB$_WRONUMARG);
}
cmargc = argc-(j+1);
cmargv = &argv[j+1];
@@ -1147,8 +1452,8 @@ getredirection(int *ac, char ***av)
{
if (out != NULL)
{
- errno = EINVAL;
- croak("'|' and '>' may not both be specified on command line");
+ fprintf(stderr,"'|' and '>' may not both be specified on command line");
+ exit(LIB$_INVARGORD);
}
pipe_and_fork(cmargv);
}
@@ -1168,10 +1473,10 @@ getredirection(int *ac, char ***av)
if (in != NULL)
{
- errno = EINVAL;
- croak("'|' and '<' may not both be specified on command line");
+ fprintf(stderr,"'|' and '<' may not both be specified on command line");
+ exit(LIB$_INVARGORD);
}
- fgetname(stdin, mbxname);
+ fgetname(stdin, mbxname,1);
mbxnam.dsc$a_pointer = mbxname;
mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
@@ -1180,24 +1485,37 @@ getredirection(int *ac, char ***av)
dvi_item = DVI$_DEVNAM;
lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
- errno = 0;
+ set_errno(0);
+ set_vaxc_errno(1);
freopen(mbxname, "rb", stdin);
if (errno != 0)
{
- croak("Error reopening pipe (name: %s) in binary mode",mbxname);
+ fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
+ exit(vaxc$errno);
}
}
if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
{
- croak("Can't open input file %s",in);
+ fprintf(stderr,"Can't open input file %s as stdin",in);
+ exit(vaxc$errno);
}
if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
{
- croak("Can't open output file %s",out);
+ fprintf(stderr,"Can't open output file %s as stdout",out);
+ exit(vaxc$errno);
}
- if ((err != NULL) && (NULL == freopen(err, errmode, stderr, "mbc=32", "mbf=2")))
- {
- croak("Can't open error file %s",err);
+ if (err != NULL) {
+ FILE *tmperr;
+ if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
+ {
+ fprintf(stderr,"Can't open error file %s as stderr",err);
+ exit(vaxc$errno);
+ }
+ fclose(tmperr);
+ if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
+ {
+ exit(vaxc$errno);
+ }
}
#ifdef ARGPROC_DEBUG
fprintf(stderr, "Arglist:\n");
@@ -1231,9 +1549,8 @@ static void expand_wild_cards(char *item,
int *count)
{
int expcount = 0;
-int context = 0;
+unsigned long int context = 0;
int isunix = 0;
-int status;
int status_value;
char *had_version;
char *had_device;
@@ -1241,7 +1558,7 @@ int had_directory;
char *devdir;
char vmsspec[NAM$C_MAXRSS+1];
$DESCRIPTOR(filespec, "");
-$DESCRIPTOR(defaultspec, "SYS$DISK:[]*.*;");
+$DESCRIPTOR(defaultspec, "SYS$DISK:[]");
$DESCRIPTOR(resultspec, "");
unsigned long int zero = 0;
@@ -1253,7 +1570,7 @@ unsigned long int zero = 0;
resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
resultspec.dsc$b_class = DSC$K_CLASS_D;
resultspec.dsc$a_pointer = NULL;
- if (isunix = strchr(item,'/'))
+ if ((isunix = (int) strchr(item,'/')) != (int) NULL)
filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
if (!isunix || !filespec.dsc$a_pointer)
filespec.dsc$a_pointer = item;
@@ -1304,9 +1621,9 @@ unsigned long int zero = 0;
static int child_st[2];/* Event Flag set when child process completes */
-static short child_chan;/* I/O Channel for Pipe Mailbox */
+static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
-static exit_handler(int *status)
+static unsigned long int exit_handler(int *status)
{
short iosb[4];
@@ -1334,14 +1651,7 @@ static void sig_child(int chan)
child_st[0] = 1;
}
-static struct exit_control_block
- {
- struct exit_control_block *flink;
- int (*exit_routine)();
- int arg_count;
- int *status_address;
- int exit_status;
- } exit_block =
+static struct exit_control_block exit_block =
{
0,
exit_handler,
@@ -1356,10 +1666,7 @@ static void pipe_and_fork(char **cmargv)
$DESCRIPTOR(cmddsc, "");
static char mbxname[64];
$DESCRIPTOR(mbxdsc, mbxname);
- short iosb[4];
- int status;
int pid, j;
- short dvi_item = DVI$_DEVNAM;
unsigned long int zero = 0, one = 1;
strcpy(subcmd, cmargv[0]);
@@ -1377,20 +1684,16 @@ static void pipe_and_fork(char **cmargv)
fprintf(stderr, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
fprintf(stderr, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
#endif
- if (0 == (1&(vaxc$errno = lib$spawn(&cmddsc, &mbxdsc, 0, &one,
+ _ckvmssts(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
0, &pid, child_st, &zero, sig_child,
- &child_chan))))
- {
- errno = EVMSERR;
- croak("Can't spawn subprocess");
- }
+ &child_chan));
#ifdef ARGPROC_DEBUG
fprintf(stderr, "Subprocess's Pid = %08X\n", pid);
#endif
sys$dclexh(&exit_block);
if (NULL == freopen(mbxname, "wb", stdout))
{
- croak("Can't open pipe mailbox for output");
+ fprintf(stderr,"Can't open output pipe (name %s)",mbxname);
}
}
@@ -1404,7 +1707,7 @@ static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
char pidstring[80];
$DESCRIPTOR(pidstr, "");
int pid;
-unsigned long int flags = 17, one = 1;
+unsigned long int flags = 17, one = 1, retsts;
strcat(command, argv[0]);
while (--argc)
@@ -1415,23 +1718,14 @@ unsigned long int flags = 17, one = 1;
}
value.dsc$a_pointer = command;
value.dsc$w_length = strlen(value.dsc$a_pointer);
- if (0 == (1&(vaxc$errno = lib$set_symbol(&cmd, &value))))
- {
- errno = EVMSERR;
- croak("Can't create symbol for subprocess command");
- }
- if ((0 == (1&(vaxc$errno = lib$spawn(&cmd, &null, 0, &flags, 0, &pid)))) &&
- (vaxc$errno != 0x38250))
- {
- errno = EVMSERR;
- croak("Can't spawn subprocess");
- }
- if (vaxc$errno == 0x38250) /* We must be BATCH, so retry */
- if (0 == (1&(vaxc$errno = lib$spawn(&cmd, &null, 0, &one, 0, &pid))))
- {
- errno = EVMSERR;
- croak("Can't spawn subprocess");
- }
+ _ckvmssts(lib$set_symbol(&cmd, &value));
+ retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
+ if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
+ _ckvmssts(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
+ }
+ else {
+ _ckvmssts(retsts);
+ }
#ifdef ARGPROC_DEBUG
fprintf(stderr, "%s\n", command);
#endif
@@ -1445,84 +1739,6 @@ unsigned long int flags = 17, one = 1;
/*}}}*/
/***** End of code taken from Mark Pizzolato's argproc.c package *****/
-/*
- * flex_stat, flex_fstat
- * basic stat, but gets it right when asked to stat
- * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
- */
-
-static char namecache[NAM$C_MAXRSS+1];
-
-static int
-is_null_device(name)
- const char *name;
-{
- /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
- The underscore prefix, controller letter, and unit number are
- independently optional; for our purposes, the colon punctuation
- is not. The colon can be trailed by optional directory and/or
- filename, but two consecutive colons indicates a nodename rather
- than a device. [pr] */
- if (*name == '_') ++name;
- if (tolower(*name++) != 'n') return 0;
- if (tolower(*name++) != 'l') return 0;
- if (tolower(*name) == 'a') ++name;
- if (*name == '0') ++name;
- return (*name++ == ':') && (*name != ':');
-}
-
-/*{{{ int flex_fstat(int fd, struct stat *statbuf)*/
-int
-flex_fstat(int fd, struct stat *statbuf)
-{
- char fspec[NAM$C_MAXRSS+1];
-
- if (!getname(fd,fspec)) return -1;
- return flex_stat(fspec,statbuf);
-
-} /* end of flex_fstat() */
-/*}}}*/
-
-/*{{{ int flex_stat(char *fspec, struct stat *statbufp)*/
-flex_stat(char *fspec, struct stat *statbufp)
-{
- char fileified[NAM$C_MAXRSS+1];
- int retval,myretval;
- struct stat tmpbuf;
-
-
- if (statbufp == &statcache) strcpy(namecache,fspec);
- if (is_null_device(fspec)) { /* Fake a stat() for the null device */
- memset(statbufp,0,sizeof *statbufp);
- statbufp->st_dev = "_NLA0:";
- statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
- statbufp->st_uid = 0x00010001;
- statbufp->st_gid = 0x0001;
- time(&statbufp->st_mtime);
- statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
- return 0;
- }
- if (do_fileify_dirspec(fspec,fileified,0) == NULL) myretval = -1;
- else {
- myretval = stat(fileified,&tmpbuf);
- }
- retval = stat(fspec,statbufp);
- if (!myretval) {
- if (retval == -1) {
- *statbufp = tmpbuf;
- retval = 0;
- }
- else if (!retval) { /* Dir with same name. Substitute it. */
- statbufp->st_mode &= ~S_IFDIR;
- statbufp->st_mode |= tmpbuf.st_mode & S_IFDIR;
- strcpy(namecache,fileified);
- }
- }
- return retval;
-
-} /* end of flex_stat() */
-/*}}}*/
-
/* trim_unixpath()
* Trim Unix-style prefix off filespec, so it looks like what a shell
* glob expansion would return (i.e. from specified prefix on, not
@@ -1567,57 +1783,6 @@ trim_unixpath(char *template, char *fspec)
} /* end of trim_unixpath() */
/*}}}*/
-/* Do the permissions allow some operation? Assumes statcache already set. */
-/* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
- * subset of the applicable information.
- */
-/*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
-I32
-cando(I32 bit, I32 effective, struct stat *statbufp)
-{
- unsigned long int objtyp = ACL$C_FILE, access, retsts;
- unsigned short int retlen;
- struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, namecache};
- static char usrname[L_cuserid];
- static struct dsc$descriptor_s usrdsc =
- {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
- struct itmlst_3 armlst[2] = {sizeof access, CHP$_ACCESS, &access, &retlen,
- 0, 0, 0, 0};
-
- if (!usrdsc.dsc$w_length) {
- cuserid(usrname);
- usrdsc.dsc$w_length = strlen(usrname);
- }
- namdsc.dsc$w_length = strlen(namecache);
- switch (bit) {
- case S_IXUSR:
- case S_IXGRP:
- case S_IXOTH:
- access = ARM$M_EXECUTE;
- break;
- case S_IRUSR:
- case S_IRGRP:
- case S_IROTH:
- access = ARM$M_READ;
- break;
- case S_IWUSR:
- case S_IWGRP:
- case S_IWOTH:
- access = ARM$M_READ;
- break;
- default:
- return FALSE;
- }
-
- retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
- if (retsts == SS$_NORMAL) return TRUE;
- if (retsts == SS$_NOPRIV) return FALSE;
- _cksts(retsts);
-
- return FALSE; /* Should never get here */
-
-} /* end of cando() */
-/*}}}*/
/*
* VMS readdir() routines.
@@ -1728,15 +1893,15 @@ collectversions(dd)
e->vms_verscount++) {
tmpsts = lib$find_file(&pat, &res, &context);
if (tmpsts == RMS$_NMF || context == 0) break;
- _cksts(tmpsts);
+ _ckvmssts(tmpsts);
buff[sizeof buff - 1] = '\0';
- if (p = strchr(buff, ';'))
+ if ((p = strchr(buff, ';')))
e->vms_versions[e->vms_verscount] = atoi(p + 1);
else
e->vms_versions[e->vms_verscount] = -1;
}
- _cksts(lib$find_file_end(&context));
+ _ckvmssts(lib$find_file_end(&context));
Safefree(text);
} /* end of collectversions() */
@@ -1750,7 +1915,6 @@ readdir(DIR *dd)
{
struct dsc$descriptor_s res;
char *p, buff[sizeof dd->entry.d_name];
- int i;
unsigned long int tmpsts;
/* Set up result descriptor, and get next file. */
@@ -1760,7 +1924,8 @@ readdir(DIR *dd)
res.dsc$b_class = DSC$K_CLASS_S;
dd->count++;
tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
- if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
+ if ( tmpsts == RMS$_NMF || tmpsts == RMS$_FNF ||
+ dd->context == 0) return NULL; /* None left. */
/* Force the buffer to end with a NUL, and downcase name to match C convention. */
buff[sizeof buff - 1] = '\0';
@@ -1768,11 +1933,11 @@ readdir(DIR *dd)
*p = '\0';
/* Skip any directory component and just copy the name. */
- if (p = strchr(buff, ']')) (void)strcpy(dd->entry.d_name, p + 1);
+ if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
else (void)strcpy(dd->entry.d_name, buff);
/* Clobber the version. */
- if (p = strchr(dd->entry.d_name, ';')) *p = '\0';
+ if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
dd->entry.d_namlen = strlen(dd->entry.d_name);
dd->entry.vms_verscount = 0;
@@ -1801,7 +1966,6 @@ void
seekdir(DIR *dd, long count)
{
int vms_wantversions;
- unsigned long int tmpsts;
/* If we haven't done anything yet... */
if (dd->count == 0)
@@ -1810,7 +1974,7 @@ seekdir(DIR *dd, long count)
/* Remember some state, and clear it. */
vms_wantversions = dd->vms_wantversions;
dd->vms_wantversions = 0;
- _cksts(lib$find_file_end(&dd->context));
+ _ckvmssts(lib$find_file_end(&dd->context));
dd->context = 0;
/* The increment is in readdir(). */
@@ -1858,7 +2022,7 @@ static int vfork_called;
int
my_vfork()
{
- vfork_called = 1;
+ vfork_called++;
return vfork();
}
/*}}}*/
@@ -1872,7 +2036,8 @@ setup_argstr(SV *really, SV **mark, SV **sp, char **argstr)
register SV **idx;
idx = mark;
- if (really && *(tmps = SvPV(really,rlen))) {
+ tmps = SvPV(really,rlen);
+ if (really && *tmps) {
cmdlen += rlen + 1;
idx++;
}
@@ -1937,8 +2102,8 @@ setup_cmddsc(char *cmd, struct dsc$descriptor_s *cmddsc, int check_img)
retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
if ((retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
else {
- _cksts(retsts);
- _cksts(lib$find_file_end(&cxt));
+ _ckvmssts(retsts);
+ _ckvmssts(lib$find_file_end(&cxt));
s = resspec;
while (*s && !isspace(*s)) s++;
*s = '\0';
@@ -1961,13 +2126,17 @@ vms_do_aexec(SV *really,SV **mark,SV **sp)
if (sp > mark) {
if (vfork_called) { /* this follows a vfork - act Unixish */
- vfork_called = 0;
- do_aexec(really,mark,sp);
- }
- else { /* no vfork - act VMSish */
- setup_argstr(really,mark,sp,&Argv);
- return vms_do_exec(Argv);
+ vfork_called--;
+ if (vfork_called < 0) {
+ warn("Internal inconsistency in tracking vforks");
+ vfork_called = 0;
+ }
+ else return do_aexec(really,mark,sp);
}
+
+ /* no vfork - act VMSish */
+ setup_argstr(really,mark,sp,Argv);
+ return vms_do_exec(*Argv);
}
return FALSE;
@@ -1980,16 +2149,23 @@ vms_do_exec(char *cmd)
{
if (vfork_called) { /* this follows a vfork - act Unixish */
- vfork_called = 0;
- do_exec(cmd);
+ vfork_called--;
+ if (vfork_called < 0) {
+ warn("Internal inconsistency in tracking vforks");
+ vfork_called = 0;
+ }
+ else return do_exec(cmd);
}
- else { /* no vfork - act VMSish */
+
+ { /* no vfork - act VMSish */
struct dsc$descriptor_s cmddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
+ unsigned long int retsts;
- if ((vaxc$errno = setup_cmddsc(cmd,&cmddsc,1)) & 1)
- vaxc$errno = lib$do_command(&cmddsc);
+ if ((retsts = setup_cmddsc(cmd,&cmddsc,1)) & 1)
+ retsts = lib$do_command(&cmddsc);
- errno = EVMSERR;
+ set_errno(EVMSERR);
+ set_vaxc_errno(retsts);
if (dowarn)
warn("Can't exec \"%s\": %s", cmddsc.dsc$a_pointer, Strerror(errno));
do_execfree();
@@ -2008,8 +2184,8 @@ do_aspawn(SV *really,SV **mark,SV **sp)
{
if (sp > mark) {
- setup_argstr(really,mark,sp,&Argv);
- return do_spawn(Argv);
+ setup_argstr(really,mark,sp,Argv);
+ return do_spawn(*Argv);
}
return SS$_ABORT;
@@ -2023,14 +2199,19 @@ do_spawn(char *cmd)
struct dsc$descriptor_s cmddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
unsigned long int substs;
- if ((substs = setup_cmddsc(cmd,&cmddsc,0)) & 1)
- _cksts(lib$spawn(&cmddsc,&nl_desc,0,0,0,&substs,0,0,0,0,0));
+ if (!cmd || !*cmd) {
+ _ckvmssts(lib$spawn(0,0,0,0,0,&substs,0,0,0,0,0));
+ }
+ else if ((substs = setup_cmddsc(cmd,&cmddsc,0)) & 1) {
+ _ckvmssts(lib$spawn(&cmddsc,0,0,0,0,&substs,0,0,0,0,0));
+ }
if (!(substs&1)) {
- vaxc$errno = substs;
- errno = EVMSERR;
+ set_errno(EVMSERR);
+ set_vaxc_errno(substs);
if (dowarn)
- warn("Can't exec \"%s\": %s", cmddsc.dsc$a_pointer, Strerror(errno));
+ warn("Can't exec \"%s\": %s",
+ (cmd && *cmd) ? cmddsc.dsc$a_pointer : "", Strerror(errno));
}
return substs;
@@ -2062,34 +2243,639 @@ my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
} /* end of my_fwrite() */
/*}}}*/
-#ifndef VMS_DO_SOCKETS
-/***** The following two routines are temporary, and should be removed,
- * along with the corresponding #defines in vmsish.h, when TCP/IP support
- * has been added to the VMS port of perl5. (The temporary hacks are
- * here now sho that pack can handle type N elements.)
- * - C. Bailey 16-Aug-1994
- *****/
-
-/*{{{ unsigned short int tmp_shortflip(unsigned short int val)*/
-unsigned short int
-tmp_shortflip(unsigned short int val)
+/*
+ * Here are replacements for the following Unix routines in the VMS environment:
+ * getpwuid Get information for a particular UIC or UID
+ * getpwnam Get information for a named user
+ * getpwent Get information for each user in the rights database
+ * setpwent Reset search to the start of the rights database
+ * endpwent Finish searching for users in the rights database
+ *
+ * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
+ * (defined in pwd.h), which contains the following fields:-
+ * struct passwd {
+ * char *pw_name; Username (in lower case)
+ * char *pw_passwd; Hashed password
+ * unsigned int pw_uid; UIC
+ * unsigned int pw_gid; UIC group number
+ * char *pw_unixdir; Default device/directory (VMS-style)
+ * char *pw_gecos; Owner name
+ * char *pw_dir; Default device/directory (Unix-style)
+ * char *pw_shell; Default CLI name (eg. DCL)
+ * };
+ * If the specified user does not exist, getpwuid and getpwnam return NULL.
+ *
+ * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
+ * not the UIC member number (eg. what's returned by getuid()),
+ * getpwuid() can accept either as input (if uid is specified, the caller's
+ * UIC group is used), though it won't recognise gid=0.
+ *
+ * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
+ * information about other users in your group or in other groups, respectively.
+ * If the required privilege is not available, then these routines fill only
+ * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
+ * string).
+ *
+ * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
+ */
+
+/* sizes of various UAF record fields */
+#define UAI$S_USERNAME 12
+#define UAI$S_IDENT 31
+#define UAI$S_OWNER 31
+#define UAI$S_DEFDEV 31
+#define UAI$S_DEFDIR 63
+#define UAI$S_DEFCLI 31
+#define UAI$S_PWD 8
+
+#define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
+ (uic).uic$v_member != UIC$K_WILD_MEMBER && \
+ (uic).uic$v_group != UIC$K_WILD_GROUP)
+
+static const char __empty[]= "";
+static const struct passwd __passwd_empty=
+ {(char *) __empty, (char *) __empty, 0, 0,
+ (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
+static int contxt= 0;
+static struct passwd __pwdcache;
+static char __pw_namecache[UAI$S_IDENT+1];
+
+static char *_mystrtolower(char *str)
+{
+ if (str) for (; *str; ++str) *str= tolower(*str);
+ return str;
+}
+
+/*
+ * This routine does most of the work extracting the user information.
+ */
+static int fillpasswd (const char *name, struct passwd *pwd)
{
- return val << 8 | val >> 8;
+ static struct {
+ unsigned char length;
+ char pw_gecos[UAI$S_OWNER+1];
+ } owner;
+ static union uicdef uic;
+ static struct {
+ unsigned char length;
+ char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
+ } defdev;
+ static struct {
+ unsigned char length;
+ char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
+ } defdir;
+ static struct {
+ unsigned char length;
+ char pw_shell[UAI$S_DEFCLI+1];
+ } defcli;
+ static char pw_passwd[UAI$S_PWD+1];
+
+ static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
+ struct dsc$descriptor_s name_desc;
+ int status;
+
+ static const struct itmlst_3 itmlst[]= {
+ {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
+ {sizeof(uic), UAI$_UIC, &uic, &luic},
+ {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
+ {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
+ {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
+ {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
+ {0, 0, NULL, NULL}};
+
+ name_desc.dsc$w_length= strlen(name);
+ name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
+ name_desc.dsc$b_class= DSC$K_CLASS_S;
+ name_desc.dsc$a_pointer= (char *) name;
+
+/* Note that sys$getuai returns many fields as counted strings. */
+ status= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
+ if (!(status&1)) return status;
+
+ if ((int) owner.length < lowner) lowner= (int) owner.length;
+ if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
+ if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
+ if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
+ memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
+ owner.pw_gecos[lowner]= '\0';
+ defdev.pw_dir[ldefdev+ldefdir]= '\0';
+ defcli.pw_shell[ldefcli]= '\0';
+ if (valid_uic(uic)) {
+ pwd->pw_uid= uic.uic$l_uic;
+ pwd->pw_gid= uic.uic$v_group;
+ }
+ else
+ warn("getpwnam returned invalid UIC %#o for user \"%s\"");
+ pwd->pw_passwd= pw_passwd;
+ pwd->pw_gecos= owner.pw_gecos;
+ pwd->pw_dir= defdev.pw_dir;
+ pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
+ pwd->pw_shell= defcli.pw_shell;
+ if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
+ int ldir;
+ ldir= strlen(pwd->pw_unixdir) - 1;
+ if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
+ }
+ else
+ strcpy(pwd->pw_unixdir, pwd->pw_dir);
+ _mystrtolower(pwd->pw_unixdir);
+ return status;
}
+
+/*
+ * Get information for a named user.
+*/
+/*{{{struct passwd *getpwnam(char *name)*/
+struct passwd *my_getpwnam(char *name)
+{
+ struct dsc$descriptor_s name_desc;
+ union uicdef uic;
+ unsigned long int status, stat;
+
+ __pwdcache = __passwd_empty;
+ if ((status = fillpasswd(name, &__pwdcache)) == SS$_NOSYSPRV
+ || status == SS$_NOGRPPRV || status == RMS$_RNF) {
+ /* We still may be able to determine pw_uid and pw_gid */
+ name_desc.dsc$w_length= strlen(name);
+ name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
+ name_desc.dsc$b_class= DSC$K_CLASS_S;
+ name_desc.dsc$a_pointer= (char *) name;
+ if ((stat = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
+ __pwdcache.pw_uid= uic.uic$l_uic;
+ __pwdcache.pw_gid= uic.uic$v_group;
+ }
+ else if (stat == SS$_NOSUCHID || stat == RMS$_PRV) return NULL;
+ else { _ckvmssts(stat); }
+ }
+ else { _ckvmssts(status); }
+ strncpy(__pw_namecache, name, sizeof(__pw_namecache));
+ __pw_namecache[sizeof __pw_namecache - 1] = '\0';
+ __pwdcache.pw_name= __pw_namecache;
+ return &__pwdcache;
+} /* end of my_getpwnam() */
/*}}}*/
-/*{{{ unsigned long int tmp_longflip(unsigned long int val)*/
-unsigned long int
-tmp_longflip(unsigned long int val)
+/*
+ * Get information for a particular UIC or UID.
+ * Called by my_getpwent with uid=-1 to list all users.
+*/
+/*{{{struct passwd *my_getpwuid(Uid_t uid)*/
+struct passwd *my_getpwuid(Uid_t uid)
{
- unsigned long int scratch = val;
- unsigned char savbyte, *tmp;
+ const $DESCRIPTOR(name_desc,__pw_namecache);
+ unsigned short lname;
+ union uicdef uic;
+ unsigned long int status;
+
+ if (uid == (unsigned int) -1) {
+ do {
+ status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
+ if (status == SS$_NOSUCHID || status == RMS$_PRV) {
+ my_endpwent();
+ return NULL;
+ }
+ else { _ckvmssts(status); }
+ } while (!valid_uic (uic));
+ }
+ else {
+ uic.uic$l_uic= uid;
+ if (!uic.uic$v_group) uic.uic$v_group= getgid();
+ if (valid_uic(uic))
+ status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
+ else status = SS$_IVIDENT;
+ _ckvmssts(status);
+ }
+ __pw_namecache[lname]= '\0';
+ _mystrtolower(__pw_namecache);
+
+ __pwdcache = __passwd_empty;
+ __pwdcache.pw_name = __pw_namecache;
+
+/* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
+ The identifier's value is usually the UIC, but it doesn't have to be,
+ so if we can, we let fillpasswd update this. */
+ __pwdcache.pw_uid = uic.uic$l_uic;
+ __pwdcache.pw_gid = uic.uic$v_group;
+
+ status = fillpasswd(__pw_namecache, &__pwdcache);
+ if (status != SS$_NOSYSPRV && status != SS$_NOGRPPRV &&
+ status != RMS$_RNF) { _ckvmssts(status); }
+ return &__pwdcache;
- tmp = (unsigned char *) &scratch;
- savbyte = tmp[0]; tmp[0] = tmp[3]; tmp[3] = savbyte;
- savbyte = tmp[1]; tmp[1] = tmp[2]; tmp[2] = savbyte;
+} /* end of my_getpwuid() */
+/*}}}*/
+
+/*
+ * Get information for next user.
+*/
+/*{{{struct passwd *my_getpwent()*/
+struct passwd *my_getpwent()
+{
+ return (my_getpwuid((unsigned int) -1));
+}
+/*}}}*/
- return scratch;
+/*
+ * Finish searching rights database for users.
+*/
+/*{{{void my_endpwent()*/
+void my_endpwent()
+{
+ if (contxt) {
+ _ckvmssts(sys$finish_rdb(&contxt));
+ contxt= 0;
+ }
}
/*}}}*/
+
+/*
+ * flex_stat, flex_fstat
+ * basic stat, but gets it right when asked to stat
+ * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
+ */
+
+/* encode_dev packs a VMS device name string into an integer to allow
+ * simple comparisons. This can be used, for example, to check whether two
+ * files are located on the same device, by comparing their encoded device
+ * names. Even a string comparison would not do, because stat() reuses the
+ * device name buffer for each call; so without encode_dev, it would be
+ * necessary to save the buffer and use strcmp (this would mean a number of
+ * changes to the standard Perl code, to say nothing of what a Perl script
+ * would have to do.
+ *
+ * The device lock id, if it exists, should be unique (unless perhaps compared
+ * with lock ids transferred from other nodes). We have a lock id if the disk is
+ * mounted cluster-wide, which is when we tend to get long (host-qualified)
+ * device names. Thus we use the lock id in preference, and only if that isn't
+ * available, do we try to pack the device name into an integer (flagged by
+ * the sign bit (LOCKID_MASK) being set).
+ *
+ * Note that encode_dev cann guarantee an 1-to-1 correspondence twixt device
+ * name and its encoded form, but it seems very unlikely that we will find
+ * two files on different disks that share the same encoded device names,
+ * and even more remote that they will share the same file id (if the test
+ * is to check for the same file).
+ *
+ * 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.
+ * This is probably not worth it, and anyway would take quite a bit longer
+ * on the first call.
+ */
+#define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
+static dev_t encode_dev (const char *dev)
+{
+ int i;
+ unsigned long int f;
+ dev_t enc;
+ char c;
+ const char *q;
+
+ if (!dev || !dev[0]) return 0;
+
+#if LOCKID_MASK
+ {
+ struct dsc$descriptor_s dev_desc;
+ unsigned long int status, lockid, item = DVI$_LOCKID;
+
+ /* For cluster-mounted disks, the disk lock identifier is unique, so we
+ can try that first. */
+ dev_desc.dsc$w_length = strlen (dev);
+ 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;
+ _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
+ if (lockid) return (lockid & ~LOCKID_MASK);
+ }
#endif
+
+ /* Otherwise we try to encode the device name */
+ enc = 0;
+ f = 1;
+ i = 0;
+ for (q = dev + strlen(dev); q--; q >= dev) {
+ if (isdigit (*q))
+ c= (*q) - '0';
+ else if (isalpha (toupper (*q)))
+ c= toupper (*q) - 'A' + (char)10;
+ else
+ continue; /* Skip '$'s */
+ i++;
+ if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
+ if (i>1) f *= 36;
+ enc += f * (unsigned long int) c;
+ }
+ return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
+
+} /* end of encode_dev() */
+
+static char namecache[NAM$C_MAXRSS+1];
+
+static int
+is_null_device(name)
+ const char *name;
+{
+ /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
+ The underscore prefix, controller letter, and unit number are
+ independently optional; for our purposes, the colon punctuation
+ is not. The colon can be trailed by optional directory and/or
+ filename, but two consecutive colons indicates a nodename rather
+ than a device. [pr] */
+ if (*name == '_') ++name;
+ if (tolower(*name++) != 'n') return 0;
+ if (tolower(*name++) != 'l') return 0;
+ if (tolower(*name) == 'a') ++name;
+ if (*name == '0') ++name;
+ return (*name++ == ':') && (*name != ':');
+}
+
+/* Do the permissions allow some operation? Assumes statcache already set. */
+/* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
+ * subset of the applicable information.
+ */
+/*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
+I32
+cando(I32 bit, I32 effective, struct stat *statbufp)
+{
+ if (statbufp == &statcache)
+ return cando_by_name(bit,effective,namecache);
+ else {
+ char fname[NAM$C_MAXRSS+1];
+ unsigned long int retsts;
+ struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
+ namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
+
+ /* If the struct mystat is stale, we're OOL; stat() overwrites the
+ device name on successive calls */
+ devdsc.dsc$a_pointer = statbufp->st_devnam;
+ devdsc.dsc$w_length = strlen(statbufp->st_devnam);
+ namdsc.dsc$a_pointer = fname;
+ namdsc.dsc$w_length = sizeof fname - 1;
+
+ retsts = lib$fid_to_name(&devdsc,statbufp->st_inode_u.fid,&namdsc,
+ &namdsc.dsc$w_length,0,0);
+ if (retsts & 1) {
+ fname[namdsc.dsc$w_length] = '\0';
+ return cando_by_name(bit,effective,fname);
+ }
+ else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
+ warn("Can't get filespec - stale stat buffer?\n");
+ return FALSE;
+ }
+ _ckvmssts(retsts);
+ return FALSE; /* Should never get to here */
+ }
+}
+/*}}}*/
+
+/*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
+I32
+cando_by_name(I32 bit, I32 effective, char *fname)
+{
+ static char usrname[L_cuserid];
+ static struct dsc$descriptor_s usrdsc =
+ {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
+
+ unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
+ unsigned short int retlen;
+ struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
+ union prvdef curprv;
+ struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
+ {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
+ struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
+ {0,0,0,0}};
+
+ if (!fname || !*fname) return FALSE;
+ if (!usrdsc.dsc$w_length) {
+ cuserid(usrname);
+ usrdsc.dsc$w_length = strlen(usrname);
+ }
+ namdsc.dsc$w_length = strlen(fname);
+ namdsc.dsc$a_pointer = fname;
+ switch (bit) {
+ case S_IXUSR:
+ case S_IXGRP:
+ case S_IXOTH:
+ access = ARM$M_EXECUTE;
+ break;
+ case S_IRUSR:
+ case S_IRGRP:
+ case S_IROTH:
+ access = ARM$M_READ;
+ break;
+ case S_IWUSR:
+ case S_IWGRP:
+ case S_IWOTH:
+ access = ARM$M_WRITE;
+ break;
+ case S_IDUSR:
+ case S_IDGRP:
+ case S_IDOTH:
+ access = ARM$M_DELETE;
+ break;
+ default:
+ return FALSE;
+ }
+
+ retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
+ if (retsts == SS$_NOPRIV || retsts == RMS$_FNF ||
+ retsts == RMS$_DIR || retsts == RMS$_DEV) return FALSE;
+ if (retsts == SS$_NORMAL) {
+ if (!privused) return TRUE;
+ /* We can get access, but only by using privs. Do we have the
+ necessary privs currently enabled? */
+ _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
+ if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
+ if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv
+ && !curprv.prv$v_bypass) return FALSE;
+ if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv
+ && !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
+ if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
+ return TRUE;
+ }
+ _ckvmssts(retsts);
+
+ return FALSE; /* Should never get here */
+
+} /* end of cando_by_name() */
+/*}}}*/
+
+
+/*{{{ int flex_fstat(int fd, struct stat *statbuf)*/
+int
+flex_fstat(int fd, struct stat *statbuf)
+{
+ char fspec[NAM$C_MAXRSS+1];
+
+ if (!getname(fd,fspec,1)) return -1;
+ return flex_stat(fspec,statbuf);
+
+} /* end of flex_fstat() */
+/*}}}*/
+
+/*{{{ int flex_stat(char *fspec, struct stat *statbufp)*/
+int
+flex_stat(char *fspec, struct stat *statbufp)
+{
+ char fileified[NAM$C_MAXRSS+1];
+ int retval,myretval;
+ struct stat tmpbuf;
+
+
+ if (statbufp == &statcache) do_tovmsspec(fspec,namecache,0);
+ if (is_null_device(fspec)) { /* Fake a stat() for the null device */
+ memset(statbufp,0,sizeof *statbufp);
+ statbufp->st_dev = encode_dev("_NLA0:");
+ statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
+ statbufp->st_uid = 0x00010001;
+ statbufp->st_gid = 0x0001;
+ time((time_t *)&statbufp->st_mtime);
+ statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
+ return 0;
+ }
+
+/* We defined 'stat' as 'mystat' in vmsish.h so that declarations of
+ * 'struct stat' elsewhere in Perl would use our struct. We go back
+ * to the system version here, since we're actually calling their
+ * stat().
+ */
+#undef stat
+
+ if (do_fileify_dirspec(fspec,fileified,0) == NULL) myretval = -1;
+ else {
+ myretval = stat(fileified,(stat_t *) &tmpbuf);
+ }
+ retval = stat(fspec,(stat_t *) statbufp);
+ if (!myretval) {
+ if (retval == -1) {
+ *statbufp = tmpbuf;
+ retval = 0;
+ }
+ else if (!retval) { /* Dir with same name. Substitute it. */
+ statbufp->st_mode &= ~S_IFDIR;
+ statbufp->st_mode |= tmpbuf.st_mode & S_IFDIR;
+ strcpy(namecache,fileified);
+ }
+ }
+ if (!retval) statbufp->st_dev = encode_dev(statbufp->st_devnam);
+ return retval;
+
+} /* end of flex_stat() */
+/*}}}*/
+
+/*** The following glue provides 'hooks' to make some of the routines
+ * from this file available from Perl. These routines are sufficiently
+ * basic, and are required sufficiently early in the build process,
+ * that's it's nice to have them available to miniperl as well as the
+ * full Perl, so they're set up here instead of in an extension. The
+ * Perl code which handles importation of these names into a given
+ * package lives in [.VMS]Filespec.pm in @INC.
+ */
+
+void
+vmsify_fromperl(CV *cv)
+{
+ dXSARGS;
+ char *vmsified;
+
+ if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
+ vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
+ ST(0) = sv_newmortal();
+ if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
+ XSRETURN(1);
+}
+
+void
+unixify_fromperl(CV *cv)
+{
+ dXSARGS;
+ char *unixified;
+
+ if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
+ unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
+ ST(0) = sv_newmortal();
+ if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
+ XSRETURN(1);
+}
+
+void
+fileify_fromperl(CV *cv)
+{
+ dXSARGS;
+ char *fileified;
+
+ if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
+ fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1);
+ ST(0) = sv_newmortal();
+ if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
+ XSRETURN(1);
+}
+
+void
+pathify_fromperl(CV *cv)
+{
+ dXSARGS;
+ char *pathified;
+
+ if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
+ pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1);
+ ST(0) = sv_newmortal();
+ if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
+ XSRETURN(1);
+}
+
+void
+vmspath_fromperl(CV *cv)
+{
+ dXSARGS;
+ char *vmspath;
+
+ if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
+ vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1);
+ ST(0) = sv_newmortal();
+ if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
+ XSRETURN(1);
+}
+
+void
+unixpath_fromperl(CV *cv)
+{
+ dXSARGS;
+ char *unixpath;
+
+ if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
+ unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1);
+ ST(0) = sv_newmortal();
+ if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
+ XSRETURN(1);
+}
+
+void
+candelete_fromperl(CV *cv)
+{
+ dXSARGS;
+ char vmsspec[NAM$C_MAXRSS+1];
+
+ if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
+ if (do_tovmsspec(SvPV(ST(0),na),buf,0) && cando_by_name(S_IDUSR,0,buf))
+ ST(0) = &sv_yes;
+ else ST(0) = &sv_no;
+ XSRETURN(1);
+}
+
+void
+init_os_extras()
+{
+ char* file = __FILE__;
+
+ newXS("VMS::Filespec::vmsify",vmsify_fromperl,file);
+ newXS("VMS::Filespec::unixify",unixify_fromperl,file);
+ newXS("VMS::Filespec::pathify",pathify_fromperl,file);
+ newXS("VMS::Filespec::fileify",fileify_fromperl,file);
+ newXS("VMS::Filespec::vmspath",vmspath_fromperl,file);
+ newXS("VMS::Filespec::unixpath",unixpath_fromperl,file);
+ newXS("VMS::Filespec::candelete",candelete_fromperl,file);
+ return;
+}
+
+/* End of vms.c */
diff --git a/vms/vmsish.h b/vms/vmsish.h
index ec0dbde2eb..ce6829060e 100644
--- a/vms/vmsish.h
+++ b/vms/vmsish.h
@@ -2,26 +2,53 @@
*
* VMS-specific C header file for perl5.
*
- * Last revised: 09-Oct-1994 by Charles Bailey bailey@genetics.upenn.edu
+ * Last revised: 12-Dec-1994 by Charles Bailey bailey@genetics.upenn.edu
*/
#ifndef __vmsish_h_included
#define __vmsish_h_included
#include <descrip.h> /* for dirent struct definitions */
+#include <libdef.h> /* status codes for various places */
+#include <rmsdef.h> /* at which errno and vaxc$errno are */
+#include <ssdef.h> /* explicitly set in the perl source code */
+
+/* DEC's C compilers and gcc use incompatible definitions of _to(upp|low)er() */
+#ifdef _toupper
+# undef _toupper
+#endif
+#define _toupper(c) (((c) < 'a' || (c) > 'z') ? (c) : (c) & ~040)
+#ifdef _tolower
+# undef _tolower
+#endif
+#define _tolower(c) (((c) < 'A' || (c) > 'Z') ? (c) : (c) | 040)
/* Assorted things to look like Unix */
#ifdef __GNUC__
#ifndef _IOLBF /* gcc's stdio.h doesn't define this */
#define _IOLBF 1
#endif
-#else
+#endif
#include <processes.h> /* for vfork() */
#include <unixio.h>
-#endif
#include <unixlib.h>
#include <file.h> /* it's not <sys/file.h>, so don't use I_SYS_FILE */
-#define unlink remove
+#define unlink kill_file
+
+/* Macros to set errno using the VAX thread-safe calls, if present */
+#if (defined(__DECC) || defined(__DECCXX)) && !defined(__ALPHA)
+# define set_errno(v) (cma$tis_errno_set_value(v))
+# define set_vaxc_errno(v) (vaxc$errno = (v))
+#else
+# define set_errno(v) (errno = (v))
+# define set_vaxc_errno(v) (vaxc$errno = (v))
+#endif
+
+/* Handy way to vet calls to VMS system services and RTL routines. */
+#define _ckvmssts(call) { register unsigned long int __ckvms_sts; \
+ if (!((__ckvms_sts=(call))&1)) { \
+ set_errno(EVMSERR); set_vaxc_errno(__ckvms_sts); \
+ croak("Fatal VMS error at %s, line %d",__FILE__,__LINE__); } }
#ifdef VMS_DO_SOCKETS
#include "sockadapt.h"
@@ -57,6 +84,13 @@
# include <signal.h>
#define ABORT() abort()
+/* Used with our my_utime() routine in vms.c */
+struct utimbuf {
+ time_t actime;
+ time_t modtime;
+};
+#define utime my_utime
+
/* This is what times() returns, but <times.h> calls it tbuffer_t on VMS */
struct tms {
@@ -107,6 +141,82 @@ typedef struct _dirdesc {
#define rewinddir(dirp) seekdir((dirp), 0)
+/* used for our emulation of getpw* */
+struct passwd {
+ char *pw_name; /* Username */
+ char *pw_passwd;
+ Uid_t pw_uid; /* UIC member number */
+ Gid_t pw_gid; /* UIC group number */
+ char *pw_comment; /* Default device/directory (Unix-style) */
+ char *pw_gecos; /* Owner */
+ char *pw_dir; /* Default device/directory (VMS-style) */
+ char *pw_shell; /* Default CLI name (eg. DCL) */
+};
+#define pw_unixdir pw_comment /* Default device/directory (Unix-style) */
+#define getpwnam my_getpwnam
+#define getpwuid my_getpwuid
+#define getpwent my_getpwent
+#define endpwent my_endpwent
+#define setpwent my_endpwent
+
+/* Our own stat_t substitute, since we play with st_dev and st_ino -
+ * we want atomic types so Unix-bound code which compares these fields
+ * for two files will work most of the time under VMS
+ */
+/* First, grab the system types, so we don't clobber them later */
+#include <stat.h>
+/* Since we've got to match the size of the CRTL's stat_t, we need
+ * to mimic DECC's alignment settings.
+ */
+#if defined(__DECC) || defined(__DECCXX)
+# pragma __member_alignment __save
+# pragma __nomember_alignment
+#endif
+#if defined(__DECC)
+# pragma __message __save
+# pragma __message disable (__MISALGNDSTRCT)
+# pragma __message disable (__MISALGNDMEM)
+#endif
+struct mystat
+{
+ char *st_devnam; /* pointer to device name */
+ union {
+ unsigned short fid[3];
+ unsigned long st_ino_mostly;
+ } st_inode_u;
+ unsigned short st_mode; /* file "mode" i.e. prot, dir, reg, etc. */
+ int st_nlink; /* for compatibility - not really used */
+ unsigned st_uid; /* from ACP - QIO uic field */
+ unsigned short st_gid; /* group number extracted from st_uid */
+ dev_t st_rdev; /* for compatibility - always zero */
+ off_t st_size; /* file size in bytes */
+ unsigned st_atime; /* file access time; always same as st_mtime */
+ unsigned st_mtime; /* last modification time */
+ unsigned st_ctime; /* file creation time */
+ char st_fab_rfm; /* record format */
+ char st_fab_rat; /* record attributes */
+ char st_fab_fsz; /* fixed header size */
+ unsigned st_dev; /* encoded device name */
+};
+#ifdef st_ino
+# undef st_ino
+#endif
+#define st_ino st_inode_u.st_ino_mostly
+#define stat mystat
+typedef unsigned mydev_t;
+#define dev_t mydev_t
+typedef unsigned long myino_t;
+#define ino_t myino_t
+#if defined(__DECC) || defined(__DECCXX)
+# pragma __member_alignment __restore
+#endif
+#if defined(__DECC)
+# pragma __message __restore
+#endif
+/* Cons up a 'delete' bit for testing access */
+#define S_IDUSR (S_IWUSR | S_IXUSR)
+#define S_IDGRP (S_IWGRP | S_IXGRP)
+#define S_IDOTH (S_IWOTH | S_IXOTH)
/* Prototypes for functions unique to vms.c. Don't include replacements
* for routines in the mainline source files excluded by #ifndef VMS;
@@ -119,12 +229,11 @@ typedef struct _dirdesc {
*/
typedef char __VMS_PROTOTYPES__; /* prototype section start marker */
char * my_getenv _((char *));
-#ifndef HAS_WAITPID /* Not a real waitpid - use only with popen from vms.c! */
unsigned long int waitpid _((unsigned long int, int *, int));
-#endif
char * my_gconvert _((double, int, int, char *));
int do_rmdir _((char *));
int kill_file _((char *));
+int my_utime _((char *, struct utimbuf *));
char * fileify_dirspec _((char *, char *));
char * fileify_dirspec_ts _((char *, char *));
char * pathify_dirspec _((char *, char *));
@@ -145,32 +254,31 @@ void seekdir _((DIR *, long));
void closedir _((DIR *));
void vmsreaddirversions _((DIR *, int));
void getredirection _((int *, char ***));
-int flex_fstat _((int, stat_t *));
-int flex_stat _((char *, stat_t *));
+I32 cando_by_name _((I32, I32, char *));
+int flex_fstat _((int, struct stat *));
+int flex_stat _((char *, struct stat *));
int trim_unixpath _((char *, char*));
-struct sv; /* forward declaration for vms_do_aexec and do_aspawn */
- /* real declaration is in sv.h */
-#define bool char /* This must match handy.h */
-bool vms_do_aexec _((struct sv *, struct sv **, struct sv **));
+bool vms_do_aexec _((SV *, SV **, SV **));
bool vms_do_exec _((char *));
-unsigned long int do_aspawn _((struct sv *, struct sv **, struct sv **));
+unsigned long int do_aspawn _((SV *, SV **, SV **));
unsigned long int do_spawn _((char *));
int my_fwrite _((void *, size_t, size_t, FILE *));
+struct passwd * my_getpwnam _((char *name));
+struct passwd * my_getpwuid _((Uid_t uid));
+struct passwd * my_getpwent _(());
+void my_endpwent _(());
+void init_os_extras _(());
typedef char __VMS_SEPYTOTORP__; /* prototype section end marker */
#ifndef VMS_DO_SOCKETS
-/***** The following four #defines are temporary, and should be removed,
- * along with the corresponding routines in vms.c, when TCP/IP support
- * is integrated into the VMS port of perl5. (The temporary hacks are
- * here for now so pack can handle type N elements.)
- * - C. Bailey 26-Aug-1994
- *****/
-unsigned short int tmp_shortflip _((unsigned short int));
-unsigned long int tmp_longflip _((unsigned long int));
-#define htons(us) tmp_shortflip(us)
-#define ntohs(us) tmp_shortflip(us)
-#define htonl(ul) tmp_longflip(ul)
-#define ntohl(ul) tmp_longflip(ul)
+/* This relies on tricks in perl.h to pick up that these manifest constants
+ * are undefined and set up conversion routines. It will then redefine
+ * these manifest constants, so the actual values will match config.h
+ */
+#undef HAS_HTONS
+#undef HAS_NTOHS
+#undef HAS_HTONL
+#undef HAS_NTOHL
#endif
#endif /* __vmsish_h_included */
diff --git a/vms/writemain.pl b/vms/writemain.pl
index 38b6670b10..0208313288 100644
--- a/vms/writemain.pl
+++ b/vms/writemain.pl
@@ -1,7 +1,11 @@
#!./miniperl
#
# Create perlmain.c from miniperlmain.c, adding code to boot the
-# extensions listed on the command line.
+# extensions listed on the command line. In addition, create a
+# linker options file which causes the bootstrap routines for
+# these extension to be universal symbols in PerlShr.Exe.
+#
+# Last modified 29-Nov-1994 by Charles Bailey bailey@genetics.upenn.edu
#
if (-f 'miniperlmain.c') { $dir = ''; }
@@ -28,23 +32,30 @@ if (!$ok) {
}
-if ($#ARGV > -1) {
- print OUT " char *file = __FILE__;\n";
+if (@ARGV) {
+ # Allow for multiple names in one quoted group
+ @exts = split(/\s+/, join(' ',@ARGV));
}
-foreach $ext (@ARGV) {
- print OUT "extern void boot_${ext} _((CV* cv));\n"
-}
-
-foreach $ext (@ARGV) {
- print "Adding $ext . . .\n";
- if ($ext eq 'DynaLoader') {
- # Must NOT install 'DynaLoader::boot_DynaLoader' as 'bootstrap'!
- # boot_DynaLoader is called directly in DynaLoader.pm
- print OUT " newXS(\"${ext}::boot_${ext}\", boot_${ext}, file);\n"
+if (@exts) {
+ print OUT " char *file = __FILE__;\n";
+ foreach $ext (@exts) {
+ my($subname) = $ext;
+ $subname =~ s/::/__/g;
+ print OUT "extern void boot_${subname} _((CV* cv));\n"
}
- else {
- print OUT " newXS(\"${ext}::bootstrap\", boot_${ext}, file);\n"
+ foreach $ext (@exts) {
+ my($subname) = $ext;
+ $subname =~ s/::/__/g;
+ print "Adding $ext . . .\n";
+ if ($ext eq 'DynaLoader') {
+ # Must NOT install 'DynaLoader::boot_DynaLoader' as 'bootstrap'!
+ # boot_DynaLoader is called directly in DynaLoader.pm
+ print OUT " newXS(\"${ext}::boot_${ext}\", boot_${subname}, file);\n"
+ }
+ else {
+ print OUT " newXS(\"${ext}::bootstrap\", boot_${subname}, file);\n"
+ }
}
}