diff options
author | Todd C. Miller <millert@cvs.openbsd.org> | 2001-05-24 18:36:42 +0000 |
---|---|---|
committer | Todd C. Miller <millert@cvs.openbsd.org> | 2001-05-24 18:36:42 +0000 |
commit | 8bab8b19946f98d4be49345ca9c42e56674b65fb (patch) | |
tree | bd62d7b5d463fab205d08914b30ba647eb3c8bc8 /gnu/usr.bin/perl/vms | |
parent | 483d4e680bd2a6db14835b1b4d65be33488d532b (diff) |
merge in perl 5.6.1 with our local changes
Diffstat (limited to 'gnu/usr.bin/perl/vms')
-rw-r--r-- | gnu/usr.bin/perl/vms/ext/DCLsym/DCLsym.pm | 2 | ||||
-rw-r--r-- | gnu/usr.bin/perl/vms/ext/DCLsym/Makefile.PL | 2 | ||||
-rw-r--r-- | gnu/usr.bin/perl/vms/ext/Stdio/Stdio.pm | 4 | ||||
-rw-r--r-- | gnu/usr.bin/perl/vms/ext/Stdio/Stdio.xs | 1 | ||||
-rw-r--r-- | gnu/usr.bin/perl/vms/ext/vmsish.t | 1 | ||||
-rw-r--r-- | gnu/usr.bin/perl/vms/gen_shrfls.pl | 23 | ||||
-rw-r--r-- | gnu/usr.bin/perl/vms/genconfig.pl | 2 | ||||
-rw-r--r-- | gnu/usr.bin/perl/vms/perlvms.pod | 40 | ||||
-rw-r--r-- | gnu/usr.bin/perl/vms/perly_c.vms | 8 | ||||
-rw-r--r-- | gnu/usr.bin/perl/vms/subconfigure.com | 2628 | ||||
-rw-r--r-- | gnu/usr.bin/perl/vms/test.com | 25 | ||||
-rw-r--r-- | gnu/usr.bin/perl/vms/vms.c | 2006 | ||||
-rw-r--r-- | gnu/usr.bin/perl/vms/vmsish.h | 175 |
13 files changed, 1959 insertions, 2958 deletions
diff --git a/gnu/usr.bin/perl/vms/ext/DCLsym/DCLsym.pm b/gnu/usr.bin/perl/vms/ext/DCLsym/DCLsym.pm index 7989cee0ad5..99adb94522e 100644 --- a/gnu/usr.bin/perl/vms/ext/DCLsym/DCLsym.pm +++ b/gnu/usr.bin/perl/vms/ext/DCLsym/DCLsym.pm @@ -215,7 +215,7 @@ C<tie> described above. If called in a scalar context, C<getsym> returns the value of the symbol whose name is given as the argument to the call, or C<undef> if no such symbol exists. Symbols in the local symbol table are always used in preference to -symbols in the global symbol table. If called in an array context, C<getsym> +symbols in the global symbol table. If called in a list context, C<getsym> returns a two-element list, whose first element is the value of the symbol, and whose second element is the string 'GLOBAL' or 'LOCAL', indicating the table from which the symbol's value was read. diff --git a/gnu/usr.bin/perl/vms/ext/DCLsym/Makefile.PL b/gnu/usr.bin/perl/vms/ext/DCLsym/Makefile.PL index 84ab2be2b52..28e2fa37585 100644 --- a/gnu/usr.bin/perl/vms/ext/DCLsym/Makefile.PL +++ b/gnu/usr.bin/perl/vms/ext/DCLsym/Makefile.PL @@ -1,4 +1,4 @@ use ExtUtils::MakeMaker; WriteMakefile( 'VERSION_FROM' => 'DCLsym.pm', - 'MAN3PODS' => ' '); + 'MAN3PODS' => {}); diff --git a/gnu/usr.bin/perl/vms/ext/Stdio/Stdio.pm b/gnu/usr.bin/perl/vms/ext/Stdio/Stdio.pm index b51f2c9f15d..446b0785e15 100644 --- a/gnu/usr.bin/perl/vms/ext/Stdio/Stdio.pm +++ b/gnu/usr.bin/perl/vms/ext/Stdio/Stdio.pm @@ -134,7 +134,7 @@ This package C<ISA> IO::File, so that you can call IO::File methods on the handles returned by C<vmsopen> and C<vmssysopen>. The IO::File package is not initialized, however, until you actually call a method that VMS::Stdio doesn't provide. This -is doen to save startup time for users who don't wish to use +is done to save startup time for users who don't wish to use the IO::File methods. B<Note:> In order to conform to naming conventions for Perl @@ -201,7 +201,7 @@ true value if successful, and C<undef> if it fails. This function sets the default device and directory for the process. It is identical to the built-in chdir() operator, except that the change persists after Perl exits. It returns a true value on success, and -C<undef> if it encounters and error. +C<undef> if it encounters an error. =item sync diff --git a/gnu/usr.bin/perl/vms/ext/Stdio/Stdio.xs b/gnu/usr.bin/perl/vms/ext/Stdio/Stdio.xs index 22d9a7262cf..d82b17dbfa0 100644 --- a/gnu/usr.bin/perl/vms/ext/Stdio/Stdio.xs +++ b/gnu/usr.bin/perl/vms/ext/Stdio/Stdio.xs @@ -87,7 +87,6 @@ newFH(FILE *fp, char type) { HV *stash; IO *io; - dTHR; /* Find stash for VMS::Stdio. We don't do this once at boot * to allow for possibility of threaded Perl with per-thread * symbol tables. This code (through io = ...) is really diff --git a/gnu/usr.bin/perl/vms/ext/vmsish.t b/gnu/usr.bin/perl/vms/ext/vmsish.t index 2a5b580bda3..d63da57235d 100644 --- a/gnu/usr.bin/perl/vms/ext/vmsish.t +++ b/gnu/usr.bin/perl/vms/ext/vmsish.t @@ -136,6 +136,7 @@ sub do_a_perl { local *P; open(P,'>vmsish_test.com') || die('not ok ?? : unable to open "vmsish_test.com" for writing'); print P "\$ set message/facil/sever/ident/text\n"; + print P "\$ define/nolog/user sys\$error _nla0:\n"; print P "\$ $Invoke_Perl @_\n"; close P; my $x = `\@vmsish_test.com`; diff --git a/gnu/usr.bin/perl/vms/gen_shrfls.pl b/gnu/usr.bin/perl/vms/gen_shrfls.pl index a109f7bdfd7..6c54c107e37 100644 --- a/gnu/usr.bin/perl/vms/gen_shrfls.pl +++ b/gnu/usr.bin/perl/vms/gen_shrfls.pl @@ -68,16 +68,21 @@ if ($docc) { elsif (-f '[-]perl.h') { $dir = '[-]'; } else { die "$0: Can't find perl.h\n"; } - # Go see if debugging is enabled in config.h - $config = $dir . "config.h"; + $use_threads = $use_mymalloc = $case_about_case = $debugging_enabled = 0; + $hide_mymalloc = $isgcc = 0; + + # Go see what is enabled in config.sh + $config = $dir . "config.sh"; open CONFIG, "< $config"; while(<CONFIG>) { - $debugging_enabled++ if /define\s+DEBUGGING/; - $use_mymalloc++ if /define\s+MYMALLOC/; - $hide_mymalloc++ if /define\s+EMBEDMYMALLOC/; - $use_threads++ if /define\s+USE_THREADS/; - $care_about_case++ if /define\s+VMS_WE_ARE_CASE_SENSITIVE/; + $use_threads++ if /usethreads='define'/; + $use_mymalloc++ if /usemymalloc='Y'/; + $care_about_case++ if /d_vms_case_sensitive_symbols='define'/; + $debugging_enabled++ if /usedebugging_perl='Y'/; + $hide_mymalloc++ if /embedmymalloc='Y'/; + $isgcc++ if /gccversion='[^']/; } + close CONFIG; # put quotes back onto defines - they were removed by DCL on the way in if (($prefix,$defines,$suffix) = @@ -92,8 +97,7 @@ if ($docc) { # check for gcc - if present, we'll need to use MACRO hack to # define global symbols for shared variables - $isgcc = `$cc_cmd _nla0:/Version` =~ /GNU/ - or 0; # make debug output nice + print "\$isgcc: $isgcc\n" if $debug; print "\$debugging_enabled: $debugging_enabled\n" if $debug; @@ -328,6 +332,7 @@ if ($ENV{PERLSHR_USE_GSMATCH}) { # 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 diff --git a/gnu/usr.bin/perl/vms/genconfig.pl b/gnu/usr.bin/perl/vms/genconfig.pl index e500e760a27..ef1d5ad4a5a 100644 --- a/gnu/usr.bin/perl/vms/genconfig.pl +++ b/gnu/usr.bin/perl/vms/genconfig.pl @@ -229,6 +229,8 @@ foreach (@ARGV) { 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"; diff --git a/gnu/usr.bin/perl/vms/perlvms.pod b/gnu/usr.bin/perl/vms/perlvms.pod index 0bef835f7f8..f43cbb0e467 100644 --- a/gnu/usr.bin/perl/vms/perlvms.pod +++ b/gnu/usr.bin/perl/vms/perlvms.pod @@ -122,7 +122,7 @@ 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, you shouldn't nest the source directory -too deeply in your directory structure, lest you eccedd RMS' +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 @@ -167,7 +167,7 @@ translates to the full file specification of the shareable image. We have tried to make Perl aware of both VMS-style and Unix- style file specifications wherever possible. You may use either style, or both, on the command line and in scripts, -but you may not combine the two styles within a single fle +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 @@ -233,7 +233,7 @@ Perl will wait for the subprocess to complete before continuing. =head1 PERL5LIB and PERLLIB -The PERL5LIB and PERLLIB logical names work as documented L<perl>, +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. @@ -516,7 +516,7 @@ true, a warning message is printed, and C<undef> is returned. =item kill -In most cases, C<kill> kill is implemented via the CRTL's C<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 @@ -569,7 +569,7 @@ 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 typiing +interactive DCL subprocess, in the same fashion as typing B<SPAWN> at the DCL prompt. Perl waits for the subprocess to complete before continuing @@ -592,19 +592,21 @@ The array returned by the C<times> operator is divided up according to the same rules the CRTL C<times()> routine. Therefore, the "system time" elements will always be 0, since there is no difference between "user time" and "system" time -under VMS, and the time accumulated by subprocess may or may +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 suprocesses spawned via pipes, L<system>, +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. @@ -644,8 +646,8 @@ time of the file (VMS revision date). =item waitpid PID,FLAGS -If PID is a subprocess started by a piped L<open>, C<waitpid> -will wait for that subprocess, and return its final +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. If PID is a subprocess created in some other way (e.g. SPAWNed before Perl was invoked), or is not a subprocess of the current process, C<waitpid> will check once per second whether @@ -661,7 +663,7 @@ The FLAGS argument is ignored in all cases. 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 infrmation +in L<perlvar>. Where there is a conflict, this information takes precedence. =over 4 @@ -694,7 +696,7 @@ 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. +symbol table; otherwise the global symbol table is changed. =item Any other string @@ -751,7 +753,7 @@ 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> @@ -786,6 +788,14 @@ by saying (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. @@ -796,7 +806,7 @@ 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 +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) @@ -830,7 +840,7 @@ 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 -severity portion of the subprocess' exit status: if the +the severity portion of the subprocess' exit status: if the severity was success or informational, these bits are all 0; otherwise, they contain the severity value shifted left one bit. As a result, C<$?> will always be zero if the subprocess' exit @@ -841,7 +851,7 @@ be found in C<$^S> (q.v.). =item $^S Under VMS, this is the 32-bit VMS status value returned by the -last subprocess to complete. Unlink C<$?>, no manipulation +last subprocess to complete. Unlike C<$?>, no manipulation is done to make this look like a POSIX wait(5) value, so it may be treated as a normal VMS status value. diff --git a/gnu/usr.bin/perl/vms/perly_c.vms b/gnu/usr.bin/perl/vms/perly_c.vms index b17faeade11..640780af83c 100644 --- a/gnu/usr.bin/perl/vms/perly_c.vms +++ b/gnu/usr.bin/perl/vms/perly_c.vms @@ -1387,6 +1387,9 @@ yyparse() #endif struct ysv *ysave; +#ifdef USE_ITHREADS + ENTER; /* force yydestruct() before we return */ +#endif New(73, ysave, 1, struct ysv); SAVEDESTRUCTOR_X(yydestruct, ysave); ysave->oldyydebug = yydebug; @@ -1746,7 +1749,7 @@ case 35: break; case 37: #line 269 "perly.y" -{ (void)scan_num("1"); yyval.opval = yylval.opval; } +{ (void)scan_num("1", &yylval); yyval.opval = yylval.opval; } break; case 39: #line 274 "perly.y" @@ -2479,6 +2482,9 @@ yyoverflow: yyabort: retval = 1; yyaccept: +#ifdef USE_ITHREADS + LEAVE; /* force yydestruct() before we return */ +#endif return retval; } diff --git a/gnu/usr.bin/perl/vms/subconfigure.com b/gnu/usr.bin/perl/vms/subconfigure.com deleted file mode 100644 index 4cdafbc08f8..00000000000 --- a/gnu/usr.bin/perl/vms/subconfigure.com +++ /dev/null @@ -1,2628 +0,0 @@ -$! SUBCONFIGURE.COM - build a config.sh for VMS Perl. -$! -$! Note for folks from other platforms changing things in here: -$! Fancy changes (based on compiler capabilities or VMS version or -$! whatever) are tricky, so go ahead and punt on those. -$! -$! Simple changes, though (say, always setting something to 1, or undef, -$! or something like that) are straightforward. Adding a new item for the -$! ultimately created config.sh requires adding two lines to this file. -$! -$! First, a line in the format: -$! $ perl_foo = "bar" -$! after the line tagged ##ADD NEW CONSTANTS HERE##. Replace foo with the -$! variable name as it appears in config.sh. -$! -$! Second, add a line in the format: -$! $ WC "foo='" + perl_foo + "'" -$! after the line tagged ##WRITE NEW CONSTANTS HERE##. Careful of the -$! quoting, as it can be tricky. -$! -$! This .COM file expects to be called by configure.com, and thus expects -$! a few symbols in the environment. Notably: -$! -$! One of: Using_Dec_C, Using_Vax_C, Using_Gnu_C set to "YES" -$! Dec_C_Version set to the Dec C version (defaults to 0 if not specified) -$! Has_Socketshr set to "T" if using socketshr -$! Has_Dec_C_Sockets set to "T" if using Dec C sockets -$! Use_Threads set to "T" if they're using threads -$! C_Compiler_Invoke is the command needed to invoke the C compiler -$! -$! Set Dec_C_Version to something -$ WRITE_RESULT := "WRITE SYS$OUTPUT ""%CONFIG-I-RESULT "" + " -$ Dec_C_Version := "''Dec_C_Version'" -$ Dec_C_Version = Dec_C_Version + 0 -$ Vms_Ver := "''f$extract(1,3, f$getsyi(""version""))'" -$ perl_extensions := "''extensions'" -$ if f$length(Mcc) .eq. 0 then Mcc := "cc" -$ MCC = f$edit(mcc, "UPCASE") -$ IF Mcc.eqs."CC -$ THEN -$ C_Compiler_Replace := "CC=" -$ ELSE -$ C_Compiler_Replace := "CC=CC=''Mcc'" -$ ENDIF -$ if "''Using_Dec_C'" .eqs. "Yes" -$ THEN -$ Checkcc := "''Mcc'/prefix=all" -$ ELSE -$ Checkcc := "''Mcc'" -$ ENDIF -$ cc_flags = "" -$! Some constant defaults. -$ -$ hwname = f$getsyi("HW_NAME") -$ myname = myhostname -$ if "''myname'" .eqs. "" THEN myname = f$trnlnm("SYS$NODE") -$! -$! ##ADD NEW CONSTANTS HERE## -$ perl_i_sysmount="undef" -$ perl_d_fstatfs="undef" -$ perl_i_machcthreads="undef" -$ perl_i_pthread="define" -$ perl_d_fstatvfs="undef" -$ perl_d_statfsflags="undef" -$ perl_i_sysstatvfs="undef" -$ perl_i_mntent="undef" -$ perl_d_getmntent="undef" -$ perl_d_hasmntopt="undef" -$ perl_package="''package'" -$ perl_baserev = "''baserev'" -$ cc_defines="" -$ perl_CONFIG="true" -$ perl_i_netdb="undef" -$ perl_d_gnulibc="undef" -$ perl_cf_by="unknown" -$ perl_ccdlflags="" -$ perl_cccdlflags="" -$ perl_mab="" -$ perl_libpth="/sys$share /sys$library" -$ perl_ld="Link" -$ perl_lddlflags="/Share" -$ perl_ranlib="" -$ perl_ar="" -$ perl_eunicefix=":" -$ perl_hint="none" -$ perl_i_arpainet="undef" -$ perl_d_grpasswd="undef" -$ perl_d_setgrent="undef" -$ perl_d_getgrent="define" -$ perl_d_endgrent="define" -$ perl_d_pwpasswd="define" -$ perl_d_setpwent="define" -$ perl_d_getpwent="define" -$ perl_d_endpwent="define" -$ perl_ebcdic="undef" -$ perl_hintfile="" -$ perl_shrplib="define" -$ perl_usemymalloc=mymalloc -$ perl_usevfork="true" -$ perl_useposix="false" -$ perl_spitshell="write sys$output " -$ perl_dlsrc="dl_vms.c" -$ perl_man1ext="rno" -$ perl_man3ext="rno" -$ perl_prefix="perl_root" -$ perl_binexp="''perl_prefix':[000000]" -$ perl_builddir="''perl_prefix':[000000]" -$ perl_installbin="''perl_prefix':[000000]" -$ perl_installscript="''perl_prefix':[000000]" -$ perl_installman1dir="''perl_prefix':[man.man1]" -$ perl_installman3dir="''perl_prefix':[man.man3]" -$ perl_installprivlib="''perl_prefix':[lib]" -$ perl_installsitelib="''perl_prefix':[lib.site_perl]" -$ perl_path_sep="|" -$ perl_cc=Mcc -$ perl_d_sockpair="undef" -$ perl_i_neterrno="define" -$ perl_ldflags="/NoTrace/NoMap" -$ perl_d_lchown="undef" -$ perl_d_mknod="undef" -$ perl_d_union_semun="undef" -$ perl_d_semctl_semun="undef" -$ perl_d_semctl_semid_ds="undef" -$ IF (sharedperl.EQS."Y") -$ THEN -$ perl_obj_ext=".abj" -$ perl_so="axe" -$ perl_dlext="axe" -$ perl_exe_ext=".axe" -$ perl_lib_ext=".alb" -$ ELSE -$ perl_obj_ext=".obj" -$ perl_so="exe" -$ perl_dlext="exe" -$ perl_exe_ext=".exe" -$ perl_lib_ext=".olb" -$ENDIF -$ perl_dlobj="dl_vms''perl_obj_ext'" -$ perl_osname="VMS" -$ perl_d_archlib="define" -$ perl_d_bincompat3="undef" -$ perl_cppstdin="''Perl_CC'/noobj/preprocess=sys$output sys$input" -$ perl_cppminus="" -$ perl_d_castneg="define" -$ perl_castflags="0" -$ perl_d_chsize="undef" -$ perl_d_const="define" -$ perl_d_crypt="define" -$ perl_byteorder="1234" -$ perl_full_csh="" -$ perl_d_csh="undef" -$ perl_d_dup2="define" -$ perl_d_fchmod="undef" -$ perl_d_fchown="undef" -$ perl_d_fcntl="undef" -$ perl_d_fgetpos="define" -$ perl_d_flexfnam="define" -$ perl_d_flock="undef" -$ perl_d_fsetpos="define" -$ perl_d_getgrps="undef" -$ perl_d_setgrps="undef" -$ perl_d_getprior="undef" -$ perl_d_killpg="undef" -$ perl_d_link="undef" -$ perl_d_lstat="undef" -$ perl_d_lockf="undef" -$ perl_d_memcmp="define" -$ perl_d_memcpy="define" -$ perl_d_memmove="define" -$ perl_d_memset="define" -$ perl_d_mkdir="define" -$ perl_d_msg="undef" -$ perl_d_open3="define" -$ perl_d_poll="undef" -$ perl_d_readdir="define" -$ perl_d_seekdir="define" -$ perl_d_telldir="define" -$ perl_d_rewinddir="define" -$ perl_d_rename="define" -$ perl_d_rmdir="define" -$ perl_d_sem="undef" -$ perl_d_setegid="undef" -$ perl_d_seteuid="undef" -$ perl_d_setprior="undef" -$ perl_d_setregid="undef" -$ perl_d_setresgid="undef" -$ perl_d_setreuid="undef" -$ perl_d_setresuid="undef" -$ perl_d_setrgid="undef" -$ perl_d_setruid="undef" -$ perl_d_setsid="undef" -$ perl_d_shm="undef" -$ perl_d_shmatprototype="undef" -$ perl_d_statblks="undef" -$ perl_stdio_ptr="((*fp)->_ptr)" -$ perl_stdio_cnt="((*fp)->_cnt)" -$ perl_stdio_base="((*fp)->_base)" -$ perl_stdio_bufsiz="((*fp)->_cnt + (*fp)->_ptr - (*fp)->_base)" -$ perl_d_strctcpy="define" -$ perl_d_strerror="define" -$ perl_d_syserrlst="undef" -$ perl_d_strerrm="strerror((e),vaxc$errno)" -$ perl_d_symlink="undef" -$ perl_d_syscall="undef" -$ perl_d_system="define" -$ perl_timetype="time_t" -$ perl_d_vfork="define" -$ perl_signal_t="void" -$ perl_d_volatile="define" -$ perl_d_vprintf="define" -$ perl_d_charvspr="undef" -$ perl_d_waitpid="define" -$ perl_i_dirent="undef" -$ perl_d_dirnamlen="define" -$ perl_direntrytype="struct dirent" -$ perl_i_fcntl="undef" -$ perl_i_grp="undef" -$ perl_i_limits="define" -$ perl_i_memory="undef" -$ perl_i_ndbm="undef" -$ perl_i_stdarg="define" -$ perl_i_pwd="undef" -$ perl_d_pwquota="undef" -$ perl_d_pwage="undef" -$ perl_d_pwchange="undef" -$ perl_d_pwclass="undef" -$ perl_d_pwexpire="undef" -$ perl_d_pwcomment="define" -$ perl_i_stddef="define" -$ perl_i_stdlib="define" -$ perl_i_string="define" -$ perl_i_sysdir="undef" -$ perl_i_sysfile="undef" -$ perl_i_sysioctl="undef" -$ perl_i_sysndir="undef" -$ perl_i_sysresrc="undef" -$ perl_i_sysselct="undef" -$ perl_i_dbm="undef" -$ perl_i_rpcsvcdbm="undef" -$ perl_i_sfio="undef" -$ perl_i_sysstat="define" -$ perl_i_systimes="undef" -$ perl_i_systypes="define" -$ perl_i_sysun="undef" -$ perl_i_syswait="undef" -$ perl_i_termio="undef" -$ perl_i_sgtty="undef" -$ perl_i_termios="undef" -$ perl_i_time="define" -$ perl_i_systime="undef" -$ perl_i_systimek="undef" -$! perl_i_unistd="undef" -$ perl_i_utime="undef" -$ perl_i_varargs="undef" -$ perl_i_vfork="undef" -$ perl_prototype="define" -$ perl_randbits="31" -$ perl_stdchar="char" -$ perl_d_unlink_all_versions="undef" -$ perl_full_sed="_NLA0:" -$ perl_bin="/''perl_prefix'/000000" -$ perl_binexp="''perl_prefix':[000000]" -$ perl_d_alarm="define" -$ perl_d_casti32="define" -$ perl_d_chown="define" -$ perl_d_chroot="undef" -$ perl_d_cuserid="define" -$ perl_d_dbl_dig="define" -$ perl_d_difftime="define" -$ perl_d_fork="undef" -$ perl_d_getlogin="define" -$ perl_d_getppid="undef" -$ perl_d_nice="define" -$ perl_d_pause="define" -$ perl_d_pipe="define" -$ perl_d_readlink="undef" -$ perl_d_setlinebuf="undef" -$ perl_d_strchr="define" -$ perl_d_strtod="define" -$ perl_d_strtol="define" -$ perl_d_strtoul="define" -$ perl_d_tcgetpgrp="undef" -$ perl_d_tcsetpgrp="undef" -$ perl_d_times="define" -$ perl_d_tzname="undef" -$ perl_d_umask="define" -$ perl_fpostype="fpos_t" -$ perl_i_dlfcn="undef" -$ perl_i_float="define" -$ perl_i_math="define" -$ perl_lseektype="int" -$ perl_i_values="undef" -$ perl_malloctype="void *" -$ perl_freetype="void" -$ if "''mymalloc'".eqs."Y" -$ THEN -$ perl_d_mymalloc="define" -$ ELSE -$ perl_d_mymalloc="undef" -$ENDIF -$ perl_sh="MCR" -$ perl_modetype="unsigned int" -$ perl_ssizetype="int" -$ perl_o_nonblock="" -$ perl_eagain="" -$ perl_rd_nodata="" -$ perl_d_eofnblk="undef" -$ perl_d_oldarchlib="define" -$ perl_privlibexp="''perl_prefix':[lib]" -$ perl_privlib="''perl_prefix':[lib]" -$ perl_sitelibexp="''perl_prefix':[lib.site_perl]" -$ perl_sitelib="''perl_prefix':[lib.site_perl]" -$ perl_sizetype="size_t" -$ perl_i_sysparam="undef" -$ perl_d_void_closedir="define" -$ perl_d_dlerror="undef" -$ perl_d_dlsymun="undef" -$ perl_d_suidsafe="undef" -$ perl_d_dosuid="undef" -$ perl_d_inetaton="undef" -$ perl_d_isascii="define" -$ perl_d_mkfifo="undef" -$ perl_d_safebcpy="undef" -$ perl_d_safemcpy="define" -$ perl_d_sanemcmp="define" -$ perl_d_setpgrp="undef" -$ perl_d_bsdsetpgrp="undef" -$ perl_d_bsdpgrp="undef" -$ perl_d_setpgid="undef" -$ perl_d_setpgrp2="undef" -$ perl_d_Gconvert="my_gconvert(x,n,t,b)" -$ perl_d_getpgid="undef" -$ perl_d_getpgrp="undef" -$ perl_d_bsdgetpgrp="undef" -$ perl_d_getpgrp2="undef" -$ perl_d_sfio="undef" -$ perl_usedl="define" -$ perl_startperl="""$ perl 'f$env(\""procedure\"")' 'p1' 'p2' 'p3' 'p4' 'p5' 'p6' 'p7' 'p8' !\n$ exit++ + ++$status != 0 and $exit = $status = undef;""" -$ perl_db_hashtype="" -$ perl_db_prefixtype="" -$ perl_useperlio="undef" -$ perl_defvoidused="15" -$ perl_voidflags="15" -$ perl_d_eunice="undef" -$ perl_d_pwgecos="define" -$ IF ("''Use_Threads'".eqs."T").and.("''VMS_VER'".LES."6.2") -$ THEN -$ perl_libs="SYS$SHARE:CMA$LIB_SHR.EXE/SHARE SYS$SHARE:CMA$RTL.EXE/SHARE SYS$SHARE:CMA$OPEN_LIB_SHR.exe/SHARE SYS$SHARE:CMA$OPEN_RTL.exe/SHARE" -$ ELSE -$ perl_libs="" -$ ENDIF -$ IF ("''Using_Dec_C'".eqs."Yes") -$ THEN -$ perl_libc="(DECCRTL)" -$ ELSE -$ perl_libc="" -$ ENDIF -$ perl_PATCHLEVEL="''patchlevel'" -$ perl_SUBVERSION="''subversion'" -$ perl_pager="most" -$! -$! -$! Now some that we build up -$! -$ LocalTime = f$time() -$ perl_cf_time= f$extract(0, 3, f$cvtime(LocalTime,, "WEEKDAY")) + " " + - - f$edit(f$cvtime(LocalTime, "ABSOLUTE", "MONTH"), "LOWERCASE") + - - " " + f$cvtime(LocalTime,, "DAY") + " " + f$cvtime(LocalTime,, "TIME") + - - " " + f$cvtime(LocalTime,, "YEAR") -$ if f$getsyi("HW_MODEL").ge.1024 -$ THEN -$ perl_arch="VMS_AXP" -$ perl_archname="VMS_AXP" -$ perl_alignbytes="8" -$ ELSE -$ perl_arch="VMS_VAX" -$ perl_archname="VMS_VAX" -$ perl_alignbytes="8" -$ ENDIF -$ if ("''Use_Threads'".eqs."T") -$ THEN -$ perl_arch = "''perl_arch'-thread" -$ perl_archname = "''perl_archname'-thread" -$ ENDIF -$ perl_osvers=f$edit(osvers, "TRIM") -$ if (perl_subversion + 0).eq.0 -$ THEN -$ LocalPerlVer = "5_" + Perl_PATCHLEVEL -$ ELSE -$ LocalPerlVer = "5_" + Perl_PATCHLEVEL + perl_subversion -$ ENDIF -$! -$! Some that we need to invoke the compiler for -$ OS := "open/write SOURCECHAN []temp.c" -$ WS := "write SOURCECHAN" -$ CS := "close SOURCECHAN" -$ DS := "delete/nolog []temp.*;*" -$ Needs_Opt := "No" -$ if ("''using_vax_c'".eqs."Yes").or.("''using_gnu_c'".eqs."Yes") -$ THEN -$ open/write OPTCHAN []temp.opt -$ IF ("''using_gnu_c'".eqs."Yes") -$ THEN -$ write OPTCHAN "Gnu_CC:[000000]gcclib.olb/library" -$ endif -$ write OPTCHAN "Sys$Share:VAXCRTL/Share" -$ Close OPTCHAN -$ Needs_Opt := "Yes" -$ ENDIF -$! -$! Check for __STDC__ -$! -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ WS "int main() -$ WS "{" -$ WS "#ifdef __STDC__ -$ WS "printf(""42\n""); -$ WS "#else -$ WS "printf(""1\n""); -$ WS "#endif -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ ON ERROR THEN CONTINUE -$ ON WARNING THEN CONTINUE -$ 'Checkcc' temp.c -$ If (Needs_Opt.eqs."Yes") -$ THEN -$ link temp.obj,temp.opt/opt -$ else -$ link temp.obj -$ endif -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ OPEN/WRITE TEMPOUT [-.uu]tempout.lis -$ DEFINE SYS$ERROR TEMPOUT -$ DEFINE SYS$OUTPUT TEMPOUT -$ mcr []temp -$ CLOSE TEMPOUT -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ OPEN/READ TEMPOUT [-.uu]tempout.lis -$ READ TEMPOUT line -$ CLOSE TEMPOUT -$ -$ perl_cpp_stuff=line -$ WRITE_RESULT "cpp_stuff is ''perl_cpp_stuff'" -$! -$! Check for double size -$! -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ WS "int main() -$ WS "{" -$ WS "int foo; -$ WS "foo = sizeof(double); -$ WS "printf(""%d\n"", foo); -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ ON ERROR THEN CONTINUE -$ ON WARNING THEN CONTINUE -$ 'Checkcc' temp.c -$ If (Needs_Opt.eqs."Yes") -$ THEN -$ link temp.obj,temp.opt/opt -$ else -$ link temp.obj -$ endif -$! link temp.obj -$ OPEN/WRITE TEMPOUT [-.uu]tempout.lis -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ DEFINE SYS$ERROR TEMPOUT -$ DEFINE SYS$OUTPUT TEMPOUT -$ mcr []temp -$ CLOSE TEMPOUT -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ OPEN/READ TEMPOUT [-.uu]tempout.lis -$ READ TEMPOUT line -$ CLOSE TEMPOUT -$ -$ perl_doublesize=line -$ WRITE_RESULT "doublesize is ''perl_doublesize'" -$! -$! Check for long double size -$! -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ WS "int main() -$ WS "{" -$ WS "printf(""%d\n"", sizeof(long double)); -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ ON ERROR THEN CONTINUE -$ ON WARNING THEN CONTINUE -$ 'Checkcc' temp.c -$ teststatus = f$extract(9,1,$status) -$ if (teststatus.nes."1") -$ THEN -$ perl_longdblsize="0" -$ perl_d_longdbl="undef" -$ ELSE -$ ON ERROR THEN CONTINUE -$ ON WARNING THEN CONTINUE -$ If (Needs_Opt.eqs."Yes") -$ THEN -$ link temp.obj,temp.opt/opt -$ else -$ link temp.obj -$ endif -$ teststatus = f$extract(9,1,$status) -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ if (teststatus.nes."1") -$ THEN -$ perl_longdblsize="0" -$ perl_d_longdbl="undef" -$ ELSE -$ OPEN/WRITE TEMPOUT [-.uu]tempout.lis -$ DEFINE SYS$ERROR TEMPOUT -$ DEFINE SYS$OUTPUT TEMPOUT -$ mcr []temp -$ CLOSE TEMPOUT -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ OPEN/READ TEMPOUT [-.uu]tempout.lis -$ READ TEMPOUT line -$ CLOSE TEMPOUT -$ -$ perl_longdblsize=line -$ perl_d_longdbl="define" -$ ENDIF -$ ENDIF -$ WRITE_RESULT "longdblsize is ''perl_longdblsize'" -$ WRITE_RESULT "d_longdbl is ''perl_d_longdbl'" -$! -$! Check for long long existance and size -$! -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ WS "int main() -$ WS "{" -$ WS "printf(""%d\n"", sizeof(long long)); -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ on error then continue -$ on warning then continue -$ 'Checkcc' temp.c -$ If (Needs_Opt.eqs."Yes") -$ THEN -$ link temp.obj,temp.opt/opt -$ else -$ link temp.obj -$ endif -$ teststatus = f$extract(9,1,$status) -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ if (teststatus.nes."1") -$ THEN -$ perl_longlongsize="0" -$ perl_d_longlong="undef" -$ ELSE -$ OPEN/WRITE TEMPOUT [-.uu]tempout.lis -$ DEFINE SYS$ERROR TEMPOUT -$ DEFINE SYS$OUTPUT TEMPOUT -$ mcr []temp -$ CLOSE TEMPOUT -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ OPEN/READ TEMPOUT [-.uu]tempout.lis -$ READ TEMPOUT line -$ CLOSE TEMPOUT -$ -$ perl_longlongsize=line -$ perl_d_longlong="define" -$ ENDIF -$ WRITE_RESULT "longlongsize is ''perl_longlongsize'" -$ WRITE_RESULT "d_longlong is ''perl_d_longlong'" -$! -$! Check for int size -$! -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ WS "int main() -$ WS "{" -$ WS "printf(""%d\n"", sizeof(int)); -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ on error then continue -$ on warning then continue -$ 'Checkcc' temp.c -$ If (Needs_Opt.eqs."Yes") -$ THEN -$ link temp.obj,temp.opt/opt -$ else -$ link temp.obj -$ endif -$ If (Needs_Opt.eqs."Yes") -$ THEN -$ link temp.obj,temp.opt/opt -$ else -$ link temp.obj -$ endif -$ OPEN/WRITE TEMPOUT [-.uu]tempout.lis -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ DEFINE SYS$ERROR TEMPOUT -$ DEFINE SYS$OUTPUT TEMPOUT -$ mcr []temp -$ CLOSE TEMPOUT -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ OPEN/READ TEMPOUT [-.uu]tempout.lis -$ READ TEMPOUT line -$ CLOSE TEMPOUT -$ -$ perl_intsize=line -$ WRITE_RESULT "intsize is ''perl_intsize'" -$! -$! Check for short size -$! -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ WS "int main() -$ WS "{" -$ WS "printf(""%d\n"", sizeof(short)); -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ on error then continue -$ on warning then continue -$ 'Checkcc' temp.c -$ If (Needs_Opt.eqs."Yes") -$ THEN -$ link temp.obj,temp.opt/opt -$ else -$ link temp.obj -$ endif -$ OPEN/WRITE TEMPOUT [-.uu]tempout.lis -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ DEFINE SYS$ERROR TEMPOUT -$ DEFINE SYS$OUTPUT TEMPOUT -$ mcr []temp -$ CLOSE TEMPOUT -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ OPEN/READ TEMPOUT [-.uu]tempout.lis -$ READ TEMPOUT line -$ CLOSE TEMPOUT -$ -$ perl_shortsize=line -$ WRITE_RESULT "shortsize is ''perl_shortsize'" -$! -$! Check for long size -$! -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ WS "int main() -$ WS "{" -$ WS "int foo; -$ WS "foo = sizeof(long); -$ WS "printf(""%d\n"", foo); -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ on error then continue -$ on warning then continue -$ 'Checkcc' temp.c -$ If (Needs_Opt.eqs."Yes") -$ THEN -$ link temp.obj,temp.opt/opt -$ else -$ link temp.obj -$ endif -$ OPEN/WRITE TEMPOUT [-.uu]tempout.lis -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ DEFINE SYS$ERROR TEMPOUT -$ DEFINE SYS$OUTPUT TEMPOUT -$ mcr []temp -$ CLOSE TEMPOUT -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ OPEN/READ TEMPOUT [-.uu]tempout.lis -$ READ TEMPOUT line -$ CLOSE TEMPOUT -$ -$ perl_longsize=line -$ WRITE_RESULT "longsize is ''perl_longsize'" -$! -$! Check the prototype for getgid -$! -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ WS "#include <types.h> -$ WS "#include <unistd.h> -$ WS "int main() -$ WS "{" -$ WS "gid_t foo; -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ on error then continue -$ on warning then continue -$ 'Checkcc' temp.c -$ teststatus = f$extract(9,1,$status) -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ if (teststatus.nes."1") -$ THEN -$! Okay, gid_t failed. Must be unsigned int -$ perl_gidtype = "unsigned int" -$ ELSE -$ perl_gidtype = "gid_t" -$ ENDIF -$ WRITE_RESULT "Gid_t is ''perl_gidtype'" -$! -$! Check to see if we've got dev_t -$! -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ WS "#include <types.h> -$ WS "#include <unistd.h> -$ WS "int main() -$ WS "{" -$ WS "dev_t foo; -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ on error then continue -$ on warning then continue -$ 'Checkcc' temp.c -$ teststatus = f$extract(9,1,$status) -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ if (teststatus.nes."1") -$ THEN -$! Okay, dev_t failed. Must be unsigned int -$ perl_devtype = "unsigned int" -$ ELSE -$ perl_devtype = "dev_t" -$ ENDIF -$ WRITE_RESULT "Dev_t is ''perl_devtype'" -$! -$! Check to see if we've got unistd.h (which we ought to, but you never know) -$! -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <unistd.h> -$ WS "int main() -$ WS "{" -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ on error then continue -$ on warning then continue -$ 'Checkcc' temp.c -$ teststatus = f$extract(9,1,$status) -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ if (teststatus.nes."1") -$ THEN -$! Okay, failed. Must not have it -$ perl_i_unistd = "undef" -$ ELSE -$ perl_i_unistd = "define" - -$ ENDIF -$ WRITE_RESULT "i_unistd is ''perl_i_unistd'" -$! -$! Check the prototype for select -$! -$ if ("''Has_Dec_C_Sockets'".eqs."T").or.("''Has_Socketshr'".eqs."T") -$ THEN -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ WS "#include <types.h> -$ WS "#include <unistd.h> -$ if ("''Has_Socketshr'".eqs."T") -$ THEN -$ WS "#include <socketshr.h>" -$ else -$ WS "#include <time.h> -$ WS "#include <socket.h> -$ endif -$ WS "int main() -$ WS "{" -$ WS "fd_set *foo; -$ WS "int bar; -$ WS "foo = NULL; -$ WS "bar = select(2, foo, foo, foo, NULL); -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ on error then continue -$ on warning then continue -$ 'Checkcc' temp.c -$ teststatus = f$extract(9,1,$status) -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ if (teststatus.nes."1") -$ THEN -$! Okay, fd_set failed. Must be an int -$ perl_selecttype = "int *" -$ ELSE -$ perl_selecttype="fd_set *" -$ ENDIF -$ ELSE -$ ! No sockets, so stick in an int * -$ perl_selecttype = "int *" -$ ENDIF -$ WRITE_RESULT "selectype is ''perl_selecttype'" -$! -$! Check for sys/file.h -$! -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ WS "#include <unistd.h> -$ WS "#include <sys/file.h> -$ WS "int main() -$ WS "{" -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ on error then continue -$ on warning then continue -$ 'Checkcc' temp.c -$ savedstatus = $status -$ teststatus = f$extract(9,1,savedstatus) -$ if (teststatus.nes."1") -$ THEN -$ perl_i_sysfile="undef" -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ ELSE -$ If (Needs_Opt.eqs."Yes") -$ THEN -$ link temp.obj,temp.opt/opt -$ else -$ link temp.obj -$ endif -$ savedstatus = $status -$ teststatus = f$extract(9,1,savedstatus) -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ if (teststatus.nes."1") -$ THEN -$ perl_i_sysfile="undef" -$ ELSE -$ perl_i_sysfile="define" -$ ENDIF -$ ENDIF -$ WRITE_RESULT "i_sysfile is ''perl_i_sysfile'" -$! -$! Check for fcntl.h -$! -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ WS "#include <unistd.h> -$ WS "#include <fcntl.h> -$ WS "int main() -$ WS "{" -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ on error then continue -$ on warning then continue -$ 'Checkcc' temp.c -$ savedstatus = $status -$ teststatus = f$extract(9,1,savedstatus) -$ if (teststatus.nes."1") -$ THEN -$ perl_i_fcntl="undef" -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ ELSE -$ If (Needs_Opt.eqs."Yes") -$ THEN -$ link temp.obj,temp.opt/opt -$ else -$ link temp.obj -$ endif -$ savedstatus = $status -$ teststatus = f$extract(9,1,savedstatus) -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ if (teststatus.nes."1") -$ THEN -$ perl_i_fcntl="undef" -$ ELSE -$ perl_i_fcntl="define" -$ ENDIF -$ ENDIF -$ WRITE_RESULT "i_fcntl is ''perl_i_fcntl'" -$! -$! Check for fcntl -$! -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ WS "#include <unistd.h> -$ WS "#include <fcntl.h> -$ WS "int main() -$ WS "{" -$ WS "fcntl(1,2,3); -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ on error then continue -$ on warning then continue -$ 'Checkcc' temp.c -$ savedstatus = $status -$ teststatus = f$extract(9,1,savedstatus) -$ if (teststatus.nes."1") -$ THEN -$ perl_d_fcntl="undef" -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ ELSE -$ If (Needs_Opt.eqs."Yes") -$ THEN -$ link temp.obj,temp.opt/opt -$ else -$ link temp.obj -$ endif -$ savedstatus = $status -$ teststatus = f$extract(9,1,savedstatus) -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ if (teststatus.nes."1") -$ THEN -$ perl_d_fcntl="undef" -$ ELSE -$ perl_d_fcntl="define" -$ ENDIF -$ ENDIF -$ WRITE_RESULT "d_fcntl is ''perl_d_fcntl'" -$! -$! Check for bzero -$! -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ WS "#include <strings.h> -$ WS "int main() -$ WS "{" -$ WS "char foo[10]; -$ WS "bzero(foo, 10); -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ on error then continue -$ on warning then continue -$ 'Checkcc' temp.c -$ savedstatus = $status -$ teststatus = f$extract(9,1,savedstatus) -$ if (teststatus.nes."1") -$ THEN -$ perl_d_bzero="undef" -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ ELSE -$ If (Needs_Opt.eqs."Yes") -$ THEN -$ link temp.obj,temp.opt/opt -$ else -$ link temp.obj -$ endif -$ savedstatus = $status -$ teststatus = f$extract(9,1,savedstatus) -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ if (teststatus.nes."1") -$ THEN -$ perl_d_bzero="undef" -$ ELSE -$ perl_d_bzero="define" -$ ENDIF -$ ENDIF -$ WRITE_RESULT "d_bzero is ''perl_d_bzero'" -$! -$! Check for bcopy -$! -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ WS "#include <strings.h> -$ WS "int main() -$ WS "{" -$ WS "char foo[10], bar[10]; -$ WS "bcopy(""foo"", bar, 3); -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ on error then continue -$ on warning then continue -$ 'Checkcc' temp.c -$ savedstatus = $status -$ teststatus = f$extract(9,1,savedstatus) -$ if (teststatus.nes."1") -$ THEN -$ perl_d_bcopy="undef" -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ ELSE -$ If (Needs_Opt.eqs."Yes") -$ THEN -$ link temp.obj,temp.opt/opt -$ else -$ link temp.obj -$ endif -$ savedstatus = $status -$ teststatus = f$extract(9,1,savedstatus) -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ if (teststatus.nes."1") -$ THEN -$ perl_d_bcopy="undef" -$ ELSE -$ perl_d_bcopy="define" -$ ENDIF -$ ENDIF -$ WRITE_RESULT "d_bcopy is ''perl_d_bcopy'" -$! -$! Check for mkstemp -$! -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ WS "int main() -$ WS "{" -$ WS "mkstemp(""foo""); -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ on error then continue -$ on warning then continue -$ 'Checkcc' temp.c -$ If (Needs_Opt.eqs."Yes") -$ THEN -$ link temp.obj,temp.opt/opt -$ else -$ link temp.obj -$ endif -$ savedstatus = $status -$ teststatus = f$extract(9,1,savedstatus) -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ if (teststatus.nes."1") -$ THEN -$ perl_d_mkstemp="undef" -$ ELSE -$ perl_d_mkstemp="define" -$ ENDIF -$ WRITE_RESULT "d_mkstemp is ''perl_d_mkstemp'" -$! -$! Check for setvbuf -$! -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ WS "int main() -$ WS "{" -$ WS "FILE *foo; -$ WS "char Buffer[99]; -$ WS "foo = fopen(""foo"", ""r""); -$ WS "setvbuf(foo, Buffer, 0, 0); -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ on error then continue -$ on warning then continue -$ 'Checkcc' temp.c -$ If (Needs_Opt.eqs."Yes") -$ THEN -$ link temp.obj,temp.opt/opt -$ else -$ link temp.obj -$ endif -$ teststatus = f$extract(9,1,$status) -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ if (teststatus.nes."1") -$ THEN -$ perl_d_setvbuf="undef" -$ ELSE -$ perl_d_setvbuf="define" -$ ENDIF -$ WRITE_RESULT "d_setvbuf is ''perl_d_setvbuf'" -$! -$! Check for <netinet/in.h> -$! -$ if ("''Has_Dec_C_Sockets'".eqs."T").or.("''Has_Socketshr'".eqs."T") -$ THEN -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ if ("''Has_Socketshr'".eqs."T") -$ THEN -$ WS "#include <socketshr.h>" -$ else -$ WS "#include <netdb.h> -$ endif -$ WS "#include <netinet/in.h>" -$ WS "int main() -$ WS "{" -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ on error then continue -$ on warning then continue -$ 'Checkcc' temp.c -$ If (Needs_Opt.eqs."Yes") -$ THEN -$ link temp.obj,temp.opt/opt -$ else -$ link temp.obj -$ endif -$ teststatus = f$extract(9,1,$status) -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ if (teststatus.nes."1") -$ THEN -$ perl_i_niin="undef" -$ ELSE -$ perl_i_niin="define" -$ ENDIF -$ ELSE -$ perl_i_niin="undef" -$ ENDIF -$ WRITE_RESULT "i_niin is ''perl_i_niin'" -$! -$! Check for endhostent -$! -$ if ("''Has_Dec_C_Sockets'".eqs."T").or.("''Has_Socketshr'".eqs."T") -$ THEN -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ if ("''Has_Socketshr'".eqs."T") -$ THEN -$ WS "#include <socketshr.h>" -$ else -$ WS "#include <netdb.h> -$ endif -$ WS "int main() -$ WS "{" -$ WS "endhostent(); -$ WS "exit(0); - -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ on error then continue -$ on warning then continue -$ 'Checkcc' temp.c -$ If (Needs_Opt.eqs."Yes") -$ THEN -$ link temp.obj,temp.opt/opt -$ else -$ link temp.obj -$ endif -$ teststatus = f$extract(9,1,$status) -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ if (teststatus.nes."1") -$ THEN -$ perl_d_endhent="undef" -$ ELSE -$ perl_d_endhent="define" -$ ENDIF -$ ELSE -$ perl_d_endhent="undef" -$ ENDIF -$ WRITE_RESULT "d_endhent is ''perl_d_endhent'" -$! -$! Check for endnetent -$! -$ if ("''Has_Dec_C_Sockets'".eqs."T").or.("''Has_Socketshr'".eqs."T") -$ THEN -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ if ("''Has_Socketshr'".eqs."T") -$ THEN -$ WS "#include <socketshr.h>" -$ else -$ WS "#include <netdb.h> -$ endif -$ WS "int main() -$ WS "{" -$ WS "endnetent(); -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ on error then continue -$ on warning then continue -$ 'Checkcc' temp.c -$ If (Needs_Opt.eqs."Yes") -$ THEN -$ link temp.obj,temp.opt/opt -$ else -$ link temp.obj -$ endif -$ teststatus = f$extract(9,1,$status) -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ if (teststatus.nes."1") -$ THEN -$ perl_d_endnent="undef" -$ ELSE -$ perl_d_endnent="define" -$ ENDIF -$ ELSE -$ perl_d_endnent="undef" -$ ENDIF -$ WRITE_RESULT "d_endnent is ''perl_d_endnent'" -$! -$! Check for endprotoent -$! -$ if ("''Has_Dec_C_Sockets'".eqs."T").or.("''Has_Socketshr'".eqs."T") -$ THEN -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ if ("''Has_Socketshr'".eqs."T") -$ THEN -$ WS "#include <socketshr.h>" -$ else -$ WS "#include <netdb.h> -$ endif -$ WS "int main() -$ WS "{" -$ WS "endprotoent(); -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ on error then continue -$ on warning then continue -$ 'Checkcc' temp.c -$ If (Needs_Opt.eqs."Yes") -$ THEN -$ link temp.obj,temp.opt/opt -$ else -$ link temp.obj -$ endif -$ teststatus = f$extract(9,1,$status) -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ if (teststatus.nes."1") -$ THEN -$ perl_d_endpent="undef" -$ ELSE -$ perl_d_endpent="define" -$ ENDIF -$ ELSE -$ perl_d_endpent="undef" -$ ENDIF -$ WRITE_RESULT "d_endpent is ''perl_d_endpent'" -$! -$! Check for endservent -$! -$ if ("''Has_Dec_C_Sockets'".eqs."T").or.("''Has_Socketshr'".eqs."T") -$ THEN -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ if ("''Has_Socketshr'".eqs."T") -$ THEN -$ WS "#include <socketshr.h>" -$ else -$ WS "#include <netdb.h> -$ endif -$ WS "int main() -$ WS "{" -$ WS "endservent(); -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ on error then continue -$ on warning then continue -$ 'Checkcc' temp.c -$ If (Needs_Opt.eqs."Yes") -$ THEN -$ link temp.obj,temp.opt/opt -$ else -$ link temp.obj -$ endif -$ teststatus = f$extract(9,1,$status) -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ if (teststatus.nes."1") -$ THEN -$ perl_d_endsent="undef" -$ ELSE -$ perl_d_endsent="define" -$ ENDIF -$ ELSE -$ perl_d_endsent="undef" -$ ENDIF -$ WRITE_RESULT "d_endsent is ''perl_d_endsent'" -$! -$! Check for sethostent -$! -$ if ("''Has_Dec_C_Sockets'".eqs."T").or.("''Has_Socketshr'".eqs."T") -$ THEN -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ if ("''Has_Socketshr'".eqs."T") -$ THEN -$ WS "#include <socketshr.h>" -$ else -$ WS "#include <netdb.h> -$ endif -$ WS "int main() -$ WS "{" -$ WS "sethostent(1); -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ on error then continue -$ on warning then continue -$ 'Checkcc' temp.c -$ If (Needs_Opt.eqs."Yes") -$ THEN -$ link temp.obj,temp.opt/opt -$ else -$ link temp.obj -$ endif -$ teststatus = f$extract(9,1,$status) -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ if (teststatus.nes."1") -$ THEN -$ perl_d_sethent="undef" -$ ELSE -$ perl_d_sethent="define" -$ ENDIF -$ ELSE -$ perl_d_sethent="undef" -$ ENDIF -$ WRITE_RESULT "d_sethent is ''perl_d_sethent'" -$! -$! Check for setnetent -$! -$ if ("''Has_Dec_C_Sockets'".eqs."T").or.("''Has_Socketshr'".eqs."T") -$ THEN -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ if ("''Has_Socketshr'".eqs."T") -$ THEN -$ WS "#include <socketshr.h>" -$ else -$ WS "#include <netdb.h> -$ endif -$ WS "int main() -$ WS "{" -$ WS "setnetent(1); -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ on error then continue -$ on warning then continue -$ 'Checkcc' temp.c -$ If (Needs_Opt.eqs."Yes") -$ THEN -$ link temp.obj,temp.opt/opt -$ else -$ link temp.obj -$ endif -$ teststatus = f$extract(9,1,$status) -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ if (teststatus.nes."1") -$ THEN -$ perl_d_setnent="undef" -$ ELSE -$ perl_d_setnent="define" -$ ENDIF -$ ELSE -$ perl_d_setnent="undef" -$ ENDIF -$ WRITE_RESULT "d_setnent is ''perl_d_setnent'" -$! -$! Check for setprotoent -$! -$ if ("''Has_Dec_C_Sockets'".eqs."T").or.("''Has_Socketshr'".eqs."T") -$ THEN -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ if ("''Has_Socketshr'".eqs."T") -$ THEN -$ WS "#include <socketshr.h>" -$ else -$ WS "#include <netdb.h> -$ endif -$ WS "int main() -$ WS "{" -$ WS "setprotoent(1); -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ on error then continue -$ on warning then continue -$ 'Checkcc' temp.c -$ If (Needs_Opt.eqs."Yes") -$ THEN -$ link temp.obj,temp.opt/opt -$ else -$ link temp.obj -$ endif -$ teststatus = f$extract(9,1,$status) -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ if (teststatus.nes."1") -$ THEN -$ perl_d_setpent="undef" -$ ELSE -$ perl_d_setpent="define" -$ ENDIF -$ ELSE -$ perl_d_setpent="undef" -$ ENDIF -$ WRITE_RESULT "d_setpent is ''perl_d_setpent'" -$! -$! Check for setservent -$! -$ if ("''Has_Dec_C_Sockets'".eqs."T").or.("''Has_Socketshr'".eqs."T") -$ THEN -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ if ("''Has_Socketshr'".eqs."T") -$ THEN -$ WS "#include <socketshr.h>" -$ else -$ WS "#include <netdb.h> -$ endif -$ WS "int main() -$ WS "{" -$ WS "setservent(1); -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ on error then continue -$ on warning then continue -$ 'Checkcc' temp.c -$ If (Needs_Opt.eqs."Yes") -$ THEN -$ link temp.obj,temp.opt/opt -$ else -$ link temp.obj -$ endif -$ teststatus = f$extract(9,1,$status) -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ if (teststatus.nes."1") -$ THEN -$ perl_d_setsent="undef" -$ ELSE -$ perl_d_setsent="define" -$ ENDIF -$ ELSE -$ perl_d_setsent="undef" -$ ENDIF -$ WRITE_RESULT "d_setsent is ''perl_d_setsent'" -$! -$! Check for gethostent -$! -$ if ("''Has_Dec_C_Sockets'".eqs."T").or.("''Has_Socketshr'".eqs."T") -$ THEN -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ if ("''Has_Socketshr'".eqs."T") -$ THEN -$ WS "#include <socketshr.h>" -$ else -$ WS "#include <netdb.h> -$ endif -$ WS "int main() -$ WS "{" -$ WS "gethostent(); -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ on error then continue -$ on warning then continue -$ 'Checkcc' temp.c -$ If (Needs_Opt.eqs."Yes") -$ THEN -$ link temp.obj,temp.opt/opt -$ else -$ link temp.obj -$ endif -$ teststatus = f$extract(9,1,$status) -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ if (teststatus.nes."1") -$ THEN -$ perl_d_gethent="undef" -$ ELSE -$ perl_d_gethent="define" -$ ENDIF -$ ELSE -$ perl_d_gethent="undef" -$ ENDIF -$ WRITE_RESULT "d_gethent is ''perl_d_gethent'" -$! -$! Check for getnetent -$! -$ if ("''Has_Dec_C_Sockets'".eqs."T").or.("''Has_Socketshr'".eqs."T") -$ THEN -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ if ("''Has_Socketshr'".eqs."T") -$ THEN -$ WS "#include <socketshr.h>" -$ else -$ WS "#include <netdb.h> -$ endif -$ WS "int main() -$ WS "{" -$ WS "getnetent(); -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ on error then continue -$ on warning then continue -$ 'Checkcc' temp.c -$ If (Needs_Opt.eqs."Yes") -$ THEN -$ link temp.obj,temp.opt/opt -$ else -$ link temp.obj -$ endif -$ teststatus = f$extract(9,1,$status) -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ if (teststatus.nes."1") -$ THEN -$ perl_d_getnent="undef" -$ ELSE -$ perl_d_getnent="define" -$ ENDIF -$ ELSE -$ perl_d_getnent="undef" -$ ENDIF -$ WRITE_RESULT "d_getnent is ''perl_d_getnent'" -$! -$! Check for getprotoent -$! -$ if ("''Has_Dec_C_Sockets'".eqs."T").or.("''Has_Socketshr'".eqs."T") -$ THEN -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ if ("''Has_Socketshr'".eqs."T") -$ THEN -$ WS "#include <socketshr.h>" -$ else -$ WS "#include <netdb.h> -$ endif -$ WS "int main() -$ WS "{" -$ WS "getprotoent(); -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ on error then continue -$ on warning then continue -$ 'Checkcc' temp.c -$ If (Needs_Opt.eqs."Yes") -$ THEN -$ link temp.obj,temp.opt/opt -$ else -$ link temp.obj -$ endif -$ teststatus = f$extract(9,1,$status) -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ if (teststatus.nes."1") -$ THEN -$ perl_d_getpent="undef" -$ ELSE -$ perl_d_getpent="define" -$ ENDIF -$ ELSE -$ perl_d_getpent="undef" -$ ENDIF -$ WRITE_RESULT "d_getpent is ''perl_d_getpent'" -$! -$! Check for getservent -$! -$ if ("''Has_Dec_C_Sockets'".eqs."T").or.("''Has_Socketshr'".eqs."T") -$ THEN -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ if ("''Has_Socketshr'".eqs."T") -$ THEN -$ WS "#include <socketshr.h>" -$ else -$ WS "#include <netdb.h> -$ endif -$ WS "int main() -$ WS "{" -$ WS "getservent(); -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ on error then continue -$ on warning then continue -$ 'Checkcc' temp.c -$ If (Needs_Opt.eqs."Yes") -$ THEN -$ link temp.obj,temp.opt/opt -$ else -$ link temp.obj -$ endif -$ teststatus = f$extract(9,1,$status) -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ if (teststatus.nes."1") -$ THEN -$ perl_d_getsent="undef" -$ ELSE -$ perl_d_getsent="define" -$ ENDIF -$ ELSE -$ perl_d_getsent="undef" -$ ENDIF -$ WRITE_RESULT "d_getsent is ''perl_d_getsent'" -$! -$! Check for pthread_yield -$! -$ if ("''use_threads'".eqs."T") -$ THEN -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <pthread.h> -$ WS "#include <stdio.h> -$ WS "int main() -$ WS "{" -$ WS "pthread_yield(); -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ on error then continue -$ on warning then continue -$ 'Checkcc' temp.c -$ teststatus = f$extract(9,1,$status) -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ if (teststatus.nes."1") -$ THEN -$ perl_d_pthread_yield="undef" -$ ELSE -$ perl_d_pthread_yield="define" -$ ENDIF -$ ELSE -$ perl_d_pthread_yield="undef" -$ ENDIF -$ WRITE_RESULT "d_pthread_yield is ''perl_d_pthread_yield'" -$! -$! Check for sched_yield -$! -$ if ("''use_threads'".eqs."T") -$ THEN -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <pthread.h> -$ WS "#include <stdio.h> -$ WS "int main() -$ WS "{" -$ WS "sched_yield(); -$ WS "exit(0); -$ WS "}" -$ CS -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ on error then continue -$ on warning then continue -$ 'Checkcc' temp.c -$ teststatus = f$extract(9,1,$status) -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ if (teststatus.nes."1") -$ THEN -$ perl_d_sched_yield="undef" -$ ELSE -$ perl_d_sched_yield="define" -$ ENDIF -$ ELSE -$ perl_d_sched_yield="undef" -$ ENDIF -$ WRITE_RESULT "d_sched_yield is ''perl_d_sched_yield'" -$! -$! Check for generic pointer size -$! -$ OS -$ WS "#ifdef __DECC -$ WS "#include <stdlib.h> -$ WS "#endif -$ WS "#include <stdio.h> -$ WS "int main() -$ WS "{" -$ WS "int foo; -$ WS "foo = sizeof(char *); -$ WS "printf(""%d\n"", foo); -$ WS "exit(0); -$ WS "}" -$ CS -$! copy temp.c sys$output -$! -$ DEFINE SYS$ERROR _NLA0: -$ DEFINE SYS$OUTPUT _NLA0: -$ ON ERROR THEN CONTINUE -$ ON WARNING THEN CONTINUE -$ 'Checkcc' temp.c -$ If (Needs_Opt.eqs."Yes") -$ THEN -$ link temp.obj,temp.opt/opt -$ else -$ link temp.obj -$ endif -$ OPEN/WRITE TEMPOUT [-.uu]tempout.lis -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ DEFINE SYS$ERROR TEMPOUT -$ DEFINE SYS$OUTPUT TEMPOUT -$ mcr []temp -$ CLOSE TEMPOUT -$ DEASSIGN SYS$OUTPUT -$ DEASSIGN SYS$ERROR -$ OPEN/READ TEMPOUT [-.uu]tempout.lis -$ READ TEMPOUT line -$ CLOSE TEMPOUT -$ -$ perl_ptrsize=line -$ WRITE_RESULT "ptrsize is ''perl_ptrsize'" -$! -$ set nover -$! Done with compiler checks. Clean up. -$ if f$search("temp.c").nes."" then DELETE/NOLOG temp.c;* -$ if f$search("temp.obj").nes."" then DELETE/NOLOG temp.obj;* -$ if f$search("temp.exe").nes."" then DELETE/NOLOG temp.exe;* -$ if f$search("temp.opt").nes."" then DELETE/NOLOG Temp.opt;* -$! -$! -$! Some that are compiler or VMS version sensitive -$! -$! Gnu C stuff -$ IF "''Using_Gnu_C'".EQS."Yes" -$ THEN -$ perl_d_attribut="define" -$ perl_vms_cc_type="gcc" -$ ELSE -$ perl_d_attribut="undef" -$ ENDIF -$ -$! Dec C >= 5.2 and VMS ver >= 7.0 -$ IF ("''Using_Dec_C'".EQS."Yes").AND.(F$INTEGER(Dec_C_Version).GE.50200000).AND.("''VMS_VER'".GES."7.0") -$ THEN -$ perl_d_bcmp="define" -$ perl_d_gettimeod="define" -$ perl_d_uname="define" -$ perl_d_sigaction="define" -$ perl_d_truncate="define" -$ perl_d_wait4="define" -$ perl_d_index="define" -$ perl_pidtype="pid_t" -$ perl_sig_name="ZERO HUP INT QUIT ILL TRAP IOT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM ABRT USR1 USR2 SPARE18 SPARE19 CHLD CONT STOP TSTP TTIN TTOU DEBUG SPARE27 SPARE28 SPARE29 SPARE30 SPARE31 SPARE32 RTMIN RTMAX"",0" -$ psnwc1="""ZERO"",""HUP"",""INT"",""QUIT"",""ILL"",""TRAP"",""IOT"",""EMT"",""FPE"",""KILL"",""BUS"",""SEGV"",""SYS""," -$ psnwc2="""PIPE"",""ALRM"",""TERM"",""ABRT"",""USR1"",""USR2"",""SPARE18"",""SPARE19"",""CHLD"",""CONT"",""STOP"",""TSTP""," -$ psnwc3="""TTIN"",""TTOU"",""DEBUG"",""SPARE27"",""SPARE28"",""SPARE29"",""SPARE30"",""SPARE31"",""SPARE32"",""RTMIN"",""RTMAX"",0" -$perl_sig_name_with_commas = psnwc1 + psnwc2 + psnwc3 -$ perl_sig_num="0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,6,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,64,0" -$ perl_sig_num_with_commas=perl_sig_num -$ perl_uidtype="uid_t" -$ perl_d_pathconf="define" -$ perl_d_fpathconf="define" -$ perl_d_sysconf="define" -$ perl_d_sigsetjmp="define" -$ ELSE -$ perl_pidtype="unsigned int" -$ perl_d_gettimeod="undef" -$ perl_d_bcmp="undef" -$ perl_d_uname="undef" -$ perl_d_sigaction="undef" -$ perl_d_truncate="undef" -$ perl_d_wait4="undef" -$ perl_d_index="undef" -$ perl_sig_name="ZERO HUP INT QUIT ILL TRAP IOT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM ABRT USR1 USR2"",0" -$ psnwc1="""ZERO"",""HUP"",""INT"",""QUIT"",""ILL"",""TRAP"",""IOT"",""EMT"",""FPE"",""KILL"",""BUS"",""SEGV"",""SYS""," -$ psnwc2="""PIPE"",""ALRM"",""TERM"",""ABRT"",""USR1"",""USR2"",0" -$ perl_sig_name_with_commas = psnwc1 + psnwc2 -$ perl_sig_num="0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,6,16,17,0" -$ perl_sig_num_with_commas=perl_sig_num -$ perl_uidtype="unsigned int" -$ perl_d_pathconf="undef" -$ perl_d_fpathconf="undef" -$ perl_d_sysconf="undef" -$ perl_d_sigsetjmp="undef" -$ ENDIF -$! -$! Dec C alone -$ IF ("''Using_Dec_C'".EQS."Yes") -$ THEN -$ perl_d_mbstowcs="define" -$ perl_d_mbtowc="define" -$ perl_d_stdiobase="define" -$ perl_d_stdio_ptr_lval="define" -$ perl_d_stdio_cnt_lval="define" -$ perl_d_stdstdio="define" -$ perl_d_wcstombs="define" -$ perl_d_mblen="define" -$ perl_d_mktime="define" -$ perl_d_strcoll="define" -$ perl_d_strxfrm="define" -$ perl_d_wctomb="define" -$ perl_i_locale="define" -$ perl_d_locconv="define" -$ perl_d_setlocale="define" -$ perl_vms_cc_type="decc" -$ ELSE -$ perl_d_mbstowcs="undef" -$ perl_d_mbtowc="undef" -$ perl_d_stdiobase="undef" -$ perl_d_stdio_ptr_lval="undef" -$ perl_d_stdio_cnt_lval="undef" -$ perl_d_stdstdio="undef" -$ perl_d_wcstombs="undef" -$ perl_d_mblen="undef" -$ perl_d_mktime="undef" -$ perl_d_strcoll="undef" -$ perl_d_strxfrm="undef" -$ perl_d_wctomb="undef" -$ perl_i_locale="undef" -$ perl_d_locconv="undef" -$ perl_d_setlocale="undef" -$ ENDIF -$! -$! Vax C stuff -$ if ("''Using_Vax_C'".EQS."Yes") -$ THEN -$ perl_vms_cc_type="vaxc" -$ ENDIF -$! -$! -$! Sockets? -$ if ("''Has_Socketshr'".EQS."T").OR.("''Has_Dec_C_Sockets'".EQS."T") -$ THEN -$ perl_d_vms_do_sockets="define" -$ perl_d_htonl="define" -$ perl_d_socket="define" -$ perl_d_select="define" -$ perl_netdb_host_type="char *" -$ perl_netdb_hlen_type="int" -$ perl_netdb_name_type="char *" -$ perl_netdb_net_type="long" -$ perl_d_gethbyaddr="define" -$ perl_d_gethbyname="define" -$ perl_d_getnbyaddr="define" -$ perl_d_getnbyname="define" -$ perl_d_getpbynumber="define" -$ perl_d_getpbyname="define" -$ perl_d_getsbyport="define" -$ perl_d_getsbyname="define" -$ perl_d_gethostprotos="define" -$ perl_d_getnetprotos="define" -$ perl_d_getprotoprotos="define" -$ perl_d_getservprotos="define" -$ ELSE -$ perl_d_vms_do_sockets="undef" -$ perl_d_htonl="undef" -$ perl_d_socket="undef" -$ perl_d_select="undef" -$ perl_netdb_host_type="char *" -$ perl_netdb_hlen_type="int" -$ perl_netdb_name_type="char *" -$ perl_netdb_net_type="long" -$ perl_d_gethbyaddr="undef" -$ perl_d_gethbyname="undef" -$ perl_d_getnbyaddr="undef" -$ perl_d_getnbyname="undef" -$ perl_d_getpbynumber="undef" -$ perl_d_getpbyname="undef" -$ perl_d_getsbyport="undef" -$ perl_d_getsbyname="undef" -$ perl_d_gethostprotos="undef" -$ perl_d_getnetprotos="undef" -$ perl_d_getprotoprotos="undef" -$ perl_d_getservprotos="undef" -$ ENDIF -$! Threads -$ if ("''use_threads'".eqs."T") -$ THEN -$ perl_usethreads="define" -$ perl_d_pthreads_created_joinable="define" -$ if ("''VMS_VER'".ges."7.0") -$ THEN -$ perl_d_oldpthreads="undef" -$ ELSE -$ perl_d_oldpthreads="define" -$ ENDIF -$ ELSE -$ perl_d_oldpthreads="undef" -$ perl_usethreads="undef" -$ -$ perl_d_pthreads_created_joinable="undef" -$ ENDIF -$! -$! -$! Finally the composite ones. All config -$ perl_installarchlib="''perl_prefix':[lib.''perl_arch'.''localperlver']" -$ perl_installsitearch="''perl_prefix':[lib.site_perl.''perl_arch']" -$ perl_myhostname="''myhostname'" -$ perl_mydomain="''mydomain'" -$ perl_perladmin="''perladmin'" -$ perl_cf_email="''cf_email'" -$ perl_myuname:="VMS ''myname' ''f$edit(perl_osvers, "TRIM")' ''f$edit(hwname, "TRIM")'" -$ perl_archlibexp="''perl_prefix':[lib.''perl_arch'.''localperlver']" -$ perl_archlib="''perl_prefix':[lib.''perl_arch'.''lovalperlver']" -$ perl_oldarchlibexp="''perl_prefix':[lib.''perl_arch']" -$ perl_oldarchlib="''perl_prefix':[lib.''perl_arch']" -$ perl_sitearchexp="''perl_prefix':[lib.site_perl.''perl_arch']" -$ perl_sitearch="''perl_prefix':[lib.site_perl.''perl_arch']" -$ if "''Using_Dec_C'" .eqs. "Yes" -$ THEN -$ perl_ccflags="/Include=[]/Standard=Relaxed_ANSI/Prefix=All/Obj=''perl_obj_ext'/NoList''cc_flags'" -$ ELSE -$ IF "''Using_Vax_C'" .eqs. "Yes" -$ THEN -$ perl_ccflags="/Include=[]/Obj=''perl_obj_ext'/NoList''cc_flags'" -$ ENDIF -$ ENDIF -$! -$! Finally clean off any leading zeros from the patchlevel or subversion -$ perl_patchlevel = perl_patchlevel + 0 -$ perl_subversion = perl_subversion + 0 -$! -$! Okay, we've got everything configured. Now go write out a config.sh. -$ open/write CONFIGSH [-]config.sh -$ WC := "write CONFIGSH" -$! -$ WC "# This file generated by Configure.COM on a VMS system." -$ WC "# Time: " + perl_cf_time -$ WC "" -$ WC "package='" + perl_package + "'" -$ WC "CONFIG='" + perl_config + "'" -$ WC "cf_time='" + perl_cf_time + "'" -$ WC "cf_by='" + perl_cf_by+ "'" -$ WC "cpp_stuff='" + perl_cpp_stuff + "'" -$ WC "ccdlflags='" + perl_ccdlflags + "'" -$ WC "cccdlflags='" + perl_cccdlflags + "'" -$ WC "mab='" + perl_mab + "'" -$ WC "libpth='" + perl_libpth + "'" -$ WC "ld='" + perl_ld + "'" -$ WC "lddlflags='" + perl_lddlflags + "'" -$ WC "ranlib='" + perl_ranlib + "'" -$ WC "ar='" + perl_ar + "'" -$ WC "eunicefix='" + perl_eunicefix + "'" -$ WC "hint='" + perl_hint +"'" -$ WC "hintfile='" + perl_hintfile + "'" -$ WC "shrplib='" + perl_shrplib + "'" -$ WC "usemymalloc='" + perl_usemymalloc + "'" -$ WC "usevfork='" + perl_usevfork + "'" -$ WC "useposix='false'" -$ WC "spitshell='write sys$output '" -$ WC "dlsrc='dl_vms.c'" -$ WC "binexp='" + perl_binexp + "'" -$ WC "man1ext='" + perl_man1ext + "'" -$ WC "man3ext='" + perl_man3ext + "'" -$ WC "arch='" + perl_arch + "'" -$ WC "archname='" + perl_archname + "'" -$ WC "osvers='" + perl_osvers + "'" -$ WC "prefix='" + perl_prefix + "'" -$ WC "builddir='" + perl_builddir + "'" -$ WC "installbin='" + perl_installbin + "'" -$ WC "installscript='" + perl_installscript + "'" -$ WC "installman1dir='" + perl_installman1dir + "'" -$ WC "installman3dir='" + perl_installman3dir + "'" -$ WC "installprivlib='" + perl_installprivlib + "'" -$ WC "installarchlib='" + perl_installarchlib + "'" -$ WC "installsitelib='" + perl_installsitelib + "'" -$ WC "installsitearch='" + perl_installsitearch + "'" -$ WC "path_sep='" + perl_path_sep + "'" -$ WC "vms_cc_type='" + perl_vms_cc_type + "'" -$ WC "d_attribut='" + perl_d_attribut + "'" -$ WC "cc='" + perl_cc + "'" -$ WC "ccflags='" + perl_ccflags + "'" -$ WC "d_vms_do_sockets='" + perl_d_vms_do_sockets + "'" -$ WC "d_socket='" + perl_d_socket + "'" -$ WC "d_sockpair='" + perl_d_sockpair + "'" -$ WC "d_gethent='" + perl_d_gethent + "'" -$ WC "d_getsent='" + perl_d_getsent + "'" -$ WC "d_select='" + perl_d_select + "'" -$ WC "i_niin='" + perl_i_niin + "'" -$ WC "i_neterrno='" + perl_i_neterrno + "'" -$ WC "d_stdstdio='" + perl_d_stdstdio + "'" -$ WC "d_stdio_ptr_lval='" + perl_d_stdio_ptr_lval + "'" -$ WC "d_stdio_cnt_lval='" + perl_d_stdio_cnt_lval + "'" -$ WC "d_stdiobase='" + perl_d_stdiobase + "'" -$ WC "d_locconv='" + perl_d_locconv + "'" -$ WC "d_setlocale='" + perl_d_setlocale + "'" -$ WC "i_locale='" + perl_i_locale + "'" -$ WC "d_mbstowcs='" + perl_d_mbstowcs + "'" -$ WC "d_mbtowc='" + perl_d_mbtowc + "'" -$ WC "d_wcstombs='" + perl_d_wcstombs + "'" -$ WC "d_wctomb='" + perl_d_wctomb + "'" -$ WC "d_mblen='" + perl_d_mblen + "'" -$ WC "d_mktime='" + perl_d_mktime + "'" -$ WC "d_strcoll='" + perl_d_strcoll + "'" -$ WC "d_strxfrm='" + perl_d_strxfrm + "'" -$ WC "ldflags='" + perl_ldflags + "'" -$ WC "dlobj='" + perl_dlobj + "'" -$ WC "obj_ext='" + perl_obj_ext + "'" -$ WC "so='" + perl_so + "'" -$ WC "dlext='" + perl_dlext + "'" -$ WC "exe_ext='" + perl_exe_ext + "'" -$ WC "lib_ext='" + perl_lib_ext + "'" -$ WC "myhostname='" + perl_myhostname + "'" -$ WC "mydomain='" + perl_mydomain + "'" -$ WC "perladmin='" + perl_perladmin + "'" -$ WC "cf_email='" + perl_cf_email + "'" -$ WC "myuname='" + perl_myuname + "'" -$ WC "alignbytes='" + perl_alignbytes + "'" -$ WC "osname='" + perl_osname + "'" -$ WC "d_archlib='" + perl_d_archlib + "'" -$ WC "archlibexp='" + perl_archlibexp + "'" -$ WC "archlib='" + perl_archlib + "'" -$ WC "archname='" + perl_archname + "'" -$ WC "d_bincompat3='" + perl_d_bincompat3 + "'" -$ WC "cppstdin='" + perl_cppstdin + "'" -$ WC "cppminus='" + perl_cppminus + "'" -$ WC "d_bcmp='" + perl_d_bcmp + "'" -$ WC "d_bcopy='" + perl_d_bcopy + "'" -$ WC "d_bzero='" + perl_d_bzero + "'" -$ WC "d_castneg='" + perl_d_castneg + "'" -$ WC "castflags='" + perl_castflags + "'" -$ WC "d_chsize='" + perl_d_chsize + "'" -$ WC "d_const='" + perl_d_const + "'" -$ WC "d_crypt='" + perl_d_crypt + "'" -$ WC "byteorder='" + perl_byteorder + "'" -$ WC "full_csh='" + perl_full_csh + "'" -$ WC "d_csh='" + perl_d_csh + "'" -$ WC "d_dup2='" + perl_d_dup2 + "'" -$ WC "d_fchmod='" + perl_d_fchmod + "'" -$ WC "d_fchown='" + perl_d_fchown + "'" -$ WC "d_fcntl='" + perl_d_fcntl + "'" -$ WC "d_fgetpos='" + perl_d_fgetpos + "'" -$ WC "d_flexfnam='" + perl_d_flexfnam + "'" -$ WC "d_flock='" + perl_d_flock + "'" -$ WC "d_fsetpos='" + perl_d_fsetpos + "'" -$ WC "d_gettimeod='" + perl_d_gettimeod + "'" -$ WC "d_getgrps='" + perl_d_getgrps + "'" -$ WC "d_setgrps='" + perl_d_setgrps + "'" -$ WC "d_uname='" + perl_d_uname + "'" -$ WC "d_getprior='" + perl_d_getprior + "'" -$ WC "d_killpg='" + perl_d_killpg + "'" -$ WC "d_link='" + perl_d_link + "'" -$ WC "d_lstat='" + perl_d_lstat + "'" -$ WC "d_lockf='" + perl_d_lockf + "'" -$ WC "d_memcmp='" + perl_d_memcmp + "'" -$ WC "d_memcpy='" + perl_d_memcpy + "'" -$ WC "d_memmove='" + perl_d_memmove + "'" -$ WC "d_memset='" + perl_d_memset + "'" -$ WC "d_mkdir='" + perl_d_mkdir + "'" -$ WC "d_msg='" + perl_d_msg + "'" -$ WC "d_open3='" + perl_d_open3 + "'" -$ WC "d_poll='" + perl_d_poll + "'" -$ WC "d_readdir='" + perl_d_readdir + "'" -$ WC "d_seekdir='" + perl_d_seekdir + "'" -$ WC "d_telldir='" + perl_d_telldir + "'" -$ WC "d_rewinddir='" + perl_d_rewinddir + "'" -$ WC "d_rename='" + perl_d_rename + "'" -$ WC "d_rmdir='" + perl_d_rmdir + "'" -$ WC "d_sem='" + perl_d_sem + "'" -$ WC "d_setegid='" + perl_d_setegid + "'" -$ WC "d_seteuid='" + perl_d_seteuid + "'" -$ WC "d_setprior='" + perl_d_setprior + "'" -$ WC "d_setregid='" + perl_d_setregid + "'" -$ WC "d_setresgid='" + perl_d_setresgid + "'" -$ WC "d_setreuid='" + perl_d_setreuid + "'" -$ WC "d_setresuid='" + perl_d_setresuid + "'" -$ WC "d_setrgid='" + perl_d_setrgid + "'" -$ WC "d_setruid='" + perl_d_setruid + "'" -$ WC "d_setsid='" + perl_d_setsid + "'" -$ WC "d_shm='" + perl_d_shm + "'" -$ WC "d_shmatprototype='" + perl_d_shmatprototype + "'" -$ WC "d_sigaction='" + perl_d_sigaction + "'" -$ WC "d_statblks='" + perl_d_statblks + "'" -$ WC "stdio_ptr='" + perl_stdio_ptr + "'" -$ WC "stdio_cnt='" + perl_stdio_cnt + "'" -$ WC "stdio_base='" + perl_stdio_base + "'" -$ WC "stdio_bufsiz='" + perl_stdio_bufsiz + "'" -$ WC "d_strctcpy='" + perl_d_strctcpy + "'" -$ WC "d_strerror='" + perl_d_strerror + "'" -$ WC "d_syserrlst='" + perl_d_syserrlst + "'" -$ WC "d_strerrm='" + perl_d_strerrm + "'" -$ WC "d_symlink='" + perl_d_symlink + "'" -$ WC "d_syscall='" + perl_d_syscall + "'" -$ WC "d_system='" + perl_d_system + "'" -$ WC "timetype='" + perl_timetype + "'" -$ WC "d_truncate='" + perl_d_truncate + "'" -$ WC "d_vfork='" + perl_d_vfork + "'" -$ WC "signal_t='" + perl_signal_t + "'" -$ WC "d_volatile='" + perl_d_volatile + "'" -$ WC "d_vprintf='" + perl_d_vprintf + "'" -$ WC "d_charvspr='" + perl_d_charvspr + "'" -$ WC "d_wait4='" + perl_d_wait4 + "'" -$ WC "d_waitpid='" + perl_d_waitpid + "'" -$ WC "i_dirent='" + perl_i_dirent + "'" -$ WC "d_dirnamlen='" + perl_d_dirnamlen + "'" -$ WC "direntrytype='" + perl_direntrytype + "'" -$ WC "i_fcntl='" + perl_i_fcntl + "'" -$ WC "i_grp='" + perl_i_grp + "'" -$ WC "i_limits='" + perl_i_limits + "'" -$ WC "i_memory='" + perl_i_memory + "'" -$ WC "i_ndbm='" + perl_i_ndbm + "'" -$ WC "i_stdarg='" + perl_i_stdarg + "'" -$ WC "i_pwd='" + perl_i_pwd + "'" -$ WC "d_pwquota='" + perl_d_pwquota + "'" -$ WC "d_pwage='" + perl_d_pwage + "'" -$ WC "d_pwchange='" + perl_d_pwchange + "'" -$ WC "d_pwclass='" + perl_d_pwclass + "'" -$ WC "d_pwexpire='" + perl_d_pwexpire + "'" -$ WC "d_pwcomment='" + perl_d_pwcomment + "'" -$ WC "i_stddef='" + perl_i_stddef + "'" -$ WC "i_stdlib='" + perl_i_stdlib + "'" -$ WC "i_string='" + perl_i_string + "'" -$ WC "i_sysdir='" + perl_i_sysdir + "'" -$ WC "i_sysfile='" + perl_i_sysfile + "'" -$ WC "i_sysioctl='" + perl_i_sysioctl + "'" -$ WC "i_sysndir='" + perl_i_sysndir + "'" -$ WC "i_sysresrc='" + perl_i_sysresrc + "'" -$ WC "i_sysselct='" + perl_i_sysselct + "'" -$ WC "i_dbm='" + perl_i_dbm + "'" -$ WC "i_rpcsvcdbm='" + perl_i_rpcsvcdbm + "'" -$ WC "i_sfio='" + perl_i_sfio + "'" -$ WC "i_sysstat='" + perl_i_sysstat + "'" -$ WC "i_systimes='" + perl_i_systimes + "'" -$ WC "i_systypes='" + perl_i_systypes + "'" -$ WC "i_sysun='" + perl_i_sysun + "'" -$ WC "i_syswait='" + perl_i_syswait + "'" -$ WC "i_termio='" + perl_i_termio + "'" -$ WC "i_sgtty='" + perl_i_sgtty + "'" -$ WC "i_termios='" + perl_i_termios + "'" -$ WC "i_time='" + perl_i_time + "'" -$ WC "i_systime='" + perl_i_systime + "'" -$ WC "i_systimek='" + perl_i_systimek + "'" -$ WC "i_unistd='" + perl_i_unistd + "'" -$ WC "i_utime='" + perl_i_utime + "'" -$ WC "i_varargs='" + perl_i_varargs + "'" -$ WC "i_vfork='" + perl_i_vfork + "'" -$ WC "prototype='" + perl_prototype + "'" -$ WC "randbits='" + perl_randbits +"'" -$ WC "selecttype='" + perl_selecttype + "'" -$ WC "stdchar='" + perl_stdchar + "'" -$ WC "d_unlink_all_versions='" + perl_d_unlink_all_versions + "'" -$ WC "full_sed='" + perl_full_sed + "'" -$ WC "bin='" + perl_bin + "'" -$ WC "binexp='" + perl_binexp + "'" -$ WC "d_alarm='" + perl_d_alarm + "'" -$ WC "d_casti32='" + perl_d_casti32 + "'" -$ WC "d_chown='" + perl_d_chown + "'" -$ WC "d_chroot='" + perl_d_chroot + "'" -$ WC "d_cuserid='" + perl_d_cuserid + "'" -$ WC "d_dbl_dig='" + perl_d_dbl_dig + "'" -$ WC "d_difftime='" + perl_d_difftime + "'" -$ WC "d_fork='" + perl_d_fork + "'" -$ WC "d_getlogin='" + perl_d_getlogin + "'" -$ WC "d_getppid='" + perl_d_getppid + "'" -$ WC "d_htonl='" + perl_d_htonl + "'" -$ WC "d_nice='" + perl_d_nice + "'" -$ WC "d_pause='" + perl_d_pause + "'" -$ WC "d_pipe='" + perl_d_pipe + "'" -$ WC "d_readlink='" + perl_d_readlink + "'" -$ WC "d_setlinebuf='" + perl_d_setlinebuf + "'" -$ WC "d_strchr='" + perl_d_strchr + "'" -$ WC "d_index='" + perl_d_index + "'" -$ WC "d_strtod='" + perl_d_strtod + "'" -$ WC "d_strtol='" + perl_d_strtol + "'" -$ WC "d_strtoul='" + perl_d_strtoul + "'" -$ WC "d_tcgetpgrp='" + perl_d_tcgetpgrp + "'" -$ WC "d_tcsetpgrp='" + perl_d_tcsetpgrp + "'" -$ WC "d_times='" + perl_d_times + "'" -$ WC "d_tzname='" + perl_d_tzname + "'" -$ WC "d_umask='" + perl_d_umask + "'" -$ WC "fpostype='" + perl_fpostype + "'" -$ WC "i_dlfcn='" + perl_i_dlfcn + "'" -$ WC "i_float='" + perl_i_float + "'" -$ WC "i_math='" + perl_i_math + "'" -$ WC "intsize='" + perl_intsize + "'" -$ WC "longsize='" + perl_longsize + "'" -$ WC "shortsize='" + perl_shortsize + "'" -$ WC "lseektype='" + perl_lseektype + "'" -$ WC "i_values='" + perl_i_values + "'" -$ WC "malloctype='" + perl_malloctype + "'" -$ WC "freetype='" + perl_freetype + "'" -$ WC "d_mymalloc='" + perl_d_mymalloc + "'" -$ WC "sh='" + perl_sh + "'" -$ WC "sig_name='" + perl_sig_name + "'" -$ WC "sig_num='" + perl_sig_num + "'" -$ tempsym = "sig_name_init='" + perl_sig_name_with_commas + "'" -$ WC/symbol tempsym -$ WC "sig_num_init='" + perl_sig_num_with_commas + "'" -$ WC "modetype='" + perl_modetype + "'" -$ WC "ssizetype='" + perl_ssizetype + "'" -$ WC "o_nonblock='" + perl_o_nonblock + "'" -$ WC "eagain='" + perl_eagain + "'" -$ WC "rd_nodata='" + perl_rd_nodata + "'" -$ WC "d_eofnblk='" + perl_d_eofnblk + "'" -$ WC "d_oldarchlib='" + perl_d_oldarchlib + "'" -$ WC "oldarchlibexp='" + perl_oldarchlibexp + "'" -$ WC "oldarchlib='" + perl_oldarchlib + "'" -$ WC "privlibexp='" + perl_privlibexp + "'" -$ WC "privlib='" + perl_privlib + "'" -$ WC "sitelibexp='" + perl_sitelibexp + "'" -$ WC "sitelib='" + perl_sitelib + "'" -$ WC "sitearchexp='" + perl_sitearchexp + "'" -$ WC "sitearch='" + perl_sitearch + "'" -$ WC "sizetype='" + perl_sizetype + "'" -$ WC "i_sysparam='" + perl_i_sysparam + "'" -$ WC "d_void_closedir='" + perl_d_void_closedir + "'" -$ WC "d_dlerror='" + perl_d_dlerror + "'" -$ WC "d_dlsymun='" + perl_d_dlsymun + "'" -$ WC "d_suidsafe='" + perl_d_suidsafe + "'" -$ WC "d_dosuid='" + perl_d_dosuid + "'" -$ WC "d_inetaton='" + perl_d_inetaton + "'" -$ WC "d_isascii='" + perl_d_isascii + "'" -$ WC "d_mkfifo='" + perl_d_mkfifo + "'" -$ WC "d_pathconf='" + perl_d_pathconf + "'" -$ WC "d_fpathconf='" + perl_d_fpathconf + "'" -$ WC "d_safebcpy='" + perl_d_safebcpy + "'" -$ WC "d_safemcpy='" + perl_d_safemcpy + "'" -$ WC "d_sanemcmp='" + perl_d_sanemcmp + "'" -$ WC "d_setpgrp='" + perl_d_setpgrp + "'" -$ WC "d_bsdsetpgrp='" + perl_d_bsdsetpgrp + "'" -$ WC "d_bsdpgrp='" + perl_d_bsdpgrp + "'" -$ WC "d_setpgid='" + perl_d_setpgid + "'" -$ WC "d_setpgrp2='" + perl_d_setpgrp2 + "'" -$ WC "d_sysconf='" + perl_d_sysconf + "'" -$ WC "d_Gconvert='" + perl_d_Gconvert + "'" -$ WC "d_getpgid='" + perl_d_getpgid + "'" -$ WC "d_getpgrp='" + perl_d_getpgrp + "'" -$ WC "d_bsdgetpgrp='" + perl_d_bsdgetpgrp + "'" -$ WC "d_getpgrp2='" + perl_d_getpgrp2 + "'" -$ WC "d_sfio='" + perl_d_sfio + "'" -$ WC "d_sigsetjmp='" + perl_d_sigsetjmp + "'" -$ WC "usedl='" + perl_usedl + "'" -$ WC "startperl=" + perl_startperl ! This one's special--no enclosing single quotes -$ WC "db_hashtype='" + perl_db_hashtype + "'" -$ WC "db_prefixtype='" + perl_db_prefixtype + "'" -$ WC "useperlio='" + perl_useperlio + "'" -$ WC "defvoidused='" + perl_defvoidused + "'" -$ WC "voidflags='" + perl_voidflags + "'" -$ WC "d_eunice='" + perl_d_eunice + "'" -$ WC "libs='" + perl_libs + "'" -$ WC "libc='" + perl_libc + "'" -$ tempstring = "PATCHLEVEL='" + "''perl_patchlevel'" + "'" -$ WC tempstring -$ tempstring = "SUBVERSION='" + "''perl_SUBVERSION'" + "'" -$ WC tempstring -$ WC "pager='" + perl_pager + "'" -$ WC "uidtype='" + perl_uidtype + "'" -$ WC "gidtype='" + perl_gidtype + "'" -$ WC "usethreads='" + perl_usethreads + "'" -$ WC "d_pthread_yield='" + perl_d_pthread_yield + "'" -$ WC "d_pthreads_created_joinable='" + perl_d_pthreads_created_joinable + "'" -$ WC "d_gnulibc='" + perl_d_gnulibc + "'" -$ WC "i_netdb='" + perl_i_netdb + "'" -$ WC "pidtype='" + perl_pidtype + "'" -$ WC "netdb_host_type='" + perl_netdb_host_type + "'" -$ WC "netdb_hlen_type='" + perl_netdb_hlen_type + "'" -$ WC "netdb_name_type='" + perl_netdb_name_type + "'" -$ WC "netdb_net_type='" + perl_netdb_net_type + "'" -$ WC "baserev='" + perl_baserev + "'" -$ WC "doublesize='" + perl_doublesize + "'" -$ WC "ptrsize='" + perl_ptrsize + "'" -$ WC "d_gethbyaddr='" + perl_d_gethbyaddr + "'" -$ WC "d_gethbyname='" + perl_d_gethbyname + "'" -$ WC "d_getnbyaddr='" + perl_d_getnbyaddr + "'" -$ WC "d_getnbyname='" + perl_d_getnbyname + "'" -$ WC "d_getpbynumber='" + perl_d_getpbynumber + "'" -$ WC "d_getpbyname='" + perl_d_getpbyname + "'" -$ WC "d_getsbyport='" + perl_d_getsbyport + "'" -$ WC "d_getsbyname='" + perl_d_getsbyname + "'" -$ WC "d_sethent='" + perl_d_sethent + "'" -$ WC "d_oldpthreads='" + perl_d_oldpthreads + "'" -$ WC "d_longdbl='" + perl_d_longdbl + "'" -$ WC "longdblsize='" + perl_longdblsize + "'" -$ WC "d_longlong='" + perl_d_longlong + "'" -$ WC "longlongsize='" + perl_longlongsize + "'" -$ WC "d_mkstemp='" + perl_d_mkstemp + "'" -$ WC "d_setvbuf='" + perl_d_setvbuf + "'" -$ WC "d_endhent='" + perl_d_endhent + "'" -$ WC "d_endnent='" + perl_d_endsent + "'" -$ WC "d_endpent='" + perl_d_endpent + "'" -$ WC "d_endsent='" + perl_d_endsent + "'" -$ WC "d_gethent='" + perl_d_gethent + "'" -$ WC "d_getnent='" + perl_d_getsent + "'" -$ WC "d_getpent='" + perl_d_getpent + "'" -$ WC "d_getsent='" + perl_d_getsent + "'" -$ WC "d_sethent='" + perl_d_sethent + "'" -$ WC "d_setnent='" + perl_d_setsent + "'" -$ WC "d_setpent='" + perl_d_setpent + "'" -$ WC "ebcdic='" + perl_ebcdic + "'" -$ WC "d_setsent='" + perl_d_setsent + "'" -$ WC "d_gethostprotos='" + perl_d_gethostprotos + "'" -$ WC "d_getnetprotos='" + perl_d_getnetprotos + "'" -$ WC "d_getprotoprotos='" + perl_d_getprotoprotos + "'" -$ WC "d_getservprotos='" + perl_d_getservprotos + "'" -$ WC "d_pwgecos='" + perl_d_pwgecos + "'" -$ WC "d_sched_yield='" + perl_d_sched_yield + "'" -$ WC "d_lchown='" + perl_d_lchown + "'" -$ WC "d_union_semun='" + perl_d_union_semun + "'" -$ WC "i_arpainet='" + perl_i_arpainet + "'" -$ WC "d_grpasswd='" + perl_d_grpasswd + "'" -$ WC "d_setgrent='" + perl_d_setgrent + "'" -$ WC "d_getgrent='" + perl_d_getgrent + "'" -$ WC "d_endgrent='" + perl_d_endgrent + "'" -$ WC "d_pwpasswd='" + perl_d_pwpasswd + "'" -$ WC "d_setpwent='" + perl_d_setpwent + "'" -$ WC "d_getpwent='" + perl_d_getpwent + "'" -$ WC "d_endpwent='" + perl_d_endpwent + "'" -$ WC "d_semctl_semun='" + perl_d_semctl_semun + "'" -$ WC "d_semctl_semid_ds='" + perl_d_semctl_semid_ds + "'" -$ WC "extensions='" + perl_extensions + "'" -$ WC "d_mknod='" + perl_d_mknod + "'" -$ WC "devtype='" + perl_devtype + "'" -$ WC "i_sysmount='" + perl_i_sysmount + "'" -$ WC "d_fstatfs='" + perl_d_fstatfs + "'" -$ WC "d_statfsflags='" + perl_d_statfsflags + "'" -$ WC "i_sysstatvfs='" + perl_i_sysstatvfs + "'" -$ WC "i_machcthreads='" + perl_i_machcthreads + "'" -$ WC "i_pthread='" + perl_i_pthread + "'" -$ WC "d_fstatvfs='" + perl_d_fstatvfs + "'" -$ WC "i_mntent='" + perl_i_mntent + "'" -$ WC "d_getmntent='" + perl_d_getmntent + "'" -$ WC "d_hasmntopt='" + perl_d_hasmntopt + "'" -$! -$! ##WRITE NEW CONSTANTS HERE## -$! -$ Close CONFIGSH -$ -$! Okay, we've gotten here. Build munchconfig and run it -$ 'Perl_CC' munchconfig.c -$ If (Needs_Opt.eqs."Yes") -$ THEN -$ open/write OPTCHAN []munchconfig.opt -$ IF ("''using_gnu_c'".eqs."Yes") -$ THEN -$ write OPTCHAN "Gnu_CC:[000000]gcclib.olb/library" -$ endif -$ write OPTCHAN "Sys$Share:VAXCRTL/Share" -$ Close OPTCHAN -$ link munchconfig.obj,munchconfig.opt/opt -$ delete munchconfig.opt;* -$ else -$ link munchconfig.obj -$ endif -$ WRITE_RESULT "Writing config.h" -$ ! -$ ! we need an fdl file -$ CREATE [-]CONFIG.FDL -RECORD - FORMAT STREAM_LF -$ CREATE /FDL=[-]CONFIG.FDL [-]CONFIG.LOCAL -$ ! First spit out the header info with the local defines (to get -$ ! around the 255 character command line limit) -$ OPEN/APPEND CONFIG [-]config.local -$ if use_debugging_perl.eqs."Y" -$ THEN -$ WRITE CONFIG "#define DEBUGGING" -$ ENDIF -$ if preload_env.eqs."Y" -$ THEN -$ WRITE CONFIG "#define PRIME_ENV_AT_STARTUP" -$ ENDIF -$ if use_two_pot_malloc.eqs."Y" -$ THEN -$ WRITE CONFIG "#define TWO_POT_OPTIMIZE" -$ endif -$ if mymalloc.eqs."Y" -$ THEN -$ WRITE CONFIG "#define EMBEDMYMALLOC" -$ ENDIF -$ if use_pack_malloc.eqs."Y" -$ THEN -$ WRITE CONFIG "#define PACK_MALLOC" -$ endif -$ if use_debugmalloc.eqs."Y" -$ THEN -$ write config "#define DEBUGGING_MSTATS" -$ ENDIF -$ if "''Using_Gnu_C'" .eqs."Yes" -$ THEN -$ WRITE CONFIG "#define GNUC_ATTRIBUTE_CHECK" -$ ENDIF -$ if "''Has_Dec_C_Sockets'".eqs."T" -$ THEN -$ WRITE CONFIG "#define VMS_DO_SOCKETS" -$ WRITE CONFIG "#define DECCRTL_SOCKETS" -$ ENDIF -$ if "''Has_Socketshr'".eqs."T" -$ THEN -$ WRITE CONFIG "#define VMS_DO_SOCKETS" -$ ENDIF -$ CLOSE CONFIG -$! -$! Now build the normal config.h -$ define/user sys$output [-]config.main -$ mcr []munchconfig [-]config.sh [-]config_h.sh -$ ! Concatenate them together -$ copy [-]config.local,[-]config.main [-]config.h -$! Clean up -$ DELETE/NOLOG [-]CONFIG.MAIN;* -$ DELETE/NOLOG [-]CONFIG.LOCAL;* -$ DELETE/NOLOG [-]CONFIG.FDL;* -$! -$ if "''Using_Dec_C'" .eqs."Yes" -$ THEN -$ DECC_REPLACE = "DECC=decc=1" -$ ELSE -$ DECC_REPLACE = "DECC=" -$ ENDIF -$ if "''Using_Gnu_C'" .eqs."Yes" -$ THEN -$ GNUC_REPLACE = "GNUC=gnuc=1" -$ ELSE -$ GNUC_REPLACE = "GNUC=" -$ ENDIF -$ if "''Has_Dec_C_Sockets'" .eqs."T" -$ THEN -$ SOCKET_REPLACE = "SOCKET=DECC_SOCKETS=1" -$ ELSE -$ if "''Has_Socketshr'" .eqs."T" -$ THEN -$ SOCKET_REPLACE = "SOCKET=SOCKETSHR_SOCKETS=1" -$ ELSE -$ SOCKET_REPLACE = "SOCKET=" -$ ENDIF -$ ENDIF -$ IF ("''Use_Threads'".eqs."T") -$ THEN -$ if ("''VMS_VER'".LES."6.2") -$ THEN -$ THREAD_REPLACE = "THREAD=OLDTHREADED=1" -$ ELSE -$ THREAD_REPLACE = "THREAD=THREADED=1" -$ ENDIF -$ ELSE -$ THREAD_REPLACE = "THREAD=" -$ ENDIF -$ if mymalloc.eqs."Y" -$ THEN -$ MALLOC_REPLACE = "MALLOC=MALLOC=1" -$ ELSE -$ MALLOC_REPLACE = "MALLOC=" -$ ENDIF -$ if f$getsyi("HW_MODEL").ge.1024 -$ THEN -$ ARCH_TYPE = "ARCH-TYPE=__AXP__" -$ ELSE -$ ARCH_TYPE = "ARCH-TYPE=__VAX__" -$ ENDIF -$ WRITE_RESULT "Writing DESCRIP.MMS" -$!set ver -$ define/user sys$output [-]descrip.mms -$ mcr []munchconfig [-]config.sh descrip_mms.template "''DECC_REPLACE'" "''ARCH_TYPE'" "''GNUC_REPLACE'" "''SOCKET_REPLACE'" "''THREAD_REPLACE'" "''C_Compiler_Replace'" "''MALLOC_REPLACE'" "''Thread_Live_Dangerously'" "PV=''LocalPerlVer'" -$! set nover -$! -$! Clean up after ourselves -$ delete/nolog munchconfig.exe;* -$ delete/nolog munchconfig.obj;* diff --git a/gnu/usr.bin/perl/vms/test.com b/gnu/usr.bin/perl/vms/test.com index bda5f7d07ee..8b93f5b28d2 100644 --- a/gnu/usr.bin/perl/vms/test.com +++ b/gnu/usr.bin/perl/vms/test.com @@ -19,7 +19,7 @@ $ Write Sys$Error "Can't find test directory" $ Exit 44 $ EndIf $ EndIf -$ Set Message /Facility/Severity/Identification/Text +$ Set Message /NoFacility/NoSeverity/NoIdentification/NoText $ $ exe = ".Exe" $ If p1.nes."" Then exe = p1 @@ -41,9 +41,13 @@ $ if p2.nes."" then dbg = "dbg" $ if p2.nes."" then ndbg = "ndbg" $! $! Pick up a copy of perl to use for the tests -$ Delete/Log/NoConfirm Perl.;* +$ If F$Search("Perl.").nes."" Then Delete/Log/NoConfirm Perl.;* $ Copy/Log/NoConfirm [-]'ndbg'Perl'exe' []Perl. -$ +$! +$! 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 [] +$! $! Make the environment look a little friendlier to tests which assume Unix $ cat == "Type" $ Macro/NoDebug/NoList/Object=Echo.Obj Sys$Input @@ -86,6 +90,7 @@ $ Macro/NoDebug/NoList/Object=Echo.Obj Sys$Input movl #1,r0 ret .end echo +$ If F$Search("Echo.Exe").nes."" Then Delete/Log/NoConfirm Echo.Exe;* $ Link/NoMap/NoTrace/Exe=Echo.Exe Echo.Obj; $ Delete/Log/NoConfirm Echo.Obj;* $ echo == "$" + F$Parse("Echo.Exe") @@ -93,7 +98,7 @@ $ $! And do it $ Show Process/Accounting $ testdir = "Directory/NoHead/NoTrail/Column=1" -$ Define/User 'dbg'Perlshr Sys$Disk:[-]'dbg'PerlShr'exe' +$ Define 'dbg'Perlshr Sys$Disk:[-]'dbg'PerlShr'exe' $ MCR Sys$Disk:[]Perl. "-I[-.lib]" - "''p3'" "''p4'" "''p5'" "''p6'" $ Deck/Dollar=$$END-OF-TEST$$ # $RCSfile: TEST,v $$Revision: 4.1 $$Date: 92/08/07 18:27:00 $ @@ -108,11 +113,11 @@ $ Deck/Dollar=$$END-OF-TEST$$ use Config; @compexcl=('cpp.t'); -@ioexcl=('argv.t','dup.t','fs.t','pipe.t','openpid.t'); +@ioexcl=('argv.t','dup.t','fs.t','pipe.t'); @libexcl=('db-btree.t','db-hash.t','db-recno.t', 'gdbm.t','io_dup.t', 'io_pipe.t', 'io_poll.t', 'io_sel.t', 'io_sock.t', 'io_unix.t', - 'ndbm.t','odbm.t','open2.t','open3.t', 'ph.t', 'posix.t', 'dprof.t'); + 'ndbm.t','odbm.t','open2.t','open3.t', 'ph.t', 'posix.t'); # Note: POSIX is not part of basic build, but can be built # separately if you're using DECC @@ -121,7 +126,7 @@ use Config; # insists on stat()ing a file descriptor before it'll use it. push(@libexcl,'io_xs.t') if $Config{'vms_cc_type'} ne 'decc'; -@opexcl=('die_exit.t','exec.t','fork.t','glob.t','groups.t','magic.t','misc.t','stat.t'); +@opexcl=('die_exit.t','exec.t','fork.t','glob.t','groups.t','magic.t','stat.t'); @exclist=(@compexcl,@ioexcl,@libexcl,@opexcl); foreach $file (@exclist) { $skip{$file}++; } @@ -171,7 +176,7 @@ while ($test = shift) { } else { $switch = ''; } - open(results,"\$ MCR Sys\$Disk:[]Perl. \"-I[-.lib]\" $switch $test |") || (print "can't run.\n"); + open(results,"\$ MCR Sys\$Disk:[]Perl. \"-I[-.lib]\" $switch $test 2>&1|") || (print "can't run.\n"); $ok = 0; $next = 0; $pending_not = 0; @@ -236,12 +241,12 @@ if ($bad == 0) { } } ($user,$sys,$cuser,$csys) = times; -print sprintf("u=%g s=%g cu=%g cs=%g files=%d tests=%d\n", +print sprintf("u=%g s=%g cu=%g cs=%g scripts=%d tests=%d\n", $user,$sys,$cuser,$csys,$files,$totmax); $$END-OF-TEST$$ $ wrapup: +$ deassign 'dbg'Perlshr $ Show Process/Accounting -$ If F$Search("Echo.Exe").nes."" Then Delete/Log/NoConfirm Echo.Exe;* $ Set Default &olddef $ Set Message 'oldmsg' $ Exit diff --git a/gnu/usr.bin/perl/vms/vms.c b/gnu/usr.bin/perl/vms/vms.c index c18ca498795..f63bbde3610 100644 --- a/gnu/usr.bin/perl/vms/vms.c +++ b/gnu/usr.bin/perl/vms/vms.c @@ -1,9 +1,12 @@ /* vms.c * * VMS-specific routines for perl5 + * Version: 5.7.0 * - * Last revised: 20-Aug-1999 by Charles Bailey bailey@newman.upenn.edu - * Version: 5.5.60 + * 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@newman.upenn.edu */ #include <acedef.h> @@ -14,6 +17,7 @@ #include <clidef.h> #include <climsgdef.h> #include <descrip.h> +#include <devdef.h> #include <dvidef.h> #include <fibdef.h> #include <float.h> @@ -56,6 +60,11 @@ # define WARN_INTERNAL WARN_MISC #endif +#if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000 +# define RTL_USES_UTC 1 +#endif + + /* gcc's header files don't #define direct access macros * corresponding to VAXC's variant structs */ #ifdef __GNUC__ @@ -79,6 +88,19 @@ struct itmlst_3 { unsigned short int *retlen; }; +#define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c) +#define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c) +#define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c) +#define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c) +#define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e) +#define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c) +#define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c) +#define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d) +#define getredirection(a,b) mp_getredirection(aTHX_ a,b) + +/* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */ +#define PERL_LNM_MAX_ALLOWED_INDEX 127 + static char *__mystrtolower(char *str) { if (str) for (; *str; ++str) *str= tolower(*str); @@ -101,9 +123,13 @@ static int no_translate_barewords; /* Temp for subprocess commands */ static struct dsc$descriptor_s VMScmd = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,Nullch}; +#ifndef RTL_USES_UTC +static int tz_updated = 1; +#endif + /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */ int -vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, +Perl_vmstrnenv(pTHX_ const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) { char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2; @@ -129,7 +155,7 @@ vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, } #endif - if (!lnm || !eqv || idx > LNM$_MAX_INDEX) { + if (!lnm || !eqv || idx > PERL_LNM_MAX_ALLOWED_INDEX) { set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0; } for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) { @@ -240,7 +266,7 @@ vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/ /* Define as a function so we can access statics. */ -int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx) +int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx) { return vmstrnenv(lnm,eqv,idx,fildev, #ifdef SECURE_INTERNAL_GETENV @@ -267,7 +293,7 @@ Perl_my_getenv(pTHX_ const char *lnm, bool sys) static char __my_getenv_eqv[LNM$C_NAMLENGTH+1]; char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv; unsigned long int idx = 0; - int trnsuccess; + int trnsuccess, success, secure, saverr, savvmserr; SV *tmpsv; if (PL_curinterp) { /* Perl interpreter running -- may be threaded */ @@ -291,16 +317,25 @@ Perl_my_getenv(pTHX_ const char *lnm, bool sys) lnm = uplnm; } /* Impose security constraints only if tainting */ - if (sys) sys = PL_curinterp ? PL_tainting : will_taint; - if (vmstrnenv(lnm,eqv,idx, - sys ? fildev : NULL, + if (sys) { + /* Impose security constraints only if tainting */ + secure = PL_curinterp ? PL_tainting : will_taint; + saverr = errno; savvmserr = vaxc$errno; + } + else secure = 0; + success = vmstrnenv(lnm,eqv,idx, + secure ? fildev : NULL, #ifdef SECURE_INTERNAL_GETENV - sys ? PERL__TRNENV_SECURE : 0 + secure ? PERL__TRNENV_SECURE : 0 #else - 0 + 0 #endif - )) return eqv; - else return Nullch; + ); + /* Discard NOLOGNAM on internal calls since we're often looking + * for an optional name, and this "error" often shows up as the + * (bogus) exit status for a die() call later on. */ + if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr); + return success ? eqv : Nullch; } } /* end of my_getenv() */ @@ -315,6 +350,7 @@ my_getenv_len(const char *lnm, unsigned long *len, bool sys) char *buf, *cp1, *cp2; unsigned long idx = 0; static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1]; + int secure, saverr, savvmserr; SV *tmpsv; if (PL_curinterp) { /* Perl interpreter running -- may be threaded */ @@ -338,19 +374,25 @@ my_getenv_len(const char *lnm, unsigned long *len, bool sys) idx = strtoul(cp2+1,NULL,0); lnm = buf; } - /* Impose security constraints only if tainting */ - if (sys) sys = PL_curinterp ? PL_tainting : will_taint; - if ((*len = vmstrnenv(lnm,buf,idx, - sys ? fildev : NULL, + if (sys) { + /* Impose security constraints only if tainting */ + secure = PL_curinterp ? PL_tainting : will_taint; + saverr = errno; savvmserr = vaxc$errno; + } + else secure = 0; + *len = vmstrnenv(lnm,buf,idx, + secure ? fildev : NULL, #ifdef SECURE_INTERNAL_GETENV - sys ? PERL__TRNENV_SECURE : 0 + secure ? PERL__TRNENV_SECURE : 0 #else - 0 + 0 #endif - ))) - return buf; - else - return Nullch; + ); + /* Discard NOLOGNAM on internal calls since we're often looking + * for an optional name, and this "error" often shows up as the + * (bogus) exit status for a die() call later on. */ + if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr); + return *len ? buf : Nullch; } } /* end of my_getenv_len() */ @@ -384,7 +426,7 @@ prime_env_iter(void) $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES"); $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM"); $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam); -#ifdef USE_THREADS +#if defined(USE_THREADS) || defined(USE_ITHREADS) static perl_mutex primenv_mutex; MUTEX_INIT(&primenv_mutex); #endif @@ -573,7 +615,7 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) if ((cp1 = strchr(environ[i],'=')) && !strncmp(environ[i],lnm,cp1 - environ[i])) { #ifdef HAS_SETENV - return setenv(lnm,eqv,1) ? vaxc$errno : 0; + return setenv(lnm,"",1) ? vaxc$errno : 0; } } ivenv = 1; retsts = SS$_NOLOGNAM; @@ -681,19 +723,56 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec) void Perl_my_setenv(pTHX_ char *lnm,char *eqv) { - if (lnm && *lnm && strlen(lnm) == 7) { - char uplnm[8]; - int i; - for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]); - if (!strcmp(uplnm,"DEFAULT")) { - if (eqv && *eqv) chdir(eqv); - return; + if (lnm && *lnm) { + int len = strlen(lnm); + if (len == 7) { + char uplnm[8]; + int i; + for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]); + if (!strcmp(uplnm,"DEFAULT")) { + if (eqv && *eqv) chdir(eqv); + return; + } + } +#ifndef RTL_USES_UTC + if (len == 6 || len == 2) { + char uplnm[7]; + int i; + for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]); + uplnm[len] = '\0'; + if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1; + if (!strcmp(uplnm,"TZ")) tz_updated = 1; } +#endif } (void) vmssetenv(lnm,eqv,NULL); } /*}}}*/ +/*{{{static void vmssetuserlnm(char *name, char *eqv); +/* vmssetuserlnm + * sets a user-mode logical in the process logical name table + * used for redirection of sys$error + */ +void +Perl_vmssetuserlnm(char *name, char *eqv) +{ + $DESCRIPTOR(d_tab, "LNM$PROCESS"); + struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0}; + unsigned long int iss, attr = LNM$M_CONFINE; + unsigned char acmode = PSL$C_USER; + struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0}, + {0, 0, 0, 0}}; + d_name.dsc$a_pointer = name; + d_name.dsc$w_length = strlen(name); + + lnmlst[0].buflen = strlen(eqv); + lnmlst[0].bufadr = eqv; + + iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst); + if (!(iss&1)) lib$signal(iss); +} +/*}}}*/ /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/ @@ -732,8 +811,7 @@ my_crypt(const char *textpasswd, const char *usrname) usrdsc.dsc$a_pointer = usrname; if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) { switch (sts) { - case SS$_NOGRPPRV: - case SS$_NOSYSPRV: + case SS$_NOGRPPRV: case SS$_NOSYSPRV: set_errno(EACCES); break; case RMS$_RNF: @@ -758,13 +836,13 @@ my_crypt(const char *textpasswd, const char *usrname) /*}}}*/ -static char *do_rmsexpand(char *, char *, int, char *, unsigned); -static char *do_fileify_dirspec(char *, char *, int); -static char *do_tovmsspec(char *, char *, int); +static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned); +static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int); +static char *mp_do_tovmsspec(pTHX_ char *, char *, int); /*{{{int do_rmdir(char *name)*/ int -do_rmdir(char *name) +Perl_do_rmdir(pTHX_ char *name) { char dirfile[NAM$C_MAXRSS+1]; int retval; @@ -832,15 +910,13 @@ kill_file(char *name) newace.myace$l_ident = oldace.myace$l_ident; if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) { switch (aclsts) { - case RMS$_FNF: - case RMS$_DNF: - case RMS$_DIR: - case SS$_NOSUCHOBJECT: + case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT: set_errno(ENOENT); break; + case RMS$_DIR: + set_errno(ENOTDIR); break; case RMS$_DEV: set_errno(ENODEV); break; - case RMS$_SYN: - case SS$_INVFILFOROP: + case RMS$_SYN: case SS$_INVFILFOROP: set_errno(EINVAL); break; case RMS$_PRV: set_errno(EACCES); break; @@ -897,6 +973,9 @@ my_mkdir(char *dir, Mode_t mode) STRLEN dirlen = strlen(dir); dTHX; + /* zero length string sometimes gives ACCVIO */ + if (dirlen == 0) return -1; + /* CRTL mkdir() doesn't tolerate trailing /, since that implies * null file name/type. However, it's commonplace under Unix, * so we'll allow it for a gain in portability. @@ -911,23 +990,86 @@ my_mkdir(char *dir, Mode_t mode) } /* end of my_mkdir */ /*}}}*/ +/*{{{int my_chdir(char *)*/ +int +my_chdir(char *dir) +{ + STRLEN dirlen = strlen(dir); + dTHX; + + /* zero length string sometimes gives ACCVIO */ + if (dirlen == 0) return -1; + + /* some versions of CRTL chdir() doesn't tolerate trailing /, since + * that implies + * null file name/type. However, it's commonplace under Unix, + * so we'll allow it for a gain in portability. + */ + if (dir[dirlen-1] == '/') { + char *newdir = savepvn(dir,dirlen-1); + int ret = chdir(newdir); + Safefree(newdir); + return ret; + } + else return chdir(dir); +} /* end of my_chdir */ +/*}}}*/ + + +/*{{{FILE *my_tmpfile()*/ +FILE * +my_tmpfile(void) +{ + FILE *fp; + char *cp; + dTHX; + + if ((fp = tmpfile())) return fp; + + New(1323,cp,L_tmpnam+24,char); + strcpy(cp,"Sys$Scratch:"); + tmpnam(cp+strlen(cp)); + strcat(cp,".Perltmp"); + fp = fopen(cp,"w+","fop=dlt"); + Safefree(cp); + return fp; +} +/*}}}*/ + +/* default piping mailbox size */ +#define PERL_BUFSIZ 512 + static void create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc) { - static unsigned long int mbxbufsiz; - long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM; + unsigned long int mbxbufsiz; + static unsigned long int syssize = 0; + unsigned long int dviitm = DVI$_DEVNAM; dTHX; + char csize[LNM$C_NAMLENGTH+1]; - if (!mbxbufsiz) { + if (!syssize) { + unsigned long syiitm = SYI$_MAXBUF; /* - * Get the SYSGEN parameter MAXBUF, and the smaller of it and the - * preprocessor consant BUFSIZ from stdio.h as the size of the - * 'pipe' mailbox. + * Get the SYSGEN parameter MAXBUF + * + * If the logical 'PERL_MBX_SIZE' is defined + * use the value of the logical instead of PERL_BUFSIZ, but + * keep the size between 128 and MAXBUF. + * */ - _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0)); - if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ; + _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0)); + } + + if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) { + mbxbufsiz = atoi(csize); + } else { + mbxbufsiz = PERL_BUFSIZ; } + if (mbxbufsiz < 128) mbxbufsiz = 128; + if (mbxbufsiz > syssize) mbxbufsiz = syssize; + _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0)); _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length)); @@ -935,15 +1077,78 @@ create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc) } /* end of create_mbx() */ + /*{{{ my_popen and my_pclose*/ + +typedef struct _iosb IOSB; +typedef struct _iosb* pIOSB; +typedef struct _pipe Pipe; +typedef struct _pipe* pPipe; +typedef struct pipe_details Info; +typedef struct pipe_details* pInfo; +typedef struct _srqp RQE; +typedef struct _srqp* pRQE; +typedef struct _tochildbuf CBuf; +typedef struct _tochildbuf* pCBuf; + +struct _iosb { + unsigned short status; + unsigned short count; + unsigned long dvispec; +}; + +#pragma member_alignment save +#pragma nomember_alignment quadword +struct _srqp { /* VMS self-relative queue entry */ + unsigned long qptr[2]; +}; +#pragma member_alignment restore +static RQE RQE_ZERO = {0,0}; + +struct _tochildbuf { + RQE q; + int eof; + unsigned short size; + char *buf; +}; + +struct _pipe { + RQE free; + RQE wait; + int fd_out; + unsigned short chan_in; + unsigned short chan_out; + char *buf; + unsigned int bufsize; + IOSB iosb; + IOSB iosb2; + int *pipe_done; + int retry; + int type; + int shut_on_empty; + int need_wake; + pPipe *home; + pInfo info; + pCBuf curr; + pCBuf curr2; +}; + + struct pipe_details { - struct pipe_details *next; + pInfo next; PerlIO *fp; /* stdio file pointer to pipe mailbox */ int pid; /* PID of subprocess */ int mode; /* == 'r' if pipe open for reading */ int done; /* subprocess has completed */ - unsigned long int completion; /* termination status of subprocess */ + int closing; /* my_pclose is closing this pipe */ + unsigned long completion; /* termination status of subprocess */ + pPipe in; /* pipe in to sub */ + pPipe out; /* pipe out of sub */ + pPipe err; /* pipe of sub's sys$error */ + int in_done; /* true when in pipe finished */ + int out_done; + int err_done; }; struct exit_control_block @@ -955,45 +1160,23 @@ struct exit_control_block unsigned long int exit_status; }; -static struct pipe_details *open_pipes = NULL; -static $DESCRIPTOR(nl_desc, "NL:"); -static int waitpid_asleep = 0; +#define RETRY_DELAY "0 ::0.20" +#define MAX_RETRY 50 -/* Send an EOF to a mbx. N.B. We don't check that fp actually points - * to a mbx; that's the caller's responsibility. - */ -static unsigned long int -pipe_eof(FILE *fp, int immediate) -{ - char devnam[NAM$C_MAXRSS+1], *cp; - unsigned long int chan, iosb[2], retsts, retsts2; - struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam}; - dTHX; +static int pipe_ef = 0; /* first call to safe_popen inits these*/ +static unsigned long mypid; +static unsigned long delaytime[2]; + +static pInfo open_pipes = NULL; +static $DESCRIPTOR(nl_desc, "NL:"); - if (fgetname(fp,devnam,1)) { - /* It oughta be a mailbox, so fgetname should give just the device - * name, but just in case . . . */ - if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0'; - devdsc.dsc$w_length = strlen(devnam); - _ckvmssts(sys$assign(&devdsc,&chan,0,0)); - retsts = sys$qiow(0,chan,IO$_WRITEOF|(immediate?IO$M_NOW|IO$M_NORSWAIT:0), - iosb,0,0,0,0,0,0,0,0); - if (retsts & 1) retsts = iosb[0]; - retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */ - if (retsts & 1) retsts = retsts2; - _ckvmssts(retsts); - return retsts; - } - else _ckvmssts(vaxc$errno); /* Should never happen */ - return (unsigned long int) vaxc$errno; -} static unsigned long int pipe_exit_routine() { - struct pipe_details *info; + pInfo info; unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT; - int sts, did_stuff; + int sts, did_stuff, need_eof; dTHX; /* @@ -1006,11 +1189,12 @@ pipe_exit_routine() while (info) { int need_eof; _ckvmssts(sys$setast(0)); - need_eof = info->mode != 'r' && !info->done; - _ckvmssts(sys$setast(1)); - if (need_eof) { - if (pipe_eof(info->fp, 1) & 1) did_stuff = 1; + if (info->in && !info->in->shut_on_empty) { + _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0, + 0, 0, 0, 0, 0, 0)); + did_stuff = 1; } + _ckvmssts(sys$setast(1)); info = info->next; } if (did_stuff) sleep(1); /* wait for EOF to have an effect */ @@ -1035,7 +1219,6 @@ pipe_exit_routine() if (!info->done) { /* We tried to be nice . . . */ sts = sys$delprc(&info->pid,0); if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts); - info->done = 1; /* so my_pclose doesn't try to write EOF */ } _ckvmssts(sys$setast(1)); info = info->next; @@ -1052,72 +1235,914 @@ static struct exit_control_block pipe_exitblock = {(struct exit_control_block *) 0, pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0}; +static void pipe_mbxtofd_ast(pPipe p); +static void pipe_tochild1_ast(pPipe p); +static void pipe_tochild2_ast(pPipe p); static void -popen_completion_ast(struct pipe_details *thispipe) +popen_completion_ast(pInfo info) { - thispipe->done = TRUE; - if (waitpid_asleep) { - waitpid_asleep = 0; - sys$wake(0,0); + dTHX; + pInfo i = open_pipes; + int iss; + + while (i) { + if (i == info) break; + i = i->next; } + if (!i) return; /* unlinked, probably freed too */ + + info->completion &= 0x0FFFFFFF; /* strip off "control" field */ + info->done = TRUE; + +/* + Writing to subprocess ... + if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe + + chan_out may be waiting for "done" flag, or hung waiting + for i/o completion to child...cancel the i/o. This will + put it into "snarf mode" (done but no EOF yet) that discards + input. + + Output from subprocess (stdout, stderr) needs to be flushed and + shut down. We try sending an EOF, but if the mbx is full the pipe + routine should still catch the "shut_on_empty" flag, telling it to + use immediate-style reads so that "mbx empty" -> EOF. + + +*/ + if (info->in && !info->in_done) { /* only for mode=w */ + if (info->in->shut_on_empty && info->in->need_wake) { + info->in->need_wake = FALSE; + _ckvmssts(sys$dclast(pipe_tochild2_ast,info->in,0)); + } else { + _ckvmssts(sys$cancel(info->in->chan_out)); + } + } + + if (info->out && !info->out_done) { /* were we also piping output? */ + info->out->shut_on_empty = TRUE; + iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0); + if (iss == SS$_MBFULL) iss = SS$_NORMAL; + _ckvmssts(iss); + } + + if (info->err && !info->err_done) { /* we were piping stderr */ + info->err->shut_on_empty = TRUE; + iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0); + if (iss == SS$_MBFULL) iss = SS$_NORMAL; + _ckvmssts(iss); + } + _ckvmssts(sys$setef(pipe_ef)); + } static unsigned long int setup_cmddsc(char *cmd, int check_img); -static void vms_execfree(); +static void vms_execfree(pTHX); + +/* + we actually differ from vmstrnenv since we use this to + get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really* + are pointing to the same thing +*/ + +static unsigned short +popen_translate(char *logical, char *result) +{ + int iss; + $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE"); + $DESCRIPTOR(d_log,""); + struct _il3 { + unsigned short length; + unsigned short code; + char * buffer_addr; + unsigned short *retlenaddr; + } itmlst[2]; + unsigned short l, ifi; + + d_log.dsc$a_pointer = logical; + d_log.dsc$w_length = strlen(logical); + + itmlst[0].code = LNM$_STRING; + itmlst[0].length = 255; + itmlst[0].buffer_addr = result; + itmlst[0].retlenaddr = &l; + + itmlst[1].code = 0; + itmlst[1].length = 0; + itmlst[1].buffer_addr = 0; + itmlst[1].retlenaddr = 0; + + iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst); + if (iss == SS$_NOLOGNAM) { + iss = SS$_NORMAL; + l = 0; + } + if (!(iss&1)) lib$signal(iss); + result[l] = '\0'; +/* + logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI) + strip it off and return the ifi, if any +*/ + ifi = 0; + if (result[0] == 0x1b && result[1] == 0x00) { + memcpy(&ifi,result+2,2); + strcpy(result,result+4); + } + return ifi; /* this is the RMS internal file id */ +} + +#define MAX_DCL_SYMBOL 255 +static void pipe_infromchild_ast(pPipe p); + +/* + I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate + inside an AST routine without worrying about reentrancy and which Perl + memory allocator is being used. + + We read data and queue up the buffers, then spit them out one at a + time to the output mailbox when the output mailbox is ready for one. + +*/ +#define INITIAL_TOCHILDQUEUE 2 + +static pPipe +pipe_tochild_setup(char *rmbx, char *wmbx) +{ + dTHX; + pPipe p; + pCBuf b; + char mbx1[64], mbx2[64]; + struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T, + DSC$K_CLASS_S, mbx1}, + d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T, + DSC$K_CLASS_S, mbx2}; + unsigned int dviitm = DVI$_DEVBUFSIZ; + int j, n; + + New(1368, p, 1, Pipe); + + create_mbx(&p->chan_in , &d_mbx1); + create_mbx(&p->chan_out, &d_mbx2); + _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize)); + + p->buf = 0; + p->shut_on_empty = FALSE; + p->need_wake = FALSE; + p->type = 0; + p->retry = 0; + p->iosb.status = SS$_NORMAL; + p->iosb2.status = SS$_NORMAL; + p->free = RQE_ZERO; + p->wait = RQE_ZERO; + p->curr = 0; + p->curr2 = 0; + p->info = 0; + + n = sizeof(CBuf) + p->bufsize; + + for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) { + _ckvmssts(lib$get_vm(&n, &b)); + b->buf = (char *) b + sizeof(CBuf); + _ckvmssts(lib$insqhi(b, &p->free)); + } + + pipe_tochild2_ast(p); + pipe_tochild1_ast(p); + strcpy(wmbx, mbx1); + strcpy(rmbx, mbx2); + return p; +} + +/* reads the MBX Perl is writing, and queues */ + +static void +pipe_tochild1_ast(pPipe p) +{ + dTHX; + pCBuf b = p->curr; + int iss = p->iosb.status; + int eof = (iss == SS$_ENDOFFILE); + + if (p->retry) { + if (eof) { + p->shut_on_empty = TRUE; + b->eof = TRUE; + _ckvmssts(sys$dassgn(p->chan_in)); + } else { + _ckvmssts(iss); + } + + b->eof = eof; + b->size = p->iosb.count; + _ckvmssts(lib$insqhi(b, &p->wait)); + if (p->need_wake) { + p->need_wake = FALSE; + _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0)); + } + } else { + p->retry = 1; /* initial call */ + } + + if (eof) { /* flush the free queue, return when done */ + int n = sizeof(CBuf) + p->bufsize; + while (1) { + iss = lib$remqti(&p->free, &b); + if (iss == LIB$_QUEWASEMP) return; + _ckvmssts(iss); + _ckvmssts(lib$free_vm(&n, &b)); + } + } + + iss = lib$remqti(&p->free, &b); + if (iss == LIB$_QUEWASEMP) { + int n = sizeof(CBuf) + p->bufsize; + _ckvmssts(lib$get_vm(&n, &b)); + b->buf = (char *) b + sizeof(CBuf); + } else { + _ckvmssts(iss); + } + + p->curr = b; + iss = sys$qio(0,p->chan_in, + IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0), + &p->iosb, + pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0); + if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL; + _ckvmssts(iss); +} + + +/* writes queued buffers to output, waits for each to complete before + doing the next */ + +static void +pipe_tochild2_ast(pPipe p) +{ + dTHX; + pCBuf b = p->curr2; + int iss = p->iosb2.status; + int n = sizeof(CBuf) + p->bufsize; + int done = (p->info && p->info->done) || + iss == SS$_CANCEL || iss == SS$_ABORT; + + do { + if (p->type) { /* type=1 has old buffer, dispose */ + if (p->shut_on_empty) { + _ckvmssts(lib$free_vm(&n, &b)); + } else { + _ckvmssts(lib$insqhi(b, &p->free)); + } + p->type = 0; + } + + iss = lib$remqti(&p->wait, &b); + if (iss == LIB$_QUEWASEMP) { + if (p->shut_on_empty) { + if (done) { + _ckvmssts(sys$dassgn(p->chan_out)); + *p->pipe_done = TRUE; + _ckvmssts(sys$setef(pipe_ef)); + } else { + _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, + &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0)); + } + return; + } + p->need_wake = TRUE; + return; + } + _ckvmssts(iss); + p->type = 1; + } while (done); + + + p->curr2 = b; + if (b->eof) { + _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, + &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0)); + } else { + _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK, + &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0)); + } + + return; + +} + + +static pPipe +pipe_infromchild_setup(char *rmbx, char *wmbx) +{ + dTHX; + pPipe p; + char mbx1[64], mbx2[64]; + struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T, + DSC$K_CLASS_S, mbx1}, + d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T, + DSC$K_CLASS_S, mbx2}; + unsigned int dviitm = DVI$_DEVBUFSIZ; + + New(1367, p, 1, Pipe); + create_mbx(&p->chan_in , &d_mbx1); + create_mbx(&p->chan_out, &d_mbx2); + + _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize)); + New(1367, p->buf, p->bufsize, char); + p->shut_on_empty = FALSE; + p->info = 0; + p->type = 0; + p->iosb.status = SS$_NORMAL; + pipe_infromchild_ast(p); + + strcpy(wmbx, mbx1); + strcpy(rmbx, mbx2); + return p; +} + +static void +pipe_infromchild_ast(pPipe p) +{ + dTHX; + int iss = p->iosb.status; + int eof = (iss == SS$_ENDOFFILE); + int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0)); + int kideof = (eof && (p->iosb.dvispec == p->info->pid)); + + if (p->info && p->info->closing && p->chan_out) { /* output shutdown */ + _ckvmssts(sys$dassgn(p->chan_out)); + p->chan_out = 0; + } + + /* read completed: + input shutdown if EOF from self (done or shut_on_empty) + output shutdown if closing flag set (my_pclose) + send data/eof from child or eof from self + otherwise, re-read (snarf of data from child) + */ + + if (p->type == 1) { + p->type = 0; + if (myeof && p->chan_in) { /* input shutdown */ + _ckvmssts(sys$dassgn(p->chan_in)); + p->chan_in = 0; + } + + if (p->chan_out) { + if (myeof || kideof) { /* pass EOF to parent */ + _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb, + pipe_infromchild_ast, p, + 0, 0, 0, 0, 0, 0)); + return; + } else if (eof) { /* eat EOF --- fall through to read*/ + + } else { /* transmit data */ + _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb, + pipe_infromchild_ast,p, + p->buf, p->iosb.count, 0, 0, 0, 0)); + return; + } + } + } + + /* everything shut? flag as done */ + + if (!p->chan_in && !p->chan_out) { + *p->pipe_done = TRUE; + _ckvmssts(sys$setef(pipe_ef)); + return; + } + + /* write completed (or read, if snarfing from child) + if still have input active, + queue read...immediate mode if shut_on_empty so we get EOF if empty + otherwise, + check if Perl reading, generate EOFs as needed + */ + + if (p->type == 0) { + p->type = 1; + if (p->chan_in) { + iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb, + pipe_infromchild_ast,p, + p->buf, p->bufsize, 0, 0, 0, 0); + if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL; + _ckvmssts(iss); + } else { /* send EOFs for extra reads */ + p->iosb.status = SS$_ENDOFFILE; + p->iosb.dvispec = 0; + _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN, + 0, 0, 0, + pipe_infromchild_ast, p, 0, 0, 0, 0)); + } + } +} + +static pPipe +pipe_mbxtofd_setup(int fd, char *out) +{ + dTHX; + pPipe p; + char mbx[64]; + unsigned long dviitm = DVI$_DEVBUFSIZ; + struct stat s; + struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T, + DSC$K_CLASS_S, mbx}; + + /* things like terminals and mbx's don't need this filter */ + if (fd && fstat(fd,&s) == 0) { + unsigned long dviitm = DVI$_DEVCHAR, devchar; + struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T, + DSC$K_CLASS_S, s.st_dev}; + + _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0)); + if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/ + strcpy(out, s.st_dev); + return 0; + } + } + + New(1366, p, 1, Pipe); + p->fd_out = dup(fd); + create_mbx(&p->chan_in, &d_mbx); + _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize)); + New(1366, p->buf, p->bufsize+1, char); + p->shut_on_empty = FALSE; + p->retry = 0; + p->info = 0; + strcpy(out, mbx); + + _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb, + pipe_mbxtofd_ast, p, + p->buf, p->bufsize, 0, 0, 0, 0)); + + return p; +} + +static void +pipe_mbxtofd_ast(pPipe p) +{ + dTHX; + int iss = p->iosb.status; + int done = p->info->done; + int iss2; + int eof = (iss == SS$_ENDOFFILE); + int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0)); + int err = !(iss&1) && !eof; + + + if (done && myeof) { /* end piping */ + close(p->fd_out); + sys$dassgn(p->chan_in); + *p->pipe_done = TRUE; + _ckvmssts(sys$setef(pipe_ef)); + return; + } + + if (!err && !eof) { /* good data to send to file */ + p->buf[p->iosb.count] = '\n'; + iss2 = write(p->fd_out, p->buf, p->iosb.count+1); + if (iss2 < 0) { + p->retry++; + if (p->retry < MAX_RETRY) { + _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p)); + return; + } + } + p->retry = 0; + } else if (err) { + _ckvmssts(iss); + } + + + iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb, + pipe_mbxtofd_ast, p, + p->buf, p->bufsize, 0, 0, 0, 0); + if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL; + _ckvmssts(iss); +} + + +typedef struct _pipeloc PLOC; +typedef struct _pipeloc* pPLOC; + +struct _pipeloc { + pPLOC next; + char dir[NAM$C_MAXRSS+1]; +}; +static pPLOC head_PLOC = 0; + +void +free_pipelocs(void *head) +{ + pPLOC p, pnext; + + p = (pPLOC) head; + while (p) { + pnext = p->next; + Safefree(p); + p = pnext; + } +} + +static void +store_pipelocs() +{ + int i; + pPLOC p; + AV *av = GvAVn(PL_incgv); + SV *dirsv; + GV *gv; + char *dir, *x; + char *unixdir; + char temp[NAM$C_MAXRSS+1]; + STRLEN n_a; + +/* the . directory from @INC comes last */ + + New(1370,p,1,PLOC); + p->next = head_PLOC; + head_PLOC = p; + strcpy(p->dir,"./"); + +/* get the directory from $^X */ + + if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */ + strcpy(temp, PL_origargv[0]); + x = strrchr(temp,']'); + if (x) x[1] = '\0'; + + if ((unixdir = tounixpath(temp, Nullch)) != Nullch) { + New(1370,p,1,PLOC); + p->next = head_PLOC; + head_PLOC = p; + strncpy(p->dir,unixdir,sizeof(p->dir)-1); + p->dir[NAM$C_MAXRSS] = '\0'; + } + } + +/* reverse order of @INC entries, skip "." since entered above */ + + for (i = 0; i <= AvFILL(av); i++) { + dirsv = *av_fetch(av,i,TRUE); + + if (SvROK(dirsv)) continue; + dir = SvPVx(dirsv,n_a); + if (strcmp(dir,".") == 0) continue; + if ((unixdir = tounixpath(dir, Nullch)) == Nullch) + continue; + + New(1370,p,1,PLOC); + p->next = head_PLOC; + head_PLOC = p; + strncpy(p->dir,unixdir,sizeof(p->dir)-1); + p->dir[NAM$C_MAXRSS] = '\0'; + } + +/* most likely spot (ARCHLIB) put first in the list */ + +#ifdef ARCHLIB_EXP + if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) { + New(1370,p,1,PLOC); + p->next = head_PLOC; + head_PLOC = p; + strncpy(p->dir,unixdir,sizeof(p->dir)-1); + p->dir[NAM$C_MAXRSS] = '\0'; + } +#endif + Perl_call_atexit(&free_pipelocs, head_PLOC); +} + + +static char * +find_vmspipe(void) +{ + static int vmspipe_file_status = 0; + static char vmspipe_file[NAM$C_MAXRSS+1]; + + /* already found? Check and use ... need read+execute permission */ + + if (vmspipe_file_status == 1) { + if (cando_by_name(S_IRUSR, 0, vmspipe_file) + && cando_by_name(S_IXUSR, 0, vmspipe_file)) { + return vmspipe_file; + } + vmspipe_file_status = 0; + } + + /* scan through stored @INC, $^X */ + + if (vmspipe_file_status == 0) { + char file[NAM$C_MAXRSS+1]; + pPLOC p = head_PLOC; + + while (p) { + strcpy(file, p->dir); + strncat(file, "vmspipe.com",NAM$C_MAXRSS); + file[NAM$C_MAXRSS] = '\0'; + p = p->next; + + if (!do_tovmsspec(file,vmspipe_file,0)) continue; + + if (cando_by_name(S_IRUSR, 0, vmspipe_file) + && cando_by_name(S_IXUSR, 0, vmspipe_file)) { + vmspipe_file_status = 1; + return vmspipe_file; + } + } + vmspipe_file_status = -1; /* failed, use tempfiles */ + } + + return 0; +} + +static FILE * +vmspipe_tempfile(void) +{ + char file[NAM$C_MAXRSS+1]; + FILE *fp; + static int index = 0; + stat_t s0, s1; + + /* create a tempfile */ + + /* we can't go from W, shr=get to R, shr=get without + an intermediate vulnerable state, so don't bother trying... + + and lib$spawn doesn't shr=put, so have to close the write + + So... match up the creation date/time and the FID to + make sure we're dealing with the same file + + */ + + index++; + sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index); + fp = fopen(file,"w"); + if (!fp) { + sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index); + fp = fopen(file,"w"); + if (!fp) { + sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index); + fp = fopen(file,"w"); + } + } + if (!fp) return 0; /* we're hosed */ + + fprintf(fp,"$! 'f$verify(0)\n"); + fprintf(fp,"$! --- protect against nonstandard definitions ---\n"); + fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n"); + fprintf(fp,"$ perl_define = \"define/nolog\"\n"); + fprintf(fp,"$ perl_on = \"set noon\"\n"); + fprintf(fp,"$ perl_exit = \"exit\"\n"); + fprintf(fp,"$ perl_del = \"delete\"\n"); + fprintf(fp,"$ pif = \"if\"\n"); + fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n"); + fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n"); + fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n"); + fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n"); + fprintf(fp,"$ cmd = perl_popen_cmd\n"); + fprintf(fp,"$! --- get rid of global symbols\n"); + fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n"); + fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n"); + fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n"); + fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd\n"); + fprintf(fp,"$ perl_on\n"); + fprintf(fp,"$ 'cmd\n"); + fprintf(fp,"$ perl_status = $STATUS\n"); + fprintf(fp,"$ perl_del 'perl_cfile'\n"); + fprintf(fp,"$ perl_exit 'perl_status'\n"); + fsync(fileno(fp)); + + fgetname(fp, file, 1); + fstat(fileno(fp), &s0); + fclose(fp); + + fp = fopen(file,"r","shr=get"); + if (!fp) return 0; + fstat(fileno(fp), &s1); + + if (s0.st_ino[0] != s1.st_ino[0] || + s0.st_ino[1] != s1.st_ino[1] || + s0.st_ino[2] != s1.st_ino[2] || + s0.st_ctime != s1.st_ctime ) { + fclose(fp); + return 0; + } + + return fp; +} + + static PerlIO * safe_popen(char *cmd, char *mode) { + dTHX; static int handler_set_up = FALSE; - char mbxname[64]; - unsigned short int chan; unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */ - dTHX; - struct pipe_details *info; - struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T, - DSC$K_CLASS_S, mbxname}, - cmddsc = {0, DSC$K_DTYPE_T, + unsigned int table = LIB$K_CLI_GLOBAL_SYM; + char *p, symbol[MAX_DCL_SYMBOL+1], *vmspipe; + char in[512], out[512], err[512], mbx[512]; + FILE *tpipe = 0; + char tfilebuf[NAM$C_MAXRSS+1]; + pInfo info; + struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T, + DSC$K_CLASS_S, symbol}; + struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; - - - if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; } - New(1301,info,1,struct pipe_details); - /* create mailbox */ - create_mbx(&chan,&namdsc); + $DESCRIPTOR(d_sym_cmd,"PERL_POPEN_CMD"); + $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN"); + $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT"); + $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR"); + + /* once-per-program initialization... + note that the SETAST calls and the dual test of pipe_ef + makes sure that only the FIRST thread through here does + the initialization...all other threads wait until it's + done. + + Yeah, uglier than a pthread call, it's got all the stuff inline + rather than in a separate routine. + */ - /* open a FILE* onto it */ - info->fp = PerlIO_open(mbxname, mode); + if (!pipe_ef) { + _ckvmssts(sys$setast(0)); + if (!pipe_ef) { + unsigned long int pidcode = JPI$_PID; + $DESCRIPTOR(d_delay, RETRY_DELAY); + _ckvmssts(lib$get_ef(&pipe_ef)); + _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0)); + _ckvmssts(sys$bintim(&d_delay, delaytime)); + } + if (!handler_set_up) { + _ckvmssts(sys$dclexh(&pipe_exitblock)); + handler_set_up = TRUE; + } + _ckvmssts(sys$setast(1)); + } - /* give up other channel onto it */ - _ckvmssts(sys$dassgn(chan)); + /* see if we can find a VMSPIPE.COM */ - if (!info->fp) + tfilebuf[0] = '@'; + vmspipe = find_vmspipe(); + if (vmspipe) { + strcpy(tfilebuf+1,vmspipe); + } else { /* uh, oh...we're in tempfile hell */ + tpipe = vmspipe_tempfile(); + if (!tpipe) { /* a fish popular in Boston */ + if (ckWARN(WARN_PIPE)) { + Perl_warner(aTHX_ WARN_PIPE,"unable to find VMSPIPE.COM for i/o piping"); + } return Nullfp; + } + fgetname(tpipe,tfilebuf+1,1); + } + vmspipedsc.dsc$a_pointer = tfilebuf; + vmspipedsc.dsc$w_length = strlen(tfilebuf); + + if (!(setup_cmddsc(cmd,0) & 1)) { set_errno(EINVAL); return Nullfp; } + New(1301,info,1,Info); info->mode = *mode; info->done = FALSE; - info->completion=0; + info->completion = 0; + info->closing = FALSE; + info->in = 0; + info->out = 0; + info->err = 0; + info->in_done = TRUE; + info->out_done = TRUE; + info->err_done = TRUE; + in[0] = out[0] = err[0] = '\0'; + + if (*mode == 'r') { /* piping from subroutine */ + + info->out = pipe_infromchild_setup(mbx,out); + if (info->out) { + info->out->pipe_done = &info->out_done; + info->out_done = FALSE; + info->out->info = info; + } + info->fp = PerlIO_open(mbx, mode); + if (!info->fp && info->out) { + sys$cancel(info->out->chan_out); - if (*mode == 'r') { - _ckvmssts(lib$spawn(&VMScmd, &nl_desc, &namdsc, &flags, - 0 /* name */, &info->pid, &info->completion, - 0, popen_completion_ast,info,0,0,0)); - } - else { - _ckvmssts(lib$spawn(&VMScmd, &namdsc, 0 /* sys$output */, &flags, - 0 /* name */, &info->pid, &info->completion, - 0, popen_completion_ast,info,0,0,0)); - } + while (!info->out_done) { + int done; + _ckvmssts(sys$setast(0)); + done = info->out_done; + if (!done) _ckvmssts(sys$clref(pipe_ef)); + _ckvmssts(sys$setast(1)); + if (!done) _ckvmssts(sys$waitfr(pipe_ef)); + } + + if (info->out->buf) Safefree(info->out->buf); + Safefree(info->out); + Safefree(info); + return Nullfp; + } + + info->err = pipe_mbxtofd_setup(fileno(stderr), err); + if (info->err) { + info->err->pipe_done = &info->err_done; + info->err_done = FALSE; + info->err->info = info; + } - vms_execfree(); - if (!handler_set_up) { - _ckvmssts(sys$dclexh(&pipe_exitblock)); - handler_set_up = TRUE; + } else { /* piping to subroutine , mode=w*/ + + info->in = pipe_tochild_setup(in,mbx); + info->fp = PerlIO_open(mbx, mode); + if (info->in) { + info->in->pipe_done = &info->in_done; + info->in_done = FALSE; + info->in->info = info; + } + + /* error cleanup */ + if (!info->fp && info->in) { + info->done = TRUE; + _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0, + 0, 0, 0, 0, 0, 0, 0, 0)); + + while (!info->in_done) { + int done; + _ckvmssts(sys$setast(0)); + done = info->in_done; + if (!done) _ckvmssts(sys$clref(pipe_ef)); + _ckvmssts(sys$setast(1)); + if (!done) _ckvmssts(sys$waitfr(pipe_ef)); + } + + if (info->in->buf) Safefree(info->in->buf); + Safefree(info->in); + Safefree(info); + return Nullfp; + } + + + info->out = pipe_mbxtofd_setup(fileno(stdout), out); + if (info->out) { + info->out->pipe_done = &info->out_done; + info->out_done = FALSE; + info->out->info = info; + } + + info->err = pipe_mbxtofd_setup(fileno(stderr), err); + if (info->err) { + info->err->pipe_done = &info->err_done; + info->err_done = FALSE; + info->err->info = info; + } } + + symbol[MAX_DCL_SYMBOL] = '\0'; + + strncpy(symbol, in, MAX_DCL_SYMBOL); + d_symbol.dsc$w_length = strlen(symbol); + _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table)); + + strncpy(symbol, err, MAX_DCL_SYMBOL); + d_symbol.dsc$w_length = strlen(symbol); + _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table)); + + strncpy(symbol, out, MAX_DCL_SYMBOL); + d_symbol.dsc$w_length = strlen(symbol); + _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table)); + + p = VMScmd.dsc$a_pointer; + while (*p && *p != '\n') p++; + *p = '\0'; /* truncate on \n */ + p = VMScmd.dsc$a_pointer; + while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */ + if (*p == '$') p++; /* remove leading $ */ + while (*p == ' ' || *p == '\t') p++; + strncpy(symbol, p, MAX_DCL_SYMBOL); + d_symbol.dsc$w_length = strlen(symbol); + _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table)); + + _ckvmssts(sys$setast(0)); info->next=open_pipes; /* prepend to list */ open_pipes=info; + _ckvmssts(sys$setast(1)); + _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags, + 0, &info->pid, &info->completion, + 0, popen_completion_ast,info,0,0,0)); + + /* if we were using a tempfile, close it now */ + + if (tpipe) fclose(tpipe); + + /* once the subprocess is spawned, its copied the symbols and + we can get rid of ours */ + + _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table)); + _ckvmssts(lib$delete_symbol(&d_sym_in, &table)); + _ckvmssts(lib$delete_symbol(&d_sym_err, &table)); + _ckvmssts(lib$delete_symbol(&d_sym_out, &table)); + vms_execfree(aTHX); PL_forkprocess = info->pid; return info->fp; @@ -1139,9 +2164,10 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) /*{{{ I32 my_pclose(FILE *fp)*/ I32 Perl_my_pclose(pTHX_ FILE *fp) { - struct pipe_details *info, *last = NULL; + dTHX; + pInfo info, last = NULL; unsigned long int retsts; - int need_eof; + int done, iss; for (info = open_pipes; info != NULL; last = info, info = info->next) if (info->fp == fp) break; @@ -1154,21 +2180,67 @@ I32 Perl_my_pclose(pTHX_ FILE *fp) /* If we were writing to a subprocess, insure that someone reading from * the mailbox gets an EOF. It looks like a simple fclose() doesn't - * produce an EOF record in the mailbox. */ + * produce an EOF record in the mailbox. + * + * well, at least sometimes it *does*, so we have to watch out for + * the first EOF closing the pipe (and DASSGN'ing the channel)... + */ + + fsync(fileno(info->fp)); /* first, flush data */ + _ckvmssts(sys$setast(0)); - need_eof = info->mode != 'r' && !info->done; + info->closing = TRUE; + done = info->done && info->in_done && info->out_done && info->err_done; + /* hanging on write to Perl's input? cancel it */ + if (info->mode == 'r' && info->out && !info->out_done) { + if (info->out->chan_out) { + _ckvmssts(sys$cancel(info->out->chan_out)); + if (!info->out->chan_in) { /* EOF generation, need AST */ + _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0)); + } + } + } + if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */ + _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0, + 0, 0, 0, 0, 0, 0)); _ckvmssts(sys$setast(1)); - if (need_eof) pipe_eof(info->fp,0); PerlIO_close(info->fp); - if (info->done) retsts = info->completion; - else waitpid(info->pid,(int *) &retsts,0); + /* + we have to wait until subprocess completes, but ALSO wait until all + the i/o completes...otherwise we'll be freeing the "info" structure + that the i/o ASTs could still be using... + */ + + while (!done) { + _ckvmssts(sys$setast(0)); + done = info->done && info->in_done && info->out_done && info->err_done; + if (!done) _ckvmssts(sys$clref(pipe_ef)); + _ckvmssts(sys$setast(1)); + if (!done) _ckvmssts(sys$waitfr(pipe_ef)); + } + retsts = info->completion; /* remove from list of open pipes */ _ckvmssts(sys$setast(0)); if (last) last->next = info->next; else open_pipes = info->next; _ckvmssts(sys$setast(1)); + + /* free buffers and structures */ + + if (info->in) { + if (info->in->buf) Safefree(info->in->buf); + Safefree(info->in); + } + if (info->out) { + if (info->out->buf) Safefree(info->out->buf); + Safefree(info->out); + } + if (info->err) { + if (info->err->buf) Safefree(info->err->buf); + Safefree(info->err); + } Safefree(info); return retsts; @@ -1180,7 +2252,8 @@ I32 Perl_my_pclose(pTHX_ FILE *fp) Pid_t my_waitpid(Pid_t pid, int *statusp, int flags) { - struct pipe_details *info; + pInfo info; + int done; dTHX; for (info = open_pipes; info != NULL; info = info->next) @@ -1188,8 +2261,11 @@ my_waitpid(Pid_t pid, int *statusp, int flags) if (info != NULL) { /* we know about this child */ while (!info->done) { - waitpid_asleep = 1; - sys$hiber(); + _ckvmssts(sys$setast(0)); + done = info->done; + if (!done) _ckvmssts(sys$clref(pipe_ef)); + _ckvmssts(sys$setast(1)); + if (!done) _ckvmssts(sys$waitfr(pipe_ef)); } *statusp = info->completion; @@ -1212,6 +2288,7 @@ my_waitpid(Pid_t pid, int *statusp, int flags) _ckvmssts(sys$schdwk(0,0,interval,0)); _ckvmssts(sys$hiber()); } + if (sts == SS$_NONEXPR) sts = SS$_NORMAL; _ckvmssts(sts); /* There's no easy way to find the termination status a child we're @@ -1269,10 +2346,10 @@ my_gconvert(double val, int ndig, int trail, char *buf) * rmesexpand() returns the address of the resultant string if * successful, and NULL on error. */ -static char *do_tounixspec(char *, char *, int); +static char *mp_do_tounixspec(pTHX_ char *, char *, int); static char * -do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts) +mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts) { static char __rmsexpand_retbuf[NAM$C_MAXRSS+1]; char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1]; @@ -1316,8 +2393,7 @@ do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts) retsts = sys$parse(&myfab,0,0); if (!(retsts & 1)) { mynam.nam$b_nop |= NAM$M_SYNCHK; - if (retsts == RMS$_DNF || retsts == RMS$_DIR || - retsts == RMS$_DEV || retsts == RMS$_DEV) { + if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) { retsts = sys$parse(&myfab,0,0); if (retsts & 1) goto expanded; } @@ -1408,9 +2484,9 @@ do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts) } /*}}}*/ /* External entry points */ -char *rmsexpand(char *spec, char *buf, char *def, unsigned opt) +char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt) { return do_rmsexpand(spec,buf,0,def,opt); } -char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt) +char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt) { return do_rmsexpand(spec,buf,1,def,opt); } @@ -1449,7 +2525,7 @@ char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt) */ /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/ -static char *do_fileify_dirspec(char *dir,char *buf,int ts) +static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts) { static char __fileify_retbuf[NAM$C_MAXRSS+1]; unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0; @@ -1460,7 +2536,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL; } dirlen = strlen(dir); - while (dir[dirlen-1] == '/') --dirlen; + while (dirlen && dir[dirlen-1] == '/') --dirlen; if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */ strcpy(trndir,"/sys$disk/000000"); dir = trndir; @@ -1486,7 +2562,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) * ... do_fileify_dirspec("myroot",buf,1) ... * does something useful. */ - if (!strcmp(dir+dirlen-2,".]")) { + if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) { dir[--dirlen] = '\0'; dir[dirlen-1] = ']'; } @@ -1516,7 +2592,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0'))) return do_fileify_dirspec("[-]",buf,ts); } - if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */ + if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */ dirlen -= 1; /* to last element */ lastdir = strrchr(dir,'/'); } @@ -1543,7 +2619,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) } while ((cp1 = strstr(cp1,"/.")) != NULL); lastdir = strrchr(dir,'/'); } - else if (!strcmp(&dir[dirlen-7],"/000000")) { + else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) { /* Ditto for specs that end in an MFD -- let the VMS code * figure out whether it's a real device or a rooted logical. */ dir[dirlen] = '/'; dir[dirlen+1] = '\0'; @@ -1761,13 +2837,13 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) } /* end of do_fileify_dirspec() */ /*}}}*/ /* External entry points */ -char *fileify_dirspec(char *dir, char *buf) +char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf) { return do_fileify_dirspec(dir,buf,0); } -char *fileify_dirspec_ts(char *dir, char *buf) +char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf) { return do_fileify_dirspec(dir,buf,1); } /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/ -static char *do_pathify_dirspec(char *dir,char *buf, int ts) +static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts) { static char __pathify_retbuf[NAM$C_MAXRSS+1]; unsigned long int retlen; @@ -1947,13 +3023,13 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts) } /* end of do_pathify_dirspec() */ /*}}}*/ /* External entry points */ -char *pathify_dirspec(char *dir, char *buf) +char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf) { return do_pathify_dirspec(dir,buf,0); } -char *pathify_dirspec_ts(char *dir, char *buf) +char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf) { return do_pathify_dirspec(dir,buf,1); } /*{{{ char *tounixspec[_ts](char *path, char *buf)*/ -static char *do_tounixspec(char *spec, char *buf, int ts) +static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts) { static char __tounixspec_retbuf[NAM$C_MAXRSS+1]; char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1]; @@ -2077,11 +3153,11 @@ static char *do_tounixspec(char *spec, char *buf, int ts) } /* end of do_tounixspec() */ /*}}}*/ /* External entry points */ -char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); } -char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); } +char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); } +char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); } /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/ -static char *do_tovmsspec(char *path, char *buf, int ts) { +static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) { static char __tovmsspec_retbuf[NAM$C_MAXRSS+1]; char *rslt, *dirend; register char *cp1, *cp2; @@ -2221,11 +3297,11 @@ static char *do_tovmsspec(char *path, char *buf, int ts) { } /* end of do_tovmsspec() */ /*}}}*/ /* External entry points */ -char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); } -char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); } +char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); } +char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); } /*{{{ char *tovmspath[_ts](char *path, char *buf)*/ -static char *do_tovmspath(char *path, char *buf, int ts) { +static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) { static char __tovmspath_retbuf[NAM$C_MAXRSS+1]; int vmslen; char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp; @@ -2249,12 +3325,12 @@ static char *do_tovmspath(char *path, char *buf, int ts) { } /* end of do_tovmspath() */ /*}}}*/ /* External entry points */ -char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); } -char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); } +char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); } +char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); } /*{{{ char *tounixpath[_ts](char *path, char *buf)*/ -static char *do_tounixpath(char *path, char *buf, int ts) { +static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) { static char __tounixpath_retbuf[NAM$C_MAXRSS+1]; int unixlen; char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp; @@ -2278,8 +3354,8 @@ static char *do_tounixpath(char *path, char *buf, int ts) { } /* end of do_tounixpath() */ /*}}}*/ /* External entry points */ -char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); } -char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); } +char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); } +char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); } /* * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com) @@ -2324,10 +3400,10 @@ static void add_item(struct list_item **head, char *value, int *count); -static void expand_wild_cards(char *item, - struct list_item **head, - struct list_item **tail, - int *count); +static void mp_expand_wild_cards(pTHX_ char *item, + struct list_item **head, + struct list_item **tail, + int *count); static int background_process(int argc, char **argv); @@ -2335,7 +3411,7 @@ static void pipe_and_fork(char **cmargv); /*{{{ void getredirection(int *ac, char ***av)*/ static void -getredirection(int *ac, char ***av) +mp_getredirection(pTHX_ int *ac, char ***av) /* * Process vms redirection arg's. Exit if any error is seen. * If getredirection() processes an argument, it is erased @@ -2539,9 +3615,12 @@ getredirection(int *ac, char ***av) PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out); exit(vaxc$errno); } + if (out != NULL) Perl_vmssetuserlnm("SYS$OUTPUT",out); + if (err != NULL) { if (strcmp(err,"&1") == 0) { dup2(fileno(stdout), fileno(Perl_debug_log)); + Perl_vmssetuserlnm("SYS$ERROR","SYS$OUTPUT"); } else { FILE *tmperr; if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2"))) @@ -2554,6 +3633,7 @@ getredirection(int *ac, char ***av) { exit(vaxc$errno); } + Perl_vmssetuserlnm("SYS$ERROR",err); } } #ifdef ARGPROC_DEBUG @@ -2585,7 +3665,7 @@ static void add_item(struct list_item **head, ++(*count); } -static void expand_wild_cards(char *item, +static void mp_expand_wild_cards(pTHX_ char *item, struct list_item **head, struct list_item **tail, int *count) @@ -2663,14 +3743,13 @@ unsigned long int zero = 0, sts; set_vaxc_errno(sts); switch (sts) { - case RMS$_FNF: - case RMS$_DNF: - case RMS$_DIR: + case RMS$_FNF: case RMS$_DNF: set_errno(ENOENT); break; + case RMS$_DIR: + set_errno(ENOTDIR); break; case RMS$_DEV: set_errno(ENODEV); break; - case RMS$_FNM: - case RMS$_SYN: + case RMS$_FNM: case RMS$_SYN: set_errno(EINVAL); break; case RMS$_PRV: set_errno(EACCES); break; @@ -2846,7 +3925,16 @@ vms_image_init(int *argcp, char ***argvp) * buffer much larger than $GETJPI wants (rsz is size in bytes that * were needed to hold all identifiers at time of last call; we'll * allocate that many unsigned long ints), and go back and get 'em. + * If it gave us less than it wanted to despite ample buffer space, + * something's broken. Is your system missing a system identifier? */ + if (rsz <= jpilist[1].buflen) { + /* Perl_croak accvios when used this early in startup. */ + fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s", + rsz, (unsigned long) jpilist[1].buflen, + "Check your rights database for corruption.\n"); + exit(SS$_ABORT); + } if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr); jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int); jpilist[1].buflen = rsz * sizeof(unsigned long int); @@ -2912,7 +4000,7 @@ vms_image_init(int *argcp, char ***argvp) if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; } getredirection(argcp,argvp); -#if defined(USE_THREADS) && defined(__DECC) +#if defined(USE_THREADS) && ( defined(__DECC) || defined(__DECCXX) ) { # include <reentrancy.h> (void) decc$set_reentrancy(C$C_MULTITHREAD); @@ -2940,7 +4028,7 @@ vms_image_init(int *argcp, char ***argvp) */ /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/ int -trim_unixpath(char *fspec, char *wildspec, int opts) +Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts) { char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1], *template, *base, *end, *cp1, *cp2; @@ -3099,7 +4187,7 @@ trim_unixpath(char *fspec, char *wildspec, int opts) */ /*{{{ DIR *opendir(char*name) */ DIR * -opendir(char *name) +Perl_opendir(pTHX_ char *name) { DIR *dd; char dir[NAM$C_MAXRSS+1]; @@ -3240,7 +4328,8 @@ readdir(DIR *dd) case RMS$_DEV: set_errno(ENODEV); break; case RMS$_DIR: - case RMS$_FNF: + set_errno(ENOTDIR); break; + case RMS$_FNF: case RMS$_DNF: set_errno(ENOENT); break; default: set_errno(EVMSERR); @@ -3352,7 +4441,7 @@ my_vfork() static void -vms_execfree() { +vms_execfree(pTHX) { if (PL_Cmd) { if (PL_Cmd != VMScmd.dsc$a_pointer) Safefree(PL_Cmd); PL_Cmd = Nullch; @@ -3580,10 +4669,12 @@ vms_do_exec(char *cmd) retsts = lib$do_command(&VMScmd); switch (retsts) { - case RMS$_FNF: + case RMS$_FNF: case RMS$_DNF: set_errno(ENOENT); break; - case RMS$_DNF: case RMS$_DIR: case RMS$_DEV: + case RMS$_DIR: set_errno(ENOTDIR); break; + case RMS$_DEV: + set_errno(ENODEV); break; case RMS$_PRV: set_errno(EACCES); break; case RMS$_SYN: @@ -3600,7 +4691,7 @@ vms_do_exec(char *cmd) Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s", VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno)); } - vms_execfree(); + vms_execfree(aTHX); } return FALSE; @@ -3640,10 +4731,12 @@ do_spawn(char *cmd) if (!(sts & 1)) { switch (sts) { - case RMS$_FNF: + case RMS$_FNF: case RMS$_DNF: set_errno(ENOENT); break; - case RMS$_DNF: case RMS$_DIR: case RMS$_DEV: + case RMS$_DIR: set_errno(ENOTDIR); break; + case RMS$_DEV: + set_errno(ENODEV); break; case RMS$_PRV: set_errno(EACCES); break; case RMS$_SYN: @@ -3663,33 +4756,105 @@ do_spawn(char *cmd) Strerror(errno)); } } - vms_execfree(); + vms_execfree(aTHX); return substs; } /* end of do_spawn() */ /*}}}*/ + +static unsigned int *sockflags, sockflagsize; + +/* + * Shim fdopen to identify sockets for my_fwrite later, since the stdio + * routines found in some versions of the CRTL can't deal with sockets. + * We don't shim the other file open routines since a socket isn't + * likely to be opened by a name. + */ +/*{{{ FILE *my_fdopen(int fd, char *mode)*/ +FILE *my_fdopen(int fd, char *mode) +{ + FILE *fp = fdopen(fd,mode); + + if (fp) { + unsigned int fdoff = fd / sizeof(unsigned int); + struct stat sbuf; /* native stat; we don't need flex_stat */ + if (!sockflagsize || fdoff > sockflagsize) { + if (sockflags) Renew( sockflags,fdoff+2,unsigned int); + else New (1324,sockflags,fdoff+2,unsigned int); + memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize); + sockflagsize = fdoff + 2; + } + if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode)) + sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int)); + } + return fp; + +} +/*}}}*/ + + +/* + * Clear the corresponding bit when the (possibly) socket stream is closed. + * There still a small hole: we miss an implicit close which might occur + * via freopen(). >> Todo + */ +/*{{{ int my_fclose(FILE *fp)*/ +int my_fclose(FILE *fp) { + if (fp) { + unsigned int fd = fileno(fp); + unsigned int fdoff = fd / sizeof(unsigned int); + + if (sockflagsize && fdoff <= sockflagsize) + sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int)); + } + return fclose(fp); +} +/*}}}*/ + + /* * A simple fwrite replacement which outputs itmsz*nitm chars without * introducing record boundaries every itmsz chars. + * We are using fputs, which depends on a terminating null. We may + * well be writing binary data, so we need to accommodate not only + * data with nulls sprinkled in the middle but also data with no null + * byte at the end. */ /*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest) { - register char *cp, *end; + register char *cp, *end, *cpd, *data; + register unsigned int fd = fileno(dest); + register unsigned int fdoff = fd / sizeof(unsigned int); + int retval; + int bufsize = itmsz * nitm + 1; + + if (fdoff < sockflagsize && + (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) { + if (write(fd, src, itmsz * nitm) == EOF) return EOF; + return nitm; + } - end = (char *)src + itmsz * nitm; + _ckvmssts_noperl(lib$get_vm(&bufsize, &data)); + memcpy( data, src, itmsz*nitm ); + data[itmsz*nitm] = '\0'; - while ((char *)src <= end) { - for (cp = src; cp <= end; cp++) if (!*cp) break; - if (fputs(src,dest) == EOF) return EOF; + end = data + itmsz * nitm; + retval = (int) nitm; /* on success return # items written */ + + cpd = data; + while (cpd <= end) { + for (cp = cpd; cp <= end; cp++) if (!*cp) break; + if (fputs(cpd,dest) == EOF) { retval = EOF; break; } if (cp < end) - if (fputc('\0',dest) == EOF) return EOF; - src = cp + 1; + if (fputc('\0',dest) == EOF) { retval = EOF; break; } + cpd = cp + 1; } - return 1; + if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data)); + return retval; } /* end of my_fwrite() */ /*}}}*/ @@ -3706,6 +4871,13 @@ my_flush(FILE *fp) #endif res = fsync(fileno(fp)); } +/* + * If the flush succeeded but set end-of-file, we need to clear + * the error because our caller may check ferror(). BTW, this + * probably means we just flushed an empty file. + */ + if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp); + return res; } /*}}}*/ @@ -4085,9 +5257,6 @@ static long int utc_offset_secs; #undef localtime #undef time -#if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000 -# define RTL_USES_UTC 1 -#endif /* * DEC C previous to 6.0 corrupts the behavior of the /prefix @@ -4136,6 +5305,289 @@ static time_t toloc_dst(time_t utc) { (gmtime_emulation_type == 1 ? toloc_dst(secs) : \ ((secs) + utc_offset_secs)))) +#ifndef RTL_USES_UTC +/* + + ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical + DST starts on 1st sun of april at 02:00 std time + ends on last sun of october at 02:00 dst time + see the UCX management command reference, SET CONFIG TIMEZONE + for formatting info. + + No, it's not as general as it should be, but then again, NOTHING + will handle UK times in a sensible way. +*/ + + +/* + parse the DST start/end info: + (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss] +*/ + +static char * +tz_parse_startend(char *s, struct tm *w, int *past) +{ + int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31}; + int ly, dozjd, d, m, n, hour, min, sec, j, k; + time_t g; + + if (!s) return 0; + if (!w) return 0; + if (!past) return 0; + + ly = 0; + if (w->tm_year % 4 == 0) ly = 1; + if (w->tm_year % 100 == 0) ly = 0; + if (w->tm_year+1900 % 400 == 0) ly = 1; + if (ly) dinm[1]++; + + dozjd = isdigit(*s); + if (*s == 'J' || *s == 'j' || dozjd) { + if (!dozjd && !isdigit(*++s)) return 0; + d = *s++ - '0'; + if (isdigit(*s)) { + d = d*10 + *s++ - '0'; + if (isdigit(*s)) { + d = d*10 + *s++ - '0'; + } + } + if (d == 0) return 0; + if (d > 366) return 0; + d--; + if (!dozjd && d > 58 && ly) d++; /* after 28 feb */ + g = d * 86400; + dozjd = 1; + } else if (*s == 'M' || *s == 'm') { + if (!isdigit(*++s)) return 0; + m = *s++ - '0'; + if (isdigit(*s)) m = 10*m + *s++ - '0'; + if (*s != '.') return 0; + if (!isdigit(*++s)) return 0; + n = *s++ - '0'; + if (n < 1 || n > 5) return 0; + if (*s != '.') return 0; + if (!isdigit(*++s)) return 0; + d = *s++ - '0'; + if (d > 6) return 0; + } + + if (*s == '/') { + if (!isdigit(*++s)) return 0; + hour = *s++ - '0'; + if (isdigit(*s)) hour = 10*hour + *s++ - '0'; + if (*s == ':') { + if (!isdigit(*++s)) return 0; + min = *s++ - '0'; + if (isdigit(*s)) min = 10*min + *s++ - '0'; + if (*s == ':') { + if (!isdigit(*++s)) return 0; + sec = *s++ - '0'; + if (isdigit(*s)) sec = 10*sec + *s++ - '0'; + } + } + } else { + hour = 2; + min = 0; + sec = 0; + } + + if (dozjd) { + if (w->tm_yday < d) goto before; + if (w->tm_yday > d) goto after; + } else { + if (w->tm_mon+1 < m) goto before; + if (w->tm_mon+1 > m) goto after; + + j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */ + k = d - j; /* mday of first d */ + if (k <= 0) k += 7; + k += 7 * ((n>4?4:n)-1); /* mday of n'th d */ + if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7; + if (w->tm_mday < k) goto before; + if (w->tm_mday > k) goto after; + } + + if (w->tm_hour < hour) goto before; + if (w->tm_hour > hour) goto after; + if (w->tm_min < min) goto before; + if (w->tm_min > min) goto after; + if (w->tm_sec < sec) goto before; + goto after; + +before: + *past = 0; + return s; +after: + *past = 1; + return s; +} + + + + +/* parse the offset: (+|-)hh[:mm[:ss]] */ + +static char * +tz_parse_offset(char *s, int *offset) +{ + int hour = 0, min = 0, sec = 0; + int neg = 0; + if (!s) return 0; + if (!offset) return 0; + + if (*s == '-') {neg++; s++;} + if (*s == '+') s++; + if (!isdigit(*s)) return 0; + hour = *s++ - '0'; + if (isdigit(*s)) hour = hour*10+(*s++ - '0'); + if (hour > 24) return 0; + if (*s == ':') { + if (!isdigit(*++s)) return 0; + min = *s++ - '0'; + if (isdigit(*s)) min = min*10 + (*s++ - '0'); + if (min > 59) return 0; + if (*s == ':') { + if (!isdigit(*++s)) return 0; + sec = *s++ - '0'; + if (isdigit(*s)) sec = sec*10 + (*s++ - '0'); + if (sec > 59) return 0; + } + } + + *offset = (hour*60+min)*60 + sec; + if (neg) *offset = -*offset; + return s; +} + +/* + input time is w, whatever type of time the CRTL localtime() uses. + sets dst, the zone, and the gmtoff (seconds) + + caches the value of TZ and UCX$TZ env variables; note that + my_setenv looks for these and sets a flag if they're changed + for efficiency. + + We have to watch out for the "australian" case (dst starts in + october, ends in april)...flagged by "reverse" and checked by + scanning through the months of the previous year. + +*/ + +static int +tz_parse(time_t *w, int *dst, char *zone, int *gmtoff) +{ + time_t when; + struct tm *w2; + char *s,*s2; + char *dstzone, *tz, *s_start, *s_end; + int std_off, dst_off, isdst; + int y, dststart, dstend; + static char envtz[1025]; /* longer than any logical, symbol, ... */ + static char ucxtz[1025]; + static char reversed = 0; + + if (!w) return 0; + + if (tz_updated) { + tz_updated = 0; + reversed = -1; /* flag need to check */ + envtz[0] = ucxtz[0] = '\0'; + tz = my_getenv("TZ",0); + if (tz) strcpy(envtz, tz); + tz = my_getenv("UCX$TZ",0); + if (tz) strcpy(ucxtz, tz); + if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */ + } + tz = envtz; + if (!*tz) tz = ucxtz; + + s = tz; + while (isalpha(*s)) s++; + s = tz_parse_offset(s, &std_off); + if (!s) return 0; + if (!*s) { /* no DST, hurray we're done! */ + isdst = 0; + goto done; + } + + dstzone = s; + while (isalpha(*s)) s++; + s2 = tz_parse_offset(s, &dst_off); + if (s2) { + s = s2; + } else { + dst_off = std_off - 3600; + } + + if (!*s) { /* default dst start/end?? */ + if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */ + s = strchr(ucxtz,','); + } + if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */ + } + if (*s != ',') return 0; + + when = *w; + when = _toutc(when); /* convert to utc */ + when = when - std_off; /* convert to pseudolocal time*/ + + w2 = localtime(&when); + y = w2->tm_year; + s_start = s+1; + s = tz_parse_startend(s_start,w2,&dststart); + if (!s) return 0; + if (*s != ',') return 0; + + when = *w; + when = _toutc(when); /* convert to utc */ + when = when - dst_off; /* convert to pseudolocal time*/ + w2 = localtime(&when); + if (w2->tm_year != y) { /* spans a year, just check one time */ + when += dst_off - std_off; + w2 = localtime(&when); + } + s_end = s+1; + s = tz_parse_startend(s_end,w2,&dstend); + if (!s) return 0; + + if (reversed == -1) { /* need to check if start later than end */ + int j, ds, de; + + when = *w; + if (when < 2*365*86400) { + when += 2*365*86400; + } else { + when -= 365*86400; + } + w2 =localtime(&when); + when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */ + + for (j = 0; j < 12; j++) { + w2 =localtime(&when); + (void) tz_parse_startend(s_start,w2,&ds); + (void) tz_parse_startend(s_end,w2,&de); + if (ds != de) break; + when += 30*86400; + } + reversed = 0; + if (de && !ds) reversed = 1; + } + + isdst = dststart && !dstend; + if (reversed) isdst = dststart || !dstend; + +done: + if (dst) *dst = isdst; + if (gmtoff) *gmtoff = isdst ? dst_off : std_off; + if (isdst) tz = dstzone; + if (zone) { + while(isalpha(*tz)) *zone++ = *tz++; + *zone = '\0'; + } + return 1; +} + +#endif /* !RTL_USES_UTC */ /* my_time(), my_localtime(), my_gmtime() * By default traffic in UTC time values, using CRTL gmtime() or @@ -4167,6 +5619,7 @@ time_t my_time(time_t *timep) gmtime_emulation_type++; if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) { gmtime_emulation_type++; + utc_offset_secs = 0; Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC"); } else { utc_offset_secs = atol(off); } @@ -4235,8 +5688,9 @@ struct tm * my_localtime(const time_t *timep) { dTHX; - time_t when; + time_t when, whenutc; struct tm *rsltmp; + int dst, offset; if (timep == NULL) { set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); @@ -4252,15 +5706,24 @@ my_localtime(const time_t *timep) # endif /* CRTL localtime() wants UTC as input, does tz correction itself */ return localtime(&when); -# else + +# else /* !RTL_USES_UTC */ + whenutc = when; # ifdef VMSISH_TIME - if (!VMSISH_TIME) when = _toloc(when); /* Input was UTC */ + if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */ + if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */ # endif + dst = -1; +#ifndef RTL_USES_UTC + if (tz_parse(&when, &dst, 0, &offset)) { /* truelocal determines DST*/ + when = whenutc - offset; /* pseudolocal time*/ + } # endif /* CRTL localtime() wants local time as input, so does no tz correction */ rsltmp = localtime(&when); - if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = -1; + if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst; return rsltmp; +# endif } /* end of my_localtime() */ /*}}}*/ @@ -4412,7 +5875,7 @@ int my_utime(char *file, struct utimbuf *utimes) fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver; memset((void *) &myfib, 0, sizeof myfib); -#ifdef __DECC +#if defined(__DECC) || defined(__DECCXX) for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i]; for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i]; /* This prevents the revision time of the file being reset to the current @@ -4549,6 +6012,7 @@ is_null_device(name) bool Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp) { + char fname_phdev[NAM$C_MAXRSS+1]; if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache); else { char fname[NAM$C_MAXRSS+1]; @@ -4567,7 +6031,15 @@ Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp) &namdsc,&namdsc.dsc$w_length,0,0); if (retsts & 1) { fname[namdsc.dsc$w_length] = '\0'; - return cando_by_name(bit,effective,fname); +/* + * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name, + * but if someone has redefined that logical, Perl gets very lost. Since + * we have the physical device name from the stat buffer, just paste it on. + */ + strcpy( fname_phdev, statbufp->st_devnam ); + strcat( fname_phdev, strrchr(fname, ':') ); + + return cando_by_name(bit,effective,fname_phdev); } else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) { Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n"); @@ -4621,26 +6093,14 @@ cando_by_name(I32 bit, Uid_t effective, char *fname) } switch (bit) { - case S_IXUSR: - case S_IXGRP: - case S_IXOTH: - access = ARM$M_EXECUTE; - break; - case S_IRUSR: - case S_IRGRP: - case S_IROTH: - access = ARM$M_READ; - break; - case S_IWUSR: - case S_IWGRP: - case S_IWOTH: - access = ARM$M_WRITE; - break; - case S_IDUSR: - case S_IDGRP: - case S_IDOTH: - access = ARM$M_DELETE; - break; + case S_IXUSR: case S_IXGRP: case S_IXOTH: + access = ARM$M_EXECUTE; break; + case S_IRUSR: case S_IRGRP: case S_IROTH: + access = ARM$M_READ; break; + case S_IWUSR: case S_IWGRP: case S_IWOTH: + access = ARM$M_WRITE; break; + case S_IDUSR: case S_IDGRP: case S_IDOTH: + access = ARM$M_DELETE; break; default: return FALSE; } @@ -4648,7 +6108,7 @@ cando_by_name(I32 bit, Uid_t effective, char *fname) retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst); if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT || retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN || - retsts == RMS$_DIR || retsts == RMS$_DEV) { + retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) { set_vaxc_errno(retsts); if (retsts == SS$_NOPRIV) set_errno(EACCES); else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL); @@ -4815,7 +6275,7 @@ my_getlogin() */ /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/ int -rmscopy(char *spec_in, char *spec_out, int preserve_dates) +Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates) { char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS], rsa[NAM$C_MAXRSS], ubf[32256]; @@ -4861,9 +6321,10 @@ rmscopy(char *spec_in, char *spec_out, int preserve_dates) if (!((sts = sys$open(&fab_in)) & 1)) { set_vaxc_errno(sts); switch (sts) { - case RMS$_FNF: - case RMS$_DIR: + case RMS$_FNF: case RMS$_DNF: set_errno(ENOENT); break; + case RMS$_DIR: + set_errno(ENOTDIR); break; case RMS$_DEV: set_errno(ENODEV); break; case RMS$_SYN: @@ -4905,8 +6366,10 @@ rmscopy(char *spec_in, char *spec_out, int preserve_dates) if (!((sts = sys$create(&fab_out)) & 1)) { set_vaxc_errno(sts); switch (sts) { - case RMS$_DIR: + case RMS$_DNF: set_errno(ENOENT); break; + case RMS$_DIR: + set_errno(ENOTDIR); break; case RMS$_DEV: set_errno(ENODEV); break; case RMS$_SYN: @@ -5174,6 +6637,82 @@ rmscopy_fromperl(pTHX_ CV *cv) XSRETURN(1); } + +void +mod2fname(CV *cv) +{ + dXSARGS; + char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1], + workbuff[NAM$C_MAXRSS*1 + 1]; + int total_namelen = 3, counter, num_entries; + /* ODS-5 ups this, but we want to be consistent, so... */ + int max_name_len = 39; + AV *in_array = (AV *)SvRV(ST(0)); + + num_entries = av_len(in_array); + + /* All the names start with PL_. */ + strcpy(ultimate_name, "PL_"); + + /* Clean up our working buffer */ + Zero(work_name, sizeof(work_name), char); + + /* Run through the entries and build up a working name */ + for(counter = 0; counter <= num_entries; counter++) { + /* If it's not the first name then tack on a __ */ + if (counter) { + strcat(work_name, "__"); + } + strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE), + PL_na)); + } + + /* Check to see if we actually have to bother...*/ + if (strlen(work_name) + 3 <= max_name_len) { + strcat(ultimate_name, work_name); + } else { + /* It's too darned big, so we need to go strip. We use the same */ + /* algorithm as xsubpp does. First, strip out doubled __ */ + char *source, *dest, last; + dest = workbuff; + last = 0; + for (source = work_name; *source; source++) { + if (last == *source && last == '_') { + continue; + } + *dest++ = *source; + last = *source; + } + /* Go put it back */ + strcpy(work_name, workbuff); + /* Is it still too big? */ + if (strlen(work_name) + 3 > max_name_len) { + /* Strip duplicate letters */ + last = 0; + dest = workbuff; + for (source = work_name; *source; source++) { + if (last == toupper(*source)) { + continue; + } + *dest++ = *source; + last = toupper(*source); + } + strcpy(work_name, workbuff); + } + + /* Is it *still* too big? */ + if (strlen(work_name) + 3 > max_name_len) { + /* Too bad, we truncate */ + work_name[max_name_len - 2] = 0; + } + strcat(ultimate_name, work_name); + } + + /* Okay, return it */ + ST(0) = sv_2mortal(newSVpv(ultimate_name, 0)); + XSRETURN(1); +} + void init_os_extras() { @@ -5194,8 +6733,11 @@ init_os_extras() 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); + store_pipelocs(); + return; } diff --git a/gnu/usr.bin/perl/vms/vmsish.h b/gnu/usr.bin/perl/vms/vmsish.h index e53c604d16f..15cda49e3c0 100644 --- a/gnu/usr.bin/perl/vms/vmsish.h +++ b/gnu/usr.bin/perl/vms/vmsish.h @@ -19,7 +19,7 @@ * ADDRCONSTEXT,NEEDCONSTEXT: initialization of data with non-constant values * (e.g. pointer fields of descriptors) */ -#ifdef __DECC +#if defined(__DECC) || defined(__DECCXX) # pragma message disable (ADDRCONSTEXT,NEEDCONSTEXT) #endif @@ -34,7 +34,7 @@ #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) +#if defined(__ALPHA) && (defined(__DECC) || defined(__DECCXX)) #undef abs #define abs(__x) __ABS(__x) #undef labs @@ -51,13 +51,8 @@ #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 -# include <unistd.h> /* DECC has this; VAXC and gcc don't */ -#endif - -/* VAXC doesn't have a unary plus operator, so we need to get there indirectly */ -#if defined(VAXC) && !defined(__DECC) -# define NO_UNARY_PLUS +#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 */ @@ -91,41 +86,63 @@ #define DONT_DECLARE_STD 1 /* Our own contribution to PerlShr's global symbols . . . */ -#define vmstrnenv Perl_vmstrnenv -#define my_trnlnm Perl_my_trnlnm #define my_getenv_len Perl_my_getenv_len #define prime_env_iter Perl_prime_env_iter #define vmssetenv Perl_vmssetenv #if !defined(PERL_IMPLICIT_CONTEXT) +#define my_trnlnm Perl_my_trnlnm +#define vmstrnenv Perl_vmstrnenv #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 #else +#define my_trnlnm(a,b,c) Perl_my_trnlnm(aTHX_ a,b,c) +#define vmstrnenv(a,b,c,d,e) Perl_vmstrnenv(aTHX_ a,b,c,d,e) #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) #endif #define my_crypt Perl_my_crypt #define my_waitpid Perl_my_waitpid #define my_gconvert Perl_my_gconvert -#define do_rmdir Perl_do_rmdir #define kill_file Perl_kill_file #define my_mkdir Perl_my_mkdir +#define my_chdir Perl_my_chdir +#define my_tmpfile Perl_my_tmpfile #define my_utime Perl_my_utime -#define rmsexpand Perl_rmsexpand -#define rmsexpand_ts Perl_rmsexpand_ts -#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 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 vms_image_init Perl_vms_image_init -#define opendir Perl_opendir #define readdir Perl_readdir #define telldir Perl_telldir #define seekdir Perl_seekdir @@ -143,12 +160,13 @@ #define cando_by_name Perl_cando_by_name #define flex_fstat Perl_flex_fstat #define flex_stat Perl_flex_stat -#define trim_unixpath Perl_trim_unixpath #define my_vfork Perl_my_vfork #define vms_do_aexec Perl_vms_do_aexec #define vms_do_exec Perl_vms_do_exec #define do_aspawn Perl_do_aspawn #define do_spawn Perl_do_spawn +#define my_fdopen Perl_my_fdopen +#define my_fclose Perl_my_fclose #define my_fwrite Perl_my_fwrite #define my_flush Perl_my_flush #define my_getpwnam Perl_my_getpwnam @@ -156,7 +174,6 @@ #define my_getpwent Perl_my_getpwent #define my_endpwent Perl_my_endpwent #define my_getlogin Perl_my_getlogin -#define rmscopy Perl_rmscopy #define init_os_extras Perl_init_os_extras /* Delete if at all possible, changing protections if necessary. */ @@ -174,6 +191,16 @@ # 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 my_tmpfile +#endif + + /* BIG_TIME: * This symbol is defined if Time_t is an unsigned type on this system. */ @@ -253,6 +280,8 @@ #ifdef VMS_DO_SOCKETS #include "sockadapt.h" +#define PERL_SOCK_SYSREAD_IS_RECV +#define PERL_SOCK_SYSWRITE_IS_SEND #endif #define BIT_BUCKET "_NLA0:" @@ -345,6 +374,13 @@ */ #define fwrite1 my_fwrite + +#ifndef DONT_MASK_RTL_CALLS +# 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) @@ -354,11 +390,6 @@ /* Assorted fiddling with sigs . . . */ # include <signal.h> #define ABORT() abort() - /* VAXC's signal.h doesn't #define SIG_ERR, but provides BADSIG instead. */ -#if !defined(SIG_ERR) && defined(BADSIG) -# define SIG_ERR BADSIG -#endif - /* Used with our my_utime() routine in vms.c */ struct utimbuf { @@ -441,14 +472,15 @@ struct utimbuf { #define ENVgetenv_len(v,l) my_getenv_len(v,l,FALSE) -/* Thin jacket around cuserid() tomatch Unix' calling sequence */ +/* Thin jacket around cuserid() to match Unix' calling sequence */ #define getlogin my_getlogin -/* Ditto for sys$hash_passwrod() . . . */ +/* Ditto for sys$hash_password() . . . */ #define crypt my_crypt -/* Tweak arg to mkdir first, so we can tolerate trailing /. */ +/* Tweak arg to mkdir & chdir first, so we can tolerate trailing /. */ #define Mkdir(dir,mode) my_mkdir((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) @@ -506,7 +538,7 @@ struct passwd { * 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 + * 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 */ @@ -623,38 +655,63 @@ void prime_env_iter (void); void init_os_extras (); /* prototype section start marker; `typedef' passes through cpp */ typedef char __VMS_PROTOTYPES__; -int vmstrnenv (const char *, char *, unsigned long int, struct dsc$descriptor_s **, unsigned long int); -int my_trnlnm (const char *, char *, unsigned long int); #if !defined(PERL_IMPLICIT_CONTEXT) char * Perl_my_getenv (const char *, bool); +int Perl_vmstrnenv (const char *, char *, unsigned long int, struct dsc$descriptor_s **, unsigned long int); +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); #else +int Perl_vmstrnenv (pTHX_ const char *, char *, unsigned long int, struct dsc$descriptor_s **, unsigned long int); 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); #endif char * my_getenv_len (const char *, unsigned long *, bool); int vmssetenv (char *, char *, struct dsc$descriptor_s **); +void Perl_vmssetuserlnm(char *name, char *eqv); char * my_crypt (const char *, const char *); Pid_t my_waitpid (Pid_t, int *, int); char * my_gconvert (double, int, int, char *); -int do_rmdir (char *); int kill_file (char *); int my_mkdir (char *, Mode_t); +int my_chdir (char *); +FILE * my_tmpfile (void); int my_utime (char *, struct utimbuf *); -char * rmsexpand (char *, char *, char *, unsigned); -char * rmsexpand_ts (char *, char *, char *, unsigned); -char * fileify_dirspec (char *, char *); -char * fileify_dirspec_ts (char *, char *); -char * pathify_dirspec (char *, char *); -char * pathify_dirspec_ts (char *, char *); -char * tounixspec (char *, char *); -char * tounixspec_ts (char *, char *); -char * tovmsspec (char *, char *); -char * tovmsspec_ts (char *, char *); -char * tounixpath (char *, char *); -char * tounixpath_ts (char *, char *); -char * tovmspath (char *, char *); -char * tovmspath_ts (char *, char *); void vms_image_init (int *, char ***); -DIR * opendir (char *); struct dirent * readdir (DIR *); long telldir (DIR *); void seekdir (DIR *, long); @@ -674,12 +731,13 @@ int my_sigprocmask (int, sigset_t *, sigset_t *); I32 cando_by_name (I32, Uid_t, char *); int flex_fstat (int, Stat_t *); int flex_stat (const char *, Stat_t *); -int trim_unixpath (char *, char*, int); int my_vfork (); bool vms_do_aexec (SV *, SV **, SV **); bool vms_do_exec (char *); unsigned long int do_aspawn (void *, void **, void **); unsigned long int do_spawn (char *); +FILE * my_fdopen (int, char *); +int my_fclose (FILE *); int my_fwrite (void *, size_t, size_t, FILE *); int my_flush (FILE *); struct passwd * my_getpwnam (char *name); @@ -687,7 +745,6 @@ struct passwd * my_getpwuid (Uid_t uid); struct passwd * my_getpwent (); void my_endpwent (); char * my_getlogin (); -int rmscopy (char *, char *, int); typedef char __VMS_SEPYTOTORP__; /* prototype section end marker; `typedef' passes through cpp */ @@ -722,4 +779,6 @@ typedef char __VMS_SEPYTOTORP__; # undef fileno #endif +#define NO_ENVIRON_ARRAY + #endif /* __vmsish_h_included */ |