The VM/ESA port essentials, based on
authorJarkko Hietaniemi <jhi@iki.fi>
Sat, 17 Oct 1998 13:43:54 +0000 (13:43 +0000)
committerJarkko Hietaniemi <jhi@iki.fi>
Sat, 17 Oct 1998 13:43:54 +0000 (13:43 +0000)
perl-mvs:

From: Neale Ferguson <neale@VMA.TABNSW.COM.AU>
Subject: Re: Can't find Data/Dumper.pm
Date: Mon, 28 Sep 1998 07:40:49 +1300
Message-ID: <360E86B0.23847AF4@mailbox.tabnsw.com.au>

private email:

From: Neale Ferguson <neale@VMA.TABNSW.COM.AU>
Subject: Re: Perl thread problems in VM/ESA
Date: Thu, 15 Oct 1998 07:18:35 +1300
Message-ID: <3624EAFA.16163A2B@mailbox.tabnsw.com.au>

and private email:

From: Neale Ferguson <NEALE@PUCC.PRINCETON.EDU>
Subject:  perl archive
Date:  Sun, 11 Oct 1998 19:28:54 EDT
Message-Id: <19981011233112Z67215-26626+1513@outbound.Princeton.EDU>
which gave a pointer to

http://pucc.princeton.edu/~neale/perl.tar

(based on Perl 5.005_51)

p4raw-id: //depot/cfgperl@2006

18 files changed:
ext/Errno/Errno_pm.PL
hints/vmesa.sh [new file with mode: 0644]
perl.c
perl.h
perly.y
pp_sys.c
t/io/pipe.t
t/lib/cgi-html.t
t/lib/ipc_sysv.t
t/op/magic.t
t/op/pack.t
t/op/quotemeta.t
t/op/subst.t
util.c
vmesa/Makefile [new file with mode: 0644]
vmesa/vmesa.c [new file with mode: 0644]
vmesa/vmesaish.h [new file with mode: 0644]
x2p/a2p.h

