dslinux/user/perl/vms descrip_mms.template gen_shrfls.pl genconfig.pl genopt.com make_command.com mms2make.pl munchconfig.c myconfig.com perlvms.pod perly_c.vms perly_h.vms sockadapt.c sockadapt.h test.com vms.c vms_yfix.pl vmsish.h vmspipe.com writemain.pl
cayenne
dslinux_cayenne at user.in-berlin.de
Mon Dec 4 18:02:16 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/vms
In directory antilope:/tmp/cvs-serv17422/vms
Added Files:
descrip_mms.template gen_shrfls.pl genconfig.pl genopt.com
make_command.com mms2make.pl munchconfig.c myconfig.com
perlvms.pod perly_c.vms perly_h.vms sockadapt.c sockadapt.h
test.com vms.c vms_yfix.pl vmsish.h vmspipe.com writemain.pl
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: writemain.pl ---
#!./miniperl
#
# Create perlmain.c from miniperlmain.c, adding code to boot the
# 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 at newman.upenn.edu
#
if (-f 'miniperlmain.c') { $dir = ''; }
elsif (-f '../miniperlmain.c') { $dir = '../'; }
else { die "$0: Can't find miniperlmain.c\n"; }
open (IN,"${dir}miniperlmain.c")
|| die "$0: Can't open ${dir}miniperlmain.c: $!\n";
open (OUT,">${dir}perlmain.c")
|| die "$0: Can't open ${dir}perlmain.c: $!\n";
while (<IN>) {
print OUT;
last if /Do not delete this line--writemain depends on it/;
}
$ok = !eof(IN);
close IN;
if (!$ok) {
close OUT;
unlink "${dir}perlmain.c";
die "$0: Can't find marker line in ${dir}miniperlmain.c - aborting\n";
}
print OUT <<'EOH';
static void
xs_init(pTHX)
{
EOH
if (@ARGV) {
$names = join(' ', at ARGV);
$names =~ tr/"//d; # Plan9 doesn't remove "" on command line
# Allow for multiple names in one quoted group
@exts = split(/\s+/,$names);
}
if (@exts) {
print OUT " char *file = __FILE__;\n";
foreach $ext (@exts) {
my($subname) = $ext;
$subname =~ s/::/__/g;
print OUT "extern void boot_${subname} (pTHX_ CV* cv);\n"
}
# May not actually be a declaration, so put after other declarations
print OUT " dXSUB_SYS;\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"
}
}
}
print OUT "}\n";
close OUT;
--- NEW FILE: sockadapt.h ---
/* sockadapt.h
*
* Authors: Charles Bailey bailey at newman.upenn.edu
* David Denholm denholm at conmat.phys.soton.ac.uk
* Last Revised: 4-Mar-1997
*
* 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.9D TCP/IP support.
*/
#ifndef __SOCKADAPT_INCLUDED
#define __SOCKADAPT_INCLUDED 1
#if defined(DECCRTL_SOCKETS)
/* Use builtin socket interface in DECCRTL and
* UCX emulation in whatever TCP/IP stack is present.
* Provide prototypes for missing routines; stubs are
* in sockadapt.c.
*/
# include <socket.h>
# include <inet.h>
# include <in.h>
# include <netdb.h>
#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000)
#else
void sethostent(int);
void endhostent(void);
void setnetent(int);
void endnetent(void);
void setprotoent(int);
void endprotoent(void);
void setservent(int);
void endservent(void);
#endif
# if defined(__DECC) && defined(__DECC_VER) && (__DECC_VER >= 50200000) && !defined(Sock_size_t)
# define Sock_size_t unsigned int
# endif
#else
/* Pull in SOCKETSHR's header, and set up structures for
* gcc, whose basic header file set doesn't include the
* TCP/IP stuff.
*/
#ifdef __GNU_CC__
/* 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; /* 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 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 */
};
/*
* Socket address, internet style.
*/
struct sockaddr_in {
short sin_family;
unsigned short sin_port;
struct in_addr sin_addr;
char sin_zero[8];
};
struct timeval {
long tv_sec;
long tv_usec;
};
struct netent {
char *n_name;
char **n_aliases;
int n_addrtype;
long n_net;
};
/* Since socketshr.h won't declare function prototypes unless it thinks
* the system headers have already been included, we convince it that
* this is the case.
*/
#ifndef AF_INET
# define AF_INET 2
#endif
#ifndef IPPROTO_TCP
# define IPPROTO_TCP 6
#endif
#ifndef __INET_LOADED
# define __INET_LOADED
#endif
#ifndef __NETDB_LOADED
# define __NETDB_LOADED
#endif
/* Finally, we provide prototypes for routines not supported by SocketShr,
* so that the stubs in sockadapt.c won't cause complaints about
* undeclared routines.
*/
struct netent *getnetbyaddr( long net, int type);
struct netent *getnetbyname( char *name);
struct netent *getnetent();
void setnetent(int);
void endnetent();
#else /* !__GNU_CC__ */
/* DECC and VAXC have socket headers in the system set; they're for UCX, but
* we'll assume that the actual calling sequence is identical across the
* various TCP/IP stacks; these routines are pretty standard.
*/
#include <socket.h>
#include <in.h>
#include <inet.h>
/* SocketShr doesn't support these routines, but the DECC RTL contains
* stubs with these names, designed to be used with the UCX socket
* library. We avoid linker collisions by substituting new names.
*/
#define getnetbyaddr no_getnetbyaddr
#define getnetbyname no_getnetbyname
#define getnetent no_getnetent
#define setnetent no_setnetent
#define endnetent no_endnetent
#include <netdb.h>
#endif
/* We don't have these two in the system headers. */
void setnetent(int);
void endnetent();
#include <socketshr.h>
/* socketshr.h from SocketShr 0.9D doesn't alias fileno; its comments say
* that the CRTL version works OK. This isn't the case, at least with
* VAXC, so we use the SocketShr version.
* N.B. This means that sockadapt.h must be included *after* stdio.h.
* This is presently the case for Perl.
*/
#ifdef fileno
# undef fileno
#endif
#define fileno si_fileno
int si_fileno(FILE *);
/* Catch erroneous results for UDP sockets -- see sockadapt.c */
#ifdef getpeername
# undef getpeername
#endif
#define getpeername my_getpeername
int my_getpeername (int, struct sockaddr *, int *);
#endif /* SOCKETSHR stuff */
#endif /* include guard */
--- NEW FILE: myconfig.com ---
$! #!/bin/sh ---> MYCONFIG.COM
$! # This script is designed to provide a handy summary of the configuration
$! # information being used to build perl. This is especially useful if you
$! # are requesting help from comp.lang.perl.misc on usenet or via mail.
$! DCL-ified by Peter Prymmer <pvhp at lns62.lns.cornell.edu> 22-DEC-1995
$! DCL usage (choose one):
$! @MYCONFIG !or
$! @MYCONFIG/OUTPUT=MYCONFIG.OUT !or
$! @MYCONFIG [node::][which$disk:][[dir.subdir]]CONFIG.SH !or
$! @MYCONFIG/OUTPUT=MYCONFIG.OUT [node::][w$disk:][[dir]]CONFIG.SH
$! version 2:
$! Incorporates Charles Bailey's ideas about bootstrapping system info -
$! myconfig.com is now callable as a "myconfig" target in your maker and
$! may even work if miniperl.exe and config.sh files fail to be made.
$! Thus if:
$! MMK/DESCRIP=[.VMS] !(or MMS or MAKE)
$! does not work then try:
$! MMK/DESCRIP=[.VMS]/OUTPUT=MYPERLBUILD.PROBLEM !(or MMS or MAKE)
$! Then discuss the MYPERLBUILD.PROBLEM file with a local expert.
$! If that still does not work then try:
$! MMK/DESCRIP=[.VMS]/OUT=MYNONFIG.OUT MYCONFIG !(or MMS or MAKE)
$! send output (MYNONFIG.OUT) to an outside expert and ask politely for help.
$ ECHO = "WRITE SYS$OUTPUT "
$ RATHER_LONG_DEFAULT_DIRECTORY_NAME = F$ENVIRONMENT("DEFAULT")
$ if (p1.nes."").and.(p2.eqs."")
$ then RATHER_LONG_FILENAME_TO_FIND = p1 !no typo-checking (experts only)
$ else RATHER_LONG_FILENAME_TO_FIND = "CONFIG.SH"
$ endif
$Research:
$ RATHER_LONG_FILENAME_SEARCH = F$Search(RATHER_LONG_FILENAME_TO_FIND)
$ if RATHER_LONG_FILENAME_SEARCH.EQS.""
$ then
$ if f$parse(f$environment("DEFAULT"),,,"DIRECTORY",).NES."[000000]"
$ then
$ set default [-]
$ goto Research
$ else
$ ECHO "Can't find the perl config.sh file produced by Configure"
$ set default 'RATHER_LONG_DEFAULT_DIRECTORY_NAME'
$! exit 3
$ goto cannot_find_config_sh
$ endif
$ endif
$ open/read RATHER_LONG_CONFIG_FILE_HANDLE 'RATHER_LONG_FILENAME_SEARCH'
$Loop:
$ read/end_of_file = Done RATHER_LONG_CONFIG_FILE_HANDLE line
$ name = f$extract(0,f$locate("=",line),line)
$ start = f$locate("'",line)+1
$ stop = f$locate("'",line)
$ value = f$extract(start,stop-start,line)
$ if (f$locate("#",name).eqs.f$length(name)).and. -
(name.nes."").and. -
(name.nes."'") - !bug in genconfig.pl (vms) for osvers='' ?
then $$'name' = "'" + value !$ not necessary but looks more sh-ish
$ goto Loop
$Done:
$ close RATHER_LONG_CONFIG_FILE_HANDLE
$ goto spit_it_out
$cannot_find_config_sh:
$! these parameters are assumed to be passed from make/mm[s|k]:
$! p1=$(CC), p2=$(CFLAGS), p3=$(LINKFLAGS),
$! p4=$(LIBS1), p5=$(LIBS2), p6=$(SOCKLIB),
$! p7=$(EXT), p8=$(DBG)
$! so assign to appropriate $var:
$ $cc = "'"+p1+"'" ! p1=$(CC) from make
$ $ccflags = "'"+p2+"'" ! p2=$(CFLAGS) from make
$ $ldflags = "'"+p3+"'" ! p3=$(LINKFLAGS) from make
$ $libs = "'"+p4+" "+p5+" "+p6+"'" ! p4$(LIBS1),p5$(LIBS2),p6$(SOCKLIB)frm make
$ $staticexts = "'"+p7+"'" ! p7=$(EXT) from make
$! hard-coded stuff (for now):
$ $cppflags = "'"+"'" !(vestigal)
$ $optimize = "'"+"'" !descrip.mms has /Optimize=2 in $(XTRACCFLAGS)
$! following assigns done via `dcl` calls in genconfig.pl anyway:
$ $osname = "'"+f$edit(f$getsyi("NODE_SWTYPE"),"COLLAPSE") !genconfig.pl has "osname='VMS'"
$ $osvers = f$edit(f$getsyi("VERSION")-"V","COLLAPSE")
$ if f$getsyi("HW_MODEL").GT.1024
$ then $$archname = "'VMS_AXP'" !string from descrip.mms vmsperl 12-21-95
$ else $$archname = "'VMS_VAX'" !string from descrip.mms vmsperl 12-21-95
$ endif
$ $myname = ""
$ if $myname.eqs."" then $$myname = f$trnlnm("ARPANET_HOST_NAME")
$ if $myname.eqs."" then $$myname = f$trnlnm("INTERNET_HOST_NAME")
$ if $myname.eqs."" then $$myname = f$trnlnm("MULTINET_HOST_NAME")
$ if $myname.eqs."" then $$myname = f$trnlnm("UCX$INET_HOST_NAME")
$ if $myname.eqs."" then $$myname = f$trnlnm("TCPWARE_DOMAINNAME")
$ if $myname.eqs."" then $$myname = f$trnlnm("NEWS_ADDRESS")
$ if $myname.eqs."" then $$myname = f$trnlnm("SYS$NODE")
$! Is this same as genconfig.pl ? (spacing/order unknown):
$ $myuname=$osname+" "+$myname+" "+$osvers+" "+F$GetSyi("HW_NAME")+"'"
$ $osname = $osname+"'"
$ $osvers = "'"+$osvers+"'"
$look_for_patchlevel_h:
$!
$ RATHER_LONG_FILENAME_TO_FIND = "PATCHLEVEL.H"
$Research_patchlevel_h:
$ RATHER_LONG_FILENAME_SEARCH = F$Search(RATHER_LONG_FILENAME_TO_FIND)
$ if RATHER_LONG_FILENAME_SEARCH.EQS.""
$ then
$ if f$parse(f$environment("DEFAULT"),,,"DIRECTORY",).NES."[000000]"
$ then
$ set default [-]
$ goto Research_patchlevel_h
$ else
$ ECHO "Can't find the header file patchlevel.h used to make config.sh"
$ set default 'RATHER_LONG_DEFAULT_DIRECTORY_NAME'
$ goto look_for_genconfig.pl
$ endif
$ endif
$ open/read RATHER_LONG_CONFIG_FILE_HANDLE 'RATHER_LONG_FILENAME_SEARCH'
$read_patchlevel_h:
$ read/end_of_file = patchlevel_h_Done RATHER_LONG_CONFIG_FILE_HANDLE line
$ if f$locate("PERL_VERSION",line).ne.f$length(line)
$ then
$ line = f$edit(line,"TRIM,COMPRESS")
$ $PATCHLEVEL = f$element(2," ",line)
$ if f$type($SUBVERSION).nes."" then goto patchlevel_h_Done
$ endif
$ if f$locate("PERL_SUBVERSION",line).ne.f$length(line)
$ then
$ line = f$edit(line,"TRIM,COMPRESS")
$ $SUBVERSION = f$element(2," ",line)
$ if f$type($PATCHLEVEL).nes."" then goto patchlevel_h_Done
$ endif
$ goto read_patchlevel_h
$patchlevel_h_Done:
$ close RATHER_LONG_CONFIG_FILE_HANDLE
$ if $PATCHLEVEL.eqs.""
$ then
$ echo "warning: PERL_VERSION was not found in ''RATHER_LONG_FILENAME_TO_FIND':"
$ endif
$look_for_genconfig_pl:
$!
$ if f$search("VMS.DIR").nes."" then set default [.vms]
$ RATHER_LONG_FILENAME_TO_FIND = "GENCONFIG.PL"
$ genconfig_pl_dir = ""
$Research_genconfig_pl:
$ RATHER_LONG_FILENAME_SEARCH = F$Search(RATHER_LONG_FILENAME_TO_FIND)
$ if RATHER_LONG_FILENAME_SEARCH.EQS.""
$ then
$ if f$parse(f$environment("DEFAULT"),,,"DIRECTORY",).NES."[000000]"
$ then
$ set default [-]
$ goto Research_genconfig_pl
$ else
$ ECHO "Can't find the perl genconfig.pl used to make config.sh"
$ set default 'RATHER_LONG_DEFAULT_DIRECTORY_NAME'
$ goto look_for_config_vms
$ endif
$ else !genconfig.pl has been found
$ genconfig_pl_dir = f$parse(f$environment("DEFAULT"),,,"DIRECTORY",)
$ endif
$ cnfg_keys = "package/hintfile/ld/dlext/d_stdstdio/"
$ cnfg_keys = cnfg_keys + "usevfork/usemymalloc/so/libpth/"
$ cnfg_keys = cnfg_keys + "dlsrc/cccdlflags/ccdlflags/lddlflags/"
$ cnfg_vars = "$package/$hint/$ld/$dlext/$d_stdstdio/"
$ cnfg_vars = cnfg_vars + "$usevfork/$usemymalloc/$so/$libpth/"
$ cnfg_vars = cnfg_vars + "$dlsrc/$cccdlflags/$ccdlflags/$lddlflags/"
$ open/read RATHER_LONG_CONFIG_FILE_HANDLE 'RATHER_LONG_FILENAME_SEARCH'
$read_genconfig_pl:
$ read/end_of_file = Genconfig_pl_Done RATHER_LONG_CONFIG_FILE_HANDLE line
$ if f$locate("=",line).ne.f$length(line) !then may be an assigment
$ then
$ name = f$edit( f$extract(0,f$locate("=",line),line), "COLLAPSE")
$ num = 0
$key_genconfig_pl:
$ key = f$element(num,"/",cnfg_keys)
$ if (key .nes. "/").and.(key .nes. "") !not end of cnfg_keys
$ then
$ if key.eqs.name !then is key
$ then
$ start = f$locate("=",line)+1
$ stop = f$length(line)
$ value = f$extract(start,stop-start,line)
$ var = f$element(num,"/",cnfg_vars)
$ 'var' = value
$ cnfg_keys = cnfg_keys - ("''name'/" ) !trim to shorten future matches
$ cnfg_vars = cnfg_vars - ("''var'/" ) !trim to shorten future matches
$ endif
$ num = num + 1
$ goto key_genconfig_pl
$ endif ! not end of cnfg_keys
$ endif ! then may be an assigment
$ goto read_genconfig_pl
$Genconfig_pl_Done:
$ close RATHER_LONG_CONFIG_FILE_HANDLE
$ if cnfg_vars.nes.""
$ then
$ echo "warning: the following variables were not found in ''RATHER_LONG_FILENAME_TO_FIND':"
$ echo "''cnfg_vars'"
$ endif
$ if (p8.nes."").and.($ld.nes."") then $ld = $ld + " DBG='"+p8+"'"
$look_for_config_vms:
$ RATHER_LONG_FILENAME_TO_FIND = "''genconfig_pl_dir'CONFIG.VMS"
$Research_config_vms:
$ RATHER_LONG_FILENAME_SEARCH = F$Search(RATHER_LONG_FILENAME_TO_FIND)
$ if RATHER_LONG_FILENAME_SEARCH.EQS.""
$ then
$ if f$parse(f$environment("DEFAULT"),,,"DIRECTORY",).NES."[000000]"
$ then
$ set default [-]
$ goto Research_config_vms
$ else
$ ECHO "Can't find the perl config.vms used to make config.sh"
$ set default 'RATHER_LONG_DEFAULT_DIRECTORY_NAME'
$ stop
$ exit 3
$ endif
$ endif
$ cnfg_keys = "MEM_ALIGNBYTES/CASTNEGFLOAT/CASTFLAGS/RANDBITS/STDCHAR/"
$ cnfg_keys = cnfg_keys+"CASTI32/INTSIZE/VOIDFLAGS/DLSYM_NEEDS_UNDERSCORE"
$ cnfg_vars = "$alignbytes/$d_castneg/$castflags/$randbits/$stdchar/"
$ cnfg_vars = cnfg_vars+"$d_casti32/$intsize/$voidflags/$d_dlsymun/"
$ open/read RATHER_LONG_CONFIG_FILE_HANDLE 'RATHER_LONG_FILENAME_SEARCH'
$read_config_vms:
$ read/end_of_file = config_vms_Done RATHER_LONG_CONFIG_FILE_HANDLE line
$! look for "#define" or "#undef"
$ if (f$length(line).ne.0).and.-
((f$locate("#define",line).eq.0).or.(f$locate("#undef",line).eq.0))
$ then
$ line = f$edit(line,"COMPRESS, TRIM")
$ name = f$element(1," ",line) !macro
$ num = 0
$key_config_vms:
$ key = f$element(num,"/",cnfg_keys)
$ if (key .nes. "/").and.(key .nes. "") !not end of cnfg_keys
$ then
$ if key.eqs.name !then is key
$ then
$ var = f$element(num,"/",cnfg_vars)
$ cnfg_keys = cnfg_keys - ("''name'/" ) !trim to shorten future matches
$ cnfg_vars = cnfg_vars - ("''var'/" ) !trim to shorten future matches
$ if (f$locate("#undef",line).eq.0)
$ then
$ 'var' = "'undef'"
$ else !is a #define
$strip_comment:
$ start = f$locate("/*",line)
$ if start.ne.f$length(line) !comment started
$ then
$ if f$locate("*/",line).ne.f$length(line) !comment stopped
$ then stop = f$locate("*/",line)+2
$ else stop = f$locate("*/",line)
$ endif
$ comment = f$extract(start,stop-start,line)
$ line = line - comment
$ goto strip_comment
$ endif
$ line = f$edit(line,"TRIM")
$ start = f$locate(key,line)+f$length(key)
$ stop = f$length(line)
$ value = f$edit(f$extract(start,stop-start,line),"TRIM")
$ if (value.nes."")
$ then
$ 'var' = "'"+value+"'"
$ else
$ 'var' = "'define'"
$ endif
$ endif !#define
$ endif ! is key of interest
$ num = num + 1
$ goto key_config_vms
$ endif ! not end of cnfg_keys
$ endif ! then may be #define or #undef of interest
$ goto read_config_vms
$config_vms_Done:
$ close RATHER_LONG_CONFIG_FILE_HANDLE
$ if cnfg_vars.nes.""
$ then
$ echo "warning: the following variables were not found in ''RATHER_LONG_FILENAME_TO_FIND':"
$ echo "''cnfg_vars'"
$ endif
$spit_it_out:
$! $spitshell = ECHO !<<!GROK!THIS!
$ ECHO " "
$ ECHO "Summary of my ''$package' (version ''$PATCHLEVEL' subversion ''$SUBVERSION') configuration:"
$ ECHO " Platform:"
$ ECHO " osname=''$osname', osvers=''$osvers', archname=''$archname'"
$ ECHO " uname=''$myuname'" !->d_has_uname?
$ ECHO " hint=''$hint' d_sigaction='undef'" !->hintfile?
$ ECHO " static exts=''$staticexts'" ! added for VMS
$ ECHO " Compiler:"
$ ECHO " cc=''$cc', optimize=''$optimize', ld=''$ld'"
$ ECHO " cppflags=''$cppflags'"
$ ECHO " ccflags =''$ccflags'" !->vms_cc_type?
$ ECHO " ldflags =''$ldflags'"
$ ECHO " stdchar=''$stdchar', d_stdstdio=''$d_stdstdio', usevfork=''$usevfork'"
$ ECHO " voidflags=''$voidflags', castflags=''$castflags', d_casti32=''$d_casti32', d_castneg=''$d_castneg'"
$ ECHO " intsize=''$intsize', alignbytes=''$alignbytes', usemymalloc=''$usemymalloc', randbits=''$randbits'"
$ ECHO " Libraries:"
$ ECHO " so=''$so'"
$ ECHO " libpth=''$libpth'"
$ ECHO " libs=''$libs'"
$ ECHO " libc=''$libc'"
$ ECHO " Dynamic Linking:"
$ ECHO " dlsrc=''$dlsrc', dlext=''$dlext', d_dlsymun=''$d_dlsymun'"
$ ECHO " cccdlflags=''$cccdlflags', ccdlflags=''$ccdlflags', lddlflags=''$lddlflags'"
$ ECHO " "
$ !GROK!THIS!
$ SET DEFAULT 'RATHER_LONG_DEFAULT_DIRECTORY_NAME'
$ EXIT
--- NEW FILE: vmsish.h ---
/* vmsish.h
*
* VMS-specific C header file for perl5.
*
* Last revised: 16-Sep-1998 by Charles Bailey bailey at newman.upenn.edu
* Version: 5.5.2
*/
#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 */
#include <stsdef.h> /* bitmasks for exit status testing */
/* Suppress compiler warnings from DECC for VMS-specific extensions:
* ADDRCONSTEXT,NEEDCONSTEXT: initialization of data with non-constant values
* (e.g. pointer fields of descriptors)
*/
#if defined(__DECC) || defined(__DECCXX)
# pragma message disable (ADDRCONSTEXT,NEEDCONSTEXT)
#endif
/* 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)
/* DECC 1.3 has a funny definition of abs; it's fixed in DECC 4.0, so this
* can go away once DECC 1.3 isn't in use any more. */
#if defined(__ALPHA) && (defined(__DECC) || defined(__DECCXX))
#undef abs
#define abs(__x) __ABS(__x)
#undef labs
#define labs(__x) __LABS(__x)
#endif /* __ALPHA && __DECC */
/* Assorted things to look like Unix */
#ifdef __GNUC__
#ifndef _IOLBF /* gcc's stdio.h doesn't define this */
#define _IOLBF 1
#endif
#endif
#include <processes.h> /* for vfork() */
#include <unixio.h>
#include <unixlib.h>
#include <file.h> /* it's not <sys/file.h>, so don't use I_SYS_FILE */
#if (defined(__DECC) && defined(__DECC_VER) && __DECC_VER > 20000000) || defined(__DECCXX)
# include <unistd.h> /* DECC has this; gcc doesn't */
#endif
#ifdef NO_PERL_TYPEDEFS /* a2p; we don't want Perl's special routines */
# define DONT_MASK_RTL_CALLS
#endif
/* Note that we do, in fact, have this */
#define HAS_GETENV_SV
#define HAS_GETENV_LEN
/* All this stiff is for the x2P programs. Hopefully they'll still work */
#if defined(PERL_FOR_X2P)
#ifndef aTHX_
#define aTHX_
#endif
#ifndef pTHX_
#define pTHX_
#endif
#ifndef pTHX
#define pTHX
#endif
#endif
#ifndef DONT_MASK_RTL_CALLS
# ifdef getenv
# undef getenv
# endif
/* getenv used for regular logical names */
# define getenv(v) Perl_my_getenv(aTHX_ v,TRUE)
#endif
#ifdef getenv_len
# undef getenv_len
#endif
#define getenv_len(v,l) Perl_my_getenv_len(aTHX_ v,l,TRUE)
/* DECC introduces this routine in the RTL as of VMS 7.0; for now,
* we'll use ours, since it gives us the full VMS exit status. */
#define waitpid my_waitpid
/* Don't redeclare standard RTL routines in Perl's header files;
* VMS history or extensions makes some of the formal protoypes
* differ from the common Unix forms.
*/
#define DONT_DECLARE_STD 1
/* Our own contribution to PerlShr's global symbols . . . */
#define prime_env_iter Perl_prime_env_iter
#define vms_image_init Perl_vms_image_init
#define my_tmpfile Perl_my_tmpfile
#define vmstrnenv Perl_vmstrnenv
#if !defined(PERL_IMPLICIT_CONTEXT)
#define my_getenv_len Perl_my_getenv_len
#define vmssetenv Perl_vmssetenv
#define my_trnlnm Perl_my_trnlnm
#define my_setenv Perl_my_setenv
#define my_getenv Perl_my_getenv
#define tounixspec Perl_tounixspec
#define tounixspec_ts Perl_tounixspec_ts
#define tovmsspec Perl_tovmsspec
#define tovmsspec_ts Perl_tovmsspec_ts
#define tounixpath Perl_tounixpath
#define tounixpath_ts Perl_tounixpath_ts
#define tovmspath Perl_tovmspath
#define tovmspath_ts Perl_tovmspath_ts
#define do_rmdir Perl_do_rmdir
#define fileify_dirspec Perl_fileify_dirspec
#define fileify_dirspec_ts Perl_fileify_dirspec_ts
#define pathify_dirspec Perl_pathify_dirspec
#define pathify_dirspec_ts Perl_pathify_dirspec_ts
#define trim_unixpath Perl_trim_unixpath
#define opendir Perl_opendir
#define rmscopy Perl_rmscopy
#define my_mkdir Perl_my_mkdir
#define vms_do_aexec Perl_vms_do_aexec
#define vms_do_exec Perl_vms_do_exec
#define my_waitpid Perl_my_waitpid
#define my_crypt Perl_my_crypt
#define kill_file Perl_kill_file
#define my_utime Perl_my_utime
#define my_chdir Perl_my_chdir
#define do_aspawn Perl_do_aspawn
#define seekdir Perl_seekdir
#define my_gmtime Perl_my_gmtime
#define my_localtime Perl_my_localtime
#define my_time Perl_my_time
#define do_spawn Perl_do_spawn
#define flex_fstat Perl_flex_fstat
#define flex_stat Perl_flex_stat
#define cando_by_name Perl_cando_by_name
#define my_getpwnam Perl_my_getpwnam
#define my_getpwuid Perl_my_getpwuid
#define my_flush Perl_my_flush
#define readdir Perl_readdir
#define readdir_r Perl_readdir_r
#else
#define my_getenv_len(a,b,c) Perl_my_getenv_len(aTHX_ a,b,c)
#define vmssetenv(a,b,c) Perl_vmssetenv(aTHX_ a,b,c)
#define my_trnlnm(a,b,c) Perl_my_trnlnm(aTHX_ a,b,c)
#define my_setenv(a,b) Perl_my_setenv(aTHX_ a,b)
#define my_getenv(a,b) Perl_my_getenv(aTHX_ a,b)
#define tounixspec(a,b) Perl_tounixspec(aTHX_ a,b)
#define tounixspec_ts(a,b) Perl_tounixspec_ts(aTHX_ a,b)
#define tovmsspec(a,b) Perl_tovmsspec(aTHX_ a,b)
#define tovmsspec_t(a,b) Perl_tovmsspec_ts(aTHX_ a,b)
#define tounixpath(a,b) Perl_tounixpath(aTHX_ a,b)
#define tounixpath_ts(a,b) Perl_tounixpath_ts(aTHX_ a,b)
#define tovmspath(a,b) Perl_tovmspath(aTHX_ a,b)
#define tovmspath_ts(a,b) Perl_tovmspath_ts(aTHX_ a,b)
#define do_rmdir(a) Perl_do_rmdir(aTHX_ a)
#define fileify_dirspec(a,b) Perl_fileify_dirspec(aTHX_ a,b)
#define fileify_dirspec_ts(a,b) Perl_fileify_dirspec_ts(aTHX_ a,b)
#define pathify_dirspec Perl_pathify_dirspec
#define pathify_dirspec_ts Perl_pathify_dirspec_ts
#define rmsexpand(a,b,c,d) Perl_rmsexpand(aTHX_ a,b,c,d)
#define rmsexpand_ts(a,b,c,d) Perl_rmsexpand_ts(aTHX_ a,b,c,d)
#define trim_unixpath(a,b,c) Perl_trim_unixpath(aTHX_ a,b,c)
#define opendir(a) Perl_opendir(aTHX_ a)
#define rmscopy(a,b,c) Perl_rmscopy(aTHX_ a,b,c)
#define my_mkdir(a,b) Perl_my_mkdir(aTHX_ a,b)
#define vms_do_aexec(a,b,c) Perl_vms_do_aexec(aTHX_ a,b,c)
#define vms_do_exec(a) Perl_vms_do_exec(aTHX_ a)
#define my_waitpid(a,b,c) Perl_my_waitpid(aTHX_ a,b,c)
#define my_crypt(a,b) Perl_my_crypt(aTHX_ a,b)
#define kill_file(a) Perl_kill_file(aTHX_ a)
#define my_utime(a,b) Perl_my_utime(aTHX_ a,b)
#define my_chdir(a) Perl_my_chdir(aTHX_ a)
#define do_aspawn(a,b,c) Perl_do_aspawn(aTHX_ a,b,c)
#define seekdir(a,b) Perl_seekdir(aTHX_ a,b)
#define my_gmtime(a) Perl_my_gmtime(aTHX_ a)
#define my_localtime(a) Perl_my_localtime(aTHX_ a)
#define my_time(a) Perl_my_time(aTHX_ a)
#define do_spawn(a) Perl_do_spawn(aTHX_ a)
#define flex_fstat(a,b) Perl_flex_fstat(aTHX_ a,b)
#define cando_by_name(a,b,c) Perl_cando_by_name(aTHX_ a,b,c)
#define flex_stat(a,b) Perl_flex_stat(aTHX_ a,b)
#define my_getpwnam(a) Perl_my_getpwnam(aTHX_ a)
#define my_getpwuid(a) Perl_my_getpwuid(aTHX_ a)
#define my_flush(a) Perl_my_flush(aTHX_ a)
#define readdir(a) Perl_readdir(aTHX_ a)
#define readdir_r(a,b,c) Perl_readdir_r(aTHX_ a,b,c)
#endif
#define my_gconvert Perl_my_gconvert
#define telldir Perl_telldir
#define closedir Perl_closedir
#define vmsreaddirversions Perl_vmsreaddirversions
#define my_sigemptyset Perl_my_sigemptyset
#define my_sigfillset Perl_my_sigfillset
#define my_sigaddset Perl_my_sigaddset
#define my_sigdelset Perl_my_sigdelset
#define my_sigismember Perl_my_sigismember
#define my_sigprocmask Perl_my_sigprocmask
#define my_vfork Perl_my_vfork
#define my_fdopen Perl_my_fdopen
#define my_fclose Perl_my_fclose
#define my_fwrite Perl_my_fwrite
#define my_getpwent() Perl_my_getpwent(aTHX)
#define my_endpwent() Perl_my_endpwent(aTHX)
#define my_getlogin Perl_my_getlogin
#define init_os_extras Perl_init_os_extras
/* Delete if at all possible, changing protections if necessary. */
#define unlink kill_file
/*
* Intercept calls to fork, so we know whether subsequent calls to
* exec should be handled in VMSish or Unixish style.
*/
#define fork my_vfork
#ifndef DONT_MASK_RTL_CALLS /* #defined in vms.c so we see real vfork */
# ifdef vfork
# undef vfork
# endif
# define vfork my_vfork
#endif
/*
* Toss in a shim to tmpfile which creates a plain temp file if the
* RMS tmp mechanism won't work (e.g. if someone is relying on ACLs
* from a specific directory to permit creation of files).
*/
#ifndef DONT_MASK_RTL_CALLS
# define tmpfile Perl_my_tmpfile
#endif
/* BIG_TIME:
* This symbol is defined if Time_t is an unsigned type on this system.
*/
#define BIG_TIME
/* ACME_MESS:
* This symbol, if defined, indicates that error messages should be
* should be generated in a format that allows the use of the Acme
* GUI/editor's autofind feature.
*/
#undef ACME_MESS /**/
/* ALTERNATE_SHEBANG:
* This symbol, if defined, contains a "magic" string which may be used
* as the first line of a Perl program designed to be executed directly
* by name, instead of the standard Unix #!. If ALTERNATE_SHEBANG
* begins with a character other then #, then Perl will only treat
* it as a command line if if finds the string "perl" in the first
* word; otherwise it's treated as the first line of code in the script.
* (IOW, Perl won't hand off to another interpreter via an alternate
* shebang sequence that might be legal Perl code.)
*/
#define ALTERNATE_SHEBANG "$"
/* Lower case entry points for these are missing in some earlier RTLs
* so we borrow the defines and declares from errno.h and upcase them.
*/
#if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 50500000)
# define errno (*CMA$TIS_ERRNO_GET_ADDR())
# define vaxc$errno (*CMA$TIS_VMSERRNO_GET_ADDR())
int *CMA$TIS_ERRNO_GET_ADDR (void); /* UNIX style error code */
int *CMA$TIS_VMSERRNO_GET_ADDR (void); /* VMS error (errno == EVMSERR) */
#endif
/* 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))
void cma$tis_errno_set_value(int __value); /* missing in some errno.h */
# define set_vaxc_errno(v) (vaxc$errno = (v))
#else
# define set_errno(v) (errno = (v))
# define set_vaxc_errno(v) (vaxc$errno = (v))
#endif
/* Support for 'vmsish' behaviors enabled with C<use vmsish> pragma */
#define COMPLEX_STATUS 1 /* We track both "POSIX" and VMS values */
#define HINT_V_VMSISH 24
#define HINT_M_VMSISH_STATUS 0x40000000 /* system, $? return VMS status */
#define HINT_M_VMSISH_TIME 0x80000000 /* times are local, not UTC */
#define NATIVE_HINTS (PL_hints >> HINT_V_VMSISH) /* used in op.c */
#define TEST_VMSISH(h) (PL_curcop->op_private & ((h) >> HINT_V_VMSISH))
#define VMSISH_STATUS TEST_VMSISH(HINT_M_VMSISH_STATUS)
#define VMSISH_TIME TEST_VMSISH(HINT_M_VMSISH_TIME)
/* VMS-specific data storage */
#define HAVE_INTERP_INTERN
struct interp_intern {
int hushed;
double inv_rand_max;
};
#define VMSISH_HUSHED (PL_sys_intern.hushed)
#define MY_INV_RAND_MAX (PL_sys_intern.inv_rand_max)
/* Flags for vmstrnenv() */
#define PERL__TRNENV_SECURE 0x01
#define PERL__TRNENV_JOIN_SEARCHLIST 0x02
/* Handy way to vet calls to VMS system services and RTL routines. */
#define _ckvmssts(call) STMT_START { register unsigned long int __ckvms_sts; \
if (!((__ckvms_sts=(call))&1)) { \
set_errno(EVMSERR); set_vaxc_errno(__ckvms_sts); \
Perl_croak(aTHX_ "Fatal VMS error (status=%d) at %s, line %d", \
__ckvms_sts,__FILE__,__LINE__); } } STMT_END
/* Same thing, but don't call back to Perl's croak(); useful for errors
* occurring during startup, before Perl's state is initialized */
#define _ckvmssts_noperl(call) STMT_START { register unsigned long int __ckvms_sts; \
if (!((__ckvms_sts=(call))&1)) { \
set_errno(EVMSERR); set_vaxc_errno(__ckvms_sts); \
fprintf(stderr,"Fatal VMS error (status=%d) at %s, line %d", \
__ckvms_sts,__FILE__,__LINE__); lib$signal(__ckvms_sts); } } STMT_END
#ifdef VMS_DO_SOCKETS
#include "sockadapt.h"
#define PERL_SOCK_SYSREAD_IS_RECV
#define PERL_SOCK_SYSWRITE_IS_SEND
#endif
#define BIT_BUCKET "_NLA0:"
#define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v) vms_image_init((c),(v)); MALLOC_INIT
#define PERL_SYS_TERM() OP_REFCNT_TERM; MALLOC_TERM
#define dXSUB_SYS
#define HAS_KILL
#define HAS_WAIT
#define PERL_FS_VER_FMT "%d_%d_%d"
/* Temporary; we need to add support for this to Configure.Com */
#ifdef PERL_INC_VERSION_LIST
# undef PERL_INC_VERSION_LIST
#endif
/* VMS:
* This symbol, if defined, indicates that the program is running under
* VMS. It's a symbol automagically defined by all VMS C compilers I've seen.
* Just in case, however . . . */
#ifndef VMS
#define VMS /**/
#endif
/* HAS_IOCTL:
* This symbol, if defined, indicates that the ioctl() routine is
* available to set I/O characteristics
*/
#if defined(__CRTL_VER) && __CRTL_VER >= 70000000
#define HAS_IOCTL /**/
#else
#undef HAS_IOCTL /**/
#endif
/* HAS_UTIME:
* This symbol, if defined, indicates that the routine utime() is
* available to update the access and modification times of files.
*/
#define HAS_UTIME /**/
/* HAS_GROUP
* This symbol, if defined, indicates that the getgrnam() and
* getgrgid() routines are available to get group entries.
* The getgrent() has a separate definition, HAS_GETGRENT.
*/
#undef HAS_GROUP /**/
/* HAS_PASSWD
* This symbol, if defined, indicates that the getpwnam() and
* getpwuid() routines are available to get password entries.
* The getpwent() has a separate definition, HAS_GETPWENT.
*/
#define HAS_PASSWD /**/
#define HAS_KILL
#define HAS_WAIT
/* USEMYBINMODE
* This symbol, if defined, indicates that the program should
* use the routine my_binmode(FILE *fp, char iotype, int mode) to insure
* that a file is in "binary" mode -- that is, that no translation
* of bytes occurs on read or write operations.
*/
#undef USEMYBINMODE
/* Stat_t:
* This symbol holds the type used to declare buffers for information
* returned by stat(). It's usually just struct stat. It may be necessary
* to include <sys/stat.h> and <sys/types.h> to get any typedef'ed
* information.
*/
/* VMS:
* We need this typedef to point to the new type even if DONT_MASK_RTL_CALLS
* is in effect, since Perl's thread.h embeds one of these structs in its
* thread data struct, and our struct mystat is a different size from the
* regular struct stat (cf. note above about having to pad struct to work
* around bug in compiler.)
* It's OK to pass one of these to the RTL's stat(), though, since the
* fields it fills are the same in each struct.
*/
#define Stat_t struct mystat
/* USE_STAT_RDEV:
* This symbol is defined if this system has a stat structure declaring
* st_rdev
* VMS: Field exists in POSIXish version of struct stat(), but is not used.
*/
#undef USE_STAT_RDEV /**/
/*
* fwrite1() should be a routine with the same calling sequence as fwrite(),
* but which outputs all of the bytes requested as a single stream (unlike
* fwrite() itself, which on some systems outputs several distinct records
* if the number_of_items parameter is >1).
*/
#define fwrite1 my_fwrite
#ifndef DONT_MASK_RTL_CALLS
# define fwrite my_fwrite /* for PerlSIO_fwrite */
# define fdopen my_fdopen
# define fclose my_fclose
#endif
/* By default, flush data all the way to disk, not just to RMS buffers */
#define Fflush(fp) my_flush(fp)
/* Use our own rmdir() */
#define rmdir(name) do_rmdir(name)
/* Assorted fiddling with sigs . . . */
# 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
* prior to v7.0. We check the DECC manifest to see whether it's already
* done this for us, relying on the fact that perl.h #includes <time.h>
* before it #includes "vmsish.h".
*/
#ifndef __TMS
struct tms {
clock_t tms_utime; /* user time */
clock_t tms_stime; /* system time - always 0 on VMS */
clock_t tms_cutime; /* user time, children */
clock_t tms_cstime; /* system time, children - always 0 on VMS */
};
#else
/* The new headers change the times() prototype to tms from tbuffer */
# define tbuffer_t struct tms
#endif
/* Substitute our own routines for gmtime(), localtime(), and time(),
* which allow us to implement the vmsish 'time' pragma, and work
* around absence of system-level UTC support on old versions of VMS.
*/
#define gmtime(t) my_gmtime(t)
#define localtime(t) my_localtime(t)
#define time(t) my_time(t)
/* If we're using an older version of VMS whose Unix signal emulation
* isn't very POSIXish, then roll our own.
*/
#if __VMS_VER < 70000000 || __DECC_VER < 50200000
# define HOMEGROWN_POSIX_SIGNALS
#endif
#ifdef HOMEGROWN_POSIX_SIGNALS
# define sigemptyset(t) my_sigemptyset(t)
# define sigfillset(t) my_sigfillset(t)
# define sigaddset(t, u) my_sigaddset(t, u)
# define sigdelset(t, u) my_sigdelset(t, u)
# define sigismember(t, u) my_sigismember(t, u)
# define sigprocmask(t, u, v) my_sigprocmask(t, u, v)
# ifndef _SIGSET_T
typedef int sigset_t;
# endif
/* The tools for sigprocmask() are there, just not the routine itself */
# ifndef SIG_UNBLOCK
# define SIG_UNBLOCK 1
# endif
# ifndef SIG_BLOCK
# define SIG_BLOCK 2
# endif
# ifndef SIG_SETMASK
# define SIG_SETMASK 3
# endif
# define sigaction sigvec
# define sa_flags sv_onstack
# define sa_handler sv_handler
# define sa_mask sv_mask
# define sigsuspend(set) sigpause(*set)
# define sigpending(a) (not_here("sigpending"),0)
#else
/*
* The C RTL's sigaction fails to check for invalid signal numbers so we
* help it out a bit.
*/
# ifndef DONT_MASK_RTL_CALLS
# define sigaction(a,b,c) Perl_my_sigaction(aTHX_ a,b,c)
# endif
#endif
#ifdef KILL_BY_SIGPRC
# define kill Perl_my_kill
#endif
/* VMS doesn't use a real sys_nerr, but we need this when scanning for error
* messages in text strings . . .
*/
#define sys_nerr EVMSERR /* EVMSERR is as high as we can go. */
/* Look up new %ENV values on the fly */
#define DYNAMIC_ENV_FETCH 1
/* Special getenv function for retrieving %ENV elements. */
#define ENVgetenv(v) my_getenv(v,FALSE)
#define ENVgetenv_len(v,l) my_getenv_len(v,l,FALSE)
/* Thin jacket around cuserid() to match Unix' calling sequence */
#define getlogin my_getlogin
/* Ditto for sys$hash_password() . . . */
#define crypt(a,b) Perl_my_crypt(aTHX_ a,b)
/* Tweak arg to mkdir & chdir first, so we can tolerate trailing /. */
#define Mkdir(dir,mode) Perl_my_mkdir(aTHX_ (dir),(mode))
#define Chdir(dir) my_chdir((dir))
/* Use our own stat() clones, which handle Unix-style directory names */
#define Stat(name,bufptr) flex_stat(name,bufptr)
#define Fstat(fd,bufptr) Perl_flex_fstat(aTHX_ fd,bufptr)
/* Setup for the dirent routines:
* opendir(), closedir(), readdir(), seekdir(), telldir(), and
* vmsreaddirversions(), and preprocessor stuff on which these depend:
* Written by Rich $alz, <rsalz at bbn.com> in August, 1990.
*/
/* Data structure returned by READDIR(). */
struct dirent {
char d_name[256]; /* File name */
int d_namlen; /* Length of d_name */
int vms_verscount; /* Number of versions */
int vms_versions[20]; /* Version numbers */
};
/* Handle returned by opendir(), used by the other routines. You
* are not supposed to care what's inside this structure. */
typedef struct _dirdesc {
long context;
int vms_wantversions;
unsigned long int count;
char *pattern;
struct dirent entry;
struct dsc$descriptor_s pat;
void *mutex;
} DIR;
#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.
* N.B. 1. The st_ino hack assumes that sizeof(unsigned short[3]) ==
* sizeof(unsigned) + sizeof(unsigned short). We can't use a union type
* to map the unsigned int we want and the unsigned short[3] the CRTL
* returns into the same member, since gcc has different ideas than DECC
* and VAXC about sizing union types.
* N.B. 2. The routine cando() in vms.c assumes that &stat.st_ino is the
* address of a FID.
*/
/* 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.
*/
#ifdef USE_LARGE_FILES
/* Mimic the new stat structure, filler fields, and alignment. */
#if defined(__DECC) || defined(__DECCXX)
# pragma __member_alignment __save
# pragma member_alignment
#endif
struct mystat
{
char *st_devnam; /* pointer to device name */
char *st_fill_dev;
unsigned st_ino; /* hack - CRTL uses unsigned short[3] for */
unsigned short rvn; /* FID (num,seq,rvn) */
unsigned short st_fill_ino;
unsigned short st_mode; /* file "mode" i.e. prot, dir, reg, etc. */
unsigned short st_fill_mode;
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 */
unsigned short st_fill_gid;
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_fill_atime;
unsigned st_mtime; /* last modification time */
unsigned st_fill_mtime;
unsigned st_ctime; /* file creation time */
unsigned st_fill_ctime;
char st_fab_rfm; /* record format */
char st_fab_rat; /* record attributes */
char st_fab_fsz; /* fixed header size */
char st_fab_fill;
unsigned st_fab_mrs; /* record size */
int st_fill_expand[7]; /* will probably fill from beginning, so put our st_dev at end */
unsigned st_dev; /* encoded device name */
};
#else /* !defined(USE_LARGE_FILES) */
#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 */
unsigned st_ino; /* hack - CRTL uses unsigned short[3] for */
unsigned short rvn; /* FID (num,seq,rvn) */
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 */
/* Pad struct out to integral number of longwords, since DECC 5.6/VAX
* has a bug in dealing with offsets in structs in which are embedded
* other structs whose size is an odd number of bytes. (An even
* number of bytes is enough to make it happy, but we go for natural
* alignment anyhow.)
*/
char st_fill1[sizeof(void *) - (3*sizeof(unsigned short) + 3*sizeof(char))%sizeof(void *)];
};
#if defined(__DECC)
# pragma __message __restore
#endif
#endif /* defined(USE_LARGE_FILES) */
#if defined(__DECC) || defined(__DECCXX)
# pragma __member_alignment __restore
#endif
typedef unsigned mydev_t;
typedef unsigned myino_t;
/*
* DEC C previous to 6.0 corrupts the behavior of the /prefix
* qualifier with the extern prefix pragma. This provisional
* hack circumvents this prefix pragma problem in previous
* precompilers.
*/
#if defined(__VMS_VER) && __VMS_VER >= 70000000
# if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
# pragma __extern_prefix save
# pragma __extern_prefix "" /* set to empty to prevent prefixing */
# define geteuid decc$__unix_geteuid
# define getuid decc$__unix_getuid
# define stat(__p1,__p2) decc$__utc_stat(__p1,__p2)
# define fstat(__p1,__p2) decc$__utc_fstat(__p1,__p2)
# pragma __extern_prefix restore
# endif
#endif
#ifndef DONT_MASK_RTL_CALLS /* defined for vms.c so we can see RTL calls */
# ifdef stat
# undef stat
# endif
# define stat mystat
# define dev_t mydev_t
# define ino_t myino_t
#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;
* their prototypes are already in proto.h.
*
* In order to keep Gen_ShrFls.Pl happy, functions which are to be made
* available to images linked to PerlShr.Exe must be declared between the
* __VMS_PROTOTYPES__ and __VMS_SEPYTOTORP__ lines, and must be in the form
* <data type><TAB>name<WHITESPACE>(<prototype args>);
*/
#ifdef NO_PERL_TYPEDEFS
/* We don't have Perl typedefs available (e.g. when building a2p), so
we fake them here. N.B. There is *no* guarantee that the faked
prototypes will actually match the real routines. If you want to
call Perl routines, include perl.h to get the real typedefs. */
# ifndef bool
# define bool int
# define __MY_BOOL_TYPE_FAKE
# endif
# ifndef I32
# define I32 int
# define __MY_I32_TYPE_FAKE
# endif
# ifndef SV
# define SV void /* Since we only see SV * in prototypes */
# define __MY_SV_TYPE_FAKE
# endif
#endif
void prime_env_iter (void);
void init_os_extras ();
/* prototype section start marker; `typedef' passes through cpp */
typedef char __VMS_PROTOTYPES__;
int Perl_vmstrnenv (const char *, char *, unsigned long int, struct dsc$descriptor_s **, unsigned long int);
#if !defined(PERL_IMPLICIT_CONTEXT)
char * Perl_my_getenv (const char *, bool);
int Perl_my_trnlnm (const char *, char *, unsigned long int);
char * Perl_tounixspec (char *, char *);
char * Perl_tounixspec_ts (char *, char *);
char * Perl_tovmsspec (char *, char *);
char * Perl_tovmsspec_ts (char *, char *);
char * Perl_tounixpath (char *, char *);
char * Perl_tounixpath_ts (char *, char *);
char * Perl_tovmspath (char *, char *);
char * Perl_tovmspath_ts (char *, char *);
int Perl_do_rmdir (char *);
char * Perl_fileify_dirspec (char *, char *);
char * Perl_fileify_dirspec_ts (char *, char *);
char * Perl_pathify_dirspec (char *, char *);
char * Perl_pathify_dirspec_ts (char *, char *);
char * Perl_rmsexpand (char *, char *, char *, unsigned);
char * Perl_rmsexpand_ts (char *, char *, char *, unsigned);
int Perl_trim_unixpath (char *, char*, int);
DIR * Perl_opendir (char *);
int Perl_rmscopy (char *, char *, int);
int Perl_my_mkdir (char *, Mode_t);
bool Perl_vms_do_aexec (SV *, SV **, SV **);
#else
char * Perl_my_getenv (pTHX_ const char *, bool);
int Perl_my_trnlnm (pTHX_ const char *, char *, unsigned long int);
char * Perl_tounixspec (pTHX_ char *, char *);
char * Perl_tounixspec_ts (pTHX_ char *, char *);
char * Perl_tovmsspec (pTHX_ char *, char *);
char * Perl_tovmsspec_ts (pTHX_ char *, char *);
char * Perl_tounixpath (pTHX_ char *, char *);
char * Perl_tounixpath_ts (pTHX_ char *, char *);
char * Perl_tovmspath (pTHX_ char *, char *);
char * Perl_tovmspath_ts (pTHX_ char *, char *);
int Perl_do_rmdir (pTHX_ char *);
char * Perl_fileify_dirspec (pTHX_ char *, char *);
char * Perl_fileify_dirspec_ts (pTHX_ char *, char *);
char * Perl_pathify_dirspec (pTHX_ char *, char *);
char * Perl_pathify_dirspec_ts (pTHX_ char *, char *);
char * Perl_rmsexpand (pTHX_ char *, char *, char *, unsigned);
char * Perl_rmsexpand_ts (pTHX_ char *, char *, char *, unsigned);
int Perl_trim_unixpath (pTHX_ char *, char*, int);
DIR * Perl_opendir (pTHX_ char *);
int Perl_rmscopy (pTHX_ char *, char *, int);
int Perl_my_mkdir (pTHX_ char *, Mode_t);
bool Perl_vms_do_aexec (pTHX_ SV *, SV **, SV **);
#endif
char * Perl_my_getenv_len (pTHX_ const char *, unsigned long *, bool);
int Perl_vmssetenv (pTHX_ char *, char *, struct dsc$descriptor_s **);
void Perl_vmssetuserlnm(pTHX_ char *name, char *eqv);
char * Perl_my_crypt (pTHX_ const char *, const char *);
Pid_t Perl_my_waitpid (pTHX_ Pid_t, int *, int);
char * my_gconvert (double, int, int, char *);
int Perl_kill_file (pTHX_ char *);
int Perl_my_chdir (pTHX_ char *);
FILE * Perl_my_tmpfile ();
#ifndef HOMEGROWN_POSIX_SIGNALS
int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);
#endif
#ifdef KILL_BY_SIGPRC
unsigned int Perl_sig_to_vmscondition (int);
int Perl_my_kill (int, int);
void Perl_csighandler_init (void);
#endif
int Perl_my_utime (pTHX_ char *, struct utimbuf *);
void Perl_vms_image_init (int *, char ***);
struct dirent * Perl_readdir (pTHX_ DIR *);
int Perl_readdir_r(pTHX_ DIR *, struct dirent *, struct dirent **);
long telldir (DIR *);
void Perl_seekdir (pTHX_ DIR *, long);
void closedir (DIR *);
void vmsreaddirversions (DIR *, int);
struct tm * Perl_my_gmtime (pTHX_ const time_t *);
struct tm * Perl_my_localtime (pTHX_ const time_t *);
time_t Perl_my_time (pTHX_ time_t *);
#ifdef HOMEGROWN_POSIX_SIGNALS
int my_sigemptyset (sigset_t *);
int my_sigfillset (sigset_t *);
int my_sigaddset (sigset_t *, int);
int my_sigdelset (sigset_t *, int);
int my_sigismember (sigset_t *, int);
int my_sigprocmask (int, sigset_t *, sigset_t *);
#endif
I32 Perl_cando_by_name (pTHX_ I32, Uid_t, char *);
int Perl_flex_fstat (pTHX_ int, Stat_t *);
int Perl_flex_stat (pTHX_ const char *, Stat_t *);
int my_vfork ();
bool Perl_vms_do_exec (pTHX_ char *);
unsigned long int Perl_do_aspawn (pTHX_ void *, void **, void **);
unsigned long int Perl_do_spawn (pTHX_ char *);
FILE * my_fdopen (int, const char *);
int my_fclose (FILE *);
int my_fwrite (const void *, size_t, size_t, FILE *);
int Perl_my_flush (pTHX_ FILE *);
struct passwd * Perl_my_getpwnam (pTHX_ char *name);
struct passwd * Perl_my_getpwuid (pTHX_ Uid_t uid);
void Perl_my_endpwent (pTHX);
char * my_getlogin (void);
typedef char __VMS_SEPYTOTORP__;
/* prototype section end marker; `typedef' passes through cpp */
#ifdef NO_PERL_TYPEDEFS /* We'll try not to scramble later files */
# ifdef __MY_BOOL_TYPE_FAKE
# undef bool
# undef __MY_BOOL_TYPE_FAKE
# endif
# ifdef __MY_I32_TYPE_FAKE
# undef I32
# undef __MY_I32_TYPE_FAKE
# endif
# ifdef __MY_SV_TYPE_FAKE
# undef SV
# undef __MY_SV_TYPE_FAKE
# endif
#endif
#ifndef VMS_DO_SOCKETS
/* 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
/* The C RTL manual says to undef the macro for DEC C 5.2 and lower. */
#if defined(fileno) && defined(__DECC_VER) && __DECC_VER < 50300000
# undef fileno
#endif
#define NO_ENVIRON_ARRAY
#endif /* __vmsish_h_included */
--- NEW FILE: genopt.com ---
$! generates options file for vms link
$! p1 is filename and mode to open file (filename/write or filename/append)
$! p2 is delimiter separating elements of list in p3
$! p3 is list of items to be written, one per line, into options file
$!
$ open file 'p1'
$ element=0
$loop:
$ x=f$element(element,p2,p3)
$ if x .eqs. p2 then goto out
$ y=f$edit(x,"COLLAPSE") ! lose spaces
$! Expand potential name-only args so we find shareable images
$! either via a logical name or in the default location
$ if y .nes. "" .and. -
f$locate("/SHARE",f$edit(y,"UPCASE")) .ne. f$length(y)
$ then
$ name = f$element(0,"/",y)
$ tail = f$extract(f$length(name),1024,y)
$ if f$trnlnm(name) .eqs. "" ! If it's a logical name, assume it's OK as is
$ then
$ name = f$parse(name,"sys$share:.exe;") ! Look where image activator will
$ name = f$search(name) ! Does it really exist?
$ if name .nes. ""
$ then
$ name = name - f$parse(name,,,"version") ! Insist on current version
$ y = name + tail
$ endif
$ endif
$ endif
$ if y .nes. "" then write file y
$ element=element+1
$ goto loop
$!
$out:
$ close file
$ exit
--- NEW FILE: perly_h.vms ---
/* Postprocessed by vms_yfix.pl 1.11 to add VMS declarations of globals */
#ifdef PERL_CORE
#define WORD 257
#define METHOD 258
#define FUNCMETH 259
#define THING 260
#define PMFUNC 261
#define PRIVATEREF 262
#define FUNC0SUB 263
#define UNIOPSUB 264
#define LSTOPSUB 265
#define LABEL 266
#define FORMAT 267
#define SUB 268
#define ANONSUB 269
#define PACKAGE 270
#define USE 271
#define WHILE 272
#define UNTIL 273
#define IF 274
#define UNLESS 275
#define ELSE 276
#define ELSIF 277
#define CONTINUE 278
#define FOR 279
#define LOOPEX 280
#define DOTDOT 281
#define FUNC0 282
#define FUNC1 283
#define FUNC 284
#define UNIOP 285
#define LSTOP 286
#define RELOP 287
#define EQOP 288
#define MULOP 289
#define ADDOP 290
#define DOLSHARP 291
#define DO 292
#define HASHBRACK 293
#define NOAMP 294
#define LOCAL 295
#define MY 296
#define MYSUB 297
#define COLONATTR 298
#define PREC_LOW 299
#define OROP 300
#define ANDOP 301
#define NOTOP 302
#define ASSIGNOP 303
#define OROR 304
#define ANDAND 305
#define BITOROP 306
#define BITANDOP 307
#define SHIFTOP 308
#define MATCHOP 309
#define UMINUS 310
#define REFGEN 311
#define POWOP 312
#define PREINC 313
#define PREDEC 314
#define POSTINC 315
#define POSTDEC 316
#define ARROW 317
#endif /* PERL_CORE */
typedef union {
I32 ival;
char *pval;
OP *opval;
GV *gvval;
} YYSTYPE;
#ifndef vax11c
extern YYSTYPE yylval;
#else
globalref YYSTYPE yylval;
#endif
--- NEW FILE: perlvms.pod ---
=head1 NAME
perlvms - VMS-specific documentation for Perl
=head1 DESCRIPTION
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 Perl features from the main Perl
documentation, which can be found in the F<[.pod]>
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
missed something you think should appear here, please don't
hesitate to drop a line to vmsperl at perl.org.
=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
Perl distribution..
=head1 Organization of Perl Images
=head2 Core 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<perlxs> 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.
=head2 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).
=head2 Installing dynamic extensions
In general, the distributed kit for a Perl extension includes
a file named Makefile.PL, which is a Perl program which is used
to create a F<Descrip.MMS> file which can be used to build and
install the files required by the extension. The kit should be
unpacked into a directory tree B<not> under the main Perl source
directory, and the procedure for building the extension is simply
$ perl Makefile.PL ! Create Descrip.MMS
$ mmk ! Build necessary files
$ mmk test ! Run test code, if supplied
$ mmk install ! Install into public Perl tree
I<N.B.> The procedure by which extensions are built and
tested creates several levels (at least 4) under the
directory in which the extension's source files live.
For this reason if you are running a version of VMS prior
to V7.1 you shouldn't nest the source directory
too deeply in your directory structure lest you exceed RMS'
maximum of 8 levels of subdirectory in a filespec. (You
can use rooted logical names to get another 8 levels of
nesting, if you can't place the files near the top of
the physical directory structure.)
VMS support for this process in the current release of Perl
is sufficient to handle most extensions. However, it does
not yet recognize extra libraries required to build shareable
images which are part of an extension, so these must be added
to the linker options file for the extension by hand. For
instance, if the F<PGPLOT> extension to Perl requires the
F<PGPLOTSHR.EXE> shareable image in order to properly link
the Perl extension, then the line C<PGPLOTSHR/Share> must
be added to the linker options file F<PGPLOT.Opt> produced
during the build process for the Perl extension.
By default, the shareable image for an extension is placed in
the F<[.lib.site_perl.auto>I<Arch>.I<Extname>F<]> directory of the
installed Perl directory tree (where I<Arch> is F<VMS_VAX> or
F<VMS_AXP>, and I<Extname> is the name of the extension, with
each C<::> translated to C<.>). (See the MakeMaker documentation
for more details on installation options for extensions.)
However, it can be manually placed in any of several locations:
=over 4
=item *
the F<[.Lib.Auto.>I<Arch>I<$PVers>I<Extname>F<]> subdirectory
of one of the directories in C<@INC> (where I<PVers>
is the version of Perl you're using, as supplied in C<$]>,
with '.' converted to '_'), or
=item *
one of the directories in C<@INC>, or
=item *
a directory which the extensions Perl library module
passes to the DynaLoader when asking it to map
the shareable image, or
=item *
F<Sys$Share> or F<Sys$Library>.
=back
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.
=head1 File specifications
=head2 Syntax
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 file
specification. VMS Perl interprets Unix pathnames in much
the same way as the CRTL (I<e.g.> the first component of
an absolute path is read as the device name for the
VMS file specification). There are a set of functions
provided in the C<VMS::Filespec> package for explicit
interconversion between VMS and Unix syntax; its
documentation provides more details.
Filenames are, of course, still case-insensitive. For
consistency, most Perl routines return filespecs using
lower case letters only, regardless of the case used in
the arguments passed to them. (This is true only when
running under VMS; Perl respects the case-sensitivity
of OSs like Unix.)
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, I<etc.> If you find instances
of this in the Perl distribution itself, please let us know,
so we can try to work around them.
=head2 Wildcard expansion
File specifications containing wildcards are allowed both on
the command line and within Perl globs (e.g. C<E<lt>*.cE<gt>>). 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.
Similar to the behavior of wildcard globbing for a Unix shell,
one can escape command line wildcards with double quotation
marks C<"> around a perl program command line argument. However,
owing to the stripping of C<"> characters carried out by the C
handling of argv you will need to escape a construct such as
this one (in a directory containing the files F<PERL.C>, F<PERL.EXE>,
F<PERL.H>, and F<PERL.OBJ>):
$ perl -e "print join(' ', at ARGV)" perl.*
perl.c perl.exe perl.h perl.obj
in the following triple quoted manner:
$ perl -e "print join(' ', at ARGV)" """perl.*"""
perl.*
In both the case of unquoted command line arguments or in calls
to C<glob()> VMS wildcard expansion is performed. (csh-style
wildcard expansion is available if you use C<File::Glob::glob>.)
If the wildcard filespec contains a device or directory
specification, then the resultant filespecs will also contain
a device and directory; otherwise, device and directory
information are removed. VMS-style resultant filespecs will
contain a full device and directory, while Unix-style
resultant filespecs will contain only as much of a directory
path as was present in the input filespec. For example, if
your default directory is Perl_Root:[000000], the expansion
of C<[.t]*.*> will yield filespecs like
"perl_root:[t]base.dir", while the expansion of C<t/*/*> will
yield filespecs like "t/base.dir". (This is done to match
the behavior of glob expansion performed by Unix shells.)
Similarly, the resultant filespec will contain the file version
only if one was present in the input filespec.
=head2 Pipes
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.
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 handled as if it were the
argument to the C<system> operator (see below). In this case,
Perl will wait for the subprocess to complete before continuing.
The mailbox (MBX) that perl can create to communicate with a pipe
defaults to a buffer size of 512. The default buffer size is
adjustable via the logical name PERL_MBX_SIZE provided that the
value falls between 128 and the SYSGEN parameter MAXBUF inclusive.
For example, to double the MBX size from the default within
a Perl program, use C<$ENV{'PERL_MBX_SIZE'} = 1024;> and then
open and use pipe constructs. An alternative would be to issue
the command:
$ Define PERL_MBX_SIZE 1024
before running your wide record pipe program. A larger value may
improve performance at the expense of the BYTLM UAF quota.
=head1 PERL5LIB and PERLLIB
The PERL5LIB and PERLLIB logical names work as documented in L<perl>,
except that the element separator is '|' instead of ':'. The
directory specifications may use either VMS or Unix syntax.
=head1 Command line
=head2 I/O redirection and backgrounding
Perl for VMS supports redirection of input and output on the
command line, using a subset of Bourne shell syntax:
=over 4
=item *
C<E<lt>file> reads stdin from C<file>,
=item *
C<E<gt>file> writes stdout to C<file>,
=item *
C<E<gt>E<gt>file> appends stdout to C<file>,
=item *
C<2E<gt>file> writes stderr to C<file>,
=item *
C<2E<gt>E<gt>file> appends stderr to C<file>, and
=item *
C<< 2>&1 >> redirects stderr to stdout.
=back
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.
Finally, if the command line ends with '&', the entire
command is run in the background as an asynchronous
subprocess.
=head2 Command line switches
The following command line switches behave differently under
VMS than described in L<perlrun>. Note also that in order
to pass uppercase switches to Perl, you need to enclose
them in double-quotes on the command line, since the CRTL
downcases all unquoted strings.
=over 4
=item -i
If the C<-i> switch is present but no extension for a backup
copy is given, then inplace editing creates a new version of
a file; the existing copy is not deleted. (Note that if
an extension is given, an existing file is renamed to the backup
file, as is the case under other operating systems, so it does
not remain as a previous version under the original filename.)
=item -S
If the C<"-S"> or C<-"S"> switch is present I<and> the script
name does not contain a directory, then Perl translates the
logical name DCL$PATH as a searchlist, using each translation
as a directory in which to look for the script. In addition,
if no file type is specified, Perl looks in each directory
for a file matching the name specified, with a blank type,
a type of F<.pl>, and a type of F<.com>, in that order.
=item -u
The C<-u> switch causes the VMS debugger to be invoked
after the Perl program is compiled, but before it has
run. It does not create a core dump file.
=back
=head1 Perl functions
As of the time this document was last revised, the following
Perl functions were implemented in the VMS port of Perl
(functions marked with * are discussed in more detail below):
file tests*, abs, alarm, atan, backticks*, binmode*, bless,
caller, chdir, chmod, chown, chomp, chop, chr,
close, closedir, cos, crypt*, defined, delete,
die, do, dump*, each, endpwent, eof, eval, exec*,
exists, exit, exp, fileno, getc, getlogin, getppid,
getpwent*, getpwnam*, getpwuid*, glob, gmtime*, 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, print, printf, push, q//, qq//, qw//,
qx//*, quotemeta, rand, read, readdir, redo, ref, rename,
require, reset, return, reverse, rewinddir, rindex,
rmdir, s///, scalar, seek, seekdir, select(internal),
select (system call)*, 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
undefined behavior (rarely, we hope):
chroot, dbmclose, dbmopen, flock, fork*,
getpgrp, getpriority, getgrent, getgrgid,
getgrnam, setgrent, endgrent, ioctl, link, lstat,
msgctl, msgget, msgsend, msgrcv, readlink, semctl,
semget, semop, setpgrp, setpriority, shmctl, shmget,
shmread, shmwrite, socketpair, symlink, syscall
The following functions are available on Perls compiled with Dec C
5.2 or greater and running VMS 7.0 or greater:
truncate
The following functions are available on Perls built on VMS 7.2 or
greater:
fcntl (without locking)
The following functions may or may not be implemented,
depending on what type of socket support you've built into
your copy of Perl:
accept, bind, connect, getpeername,
gethostbyname, getnetbyname, getprotobyname,
getservbyname, gethostbyaddr, getnetbyaddr,
getprotobynumber, getservbyport, gethostent,
getnetent, getprotoent, getservent, sethostent,
setnetent, setprotoent, setservent, endhostent,
endnetent, endprotoent, endservent, getsockname,
getsockopt, listen, recv, select(system call)*,
send, setsockopt, shutdown, socket
=over 4
=item File tests
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.
Note: Some sites have reported problems when using the file-access
tests (C<-r>, C<-w>, and C<-x>) on files accessed via DEC's DFS.
Specifically, since DFS does not currently provide access to the
extended file header of files on remote volumes, attempts to
examine the ACL fail, and the file tests will return false,
with C<$!> indicating that the file does not exist. You can
use C<stat> on these files, since that checks UIC-based protection
only, and then manually check the appropriate bits, as defined by
your C compiler's F<stat.h>, in the mode value it returns, if you
need an approximation of the file's protections.
=item backticks
Backticks create a subprocess, and pass the enclosed string
to it for execution as a DCL command. Since the subprocess is
created directly via C<lib$spawn()>, any valid DCL command string
may be specified.
=item binmode FILEHANDLE
The C<binmode> operator will attempt to insure that no translation
of carriage control occurs on input from or output to this filehandle.
Since this involves reopening the file and then restoring its
file position indicator, if this function returns FALSE, the
underlying filehandle may no longer point to an open file, or may
point to a different position in the file than before C<binmode>
was called.
Note that C<binmode> is generally not necessary when using normal
filehandles; it is provided so that you can control I/O to existing
record-structured files when necessary. You can also use the
C<vmsfopen> function in the VMS::Stdio extension to gain finer
control of I/O to files and devices with different record structures.
=item crypt PLAINTEXT, USER
The C<crypt> operator uses the C<sys$hash_password> system
service to generate the hashed representation of PLAINTEXT.
If USER is a valid username, the algorithm and salt values
are taken from that user's UAF record. If it is not, then
the preferred algorithm and a salt of 0 are used. The
quadword encrypted value is returned as an 8-character string.
The value returned by C<crypt> may be compared against
the encrypted password from the UAF returned by the C<getpw*>
functions, in order to authenticate users. If you're
going to do this, remember that the encrypted password in
the UAF was generated using uppercase username and
password strings; you'll have to upcase the arguments to
C<crypt> to insure that you'll get the proper value:
sub validate_passwd {
my($user,$passwd) = @_;
my($pwdhash);
if ( !($pwdhash = (getpwnam($user))[1]) ||
$pwdhash ne crypt("\U$passwd","\U$name") ) {
intruder_alert($name);
}
return 1;
}
=item dump
Rather than causing Perl to abort and dump core, the C<dump>
operator invokes the VMS debugger. If you continue to
execute the Perl program under the debugger, control will
be transferred to the label specified as the argument to
C<dump>, or, if no label was specified, back to the
beginning of the program. All other state of the program
(I<e.g.> values of variables, open file handles) are not
affected by calling C<dump>.
=item exec LIST
A call to C<exec> 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 '@' or '$' (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 C<exec>'s
argument to it as parameters. If the token has no file type, and
matches a file with null type, then an attempt is made to determine
whether the file is an executable image which should be invoked
using C<MCR> or a text file which should be passed to DCL as a
command procedure.
=item fork
While in principle the C<fork> operator could be implemented via
(and with the same rather severe limitations as) the CRTL C<vfork()>
routine, and while some internal support to do just that is in
place, the implementation has never been completed, making C<fork>
currently unavailable. A true kernel C<fork()> is expected in a
future version of VMS, and the pseudo-fork based on interpreter
threads may be available in a future version of Perl on VMS (see
L<perlfork>). In the meantime, use C<system>, backticks, or piped
filehandles to create subprocesses.
=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 gmtime
The C<gmtime> operator will function properly if you have a
working CRTL C<gmtime()> routine, or if the logical name
SYS$TIMEZONE_DIFFERENTIAL is defined as the number of seconds
which must be added to UTC to yield local time. (This logical
name is defined automatically if you are running a version of
VMS with built-in UTC support.) If neither of these cases is
true, a warning message is printed, and C<undef> is returned.
=item kill
In most cases, C<kill> is implemented via the CRTL's C<kill()>
function, so it will behave according to that function's
documentation. If you send a SIGKILL, however, the $DELPRC system
service is called directly. This insures that the target
process is actually deleted, if at all possible. (The CRTL's C<kill()>
function is presently implemented via $FORCEX, which is ignored by
supervisor-mode images like DCL.)
Also, negative signal values don't do anything special under
VMS; they're just converted to the corresponding positive value.
=item qx//
See the entry on C<backticks> above.
=item select (system call)
If Perl was not built with socket support, the system call
version of C<select> is not available at all. If socket
support is present, then the system call version of
C<select> functions only for file descriptors attached
to sockets. It will not provide information about regular
files or pipes, since the CRTL C<select()> routine does not
provide this functionality.
=item stat EXPR
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 C<lib$spawn()>, any
valid DCL command string may be specified. If the string begins with
'@', it is treated as a DCL command unconditionally. Otherwise, if
the first token contains a character used as a delimiter in file
specification (e.g. C<:> or C<]>), an attempt is made to expand it
using a default type of F<.Exe> and the process defaults, and if
successful, the resulting file is invoked via C<MCR>. This allows you
to invoke an image directly simply by passing the file specification
to C<system>, a common Unixish idiom. If the token has no file type,
and matches a file with null type, then an attempt is made to
determine whether the file is an executable image which should be
invoked using C<MCR> or a text file which should be passed to DCL
as a command procedure.
If LIST consists of the empty string, C<system> spawns an
interactive DCL subprocess, in the same fashion as typing
B<SPAWN> at the DCL prompt.
Perl waits for the subprocess to complete before continuing
execution in the current process. As described in L<perlfunc>,
the return value of C<system> is a fake "status" which follows
POSIX semantics unless the pragma C<use vmsish 'status'> is in
effect; see the description of C<$?> in this document for more
detail.
=item time
The value returned by C<time> is the offset in seconds from
01-JAN-1970 00:00:00 (just like the CRTL's times() routine), in order
to make life easier for code coming in from the POSIX/Unix world.
=item times
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 a subprocess may or may
not appear separately in the "child time" field, depending on
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 subprocesses spawned via pipes, L<system>,
or backticks.
=item unlink LIST
C<unlink> will delete the highest version of a file only; in
order to delete all versions, you need to say
1 while unlink LIST;
You may need to make this change to scripts written for a
Unix system which expect that after a call to C<unlink>,
no files with the names passed to C<unlink> will exist.
(Note: This can be changed at compile time; if you
C<use Config> and C<$Config{'d_unlink_all_versions'}> is
C<define>, then C<unlink> will delete all versions of a
file on the first call.)
C<unlink> will delete a file if at all possible, even if it
requires changing file protection (though it won't try to
change the protection of the parent directory). You can tell
whether you've got explicit delete access to a file by using the
C<VMS::Filespec::candelete> operator. For instance, in order
to delete only files to which you have delete access, you could
say something like
sub safe_unlink {
my($file,$num);
foreach $file (@_) {
next unless VMS::Filespec::candelete($file);
$num += unlink $file;
}
$num;
}
(or you could just use C<VMS::Stdio::remove>, if you've installed
the VMS::Stdio extension distributed with Perl). If C<unlink> has to
change the file protection to delete the file, and you interrupt it
in midstream, the file may be left intact, but with a changed ACL
allowing you delete access.
=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 C<open()> (see L<open>),
C<waitpid> will wait for that subprocess, and return its final status
value in C<$?>. If PID is a subprocess created in some other way (e.g.
SPAWNed before Perl was invoked), C<waitpid> will simply check once per
second whether the process has completed, and return when it has. (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.)
Returns PID on success, -1 on error. The FLAGS argument is ignored
in all cases.
=back
=head1 Perl variables
The following VMS-specific information applies to the indicated
"special" Perl variables, in addition to the general information
in L<perlvar>. Where there is a conflict, this information
takes precedence.
=over 4
=item %ENV
The operation of the C<%ENV> array depends on the translation
of the logical name F<PERL_ENV_TABLES>. If defined, it should
be a search list, each element of which specifies a location
for C<%ENV> elements. If you tell Perl to read or set the
element C<$ENV{>I<name>C<}>, then Perl uses the translations of
F<PERL_ENV_TABLES> as follows:
=over 4
=item CRTL_ENV
This string tells Perl to consult the CRTL's internal C<environ>
array of key-value pairs, using I<name> as the key. In most cases,
this contains only a few keys, but if Perl was invoked via the C
C<exec[lv]e()> function, as is the case for CGI processing by some
HTTP servers, then the C<environ> array may have been populated by
the calling program.
=item CLISYM_[LOCAL]
A string beginning with C<CLISYM_>tells Perl to consult the CLI's
symbol tables, using I<name> as the name of the symbol. When reading
an element of C<%ENV>, the local symbol table is scanned first, followed
by the global symbol table.. The characters following C<CLISYM_> are
significant when an element of C<%ENV> is set or deleted: if the
complete string is C<CLISYM_LOCAL>, the change is made in the local
symbol table; otherwise the global symbol table is changed.
=item Any other string
If an element of F<PERL_ENV_TABLES> translates to any other string,
that string is used as the name of a logical name table, which is
consulted using I<name> as the logical name. The normal search
order of access modes is used.
=back
F<PERL_ENV_TABLES> is translated once when Perl starts up; any changes
you make while Perl is running do not affect the behavior of C<%ENV>.
If F<PERL_ENV_TABLES> is not defined, then Perl defaults to consulting
first the logical name tables specified by F<LNM$FILE_DEV>, and then
the CRTL C<environ> array.
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.
When an element of C<%ENV> is read, the locations to which
F<PERL_ENV_TABLES> points are checked in order, and the value
obtained from the first successful lookup is returned. If the
name of the C<%ENV> element contains a semi-colon, it and
any characters after it are removed. These are ignored when
the CRTL C<environ> array or a CLI symbol table is consulted.
However, the name is looked up in a logical name table, the
suffix after the semi-colon is treated as the translation index
to be used for the lookup. This lets you look up successive values
for search list logical names. For instance, if you say
$ Define STORY once,upon,a,time,there,was
$ perl -e "for ($i = 0; $i <= 6; $i++) " -
_$ -e "{ print $ENV{'story;'.$i},' '}"
Perl will print C<ONCE UPON A TIME THERE WAS>, assuming, of course,
that F<PERL_ENV_TABLES> is set up so that the logical name C<story>
is found, rather than a CLI symbol or CRTL C<environ> element with
the same name.
When an element of C<%ENV> is set to a defined string, the
corresponding definition is made in the location to which the
first translation of F<PERL_ENV_TABLES> points. If this causes a
logical name to be created, it is defined in supervisor mode.
(The same is done if an existing logical name was defined in
executive or kernel mode; an existing user or supervisor mode
logical name is reset to the new value.) If the value is an empty
string, the logical name's translation is defined as a single NUL
(ASCII 00) character, since a logical name cannot translate to a
zero-length string. (This restriction does not apply to CLI symbols
or CRTL C<environ> values; they are set to the empty string.)
An element of the CRTL C<environ> array can be set only if your
copy of Perl knows about the CRTL's C<setenv()> function. (This is
present only in some versions of the DECCRTL; check C<$Config{d_setenv}>
to see whether your copy of Perl was built with a CRTL that has this
function.)
When an element of C<%ENV> is set to C<undef>,
the element is looked up as if it were being read, and if it is
found, it is deleted. (An item "deleted" from the CRTL C<environ>
array is set to the empty string; this can only be done if your
copy of Perl knows about the CRTL C<setenv()> function.) Using
C<delete> to remove an element from C<%ENV> has a similar effect,
but after the element is deleted, another attempt is made to
look up the element, so an inner-mode logical name or a name in
another location will replace the logical name just deleted.
In either case, only the first value found searching PERL_ENV_TABLES
is altered. It is not possible at present to define a search list
logical name via %ENV.
The element C<$ENV{DEFAULT}> is special: when read, it returns
Perl's current default device and directory, and when set, it
resets them, regardless of the definition of F<PERL_ENV_TABLES>.
It cannot be cleared or deleted; attempts to do so are silently
ignored.
Note that if you want to pass on any elements of the
C-local environ array to a subprocess which isn't
started by fork/exec, or isn't running a C program, you
can "promote" them to logical names in the current
process, which will then be inherited by all subprocesses,
by saying
foreach my $key (qw[C-local keys you want promoted]) {
my $temp = $ENV{$key}; # read from C-local array
$ENV{$key} = $temp; # and define as logical name
}
(You can't just say C<$ENV{$key} = $ENV{$key}>, since the
Perl optimizer is smart enough to elide the expression.)
Don't try to clear C<%ENV> by saying C<%ENV = ();>, it will throw
a fatal error. This is equivalent to doing the following from DCL:
DELETE/LOGICAL *
You can imagine how bad things would be if, for example, the SYS$MANAGER
or SYS$SYSTEM logicals were deleted.
At present, the first time you iterate over %ENV using
C<keys>, or C<values>, you will incur a time penalty as all
logical names are read, in order to fully populate %ENV.
Subsequent iterations will not reread logical names, so they
won't be as slow, but they also won't reflect any changes
to logical name tables caused by other programs.
You do need to be careful with the logicals representing process-permanent
files, such as C<SYS$INPUT> and C<SYS$OUTPUT>. The translations for these
logicals are prepended with a two-byte binary value (0x1B 0x00) that needs to be
stripped off if you want to use it. (In previous versions of Perl it wasn't
possible to get the values of these logicals, as the null byte acted as an
end-of-string marker)
=item $!
The string value of C<$!> is that returned by the CRTL's
strerror() function, so it will include the VMS message for
VMS-specific errors. The numeric value of C<$!> is the
value of C<errno>, except if errno is EVMSERR, in which
case C<$!> contains the value of vaxc$errno. Setting C<$!>
always sets errno to the value specified. If this value is
EVMSERR, it also sets vaxc$errno to 4 (NONAME-F-NOMSG), so
that the string value of C<$!> won't reflect the VMS error
message from before C<$!> was set.
=item $^E
This variable provides direct access to VMS status values
in vaxc$errno, which are often more specific than the
generic Unix-style error messages in C<$!>. Its numeric value
is the value of vaxc$errno, and its string value is the
corresponding VMS message string, as retrieved by sys$getmsg().
Setting C<$^E> sets vaxc$errno to the value specified.
=item $?
The "status value" returned in C<$?> is synthesized from the
actual exit status of the subprocess in a way that approximates
POSIX wait(5) semantics, in order to allow Perl programs to
portably test for successful completion of subprocesses. The
low order 8 bits of C<$?> are always 0 under VMS, since the
termination status of a process may or may not have been
generated by an exception. The next 8 bits are derived from
the severity portion of the subprocess' exit status: if the
severity was success or informational, these bits are all 0;
if the severity was warning, they contain a value of 1; if the
severity was error or fatal error, they contain the actual
severity bits, which turns out to be a value of 2 for error
and 4 for fatal error.
As a result, C<$?> will always be zero if the subprocess' exit
status indicated successful completion, and non-zero if a
warning or error occurred. Conversely, when setting C<$?> in
an END block, an attempt is made to convert the POSIX value
into a native status intelligible to the operating system upon
exiting Perl. What this boils down to is that setting C<$?>
to zero results in the generic success value SS$_NORMAL, and
setting C<$?> to a non-zero value results in the generic
failure status SS$_ABORT. See also L<perlport/exit>.
The pragma C<use vmsish 'status'> makes C<$?> reflect the actual
VMS exit status instead of the default emulation of POSIX status
described above. This pragma also disables the conversion of
non-zero values to SS$_ABORT when setting C<$?> in an END
block (but zero will still be converted to SS$_NORMAL).
=item $|
Setting C<$|> for an I/O stream causes data to be flushed
all the way to disk on each write (I<i.e.> not just to
the underlying RMS buffers for a file). In other words,
it's equivalent to calling fflush() and fsync() from C.
=back
=head1 Standard modules with VMS-specific differences
=head2 SDBM_File
SDBM_File works properly on VMS. It has, however, one minor
difference. The database directory file created has a F<.sdbm_dir>
extension rather than a F<.dir> extension. F<.dir> files are VMS filesystem
directory files, and using them for other purposes could cause unacceptable
problems.
=head1 Revision date
This document was last updated on 01-May-2002, for Perl 5,
patchlevel 8.
=head1 AUTHOR
Charles Bailey bailey at cor.newman.upenn.edu
Craig Berry craigberry at mac.com
Dan Sugalski dan at sidhe.org
--- NEW FILE: sockadapt.c ---
/* sockadapt.c
*
* Author: Charles Bailey bailey at newman.upenn.edu
* Last Revised: 4-Mar-1997
*
* 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 UCX (or emulation) via
* the DECCRTL or SOCKETSHR 0.9D.
*/
#include "EXTERN.h"
#include "perl.h"
#if defined(__DECC) && defined(__DECC_VER) && (__DECC_VER >= 50200000)
# define __sockadapt_my_hostent_t __struct_hostent_ptr32
# define __sockadapt_my_netent_t __struct_netent_ptr32
# define __sockadapt_my_servent_t __struct_servent_ptr32
# define __sockadapt_my_addr_t __in_addr_t
# define __sockadapt_my_name_t const char *
#else
# define __sockadapt_my_hostent_t struct hostent *
# define __sockadapt_my_netent_t struct netent *
# define __sockadapt_my_servent_t struct servent *
# define __sockadapt_my_addr_t long
# define __sockadapt_my_name_t char *
#endif
/* We have these on VMS 7.0 and above, or on Dec C 5.6 if it's providing */
/* the 7.0 DECC RTL */
#if ((((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000)) && defined(DECCRTL_SOCKETS))
#else
void setnetent(int stayopen) {
dTHX;
Perl_croak(aTHX_ "Function \"setnetent\" not implemented in this version of perl");
}
void endnetent() {
dTHX;
Perl_croak(aTHX_ "Function \"endnetent\" not implemented in this version of perl");
}
#endif
#if defined(DECCRTL_SOCKETS)
/* Use builtin socket interface in DECCRTL and
* UCX emulation in whatever TCP/IP stack is present.
*/
#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000)
#else
void sethostent(int stayopen) {
dTHX;
Perl_croak(aTHX_ "Function \"sethostent\" not implemented in this version of perl");
}
void endhostent() {
dTHX;
Perl_croak(aTHX_ "Function \"endhostent\" not implemented in this version of perl");
}
void setprotoent(int stayopen) {
dTHX;
Perl_croak(aTHX_ "Function \"setprotoent\" not implemented in this version of perl");
}
void endprotoent() {
dTHX;
Perl_croak(aTHX_ "Function \"endprotoent\" not implemented in this version of perl");
}
void setservent(int stayopen) {
dTHX;
Perl_croak(aTHX_ "Function \"setservent\" not implemented in this version of perl");
}
void endservent() {
dTHX;
Perl_croak(aTHX_ "Function \"endservent\" not implemented in this version of perl");
}
__sockadapt_my_hostent_t gethostent() {
dTHX;
Perl_croak(aTHX_ "Function \"gethostent\" not implemented in this version of perl");
return (__sockadapt_my_hostent_t )NULL; /* Avoid MISSINGRETURN warning, not reached */
}
__sockadapt_my_servent_t getservent() {
dTHX;
Perl_croak(aTHX_ "Function \"getservent\" not implemented in this version of perl");
return (__sockadapt_my_servent_t )NULL; /* Avoid MISSINGRETURN warning, not reached */
}
#endif
#else
/* Work around things missing/broken in SOCKETSHR. */
__sockadapt_my_netent_t getnetbyaddr( __sockadapt_my_addr_t net, int type) {
dTHX;
Perl_croak(aTHX_ "Function \"getnetbyaddr\" not implemented in this version of perl");
return (struct netent *)NULL; /* Avoid MISSINGRETURN warning, not reached */
}
__sockadapt_my_netent_t getnetbyname( __sockadapt_my_name_t name) {
dTHX;
Perl_croak(aTHX_ "Function \"getnetbyname\" not implemented in this version of perl");
return (struct netent *)NULL; /* Avoid MISSINGRETURN warning, not reached */
}
__sockadapt_my_netent_t getnetent() {
dTHX;
Perl_croak(aTHX_ "Function \"getnetent\" not implemented in this version of perl");
return (__sockadapt_my_netent_t )NULL; /* Avoid MISSINGRETURN warning, not reached */
}
/* Some TCP/IP implementations seem to return success, when getpeername()
* is called on a UDP socket, but the port and in_addr are all zeroes.
*/
int my_getpeername(int sock, struct sockaddr *addr, int *addrlen) {
static char nowhere[] = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
int rslt;
rslt = si_getpeername(sock, addr, addrlen);
/* Just pass an error back up the line */
if (rslt) return rslt;
/* If the call succeeded, make sure we don't have a zeroed port/addr */
if (addr->sa_family == AF_INET &&
!memcmp((char *)addr + sizeof(u_short), nowhere,
sizeof(u_short) + sizeof(struct in_addr))) {
rslt = -1;
SETERRNO(ENOTCONN,SS$_CLEARED);
}
return rslt;
}
#endif /* SOCKETSHR stuff */
--- NEW FILE: mms2make.pl ---
#!/usr/bin/perl
#
# mms2make.pl - convert Descrip.MMS file to Makefile
# Version 2.2 29-Jan-1996
# David Denholm <denholm at conmat.phys.soton.ac.uk>
#
# 1.0 06-Aug-1994 Charles Bailey bailey at newman.upenn.edu
# - original version
# 2.0 29-Sep-1994 David Denholm <denholm at conmat.phys.soton.ac.uk>
# - take action based on MMS .if / .else / .endif
# any command line options after filenames are set in an assoc array %macros
# maintain "@condition as a stack of current conditions
# we unshift a 0 or 1 to front of @conditions at an .ifdef
# we invert top of stack at a .else
# we pop at a .endif
# 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 at newman.upenn.edu
# - handle MMS macros generated by MakeMaker
# 2.2 29-Jan-1996 Charles Bailey bailey at newman.upenn.edu
# - Fix output file name to work under Unix
if ($#ARGV > -1 && $ARGV[0] =~ /^[\-\/]trim/i) {
$do_trim = 1;
shift @ARGV;
}
$infile = $#ARGV > -1 ? shift(@ARGV) : "Descrip.MMS";
$outfile = $#ARGV > -1 ? shift(@ARGV) : "Makefile";
# set any other args in %macros - set VAXC by default
foreach (@ARGV) { $macros{"\U$_"}=1 }
# consistency check
$macros{"DECC"} = 1 if $macros{"__AXP__"};
# set conditions as if there was a .if 1 around whole file
# [lazy - saves having to check for empty array - just test [0]==1]
@conditions = (1);
open(INFIL,$infile) || die "Can't open $infile: $!\n";
open(OUTFIL,">$outfile") || die "Can't open $outfile: $!\n";
print OUTFIL "#> This file produced from $infile by $0\n";
print OUTFIL "#> Lines beginning with \"#>\" were commented out during the\n";
print OUTFIL "#> conversion process. For more information, see $0\n";
print OUTFIL "#>\n";
while (<INFIL>) {
s/$infile/$outfile/eoi;
if (/^\#/) {
if (!/^\#\:/) {print OUTFIL;}
next;
}
# look for ".ifdef macro" and push 1 or 0 to head of @conditions
# push 0 if we are in false branch of another if
if (/^\.ifdef\s*(.+)/i)
{
print OUTFIL "#> ",$_ unless $do_trim;
unshift @conditions, ($macros{"\U$1"} ? $conditions[0] : 0);
next;
}
# reverse $conditions[0] for .else provided surrounding if is active
if (/^\.else/i)
{
print OUTFIL "#> ",$_ unless $do_trim;
$conditions[0] = $conditions[1] && !$conditions[0];
next;
}
# pop top condition for .endif
if (/^\.endif/i)
{
print OUTFIL "#> ",$_ unless $do_trim;
shift @conditions;
next;
}
next if ($do_trim && !$conditions[0]);
# spot new rule and pick up first source file, since some versions of
# Make don't provide a macro for this
if (/[^#!]*:\s+/) {
if (/:\s+([^\s,]+)/) { $firstsrc = $1 }
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;
s/\@\[\.vms\]/\$\$\@\[\.vms\]/;
s/f\$/f\$\$/goi;
s/\$\(mms\$source\)/$firstsrc/i;
s/\$\(mms\$target\)/\$\@/i;
s/\$\(mms\$target_name\)\$\(O\)/\$\@/i;
s/\$\(mms\$target_name\)/\$\*/i;
s/sys\$([^\(])/sys\$\$$1/gi;
print OUTFIL "#> " unless $conditions[0];
print OUTFIL $_;
}
close INFIL;
close OUTFIL;
--- NEW FILE: make_command.com ---
$! MAKE_COMMAND.COM
$! Record MM[SK]/Make parameters in configuration report
$!
$! Author: Peter Prymmer <pvhp at lns62.lns.cornell.edu>
$! Version: 1.0 18-Jan-1996
$!
$! DCL usage (choose one):
$! @MAKE_COMMAND !or
$! @MAKE_COMMAND/OUTPUT=MYCONFIG.OUT
$!------------------------------------------------
$ $mms = "'"+p1
$ $makeline = p2+" "+p3+" "+p4+" "+p5+" "+p6+" "+p7+" "+p8
$quotable:
$ if f$locate("""",$makeline).lt.f$length($makeline)
$ then
$ $makeline = $makeline - """"
$ goto quotable
$ endif
$ $makeline = f$edit($makeline,"COMPRESS,TRIM")
$ write sys$output " make_cmd=''$mms'"+" ''$makeline''"
$!------------------------------------------------
--- NEW FILE: gen_shrfls.pl ---
# Create global symbol declarations, transfer vector, and
# linker options files for PerlShr.
#
# Input:
# $cflags - command line qualifiers passed to cc when preprocesing perl.h
# 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_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.
# PerlShr_Gbl.Opt (VAX only) - list of PerlShr_Gbl*.Obj, used for input
# to the linker when building PerlShr.Exe.
#
# To do:
# - figure out a good way to collect global vars in one psect, given that
# we can't use globaldef because of gcc.
# - then, check for existing files and preserve symbol and transfer vector
# order for upward compatibility
# - then, add GSMATCH to options file - but how do we insure that new
# library has everything old one did
# (i.e. /Define=DEBUGGING,EMBED,MULTIPLICITY)?
#
# Author: Charles Bailey bailey at newman.upenn.edu
require 5.000;
$debug = $ENV{'GEN_SHRFLS_DEBUG'};
print "gen_shrfls.pl Rev. 18-Dec-2003\n" if $debug;
if ($ARGV[0] eq '-f') {
open(INP,$ARGV[1]) or die "Can't read input file $ARGV[1]: $!\n";
print "Input taken from file $ARGV[1]\n" if $debug;
@ARGV = ();
while (<INP>) {
chomp;
push(@ARGV,split(/\|/,$_));
}
close INP;
print "Read input data | ",join(' | ', at ARGV)," |\n" if $debug > 1;
}
$cc_cmd = shift @ARGV;
# Someday, we'll have $GetSyI built into perl . . .
$isvax = `\$ Write Sys\$Output \(F\$GetSyI(\"HW_MODEL\") .LE. 1024 .AND. F\$GetSyI(\"HW_MODEL\") .GT. 0\)`;
chomp $isvax;
print "\$isvax: \\$isvax\\\n" if $debug;
print "Input \$cc_cmd: \\$cc_cmd\\\n" if $debug;
$docc = ($cc_cmd !~ /^~~/);
print "\$docc = $docc\n" if $debug;
if ($docc) {
if (-f 'perl.h') { $dir = '[]'; }
elsif (-f '[-]perl.h') { $dir = '[-]'; }
else { die "$0: Can't find perl.h\n"; }
$use_threads = $use_mymalloc = $case_about_case = $debugging_enabled = 0;
$hide_mymalloc = $isgcc = $use_perlio = 0;
# Go see what is enabled in config.sh
$config = $dir . "config.sh";
open CONFIG, "< $config";
while(<CONFIG>) {
$use_threads++ if /usethreads='(define|yes|true|t|y|1)'/i;
$use_mymalloc++ if /usemymalloc='(define|yes|true|t|y|1)'/i;
$care_about_case++ if /d_vms_case_sensitive_symbols='(define|yes|true|t|y|1)'/i;
$debugging_enabled++ if /usedebugging_perl='(define|yes|true|t|y|1)'/i;
$hide_mymalloc++ if /embedmymalloc='(define|yes|true|t|y|1)'/i;
$isgcc++ if /gccversion='[^']/;
$use_perlio++ if /useperlio='(define|yes|true|t|y|1)'/i;
}
close CONFIG;
# put quotes back onto defines - they were removed by DCL on the way in
if (($prefix,$defines,$suffix) =
($cc_cmd =~ m#(.*)/Define=(.*?)([/\s].*)#i)) {
$defines =~ s/^\((.*)\)$/$1/;
$debugging_enabled ||= $defines =~ /\bDEBUGGING\b/;
@defines = split(/,/,$defines);
$cc_cmd = "$prefix/Define=(" . join(',',grep($_ = "\"$_\"", at defines))
. ')' . $suffix;
}
print "Filtered \$cc_cmd: \\$cc_cmd\\\n" if $debug;
# check for gcc - if present, we'll need to use MACRO hack to
# define global symbols for shared variables
print "\$isgcc: $isgcc\n" if $debug;
print "\$debugging_enabled: $debugging_enabled\n" if $debug;
}
else {
($junk,$junk,$cpp_file,$cc_cmd) = split(/~~/,$cc_cmd,4);
$isgcc = $cc_cmd =~ /case_hack/i
or 0; # for nice debug output
$debugging_enabled = $cc_cmd =~ /\bdebugging\b/i;
print "\$isgcc: \\$isgcc\\\n" if $debug;
print "\$debugging_enabled: \\$debugging_enabled\\\n" if $debug;
print "Not running cc, preprocesor output in \\$cpp_file\\\n" if $debug;
}
$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;
sub scan_var {
my($line) = @_;
my($const) = $line =~ /^EXTCONST/;
print "\tchecking for global variable\n" if $debug > 1;
$line =~ s/\s*EXT/EXT/;
$line =~ s/INIT\s*\(.*\)//;
$line =~ s/\[.*//;
$line =~ s/=.*//;
$line =~ s/\W*;?\s*$//;
$line =~ s/\W*\)\s*\(.*$//; # closing paren for args stripped in previous stmt
print "\tfiltered to \\$line\\\n" if $debug > 1;
if ($line =~ /(\w+)$/) {
print "\tvar name is \\$1\\" . ($const ? ' (const)' : '') . "\n" if $debug > 1;
if ($const) { $cvars{$1}++; }
else { $vars{$1}++; }
}
}
sub scan_func {
my @lines = split /;/, @_[0];
for my $line (@lines) {
print "\tchecking for global routine\n" if $debug > 1;
$line =~ s/\b(IV|Off_t|Size_t|SSize_t|void)\b//i;
if ( $line =~ /(\w+)\s*\(/ ) {
print "\troutine name is \\$1\\\n" if $debug > 1;
if ($1 eq 'main' || $1 eq 'perl_init_ext' || $1 eq '__attribute__format__'
|| $1 eq 'sizeof' || (($1 eq 'Perl_stashpv_hvname_match') && ! $use_threads)) {
print "\tskipped\n" if $debug > 1;
}
else { $fcns{$1}++ }
}
}
}
# Go add some right up front if we need 'em
if ($use_mymalloc) {
$fcns{'Perl_malloc'}++;
$fcns{'Perl_calloc'}++;
$fcns{'Perl_realloc'}++;
$fcns{'Perl_mfree'}++;
}
if ($use_perlio) {
$preprocess_list = "${dir}perl.h+${dir}perlapi.h,${dir}perliol.h";
} else {
$preprocess_list = "${dir}perl.h+${dir}perlapi.h";
}
$used_expectation_enum = $used_opcode_enum = 0; # avoid warnings
if ($docc) {
open(CPP,"${cc_cmd}/NoObj/PreProc=Sys\$Output $preprocess_list|")
or die "$0: Can't preprocess $preprocess_list: $!\n";
}
else {
open(CPP,"$cpp_file") or die "$0: Can't read preprocessed file $cpp_file: $!\n";
}
%checkh = map { $_,1 } qw( thread bytecode byterun proto perlapi perlio perlvars intrpvar thrdvar );
$ckfunc = 0;
LINE: while (<CPP>) {
while (/^#.*vmsish\.h/i .. /^#.*perl\.h/i) {
while (/__VMS_PROTOTYPES__/i .. /__VMS_SEPYTOTORP__/i) {
print "vms_proto>> $_" if $debug > 2;
if (/^\s*EXT/) { &scan_var($_); }
else { &scan_func($_); }
last LINE unless defined($_ = <CPP>);
}
print "vmsish.h>> $_" if $debug > 2;
if (/^\s*EXT/) { &scan_var($_); }
last LINE unless defined($_ = <CPP>);
}
while (/^#.*opcode\.h/i .. /^#.*perl\.h/i) {
print "opcode.h>> $_" if $debug > 2;
if (/^OP \*\s/) { &scan_func($_); }
if (/^\s*EXT/) { &scan_var($_); }
last LINE unless defined($_ = <CPP>);
}
# Check for transition to new header file
if (/^# \d+ "(\S+)"/) {
my $spec = $1;
# Pull name from library module or header filespec
$spec =~ /^(\w+)$/ or $spec =~ /(\w+)\.h/i;
my $name = lc $1;
$name = 'perlio' if $name eq 'perliol';
$ckfunc = exists $checkh{$name} ? 1 : 0;
$scanname = $name if $ckfunc;
print "Header file transition: ckfunc = $ckfunc for $name.h\n" if $debug > 1;
}
if ($ckfunc) {
print "$scanname>> $_" if $debug > 2;
if (/^\s*EXT/) { &scan_var($_); }
else { &scan_func($_); }
}
else {
print $_ if $debug > 3 && ($debug > 5 || length($_));
if (/^\s*EXT/) { &scan_var($_); }
}
}
close CPP;
while (<DATA>) {
next if /^#/;
s/\s+#.*\n//;
next if /^\s*$/;
($key,$array) = split('=',$_);
if ($array eq 'vars') { $key = "PL_$key"; }
else { $key = "Perl_$key"; }
print "Adding $key to \%$array list\n" if $debug > 1;
${$array}{$key}++;
}
if ($debugging_enabled and $isgcc) { $vars{'colors'}++ }
foreach (split /\s+/, $extnames) {
my($pkgname) = $_;
$pkgname =~ s/::/__/g;
$fcns{"boot_$pkgname"}++;
print "Adding boot_$pkgname to \%fcns (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(OPTBLD,">${dir}${dbgprefix}perlshr_bld.opt")
or die "$0: Can't write to ${dir}${dbgprefix}perlshr_bld.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";
}
unless ($isgcc) {
print OPTBLD "PSECT_ATTR=\$GLOBAL_RO_VARS,PIC,NOEXE,RD,NOWRT,SHR\n";
print OPTBLD "PSECT_ATTR=\$GLOBAL_RW_VARS,PIC,NOEXE,RD,WRT,NOSHR\n";
}
print OPTBLD "case_sensitive=yes\n" if $care_about_case;
foreach $var (sort (keys %vars,keys %cvars)) {
if ($isvax) { print OPTBLD "UNIVERSAL=$var\n"; }
else { print OPTBLD "SYMBOL_VECTOR=($var=DATA)\n"; }
# This hack brought to you by the lack of a globaldef in gcc.
if ($isgcc) {
if ($count++ > 200) { # max 254 psects/file
print MAR "\t.end\n";
close MAR;
$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;
}
print MAR "\t.psect ${var},long,pic,ovr,rd,wrt,noexe,noshr\n";
print MAR "\t${var}:: .blkl 1\n";
}
}
print MAR "\t.psect \$transfer_vec,pic,rd,nowrt,exe,shr\n" if ($isvax);
foreach $func (sort keys %fcns) {
if ($isvax) {
print MAR "\t.transfer $func\n";
print MAR "\t.mask $func\n";
print MAR "\tjmp G\^${func}+2\n";
}
else { print OPTBLD "SYMBOL_VECTOR=($func=PROCEDURE)\n"; }
}
if ($isvax) {
print MAR "\t.end\n";
close MAR;
}
open(OPTATTR,">${dir}perlshr_attr.opt")
or die "$0: Can't write to ${dir}perlshr_attr.opt: $!\n";
if ($isgcc) {
foreach $var (sort keys %cvars) {
print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,NOWRT,SHR\n";
}
foreach $var (sort keys %vars) {
print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,WRT,NOSHR\n";
}
}
else {
print OPTATTR "! No additional linker directives are needed when using DECC\n";
}
close OPTATTR;
$incstr = 'PERL,GLOBALS';
if ($isvax) {
$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 {
push(@symfiles,"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;
}
# Initial hack to permit building of compatible shareable images for a
# given version of Perl.
if ($ENV{PERLSHR_USE_GSMATCH}) {
if ($ENV{PERLSHR_USE_GSMATCH} eq 'INCLUDE_COMPILE_OPTIONS') {
# Build up a major ID. Since it can only be 8 bits, we encode the version
# number in the top four bits and use the bottom four for build options
# that'll cause incompatibilities
($ver, $sub) = $] =~ /\.(\d\d\d)(\d\d)/;
$ver += 0; $sub += 0;
$gsmatch = ($sub >= 50) ? "equal" : "lequal"; # Force an equal match for
# dev, but be more forgiving
# for releases
$ver *=16;
$ver += 8 if $debugging_enabled; # If DEBUGGING is set
$ver += 4 if $use_threads; # if we're threaded
$ver += 2 if $use_mymalloc; # if we're using perl's malloc
print OPTBLD "GSMATCH=$gsmatch,$ver,$sub\n";
}
else {
my $major = int($] * 1000) & 0xFF; # range 0..255
my $minor = int(($] * 1000 - $major) * 100 + 0.5) & 0xFF; # range 0..255
print OPTBLD "GSMATCH=LEQUAL,$major,$minor\n";
}
print OPTBLD 'CLUSTER=$$TRANSFER_VECTOR,,',
map(",$_$objsuffix", at symfiles), "\n";
}
elsif (@symfiles) { $incstr .= ',' . join(',', at symfiles); }
# 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 options file $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
regkind=vars # declared in regcomp.h
simple=vars # declared in regcomp.h
varies=vars # declared in regcomp.h
--- NEW FILE: genconfig.pl ---
#!/usr/bin/perl
# Habit . . .
#
# 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. In addition, values which change from run
# to run may be supplied on the command line as key=val pairs.
#
# Rev. 16-Feb-1998 Charles Bailey bailey at newman.upenn.edu
#
#==== Locations of installed Perl components
$prefix='perl_root';
$builddir="$prefix:[000000]";
$installbin="$prefix:[000000]";
$installscript="$prefix:[000000]";
$installman1dir="$prefix:[man.man1]";
$installman3dir="$prefix:[man.man3]";
$installprivlib="$prefix:[lib]";
$installsitelib="$prefix:[lib.site_perl]";
unshift(@INC,'lib'); # In case someone didn't define Perl_Root
# before the build
if ($ARGV[0] eq '-f') {
open(ARGS,$ARGV[1]) or die "Can't read data from $ARGV[1]: $!\n";
@ARGV = ();
while (<ARGS>) {
chomp;
push(@ARGV,split(/\|/,$_));
}
close ARGS;
}
if (-f "config.vms") { $infile = "config.vms"; $outdir = "[-]"; }
elsif (-f "[.vms]config.vms") { $infile = "[.vms]config.vms"; $outdir = "[]"; }
elsif (-f "config.h") { $infile = "config.h"; $outdir = "[]";}
if ($infile) { print "Generating Config.sh from $infile . . .\n"; }
else { die <<EndOfGasp;
Can't find config.vms or config.h to read!
Please run this script from the perl source directory or
the VMS subdirectory in the distribution.
EndOfGasp
}
$outdir = '';
open(IN,"$infile") || die "Can't open $infile: $!\n";
open(OUT,">${outdir}Config.sh") || die "Can't open ${outdir}Config.sh: $!\n";
$time = localtime;
$cf_by = (getpwuid($<))[0];
$archsufx = `Write Sys\$Output F\$GetSyi("HW_MODEL")` > 1024 ? 'AXP' : 'VAX';
($vers = $]) =~ tr/./_/;
$installarchlib = VMS::Filespec::vmspath($installprivlib);
$installarchlib =~ s#\]#.VMS_$archsufx.$vers\]#;
$installsitearch = VMS::Filespec::vmspath($installsitelib);
$installsitearch =~ s#\]#.VMS_$archsufx\]#;
($osvers = `Write Sys\$Output F\$GetSyi("VERSION")`) =~ s/^V?(\S+)\s*\n?$/$1/;
print OUT <<EndOfIntro;
# This file generated by GenConfig.pl on a VMS system.
# Input obtained from:
# $infile
# $0
# Time: $time
package='perl5'
CONFIG='true'
cf_time='$time'
cf_by='$cf_by'
ccdlflags='undef'
cccdlflags='undef'
mab='undef'
libpth='/sys\$share /sys\$library'
ld='Link'
lddlflags='/Share'
ranlib='undef'
ar='undef'
eunicefix=':'
hint='none'
hintfile='undef'
useshrplib='define'
usemymalloc='n'
usevfork='true'
spitshell='write sys\$output '
dlsrc='dl_vms.c'
binexp='$installbin'
man1ext='rno'
man3ext='rno'
arch='VMS_$archsufx'
archname='VMS_$archsufx'
bincompat3='undef'
d_bincompat3='undef'
osvers='$osvers'
prefix='$prefix'
builddir='$builddir'
installbin='$installbin'
installscript='$installscript'
installman1dir='$installman1dir'
installman3dir='$installman3dir'
installprivlib='$installprivlib'
installarchlib='$installarchlib'
installsitelib='$installsitelib'
installsitearch='$installsitearch'
path_sep='|'
startperl='\$ perl 'f\$env("procedure")' 'p1' 'p2' 'p3' 'p4' 'p5' 'p6' 'p7' 'p8' !
\$ exit++ + ++\$status != 0 and \$exit = \$status = undef;'
EndOfIntro
foreach (@ARGV) {
($key,$val) = split('=',$_,2);
if ($key eq 'cc') { # Figure out which C compiler we're using
my($cc,$ccflags) = split('/',$val,2);
my($d_attr);
$ccflags = "/$ccflags";
if ($ccflags =~s!/DECC!!ig) {
$cc .= '/DECC';
$cctype = 'decc';
$d_attr = 'undef';
}
elsif ($ccflags =~s!/VAXC!!ig) {
$cc .= '/VAXC';
$cctype = 'vaxc';
$d_attr = 'undef';
}
elsif (`$val/NoObject/NoList _nla0:/Version` =~ /GNU C version (\S+)/) {
$cctype = 'gcc';
$d_attr = 'define';
print OUT "gccversion='$1'\n";
}
elsif ($archsufx eq 'VAX' &&
# Check exit status too, in case message is turned off
( `$val/NoObject/NoList /prefix=all _nla0:` =~ /IVQUAL/ ||
$? == 0x38240 )) {
$cctype = 'vaxc';
$d_attr = 'undef';
}
else {
$cctype = 'decc';
$d_attr = 'undef';
}
print OUT "vms_cc_type='$cctype'\n";
print OUT "d_attribute_format='$d_attr'\n";
# XXX The following attributes may be able to use $d_attr, too.
print OUT "d_attribute_malloc='undef'\n";
print OUT "d_attribute_nonnull='undef'\n";
print OUT "d_attribute_noreturn='undef'\n";
print OUT "d_attribute_pure='undef'\n";
print OUT "d_attribute_unused='undef'\n";
print OUT "d_attribute_warn_unused_result='undef'\n";
print OUT "cc='$cc'\n";
if ( ($cctype eq 'decc' and $archsufx eq 'VAX') || $cctype eq 'gcc') {
# gcc and DECC for VAX requires filename in /object qualifier, so we
# have to remove it here. Alas, this means we lose the user's
# object file suffix if it's not .obj.
$ccflags =~ s#/obj(?:ect)?=[^/\s]+##i;
}
$debug = $optimize = '';
while ( ($qual) = $ccflags =~ m|(/(No)?Deb[^/]*)|i ) {
$debug = $qual;
$ccflags =~ s/$qual//;
}
while ( ($qual) = $ccflags =~ m|(/(No)?Opt[^/]*)|i ) {
$optimize = $qual;
$ccflags =~ s/$qual//;
}
$usethreads = ($ccflags =~ m!/DEF[^/]+USE_5005THREADS!i and
$ccflags !~ m!/UND[^/]+USE_5005THREADS!i);
print OUT "usethreads='",($usethreads ? 'define' : 'undef'),"'\n";;
$optimize = "$debug$optimize";
print OUT "ccflags='$ccflags'\n";
print OUT "optimize='$optimize'\n";
$dosock = ($ccflags =~ m!/DEF[^/]+VMS_DO_SOCKETS!i and
$ccflags !~ m!/UND[^/]+VMS_DO_SOCKETS!i);
print OUT "d_vms_do_sockets=",$dosock ? "'define'\n" : "'undef'\n";
print OUT "d_socket=",$dosock ? "'define'\n" : "'undef'\n";
print OUT "d_sockpair=",$dosock ? "'define'\n" : "'undef'\n";
print OUT "d_gethent=",$dosock ? "'define'\n" : "'undef'\n";
print OUT "d_sethent=",$dosock ? "'define'\n" : "'undef'\n";
print OUT "d_select=",$dosock ? "'define'\n" : "'undef'\n";
print OUT "i_netdb=",$dosock ? "'define'\n" : "'undef'\n";
print OUT "i_niin=",$dosock ? "'define'\n" : "'undef'\n";
print OUT "i_neterrno=",$dosock ? "'define'\n" : "'undef'\n";
print OUT "d_gethbyname=",$dosock ? "'define'\n" : "'undef'\n";
print OUT "d_gethbyaddr=",$dosock ? "'define'\n" : "'undef'\n";
print OUT "d_getpbyname=",$dosock ? "'define'\n" : "'undef'\n";
print OUT "d_getpbynumber=",$dosock ? "'define'\n" : "'undef'\n";
print OUT "d_getsbyname=",$dosock ? "'define'\n" : "'undef'\n";
print OUT "d_getsbyport=",$dosock ? "'define'\n" : "'undef'\n";
print OUT "d_endhent=",$dosock ? "'define'\n" : "'undef'\n";
print OUT "d_getpent=",$dosock ? "'define'\n" : "'undef'\n";
print OUT "d_setpent=",$dosock ? "'define'\n" : "'undef'\n";
print OUT "d_endpent=",$dosock ? "'define'\n" : "'undef'\n";
print OUT "d_getsent=",$dosock ? "'define'\n" : "'undef'\n";
print OUT "d_setsent=",$dosock ? "'define'\n" : "'undef'\n";
print OUT "d_endsent=",$dosock ? "'define'\n" : "'undef'\n";
print OUT "netdb_name_type=",$dosock ? "'char *'\n" : "'undef'\n";
print OUT "netdb_host_type=",$dosock ? "'char *'\n" : "'undef'\n";
print OUT "netdb_hlen_type=",$dosock ? "'int'\n" : "'undef'\n";
print OUT "d_gethostprotos=",$dosock ? "'define'\n" : "'undef'\n";
print OUT "d_getnetprotos=",$dosock ? "'define'\n" : "'undef'\n";
print OUT "d_getservprotos=",$dosock ? "'define'\n" : "'undef'\n";
print OUT "d_getprotoprotos=",$dosock ? "'define'\n" : "'undef'\n";
if ($dosock and $cctype eq 'decc' and $ccflags =~ /DECCRTL_SOCKETS/) {
print OUT "selecttype='fd_set'\n";
print OUT "d_getnbyaddr='define'\n";
print OUT "d_getnbyname='define'\n";
print OUT "d_getnent='define'\n";
print OUT "d_setnent='define'\n";
print OUT "d_endnent='define'\n";
print OUT "netdb_net_type='long'\n";
}
else {
print OUT "selecttype='int'\n";
print OUT "d_getnybname='undef'\n";
print OUT "d_getnybaddr='undef'\n";
print OUT "d_getnent='undef'\n";
print OUT "d_setnent='undef'\n";
print OUT "d_endnent='undef'\n";
print OUT "netdb_net_type='undef'\n";
}
if ($cctype eq 'decc') {
$rtlhas = 'define';
print OUT "useposix='true'\n";
($ccver,$vmsver) = `$cc/VERSION` =~ /V(\S+) on .*V(\S+)$/;
# Best guess; the may be wrong on systems which have separately
# installed the new CRTL.
if ($ccver >= 5.2 and $vmsver >= 7) { $rtlnew = 'define'; }
else { $rtlnew = 'undef'; }
}
else { $rtlhas = $rtlnew = 'undef'; print OUT "useposix='false'\n"; }
foreach (qw[ d_stdstdio d_stdio_ptr_lval d_stdio_cnt_lval d_stdiobase
d_locconv d_setlocale i_locale d_mbstowcs d_mbtowc
d_wcstombs d_wctomb d_mblen d_mktime d_strcoll d_strxfrm ]) {
print OUT "$_='$rtlhas'\n";
}
print OUT "d_stdio_ptr_lval_sets_cnt='undef'\n";
print OUT "d_stdio_ptr_lval_nochange_cnt='undef'\n";
foreach (qw[ d_gettimeod d_uname d_truncate d_wait4 d_index
d_pathconf d_fpathconf d_sysconf d_sigsetjmp ]) {
print OUT "$_='$rtlnew'\n";
}
next;
}
elsif ($key eq 'exe_ext') {
my($nodot) = $val;
$nodot =~ s!\.!!;
print OUT "so='$nodot'\ndlext='$nodot'\n";
}
elsif ($key eq 'obj_ext') { print OUT "dlobj='dl_vms$val'\n"; }
print OUT "$key='$val'\n";
}
# Are there any other logicals which TCP/IP stacks use for the host name?
$myname = $ENV{'ARPANET_HOST_NAME'} || $ENV{'INTERNET_HOST_NAME'} ||
$ENV{'MULTINET_HOST_NAME'} || $ENV{'UCX$INET_HOST'} ||
$ENV{'TCPWARE_DOMAINNAME'} || $ENV{'NEWS_ADDRESS'};
if (!$myname) {
($myname) = `hostname` =~ /^(\S+)/;
if ($myname =~ /IVVERB/) {
warn "Can't determine TCP/IP hostname" if $dosock;
$myname = '';
}
}
$myname = $ENV{'SYS$NODE'} unless $myname;
($myhostname,$mydomain) = split(/\./,$myname,2);
print OUT "myhostname='$myhostname'\n" if $myhostname;
if ($mydomain) {
print OUT "mydomain='.$mydomain'\n";
print OUT "perladmin='$cf_by\@$myhostname.$mydomain'\n";
print OUT "cf_email='$cf_by\@$myhostname.$mydomain'\n";
}
else {
print OUT "perladmin='$cf_by'\n";
print OUT "cf_email='$cf_by'\n";
}
chomp($hwname = `Write Sys\$Output F\$GetSyi("HW_NAME")`);
$hwname = $archsufx if $hwname =~ /IVKEYW/; # *really* old VMS version
print OUT "myuname='VMS $myname $osvers $hwname'\n";
# Before we read the C header file, find out what config.sh constants are
# equivalent to the C preprocessor macros
if (open(SH,"${outdir}config_h.SH")) {
while (<SH>) {
next unless m%^#(?!if).*\$%;
s/^#//; s!(.*?)\s*/\*.*!$1!;
my(@words) = split;
$words[1] =~ s/\(.*//; # Clip off args from macro
# Did we use a shell variable for the preprocessor directive?
if ($words[0] =~ m!^\$(\w+)!) { $pp_vars{$words[1]} = $1; }
if (@words > 2) { # We may also have a shell var in the value
shift @words; # Discard preprocessor directive
my($token) = shift @words; # and keep constant name
my($word);
foreach $word (@words) {
next unless $word =~ m!\$(\w+)!;
$val_vars{$token} = $1;
last;
}
}
}
close SH;
}
else { warn "Couldn't read ${outdir}config_h.SH: $!\n"; }
$pp_vars{UNLINK_ALL_VERSIONS} = 'd_unlink_all_versions'; # VMS_specific
# OK, now read the C header file, and retcon statements into config.sh
while (<IN>) { # roll through the comment header in Config.VMS
last if /config-start/;
}
while (<IN>) {
chop;
while (/\\\s*$/) { # pick up contination lines
my $line = $_;
$line =~ s/\\\s*$//;
$_ = <IN>;
s/^\s*//;
$_ = $line . $_;
}
next unless my ($blocked,$un,$token,$val) =
m%^(\/\*)?\s*\#\s*(un)?def\w*\s+([A-Za-z0-9]\w+)\S*\s*(.*)%;
if (/config-skip/) {
delete $pp_vars{$token} if exists $pp_vars{$token};
delete $val_vars{$token} if exists $val_vars{$token};
next;
}
$val =~ s!\s*/\*.*!!; # strip off trailing comment
my($had_val); # Maybe a macro with args that we just #undefd or commented
if (!length($val) and $val_vars{$token} and ($un || $blocked)) {
print OUT "$val_vars{$token}=''\n" unless exists $done{$val_vars{$token}};
$done{$val_vars{$token}}++;
delete $val_vars{$token};
$had_val = 1;
}
$state = ($blocked || $un) ? 'undef' : 'define';
if ($pp_vars{$token}) {
print OUT "$pp_vars{$token}='$state'\n" unless exists $done{$pp_vars{$token}};
$done{$pp_vars{$token}}++;
delete $pp_vars{$token};
}
elsif (not length $val and not $had_val) {
# Wups -- should have been shell var for C preprocessor directive
warn "Constant $token not found in config_h.SH\n";
$token = lc $token;
$token = "d_$token" unless $token =~ /^i_/;
print OUT "$token='$state'\n";
}
next unless length $val;
$val =~ s/^"//; $val =~ s/"$//; # remove end quotes
$val =~ s/","/ /g; # make signal list look nice
# Library directory; convert to VMS syntax
$val = VMS::Filespec::vmspath($val) if ($token =~ /EXP$/);
if ($val_vars{$token}) {
print OUT "$val_vars{$token}='$val'\n" unless exists $done{$val_vars{$token}};
if ($val_vars{$token} =~ s/exp$//) {
print OUT "$val_vars{$token}='$val'\n" unless exists $done{$val_vars{$token}};;
}
$done{$val_vars{$token}}++;
delete $val_vars{$token};
}
elsif (!$pp_vars{$token}) { # Haven't seen it previously, either
warn "Constant $token not found in config_h.SH (val=|$val|)\n";
$token = lc $token;
print OUT "$token='$val'\n";
if ($token =~ s/exp$//) {print OUT "$token='$val'\n";}
}
}
close IN;
# Special case -- preprocessor manifest "VMS" is defined automatically
# on VMS systems, but is also used erroneously by the Perl build process
# as the manifest for the obsolete variable $d_eunice.
print OUT "d_eunice='undef'\n"; delete $pp_vars{VMS};
# XXX temporary -- USE_5005THREADS is currently on CC command line
delete $pp_vars{'USE_5005THREADS'};
foreach (sort keys %pp_vars) {
warn "Didn't see $_ in $infile\n";
}
foreach (sort keys %val_vars) {
warn "Didn't see $_ in $infile(val)\n";
}
if (open(OPT,"${outdir}crtl.opt")) {
while (<OPT>) {
next unless m#/(sha|lib)#i;
chomp;
if (/crtl/i || /gcclib/i) { push(@crtls,$_); }
else { push(@libs,$_); }
}
close OPT;
print OUT "libs='",join(' ', at libs),"'\n";
push(@crtls,'(DECCRTL)') if $cctype eq 'decc';
print OUT "libc='",join(' ', at crtls),"'\n";
}
else { warn "Can't read ${outdir}crtl.opt - skipping 'libs' & 'libc'"; }
if (open(PL,"${outdir}patchlevel.h")) {
while (<PL>) {
if (/^#define PERL_VERSION\s+(\S+)/) {
print OUT "PERL_VERSION='$1'\n";
print OUT "PATCHLEVEL='$1'\n"; # XXX compat
}
elsif (/^#define PERL_SUBVERSION\s+(\S+)/) {
print OUT "PERL_SUBVERSION='$1'\n";
print OUT "SUBVERSION='$1'\n"; # XXX compat
}
}
close PL;
}
else { warn "Can't read ${outdir}patchlevel.h - skipping 'PATCHLEVEL'"; }
# simple pager support for perldoc
if (`most not..file` =~ /IVVERB/) {
$pager = 'more';
if (`more nl:` =~ /IVVERB/) { $pager = 'type/page'; }
}
else { $pager = 'most'; }
print OUT "pager='$pager'\n";
close OUT;
--- NEW FILE: vmspipe.com ---
$! 'f$verify(0)'
$! --- protect against nonstandard definitions ---
$ perl_define = "define/nolog"
$ perl_on = "on error then exit $STATUS"
$ perl_exit = "exit"
$ perl_del = "delete"
$ pif = "if"
$! --- define i/o redirection (sys$output set by lib$spawn)
$ pif perl_popen_in .nes. "" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'
$ pif perl_popen_err .nes. "" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'
$ pif perl_popen_out .nes. "" then perl_define sys$output 'perl_popen_out'
$! --- build command line to get max possible length
$c=perl_popen_cmd0
$c=c+perl_popen_cmd1
$c=c+perl_popen_cmd2
$x=perl_popen_cmd3
$c=c+x
$ perl_on
$ 'c'
$ perl_exit '$STATUS'
--- NEW FILE: perly_c.vms ---
/* Postprocessed by vms_yfix.pl 1.11 to add VMS declarations of globals */
#ifndef lint
/* static char yysccsid[] = "@(#)yaccpar 1.8 (Berkeley) 01/20/91"; */
#endif
#define YYBYACC 1
#line 25 "perly.y"
#include "EXTERN.h"
#define PERL_IN_PERLY_C
#include "perl.h"
#ifdef EBCDIC
#undef YYDEBUG
#endif
#define dep() deprecate_old("\"do\" to call subroutines")
/* stuff included here to make perly_c.diff apply better */
#define yydebug PL_yydebug
#define yynerrs PL_yynerrs
#define yyerrflag PL_yyerrflag
[...2517 lines suppressed...]
#ifdef USE_ITHREADS
LEAVE; /* force yydestruct() before we return */
#endif
return retval;
}
static void
yydestruct(pTHX_ void *ptr)
{
struct ysv* ysave = (struct ysv*)ptr;
if (ysave->yyss) Safefree(ysave->yyss);
if (ysave->yyvs) Safefree(ysave->yyvs);
yydebug = ysave->oldyydebug;
yynerrs = ysave->oldyynerrs;
yyerrflag = ysave->oldyyerrflag;
yychar = ysave->oldyychar;
yyval = ysave->oldyyval;
yylval = ysave->oldyylval;
Safefree(ysave);
}
--- NEW FILE: vms_yfix.pl ---
# This script takes the output produced from perly.y by byacc and
# the perly.fixer shell script (i.e. the perly.c and perly.h built
# for Unix systems) and patches them to produce copies containing
# appropriate declarations for VMS handling of global symbols.
#
# If it finds that the input files are already patches for VMS,
# it just copies the input to the output.
#
# Revised 20-Dec-1996 by Charles Bailey bailey at newman.upenn.edu
$VERSION = '1.11';
push(@ARGV,(qw[ perly.c perly.h vms/perly_c.vms vms/perly_h.vms])[@ARGV..4])
if @ARGV < 4;
($cinfile,$hinfile,$coutfile,$houtfile) = @ARGV;
open C,$cinfile or die "Can't read $cinfile: $!\n";
open COUT, ">$coutfile" or die "Can't create $coutfile: $!\n";
print COUT <<EOH;
/* Postprocessed by vms_yfix.pl $VERSION to add VMS declarations of globals */
EOH
while (<C>) {
# "y.tab.c" is illegal as a VMS filename; DECC 5.2/VAX preprocessor
# doesn't like this.
if ( s/^#line\s+(\d+)\s+"y.tab.c"/#line $1 "y_tab.c"/ ) { 1; }
elsif (/char \*getenv/) {
# accomodate old VAXC's macro susbstitution pecularities
$_ = "# ifndef getenv\n$_# endif\n";
}
elsif ( /getenv\("YYDEBUG"\)/ ) {
$_ = " {\n register int saved_errno = errno;\n"
. "#ifdef VMS\n register int saved_vaxc_errno = vaxc\$errno;\n"
. "#else\n register int saved_vaxc_errno = 0;\n#endif\n" . $_;
# Reset the "error" status if an optional lookup fails
while (not /^\s+\}/) { print COUT; $_ = <C>; }
$_ .= " else SETERRNO(saved_errno,saved_vaxc_errno);\n }\n";
}
else {
# add the dEXT tag to definitions of global vars, so we'll insert
# a globaldef when perly.c is compiled
s/^(short|int|YYSTYPE|char \*)\s*yy/dEXT $1 yy/;
}
print COUT;
}
close C;
close COUT;
open H,$hinfile or die "Can't read $hinfile: $!\n";
open HOUT, ">$houtfile" or die "Can't create $houtfile: $!\n";
print HOUT <<EOH;
/* Postprocessed by vms_yfix.pl $VERSION to add VMS declarations of globals */
EOH
$hfixed = 0; # keep -w happy
while (<H>) {
$hfixed = /globalref/ unless $hfixed; # we've already got a fixed copy
next if /^extern YYSTYPE yylval/; # we've got a Unix version, and this
# is what we want to replace
print HOUT;
}
close H;
print HOUT <<'EODECL' unless $hfixed;
#ifndef vax11c
extern YYSTYPE yylval;
#else
globalref YYSTYPE yylval;
#endif
EODECL
close HOUT;
--- NEW FILE: vms.c ---
/* vms.c
*
* VMS-specific routines for perl5
* Version: 5.7.0
*
* August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
* and Perl_cando by Craig Berry
* 29-Aug-2000 Charles Lane's piping improvements rolled in
* 20-Aug-1999 revisions by Charles Bailey bailey at newman.upenn.edu
*/
#include <acedef.h>
#include <acldef.h>
#include <armdef.h>
#include <atrdef.h>
#include <chpdef.h>
#include <clidef.h>
#include <climsgdef.h>
#include <descrip.h>
[...7517 lines suppressed...]
}
newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
store_pipelocs(aTHX); /* will redo any earlier attempts */
return;
}
/* End of vms.c */
--- NEW FILE: munchconfig.c ---
/* munchconfig.c
A very, very (very!) simple program to process a config_h.sh file on
non-unix systems.
usage:
munchconfig config.sh config_h.sh [foo=bar [baz=xyzzy [...]]] >config.h
which is to say, it takes as its firt parameter a config.sh (or
equivalent), as its second a config_h.sh (or equvalent), and a list of
optional tag=value pairs.
It spits the processed config.h out to STDOUT.
*/
#include <stdio.h>
#include <errno.h>
#include <stdlib.h>
#include <string.h>
#include <ctype.h>
/* The failure code to exit with */
#ifndef EXIT_FAILURE
#ifdef VMS
#define EXIT_FAILURE 0
#else
#define EXIT_FAILURE -1
#endif
#endif
/* The biggest line we can read in from a file */
#define LINEBUFFERSIZE 1024
#define NUMTILDESUBS 30
#define NUMCONFIGSUBS 1000
#define TOKENBUFFERSIZE 80
typedef struct {
char Tag[TOKENBUFFERSIZE];
char Value[512];
} Translate;
void tilde_sub(char [], Translate [], int);
int
main(int argc, char *argv[])
{
FILE *ConfigSH, *Config_H;
char LineBuffer[LINEBUFFERSIZE], *TempValue, *StartTilde, *EndTilde;
char SecondaryLineBuffer[LINEBUFFERSIZE], OutBuf[LINEBUFFERSIZE];
char TokenBuffer[TOKENBUFFERSIZE];
int LineBufferLength, TempLength, DummyVariable, LineBufferLoop;
int TokenBufferLoop, ConfigSubLoop, GotIt, OutBufPos;
Translate TildeSub[NUMTILDESUBS]; /* Holds the tilde (~FOO~) */
/* substitutions */
Translate ConfigSub[NUMCONFIGSUBS]; /* Holds the substitutions from */
/* config.sh */
int TildeSubCount = 0, ConfigSubCount = 0; /* # of tilde substitutions */
/* and config substitutions, */
/* respectively */
if (argc < 3) {
printf("Usage: munchconfig config.sh config_h.sh [foo=bar [baz=xyzzy [...]]]\n");
exit(EXIT_FAILURE);
}
/* First, open the input files */
if (NULL == (ConfigSH = fopen(argv[1], "r"))) {
printf("Error %i trying to open config.sh file %s\n", errno, argv[1]);
exit(EXIT_FAILURE);
}
if (NULL == (Config_H = fopen(argv[2], "r"))) {
printf("Error %i trying to open config_h.sh file %s\n", errno, argv[2]);
exit(EXIT_FAILURE);
}
/* Any tag/value pairs on the command line? */
if (argc > 3) {
int i;
char WorkString[LINEBUFFERSIZE];
for (i=3; i < argc && argv[i]; i++) {
/* Local copy */
strcpy(WorkString, argv[i]);
/* Stick a NULL over the = */
TempValue = strchr(WorkString, '=');
*TempValue++ = '\0';
/* Copy the tag and value into the holding array */
strcpy(TildeSub[TildeSubCount].Tag, WorkString);
strcpy(TildeSub[TildeSubCount].Value, TempValue);
TildeSubCount++;
}
}
/* Now read in the config.sh file. */
while(fgets(LineBuffer, LINEBUFFERSIZE - 1, ConfigSH)) {
/* Force a trailing null, just in case */
LineBuffer[LINEBUFFERSIZE - 1] = '\0';
LineBufferLength = strlen(LineBuffer);
/* Chop trailing control characters */
while((LineBufferLength > 0) && (LineBuffer[LineBufferLength-1] < ' ')) {
LineBuffer[LineBufferLength - 1] = '\0';
LineBufferLength--;
}
/* If it's empty, then try again */
if (!*LineBuffer)
continue;
/* If the line begins with a '#' or ' ', skip */
if ((LineBuffer[0] == ' ') || (LineBuffer[0] == '#'))
continue;
/* We've got something. Guess we need to actually handle it */
/* Do the tilde substitution */
tilde_sub(LineBuffer, TildeSub, TildeSubCount);
/* Stick a NULL over the = */
TempValue = strchr(LineBuffer, '=');
*TempValue++ = '\0';
/* And another over the leading ', which better be there */
*TempValue++ = '\0';
/* Check to see if there's a trailing ' or ". If not, add a newline to
the buffer and grab another line. */
TempLength = strlen(TempValue);
while ((TempValue[TempLength-1] != '\'') &&
(TempValue[TempLength-1] != '"')) {
fgets(SecondaryLineBuffer, LINEBUFFERSIZE - 1, ConfigSH);
/* Force a trailing null, just in case */
SecondaryLineBuffer[LINEBUFFERSIZE - 1] = '\0';
/* Go substitute */
tilde_sub(SecondaryLineBuffer, TildeSub, TildeSubCount);
/* Tack a nweline on the end of our primary buffer */
strcat(TempValue, "\n");
/* Concat the new line we just read */
strcat(TempValue, SecondaryLineBuffer);
/* Refigure the length */
TempLength = strlen(TempValue);
/* Chop trailing control characters */
while((TempLength > 0) && (TempValue[TempLength-1] < ' ')) {
TempValue[TempLength - 1] = '\0';
TempLength--;
}
}
/* And finally one over the trailing ' */
TempValue[TempLength-1] = '\0';
/* Is there even anything left? */
if(*TempValue) {
/* Copy the tag over */
strcpy(ConfigSub[ConfigSubCount].Tag, LineBuffer);
/* Copy the value over */
strcpy(ConfigSub[ConfigSubCount].Value, TempValue);
/* Up the count */
ConfigSubCount++;
}
}
/* Okay, we've read in all the substititions from our config.sh */
/* equivalent. Read in the config_h.sh equiv and start the substitution */
/* First, eat all the lines until we get to one with !GROK!THIS! in it */
while(!strstr(fgets(LineBuffer, LINEBUFFERSIZE, Config_H),
"!GROK!THIS!")) {
/* Dummy statement to shut up any compiler that'll whine about an empty */
/* loop */
DummyVariable++;
}
/* Right, we've read all the lines through the first one with !GROK!THIS! */
/* in it. That gets us through the beginning stuff. Now start in earnest */
/* with our translations, which run until we get to another !GROK!THIS! */
while(!strstr(fgets(LineBuffer, LINEBUFFERSIZE, Config_H),
"!GROK!THIS!")) {
/* Force a trailing null, just in case */
LineBuffer[LINEBUFFERSIZE - 1] = '\0';
/* Tilde Substitute */
tilde_sub(LineBuffer, TildeSub, TildeSubCount);
LineBufferLength = strlen(LineBuffer);
/* Chop trailing control characters */
while((LineBufferLength > 0) && (LineBuffer[LineBufferLength-1] < ' ')) {
LineBuffer[LineBufferLength - 1] = '\0';
LineBufferLength--;
}
OutBufPos = 0;
/* Right. Go looking for $s. */
for(LineBufferLoop = 0; LineBufferLoop < LineBufferLength;
LineBufferLoop++) {
/* Did we find one? */
if ('$' != LineBuffer[LineBufferLoop]) {
/* Nope, spit out the value */
OutBuf[OutBufPos++] = LineBuffer[LineBufferLoop];
} else {
/* Yes, we did. Is it escaped? */
if ((LineBufferLoop > 0) && ('\\' == LineBuffer[LineBufferLoop -
1])) {
/* Yup. Spit it out */
OutBuf[OutBufPos++] = LineBuffer[LineBufferLoop];
} else {
/* Nope. Go grab us a token */
TokenBufferLoop = 0;
/* Advance to the next character in the input stream */
LineBufferLoop++;
while((LineBufferLoop < LineBufferLength) &&
((isalnum(LineBuffer[LineBufferLoop]) || ('_' ==
LineBuffer[LineBufferLoop])))) {
TokenBuffer[TokenBufferLoop] = LineBuffer[LineBufferLoop];
LineBufferLoop++;
TokenBufferLoop++;
}
/* Trailing null on the token buffer */
TokenBuffer[TokenBufferLoop] = '\0';
/* Back the line buffer pointer up one */
LineBufferLoop--;
/* Right, we're done grabbing a token. Check to make sure we got */
/* something */
if (TokenBufferLoop) {
/* Well, we do. Run through all the tokens we've got in the */
/* ConfigSub array and see if any match */
GotIt = 0;
for(ConfigSubLoop = 0; ConfigSubLoop < ConfigSubCount;
ConfigSubLoop++) {
if (!strcmp(TokenBuffer, ConfigSub[ConfigSubLoop].Tag)) {
char *cp = ConfigSub[ConfigSubLoop].Value;
GotIt = 1;
while (*cp) OutBuf[OutBufPos++] = *(cp++);
break;
}
}
/* Did we find something? If not, spit out what was in our */
/* buffer */
if (!GotIt) {
char *cp = TokenBuffer;
OutBuf[OutBufPos++] = '$';
while (*cp) OutBuf[OutBufPos++] = *(cp++);
}
} else {
/* Just a bare $. Spit it out */
OutBuf[OutBufPos++] = '$';
}
}
}
}
/* If we've created an #undef line, make sure we don't output anthing
* after the "#undef FOO" besides comments. We could do this as we
* go by recognizing the #undef as it goes by, and thus avoid another
* use of a fixed-length buffer, but this is simpler.
*/
if (!strncmp(OutBuf,"#undef",6)) {
char *cp = OutBuf;
int i, incomment = 0;
LineBufferLoop = 0;
OutBuf[OutBufPos] = '\0';
for (i = 0; i <= 1; i++) {
while (!isspace(*cp)) LineBuffer[LineBufferLoop++] = *(cp++);
while ( isspace(*cp)) LineBuffer[LineBufferLoop++] = *(cp++);
}
while (*cp) {
while (isspace(*cp)) LineBuffer[LineBufferLoop++] = *(cp++);
if (!incomment && *cp == '/' && *(cp+1) == '*') incomment = 1;
while (*cp && !isspace(*cp)) {
if (incomment) LineBuffer[LineBufferLoop++] = *cp;
cp++;
}
if (incomment && *cp == '*' && *(cp+1) == '/') incomment = 0;
}
LineBuffer[LineBufferLoop] = '\0';
puts(LineBuffer);
}
else {
OutBuf[OutBufPos] = '\0';
puts(OutBuf);
}
}
/* Close the files */
fclose(ConfigSH);
fclose(Config_H);
}
void
tilde_sub(char LineBuffer[], Translate TildeSub[], int TildeSubCount)
{
char TempBuffer[LINEBUFFERSIZE], TempTilde[TOKENBUFFERSIZE];
int TildeLoop, InTilde, CopiedBufferLength, TildeBufferLength, k, GotIt;
int TempLength;
InTilde = 0;
CopiedBufferLength = 0;
TildeBufferLength = 0;
TempLength = strlen(LineBuffer);
/* Grovel over our input looking for ~foo~ constructs */
for(TildeLoop = 0; TildeLoop < TempLength; TildeLoop++) {
/* Are we in a tilde? */
if (InTilde) {
/* Yup. Is the current character a tilde? */
if (LineBuffer[TildeLoop] == '~') {
/* Yup. That means we're ready to do a substitution */
InTilde = 0;
GotIt = 0;
/* Trailing null */
TempTilde[TildeBufferLength] = '\0';
for( k=0; k < TildeSubCount; k++) {
if (!strcmp(TildeSub[k].Tag, TempTilde)) {
GotIt = 1;
/* Tack on the trailing null to the main buffer */
TempBuffer[CopiedBufferLength] = '\0';
/* Copy the tilde substitution over */
strcat(TempBuffer, TildeSub[k].Value);
CopiedBufferLength = strlen(TempBuffer);
}
}
/* Did we find anything? */
if (GotIt == 0) {
/* Guess not. Copy the whole thing out verbatim */
TempBuffer[CopiedBufferLength] = '\0';
TempBuffer[CopiedBufferLength++] = '~';
TempBuffer[CopiedBufferLength] = '\0';
strcat(TempBuffer, TempTilde);
strcat(TempBuffer, "~");
CopiedBufferLength = strlen(TempBuffer);
}
} else {
/* 'Kay, not a tilde. Is it a word character? */
if (isalnum(LineBuffer[TildeLoop]) ||
(LineBuffer[TildeLoop] == '-')) {
TempTilde[TildeBufferLength++] = LineBuffer[TildeLoop];
} else {
/* No, it's not a tilde character. For shame! We've got a */
/* bogus token. Copy a ~ into the output buffer, then append */
/* whatever we've got in our token buffer */
TempBuffer[CopiedBufferLength++] = '~';
TempBuffer[CopiedBufferLength] = '\0';
TempTilde[TildeBufferLength] = '\0';
strcat(TempBuffer, TempTilde);
CopiedBufferLength += TildeBufferLength;
InTilde = 0;
}
}
} else {
/* We're not in a tilde. Do we want to be? */
if (LineBuffer[TildeLoop] == '~') {
/* Guess so */
InTilde = 1;
TildeBufferLength = 0;
} else {
/* Nope. Copy the character to the output buffer */
TempBuffer[CopiedBufferLength++] = LineBuffer[TildeLoop];
}
}
}
/* Out of the loop. First, double-check to see if there was anything */
/* pending. */
if (InTilde) {
/* bogus token. Copy a ~ into the output buffer, then append */
/* whatever we've got in our token buffer */
TempBuffer[CopiedBufferLength++] = '~';
TempBuffer[CopiedBufferLength] = '\0';
TempTilde[TildeBufferLength] = '\0';
strcat(TempBuffer, TempTilde);
CopiedBufferLength += TildeBufferLength;
} else {
/* Nope, nothing pensing. Tack on a \0 */
TempBuffer[CopiedBufferLength] = '\0';
}
/* Okay, we're done. Copy the temp buffer back into the line buffer */
strcpy(LineBuffer, TempBuffer);
}
--- NEW FILE: descrip_mms.template ---
!GROK!THIS!
# Descrip.MMS for perl5 on VMS
# Last revised 5-Dec-2001 by Craig Berry -- craigberry at mac.com
#
#: 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
#: a Unix-style MAKE tool, run this file through mms2make.pl, which should
#: be found in the same directory as this file.
#:
#: Lines beginning with "#:" will be removed by mms2make.pl when converting
#: this file to MAKE syntax.
#
# tidy -- purge files generated by executing this file
# clean -- remove all intermediate (e.g. object files, C files generated
# during build) files generated by executing this file,
# but leave `installable' files (images, library) intact
# realclean -- remove all files generated by executing this file
# cleansrc -- `realclean' + purge *.c,*.h,descrip.mms
# crtl.opt -- compiler-specific linker options file (made automatically)
[...1716 lines suppressed...]
- If F$Search("[...]*$(E)").nes."" Then Delete/NoConfirm/Log [...]*$(E);*
- If F$Search("[.vms]Perl_Setup.Com").nes."" Then Delete/NoConfirm/Log [.vms]Perl_Setup.Com;*
- If F$Search("[.t]rantests.").nes."" Then Delete/NoConfirm/Log [.t]rantests.;*
- If F$Search("[.t.lib]vmsfspec.t").nes."" Then Delete/NoConfirm/Log [.t.lib]vmsfspec.t;*
- If F$Search("[.t.lib]vmsish.t").nes."" Then Delete/NoConfirm/Log [.t.lib]vmsish.t;*
- If F$Search("[.t.lib]vms_dclsym.t").nes."" Then Delete/NoConfirm/Log [.t.lib]vms_dclsym.t;*
- If F$Search("[.t.lib]vms_stdio.t").nes."" Then Delete/NoConfirm/Log [.t.lib]vms_stdio.t;*
cleansrc : clean
- If F$Search("*.C;-1").nes."" Then Purge/NoConfirm/Log *.C
- If F$Search("*.H;-1").nes."" Then Purge/NoConfirm/Log *.H
- If F$Search("*.VMS;-1").nes."" Then Purge/NoConfirm/Log *.VMS
- If F$Search("[.VMS]$(MAKEFILE);-1").nes."" Then Purge/NoConfirm/Log [.VMS]$(MAKEFILE)
- If F$Search("[.VMS]*.C;-1").nes."" Then Purge/NoConfirm/Log [.VMS]*.C
- If F$Search("[.VMS]*.H;-1").nes."" Then Purge/NoConfirm/Log [.VMS]*.H
- If F$Search("[.VMS]*.Pl;-1").nes."" Then Purge/NoConfirm/Log [.VMS]*.Pl
- If F$Search("[.VMS]*.VMS;-1").nes."" Then Purge/NoConfirm/Log [.VMS]*.VMS
- If F$Search("[.VMS...]*.pm;-1").nes."" Then Purge/NoConfirm/Log [.VMS...]*.pm
- If F$Search("[.VMS...]*.xs;-1").nes."" Then Purge/NoConfirm/Log [.VMS...]*.xs
!GROK!THIS!
--- NEW FILE: test.com ---
$! Test.Com - DCL wrapper for perl5 regression test driver
$!
$! Version 2.0 25-April-2002 Craig Berry craigberry at mac.com
$! (and many other hands in the last 7+ years)
$! The most significant difference is that we now run the external t/TEST
$! rather than keeping a separately maintained test driver embedded here.
$!
$! Version 1.1 4-Dec-1995
$! Charles Bailey bailey at newman.upenn.edu
$!
$! Set up error handler and save things we'll restore later.
$ On Control_Y Then Goto Control_Y_exit
$ On Error Then Goto wrapup
$ olddef = F$Environment("Default")
$ oldmsg = F$Environment("Message")
$ oldpriv = F$SetPrv("NOALL") ! downgrade privs for safety
$ discard = F$SetPrv("NETMBX,TMPMBX") ! only need these to run tests
$!
$! Process arguments. P1 is the file extension of the Perl images.
$! P2, when not empty, indicates that we are testing a version of Perl built
$! for the VMS debugger. The other arguments are passed directly to t/TEST.
$!
$ exe = ".Exe"
$ If p1.nes."" Then exe = p1
$ If F$Extract(0,1,exe) .nes. "."
$ Then
$ Write Sys$Error ""
$ Write Sys$Error "The first parameter passed to Test.Com must be the file type used for the"
$ Write Sys$Error "images produced when you built Perl (i.e. "".Exe"", unless you edited"
$ Write Sys$Error "Descrip.MMS or used the AXE=1 macro in the MM[SK] command line."
$ Write Sys$Error ""
$ $status = 44
$ goto wrapup
$ EndIf
$!
$! "debug" perl if second parameter is nonblank
$!
$ dbg = ""
$ ndbg = ""
$ if p2.nes."" then dbg = "dbg"
$ if p2.nes."" then ndbg = "ndbg"
$!
$! Run using "TEST." unless something else (e.g. "harness.") was specified.
$ If F$Type(PERL_TEST_DRIVER) .eqs. "" Then PERL_TEST_DRIVER == "TEST."
$!
$! Make sure we are where we need to be.
$ If F$Search("t.dir").nes.""
$ Then
$ Set Default [.t]
$ Else
$ If F$TrnLNm("Perl_Root").nes.""
$ Then
$ Set Default Perl_Root:[t]
$ Else
$ Write Sys$Error "Can't find test directory"
$ $status = 44
$ goto wrapup
$ EndIf
$ EndIf
$!
$! Pick up a copy of perl to use for the tests
$ If F$Search("Perl.").nes."" Then Delete/Log/NoConfirm Perl.;*
$ If PERL_TEST_DRIVER .eqs. "minitest"
$ Then
$ Copy/Log/NoConfirm [-]miniperl'exe' []Perl.
$ Else
$ Copy/Log/NoConfirm [-]'ndbg'Perl'exe' []Perl.
$ EndIf
$!
$! Pick up a copy of vmspipe.com to use for the tests
$ If F$Search("VMSPIPE.COM").nes."" then Delete/Log/Noconfirm VMSPIPE.COM;*
$ Copy/Log/NoConfirm [-]VMSPIPE.COM []
$!
$! This may be set for the C compiler in descrip.mms, but it confuses the File::Find tests
$ if f$trnlnm("sys") .nes. "" then Define sys " "
$!
$! And do it
$ Set Message /NoFacility/NoSeverity/NoIdentification/NoText
$ Show Process/Accounting
$ testdir = "Directory/NoHead/NoTrail/Column=1"
$ PerlShr_filespec = f$parse("Sys$Disk:[-]''dbg'PerlShr''exe'")
$ Define 'dbg'Perlshr 'PerlShr_filespec'
$ If F$Mode() .nes. "INTERACTIVE" Then Define/Nolog PERL_SKIP_TTY_TEST 1
$ If PERL_TEST_DRIVER .eqs. "minitest"
$ Then
$ MCR Sys$Disk:[]Perl. TEST. "-minitest" "base/*.t" "comp/*.t" "cmd/*.t" "run/*.t" "io/*.t" "op/*.t" "uni/*.t"
$ Else
$ MCR Sys$Disk:[]Perl. "-I[-.lib]" 'PERL_TEST_DRIVER' "''p3'" "''p4'" "''p5'" "''p6'" "''p7'"
$ EndIf
$ goto wrapup
$!
$ Control_Y_exit:
$ $status = 1552 ! %SYSTEM-W-CONTROLY
$!
$ wrapup:
$ status = $status
$ If f$trnlnm("''dbg'PerlShr") .nes. "" Then DeAssign 'dbg'PerlShr
$ Show Process/Accounting
$ If f$type(olddef) .nes. "" Then Set Default &olddef
$ If f$type(oldmsg) .nes. "" Then Set Message 'oldmsg'
$ If f$type(oldpriv) .nes. "" Then discard = F$SetPrv(oldpriv)
$ Exit status
More information about the dslinux-commit
mailing list