From 491527d0220de34ec13035d557e288c9952d1007 Mon Sep 17 00:00:00 2001 From: Gurusamy Sarathy Date: Thu, 14 May 1998 09:06:18 +0000 Subject: [PATCH] [win32] merge change#886 from maintbranch p4raw-link: @886 on //depot/maint-5.004/perl: 6dba07070c2cb08ffbc6e00eff60e8f5fc9a7ee8 p4raw-id: //depot/win32/perl@936 --- README.os2 | 32 +++++- README.vms | 9 ++ cop.h | 1 + ext/DynaLoader/dl_hpux.xs | 7 +- ext/POSIX/POSIX.xs | 38 +++---- ext/POSIX/hints/linux.pl | 2 +- global.sym | 2 + hints/aix.sh | 2 +- hints/bsdos.sh | 23 ++++- hints/hpux.sh | 6 +- hints/netbsd.sh | 8 ++ hints/os2.sh | 23 +++-- hints/svr4.sh | 9 +- lib/ExtUtils/MM_OS2.pm | 1 - lib/ExtUtils/MM_Unix.pm | 4 + lib/File/Basename.pm | 4 + lib/File/Path.pm | 6 +- op.c | 1 - os2/Makefile.SHs | 12 +-- os2/os2.c | 252 ++++++++++++++++++++++++++++++---------------- os2/perl2cmd.pl | 2 +- perl.c | 197 +----------------------------------- perl.h | 6 +- pod/perlguts.pod | 7 ++ pod/pod2man.PL | 2 +- pp_ctl.c | 18 +++- pp_hot.c | 38 ++++--- pp_sys.c | 39 ++----- proto.h | 2 + t/lib/filecopy.t | 1 + util.c | 245 ++++++++++++++++++++++++++++++++++++++++++++ utils/perldoc.PL | 1 + vms/config.vms | 2 +- vms/descrip.mms | 18 ++-- vms/ext/Filespec.pm | 1 + vms/ext/filespec.t | 2 + vms/test.com | 15 ++- 37 files changed, 649 insertions(+), 389 deletions(-) diff --git a/README.os2 b/README.os2 index 667423c..903702a 100644 --- a/README.os2 +++ b/README.os2 @@ -308,7 +308,31 @@ L<"Frequently asked questions">), and perl should be able to find it The only cases when the shell is not used is the multi-argument system() (see L)/exec() (see L), and one-argument version thereof without redirection and shell -meta-characters. +meta-characters. Perl may also start scripts which start with cookies +C or C<#!> directly, without an intervention of shell. + +If starting scripts directly, Perl will use exactly the same algorithm as for +the search of script given by B<-S> command-line option: it will look in +the current directory, then on components of C<$ENV{PATH}> using the +following order of appended extensions: no extension, F<.cmd>, F<.btm>, +F<.bat>, F<.pl>. + +Note that Perl will start to look for scripts only if OS/2 cannot start the +specified application, thus C will not look for a script if +there is an executable file F I on C. + +Note also that executable files on OS/2 can have an arbitrary extension, +but F<.exe> will be automatically appended if no dot is present in the name. +The workaround as as simple as that: since F and F denote the +same file, to start an executable residing in file F (no +extension) give an argument C to system(). + +The last note is that currently it is not straightforward to start PM +programs from VIO (=text-mode) Perl process and visa versa. Either ensure +that shell will be used, as in C, or start it using +optional arguments to system() documented in C module. This +is considered a bug and should be fixed soon. + =head1 Frequently asked questions @@ -780,6 +804,10 @@ F. =head2 Testing +If you haven't yet moved perl.dll onto LIBPATH, do it now(alternatively, if +you have a previous perl installation you'd rather not disrupt until this one +is installed, copy perl.dll to the t directory). + Now run make test @@ -911,6 +939,8 @@ to 1. =head2 Installing the built perl +If you haven't yet moved perl.dll onto LIBPATH, do it now. + Run make install diff --git a/README.vms b/README.vms index 40de6ac..21efaa0 100644 --- a/README.vms +++ b/README.vms @@ -203,6 +203,8 @@ your DCL$PATH (if you're using VMS 6.2 or higher). 6) Optionally define the command PERLDOC as PERLDOC :== $PERL_ROOT:[000000]PERL PERL_ROOT:[LIB.POD]PERLDOC.COM -T +Note that if you wish to use most as a pager please see +ftp://space.mit.edu/pub/davis/ for both most and slang. 7) Optionally define the command PERLBUG (the Perl bug report generator) as PERLBUG :== $PERL_ROOT:[000000]PERL PERL_ROOT:[LIB]PERLBUG.COM" @@ -214,6 +216,13 @@ module builds) as DEFINE/NOLOG POD2MAN PERL_ROOT:[LIB.POD]POD2MAN.COM POD2MAN :== $PERL_ROOT:[000000]PERL POD2MAN +8) Optionally define the command POD2MAN (Converts POD files to nroff +source suitable for converting to man pages. Also quiets complaints during +module builds) as + +DEFINE/NOLOG POD2MAN PERL_ROOT:[LIB.POD]POD2MAN.COM +POD2MAN :== $PERL_ROOT:[000000]PERL POD2MAN + * Installing Perl into DCLTABLES Courtesy of Brad Hughes: diff --git a/cop.h b/cop.h index 5eebaba..803be29 100644 --- a/cop.h +++ b/cop.h @@ -285,6 +285,7 @@ struct context { #define G_EVAL 4 /* Assume eval {} around subroutine call. */ #define G_NOARGS 8 /* Don't construct a @_ array. */ #define G_KEEPERR 16 /* Append errors to $@, don't overwrite it */ +#define G_NODEBUG 32 /* Disable debugging at toplevel. */ /* Support for switching (stack and block) contexts. * This ensures magic doesn't invalidate local stack and cx pointers. diff --git a/ext/DynaLoader/dl_hpux.xs b/ext/DynaLoader/dl_hpux.xs index 51d464e..a82e0ea 100644 --- a/ext/DynaLoader/dl_hpux.xs +++ b/ext/DynaLoader/dl_hpux.xs @@ -65,6 +65,9 @@ dl_load_file(filename, flags=0) * unresolved references in situations like this. */ /* bind_type = BIND_IMMEDIATE|BIND_NONFATAL; */ } + /* BIND_NOSTART removed from bind_type because it causes the shared library's */ + /* initialisers not to be run. This causes problems with all of the static objects */ + /* in the library. */ #ifdef DEBUGGING if (dl_debug) bind_type |= BIND_VERBOSE; @@ -74,14 +77,14 @@ dl_load_file(filename, flags=0) for (i = 0; i <= max; i++) { char *sym = SvPVX(*av_fetch(dl_resolve_using, i, 0)); DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s) (dependent)\n", sym)); - obj = shl_load(sym, bind_type | BIND_NOSTART, 0L); + obj = shl_load(sym, bind_type, 0L); if (obj == NULL) { goto end; } } DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s): ", filename)); - obj = shl_load(filename, bind_type | BIND_NOSTART, 0L); + obj = shl_load(filename, bind_type, 0L); DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", obj)); end: diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index e1d6833..1dba9a6 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -2289,55 +2289,55 @@ constant(char *name, int arg) case '_': if (strnEQ(name, "_PC_", 4)) { if (strEQ(name, "_PC_CHOWN_RESTRICTED")) -#ifdef _PC_CHOWN_RESTRICTED +#if defined(_PC_CHOWN_RESTRICTED) || HINT_SC_EXIST return _PC_CHOWN_RESTRICTED; #else goto not_there; #endif if (strEQ(name, "_PC_LINK_MAX")) -#ifdef _PC_LINK_MAX +#if defined(_PC_LINK_MAX) || HINT_SC_EXIST return _PC_LINK_MAX; #else goto not_there; #endif if (strEQ(name, "_PC_MAX_CANON")) -#ifdef _PC_MAX_CANON +#if defined(_PC_MAX_CANON) || HINT_SC_EXIST return _PC_MAX_CANON; #else goto not_there; #endif if (strEQ(name, "_PC_MAX_INPUT")) -#ifdef _PC_MAX_INPUT +#if defined(_PC_MAX_INPUT) || HINT_SC_EXIST return _PC_MAX_INPUT; #else goto not_there; #endif if (strEQ(name, "_PC_NAME_MAX")) -#ifdef _PC_NAME_MAX +#if defined(_PC_NAME_MAX) || HINT_SC_EXIST return _PC_NAME_MAX; #else goto not_there; #endif if (strEQ(name, "_PC_NO_TRUNC")) -#ifdef _PC_NO_TRUNC +#if defined(_PC_NO_TRUNC) || HINT_SC_EXIST return _PC_NO_TRUNC; #else goto not_there; #endif if (strEQ(name, "_PC_PATH_MAX")) -#ifdef _PC_PATH_MAX +#if defined(_PC_PATH_MAX) || HINT_SC_EXIST return _PC_PATH_MAX; #else goto not_there; #endif if (strEQ(name, "_PC_PIPE_BUF")) -#ifdef _PC_PIPE_BUF +#if defined(_PC_PIPE_BUF) || HINT_SC_EXIST return _PC_PIPE_BUF; #else goto not_there; #endif if (strEQ(name, "_PC_VDISABLE")) -#ifdef _PC_VDISABLE +#if defined(_PC_VDISABLE) || HINT_SC_EXIST return _PC_VDISABLE; #else goto not_there; @@ -2463,61 +2463,61 @@ constant(char *name, int arg) } if (strnEQ(name, "_SC_", 4)) { if (strEQ(name, "_SC_ARG_MAX")) -#ifdef _SC_ARG_MAX +#if defined(_SC_ARG_MAX) || HINT_SC_EXIST return _SC_ARG_MAX; #else goto not_there; #endif if (strEQ(name, "_SC_CHILD_MAX")) -#ifdef _SC_CHILD_MAX +#if defined(_SC_CHILD_MAX) || HINT_SC_EXIST return _SC_CHILD_MAX; #else goto not_there; #endif if (strEQ(name, "_SC_CLK_TCK")) -#ifdef _SC_CLK_TCK +#if defined(_SC_CLK_TCK) || HINT_SC_EXIST return _SC_CLK_TCK; #else goto not_there; #endif if (strEQ(name, "_SC_JOB_CONTROL")) -#ifdef _SC_JOB_CONTROL +#if defined(_SC_JOB_CONTROL) || HINT_SC_EXIST return _SC_JOB_CONTROL; #else goto not_there; #endif if (strEQ(name, "_SC_NGROUPS_MAX")) -#ifdef _SC_NGROUPS_MAX +#if defined(_SC_NGROUPS_MAX) || HINT_SC_EXIST return _SC_NGROUPS_MAX; #else goto not_there; #endif if (strEQ(name, "_SC_OPEN_MAX")) -#ifdef _SC_OPEN_MAX +#if defined(_SC_OPEN_MAX) || HINT_SC_EXIST return _SC_OPEN_MAX; #else goto not_there; #endif if (strEQ(name, "_SC_SAVED_IDS")) -#ifdef _SC_SAVED_IDS +#if defined(_SC_SAVED_IDS) || HINT_SC_EXIST return _SC_SAVED_IDS; #else goto not_there; #endif if (strEQ(name, "_SC_STREAM_MAX")) -#ifdef _SC_STREAM_MAX +#if defined(_SC_STREAM_MAX) || HINT_SC_EXIST return _SC_STREAM_MAX; #else goto not_there; #endif if (strEQ(name, "_SC_TZNAME_MAX")) -#ifdef _SC_TZNAME_MAX +#if defined(_SC_TZNAME_MAX) || HINT_SC_EXIST return _SC_TZNAME_MAX; #else goto not_there; #endif if (strEQ(name, "_SC_VERSION")) -#ifdef _SC_VERSION +#if defined(_SC_VERSION) || HINT_SC_EXIST return _SC_VERSION; #else goto not_there; diff --git a/ext/POSIX/hints/linux.pl b/ext/POSIX/hints/linux.pl index 7994f24..f1d1981 100644 --- a/ext/POSIX/hints/linux.pl +++ b/ext/POSIX/hints/linux.pl @@ -2,4 +2,4 @@ # Thanks to Bart Schuller # See Message-ID: <19971009002636.50729@tanglefoot> # XXX A Configure test is needed. -$self->{CCFLAGS} = $Config{ccflags} . ' -DSTRUCT_TM_HASZONE' ; +$self->{CCFLAGS} = $Config{ccflags} . ' -DSTRUCT_TM_HASZONE -DHINT_SC_EXIST' ; diff --git a/global.sym b/global.sym index 43a223e..31a452b 100644 --- a/global.sym +++ b/global.sym @@ -24,6 +24,7 @@ dec_amg di div_amg div_ass_amg +do_binmode ds eq_amg exp_amg @@ -308,6 +309,7 @@ fetch_io filter_add filter_del filter_read +find_script find_threadsv fold_constants force_ident diff --git a/hints/aix.sh b/hints/aix.sh index a29466e..21dc888 100644 --- a/hints/aix.sh +++ b/hints/aix.sh @@ -66,7 +66,7 @@ case "$osvers" in lddlflags='-H512 -T512 -bhalt:4 -bM:SRE -bI:$(PERL_INC)/perl.exp -bE:$(BASEEXT).exp -e _nostart -lc' ;; *) -lddlflags='-H512 -T512 -bhalt:4 -bM:SRE -bI:$(PERL_INC)/perl.exp -bE:$(BASEEXT).exp -b noentry -lc' +lddlflags='-bhalt:4 -bM:SRE -bI:$(PERL_INC)/perl.exp -bE:$(BASEEXT).exp -b noentry -lc' ;; esac diff --git a/hints/bsdos.sh b/hints/bsdos.sh index c89a0a9..0896e26 100644 --- a/hints/bsdos.sh +++ b/hints/bsdos.sh @@ -3,7 +3,7 @@ # hints file for BSD/OS (adapted from bsd386.sh) # Original by Neil Bowers ; Tue Oct 4 12:01:34 EDT 1994 # Updated by Tony Sanders ; Sat Aug 23 12:47:45 MDT 1997 -# Added 3.1 with ELF dynamic libraries +# Added 3.1 with ELF dynamic libraries (NOT in 3.1 yet. Estimated for 4.0) # SYSV IPC tested Ok so I re-enabled. # # To override the compiler on the command line: @@ -33,6 +33,9 @@ libswanted="$*" glibpth="$glibpth /usr/X11/lib" ldflags="$ldflags -L/usr/X11/lib" +# Avoid telldir prototype conflict in pp_sys.c +pp_sys_cflags='ccflags="$ccflags -DHAS_TELLDIR_PROTOTYPE"' + case "$optimize" in '') optimize='-O2' ;; esac @@ -85,4 +88,22 @@ case "$osvers" in libswanted="Xpm Xaw Xmu Xt SM ICE Xext X11 $libswanted" libswanted="rpc curses termcap $libswanted" ;; +4.0*) + # ELF dynamic link libraries starting in 4.0 (???) + useshrplib='true' + so='so' + dlext='so' + + case "$cc" in + '') cc='cc' # cc is gcc2 in 4.0 + cccdlflags="-fPIC" + ccdlflags=" " ;; + esac + + case "$ld" in + '') ld='ld' + lddlflags="-shared -x $lddlflags" ;; + esac + ;; esac + diff --git a/hints/hpux.sh b/hints/hpux.sh index 9b272ae..3e727d2 100644 --- a/hints/hpux.sh +++ b/hints/hpux.sh @@ -43,8 +43,10 @@ # "ext.libs" file which is *probably* messing up the order. Often, # you can replace ext.libs with an empty file to fix the problem. # -# If you get a message about "too much defining", you might have to -# add the following to your ccflags: '-Wp,-H256000' +# If you get a message about "too much defining", as may happen +# in HPUX < 10, you might have to append a single entry to your +# ccflags: '-Wp,-H256000' +# NOTE: This is a single entry (-W takes the argument 'p,-H256000'). #-------------------------------------------------------------------- # Turn on the _HPUX_SOURCE flag to get many of the HP add-ons diff --git a/hints/netbsd.sh b/hints/netbsd.sh index 787f0f1..b0736bf 100644 --- a/hints/netbsd.sh +++ b/hints/netbsd.sh @@ -41,6 +41,14 @@ case "$osvers" in esac ;; esac +# netbsd 1.3 linker warns about setr[gu]id being deprecated. +# (setregid, setreuid, preferred?) +case "$osvers" in +1.3|1.3*) + d_setrgid="$undef" + d_setruid="$undef" + ;; +esac # netbsd had these but they don't really work as advertised, in the # versions listed below. if they are defined, then there isn't a diff --git a/hints/os2.sh b/hints/os2.sh index 2293adf..7a980bd 100644 --- a/hints/os2.sh +++ b/hints/os2.sh @@ -23,6 +23,14 @@ if test -f $sh.exe; then sh=$sh.exe; fi startsh="#!$sh" cc='gcc' +# Make denser object files and DLL +case "X$optimize" in + X) + optimize="-O2 -fomit-frame-pointer -malign-loops=2 -malign-jumps=2 -malign-functions=2 -s" + ld_dll_optimize="-s" + ;; +esac + # Get some standard things (indented to avoid putting in config.sh): oifs="$IFS" IFS=" ;" @@ -104,11 +112,11 @@ aout_obj_ext='.o' aout_lib_ext='.a' aout_ar='ar' aout_plibext='.a' -aout_lddlflags='-Zdll' +aout_lddlflags="-Zdll $ld_dll_optimize" if [ $emxcrtrev -ge 50 ]; then - aout_ldflags='-Zexe -Zsmall-conv' + aout_ldflags='-Zexe -Zsmall-conv -Zstack 32000' else - aout_ldflags='-Zexe' + aout_ldflags='-Zexe -Zstack 32000' fi # To get into config.sh: @@ -152,7 +160,7 @@ else else d_fork='undef' fi - lddlflags='-Zdll -Zomf -Zmt -Zcrtdll' + lddlflags="-Zdll -Zomf -Zmt -Zcrtdll $ld_dll_optimize" # Recursive regmatch may eat 2.5M of stack alone. ldflags='-Zexe -Zomf -Zmt -Zcrtdll -Zstack 32000' if [ $emxcrtrev -ge 50 ]; then @@ -241,13 +249,6 @@ nm_opt='-p' d_getprior='define' d_setprior='define' -# Make denser object files and DLL -case "X$optimize" in - X) - optimize="-O2 -fomit-frame-pointer -malign-loops=2 -malign-jumps=2 -malign-functions=2 -s" - ;; -esac - if [ "X$usethreads" = "X$define" ]; then ccflags="-Zmt $ccflags" cppflags="-Zmt $cppflags" # Do we really need to set this? diff --git a/hints/svr4.sh b/hints/svr4.sh index 922736a..eb875e1 100644 --- a/hints/svr4.sh +++ b/hints/svr4.sh @@ -34,9 +34,16 @@ d_lstat=define # UnixWare has a broken csh. The undocumented -X argument to uname is probably # a reasonable way of detecting UnixWare. Also in 2.1.1 the fields in -# FILE* got renamed! +# FILE* got renamed! Plus 1.1 can't cast large floats to 32-bit ints. uw_ver=`uname -v` uw_isuw=`uname -X 2>&1 | grep Release` +if [ "$uw_isuw" = "Release = 4.2" ]; then + case $uw_ver in + 1.1) + d_casti32='undef' + ;; + esac +fi if [ "$uw_isuw" = "Release = 4.2MP" ]; then case $uw_ver in 2.1) diff --git a/lib/ExtUtils/MM_OS2.pm b/lib/ExtUtils/MM_OS2.pm index 65abfc2..7661901 100644 --- a/lib/ExtUtils/MM_OS2.pm +++ b/lib/ExtUtils/MM_OS2.pm @@ -8,7 +8,6 @@ require Exporter; Exporter::import('ExtUtils::MakeMaker', qw( $Verbose &neatvalue)); -$ENV{EMXSHELL} = 'sh'; # to run `commands` unshift @MM::ISA, 'ExtUtils::MM_OS2'; sub dlsyms { diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index 8e61fe0..f2cf735 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -1004,6 +1004,10 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists $ldrun = join ' ', map "-R$_", split /:/, $self->{LD_RUN_PATH} if ($^O eq 'solaris'); + # The IRIX linker also doesn't use LD_RUN_PATH + $ldrun = "-rpath $self->{LD_RUN_PATH}" + if ($^O eq 'irix'); + push(@m,' LD_RUN_PATH="$(LD_RUN_PATH)" $(LD) -o $@ '.$ldrun.' $(LDDLFLAGS) '.$ldfrom. ' $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) $(EXPORT_LIST)'); push @m, ' diff --git a/lib/File/Basename.pm b/lib/File/Basename.pm index 8828a52..3333844 100644 --- a/lib/File/Basename.pm +++ b/lib/File/Basename.pm @@ -177,6 +177,10 @@ sub fileparse { } elsif ($fstype !~ /^VMS/i) { # default to Unix ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#); + if ($^O eq 'VMS' and $fullname =~ m:/[^/]+/000000/?:) { + # dev:[000000] is top of VMS tree, similar to Unix '/' + ($basename,$dirpath) = ('',$fullname); + } $dirpath = './' unless $dirpath; } diff --git a/lib/File/Path.pm b/lib/File/Path.pm index 6b5d568..39f1ba1 100644 --- a/lib/File/Path.pm +++ b/lib/File/Path.pm @@ -124,11 +124,15 @@ sub mkpath { $paths = [$paths] unless ref $paths; my(@created,$path); foreach $path (@$paths) { + $path .= '/' if $^O eq 'os2' and $path =~ /^\w:$/; # feature of CRT next if -d $path; # Logic wants Unix paths, so go with the flow. $path = VMS::Filespec::unixify($path) if $Is_VMS; my $parent = File::Basename::dirname($path); - push(@created,mkpath($parent, $verbose, $mode)) unless (-d $parent); + # Allow for creation of new logical filesystems under VMS + if (not $Is_VMS or $parent !~ m:/[^/]+/000000/?:) { + push(@created,mkpath($parent, $verbose, $mode)) unless (-d $parent); + } print "mkdir $path\n" if $verbose; unless (mkdir($path,$mode)) { # allow for another process to have created it meanwhile diff --git a/op.c b/op.c index 73bd676..31b085d 100644 --- a/op.c +++ b/op.c @@ -3483,7 +3483,6 @@ newSUB(I32 floor, OP *o, OP *proto, OP *block) ENTER; SAVESPTR(compiling.cop_filegv); SAVEI16(compiling.cop_line); - SAVEI32(perldb); save_svref(&rs); sv_setsv(rs, nrs); diff --git a/os2/Makefile.SHs b/os2/Makefile.SHs index 57d4260..5506a39 100644 --- a/os2/Makefile.SHs +++ b/os2/Makefile.SHs @@ -18,7 +18,7 @@ AOUT_CLDFLAGS = $aout_ldflags AOUT_LIBPERL_DLL = libperl_dll$aout_lib_ext AOUT_CCCMD_DLL = \$(CC) -DDOSISH -DOS2=2 -DEMBED -I. -DPACK_MALLOC -DDEBUGGING_MSTATS -DTWO_POT_OPTIMIZE -DPERL_EMERGENCY_SBRK -AOUT_CLDFLAGS_DLL = -Zexe -Zmt -Zcrtdll +AOUT_CLDFLAGS_DLL = -Zexe -Zmt -Zcrtdll -Zstack 32000 LD_OPT = $optimize @@ -85,19 +85,19 @@ depend: os2ish.h dlfcn.h os2thread.h os2.c os2$(OBJ_EXT) : os2.c os2.c: os2/os2.c os2ish.h - cp $< $@ + cp -f $< $@ dl_os2.c: os2/dl_os2.c os2ish.h - cp $< $@ + cp -f $< $@ os2ish.h: os2/os2ish.h - cp $< $@ + cp -f $< $@ os2thread.h: os2/os2thread.h - cp $< $@ + cp -f $< $@ dlfcn.h: os2/dlfcn.h - cp $< $@ + cp -f $< $@ # This one is compiled OMF, so cannot fork(): diff --git a/os2/os2.c b/os2/os2.c index f24c3af..d4050ac 100644 --- a/os2/os2.c +++ b/os2/os2.c @@ -347,40 +347,37 @@ result(int flag, int pid) #endif } +#define EXECF_SPAWN 0 +#define EXECF_EXEC 1 +#define EXECF_TRUEEXEC 2 +#define EXECF_SPAWN_NOWAIT 3 + +/* Spawn/exec a program, revert to shell if needed. */ +/* global Argv[] contains arguments. */ + int -do_aspawn(really,mark,sp) +do_aspawn(really, flag, execf) SV *really; -register SV **mark; -register SV **sp; +U32 flag; +U32 execf; { dTHR; - register char **a; - char *tmps = NULL; - int rc; - int flag = P_WAIT, trueflag, err, secondtry = 0; - - if (sp > mark) { - New(1301,Argv, sp - mark + 3, char*); - a = Argv; - - if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) { - ++mark; - flag = SvIVx(*mark); - } - - while (++mark <= sp) { - if (*mark) - *a++ = SvPVx(*mark, na); - else - *a++ = ""; - } - *a = Nullch; - - trueflag = flag; + int trueflag = flag; + int rc, secondtry = 0, err; + char *tmps; + char buf[256], *s = 0; + char *args[4]; + static char * fargs[4] + = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", }; + char **argsp = fargs; + char nargs = 4; + if (flag == P_WAIT) flag = P_NOWAIT; - if (strEQ(Argv[0],"/bin/sh")) Argv[0] = sh_path; + retry: + if (strEQ(Argv[0],"/bin/sh")) + Argv[0] = sh_path; if (Argv[0][0] != '/' && Argv[0][0] != '\\' && !(Argv[0][0] && Argv[0][1] == ':' @@ -388,18 +385,29 @@ register SV **sp; ) /* will swawnvp use PATH? */ TAINT_ENV(); /* testing IFS here is overkill, probably */ /* We should check PERL_SH* and PERLLIB_* as well? */ - retry: - if (really && *(tmps = SvPV(really, na))) - rc = result(trueflag, spawnvp(flag,tmps,Argv)); - else - rc = result(trueflag, spawnvp(flag,Argv[0],Argv)); - + if (!really || !*(tmps = SvPV(really, na))) + tmps = Argv[0]; +#if 0 + rc = result(trueflag, spawnvp(flag,tmps,Argv)); +#else + if (execf == EXECF_TRUEEXEC) + rc = execvp(tmps,Argv); + else if (execf == EXECF_EXEC) + rc = spawnvp(trueflag | P_OVERLAY,tmps,Argv); + else if (execf == EXECF_SPAWN_NOWAIT) + rc = spawnvp(trueflag | P_NOWAIT,tmps,Argv); + else /* EXECF_SPAWN */ + rc = result(trueflag, + spawnvp(trueflag | P_NOWAIT,tmps,Argv)); +#endif if (rc < 0 && secondtry == 0 - && (!tmps || !*tmps)) { /* Cannot transfer `really' via shell. */ + && (tmps == Argv[0])) { /* Cannot transfer `really' via shell. */ err = errno; if (err == ENOENT) { /* No such file. */ /* One reason may be that EMX added .exe. We suppose - that .exe-less files are automatically shellable. */ + that .exe-less files are automatically shellable. + It might have also been .cmd file without + extension. */ char *no_dir; (no_dir = strrchr(Argv[0], '/')) || (no_dir = strrchr(Argv[0], '\\')) @@ -409,34 +417,139 @@ register SV **sp; if (stat(Argv[0], &buffer) != -1) { /* File exists. */ /* Maybe we need to specify the full name here? */ goto doshell; + } else { + /* Try adding script extensions to the file name */ + char *scr; + if ((scr = find_script(Argv[0], TRUE, NULL, 0))) { + FILE *file = fopen(scr, "r"); + char *s = 0, *s1; + + Argv[0] = scr; + if (!file) + goto panic_file; + if (!fgets(buf, sizeof buf, file)) { + fclose(file); + goto panic_file; + } + if (fclose(file) != 0) { /* Failure */ + panic_file: + warn("Error reading \"%s\": %s", + scr, Strerror(errno)); + goto doshell; + } + if (buf[0] == '#') { + if (buf[1] == '!') + s = buf + 2; + } else if (buf[0] == 'e') { + if (strnEQ(buf, "extproc", 7) + && isSPACE(buf[7])) + s = buf + 8; + } else if (buf[0] == 'E') { + if (strnEQ(buf, "EXTPROC", 7) + && isSPACE(buf[7])) + s = buf + 8; + } + if (!s) + goto doshell; + s1 = s; + nargs = 0; + argsp = args; + while (1) { + while (isSPACE(*s)) + s++; + if (*s == 0) + break; + if (nargs == 4) { + nargs = -1; + break; + } + args[nargs++] = s; + while (*s && !isSPACE(*s)) + s++; + if (*s == 0) + break; + *s++ = 0; + } + if (nargs == -1) { + warn("Too many args on %.*s line of \"%s\"", + s1 - buf, buf, scr); + nargs = 4; + argsp = fargs; + } + goto doshell; + } } } + /* Restore errno */ + errno = err; } else if (err == ENOEXEC) { /* Need to send to shell. */ doshell: + { + char **a = Argv; + + while (a[1]) /* Get to the end */ + a++; while (a >= Argv) { - *(a + 2) = *a; + *(a + nargs) = *a; /* Argv was preallocated to be + long enough. */ a--; } - *Argv = sh_path; - *(Argv + 1) = "-c"; + while (nargs-- >= 0) + Argv[nargs] = argsp[nargs]; secondtry = 1; goto retry; + } } } if (rc < 0 && dowarn) - warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno)); - if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ + warn("Can't %s \"%s\": %s\n", + ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) + ? "spawn" : "exec"), + Argv[0], Strerror(err)); + if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT) + && ((trueflag & 0xFF) == P_WAIT)) + rc = 255 << 8; /* Emulate the fork(). */ + + return rc; +} + +int +do_aspawn(really,mark,sp) +SV *really; +register SV **mark; +register SV **sp; +{ + dTHR; + register char **a; + char *tmps = NULL; + int rc; + int flag = P_WAIT, trueflag, err, secondtry = 0; + + if (sp > mark) { + New(1301,Argv, sp - mark + 3, char*); + a = Argv; + + if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) { + ++mark; + flag = SvIVx(*mark); + } + + while (++mark <= sp) { + if (*mark) + *a++ = SvPVx(*mark, na); + else + *a++ = ""; + } + *a = Nullch; + + rc = do_spawn_ve(really, flag, EXECF_SPAWN); } else rc = -1; do_execfree(); return rc; } -#define EXECF_SPAWN 0 -#define EXECF_EXEC 1 -#define EXECF_TRUEEXEC 2 -#define EXECF_SPAWN_NOWAIT 3 - +/* Try converting 1-arg form to (usually shell-less) multi-arg form. */ int do_spawn2(cmd, execf) char *cmd; @@ -501,6 +614,8 @@ int execf; } else if (*s == '\\' && !seenspace) { continue; /* Allow backslashes in names */ } + /* We do not convert this to do_spawn_ve since shell + should be smart enough to start itself gloriously. */ doshell: if (execf == EXECF_TRUEEXEC) return execl(shell,shell,copt,cmd,(char*)0); @@ -523,7 +638,8 @@ int execf; } } - New(1303,Argv, (s - cmd) / 2 + 2, char*); + /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */ + New(1303,Argv, (s - cmd + 11) / 2, char*); Cmd = savepvn(cmd, s-cmd); a = Argv; for (s = Cmd; *s;) { @@ -535,44 +651,9 @@ int execf; *s++ = '\0'; } *a = Nullch; - if (Argv[0]) { - int err; - - if (execf == EXECF_TRUEEXEC) - rc = execvp(Argv[0],Argv); - else if (execf == EXECF_EXEC) - rc = spawnvp(P_OVERLAY,Argv[0],Argv); - else if (execf == EXECF_SPAWN_NOWAIT) - rc = spawnvp(P_NOWAIT,Argv[0],Argv); - else - rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv)); - if (rc < 0) { - err = errno; - if (err == ENOENT) { /* No such file. */ - /* One reason may be that EMX added .exe. We suppose - that .exe-less files are automatically shellable. */ - char *no_dir; - (no_dir = strrchr(Argv[0], '/')) - || (no_dir = strrchr(Argv[0], '\\')) - || (no_dir = Argv[0]); - if (!strchr(no_dir, '.')) { - struct stat buffer; - if (stat(Argv[0], &buffer) != -1) { /* File exists. */ - /* Maybe we need to specify the full name here? */ - goto doshell; - } - } - } else if (err == ENOEXEC) { /* Need to send to shell. */ - goto doshell; - } - } - if (rc < 0 && dowarn) - warn("Can't %s \"%s\": %s", - ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) - ? "spawn" : "exec"), - Argv[0], Strerror(err)); - if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ - } else + if (Argv[0]) + rc = do_spawn_ve(NULL, 0, execf); + else rc = -1; if (news) Safefree(news); do_execfree(); @@ -643,7 +724,8 @@ char *mode; dup2(newfd, *mode == 'r'); /* Return std* back. */ close(newfd); } - close(p[that]); + if (p[that] == (*mode == 'r')) + close(p[that]); if (pid == -1) { close(p[this]); return NULL; diff --git a/os2/perl2cmd.pl b/os2/perl2cmd.pl index e774f77..f9cc03b 100644 --- a/os2/perl2cmd.pl +++ b/os2/perl2cmd.pl @@ -23,7 +23,7 @@ foreach $file (<$idir/*>) { $base =~ s|.*/||; $file =~ s|/|\\|g ; print "Processing $file => $dir\\$base.cmd\n"; - system 'cmd.exe', '/c', "echo extproc perl -S >$dir\\$base.cmd"; + system 'cmd.exe', '/c', "echo extproc perl -S>$dir\\$base.cmd"; system 'cmd.exe', '/c', "type $file >> $dir\\$base.cmd"; } diff --git a/perl.c b/perl.c index 1240a5b..88c0837 100644 --- a/perl.c +++ b/perl.c @@ -1210,7 +1210,8 @@ perl_call_sv(SV *sv, I32 flags) && (DBcv || (DBcv = GvCV(DBsub))) /* Try harder, since this may have been a sighandler, thus * curstash may be meaningless. */ - && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash)) + && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash) + && !(flags & G_NODEBUG)) op->op_private |= OPpENTERSUB_DB; if (flags & G_EVAL) { @@ -1805,201 +1806,9 @@ static void open_script(char *scriptname, bool dosearch, SV *sv) { dTHR; - char *xfound = Nullch; - char *xfailed = Nullch; register char *s; - I32 len; - int retval; -#if defined(DOSISH) && !defined(OS2) && !defined(atarist) -# define SEARCH_EXTS ".bat", ".cmd", NULL -# define MAX_EXT_LEN 4 -#endif -#ifdef OS2 -# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL -# define MAX_EXT_LEN 4 -#endif -#ifdef VMS -# define SEARCH_EXTS ".pl", ".com", NULL -# define MAX_EXT_LEN 4 -#endif - /* additional extensions to try in each dir if scriptname not found */ -#ifdef SEARCH_EXTS - char *ext[] = { SEARCH_EXTS }; - int extidx = 0, i = 0; - char *curext = Nullch; -#else -# define MAX_EXT_LEN 0 -#endif - - /* - * If dosearch is true and if scriptname does not contain path - * delimiters, search the PATH for scriptname. - * - * If SEARCH_EXTS is also defined, will look for each - * scriptname{SEARCH_EXTS} whenever scriptname is not found - * while searching the PATH. - * - * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search - * proceeds as follows: - * If DOSISH or VMSISH: - * + look for ./scriptname{,.foo,.bar} - * + search the PATH for scriptname{,.foo,.bar} - * - * If !DOSISH: - * + look *only* in the PATH for scriptname{,.foo,.bar} (note - * this will not look in '.' if it's not in the PATH) - */ - -#ifdef VMS -# ifdef ALWAYS_DEFTYPES - len = strlen(scriptname); - if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') { - int hasdir, idx = 0, deftypes = 1; - bool seen_dot = 1; - - hasdir = !dosearch || (strpbrk(scriptname,":[= sizeof tokenbuf) - continue; /* don't search dir with too-long name */ - strcat(tokenbuf, scriptname); -#else /* !VMS */ - -#ifdef DOSISH - if (strEQ(scriptname, "-")) - dosearch = 0; - if (dosearch) { /* Look in '.' first. */ - char *cur = scriptname; -#ifdef SEARCH_EXTS - if ((curext = strrchr(scriptname,'.'))) /* possible current ext */ - while (ext[i]) - if (strEQ(ext[i++],curext)) { - extidx = -1; /* already has an ext */ - break; - } - do { -#endif - DEBUG_p(PerlIO_printf(Perl_debug_log, - "Looking for %s\n",cur)); - if (PerlLIO_stat(cur,&statbuf) >= 0) { - dosearch = 0; - scriptname = cur; -#ifdef SEARCH_EXTS - break; -#endif - } -#ifdef SEARCH_EXTS - if (cur == scriptname) { - len = strlen(scriptname); - if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf)) - break; - cur = strcpy(tokenbuf, scriptname); - } - } while (extidx >= 0 && ext[extidx] /* try an extension? */ - && strcpy(tokenbuf+len, ext[extidx++])); -#endif - } -#endif - if (dosearch && !strchr(scriptname, '/') -#ifdef DOSISH - && !strchr(scriptname, '\\') -#endif - && (s = PerlEnv_getenv("PATH"))) { - bool seen_dot = 0; - - bufend = s + strlen(s); - while (s < bufend) { -#if defined(atarist) || defined(DOSISH) - for (len = 0; *s -# ifdef atarist - && *s != ',' -# endif - && *s != ';'; len++, s++) { - if (len < sizeof tokenbuf) - tokenbuf[len] = *s; - } - if (len < sizeof tokenbuf) - tokenbuf[len] = '\0'; -#else /* ! (atarist || DOSISH) */ - s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend, - ':', - &len); -#endif /* ! (atarist || DOSISH) */ - if (s < bufend) - s++; - if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf) - continue; /* don't search dir with too-long name */ - if (len -#if defined(atarist) || defined(DOSISH) - && tokenbuf[len - 1] != '/' - && tokenbuf[len - 1] != '\\' -#endif - ) - tokenbuf[len++] = '/'; - if (len == 2 && tokenbuf[0] == '.') - seen_dot = 1; - (void)strcpy(tokenbuf + len, scriptname); -#endif /* !VMS */ - -#ifdef SEARCH_EXTS - len = strlen(tokenbuf); - if (extidx > 0) /* reset after previous loop */ - extidx = 0; - do { -#endif - DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf)); - retval = PerlLIO_stat(tokenbuf,&statbuf); -#ifdef SEARCH_EXTS - } while ( retval < 0 /* not there */ - && extidx>=0 && ext[extidx] /* try an extension? */ - && strcpy(tokenbuf+len, ext[extidx++]) - ); -#endif - if (retval < 0) - continue; - if (S_ISREG(statbuf.st_mode) - && cando(S_IRUSR,TRUE,&statbuf) -#ifndef DOSISH - && cando(S_IXUSR,TRUE,&statbuf) -#endif - ) - { - xfound = tokenbuf; /* bingo! */ - break; - } - if (!xfailed) - xfailed = savepv(tokenbuf); - } -#ifndef DOSISH - if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&statbuf) < 0)) -#endif - seen_dot = 1; /* Disable message. */ - if (!xfound) - croak("Can't %s %s%s%s", - (xfailed ? "execute" : "find"), - (xfailed ? xfailed : scriptname), - (xfailed ? "" : " on PATH"), - (xfailed || seen_dot) ? "" : ", '.' not in PATH"); - if (xfailed) - Safefree(xfailed); - scriptname = xfound; - } + scriptname = find_script(scriptname, dosearch, NULL, 0); if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) { char *s = scriptname + 8; diff --git a/perl.h b/perl.h index 9be3245..537da4f 100644 --- a/perl.h +++ b/perl.h @@ -2009,7 +2009,7 @@ enum { #endif /* OVERLOAD */ -#define PERLDB_ALL 0xff +#define PERLDB_ALL 0x3f /* No _NONAME, _GOTO */ #define PERLDBf_SUB 0x01 /* Debug sub enter/exit. */ #define PERLDBf_LINE 0x02 /* Keep line #. */ #define PERLDBf_NOOPT 0x04 /* Switch off optimizations. */ @@ -2017,6 +2017,8 @@ enum { later inspections. */ #define PERLDBf_SUBLINE 0x10 /* Keep subr source lines. */ #define PERLDBf_SINGLE 0x20 /* Start with single-step on. */ +#define PERLDBf_NONAME 0x40 /* For _SUB: no name of the subr. */ +#define PERLDBf_GOTO 0x80 /* Report goto: call DB::goto. */ #define PERLDB_SUB (perldb && (perldb & PERLDBf_SUB)) #define PERLDB_LINE (perldb && (perldb & PERLDBf_LINE)) @@ -2024,6 +2026,8 @@ enum { #define PERLDB_INTER (perldb && (perldb & PERLDBf_INTER)) #define PERLDB_SUBLINE (perldb && (perldb & PERLDBf_SUBLINE)) #define PERLDB_SINGLE (perldb && (perldb & PERLDBf_SINGLE)) +#define PERLDB_SUB_NN (perldb && (perldb & (PERLDBf_NONAME))) +#define PERLDB_GOTO (perldb && (perldb & PERLDBf_GOTO)) #ifdef USE_LOCALE_NUMERIC diff --git a/pod/perlguts.pod b/pod/perlguts.pod index d51e52b..6edb8b8 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -1623,6 +1623,13 @@ to indicate the number of items on the stack. Sets up the C variable for an XSUB which has aliases. This is usually handled automatically by C. +=item do_binmode + +Switches filehandle to binmode. C is what C would +contain. + + do_binmode(fp, iotype, TRUE); + =item ENTER Opening bracket on a callback. See C and L. diff --git a/pod/pod2man.PL b/pod/pod2man.PL index 5e5dfb0..a91d3e5 100644 --- a/pod/pod2man.PL +++ b/pod/pod2man.PL @@ -315,7 +315,7 @@ $cutting = 1; # We try first to get the version number from a local binary, in case we're # running an installed version of Perl to produce documentation from an # uninstalled newer version's pod files. -if ($^O ne 'plan9' && $^O ne 'dos') { +if ($^O ne 'plan9' and $^O ne 'dos' and $^O ne 'os2' and $^O ne 'MSWin32') { ($version,$patch) = `\PATH=.:..:\$PATH; perl -v` =~ /version (\d\.\d{3})(?:_(\d{2}))?/; } diff --git a/pp_ctl.c b/pp_ctl.c index f54bb75..f6934e9 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1877,14 +1877,26 @@ PP(pp_goto) mark++; } } - if (PERLDB_SUB && curstash != debstash) { + if (PERLDB_SUB) { /* Checking curstash breaks DProf. */ /* * We do not care about using sv to call CV; * it's for informational purposes only. */ SV *sv = GvSV(DBsub); - save_item(sv); - gv_efullname3(sv, CvGV(cv), Nullch); + CV *gotocv; + + if (PERLDB_SUB_NN) { + SvIVX(sv) = (IV)cv; /* Already upgraded, saved */ + } else { + save_item(sv); + gv_efullname3(sv, CvGV(cv), Nullch); + } + if ( PERLDB_GOTO + && (gotocv = perl_get_cv("DB::goto", FALSE)) ) { + PUSHMARK( stack_sp ); + perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG); + stack_sp--; + } } RETURNOP(CvSTART(cv)); } diff --git a/pp_hot.c b/pp_hot.c index 0422605..be1ce49 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1800,27 +1800,35 @@ static CV * get_db_sub(SV **svp, CV *cv) { dTHR; - SV *oldsv = *svp; - GV *gv; + SV *dbsv = GvSV(DBsub); + + if (!PERLDB_SUB_NN) { + GV *gv = CvGV(cv); - *svp = GvSV(DBsub); - save_item(*svp); - gv = CvGV(cv); - if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) - || strEQ(GvNAME(gv), "END") - || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */ - !( (SvTYPE(oldsv) == SVt_PVGV) && (GvCV((GV*)oldsv) == cv) - && (gv = (GV*)oldsv) ))) { - /* Use GV from the stack as a fallback. */ - /* GV is potentially non-unique, or contain different CV. */ - sv_setsv(*svp, newRV((SV*)cv)); + save_item(dbsv); + if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) + || strEQ(GvNAME(gv), "END") + || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */ + !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) + && (gv = (GV*)*svp) ))) { + /* Use GV from the stack as a fallback. */ + /* GV is potentially non-unique, or contain different CV. */ + sv_setsv(dbsv, newRV((SV*)cv)); + } + else { + gv_efullname3(dbsv, gv, Nullch); + } } else { - gv_efullname3(*svp, gv, Nullch); + SvUPGRADE(dbsv, SVt_PVIV); + SvIOK_on(dbsv); + SAVEIV(SvIVX(dbsv)); + SvIVX(dbsv) = (IV)cv; /* Do it the quickest way */ } - cv = GvCV(DBsub); + if (CvXSUB(cv)) curcopdb = curcop; + cv = GvCV(DBsub); return cv; } diff --git a/pp_sys.c b/pp_sys.c index ce32fc5..d841d04 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -485,40 +485,10 @@ PP(pp_binmode) if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) RETPUSHUNDEF; -#ifdef DOSISH -#ifdef atarist - if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN)) + if (do_binmode(fp,IoTYPE(io),TRUE)) RETPUSHYES; else RETPUSHUNDEF; -#else - if (PerlLIO_setmode(PerlIO_fileno(fp), OP_BINARY) != -1) { -#if defined(WIN32) && defined(__BORLANDC__) - /* The translation mode of the stream is maintained independent - * of the translation mode of the fd in the Borland RTL (heavy - * digging through their runtime sources reveal). User has to - * set the mode explicitly for the stream (though they don't - * document this anywhere). GSAR 97-5-24 - */ - PerlIO_seek(fp,0L,0); - fp->flags |= _F_BIN; -#endif - RETPUSHYES; - } - else - RETPUSHUNDEF; -#endif -#else -#if defined(USEMYBINMODE) - if (my_binmode(fp,IoTYPE(io)) != NULL) - RETPUSHYES; - else - RETPUSHUNDEF; -#else - RETPUSHYES; -#endif -#endif - } @@ -2603,6 +2573,13 @@ PP(pp_chdir) if (svp) tmps = SvPV(*svp, na); } +#ifdef VMS + if (!tmps || !*tmps) { + svp = hv_fetch(GvHVn(envgv), "SYS$LOGIN", 9, FALSE); + if (svp) + tmps = SvPV(*svp, na); + } +#endif TAINT_PROPER("chdir"); PUSHi( PerlDir_chdir(tmps) >= 0 ); #ifdef VMS diff --git a/proto.h b/proto.h index eb75dc4..fb20480 100644 --- a/proto.h +++ b/proto.h @@ -90,6 +90,7 @@ OP* die _((const char* pat,...)); OP* die_where _((char* message)); void dounwind _((I32 cxix)); bool do_aexec _((SV* really, SV** mark, SV** sp)); +int do_binmode _((PerlIO *fp, int iotype, int flag)); void do_chop _((SV* asv, SV* sv)); bool do_close _((GV* gv, bool not_implicit)); bool do_eof _((GV* gv)); @@ -139,6 +140,7 @@ void dump_packsubs _((HV* stash)); void dump_sub _((GV* gv)); void fbm_compile _((SV* sv, U32 flags)); char* fbm_instr _((unsigned char* big, unsigned char* bigend, SV* littlesv)); +char* find_script _((char *scriptname, bool dosearch, char **search_ext, I32 flags)); #ifdef USE_THREADS PADOFFSET find_threadsv _((char *name)); #endif diff --git a/t/lib/filecopy.t b/t/lib/filecopy.t index 8a23fb6..e4bde30 100755 --- a/t/lib/filecopy.t +++ b/t/lib/filecopy.t @@ -29,6 +29,7 @@ print "ok 1\n"; print "not " unless $foo eq "ok 3\n"; print "ok 2\n"; +binmode STDOUT; # Copy::copy works in binary mode copy "copy-$$", \*STDOUT; unlink "copy-$$" or die "unlink: $!"; diff --git a/util.c b/util.c index ac51f13..866e598 100644 --- a/util.c +++ b/util.c @@ -1835,6 +1835,46 @@ VTOH(vtohs,short) VTOH(vtohl,long) #endif +int +do_binmode(PerlIO *fp, int iotype, int flag) +{ + if (flag != TRUE) + croak("panic: unsetting binmode"); /* Not implemented yet */ +#ifdef DOSISH +#ifdef atarist + if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN)) + return 1; + else + return 0; +#else + if (PerlLIO_setmode(PerlIO_fileno(fp), OP_BINARY) != -1) { +#if defined(WIN32) && defined(__BORLANDC__) + /* The translation mode of the stream is maintained independent + * of the translation mode of the fd in the Borland RTL (heavy + * digging through their runtime sources reveal). User has to + * set the mode explicitly for the stream (though they don't + * document this anywhere). GSAR 97-5-24 + */ + PerlIO_seek(fp,0L,0); + fp->flags |= _F_BIN; +#endif + return 1; + } + else + return 0; +#endif +#else +#if defined(USEMYBINMODE) + if (my_binmode(fp,iotype) != NULL) + return 1; + else + return 0; +#else + return 1; +#endif +#endif +} + /* VMS' my_popen() is in VMS.c, same with OS/2. */ #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) PerlIO * @@ -2404,6 +2444,211 @@ scan_hex(char *start, I32 len, I32 *retlen) return retval; } +char* +find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags) +{ + dTHR; + char *xfound = Nullch; + char *xfailed = Nullch; + register char *s; + I32 len; + int retval; +#if defined(DOSISH) && !defined(OS2) && !defined(atarist) +# define SEARCH_EXTS ".bat", ".cmd", NULL +# define MAX_EXT_LEN 4 +#endif +#ifdef OS2 +# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL +# define MAX_EXT_LEN 4 +#endif +#ifdef VMS +# define SEARCH_EXTS ".pl", ".com", NULL +# define MAX_EXT_LEN 4 +#endif + /* additional extensions to try in each dir if scriptname not found */ +#ifdef SEARCH_EXTS + char *exts[] = { SEARCH_EXTS }; + char **ext = search_ext ? search_ext : exts; + int extidx = 0, i = 0; + char *curext = Nullch; +#else +# define MAX_EXT_LEN 0 +#endif + + /* + * If dosearch is true and if scriptname does not contain path + * delimiters, search the PATH for scriptname. + * + * If SEARCH_EXTS is also defined, will look for each + * scriptname{SEARCH_EXTS} whenever scriptname is not found + * while searching the PATH. + * + * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search + * proceeds as follows: + * If DOSISH or VMSISH: + * + look for ./scriptname{,.foo,.bar} + * + search the PATH for scriptname{,.foo,.bar} + * + * If !DOSISH: + * + look *only* in the PATH for scriptname{,.foo,.bar} (note + * this will not look in '.' if it's not in the PATH) + */ + +#ifdef VMS +# ifdef ALWAYS_DEFTYPES + len = strlen(scriptname); + if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') { + int hasdir, idx = 0, deftypes = 1; + bool seen_dot = 1; + + hasdir = !dosearch || (strpbrk(scriptname,":[= sizeof tokenbuf) + continue; /* don't search dir with too-long name */ + strcat(tokenbuf, scriptname); +#else /* !VMS */ + +#ifdef DOSISH + if (strEQ(scriptname, "-")) + dosearch = 0; + if (dosearch) { /* Look in '.' first. */ + char *cur = scriptname; +#ifdef SEARCH_EXTS + if ((curext = strrchr(scriptname,'.'))) /* possible current ext */ + while (ext[i]) + if (strEQ(ext[i++],curext)) { + extidx = -1; /* already has an ext */ + break; + } + do { +#endif + DEBUG_p(PerlIO_printf(Perl_debug_log, + "Looking for %s\n",cur)); + if (PerlLIO_stat(cur,&statbuf) >= 0) { + dosearch = 0; + scriptname = cur; +#ifdef SEARCH_EXTS + break; +#endif + } +#ifdef SEARCH_EXTS + if (cur == scriptname) { + len = strlen(scriptname); + if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf)) + break; + cur = strcpy(tokenbuf, scriptname); + } + } while (extidx >= 0 && ext[extidx] /* try an extension? */ + && strcpy(tokenbuf+len, ext[extidx++])); +#endif + } +#endif + + if (dosearch && !strchr(scriptname, '/') +#ifdef DOSISH + && !strchr(scriptname, '\\') +#endif + && (s = PerlEnv_getenv("PATH"))) { + bool seen_dot = 0; + + bufend = s + strlen(s); + while (s < bufend) { +#if defined(atarist) || defined(DOSISH) + for (len = 0; *s +# ifdef atarist + && *s != ',' +# endif + && *s != ';'; len++, s++) { + if (len < sizeof tokenbuf) + tokenbuf[len] = *s; + } + if (len < sizeof tokenbuf) + tokenbuf[len] = '\0'; +#else /* ! (atarist || DOSISH) */ + s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend, + ':', + &len); +#endif /* ! (atarist || DOSISH) */ + if (s < bufend) + s++; + if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf) + continue; /* don't search dir with too-long name */ + if (len +#if defined(atarist) || defined(DOSISH) + && tokenbuf[len - 1] != '/' + && tokenbuf[len - 1] != '\\' +#endif + ) + tokenbuf[len++] = '/'; + if (len == 2 && tokenbuf[0] == '.') + seen_dot = 1; + (void)strcpy(tokenbuf + len, scriptname); +#endif /* !VMS */ + +#ifdef SEARCH_EXTS + len = strlen(tokenbuf); + if (extidx > 0) /* reset after previous loop */ + extidx = 0; + do { +#endif + DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf)); + retval = PerlLIO_stat(tokenbuf,&statbuf); +#ifdef SEARCH_EXTS + } while ( retval < 0 /* not there */ + && extidx>=0 && ext[extidx] /* try an extension? */ + && strcpy(tokenbuf+len, ext[extidx++]) + ); +#endif + if (retval < 0) + continue; + if (S_ISREG(statbuf.st_mode) + && cando(S_IRUSR,TRUE,&statbuf) +#ifndef DOSISH + && cando(S_IXUSR,TRUE,&statbuf) +#endif + ) + { + xfound = tokenbuf; /* bingo! */ + break; + } + if (!xfailed) + xfailed = savepv(tokenbuf); + } +#ifndef DOSISH + if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&statbuf) < 0)) +#endif + seen_dot = 1; /* Disable message. */ + if (!xfound) + scriptname = NULL; +/* croak("Can't %s %s%s%s", + (xfailed ? "execute" : "find"), + (xfailed ? xfailed : scriptname), + (xfailed ? "" : " on PATH"), + (xfailed || seen_dot) ? "" : ", '.' not in PATH"); */ + if (xfailed) + Safefree(xfailed); + scriptname = xfound; + } + return scriptname; +} + + #ifdef USE_THREADS #ifdef FAKE_THREADS /* Very simplistic scheduler for now */ diff --git a/utils/perldoc.PL b/utils/perldoc.PL index bb3d69d..326da7a 100644 --- a/utils/perldoc.PL +++ b/utils/perldoc.PL @@ -361,6 +361,7 @@ if ($Is_MSWin32) { if ($^O eq 'os2') { require POSIX; $tmp = POSIX::tmpnam(); + unshift @pagers, 'less', 'cmd /c more <'; } else { $tmp = "/tmp/perldoc1.$$"; } diff --git a/vms/config.vms b/vms/config.vms index 35abbdb..39c7e50 100644 --- a/vms/config.vms +++ b/vms/config.vms @@ -1029,7 +1029,7 @@ * have select(), of course. */ #if defined(__DECC) && defined(__DECC_VER) && (__DECC_VER >= 50200000) && defined(DECCRTL_SOCKETS) -#define Select_fd_set_t fd_set * /**/ +#define Select_fd_set_t fd_set * /* config-skip */ #else #define Select_fd_set_t int * /* config-skip */ #endif diff --git a/vms/descrip.mms b/vms/descrip.mms index 00a5c0b..b806231 100644 --- a/vms/descrip.mms +++ b/vms/descrip.mms @@ -779,14 +779,14 @@ B : [.lib]B.pm [.lib]O.pm [.lib.B]Asmdata.pm [.lib.B]Assembler.pm [.lib.B]Bblock [.lib]perlbug.com : [.utils]perlbug.PL $(ARCHDIR)Config.pm $(MINIPERL) $(MMS$SOURCE) - Rename/Log [.utils]perlbug.com $(MMS$TARGET) + Copy/Log [.utils]perlbug.com $(MMS$TARGET) [.utils]pl2pm.com : [.utils]pl2pm.PL $(ARCHDIR)Config.pm $(MINIPERL) $(MMS$SOURCE) [.lib]splain.com : [.utils]splain.PL $(ARCHDIR)Config.pm $(MINIPERL) $(MMS$SOURCE) - Rename/Log [.utils]splain.com $(MMS$TARGET) + Copy/Log [.utils]splain.com $(MMS$TARGET) [.x2p]find2perl.com : [.x2p]find2perl.PL $(ARCHDIR)Config.pm $(MINIPERL) $(MMS$SOURCE) @@ -826,22 +826,22 @@ B : [.lib]B.pm [.lib]O.pm [.lib.B]Asmdata.pm [.lib.B]Assembler.pm [.lib.B]Bblock [.lib.pod]pod2html.com : [.pod]pod2html.PL $(ARCHDIR)Config.pm @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] $(MINIPERL) $(MMS$SOURCE) - Rename/Log [.pod]pod2html.com $(MMS$TARGET) + Copy/Log [.pod]pod2html.com $(MMS$TARGET) [.lib.pod]pod2latex.com : [.pod]pod2latex.PL $(ARCHDIR)Config.pm @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] $(MINIPERL) $(MMS$SOURCE) - Rename/Log [.pod]pod2latex.com $(MMS$TARGET) + Copy/Log [.pod]pod2latex.com $(MMS$TARGET) [.lib.pod]pod2man.com : [.pod]pod2man.PL $(ARCHDIR)Config.pm @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] $(MINIPERL) $(MMS$SOURCE) - Rename/Log [.pod]pod2man.com $(MMS$TARGET) + Copy/Log [.pod]pod2man.com $(MMS$TARGET) [.lib.pod]pod2text.com : [.pod]pod2text.PL $(ARCHDIR)Config.pm @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] $(MINIPERL) $(MMS$SOURCE) - Rename/Log [.pod]pod2text.com $(MMS$TARGET) + Copy/Log [.pod]pod2text.com $(MMS$TARGET) preplibrary : $(MINIPERL_EXE) $(LIBPREREQ) $(SOCKPM) @ Write Sys$Output "Autosplitting Perl library . . ." @@ -1066,6 +1066,9 @@ perly$(O) : perly.c, perly.h, $(h) test : all [.t.lib]vmsfspec.t [.t.lib]vmsish.t - @[.VMS]Test.Com "$(E)" +install : + $(MINIPERL) installperl + archify : all @ Write Sys$Output "Moving files to architecture-specific locations for $(ARCH)" archroot = "$(ARCHAUTO)" - "]" + "...]" @@ -1313,6 +1316,7 @@ tidy : cleanlis - If F$Search("Perlshr_Gbl*.Mar;-1") .nes."" Then Purge/NoConfirm/Log Perlshr_Gbl*.Mar - If F$Search("[.Ext.DynaLoader]DL_VMS$(O);-1").nes."" Then Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS$(O) - If F$Search("[.Ext.DynaLoader]DL_VMS.C;-1").nes."" Then Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS.C + - If F$Search("[.Ext.Socket]Socket.C;-1").nes."" Then Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS.C - If F$Search("[.Ext.Opcode...];-1").nes."" Then Purge/NoConfirm/Log [.Ext.Opcode] - If F$Search("[.VMS.Ext...]*.C;-1").nes."" Then Purge/NoConfirm/Log [.VMS.Ext...]*.C - If F$Search("[.VMS.Ext...]*$(O);-1").nes."" Then Purge/NoConfirm/Log [.VMS.Ext...]*$(O) @@ -1328,6 +1332,7 @@ tidy : cleanlis - If F$Search("[.Lib.Pod]*.Pod;-1").nes."" Then Purge/NoConfirm/Log [.Lib.Pod]*.Pod - If F$Search("$(ARCHCORE)*.*").nes."" Then Purge/NoConfirm/Log $(ARCHCORE)*.* - If F$Search("[.lib]*.com;-1").nes."" Then Purge/NoConfirm/Log [.lib]*.com + - If F$Search("[.pod]*.com;-1").nes."" Then Purge/NoConfirm/Log [.pod]*.com - If F$Search("[.utils]*.com;-1").nes."" Then Purge/NoConfirm/Log [.utils]*.com - If F$Search("[.x2p]*.com;-1").nes."" Then Purge/NoConfirm/Log [.x2p]*.com - If F$Search("[.lib.pod]*.com;-1").nes."" Then Purge/NoConfirm/Log [.lib.pod]*.com @@ -1381,6 +1386,7 @@ clean : tidy - If F$Search("[.Ext.Socket]Socket.C").nes."" Then Delete/NoConfirm/Log [.Ext.Socket]Socket.C;* - If F$Search("[.VMS.Ext...]*.C").nes."" Then Delete/NoConfirm/Log [.VMS.Ext...]*.C;* - If F$Search("[.VMS.Ext...]*$(O)").nes."" Then Delete/NoConfirm/Log [.VMS.Ext...]*$(O);* + - If F$Search("[.pod]*.com").nes."" Then Delete/NoConfirm/Log [.pod]*.com;* realclean : clean Set Default [.ext.Fcntl] diff --git a/vms/ext/Filespec.pm b/vms/ext/Filespec.pm index b0b1414..4a539c2 100644 --- a/vms/ext/Filespec.pm +++ b/vms/ext/Filespec.pm @@ -266,6 +266,7 @@ sub fileify ($) { my($path) = @_; if (!$path) { return undef } + if ($path eq '/') { return 'sys$disk:[000000]'; } if ($path =~ /(.+)\.([^:>\]]*)$/) { $path = $1; if ($2 !~ /^dir(?:;1)?$/i) { return undef } diff --git a/vms/ext/filespec.t b/vms/ext/filespec.t index 0564491..779396b 100644 --- a/vms/ext/filespec.t +++ b/vms/ext/filespec.t @@ -96,6 +96,7 @@ some/where/... vmsify [.some.where...] .. vmsify [-] ../.. vmsify [--] .../ vmsify [...] +/ vmsify sys$disk:[000000] # Fileifying directory specs down:[the.garden.path] fileify down:[the.garden]path.dir;1 @@ -135,6 +136,7 @@ down:[the.garden.path...] unixpath /down/the/garden/path/.../ [.down.the.garden]path.dir unixpath down/the/garden/path/ down/the/garden/path vmspath [.down.the.garden.path] path vmspath [.path] +/ vmspath sys$disk:[000000] # Redundant characters in Unix paths //some/where//over/../the.rainbow vmsify some:[where]the.rainbow diff --git a/vms/test.com b/vms/test.com index affc6a8..f131088 100644 --- a/vms/test.com +++ b/vms/test.com @@ -21,8 +21,17 @@ $ EndIf $ EndIf $ Set Message /Facility/Severity/Identification/Text $ -$ exe = ".Exe" -$ If p1.nes."" Then exe = p1 +$ exe = ".Exe" +$ If p1.nes."" Then exe = p1 +$ If F$Extract(0,1,exe) .nes. "." +$ Then +$ Write Sys$Error "" +$ Write Sys$Error "The first parameter passed to Test.Com must be the file type used for the" +$ Write Sys$Error "images produced when you built Perl (i.e. "".Exe"", unless you edited" +$ Write Sys$Error "Descrip.MMS or used the AXE=1 macro in the MM[SK] command line." +$ Write Sys$Error "" +$ Exit 44 +$ EndIf $! Pick up a copy of perl to use for the tests $ Delete/Log/NoConfirm Perl.;* $ Copy/Log/NoConfirm [-]Perl'exe' []Perl. @@ -103,7 +112,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=('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','misc.t','stat.t'); @exclist=(@compexcl,@ioexcl,@libexcl,@opexcl); foreach $file (@exclist) { $skip{$file}++; } -- 2.7.4