index 0d3ca75..286dbc6 100644 (file)
@@ -58,6 +58,9 @@ sub get_files {
     } elsif ($^O eq 'os390') {
        # OS/390 C compiler doesn't generate #file or #line directives
        $file{'/usr/include/errno.h'} = 1;
+    } elsif ($^O eq 'vmesa') {
+       # OS/390 C compiler doesn't generate #file or #line directives
+       $file{'../../vmesa/errno.h'} = 1;
     } else {
        open(CPPI,"> errno.c") or
            die "Cannot open errno.c";
diff --git a/hints/vmesa.sh b/hints/vmesa.sh
new file mode 100644 (file)
index 0000000..29d9bf0
--- /dev/null
@@ -0,0 +1,333 @@
+# hints/vmesa.sh
+#
+# VM/ESA hints by Neale Ferguson (neale@mailbox.tabnsw.com.au)
+case "$archname" in
+'') archname="$osname" ;;
+esac
+bin='/usr/local/bin'
+binexp='/usr/local/bin'
+byacc='byacc'
+c='\c'
+cc='c89'
+ccflags="-D_OE_SOCKETS -DOLD_PTHREADS_API -DYYDYNAMIC -DDEBUGGING -I.." \
+       "-I/usr/local/include -W c,hwopts\\\(string\\\),langlvl\\\(ansi\\\)"
+clocktype='clock_t'
+cryptlib="n"
+d_Gconvert='gcvt((x),(n),(b))'
+d_access='define'
+d_alarm='define'
+d_archlib='define'
+# randbits='15'
+archobjs="ebcdic.o vmesa.o"
+d_attribut='undef'
+d_bcmp='define'
+d_bcopy='define'
+d_bsd='undef'
+d_bsdgetpgrp='undef'
+d_bsdsetpgrp='undef'
+d_bzero='define'
+d_casti32='define'
+d_castneg='define'
+d_charvspr='undef'
+d_chown='define'
+d_chroot='undef'
+d_chsize='undef'
+d_closedir='define'
+d_const='define'
+d_crypt='undef'
+d_csh='undef'
+d_cuserid='define'
+d_dbl_dig='define'
+d_difftime='define'
+d_dirnamlen='undef'
+d_dlerror='define'
+d_dlopen='define'
+d_dlsymun='define'
+d_dosuid='undef'
+d_dup2='define'
+d_endgrent='undef'
+d_endpwent='undef'
+d_eofnblk='define'
+d_eunice='undef'
+d_fchmod='define'
+d_fchown='define'
+d_fcntl='define'
+d_fd_macros='define'
+d_fd_set='define'
+d_fds_bits='define'
+d_fgetpos='define'
+d_flexfnam='define'
+d_flock='undef'
+d_fork='undef'
+d_fpathconf='define'
+d_fsetpos='define'
+d_ftime='undef'
+d_getgrent='undef'
+d_gethent='define'
+d_gethname='undef'
+d_getlogin='define'
+d_getpgid='undef'
+d_getpgrp='define'
+d_getpgrp2='undef'
+d_getppid='define'
+d_getprior='undef'
+d_getpwent='undef'
+d_gettimeod='define'
+d_gnulibc='undef'
+d_htonl='define'
+d_index='define'
+d_inetaton='undef'
+d_isascii='define'
+d_killpg='define'
+d_link='define'
+d_locconv='define'
+d_lockf='define'
+d_longdbl='undef'
+d_longllong='undef'
+d_lstat='define'
+d_mblen='define'
+d_mbstowcs='define'
+d_mbtowc='define'
+d_memcmp='define'
+d_memcpy='define'
+d_memmove='define'
+d_memset='define'
+d_mkdir='define'
+d_mkfifo='define'
+d_mktime='define'
+d_msg='define'
+d_msgctl='define'
+d_msgget='define'
+d_msgrcv='define'
+d_msgsnd='define'
+d_mymalloc='undef'
+d_nice='undef'
+d_oldsock='undef'
+d_open3='define'
+d_pathconf='define'
+d_pause='define'
+d_phostname='undef'
+d_pipe='define'
+d_poll='undef'
+d_portable='define'
+d_pwage='undef'
+d_pwchange='undef'
+d_pwclass='undef'
+d_pwcomment='undef'
+d_pwexpire='undef'
+d_pwquota='undef'
+d_readdir='define'
+d_readlink='define'
+d_rename='define'
+d_rewinddir='define'
+d_rmdir='define'
+d_safebcpy='define'
+d_safemcpy='undef'
+d_sanemcmp='define'
+d_sched_yield='undef'
+d_seekdir='undef'
+d_select='define'
+d_sem='define'
+d_semctl='define'
+d_semctl_semid_ds='define'
+d_semget='define'
+d_semop='define'
+d_setegid='define'
+d_seteuid='define'
+d_setgrent='undef'
+d_setgrps='undef'
+d_setlinebuf='undef'
+d_setlocale='define'
+d_setpgid='define'
+d_setpgrp='define'
+d_setpgrp2='undef'
+d_setprior='undef'
+d_setpwent='undef'
+d_setregid='undef'
+d_setresgid='undef'
+d_setresuid='undef'
+d_setreuid='undef'
+d_setrgid='undef'
+d_setruid='undef'
+d_setsid='define'
+d_sfio='undef'
+d_shm='define'
+d_shmat='define'
+d_shmatprototype='define'
+d_shmctl='define'
+d_shmdt='define'
+d_shmget='define'
+d_sigaction='define'
+d_sigsetjmp='define'
+d_socket='define'
+d_sockpair='undef'
+d_statblks='undef'
+d_stdio_cnt_lval='undef'
+d_stdio_ptr_lval='undef'
+d_stdiobase='undef'
+d_stdstdio='undef'
+d_strchr='define'
+d_strcoll='define'
+d_strctcpy='undef'
+d_strerrm='strerror(e)'
+d_strerror='define'
+d_strtod='define'
+d_strtol='define'
+d_strtoul='define'
+d_strxfrm='define'
+d_suidsafe='undef'
+d_symlink='define'
+d_syscall='undef'
+d_sysconf='define'
+d_sysernlst="n"
+d_syserrlst='undef'
+d_system='define'
+d_tcgetpgrp='define'
+d_tcsetpgrp='define'
+d_telldir='undef'
+d_time='define'
+d_times='define'
+d_truncate='define'
+d_tzname='define'
+d_umask='define'
+d_uname='define'
+d_union_semun='undef'
+d_vfork='define'
+d_void_closedir='undef'
+d_voidsig='define'
+d_voidtty="n"
+d_volatile='define'
+d_vprintf='define'
+d_waitpid='define'
+d_wait4='undef'
+d_wcstombs='define'
+d_wctomb='define'
+d_xenix='undef'
+db_hashtype='u_int32_t'
+db_prefixtype='size_t'
+direntrytype='struct dirent'
+dlext='none'
+dlsrc='dl_vmesa.xs'
+dynamic_ext=''
+eagain='EAGAIN'
+ebcdic='define'
+exe_ext=''
+extensions='Fcntl GDBM_File IO NDBM_File Opcode POSIX Socket IPC/SysV Errno Thread attrs re Data/dumper'
+fpostype='fpos_t'
+freetype='void'
+groupstype='gid_t'
+h_fcntl='false'
+h_sysfile='true'
+hint='recommended'
+i_arpainet="define"
+i_bsdioctl="n"
+i_db='undef'
+i_dbm='define'
+i_dirent='define'
+i_dld='define'
+i_dlfcn='define'
+i_fcntl='undef'
+i_float='define'
+i_gdbm='define'
+i_grp='define'
+i_limits='define'
+i_locale='define'
+i_malloc='undef'
+i_math='define'
+i_memory='define'
+i_ndbm='define'
+i_neterrno='undef'
+i_niin='define'
+i_pwd='define'
+i_rpcsvcdbm='undef'
+i_sfio='undef'
+i_sgtty='undef'
+i_stdarg='define'
+i_stddef='define'
+i_stdlib='define'
+i_string='define'
+i_sysdir='define'
+i_sysfile='define'
+i_sysfilio='undef'
+i_sysin='undef'
+i_sysioctl='define'
+i_sysndir='undef'
+i_sysparam='undef'
+i_sysresrc='define'
+i_sysselct='undef'
+i_syssockio="n"
+i_sysstat='define'
+i_systime='define'
+i_systimek='undef'
+i_systimes='define'
+i_systypes='define'
+i_sysun='define'
+i_syswait='define'
+i_termio='undef'
+i_termios='define'
+i_time='undef'
+i_unistd='define'
+i_utime='define'
+i_values='undef'
+i_varargs='undef'
+i_varhdr='stdarg.h'
+i_vfork='undef'
+ld='c89'
+ldflags='-L/usr/local/lib -L.'
+lib_ext='.a'
+libc=''
+libperl='libperl.a'
+libpth='/usr/local/lib /lib /usr/lib'
+libs='-l//posxsock -l//vmmtlib -lgdbm -lxpg4'
+libswanted='gdbm'
+lint="n"
+locincpth='/usr/local/include /opt/local/include /usr/gnu/include /opt/gnu/include /usr/GNU/include /opt/GNU/include'
+loclibpth='/usr/local/lib /opt/local/lib /usr/gnu/lib /opt/gnu/lib /usr/GNU/lib /opt/GNU/lib'
+make_set_make='#'
+make='gnumake'
+mallocobj=''
+mallocsrc=''
+malloctype='void *'
+models='none'
+netdb_hlen_type='size_t'
+netdb_host_type='char *'
+netdb_name_type='const char *'
+netdb_net_type='in_addr_t'
+o_nonblock='O_NONBLOCK'
+obj_ext='.o'
+optimize='undef'
+prefix='/usr/local'
+prefixexp='/usr/local'
+prototype='define'
+ranlib=':'
+rd_nodata='-1'
+scriptdir='/usr/local/bin'
+scriptdirexp='/usr/local/bin'
+selecttype='fd_set *'
+shmattype='void *'
+shrpenv=''
+signal_t='void'
+sig_name_init='"ZERO","HUP","INT","ABRT","ILL","POLL","URG","STOP","FPE","KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM","USR1","USR2","NUM18","CONT","CHLD","TTIN","TTOU","IO","QUIT","TSTP","TRAP","NUM27","WINCH","XCPU","XFSZ","VTALRM","PROF","NUM33","NUM34","NUM35","NUM36","NUM3","NUM38","NUM39","NUM40","NUM41","NUM42","NUM43","NUM44","NUM45","NUM46","NUM47","NUM48","NUM49","CLD"'
+sig_num='0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,20 '
+sizetype='size_t'
+so='.a'
+ssizetype='ssize_t'
+static_ext='Data/Dumper Fcntl GDBM_File IO IPC/SysV NDBM_File Opcode POSIX Socket Thread attrs re'
+stdchar='char'
+stdio_cnt='(fp)->__countIn'
+stdio_ptr='(fp)->__bufPtr'
+timeincl='sys/time.h '
+timetype='time_t'
+uidtype='uid_t'
+usedl='define'
+usemymalloc='n'
+usenm='false'
+useopcode='true'
+useperlio='undef'
+useposix='true'
+usesfio='false'
+useshrplib='false'
+usethreads='y'
+usevfork='true'
+vi='x'
diff --git a/perl.c b/perl.c
index cb0e624..33a1667 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -1749,6 +1749,9 @@ moreswitches(char *s)
 #ifdef __VOS__
        printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1998\n");
 #endif
+#ifdef __OPEN_VM
+       printf("VM/ESA port by Neale Ferguson, 1998\n");
+#endif
 #ifdef BINARY_BUILD_NOTICE
        BINARY_BUILD_NOTICE;
 #endif
@@ -2008,6 +2011,21 @@ sed %s -e \"/^[^#]/b\" \
  %s | %_ -C %_ %s",
          (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
 #else
+#  ifdef __OPEN_VM
+       sv_setpvf(cmd, "\
+%s %s -e '/^[^#]/b' \
+ -e '/^#[      ]*include[      ]/b' \
+ -e '/^#[      ]*define[       ]/b' \
+ -e '/^#[      ]*if[   ]/b' \
+ -e '/^#[      ]*ifdef[        ]/b' \
+ -e '/^#[      ]*ifndef[       ]/b' \
+ -e '/^#[      ]*else/b' \
+ -e '/^#[      ]*elif[         ]/b' \
+ -e '/^#[      ]*undef[        ]/b' \
+ -e '/^#[      ]*endif/b' \
+ -e 's/^[      ]*#.*//' \
+ %s | %_ %_ %s",
+#  else
        sv_setpvf(cmd, "\
 %s %s -e '/^[^#]/b' \
  -e '/^#[      ]*include[      ]/b' \
@@ -2021,6 +2039,7 @@ sed %s -e \"/^[^#]/b\" \
  -e '/^#[      ]*endif/b' \
  -e 's/^[      ]*#.*//' \
  %s | %_ -C %_ %s",
+#  endif
 #ifdef LOC_SED
          LOC_SED,
 #else
diff --git a/perl.h b/perl.h
index 2871d80..bec75f7 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -339,11 +339,15 @@ register struct op *op asm(stringify(OP_IN_REGISTER));
 
 #ifdef USE_NEXT_CTYPE
 
-#if NX_CURRENT_COMPILER_RELEASE >= 400
-#include <objc/NXCType.h>
-#else /*  NX_CURRENT_COMPILER_RELEASE < 400 */
-#include <appkit/NXCType.h>
-#endif /*  NX_CURRENT_COMPILER_RELEASE >= 400 */
+#if NX_CURRENT_COMPILER_RELEASE >= 500
+#  include <bsd/ctypes.h>
+#else
+#  if NX_CURRENT_COMPILER_RELEASE >= 400
+#    include <objc/NXCType.h>
+#  else /*  NX_CURRENT_COMPILER_RELEASE < 400 */
+#    include <appkit/NXCType.h>
+#  endif /*  NX_CURRENT_COMPILER_RELEASE >= 400 */
+#endif /*  NX_CURRENT_COMPILER_RELEASE >= 500 */
 
 #else /* !USE_NEXT_CTYPE */
 #include <ctype.h>
@@ -1307,7 +1311,11 @@ typedef I32 (*filter_t) _((int, SV *, int));
 #       if defined(__VOS__)
 #         include "vosish.h"
 #       else
-#         include "unixish.h"
+#         if defined(__OPEN_VM)
+#           include "vmesa/vmesaish.h"
+#         else   
+#           include "unixish.h"
+#         endif
 #       endif
 #     endif
 #   endif
@@ -1693,7 +1701,7 @@ double atof _((const char*));
 /* All of these are in stdlib.h or time.h for ANSI C */
 Time_t time();
 struct tm *gmtime(), *localtime();
-#ifdef OEMVS
+#if defined(OEMVS) || defined(__OPEN_VM)
 char *(strchr)(), *(strrchr)();
 char *(strcpy)(), *(strcat)();
 #else
diff --git a/perly.y b/perly.y
index 47e6324..2c246fc 100644 (file)
--- a/perly.y
+++ b/perly.y
@@ -27,7 +27,7 @@ dep(void)
 %start prog
 
 %{
-#ifndef OEMVS
+#if !defined(OEMVS) && !defined(__OPEN_VM)
 %}
 
 %union {
@@ -38,7 +38,7 @@ dep(void)
 }
 
 %{
-#endif /* OEMVS */
+#endif /* !OEMVS && !__OPEN_VM*/
 %}
 
 %token <ival> '{' ')'
index 7fa4de2..4439b1c 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1467,6 +1467,13 @@ PP(pp_sysread)
 
 PP(pp_syswrite)
 {
+    djSP;
+    int items = (SP - PL_stack_base) - TOPMARK;
+    if (items == 2) {
+        EXTEND(SP, 1);
+        PUSHs(sv_2mortal(newSViv(sv_len(*SP))));
+        PUTBACK;
+    }
     return pp_send(ARGS);
 }
 
@@ -3448,7 +3455,14 @@ PP(pp_exec)
 #ifdef VMS
        value = (I32)vms_do_aexec(Nullsv, MARK, SP);
 #else
+#  ifdef __OPEN_VM
+       {
+          (void ) do_aspawn(Nullsv, MARK, SP);
+          value = 0;
+       }
+#  else
        value = (I32)do_aexec(Nullsv, MARK, SP);
+#  endif
 #endif
     else {
        if (PL_tainting) {
@@ -3459,7 +3473,12 @@ PP(pp_exec)
 #ifdef VMS
        value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), PL_na));
 #else
+#  ifdef __OPEN_VM
+       (void) do_spawn(SvPVx(sv_mortalcopy(*SP), PL_na));
+       value = 0;
+#  else
        value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), PL_na));
+#  endif
 #endif
     }
     SP = ORIGMARK;
index ba7a9b0..fc3c0e5 100755 (executable)
@@ -15,44 +15,54 @@ BEGIN {
 $| = 1;
 print "1..12\n";
 
+# External program 'tr' assumed.
 open(PIPE, "|-") || (exec 'tr', 'YX', 'ko');
 print PIPE "Xk 1\n";
 print PIPE "oY 2\n";
 close PIPE;
 
-if (open(PIPE, "-|")) {
-    while(<PIPE>) {
-       s/^not //;
-       print;
+if ($^O eq 'vmesa') {
+    # Doesn't work, yet.
+    print "ok 3\n";
+    print "ok 4\n";
+    print "ok 5\n";
+    print "ok 6\n";
+} else {
+    if (open(PIPE, "-|")) {
+       while(<PIPE>) {
+           s/^not //;
+           print;
+       }
+       close PIPE;        # avoid zombies which disrupt test 12
+    }
+    else {
+       # External program 'echo' assumed.
+       print STDOUT "not ok 3\n";
+       exec 'echo', 'not ok 4';
     }
-    close PIPE;        # avoid zombies which disrupt test 12
-}
-else {
-    print STDOUT "not ok 3\n";
-    exec 'echo', 'not ok 4';
-}
 
-pipe(READER,WRITER) || die "Can't open pipe";
+    pipe(READER,WRITER) || die "Can't open pipe";
 
-if ($pid = fork) {
-    close WRITER;
-    while(<READER>) {
-       s/^not //;
-       y/A-Z/a-z/;
-       print;
+    if ($pid = fork) {
+       close WRITER;
+       while(<READER>) {
+           s/^not //;
+           y/A-Z/a-z/;
+           print;
+       }
+       close READER;     # avoid zombies which disrupt test 12
+    }
+    else {
+       die "Couldn't fork" unless defined $pid;
+       close READER;
+       print WRITER "not ok 5\n";
+       open(STDOUT,">&WRITER") || die "Can't dup WRITER to STDOUT";
+       close WRITER;
+       # External program 'echo' assumed.
+       exec 'echo', 'not ok 6';
     }
-    close READER;     # avoid zombies which disrupt test 12
-}
-else {
-    die "Couldn't fork" unless defined $pid;
-    close READER;
-    print WRITER "not ok 5\n";
-    open(STDOUT,">&WRITER") || die "Can't dup WRITER to STDOUT";
-    close WRITER;
-    exec 'echo', 'not ok 6';
 }
 
-
 pipe(READER,WRITER) || die "Can't open pipe";
 close READER;
 
@@ -99,6 +109,14 @@ else {
     }
 }
 
+if ($^O eq 'vmesa') {
+    # These don't work, yet.
+    print "ok 10\n";
+    print "ok 11\n";
+    print "ok 12\n";
+    exit;
+}
+
 # check that errno gets forced to 0 if the piped program exited non-zero
 open NIL, '|exit 23;' or die "fork failed: $!";
 $! = 1;
index 16aa824..9d11946 100755 (executable)
@@ -10,7 +10,7 @@ BEGIN {
 
 BEGIN {$| = 1; print "1..17\n"; }
 BEGIN {$eol = $^O eq 'VMS' ? "\n" : "\cM\cJ";
-       $eol = "\r\n" if $^O eq 'os390'; }
+       $eol = "\r\n" if $^O eq 'os390' or $^O eq 'vmesa'; }
 END {print "not ok 1\n" unless $loaded;}
 use CGI (':standard','-no_debug');
 $loaded = 1;
index 30ea48d..fbaf19a 100755 (executable)
@@ -49,11 +49,19 @@ EOM
     exit(1);
 };
 
+my $perm;
+
+$perm = S_IRWXU | S_IRWXG | S_IRWXO | S_IWGRP | S_IROTH | S_IWOTH
+    if $^O eq 'vmesa';
+
+$perm = S_IRWXU | S_IRWXG | S_IRWXO unless defined $perm;
+
 if ($Config{'d_msgget'} eq 'define' &&
     $Config{'d_msgctl'} eq 'define' &&
     $Config{'d_msgsnd'} eq 'define' &&
     $Config{'d_msgrcv'} eq 'define') {
-    $msg = msgget(IPC_PRIVATE, S_IRWXU | S_IRWXG | S_IRWXO);
+
+    $msg = msgget(IPC_PRIVATE, $perm);
     # Very first time called after machine is booted value may be 0 
     die "msgget failed: $!\n" unless defined($msg) && $msg >= 0;
 
@@ -92,7 +100,7 @@ if($Config{'d_semget'} eq 'define' &&
 
     use IPC::SysV qw(IPC_CREAT GETALL SETALL);
 
-    $sem = semget(IPC_PRIVATE, 10, S_IRWXU | S_IRWXG | S_IRWXO | IPC_CREAT);
+    $sem = semget(IPC_PRIVATE, 10, $perm | IPC_CREAT);
     # Very first time called after machine is booted value may be 0 
     die "semget: $!\n" unless defined($sem) && $sem >= 0;
 
index 9d05b55..686424f 100755 (executable)
@@ -135,7 +135,7 @@ __END__
 :endofperl
 EOT
     }
-    if ($^O eq 'os390') {  # no shebang
+    if ($^O eq 'os390' or $^O eq 'vmesa') {  # no shebang
        $headmaybe = <<EOH ;
     eval 'exec ./perl -S \$0 \${1+"\$\@"}'
         if 0;
index 725a0cb..1953968 100755 (executable)
@@ -31,7 +31,7 @@ print +($x = unpack("%32B69", "\001\002\004\010\020\040\100\200\017")) == 9
        ? "ok 6\n" : "not ok 6 $x\n";
 
 my $sum = 129; # ASCII
-$sum = 103 if ($^O eq 'os390'); # An EBCDIC variant.
+$sum = 103 if ($^O eq 'os390' or $^O eq 'vmesa'); # EBCDIC.
 
 print +($x = unpack("%32B*", "Now is the time for all good blurfl")) == $sum
        ? "ok 7\n" : "not ok 7 $x\n";
index 913e07c..0217a67 100755 (executable)
@@ -2,7 +2,7 @@
 
 print "1..15\n";
 
-if ($^O eq 'os390') { # An EBCDIC variant.
+if ($^O eq 'os390' or $^O eq 'vmesa') { # EBCDIC.
     $_=join "", map chr($_), 129..233;
 
     # 105 characters - 52 letters = 53 backslashes
index d224165..3b3bc8d 100755 (executable)
@@ -183,7 +183,7 @@ tr/a-z/A-Z/;
 print $_ eq 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789' ? "ok 52\n" : "not ok 52\n";
 
 # same as tr/A-Z/a-z/;
-if ($^O eq 'os390') {  # An EBCDIC variant.
+if ($^O eq 'os390' or $^O eq 'vmesa') {        # EBCDIC.
     no utf8;
     y[\301-\351][\201-\251];
 } else {               # Ye Olde ASCII.  Or something like it.
diff --git a/util.c b/util.c
index 0a70c6b..e705402 100644 (file)
--- a/util.c
+++ b/util.c
@@ -1878,7 +1878,7 @@ VTOH(vtohl,long)
 #endif
 
     /* VMS' my_popen() is in VMS.c, same with OS/2. */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM)
 PerlIO *
 my_popen(char *cmd, char *mode)
 {
@@ -2130,7 +2130,7 @@ rsignal_restore(int signo, Sigsave_t *save)
 #endif /* !HAS_SIGACTION */
 
     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM)
 I32
 my_pclose(PerlIO *ptr)
 {
@@ -2451,7 +2451,7 @@ scan_hex(char *start, I32 len, I32 *retlen)
     while (len-- && *s) {
        tmp = strchr((char *) PL_hexdigit, *s++);
        if (!tmp) {
-           if (*s == '_')
+           if (*(s-1) == '_')
                continue;
            else {
                dTHR;
diff --git a/vmesa/Makefile b/vmesa/Makefile
new file mode 100644 (file)
index 0000000..28c1265
--- /dev/null
@@ -0,0 +1,15 @@
+CCCMD=`sh $(shellflags) ../cflags $@`
+
+all : vm perl
+
+depend :
+;cd ..; $(MAKE) depend
+
+vm  : vmesa.o
+;cp vmesa.o ../
+
+perl :
+;cd ..; $(MAKE)
+
+vmesa.o : vmesa.c
+;$(CCCMD) vmesa.c
diff --git a/vmesa/vmesa.c b/vmesa/vmesa.c
new file mode 100644 (file)
index 0000000..0e9baf3
--- /dev/null
@@ -0,0 +1,611 @@
+/************************************************************/
+/*                                                          */
+/* Module ID  - vmesa.c                                     */
+/*                                                          */
+/* Function   - Provide operating system dependent process- */
+/*              ing for perl under VM/ESA.                  */
+/*                                                          */
+/* Parameters - See individual entry points.                */
+/*                                                          */
+/* Called By  - N/A - see individual entry points.          */
+/*                                                          */
+/* Calling To - N/A - see individual entry points.          */
+/*                                                          */
+/* Notes      - (1) ....................................... */
+/*                                                          */
+/*              (2) ....................................... */
+/*                                                          */
+/* Name       - Neale Ferguson.                             */
+/*                                                          */
+/* Date       - August, 1998.                               */
+/*                                                          */
+/*                                                          */
+/* Associated    - (1) Refer To ........................... */
+/* Documentation                                            */
+/*                 (2) Refer To ........................... */
+/*                                                          */
+/************************************************************/
+/************************************************************/
+/*                                                          */
+/*                MODULE MAINTENANCE HISTORY                */
+/*                --------------------------                */
+/*                                                          */
+static char REQ_REL_WHO [13] =
+/*--------------       -------------------------------------*/
+    "9999_99 NAF "; /* Original module                      */
+/*                                                          */
+/*============ End of Module Maintenance History ===========*/
+
+/************************************************************/
+/*                                                          */
+/*                       DEFINES                            */
+/*                       -------                            */
+/*                                                          */
+/************************************************************/
+
+#define FAIL  65280
+
+/*=============== END OF DEFINES ===========================*/
+
+/************************************************************/
+/*                                                          */
+/*                INCLUDE STATEMENTS                        */
+/*                ------------------                        */
+/*                                                          */
+/************************************************************/
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <spawn.h>
+#include <fcntl.h>
+#include <unistd.h>
+#include <pthread.h>
+#include <dll.h>
+#include "EXTERN.h"
+#include "perl.h"
+#pragma map(truncate, "@@TRUNC")
+
+/*================== End of Include Statements =============*/
+
+/************************************************************/
+/*                                                          */
+/*               Global Variables                           */
+/*               ----------------                           */
+/*                                                          */
+/************************************************************/
+
+static int Perl_stdin_fd  = STDIN_FILENO,
+           Perl_stdout_fd = STDOUT_FILENO;
+
+static long dl_retcode = 0;
+
+/*================== End of Global Variables ===============*/
+
+/************************************************************/
+/*                                                          */
+/*               FUNCTION PROTOTYPES                        */
+/*               -------------------                        */
+/*                                                          */
+/************************************************************/
+
+int    do_aspawn(SV *, SV **, SV **);
+int    do_spawn(char *, int);
+static int spawnit(char *);
+static pid_t spawn_cmd(char *, int, int);
+struct perl_thread * getTHR(void);
+
+/*================== End of Prototypes =====================*/
+
+/************************************************************/
+/*                                                          */
+/*                     D O _ A S P A W N                    */
+/*                     -----------------                    */
+/*                                                          */
+/************************************************************/
+
+int
+do_aspawn(SV* really, SV **mark, SV **sp)
+{
+ char   **a,
+        *tmps;
+ struct inheritance inherit;
+ pid_t  pid;
+ int    status,
+        fd,
+        nFd,
+        fdMap[3];
+ SV     *sv,
+        **p_sv;
+
+    status = FAIL;
+    if (sp > mark)
+    {
+       dTHR;
+       New(401,PL_Argv, sp - mark + 1, char*);
+       a = PL_Argv;
+       while (++mark <= sp)
+       {
+           if (*mark)
+              *a++ = SvPVx(*mark, na);
+           else
+              *a++ = "";
+       }
+       inherit.flags        = SPAWN_SETGROUP;
+       inherit.pgroup       = SPAWN_NEWPGROUP;
+       fdMap[STDIN_FILENO]  = Perl_stdin_fd;
+       fdMap[STDOUT_FILENO] = Perl_stdout_fd;
+       fdMap[STDERR_FILENO] = STDERR_FILENO;
+       nFd                  = 3;
+       *a = Nullch;
+       /*-----------------------------------------------------*/
+       /* Will execvp() use PATH?                             */
+       /*-----------------------------------------------------*/
+       if (*PL_Argv[0] != '/')
+           TAINT_ENV();
+       if (really && *(tmps = SvPV(really, na)))
+           pid = spawnp(tmps, nFd, fdMap, &inherit,
+                        (const char **) PL_Argv,
+                        (const char **) environ);
+       else
+           pid = spawnp(PL_Argv[0], nFd, fdMap, &inherit,
+                        (const char **) PL_Argv,
+                        (const char **) environ);
+       if (pid < 0)
+       {
+          status = FAIL;
+          if (ckWARN(WARN_EXEC))
+             warner(WARN_EXEC,"Can't exec \"%s\": %s",
+                    PL_Argv[0],
+                    Strerror(errno));
+       }
+       else
+       {
+          /*------------------------------------------------*/
+          /* If the file descriptors have been remapped then*/
+          /* we've been called following a my_popen request */
+          /* therefore we don't want to wait for spawnned   */
+          /* program to complete. We need to set the fdpid  */
+          /* value to the value of the spawnned process' pid*/
+          /*------------------------------------------------*/
+          fd = 0;
+          if (Perl_stdin_fd != STDIN_FILENO)
+             fd = Perl_stdin_fd;
+          else
+             if (Perl_stdout_fd != STDOUT_FILENO)
+                fd = Perl_stdout_fd;
+          if (fd != 0)
+          {
+             /*---------------------------------------------*/
+             /* Get the fd of the other end of the pipe,    */
+             /* use this to reference the fdpid which will  */
+             /* be used by my_pclose                        */
+             /*---------------------------------------------*/
+             close(fd);
+             p_sv  = av_fetch(PL_fdpid,fd,TRUE);
+             fd    = (int) SvIVX(*p_sv);
+             SvREFCNT_dec(*p_sv);
+             *p_sv = &PL_sv_undef;
+             sv    = *av_fetch(PL_fdpid,fd,TRUE);
+             (void) SvUPGRADE(sv, SVt_IV);
+             SvIVX(sv) = pid;
+             status    = 0;
+          }
+          else
+             wait4pid(pid, &status, 0);
+       }
+       do_execfree();
+    }
+    return (status);
+}
+
+/*===================== End of do_aspawn ===================*/
+
+/************************************************************/
+/*                                                          */
+/*                     D O _ S P A W N                      */
+/*                     ---------------                      */
+/*                                                          */
+/************************************************************/
+
+int
+do_spawn(char *cmd, int execf)
+{
+ char   **a,
+        *s,
+        flags[10];
+ int    status,
+        nFd,
+        fdMap[3];
+ struct inheritance inherit;
+ pid_t  pid;
+
+    while (*cmd && isSPACE(*cmd))
+       cmd++;
+
+    /*------------------------------------------------------*/
+    /* See if there are shell metacharacters in it          */
+    /*------------------------------------------------------*/
+
+    if (*cmd == '.' && isSPACE(cmd[1]))
+       return (spawnit(cmd));
+    else
+    {
+       if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
+          return (spawnit(cmd));
+       else
+       {
+          /*------------------------------------------------*/
+          /* Catch VAR=val gizmo                            */
+          /*------------------------------------------------*/
+          for (s = cmd; *s && isALPHA(*s); s++);
+          if (*s != '=')
+          {
+             for (s = cmd; *s; s++)
+             {
+                if (*s != ' ' &&
+                    !isALPHA(*s) &&
+                    strchr("$&*(){}[]'\";\\|?<>~`\n",*s))
+                {
+                   if (*s == '\n' && !s[1])
+                   {
+                      *s = '\0';
+                      break;
+                   }
+                   return(spawnit(cmd));
+                }
+             }
+          }
+       }
+    }
+
+    New(402,PL_Argv, (s - cmd) / 2 + 2, char*);
+    PL_Cmd = savepvn(cmd, s-cmd);
+    a = PL_Argv;
+    for (s = PL_Cmd; *s;)
+    {
+       while (*s && isSPACE(*s)) s++;
+       if (*s)
+           *(a++) = s;
+       while (*s && !isSPACE(*s)) s++;
+       if (*s)
+           *s++ = '\0';
+    }
+    *a                   = Nullch;
+    fdMap[STDIN_FILENO]  = Perl_stdin_fd;
+    fdMap[STDOUT_FILENO] = Perl_stdout_fd;
+    fdMap[STDERR_FILENO] = STDERR_FILENO;
+    nFd                  = 3;
+    inherit.flags        = 0;
+    if (PL_Argv[0])
+    {
+       pid = spawnp(PL_Argv[0], nFd, fdMap, &inherit,
+                    (const char **) PL_Argv,
+                    (const char **) environ);
+       if (pid < 0)
+       {
+          dTHR;
+          status = FAIL;
+          if (ckWARN(WARN_EXEC))
+             warner(WARN_EXEC,"Can't exec \"%s\": %s",
+                    PL_Argv[0],
+                    Strerror(errno));
+       }
+       else
+          wait4pid(pid, &status, 0);
+    }
+    do_execfree();
+    return (status);
+}
+
+/*===================== End of do_spawn ====================*/
+
+/************************************************************/
+/*                                                          */
+/* Name      - spawnit.                                     */
+/*                                                          */
+/* Function  - Spawn command and return status.             */
+/*                                                          */
+/* On Entry  - cmd - command to be spawned.                 */
+/*                                                          */
+/* On Exit   - status returned.                             */
+/*                                                          */
+/************************************************************/
+
+int
+spawnit(char *cmd)
+{
+ pid_t  pid;
+ int    status;
+
+    pid = spawn_cmd(cmd, STDIN_FILENO, STDOUT_FILENO);
+    if (pid < 0)
+       status = FAIL;
+    else
+       wait4pid(pid, &status, 0);
+
+    return (status);
+}
+
+/*===================== End of spawnit =====================*/
+
+/************************************************************/
+/*                                                          */
+/* Name      - spawn_cmd.                                   */
+/*                                                          */
+/* Function  - Spawn command and return pid.                */
+/*                                                          */
+/* On Entry  - cmd - command to be spawned.                 */
+/*                                                          */
+/* On Exit   - pid returned.                                */
+/*                                                          */
+/************************************************************/
+
+pid_t
+spawn_cmd(char *cmd, int inFd, int outFd)
+{
+ struct inheritance inherit;
+ pid_t  pid;
+ const  char *argV[4] = {"/bin/sh","-c",NULL,NULL};
+ int    nFd,
+        fdMap[3];
+
+    argV[2]              = cmd;
+    fdMap[STDIN_FILENO]  = inFd;
+    fdMap[STDOUT_FILENO] = outFd;
+    fdMap[STDERR_FILENO] = STDERR_FILENO;
+    nFd                  = 3;
+    inherit.flags        = SPAWN_SETGROUP;
+    inherit.pgroup       = SPAWN_NEWPGROUP;
+    pid = spawn(argV[0], nFd, fdMap, &inherit,
+                argV, (const char **) environ);
+    return (pid);
+}
+
+/*===================== End of spawnit =====================*/
+
+/************************************************************/
+/*                                                          */
+/* Name      - my_popen.                                    */
+/*                                                          */
+/* Function  - Use popen to execute a command return a      */
+/*             file descriptor.                             */
+/*                                                          */
+/* On Entry  - cmd - command to be executed.                */
+/*                                                          */
+/* On Exit   - FILE * returned.                             */
+/*                                                          */
+/************************************************************/
+
+#include <ctest.h>
+PerlIO *
+my_popen(char *cmd, char *mode)
+{
+ FILE *fd;
+ int  pFd[2],
+      this,
+      that,
+      pid;
+ SV   *sv;
+
+   if (PerlProc_pipe(pFd) >= 0)
+   {
+      this = (*mode == 'w');
+      that = !this;
+      /*-------------------------------------------------*/
+      /* If this is a read mode pipe                     */
+      /* - map the write end of the pipe to STDOUT       */
+      /* - return the *FILE for the read end of the pipe */
+      /*-------------------------------------------------*/
+      if (!this)
+         Perl_stdout_fd = pFd[that];
+      /*-------------------------------------------------*/
+      /* Else                                            */
+      /* - map the read end of the pipe to STDIN         */
+      /* - return the *FILE for the write end of the pipe*/
+      /*-------------------------------------------------*/
+      else
+         Perl_stdin_fd = pFd[that];
+      if (strNE(cmd,"-"))
+      {
+         pid = spawn_cmd(cmd, Perl_stdin_fd, Perl_stdout_fd);
+         if (pid >= 0)
+         {
+            sv = *av_fetch(PL_fdpid,pFd[this],TRUE);
+            (void) SvUPGRADE(sv, SVt_IV);
+            SvIVX(sv) = pid;
+            fd = PerlIO_fdopen(pFd[this], mode);
+            close(pFd[that]);
+         }
+         else
+            fd = Nullfp;
+      }
+      else
+      {
+         sv = *av_fetch(PL_fdpid,pFd[that],TRUE);
+         (void) SvUPGRADE(sv, SVt_IV);
+         SvIVX(sv) = pFd[this];
+         fd = PerlIO_fdopen(pFd[this], mode);
+      }
+   }
+   else
+      fd = Nullfp;
+   return (fd);
+}
+
+/*===================== End of my_popen ====================*/
+
+/************************************************************/
+/*                                                          */
+/* Name      - my_pclose.                                   */
+/*                                                          */
+/* Function  - Use pclose to terminate a piped command      */
+/*             file stream.                                 */
+/*                                                          */
+/* On Entry  - fd  - FILE pointer.                          */
+/*                                                          */
+/* On Exit   - Status returned.                             */
+/*                                                          */
+/************************************************************/
+
+long
+my_pclose(FILE *fp)
+{
+ int  pid,
+      saveErrno,
+      status;
+ long rc,
+      wRc;
+ SV   **sv;
+ FILE *other;
+
+   sv        = av_fetch(PL_fdpid,PerlIO_fileno(fp),TRUE);
+   pid       = (int) SvIVX(*sv);
+   SvREFCNT_dec(*sv);
+   *sv       = &PL_sv_undef;
+   rc        = PerlIO_close(fp);
+   saveErrno = errno;
+   do
+   {
+      wRc = waitpid(pid, &status, 0);
+   } while ((wRc == -1) && (errno == EINTR));
+   Perl_stdin_fd  = STDIN_FILENO;
+   Perl_stdout_fd = STDOUT_FILENO;
+   errno          = saveErrno;
+   if (rc != 0)
+      SETERRNO(errno, garbage);
+   return (rc);
+
+}
+
+/*===================== End of my_pclose ===================*/
+
+/************************************************************/
+/*                                                          */
+/* Name      - getTHR.                                      */
+/*                                                          */
+/* Function  - Use pclose to terminate a piped command      */
+/*             file stream.                                 */
+/*                                                          */
+/* On Exit   - Thread specific data returned.               */
+/*                                                          */
+/************************************************************/
+
+struct perl_thread *
+getTHR()
+{
+ int status;
+ struct perl_thread *pThread;
+
+   status = pthread_getspecific(PL_thr_key, (void **) &pThread);
+   if (status != 0)
+      pThread = NULL;
+   return (pThread);
+}
+
+/*===================== End of getTHR ======================*/
+
+/************************************************************/
+/*                                                          */
+/* Name      - dlopen.                                      */
+/*                                                          */
+/* Function  - Load a DLL.                                  */
+/*                                                          */
+/* On Exit   -                                              */
+/*                                                          */
+/************************************************************/
+
+void *
+dlopen(const char *path)
+{
+ dllhandle *handle;
+
+fprintf(stderr,"Loading %s\n",path);
+   handle     = dllload(path);
+   dl_retcode = errno;
+fprintf(stderr,"Handle %08X %s\n",handle,strerror(errno));
+   return ((void *) handle);
+}
+
+/*===================== End of dlopen ======================*/
+
+/************************************************************/
+/*                                                          */
+/* Name      - dlsym.                                       */
+/*                                                          */
+/* Function  - Locate a DLL symbol.                         */
+/*                                                          */
+/* On Exit   -                                              */
+/*                                                          */
+/************************************************************/
+
+void *
+dlsym(void *handle, const char *symbol)
+{
+ void *symLoc;
+
+fprintf(stderr,"Finding %s\n",symbol);
+   symLoc  = dllqueryvar((dllhandle *) handle, (char *) symbol);
+   if (symLoc == NULL)
+      symLoc = (void *) dllqueryfn((dllhandle *) handle,
+                                   (char *) symbol);
+   dl_retcode = errno;
+   return(symLoc);
+}
+
+/*===================== End of dlsym =======================*/
+
+/************************************************************/
+/*                                                          */
+/* Name      - dlerror.                                     */
+/*                                                          */
+/* Function  - Return the last errno pertaining to a DLL    */
+/*             operation.                                   */
+/*                                                          */
+/* On Exit   -                                              */
+/*                                                          */
+/************************************************************/
+
+void *
+dlerror(void)
+{
+ char * dlEmsg;
+
+ dlEmsg     = strerror(dl_retcode);
+ dl_retcode = 0;
+ return(dlEmsg);
+}
+
+/*===================== End of dlerror =====================*/
+
+/************************************************************/
+/*                                                          */
+/* Name      - TRUNCATE.                                    */
+/*                                                          */
+/* Function  - Truncate a file identified by 'path' to      */
+/*             a given length.                              */
+/*                                                          */
+/* On Entry  - path - Path of file to be truncated.         */
+/*             length - length of truncated file.           */
+/*                                                          */
+/* On Exit   - retC - return code.                          */
+/*                                                          */
+/************************************************************/
+
+int
+truncate(const unsigned char *path, off_t length)
+{
+ int fd,
+     retC;
+
+   fd = open((const char *) path, O_RDWR);
+   if (fd > 0)
+   {
+      retC = ftruncate(fd, length);
+      close(fd);
+   }
+   else
+      retC = fd;
+   return(retC);
+}
+
+/*===================== End of trunc =======================*/
diff --git a/vmesa/vmesaish.h b/vmesa/vmesaish.h
new file mode 100644 (file)
index 0000000..f4f87a9
--- /dev/null
@@ -0,0 +1,15 @@
+#ifndef _VMESA_INCLUDED
+# define _VMESA_INCLUDED 1
+# include <string.h>
+# include <ctype.h>
+# include <vmsock.h>
+ void * dlopen(const char *);
+ void * dlsym(void *, const char *);
+ void * dlerror(void);
+# ifdef YIELD
+#  undef YIELD
+# endif
+# define YIELD pthread_yield(NULL)
+# define pthread_mutexattr_default NULL
+# define pthread_condattr_default NULL
+#endif
index 8053046..392e9e6 100644 (file)
--- a/x2p/a2p.h
+++ b/x2p/a2p.h
 /* All of these are in stdlib.h or time.h for ANSI C */
 Time_t time();
 struct tm *gmtime(), *localtime();
+#if defined(OEMVS) || defined(__OPEN_VM)
+char *(strchr)(), *(strrchr)();
+char *(strcpy)(), *(strcat)();
+#else
 char *strchr(), *strrchr();
 char *strcpy(), *strcat();
+#endif
 #endif /* ! STANDARD_C */
 
 #ifdef VMS