----------------
+Version 5.003_25
+----------------
+
+This release is beta candidate #3. Here's hoping...
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Make $] read-only"
+ From: Chip Salzenberg
+ Files: gv.c
+
+ Title: "New variable C<$^S> is a native version of C<$?>"
+ From: Chip Salzenberg
+ Files: doio.c global.sym gv.c interp.sym lib/English.pm mg.c perl.c
+ perl.h pod/perldelta.pod pod/perlfunc.pod pod/perlvar.pod
+ pp_ctl.c pp_sys.c proto.h util.c
+
+ Title: "Make $^T work with undump, and don't taint it"
+ From: Chip Salzenberg
+ Files: perl.c
+
+ CORE PORTABILITY
+
+ Title: "VMS patches for _24"
+ From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>
+ Msg-ID: <01IEUIFP5038004GQP@hmivax.humgen.upenn.edu>
+ Date: Fri, 31 Jan 1997 02:34:37 -0500 (EST)
+ Files: ext/DynaLoader/DynaLoader.pm ext/DynaLoader/dl_vms.xs
+ lib/AutoSplit.pm lib/ExtUtils/MM_VMS.pm
+ lib/ExtUtils/MakeMaker.pm perl.h pp_hot.c t/lib/filehand.t
+ t/op/closure.t vms/Makefile vms/config.vms vms/descrip.mms
+ vms/ext/filespec.t vms/vms.c vms/vmsish.h
+
+ Title: "hints/dec_osf.sh: polishing the comments"
+ From: Jarkko Hietaniemi <jhi@cc.hut.fi>
+ Msg-ID: <199701301958.VAA08992@alpha.hut.fi>
+ Date: Thu, 30 Jan 1997 21:58:10 +0200 (EET)
+ Files: hints/dec_osf.sh
+
+ Title: "amigaos.sh"
+ From: "Norbert Pueschel" <pueschel@imsdd.meb.uni-bonn.de>
+ Msg-ID: <77724724@Armageddon.meb.uni-bonn.de>
+ Date: Wed, 29 Jan 1997 11:39:49 +0100
+ Files: hints/amigaos.sh
+
+ OTHER CORE CHANGES
+
+ Title: "Require '-T' in argv[], not just on #! line"
+ From: Chip Salzenberg
+ Files: perl.c pod/perldiag.pod
+
+ Title: "Fix C<return @_> and associated stack bugs"
+ From: Chip Salzenberg
+ Files: cop.h pp_ctl.c pp_hot.c t/op/misc.t
+
+ Title: "Fix never-closing handle after C<select>"
+ From: Chip Salzenberg
+ Files: pp_sys.c
+
+ Title: "Fix /\G/g with patterns that match empty string"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Files: pp_hot.c
+
+ Title: "Fix scalar leak in av_unshift"
+ From: Chip Salzenberg
+ Files: av.c
+
+ Title: "Ignore refs to lexicals when making refs to lexicals"
+ From: Chip Salzenberg
+ Files: op.c
+
+ Title: "Don't create AV, HV, IO when assigning glob"
+ From: Chip Salzenberg
+ Files: mg.c
+
+ BUILD PROCESS
+
+ Title: "Configure updates for intsize and ssizetype"
+ From: Andy Dougherty
+ Files: Configure MANIFEST config_H config_h.SH handy.h
+
+ Title: "Ask about /usr/bin/perl iff STDIN and STDERR are terminals"
+ From: Chip Salzenberg
+ Files: installperl
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Refresh CPAN to 1.19"
+ From: Andreas Koenig <a.koenig@mind.de>
+ Files: lib/Bundle/CPAN.pm lib/CPAN.pm lib/CPAN/FirstTime.pm
+
+ Title: "Debugger update"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199702030406.XAA23029@monk.mps.ohio-state.edu>
+ Date: Sun, 2 Feb 1997 23:06:34 -0500 (EST)
+ Files: lib/perl5db.pl
+
+ Title: "In Symbol::gensym, don't make glob fake by copying it"
+ From: John Hughes <john@AtlanTech.COM>
+ Files: lib/Symbol.pm
+
+ Title: "Make POSIX::is*() eight-bit-clean"
+ From: Chip Salzenberg
+ Files: ext/POSIX/POSIX.xs
+
+ Title: "Make IO::Handle::gets() an alias of getline"
+ From: Gisle Aas <aas@bergen.sn.no>
+ Msg-ID: <199701301103.MAA11291@bergen.sn.no>
+ Date: Thu, 30 Jan 1997 12:03:15 +0100
+ Files: ext/IO/lib/IO/Handle.pm lib/IO/Handle.pm
+
+ TESTS
+
+ Title: "More Amiga test patches"
+ From: "Norbert Pueschel" <pueschel@imsdd.meb.uni-bonn.de>
+ Msg-ID: <77724725@Armageddon.meb.uni-bonn.de>
+ Date: Wed, 29 Jan 1997 16:07:33 +0100
+ Files: README.amiga t/lib/safe2.t t/op/closure.t
+
+ UTILITIES
+
+ Title: "c2ph.PL fix"
+ From: lvirden@cas.org (Larry W. Virden)
+ Msg-ID: <199701301349.IAA16724@cas.org>
+ Date: Thu, 30 Jan 1997 08:49:19 -0500
+ Files: utils/c2ph.PL
+
+ Title: "Make pod2man a little laxer for perltoc.pod"
+ From: Chip Salzenberg
+ Files: pod/pod2man.PL
+
+ DOCUMENTATION
+
+ Title: "Update to perl INSTALL file"
+ From: lvirden@cas.org (Larry W. Virden)
+ Msg-ID: <199701301338.IAA15878@cas.org>
+ Date: Thu, 30 Jan 1997 08:38:23 -0500
+ Files: INSTALL
+
+ Title: "Update to perl.pod suggested"
+ From: lvirden@cas.org (Larry W. Virden)
+ Msg-ID: <199701301345.IAA16514@cas.org>
+ Date: Thu, 30 Jan 1997 08:45:59 -0500
+ Files: pod/perl.pod
+
+ Title: "Document how extension pms go in $archlib"
+ From: Chip Salzenberg
+ Files: pod/perldelta.pod
+
+ Title: "perlfunc.pod tweaks"
+ From: Roderick Schertler <roderick@gate.net>
+ Msg-ID: <20526.854659255@eeyore.ibcinc.com>
+ Date: Thu, 30 Jan 1997 16:20:55 -0500
+ Files: pod/perlfunc.pod
+
+ Title: "new (Feb 1) perlembed.pod"
+ From: Jon Orwant <orwant@media.mit.edu>
+ Msg-ID: <9702012334.AA15747@fahrenheit-451.media.mit.edu>
+ Date: Sat, 1 Feb 1997 18:34:59 -0500
+ Files: pod/perlembed.pod
+
+ Title: "Error lines must not have trialing periods"
+ From: Chip Salzenberg
+ Files: pod/perldiag.pod
+
+
+----------------
Version 5.003_24
----------------
These tests will be skipped because they use the fork() function, which is not
supported under AmigaOS.
+=item F<op/magic.t>
+
+The ixemul.library doesn't set the expected values for $0 and $^X.
+
=back
=head2 Installing the built perl
cx->blk_sub.dfoutgv = defoutgv; \
(void)SvREFCNT_inc(cx->blk_sub.dfoutgv)
-/* We muck with cxstack_ix since _dec may call a DESTROY, overwriting cx. */
-
#define POPSUB(cx) \
- if (cx->blk_sub.hasargs) { \
+ { struct block_sub cxsub; \
+ POPSUB1(cx); \
+ POPSUB2(); }
+
+#define POPSUB1(cx) \
+ cxsub = cx->blk_sub; /* because DESTROY may clobber *cx */
+
+#define POPSUB2() \
+ if (cxsub.hasargs) { \
/* put back old @_ */ \
SvREFCNT_dec(GvAV(defgv)); \
- GvAV(defgv) = cx->blk_sub.savearray; \
+ GvAV(defgv) = cxsub.savearray; \
/* destroy arg array */ \
- av_clear(cx->blk_sub.argarray); \
- AvREAL_off(cx->blk_sub.argarray); \
+ av_clear(cxsub.argarray); \
+ AvREAL_off(cxsub.argarray); \
} \
- if (cx->blk_sub.cv) { \
- if (!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) { \
- cxstack_ix++; \
- SvREFCNT_dec((SV*)cx->blk_sub.cv); \
- cxstack_ix--; \
- } \
+ if (cxsub.cv) { \
+ if (!(CvDEPTH(cxsub.cv) = cxsub.olddepth)) \
+ SvREFCNT_dec(cxsub.cv); \
}
#define POPFORMAT(cx) \
cx->blk_loop.iterix = -1;
#define POPLOOP(cx) \
- newsp = stack_base + cx->blk_loop.resetsp; \
- SvREFCNT_dec(cx->blk_loop.iterlval); \
- if (cx->blk_loop.itervar) { \
- SvREFCNT_dec(*cx->blk_loop.itervar); \
- *cx->blk_loop.itervar = cx->blk_loop.itersave; \
+ { struct block_loop cxloop; \
+ POPLOOP1(cx); \
+ POPLOOP2(); }
+
+#define POPLOOP1(cx) \
+ cxloop = cx->blk_loop; /* because DESTROY may clobber *cx */
+
+#define POPLOOP2() \
+ newsp = stack_base + cxloop.resetsp; \
+ SvREFCNT_dec(cxloop.iterlval); \
+ if (cxloop.itervar) { \
+ SvREFCNT_dec(*cxloop.itervar); \
+ *cxloop.itervar = cxloop.itersave; \
} \
- if (cx->blk_loop.iterary && cx->blk_loop.iterary != curstack) \
- SvREFCNT_dec(cx->blk_loop.iterary);
+ if (cxloop.iterary && cxloop.iterary != curstack) \
+ SvREFCNT_dec(cxloop.iterary);
/* context common to subroutines, evals and loops */
struct block {
if (IoTYPE(io) == '|') {
status = my_pclose(IoIFP(io));
retval = (status == 0);
- statusvalue = FIXSTATUS(status);
+ STATUS_NATIVE_SET(status);
}
else if (IoTYPE(io) == '-')
retval = TRUE;
#define my_bzero Perl_my_bzero
#define my_chsize Perl_my_chsize
#define my_exit Perl_my_exit
+#define my_failure_exit Perl_my_failure_exit
#define my_htonl Perl_my_htonl
#define my_lstat Perl_my_lstat
#define my_memcmp Perl_my_memcmp
#define statgv (curinterp->Istatgv)
#define statname (curinterp->Istatname)
#define statusvalue (curinterp->Istatusvalue)
+#define statusvalue_vms (curinterp->Istatusvalue_vms)
#define stdingv (curinterp->Istdingv)
#define strchop (curinterp->Istrchop)
#define strtab (curinterp->Istrtab)
#define Istatgv statgv
#define Istatname statname
#define Istatusvalue statusvalue
+#define Istatusvalue_vms statusvalue_vms
#define Istdingv stdingv
#define Istrchop strchop
#define Istrtab strtab
#define statgv Perl_statgv
#define statname Perl_statname
#define statusvalue Perl_statusvalue
+#define statusvalue_vms Perl_statusvalue_vms
#define stdingv Perl_stdingv
#define strchop Perl_strchop
#define strtab Perl_strtab
# Flags to alter dl_load_file behaviour. Assigned bits:
# 0x01 make symbols available for linking later dl_load_file's.
# (only known to work on Solaris 2 using dlopen(RTLD_GLOBAL))
+# (ignored under VMS; effect is built-in to image linking)
#
# This is called as a class method $module->dl_load_flags. The
# definition here will be inherited and result on "default" loading
0x01 make symbols available for linking later dl_load_file's.
(only known to work on Solaris 2 using dlopen(RTLD_GLOBAL))
+ (ignored under VMS; this is a normal part of image linking)
(On systems that provide a handle for the loaded object such as SunOS
and HPUX, $libref will be that handle. On other systems $libref will
}
void
-dl_load_file(filename, flags)
- char * filename
+dl_load_file(filespec, flags)
+ char * filespec
int flags
PREINIT:
char vmsspec[NAM$C_MAXRSS];
void (*entry)();
CODE:
- DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags));
- if (flags & 0x01)
- warn("Can't make loaded symbols global on this platform while loading %s",filename);
+ DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filespec,flags));
specdsc.dsc$a_pointer = tovmsspec(filespec,vmsspec);
specdsc.dsc$w_length = strlen(specdsc.dsc$a_pointer);
DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tVMS-ified filespec is %s\n",
close
fileno
getc
- gets
eof
read
truncate
require Exporter;
@ISA = qw(Exporter);
-$VERSION = "1.1501";
+$VERSION = "1.1502";
$XS_VERSION = "1.15";
@EXPORT_OK = qw(
getc($_[0]);
}
-sub gets {
- @_ == 1 or croak 'usage: $fh->gets()';
- my ($handle) = @_;
- scalar <$handle>;
-}
-
sub eof {
@_ == 1 or croak 'usage: $fh->eof()';
eof($_[0]);
return scalar <$this>;
}
+*gets = \&getline; # deprecated
+
sub getlines {
@_ == 1 or croak 'usage: $fh->getline()';
wantarray or
my_bzero
my_chsize
my_exit
+my_failure_exit
my_htonl
my_lstat
my_memcmp
case '\017':
case '\t':
case '\020':
+ case '\023':
case '\024':
case '\027':
if (len > 1)
break;
case ']':
if (len == 1) {
- SV *sv;
- sv = GvSV(gv);
+ SV *sv = GvSV(gv);
sv_upgrade(sv, SVt_PVNV);
sv_setpv(sv, patchlevel);
+ (void)sv_2nv(sv);
+ SvREADONLY_on(sv);
}
break;
}
statgv
statname
statusvalue
+statusvalue_vms
stdingv
strchop
strtab
# where to write output files
$autodir = "lib/auto" unless $autodir;
- ($autodir = VMS::Filespec::unixpath($autodir)) =~ s#/$## if $Is_VMS;
+ if ($Is_VMS) {
+ ($autodir = VMS::Filespec::unixpath($autodir)) =~ s{/$}{};
+ $filename = VMS::Filespec::unixify($filename); # may have dirs
+ }
unless (-d $autodir){
local($", @p)="/";
foreach(split(/\//,$autodir)){
*FORMAT_LINE_BREAK_CHARACTERS
*FORMAT_FORMFEED
*CHILD_ERROR
+ *SYSTEM_CHILD_STATUS
*OS_ERROR
*ERRNO
*EXTENDED_OS_ERROR
# Error status.
*CHILD_ERROR = *? ;
+ *SYSTEM_CHILD_STATUS = *^S ;
*OS_ERROR = *! ;
- *EXTENDED_OS_ERROR = *^E ;
*ERRNO = *! ;
+ *EXTENDED_OS_ERROR = *^E ;
*EVAL_ERROR = *@ ;
# Process info.
-# $Id: Embed.pm,v 1.21 1996/11/29 17:26:23 dougm Exp $
+# $Id: Embed.pm,v 1.22 1997/01/30 00:37:09 dougm Exp $
require 5.002;
package ExtUtils::Embed;
);
use strict;
-$VERSION = sprintf("%d.%02d", q$Revision: 1.21 $ =~ /(\d+)\.(\d+)/);
+$VERSION = sprintf("%d.%02d", q$Revision: 1.22 $ =~ /(\d+)\.(\d+)/);
#for the namespace change
$Devel::embed::VERSION = "99.99";
my $ld_or_bs = $bsloadlibs || $ldloadlibs;
print STDERR "bs: $bsloadlibs ** ld: $ldloadlibs" if $Verbose;
- my $linkage = "$Config{ldflags} @archives $ld_or_bs";
+ my $linkage = "$Config{ccdlflags} $Config{ldflags} @archives $ld_or_bs";
print STDERR "ldopts: '$linkage'\n" if $Verbose;
return $linkage if scalar @_;
sub ccopts {
ccflags;
- ccdlflags;
perl_inc;
}
my(@defs) = split(/\s+/,$self->{DEFINE});
foreach $def (@defs) {
next unless $def;
- $def =~ s/^-D//;
- $def = "\"$def\"" if $def =~ /=/;
+ if ($def =~ s/^-D//) { # If it was a Unix-style definition
+ $def =~ /='(.*)'$/=$1/; # then remove shell-protection ''
+ $def =~ /^'(.*)'$/$1/; # from entire term or argument
+ }
+ if ($def =~ /=/) {
+ $def =~ s/"/""/g; # Protect existing " from DCL
+ $def = qq["$def"]; # and quote to prevent parsing of =
+ }
}
$self->{DEFINE} = join ',',@defs;
}
}
push @m,"
+.SUFFIXES :
.SUFFIXES : \$(OBJ_EXT) .c .cpp .cxx .xs
# Here is the Config.pm that we are using/depend on
';
foreach $dir (@{$self->{DIR}}) { # clean subdirectories first
my($vmsdir) = $self->fixpath($dir,1);
- push( @m, ' If F$Search("'.$vmsdir.'$(MAKEFILE)") Then \\',"\n\t",
+ push( @m, ' If F$Search("'.$vmsdir.'$(MAKEFILE)").nes."" Then \\',"\n\t",
'$(PERL) -e "chdir ',"'$vmsdir'",'; print `$(MMS) clean`;"',"\n");
}
push @m, ' $(RM_F) *.Map *.Dmp *.Lis *.cpp *.$(DLEXT) *$(OBJ_EXT) *$(LIB_EXT) *.Opt $(BOOTSTRAP) $(BASEEXT).bso .MM_Tmp
# into a filespec.
$self->{$key} = $self->catdir("..",$self->{$key})
unless $self->file_name_is_absolute($self->{$key})
- || ($^O eq 'VMS' and ($key =~ /PERL$/ && $self->{key} =~ /^[\w\-\$]$/));
+ || ($^O eq 'VMS' and ($key =~ /PERL$/ && $self->{$key} =~ /^[\w\-\$]+$/));
}
$self->{PARENT}->{CHILDREN}->{$newclass} = $self if $self->{PARENT};
} else {
}
$pos = $fh->getpos;
- $fh->setpos $pos;
+ $fh->setpos($pos);
$fh->setvbuf($buffer_var, _IOLBF, 1024);
case '\020': /* ^P */
sv_setiv(sv, (IV)perldb);
break;
+ case '\023': /* ^S */
+ if (STATUS_NATIVE == -1)
+ sv_setiv(sv, (IV)-1);
+ else
+ sv_setuv(sv, (UV)STATUS_NATIVE);
+ break;
case '\024': /* ^T */
#ifdef BIG_TIME
sv_setnv(sv, basetime);
#endif
break;
case '?':
- sv_setiv(sv, (IV)statusvalue);
+ if (STATUS_POSIX == -1)
+ sv_setiv(sv, (IV)-1);
+ else
+ sv_setuv(sv, (UV)STATUS_POSIX);
break;
case '^':
s = IoTOP_NAME(GvIOp(defoutgv));
if (GvGP(sv))
gp_free((GV*)sv);
GvGP(sv) = gp_ref(GvGP(gv));
- if (!GvAV(gv))
- gv_AVadd(gv);
- if (!GvHV(gv))
- gv_HVadd(gv);
- if (!GvIOp(gv))
- GvIOp(gv) = newIO();
return 0;
}
#ifdef VMS
set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
#else
- SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv),4); /* will anyone ever use this? */
+ /* will anyone ever use this? */
+ SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
#endif
break;
case '\006': /* ^F */
}
perldb = i;
break;
+ case '\023': /* ^S */
+ STATUS_NATIVE_SET(SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv));
+ break;
case '\024': /* ^T */
#ifdef BIG_TIME
basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
break;
case '?':
- statusvalue = FIXSTATUS(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+ STATUS_POSIX_SET(SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv));
break;
case '!':
- SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv),SvIV(sv) == EVMSERR ? 4 : vaxc$errno); /* will anyone ever use this? */
+ SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv),
+ (SvIV(sv) == EVMSERR) ? 4 : vaxc$errno);
break;
case '<':
uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
#define PATCHLEVEL 3
-#define SUBVERSION 24
+#define SUBVERSION 25
/*
local_patches -- list of locally applied less-than-subversion patches.
static void init_postdump_symbols _((int, char **, char **));
static void init_predump_symbols _((void));
static void init_stacks _((void));
+static void my_exit_jump _((void)) __attribute__((noreturn));
static void nuke_stacks _((void));
static void open_script _((char *, bool, SV *));
static void usage _((char *));
init_ids();
+ STATUS_ALL_SUCCESS;
+
SET_NUMERIC_STANDARD();
#if defined(SUBVERSION) && SUBVERSION > 0
sprintf(patchlevel, "%7.5f", (double) 5
op_free(main_root);
main_root = 0;
+ time(&basetime);
+
switch (Sigsetjmp(top_env,1)) {
case 1:
-#ifdef VMS
- statusvalue = 255;
-#else
- statusvalue = 1;
-#endif
+ STATUS_ALL_FAILURE;
+ /* FALL THROUGH */
case 2:
+ /* my_exit() was called */
curstash = defstash;
if (endav)
calllist(endav);
- return(statusvalue); /* my_exit() was called */
+ return STATUS_NATIVE_EXPORT;
case 3:
PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
return 1;
case 'n':
case 'p':
case 's':
- case 'T':
case 'u':
case 'U':
case 'v':
goto reswitch;
break;
+ case 'T':
+ tainting = TRUE;
+ s++;
+ goto reswitch;
+
case 'e':
if (euid != uid || egid != gid)
croak("No -e allowed in setuid scripts");
cxstack_ix = -1; /* start context stack again */
break;
case 2:
+ /* my_exit() was called */
curstash = defstash;
if (endav)
calllist(endav);
if (getenv("PERL_DEBUG_MSTATS"))
dump_mstats("after execution: ");
#endif
- return(statusvalue); /* my_exit() was called */
+ return STATUS_NATIVE_EXPORT;
case 3:
if (!restartop) {
PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
return 0;
}
-void
-my_exit(status)
-U32 status;
-{
- register CONTEXT *cx;
- I32 gimme;
- SV **newsp;
-
- statusvalue = FIXSTATUS(status);
- if (cxstack_ix >= 0) {
- if (cxstack_ix > 0)
- dounwind(0);
- POPBLOCK(cx,curpm);
- LEAVE;
- }
- Siglongjmp(top_env, 2);
-}
-
SV*
perl_get_sv(name, create)
char* name;
case 0:
break;
case 1:
-#ifdef VMS
- statusvalue = 255; /* XXX I don't think we use 1 anymore. */
-#else
- statusvalue = 1;
-#endif
+ STATUS_ALL_FAILURE;
/* FALL THROUGH */
case 2:
/* my_exit() was called */
Copy(oldtop, top_env, 1, Sigjmp_buf);
if (statusvalue)
croak("Callback called exit");
- my_exit(statusvalue);
+ my_exit_jump();
/* NOTREACHED */
case 3:
if (restartop) {
case 0:
break;
case 1:
-#ifdef VMS
- statusvalue = 255; /* XXX I don't think we use 1 anymore. */
-#else
- statusvalue = 1;
-#endif
+ STATUS_ALL_FAILURE;
/* FALL THROUGH */
case 2:
/* my_exit() was called */
Copy(oldtop, top_env, 1, Sigjmp_buf);
if (statusvalue)
croak("Callback called exit");
- my_exit(statusvalue);
+ my_exit_jump();
/* NOTREACHED */
case 3:
if (restartop) {
s++;
return s;
case 'T':
- tainting = TRUE;
+ if (!tainting)
+ croak("Too late for \"-T\" option (try putting it first)");
s++;
return s;
case 'u':
sv_setpv(GvSV(tmpgv),origfilename);
magicname("0", "0", 1);
}
- if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
- time(&basetime);
if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
sv_setpv(GvSV(tmpgv),origargv[0]);
if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
}
break;
case 1:
-#ifdef VMS
- statusvalue = 255; /* XXX I don't think we use 1 anymore. */
-#else
- statusvalue = 1;
-#endif
+ STATUS_ALL_FAILURE;
/* FALL THROUGH */
case 2:
/* my_exit() was called */
else
croak("END failed--cleanup aborted");
}
- my_exit(statusvalue);
+ my_exit_jump();
/* NOTREACHED */
- return;
case 3:
if (!restartop) {
PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
Copy(oldtop, top_env, 1, Sigjmp_buf);
}
+void
+my_exit(status)
+U32 status;
+{
+ switch (status) {
+ case 0:
+ STATUS_ALL_SUCCESS;
+ break;
+ case 1:
+ STATUS_ALL_FAILURE;
+ break;
+ default:
+ STATUS_NATIVE_SET(status);
+ break;
+ }
+ my_exit_jump();
+}
+
+void
+my_failure_exit()
+{
+#ifdef VMS
+ if (vaxc$errno & 1) {
+ if (GETSTATUS_NATIVE & 1) /* fortuitiously includes "-1" */
+ SETSTATUS_NATIVE(44);
+ }
+ else {
+ if (!vaxc$errno && errno) /* someone must have set $^E = 0 */
+ SETSTATUS_NATIVE(44);
+ else
+ SETSTATUS_NATIVE(vaxc$errno);
+ }
+#else
+ if (errno & 255)
+ STATUS_POSIX_SET(errno);
+ else if (STATUS_POSIX == 0)
+ STATUS_POSIX_SET(255);
+#endif
+ my_exit_jump();
+}
+
+static void
+my_exit_jump()
+{
+ register CONTEXT *cx;
+ I32 gimme;
+ SV **newsp;
+
+ if (e_tmpname) {
+ if (e_fp) {
+ PerlIO_close(e_fp);
+ e_fp = Nullfp;
+ }
+ (void)UNLINK(e_tmpname);
+ Safefree(e_tmpname);
+ e_tmpname = Nullch;
+ }
+
+ if (cxstack_ix >= 0) {
+ if (cxstack_ix > 0)
+ dounwind(0);
+ POPBLOCK(cx,curpm);
+ LEAVE;
+ }
+ Siglongjmp(top_env, 2);
+}
# include <net/errno.h>
# endif
#endif
-#ifndef VMS
-# define FIXSTATUS(sts) (U_L((sts) & 0xffff))
-# define SHIFTSTATUS(sts) ((sts) >> 8)
-# define SETERRNO(errcode,vmserrcode) errno = (errcode)
+
+#ifdef VMS
+# define SETERRNO(errcode,vmserrcode) \
+ STMT_START { \
+ set_errno(errcode); \
+ set_vaxc_errno(vmserrcode); \
+ } STMT_END
#else
-# define FIXSTATUS(sts) (U_L(sts))
-# define SHIFTSTATUS(sts) (sts)
-# define SETERRNO(errcode,vmserrcode) STMT_START {set_errno(errcode); set_vaxc_errno(vmserrcode);} STMT_END
+# define SETERRNO(errcode,vmserrcode) errno = (errcode)
#endif
#ifndef errno
# endif
#endif
+#define STATUS_POSIX statusvalue
+#define STATUS_POSIX_SET(n) (statusvalue = (n))
+
+#ifdef VMS
+# define STATUS_NATIVE statusvalue_vms
+# define STATUS_NATIVE_EXPORT \
+ ((I32)statusvalue_vms == -1 ? 4 : statusvalue_vms)
+# define STATUS_NATIVE_SET(n) \
+ STMT_START { \
+ statusvalue_vms = (n); \
+ if ((I32)statusvalue_vms == -1) \
+ statusvalue = -1; \
+ else if (statusvalue_vms & STS$M_SUCCESS) \
+ statusvalue = 0; \
+ else if ((statusvalue_vms & STS$M_SEVERITY) == 0) \
+ statusvalue = 1 << 8; \
+ else \
+ statusvalue = (statusvalue_vms & STS$M_SEVERITY) << 8; \
+ } STMT_END
+# define STATUS_ALL_SUCCESS (statusvalue = 0, statusvalue_vms = 1)
+# define STATUS_ALL_FAILURE (statusvalue = 1, statusvalue_vms = 4)
+#else
+# define STATUS_NATIVE STATUS_POSIX
+# define STATUS_NATIVE_EXPORT STATUS_POSIX
+# define STATUS_NATIVE_SET STATUS_POSIX_SET
+# define STATUS_ALL_SUCCESS STATUS_POSIX_SET(0)
+# define STATUS_ALL_FAILURE STATUS_POSIX_SET(1)
+#endif
+
#ifdef I_SYS_IOCTL
# ifndef _IOCTL_
# include <sys/ioctl.h>
# define SLOPPYDIVIDE
#endif
-#if defined(cray) || defined(convex) || BYTEORDER > 0xffff
-# define HAS_QUAD
-#endif
-
#ifdef UV
#undef UV
#endif
--Andy Dougherty August 1996
*/
-#ifdef HAS_QUAD
-# ifdef cray
-# define Quad_t int
+#ifdef cray
+# define Quad_t int
+#else
+# ifdef convex
+# define Quad_t long long
# else
-# if defined(convex)
-# define Quad_t long long
+# if defined(VMS) && defined(__ALPHA)
+# define Quad_t __int64
# else
-# define Quad_t long
+# if BYTEORDER > 0xFFFF
+# define Quad_t long
+# endif
# endif
# endif
+#endif
+
+#ifdef Quad_t
+# define HAS_QUAD
typedef Quad_t IV;
typedef unsigned Quad_t UV;
# define IV_MAX PERL_QUAD_MAX
IEXT STRLEN Iorslen;
IEXT char * Iofmt; /* $# */
IEXT I32 Imaxsysfd IINIT(MAXSYSFD); /* top fd to pass to subprocesses */
-IEXT int Imultiline; /* $*--do strings hold >1 line? */
-IEXT U32 Istatusvalue; /* $? */
+IEXT int Imultiline; /* $*--do strings hold >1 line? */
+IEXT U32 Istatusvalue; /* $? */
+#ifdef VMS
+IEXT U32 Istatusvalue_vms; /* $^S */
+#endif
IEXT struct stat Istatcache; /* _ */
IEXT GV * Istatgv;
=item $^E
-Extended error message under some platforms ($EXTENDED_OS_ERROR
-if you C<use English>).
+Extended error message on some platforms. (Also known as
+$EXTENDED_OS_ERROR if you C<use English>).
=item $^H
As a disincentive to casual use of this advanced feature,
there is no C<use English> long name for this variable.
+=item $^S
+
+The status returned by the last pipe close, back-tick (C<``>) command, or
+system() operator, in the native system format. On UNIX and UNIX-like
+systems, C<$^S> is a synonym for C<$?>. Elsewhere, C<$^S> can be used to
+determine aspects of child status that are system-specific. Check C<$^O>
+before using this variable. (Mnemonic: System-Specific Subprocess Status.
+Also known as $SYSTEM_CHILD_STATUS if you C<use English>.)
+
=back
=head2 New and Changed Built-in Functions
=head1 Modules
+=head2 Installation Directories
+
+The I<installperl> script now places the Perl source files for
+extensions in the architecture-specific library directory, which is
+where the shared libraries for extensions have always been. This
+change is intended to allow administrators to keep the Perl 5.004
+library directory unchanged from a previous version, without running
+the risk of binary incompatibility between extensions' Perl source and
+shared libraries.
+
=head2 Fcntl
New constants in the existing Fcntl modules are now supported,
it gives you this warning. Usually it indicates that an operator or
delimiter was omitted, such as a semicolon.
-=item %s had compilation errors.
+=item %s had compilation errors
(F) The final summary message when a C<perl -c> fails.
-=item %s has too many errors.
+=item %s has too many errors
(F) The parser has given up trying to parse the program after 10 errors.
Further error messages would likely be uninformative.
(F) The final summary message when a C<perl -c> succeeds.
-=item %s: Command not found.
+=item %s: Command not found
(A) You've accidentally run your script through B<csh> instead
of Perl. Check the E<lt>#!E<gt> line, or manually feed your script
into Perl yourself.
-=item %s: Expression syntax.
+=item %s: Expression syntax
(A) You've accidentally run your script through B<csh> instead
of Perl. Check the E<lt>#!E<gt> line, or manually feed your script
into Perl yourself.
-=item %s: Undefined variable.
+=item %s: Undefined variable
(A) You've accidentally run your script through B<csh> instead
of Perl. Check the E<lt>#!E<gt> line, or manually feed your script
(F) The setuid emulator requires that the arguments Perl was invoked
with match the arguments specified on the #! line.
-=item Argument "%s" isn't numeric
+=item Argument "%s" isn't numeric%s
(W) The indicated string was fed as an argument to an operator that
expected a numeric value instead. If you're fortunate the message
passed an invalid file specification to Perl, or you've found a
case the conversion routines don't handle. Drat.
-=item Execution of %s aborted due to compilation errors.
+=item Execution of %s aborted due to compilation errors
(F) The final summary message when a Perl compilation fails.
(W) You tried to do a shutdown on a closed socket. Seems a bit superfluous.
-=item SIG%s handler "%s" not defined.
+=item SIG%s handler "%s" not defined
(W) The signal handler named in %SIG doesn't, in fact, exist. Perhaps you
put it into the wrong package?
That is, the absolute value of the offset was larger than the length of
the string. See L<perlfunc/substr>.
-=item suidperl is no longer needed since...
+=item suidperl is no longer needed since %s
(F) Your Perl was compiled with B<-D>SETUID_SCRIPTS_ARE_SECURE_NOW, but a
version of the setuid emulator somehow got run anyway.
The function indicated isn't implemented on this architecture, according
to the probings of Configure.
-=item The crypt() function is unimplemented due to excessive paranoia.
+=item The crypt() function is unimplemented due to excessive paranoia
(F) Configure couldn't find the crypt() function on your machine,
probably because your vendor didn't supply it, probably because they
(F) There has to be at least one argument to syscall() to specify the
system call to call, silly dilly.
+=item Too late for "-T" option (try putting it first)
+
+(X) The #! line in a Perl script contains the "-T" option, but Perl
+was not invoked with "-T" in its argument list. Due to the way Perl
+handles tainting, by the time Perl discovers a "-T" in a script, it's
+too late to properly taint everything from the environment. So Perl
+gives up.
+
+This error can usually be fixed by editing the "#!" line so that the
+"-T" option is in the Perl program's first argument. (Many operating
+systems that implement the "#!" feature only pick up one argument from
+it, so Perl has to get the rest on its own.)
+
=item Too many ('s
=item Too many )'s
they are automatically re-bound to the current values of such
variables.
-=item Variable syntax.
+=item Variable syntax
(A) You've accidentally run your script through B<csh> instead
of Perl. Check the E<lt>#!E<gt> line, or manually feed your script
(W) You passed warn() an empty string (the equivalent of C<warn "">) or
you called it with no args and C<$_> was empty.
-=item Warning: unable to close filehandle %s properly.
+=item Warning: unable to close filehandle %s properly
(S) The implicit close() done by an open() got an error indication on the
close(). This usually indicates your file system ran out of disk space.
dbmclose, dbmopen
-
=back
=head2 Alphabetical Listing of Perl Functions
-
=over 8
=item -X FILEHANDLE
$ans = <STDIN>;
exit 0 if $ans =~ /^[Xx]/;
-See also die(). If EXPR is omitted, exits with 0 status.
+See also die(). If EXPR is omitted, exits with 0 status. The only
+univerally portable values for EXPR are 0 for success and 1 for error;
+all other values are subject to unpredictable interpretation depending
+on the environment in which the Perl program is running.
You shouldn't use exit() to abort a subroutine if there's any chance that
someone might want to trap whatever error happened. Use die() instead,
}
print "\n";
-Determination of whether to whether $BSD_STYLE should be set
+Determination of whether $BSD_STYLE should be set
is left as an exercise to the reader.
The POSIX::getattr() function can do this more portably on systems
Returns the current login from F</etc/utmp>, if any. If null, use
getpwuid().
- $login = getlogin || (getpwuid($<))[0] || "Kilroy";
+ $login = getlogin || getpwuid($<) || "Kilroy";
Do not consider getlogin() for authentication: it is not as
secure as getpwuid().
a^b == (a+1)^(b+1)
one-third of the time. So don't do that.
-
+
=item stat FILEHANDLE
=item stat EXPR
print "signal $rc\n"
}
$ok = ($rc != 0);
-
+
=item syswrite FILEHANDLE,SCALAR,LENGTH,OFFSET
=item syswrite FILEHANDLE,SCALAR,LENGTH
=item New and Changed Built-in Variables
-$^E, $^H, $^M
+$^E, $^H, $^M, $^S
=item New and Changed Built-in Functions
=over
+=item Installation Directories
+
=item Fcntl
=item Module Information Summary
sort LIST, splice ARRAY,OFFSET,LENGTH,LIST, splice ARRAY,OFFSET,LENGTH,
splice ARRAY,OFFSET, split /PATTERN/,EXPR,LIMIT, split /PATTERN/,EXPR,
split /PATTERN/, split, sprintf FORMAT, LIST, sqrt EXPR, sqrt, srand EXPR,
-stat EXPR, stat, study SCALAR, study, sub BLOCK, sub NAME, sub NAME BLOCK,
-substr EXPR,OFFSET,LEN, substr EXPR,OFFSET, symlink OLDFILE,NEWFILE,
-syscall LIST, sysopen FILEHANDLE,FILENAME,MODE, sysopen
+stat FILEHANDLE, stat EXPR, stat, study SCALAR, study, sub BLOCK, sub NAME,
+sub NAME BLOCK, substr EXPR,OFFSET,LEN, substr EXPR,OFFSET, symlink
+OLDFILE,NEWFILE, syscall LIST, sysopen FILEHANDLE,FILENAME,MODE, sysopen
FILEHANDLE,FILENAME,MODE,PERMS, sysread FILEHANDLE,SCALAR,LENGTH,OFFSET,
sysread FILEHANDLE,SCALAR,LENGTH, system LIST, syswrite
-FILEHANDLE,SCALAR,LENGTH, tell FILEHANDLE, tell, telldir DIRHANDLE, tie
-VARIABLE,CLASSNAME,LIST, tied VARIABLE, time, times, tr///, truncate
-FILEHANDLE,LENGTH, truncate EXPR,LENGTH, uc EXPR, uc, ucfirst EXPR,
-ucfirst, umask EXPR, umask, undef EXPR, undef, unlink LIST, unlink, unpack
-TEMPLATE,EXPR, untie VARIABLE, unshift ARRAY,LIST, use Module LIST, use
-Module, use Module VERSION LIST, use VERSION, utime LIST, values
-ASSOC_ARRAY, vec EXPR,OFFSET,BITS, wait, waitpid PID,FLAGS, wantarray, warn
-LIST, write FILEHANDLE, write EXPR, write, y///
+FILEHANDLE,SCALAR,LENGTH,OFFSET, syswrite FILEHANDLE,SCALAR,LENGTH, tell
+FILEHANDLE, tell, telldir DIRHANDLE, tie VARIABLE,CLASSNAME,LIST, tied
+VARIABLE, time, times, tr///, truncate FILEHANDLE,LENGTH, truncate
+EXPR,LENGTH, uc EXPR, uc, ucfirst EXPR, ucfirst, umask EXPR, umask, undef
+EXPR, undef, unlink LIST, unlink, unpack TEMPLATE,EXPR, untie VARIABLE,
+unshift ARRAY,LIST, use Module LIST, use Module, use Module VERSION LIST,
+use VERSION, utime LIST, values ASSOC_ARRAY, vec EXPR,OFFSET,BITS, wait,
+waitpid PID,FLAGS, wantarray, warn LIST, write FILEHANDLE, write EXPR,
+write, y///
=back
EXPR, $FORMAT_NAME, $~, format_top_name HANDLE EXPR, $FORMAT_TOP_NAME, $^,
format_line_break_characters HANDLE EXPR, $FORMAT_LINE_BREAK_CHARACTERS,
$:, format_formfeed HANDLE EXPR, $FORMAT_FORMFEED, $^L, $ACCUMULATOR, $^A,
-$CHILD_ERROR, $?, $OS_ERROR, $ERRNO, $!, $EXTENDED_OS_ERROR, $^E,
-$EVAL_ERROR, $@, $PROCESS_ID, $PID, $$, $REAL_USER_ID, $UID, $<,
-$EFFECTIVE_USER_ID, $EUID, $>, $REAL_GROUP_ID, $GID, $(,
-$EFFECTIVE_GROUP_ID, $EGID, $), $PROGRAM_NAME, $0, $[, $PERL_VERSION, $],
-$DEBUGGING, $^D, $SYSTEM_FD_MAX, $^F, $^H, $INPLACE_EDIT, $^I, $OSNAME,
-$^O, $PERLDB, $^P, $BASETIME, $^T, $WARNING, $^W, $EXECUTABLE_NAME, $^X,
-$ARGV, @ARGV, @INC, %INC, $ENV{expr}, $SIG{expr}
+$CHILD_ERROR, $?, $SYSTEM_CHILD_STATUS, $^S, $OS_ERROR, $ERRNO, $!,
+$EXTENDED_OS_ERROR, $^E, $EVAL_ERROR, $@, $PROCESS_ID, $PID, $$,
+$REAL_USER_ID, $UID, $<, $EFFECTIVE_USER_ID, $EUID, $>, $REAL_GROUP_ID,
+$GID, $(, $EFFECTIVE_GROUP_ID, $EGID, $), $PROGRAM_NAME, $0, $[,
+$PERL_VERSION, $], $DEBUGGING, $^D, $SYSTEM_FD_MAX, $^F, $^H,
+$INPLACE_EDIT, $^I, $OSNAME, $^O, $PERLDB, $^P, $BASETIME, $^T, $WARNING,
+$^W, $EXECUTABLE_NAME, $^X, $ARGV, @ARGV, @INC, %INC, $ENV{expr},
+$SIG{expr}
=back
=item AUTHOR
+=item COPYRIGHT
+
=head2 perlapio - perl's IO abstraction interface.
=item SYNOPSIS
=item DESCRIPTION
-=head2 ops - Perl pragma to restrict unsafe operations when compiling
-
-=item SYNOPSIS
-
-=item DESCRIPTION
-
-=item SEE ALSO
-
=head2 overload - Package for overloading perl operations
=item SYNOPSIS
=item MODIFICATION HISTORY
+=head2 Bundle::CPAN - A bundle to play with all the other modules on CPAN
+
+=item SYNOPSIS
+
+=item CONTENTS
+
+=item DESCRIPTION
+
+=item AUTHOR
+
=head2 CPAN - query, download and build perl modules from CPAN sites
=item SYNOPSIS
=item AUTHOR
-=head2 ExtUtils::Miniperl, writemain - write the C code for perlmain.c
-
-=item SYNOPSIS
-
-=item DESCRIPTION
-
-=item SEE ALSO
-
=head2 ExtUtils::Mkbootstrap - make a bootstrap file for use by DynaLoader
=item SYNOPSIS
=item DESCRIPTION
-=head2 IO::File - supply object methods for filehandles
-
-=item SYNOPSIS
-
-=item DESCRIPTION
-
-=item CONSTRUCTOR
-
-new ([ ARGS ] )
-
-=item METHODS
-
-open( FILENAME [,MODE [,PERMS]] )
-
-=item SEE ALSO
-
-=item HISTORY
-
-=head2 IO::Handle - supply object methods for I/O handles
-
-=item SYNOPSIS
-
-=item DESCRIPTION
-
-=item CONSTRUCTOR
-
-new (), new_from_fd ( FD, MODE )
-
-=item METHODS
-
-$fh->getline, $fh->getlines, $fh->fdopen ( FD, MODE ), $fh->write ( BUF,
-LEN [, OFFSET }\] ), $fh->opened, $fh->untaint
-
-=item NOTE
-
-=item SEE ALSO
-
-=item BUGS
-
-=item HISTORY
-
-=head2 IO::Pipe, IO::pipe - supply object methods for pipes
-
-=item SYNOPSIS
-
-=item DESCRIPTION
-
-=item CONSTRCUTOR
-
-new ( [READER, WRITER] )
-
-=item METHODS
-
-reader ([ARGS]), writer ([ARGS]), handles ()
-
-=item SEE ALSO
-
-=item AUTHOR
-
-=item COPYRIGHT
-
-=head2 IO::Seekable - supply seek based methods for I/O objects
-
-=item SYNOPSIS
-
-=item DESCRIPTION
-
-=item SEE ALSO
-
-=item HISTORY
-
-=head2 IO::Select - OO interface to the select system call
-
-=item SYNOPSIS
-
-=item DESCRIPTION
-
-=item CONSTRUCTOR
-
-new ( [ HANDLES ] )
-
-=item METHODS
-
-add ( HANDLES ), remove ( HANDLES ), exists ( HANDLE ), handles, can_read (
-[ TIMEOUT ] ), can_write ( [ TIMEOUT ] ), has_error ( [ TIMEOUT ] ), count
-(), bits(), bits(), select ( READ, WRITE, ERROR [, TIMEOUT ] )
-
-=item EXAMPLE
-
-=item AUTHOR
-
-=item COPYRIGHT
-
-=head2 IO::Socket - Object interface to socket communications
-
-=item SYNOPSIS
-
-=item DESCRIPTION
-
-=item CONSTRUCTOR
-
-new ( [ARGS] )
-
-=item METHODS
-
-accept([PKG]), timeout([VAL]), sockopt(OPT [, VAL]), sockdomain, socktype,
-protocol
-
-=item SUB-CLASSES
-
-=over
-
-=item IO::Socket::INET
-
-=item METHODS
-
-sockaddr (), sockport (), sockhost (), peeraddr (), peerport (), peerhost
-()
-
-=item IO::Socket::UNIX
-
-=item METHODS
-
-hostpath(), peerpath()
-
-=back
-
-=item SEE ALSO
-
-=item AUTHOR
-
-=item COPYRIGHT
-
=head2 IO::lib::IO::File, IO::File - supply object methods for filehandles
=item SYNOPSIS
=item DESCRIPTION
-=head2 Safe - Compile and execute code in restricted compartments
-
-=item SYNOPSIS
-
-=item DESCRIPTION
-
-a new namespace, an operator mask
-
-=item WARNING
-
-=over
-
-=item RECENT CHANGES
-
-=item Methods in class Safe
-
-permit (OP, ...), permit_only (OP, ...), deny (OP, ...), deny_only (OP,
-...), trap (OP, ...), untrap (OP, ...), share (NAME, ...), share_from
-(PACKAGE, ARRAYREF), varglob (VARNAME), reval (STRING), rdo (FILENAME),
-root (NAMESPACE), mask (MASK)
-
-=item Some Safety Issues
-
-Memory, CPU, Snooping, Signals, State Changes
-
-=item AUTHOR
-
-=back
-
=head2 Search::Dict, look - search for key in dictionary file
=item SYNOPSIS
=item $?
The status returned by the last pipe close, back-tick (C<``>) command,
-or system() operator. Note that this is the status word returned by
-the wait() system call, so the exit value of the subprocess is actually
-(C<$? E<gt>E<gt> 8>). Thus on many systems, C<$? & 255> gives which signal,
-if any, the process died from, and whether there was a core dump.
-(Mnemonic: similar to B<sh> and B<ksh>.)
+or system() operator. Note that this is the status word returned by the
+wait() system call (or else is made up to look like it -- see L<$^S>).
+Thus, the exit value of the subprocess is actually (C<$? E<gt>E<gt> 8>),
+and C<$? & 255> gives which signal, if any, the process died from, and
+whether there was a core dump. (Mnemonic: similar to B<sh> and B<ksh>.)
Inside an C<END> subroutine C<$?> contains the value that is going to be
given to C<exit()>. You can modify C<$?> in an C<END> subroutine to
change the exit status of the script.
+=item $SYSTEM_CHILD_STATUS
+
+=item $^S
+
+The status returned by the last pipe close, back-tick (C<``>) command, or
+system() operator, in the native system format. On UNIX and UNIX-like
+systems, C<$^S> is a synonym for C<$?>. Elsewhere, C<$^S> can be used to
+determine aspects of child status that are system-specific. Check C<$^O>
+before using this variable. (Mnemonic: System-Specific Subprocess Status.)
+
=item $OS_ERROR
=item $ERRNO
=item $^E
-More specific information about the last system error than that
-provided by C<$!>, if available. (If not, it's just C<$!> again, except under
-OS/2.)
+More specific information about the last system error than that provided by
+C<$!>, if available. (If not, it's just C<$!> again, except under OS/2.)
At the moment, this differs from C<$!> under only VMS and OS/2, where it
provides the VMS status value from the last system error, and OS/2 error
code of the last call to OS/2 API which was not directed via CRT. The
$libdir/integer.3 \
$libdir/less.3 \
$libdir/lib.3 \
- $libdir/localle.3 \
+ $libdir/locale.3 \
$libdir/overload.3 \
$libdir/sigtrap.3 \
$libdir/strict.3 \
}
PerlIO_printf(PerlIO_stderr(), "%s",message);
PerlIO_flush(PerlIO_stderr());
- if (e_tmpname) {
- if (e_fp) {
- PerlIO_close(e_fp);
- e_fp = Nullfp;
- }
- (void)UNLINK(e_tmpname);
- Safefree(e_tmpname);
- e_tmpname = Nullch;
- }
- statusvalue = SHIFTSTATUS(statusvalue);
-#ifdef VMS
- my_exit((U32)vaxc$errno?vaxc$errno:errno?errno:statusvalue?statusvalue:SS$_ABORT);
-#else
- my_exit((I32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
-#endif
+ my_failure_exit();
+ /* NOTREACHED */
return 0;
}
{
dSP;
register CONTEXT *cx;
+ struct block_loop cxloop;
I32 gimme;
SV **newsp;
PMOP *newpm;
SV **mark;
POPBLOCK(cx,newpm);
+ POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
+
mark = newsp;
- POPLOOP(cx);
if (gimme == G_SCALAR) {
if (op->op_private & OPpLEAVE_VOID)
;
while (mark < SP)
*++newsp = sv_mortalcopy(*++mark);
}
- curpm = newpm; /* Don't pop $1 et al till now */
- sp = newsp;
+ SP = newsp;
+ PUTBACK;
+
+ POPLOOP2(); /* Stack values are safe: release loop vars ... */
+ curpm = newpm; /* ... and pop $1 et al */
+
LEAVE;
LEAVE;
- RETURN;
+ return NORMAL;
}
PP(pp_return)
dSP; dMARK;
I32 cxix;
register CONTEXT *cx;
+ struct block_sub cxsub;
+ bool popsub2 = FALSE;
I32 gimme;
SV **newsp;
PMOP *newpm;
POPBLOCK(cx,newpm);
switch (cx->cx_type) {
case CXt_SUB:
- POPSUB(cx);
+ POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
+ popsub2 = TRUE;
break;
case CXt_EVAL:
POPEVAL(cx);
if (gimme == G_SCALAR) {
if (MARK < SP)
- *++newsp = sv_mortalcopy(*SP);
+ *++newsp = (popsub2 && SvTEMP(*SP))
+ ? *SP : sv_mortalcopy(*SP);
else
*++newsp = &sv_undef;
}
else {
- while (MARK < SP)
- *++newsp = sv_mortalcopy(*++MARK);
+ while (++MARK <= SP)
+ *++newsp = (popsub2 && SvTEMP(*MARK))
+ ? *MARK : sv_mortalcopy(*MARK);
}
- curpm = newpm; /* Don't pop $1 et al till now */
stack_sp = newsp;
+ /* Stack values are safe: */
+ if (popsub2) {
+ POPSUB2(); /* release CV and @_ ... */
+ }
+ curpm = newpm; /* ... and pop $1 et al */
+
LEAVE;
return pop_return();
}
dSP;
I32 cxix;
register CONTEXT *cx;
+ struct block_loop cxloop;
+ struct block_sub cxsub;
+ I32 pop2 = 0;
I32 gimme;
I32 optype;
OP *nextop;
POPBLOCK(cx,newpm);
switch (cx->cx_type) {
case CXt_LOOP:
- POPLOOP(cx);
+ POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
+ pop2 = CXt_LOOP;
nextop = cx->blk_loop.last_op->op_next;
LEAVE;
break;
- case CXt_EVAL:
- POPEVAL(cx);
+ case CXt_SUB:
+ POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
+ pop2 = CXt_SUB;
nextop = pop_return();
break;
- case CXt_SUB:
- POPSUB(cx);
+ case CXt_EVAL:
+ POPEVAL(cx);
nextop = pop_return();
break;
default:
}
if (gimme == G_SCALAR) {
- if (mark < SP)
- *++newsp = sv_mortalcopy(*SP);
+ if (MARK < SP)
+ *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
+ ? *SP : sv_mortalcopy(*SP);
else
*++newsp = &sv_undef;
}
else {
- while (mark < SP)
- *++newsp = sv_mortalcopy(*++mark);
+ while (++MARK <= SP)
+ *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
+ ? *MARK : sv_mortalcopy(*MARK);
}
- curpm = newpm; /* Don't pop $1 et al till now */
- sp = newsp;
+ SP = newsp;
+ PUTBACK;
+
+ /* Stack values are safe: */
+ switch (pop2) {
+ case CXt_LOOP:
+ POPLOOP2(); /* release loop vars ... */
+ break;
+ case CXt_SUB:
+ POPSUB2(); /* release CV and @_ ... */
+ break;
+ }
+ curpm = newpm; /* ... and pop $1 et al */
LEAVE;
- RETURNOP(nextop);
+ return nextop;
}
PP(pp_next)
STRLEN len;
I32 minmatch = 0;
I32 oldsave = savestack_ix;
+ I32 update_minmatch = 1;
if (op->op_flags & OPf_STACKED)
TARG = POPs;
if (mg && mg->mg_len >= 0) {
rx->endp[0] = rx->startp[0] = s + mg->mg_len;
minmatch = (mg->mg_flags & MGf_MINMATCH);
+ update_minmatch = 0;
}
}
}
t = s = rx->endp[0];
if (s >= strend)
goto nope;
- minmatch = (s == rx->startp[0]);
+ if (update_minmatch++)
+ minmatch = (s == rx->startp[0]);
}
if (pm->op_pmshort) {
if (pm->op_pmflags & PMf_SCANFIRST) {
*(end++) = '\n'; *end = '\0';
for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
if (hasdir) {
- if (isunix) trim_unixpath(rstr,SvPVX(tmpglob));
+ if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
begin = rstr;
}
else {
PMOP *newpm;
I32 gimme;
register CONTEXT *cx;
+ struct block_sub cxsub;
POPBLOCK(cx,newpm);
- /* Delay POPSUB until stack values are safe */
-
+ POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
+
if (gimme == G_SCALAR) {
MARK = newsp + 1;
if (MARK <= SP)
- if (SvFLAGS(TOPs) & SVs_TEMP)
- *MARK = TOPs;
- else
- *MARK = sv_mortalcopy(TOPs);
+ *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
else {
- MEXTEND(mark,0);
+ MEXTEND(MARK, 0);
*MARK = &sv_undef;
}
SP = MARK;
}
else {
- for (mark = newsp + 1; mark <= SP; mark++)
- if (!(SvFLAGS(*mark) & SVs_TEMP))
- *mark = sv_mortalcopy(*mark);
- /* in case LEAVE wipes old return values */
+ for (MARK = newsp + 1; MARK <= SP; MARK++) {
+ if (!SvTEMP(*MARK))
+ *MARK = sv_mortalcopy(*MARK);
+ }
}
-
- /* Now that stack values are safe, release CV and @_ */
- POPSUB(cx);
-
- curpm = newpm; /* Don't pop $1 et al till now */
+ PUTBACK;
+
+ POPSUB2(); /* Stack values are safe: release CV and @_ ... */
+ curpm = newpm; /* ... and pop $1 et al */
LEAVE;
- PUTBACK;
return pop_return();
}
}
}
}
- statusvalue = FIXSTATUS(my_pclose(fp));
+ STATUS_NATIVE_SET(my_pclose(fp));
}
else {
- statusvalue = -1;
+ STATUS_NATIVE_SET(-1);
if (GIMME == G_SCALAR)
RETPUSHUNDEF;
}
XPUSHs(&sv_undef);
else {
GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
- if (gvp && *gvp == egv)
+ if (gvp && *gvp == egv) {
gv_efullname3(TARG, defoutgv, Nullch);
- else
- sv_setsv(TARG, sv_2mortal(newRV((SV*)egv)));
- XPUSHTARG;
+ XPUSHTARG;
+ }
+ else {
+ XPUSHs(sv_2mortal(newRV((SV*)egv)));
+ }
}
if (newdefout) {
int argflags;
childpid = wait4pid(-1, &argflags, 0);
- statusvalue = (childpid > 0) ? FIXSTATUS(argflags) : -1;
+ STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
XPUSHi(childpid);
RETURN;
#else
optype = POPi;
childpid = TOPi;
childpid = wait4pid(childpid, &argflags, optype);
- statusvalue = (childpid > 0) ? FIXSTATUS(argflags) : -1;
+ STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
SETi(childpid);
RETURN;
#else
} while (result == -1 && errno == EINTR);
(void)rsignal_restore(SIGINT, &ihand);
(void)rsignal_restore(SIGQUIT, &qhand);
- statusvalue = FIXSTATUS(status);
- if (result < 0)
- value = -1;
- else {
- value = (I32)((unsigned int)status & 0xffff);
- }
+ STATUS_NATIVE_SET(status);
+ value = (result == -1) ? -1 : status;
do_execfree(); /* free any memory child malloced on vfork */
SP = ORIGMARK;
PUSHi(value);
else {
value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), na));
}
- statusvalue = FIXSTATUS(value);
+ STATUS_NATIVE_SET(value);
do_execfree();
SP = ORIGMARK;
PUSHi(value);
#ifdef HOST_NOT_FOUND
if (!hent)
- statusvalue = FIXSTATUS(h_errno);
+ STATUS_NATIVE_SET(h_errno);
#endif
if (GIMME != G_ARRAY) {
char* my_bzero _((char* loc, I32 len));
#endif
void my_exit _((U32 status)) __attribute__((noreturn));
+void my_failure_exit _((void)) __attribute__((noreturn));
I32 my_lstat _((void));
#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
I32 my_memcmp _((char* s1, char* s2, I32 len));
print $mystdout "ok ",fileno($mystdout),"\n";
-$fh = new FileHandle "TEST", O_RDONLY and print "ok 2\n";
+$fh = (new FileHandle "./TEST", O_RDONLY
+ or new FileHandle "TEST", O_RDONLY)
+ and print "ok 2\n";
$buffer = <$fh>;
my $t = 30;
$cpt->rdo('/non/existant/file.name');
print +(($! =~ /No such file/ || $! =~ /file specification syntax error/) ||
- $! =~ /A file or directory in the path name does not exist/ ?
+ $! =~ /A file or directory in the path name does not exist/ ||
+ $! =~ /Device not configured/ ?
"ok $t\n" : "not ok $t # $!\n"); $t++;
print 1 ? "ok $t\n" : "not ok $t\n#$@/$!\n"; $t++;
# Greatly extended by Tom Phoenix <rootbeer@teleport.com> on 28 Jan 1997.
#
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Config;
+
print "1..167\n";
my $test = 1;
&{$foo[4]}() == 0
};
+exit 0 unless $Config{'d_fork'};
+
# Additional tests by Tom Phoenix <rootbeer@teleport.com>.
{
- BEGIN {
- if (-d 't') {
- unshift @INC, "lib"
- } else {
- unshift @INC, '../lib'
- }
- }
use strict;
use vars qw!$test!;
$test++;
}
- # Fork off a new perl to run the tests.
- # (This is so we can catch spurious warnings.)
- $| = 1; print ""; $| = 0; # flush output before forking
- pipe READ, WRITE or die "Can't make pipe: $!";
- pipe READ2, WRITE2 or die "Can't make second pipe: $!";
- die "Can't fork: $!" unless defined($pid = open PERL, "|-");
- unless ($pid) {
- # Child process here. We're going to send errors back
- # through the extra pipe.
- close READ;
- close READ2;
- open STDOUT, ">&WRITE" or die "Can't redirect STDOUT: $!";
- open STDERR, ">&WRITE2" or die "Can't redirect STDERR: $!";
- exec './perl', '-w', '-'
+ if ($Config{d_fork} and $^O ne 'VMS') {
+ # Fork off a new perl to run the tests.
+ # (This is so we can catch spurious warnings.)
+ $| = 1; print ""; $| = 0; # flush output before forking
+ pipe READ, WRITE or die "Can't make pipe: $!";
+ pipe READ2, WRITE2 or die "Can't make second pipe: $!";
+ die "Can't fork: $!" unless defined($pid = open PERL, "|-");
+ unless ($pid) {
+ # Child process here. We're going to send errors back
+ # through the extra pipe.
+ close READ;
+ close READ2;
+ open STDOUT, ">&WRITE" or die "Can't redirect STDOUT: $!";
+ open STDERR, ">&WRITE2" or die "Can't redirect STDERR: $!";
+ exec './perl', '-w', '-'
or die "Can't exec ./perl: $!";
+ } else {
+ # Parent process here.
+ close WRITE;
+ close WRITE2;
+ print PERL $code;
+ close PERL;
+ { local $/;
+ $output = join '', <READ>;
+ $errors = join '', <READ2>; }
+ close READ;
+ close READ2;
+ }
+ } else {
+ # No fork(). Do it the hard way.
+ my $cmdfile = "tcmd$$"; $cmdfile++ while -e $cmdfile;
+ my $outfile = "tout$$"; $outfile++ while -e $outfile;
+ my $errfile = "terr$$"; $errfile++ while -e $errfile;
+ open CMD, ">$cmdfile"; print CMD $code; close CMD;
+ my $cmd = ($^O eq 'VMS') ? "MCR $^X" : "./perl";
+ $cmd .= " -w $cmdfile >$outfile 2>$errfile";
+ system $cmd;
+ $? = 0 if $^O eq 'VMS' and $? & 1; # Keep Unix-minded code below happy
+ if ($?) {
+ printf "not ok: exited with error code %04X\n", $?;
+ $debugging or do { 1 while unlink $cmdfile, $outfile, $errfile };
+ exit;
+ }
+ { local $/;
+ open IN, $outfile; $output = <IN>; close IN;
+ open IN, $errfile; $errors = <IN>; close IN; }
+ 1 while unlink $cmdfile, $outfile, $errfile;
}
- # Parent process here.
- close WRITE;
- close WRITE2;
- print PERL $code;
- close PERL;
- $output = join '', <READ>;
- $errors = join '', <READ2>;
- print $output, $errors;
+ print $output;
+ print STDERR $errors;
if ($debugging && ($errors || $? || ($output =~ /not ok/))) {
my $lnum = 0;
for $line (split '\n', $code) {
printf "%3d: %s\n", ++$lnum, $line;
}
}
- printf "not ok: exited with error code %04lX\n",$? if $?;
- print "-" x 30, $/ if $debugging;
+ printf "not ok: exited with error code %04X\n", $? if $?;
+ print "-" x 30, "\n" if $debugging;
} # End of foreach $within
} # End of foreach $where_declared
sub foo { local $_ = shift; split; @_ }
@x = foo(' x y z ');
print "you die joe!\n" unless "@x" eq 'x y z';
+########
+sub foo { local(@_) = ('p', 'q', 'r'); }
+sub bar { unshift @_, 'D'; @_ }
+sub baz { push @_, 'E'; return @_ }
+for (1..3) { print foo('a', 'b', 'c'), bar('d'), baz('e'), "\n" }
+EXPECT
+pqrDdeE
+pqrDdeE
+pqrDdeE
#define LOP(f,x) return lop(f,x,s)
static I32
-lop(f,x,s)
+lop
+#ifdef CAN_PROTOTYPE
+ (I32 f, expectation x, char *s)
+#else
+ (f,x,s)
I32 f;
expectation x;
char *s;
+#endif /* CAN_PROTOTYPE */
{
yylval.ival = f;
CLINE;
}
PerlIO_puts(PerlIO_stderr(),message);
(void)PerlIO_flush(PerlIO_stderr());
- if (e_tmpname) {
- if (e_fp) {
- PerlIO_close(e_fp);
- e_fp = Nullfp;
- }
- (void)UNLINK(e_tmpname);
- Safefree(e_tmpname);
- e_tmpname = Nullch;
- }
- statusvalue = SHIFTSTATUS(statusvalue);
-#ifdef VMS
- my_exit((U32)(vaxc$errno?vaxc$errno:(statusvalue?statusvalue:44)));
-#else
- my_exit((U32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
-#endif
+ my_failure_exit();
}
void
OBJVAL = $@
# Updated by fndvers.com -- do not edit by hand
-PERL_VERSION = 5_00324#
+PERL_VERSION = 5_00325#
ARCHDIR = [.lib.$(ARCH).$(PERL_VERSION)]
@ If f$$Search("[.lib]VMS.Dir").eqs."" Then Create/Directory [.lib.VMS]
Copy/Log/NoConfirm [.vms.ext]Filespec.pm $@
-[.lib.pod]perldoc : [.utils]perldoc.PL $(ARCHDIR)Config.pm
+[.lib.pod]perldoc.com : [.utils]perldoc.PL $(ARCHDIR)Config.pm
@ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
$(MINIPERL) [.utils]perldoc.PL
Copy/Log [.utils]perldoc.com $@
[.x2p]s2p.com : [.x2p]s2p.PL $(ARCHDIR)Config.pm
$(MINIPERL) [.x2p]s2p.PL
+# Rename catches problem with some DECC versions in which object file is
+# placed in current default dir, not same one as source file.
[.x2p]$(DBG)a2p$(E) : [.x2p]a2p$(O), [.x2p]hash$(O), [.x2p]str$(O), [.x2p]util$(O), [.x2p]walk$(O)
+ @ If f$$Search("a2p$(O)").nes."" Then Rename/NoLog a2p$(O),hash$(O),str$(O),util$(O),walk$(O) [.x2p]
Link $(LINKFLAGS) /Exe=$@ $(MMS$SOURCE_LIST) $(CRTLOPTS)
[.lib.pod]pod2html.com : [.pod]pod2html.PL $(ARCHDIR)Config.pm
[.t.lib]vmsfspec.t : [.vms.ext]filespec.t
Copy/Log/NoConfirm [.vms.ext]filespec.t $@
-test : all
+test : all [.t.lib]vmsfspec.t
- @[.VMS]Test.Com "$(E)"
# CORE subset for MakeMaker, so we can build Perl without sources
- If f$$Search("[.Lib.VMS]*.*;-1").nes."" Then Purge/NoConfirm/Log [.Lib.VMS]*.*
- 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("[.utils]*.;-1").nes."" Then Purge/NoConfirm/Log [.utils]*./Exclude=Makefile.
- - If f$$Search("[.lib]perlbug.;-1").nes."" Then Purge/NoConfirm/Log [.lib]perlbug.
+ - If f$$Search("[.lib]*.com;-1").nes."" Then Purge/NoConfirm/Log [.lib]*.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]*.;-1").nes."" Then Purge/NoConfirm/Log [.lib.pod]*.
clean : tidy
- If f$$Search("[.Lib]DynaLoader.pm").nes."" Then Delete/NoConfirm/Log [.Lib]DynaLoader.pm;*
- If f$$Search("[.Lib]Socket.pm").nes."" Then Delete/NoConfirm/Log [.Lib]Socket.pm;*
- If f$$Search("[.Lib]Config.pm").nes."" Then Delete/NoConfirm/Log [.Lib]Config.pm;*
- - If f$$Search("[.Lib]perlbug.").nes."" Then Delete/NoConfirm/Log [.Lib]perlbug.;*
+ - If f$$Search("[.Lib]*.com").nes."" Then Delete/NoConfirm/Log [.Lib]*.com;*
+ - If f$$Search("[.utils]*.com").nes."" Then Delete/NoConfirm/Log [.utils]*.com;*
+ - If f$$Search("[.x2p]*.com").nes."" Then Delete/NoConfirm/Log [.x2p]*.com;*
- If f$$Search("$(ARCHDIR)Config.pm").nes."" Then Delete/NoConfirm/Log $(ARCHDIR)Config.pm;*
- If f$$Search("[.lib.ExtUtils]Miniperl.pm").nes."" Then Delete/NoConfirm/Log [.lib.ExtUtils]Miniperl.pm;*
- - If f$$Search("[.utils]*.").nes."" Then Delete/NoConfirm/Log [.utils]*.;*/Exclude=Makefile.
- - If f$$Search("[.x2p]*.").nes."" Then Delete/NoConfirm/Log [.x2p]*.;*/Exclude=Makefile.
- If f$$Search("[.lib.pod]*.pod").nes."" Then Delete/NoConfirm/Log [.lib.pod]*.pod;*
- - If f$$Search("[.lib.pod]perldoc.").nes."" Then Delete/NoConfirm/Log [.lib.pod]perldoc.;*
+ - If f$$Search("[.lib.pod]perldoc.com").nes."" Then Delete/NoConfirm/Log [.lib.pod]perldoc.com;*
- If f$$Search("[.lib.pod]pod2*.com").nes."" Then Delete/NoConfirm/Log [.lib.pod]pod2*.com;*
+ - If f$$Search("[.t.lib]vmsfspec.t").nes."" Then Delete/NoConfirm/Log [.t.lib]vmsfspec.t;*
- If f$$Search("[...]*$(E)").nes."" Then Delete/NoConfirm/Log [...]*$(E);*
cleansrc : clean
* when Perl is built. Please do not change it by hand; make
* any changes to FndVers.Com instead.
*/
-#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_00324" /**/
+#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_00325" /**/
#define ARCHLIB ARCHLIB_EXP /*config-skip*/
/* ARCHNAME:
.endif
# Updated by fndvers.com -- do not edit by hand
-PERL_VERSION = 5_00324#
+PERL_VERSION = 5_00325#
ARCHDIR = [.lib.$(ARCH).$(PERL_VERSION)]
@ If F$Search("[.lib]VMS.Dir").eqs."" Then Create/Directory [.lib.VMS]
Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET)
-[.lib.pod]perldoc : [.utils]perldoc.PL $(ARCHDIR)Config.pm
+[.lib.pod]perldoc.com : [.utils]perldoc.PL $(ARCHDIR)Config.pm
@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
$(MINIPERL) $(MMS$SOURCE)
Copy/Log [.utils]perldoc.com $(MMS$TARGET)
[.x2p]s2p.com : [.x2p]s2p.PL $(ARCHDIR)Config.pm
$(MINIPERL) $(MMS$SOURCE)
+# Rename catches problem with some DECC versions in which object file is
+# placed in current default dir, not same one as source file.
[.x2p]$(DBG)a2p$(E) : [.x2p]a2p$(O), [.x2p]hash$(O), [.x2p]str$(O), [.x2p]util$(O), [.x2p]walk$(O)
+ @ If F$Search("a2p$(O)").nes."" Then Rename/NoLog a2p$(O),hash$(O),str$(O),util$(O),walk$(O) [.x2p]
Link $(LINKFLAGS) /Exe=$(MMS$TARGET) $(MMS$SOURCE_LIST) $(CRTLOPTS)
[.lib.pod]pod2html.com : [.pod]pod2html.PL $(ARCHDIR)Config.pm
[.t.lib]vmsfspec.t : [.vms.ext]filespec.t
Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET)
-test : all
+test : all [.t.lib]vmsfspec.t
- @[.VMS]Test.Com "$(E)"
# CORE subset for MakeMaker, so we can build Perl without sources
- If F$Search("[.Lib.VMS]*.*;-1").nes."" Then Purge/NoConfirm/Log [.Lib.VMS]*.*
- 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("[.utils]*.;-1").nes."" Then Purge/NoConfirm/Log [.utils]*./Exclude=Makefile.
- - If F$Search("[.lib]perlbug.;-1").nes."" Then Purge/NoConfirm/Log [.lib]perlbug.
+ - If F$Search("[.lib]*.com;-1").nes."" Then Purge/NoConfirm/Log [.lib]*.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]*.;-1").nes."" Then Purge/NoConfirm/Log [.lib.pod]*.
clean : tidy
- If F$Search("[.Lib]DynaLoader.pm").nes."" Then Delete/NoConfirm/Log [.Lib]DynaLoader.pm;*
- If F$Search("[.Lib]Socket.pm").nes."" Then Delete/NoConfirm/Log [.Lib]Socket.pm;*
- If F$Search("[.Lib]Config.pm").nes."" Then Delete/NoConfirm/Log [.Lib]Config.pm;*
- - If F$Search("[.Lib]perlbug.").nes."" Then Delete/NoConfirm/Log [.Lib]perlbug.;*
+ - If F$Search("[.Lib]*.com").nes."" Then Delete/NoConfirm/Log [.Lib]*.com;*
+ - If F$Search("[.utils]*.com").nes."" Then Delete/NoConfirm/Log [.utils]*.com;*
+ - If F$Search("[.x2p]*.com").nes."" Then Delete/NoConfirm/Log [.x2p]*.com;*
- If F$Search("$(ARCHDIR)Config.pm").nes."" Then Delete/NoConfirm/Log $(ARCHDIR)Config.pm;*
- If F$Search("[.lib.ExtUtils]Miniperl.pm").nes."" Then Delete/NoConfirm/Log [.lib.ExtUtils]Miniperl.pm;*
- - If F$Search("[.utils]*.").nes."" Then Delete/NoConfirm/Log [.utils]*.;*/Exclude=Makefile.
- - If F$Search("[.x2p]*.").nes."" Then Delete/NoConfirm/Log [.x2p]*.;*/Exclude=Makefile.
- If F$Search("[.lib.pod]*.pod").nes."" Then Delete/NoConfirm/Log [.lib.pod]*.pod;*
- - If F$Search("[.lib.pod]perldoc.").nes."" Then Delete/NoConfirm/Log [.lib.pod]perldoc.;*
+ - If F$Search("[.lib.pod]perldoc.com").nes."" Then Delete/NoConfirm/Log [.lib.pod]perldoc.com;*
- If F$Search("[.lib.pod]pod2*.com").nes."" Then Delete/NoConfirm/Log [.lib.pod]pod2*.com;*
+ - If F$Search("[.t.lib]vmsfspec.t").nes."" Then Delete/NoConfirm/Log [.t.lib]vmsfspec.t;*
- If F$Search("[...]*$(E)").nes."" Then Delete/NoConfirm/Log [...]*$(E);*
cleansrc : clean
[.some.where.over]the.rainbow unixify some/where/over/the.rainbow
[-.some.where.over]the.rainbow unixify ../some/where/over/the.rainbow
[.some.--.where.over]the.rainbow unixify some/../../where/over/the.rainbow
+[.some...where.over]the.rainbow unixify some/.../where/over/the.rainbow
+[...some.where.over]the.rainbow unixify .../some/where/over/the.rainbow
+[.some.where.over...]the.rainbow unixify some/where/over/.../the.rainbow
+[.some.where.over...] unixify some/where/over/.../
+[.some.where.over.-] unixify some/where/over/../
[] unixify ./
[-] unixify ../
[--] unixify ../../
+[...] unixify .../
# and back again
/some/where/over/the.rainbow vmsify some:[where.over]the.rainbow
some/where/over/the.rainbow vmsify [.some.where.over]the.rainbow
../some/where/over/the.rainbow vmsify [-.some.where.over]the.rainbow
some/../../where/over/the.rainbow vmsify [-.where.over]the.rainbow
+.../some/where/over/the.rainbow vmsify [...some.where.over]the.rainbow
+some/.../where/over/the.rainbow vmsify [.some...where.over]the.rainbow
+/some/.../where/over/the.rainbow vmsify some:[...where.over]the.rainbow
+some/where/... vmsify [.some.where...]
+/where/... vmsify where:[...]
. vmsify []
.. vmsify [-]
../.. vmsify [--]
+.../ vmsify [...]
# Fileifying directory specs
down:[the.garden.path] fileify down:[the.garden]path.dir;1
/down/the/garden.path pathify
down:[the.garden]path.dir;2 pathify #N.B. ;2
path pathify path/
+/down/the/garden/. pathify /down/the/garden/./
+/down/the/garden/.. pathify /down/the/garden/../
+/down/the/garden/... pathify /down/the/garden/.../
path.notdir pathify
# Both VMS/Unix and file/path conversions
down:[the.garden]path.dir;1 unixpath /down/the/garden/path/
/down/the/garden/path vmspath down:[the.garden.path]
down:[the.garden.path] unixpath /down/the/garden/path/
+down:[the.garden.path...] unixpath /down/the/garden/path/.../
/down/the/garden/path.dir vmspath down:[the.garden.path]
[.down.the.garden]path.dir unixpath down/the/garden/path/
down/the/garden/path vmspath [.down.the.garden.path]
*
* VMS-specific routines for perl5
*
- * Last revised: 14-Oct-1996 by Charles Bailey bailey@genetics.upenn.edu
- * Version: 5.3.7
+ * Last revised: 29-Jan-1997 by Charles Bailey bailey@genetics.upenn.edu
+ * Version: 5.3.24
*/
#include <acedef.h>
#include <shrdef.h>
#include <ssdef.h>
#include <starlet.h>
-#include <stsdef.h>
+#include <strdef.h>
+#include <str$routines.h>
#include <syidef.h>
#include <uaidef.h>
#include <uicdef.h>
if ( !(cp1 = strrchr(dir,'/')) &&
!(cp1 = strrchr(dir,']')) &&
!(cp1 = strrchr(dir,'>')) ) cp1 = dir;
- if ((cp2 = strchr(cp1,'.')) != NULL) {
+ if ((cp2 = strchr(cp1,'.')) != NULL &&
+ (*(cp2-1) != '/' || /* Trailing '.', '..', */
+ !(*(cp2+1) == '\0' || /* or '...' are dirs. */
+ (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
+ (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
int ver; char *cp3;
if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
!*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
{
static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
- int devlen, dirlen, retlen = NAM$C_MAXRSS+1, dashes = 0;
+ int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
if (spec == NULL) return NULL;
if (strlen(spec) > NAM$C_MAXRSS) return NULL;
cp1 = strchr(spec,'[');
if (!cp1) cp1 = strchr(spec,'<');
if (cp1) {
- for (cp1++; *cp1 == '-'; cp1++) dashes++; /* VMS '-' ==> Unix '../' */
+ for (cp1++; *cp1; cp1++) {
+ if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
+ if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
+ { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
+ }
}
- New(7015,rslt,retlen+2+2*dashes,char);
+ New(7015,rslt,retlen+2+2*expand,char);
}
else rslt = __tounixspec_retbuf;
if (strchr(spec,'/') != NULL) {
else { /* the VMS spec begins with directories */
cp2++;
if (*cp2 == ']' || *cp2 == '>') {
- strcpy(rslt,"./");
+ *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
return rslt;
}
- else if ( *cp2 != '.' && *cp2 != '-') {
- *(cp1++) = '/'; /* add the implied device into the Unix spec */
+ else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
if (getcwd(tmp,sizeof tmp,1) == NULL) {
if (ts) Safefree(rslt);
return NULL;
*(cp3++) = '\0';
if (strchr(cp3,']') != NULL) break;
} while (((cp3 = my_getenv(tmp)) != NULL) && strcpy(tmp,cp3));
- cp3 = tmp;
- while (*cp3) *(cp1++) = *(cp3++);
- *(cp1++) = '/';
- if (ts &&
+ if (ts && !buf &&
((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
- int offset = cp1 - rslt;
-
retlen = devlen + dirlen;
- Renew(rslt,retlen+1+2*dashes,char);
- cp1 = rslt + offset;
+ Renew(rslt,retlen+1+2*expand,char);
+ cp1 = rslt;
+ }
+ cp3 = tmp;
+ *(cp1++) = '/';
+ while (*cp3) {
+ *(cp1++) = *(cp3++);
+ if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
}
+ *(cp1++) = '/';
+ }
+ else if ( *cp2 == '.') {
+ if (*(cp2+1) == '.' && *(cp2+2) == '.') {
+ *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
+ cp2 += 3;
+ }
+ else cp2++;
}
- else if (*cp2 == '.') cp2++;
}
for (; cp2 <= dirend; cp2++) {
if (*cp2 == ':') {
*(cp1++) = '/';
if (*(cp2+1) == '[') cp2++;
}
- else if (*cp2 == ']' || *cp2 == '>') *(cp1++) = '/';
+ else if (*cp2 == ']' || *cp2 == '>') {
+ if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
+ }
else if (*cp2 == '.') {
*(cp1++) = '/';
if (*(cp2+1) == ']' || *(cp2+1) == '>') {
if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
*(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
}
+ else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
+ *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
+ cp2 += 2;
+ }
}
else if (*cp2 == '-') {
if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
else strcpy(rslt,path);
return rslt;
}
- if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.."? */
+ if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
if (!*(dirend+2)) dirend +=2;
if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
+ if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
}
cp1 = rslt;
cp2 = path;
*(cp1++) = '-'; /* "../" --> "-" */
cp2 += 3;
}
+ else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
+ (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
+ *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
+ if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
+ cp2 += 4;
+ }
if (cp2 > dirend) cp2 = dirend;
}
else *(cp1++) = '.';
cp2 += 2;
if (cp2 == dirend) break;
}
+ else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
+ (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
+ if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
+ *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
+ if (!*(cp2+3)) {
+ *(cp1++) = '.'; /* Simulate trailing '/' */
+ cp2 += 2; /* for loop will incr this to == dirend */
+ }
+ else cp2 += 3; /* Trailing '/' was there, so skip it, too */
+ }
else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
}
else {
for (c = string; *c; ++c)
if (isupper(*c))
*c = tolower(*c);
- if (isunix) trim_unixpath(string,item);
+ if (isunix) trim_unixpath(string,item,1);
add_item(head, tail, string, count);
++expcount;
}
* of whether input filespec was VMS-style or Unix-style.
*
* fspec is filespec to be trimmed, and wildspec is wildcard spec used to
- * determine prefix (both may be in VMS or Unix syntax).
+ * determine prefix (both may be in VMS or Unix syntax). opts is a bit
+ * vector of options; at present, only bit 0 is used, and if set tells
+ * trim unixpath to try the current default directory as a prefix when
+ * presented with a possibly ambiguous ... wildcard.
*
* Returns !=0 on success, with trimmed filespec replacing contents of
* fspec, and 0 on failure, with contents of fpsec unchanged.
*/
-/*{{{int trim_unixpath(char *fspec, char *wildspec)*/
+/*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
int
-trim_unixpath(char *fspec, char *wildspec)
+trim_unixpath(char *fspec, char *wildspec, int opts)
{
char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
- *template, *base, *cp1, *cp2;
- register int tmplen, reslen = 0;
+ *template, *base, *end, *cp1, *cp2;
+ register int tmplen, reslen = 0, dirs = 0;
if (!wildspec || !fspec) return 0;
if (strpbrk(wildspec,"]>:") != NULL) {
if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
- else template = unixified;
+ else template = unixwild;
}
else template = wildspec;
if (strpbrk(fspec,"]>:") != NULL) {
return 1;
}
- /* Find prefix to template consisting of path elements without wildcards */
- if ((cp1 = strpbrk(template,"*%?")) == NULL)
- for (cp1 = template; *cp1; cp1++) ;
- else while (cp1 > template && *cp1 != '/') cp1--;
- for (cp2 = base; *cp2; cp2++) ; /* Find end of resultant filespec */
-
- /* Wildcard was in first element, so we don't have a reliable string to
- * match against. Guess where to trim resultant filespec by counting
- * directory levels in the Unix template. (We could do this instead of
- * string matching in all cases, since Unix doesn't have a ... wildcard
- * that can expand into multiple levels of subdirectory, but we try for
- * the string match so our caller can interpret foo/.../bar.* as
- * [.foo...]bar.* if it wants, and only get burned if there was a
- * wildcard in the first word (in which case, caveat caller). */
- if (cp1 == template) {
- int subdirs = 0;
- for ( ; *cp1; cp1++) if (*cp1 == '/') subdirs++;
- /* need to back one more '/' than in template, to pick up leading dirname */
- subdirs++;
- while (cp2 > base) {
- if (*cp2 == '/') subdirs--;
- if (!subdirs) break; /* quit without decrement when we hit last '/' */
- cp2--;
- }
- /* ran out of directories on resultant; allow for already trimmed
- * resultant, which hits start of string looking for leading '/' */
- if (subdirs && (cp2 != base || subdirs != 1)) return 0;
- /* Move past leading '/', if there is one */
- base = cp2 + (*cp2 == '/' ? 1 : 0);
- tmplen = strlen(base);
- if (reslen && tmplen > reslen) return 0; /* not enough space */
- memmove(fspec,base,tmplen+1); /* copy result to fspec, with trailing NUL */
+ for (end = base; *end; end++) ; /* Find end of resultant filespec */
+ if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
+ for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
+ for (cp1 = end ;cp1 >= base; cp1--)
+ if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
+ { cp1++; break; }
+ if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
return 1;
}
- /* We have a prefix string of complete directory names, so we
- * try to find it on the resultant filespec */
- else {
- tmplen = cp1 - template;
- if (!memcmp(base,template,tmplen)) { /* Nothing before prefix; we're done */
- if (reslen) { /* we converted to Unix syntax; copy result over */
- tmplen = cp2 - base;
- if (tmplen > reslen) return 0; /* not enough space */
- memmove(fspec,base,tmplen+1); /* Copy trimmed spec + trailing NUL */
+ else {
+ char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
+ char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
+ int ells = 1, totells, segdirs, match;
+ struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
+ resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
+
+ while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
+ totells = ells;
+ for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
+ if (ellipsis == template && opts & 1) {
+ /* Template begins with an ellipsis. Since we can't tell how many
+ * directory names at the front of the resultant to keep for an
+ * arbitrary starting point, we arbitrarily choose the current
+ * default directory as a starting point. If it's there as a prefix,
+ * clip it off. If not, fall through and act as if the leading
+ * ellipsis weren't there (i.e. return shortest possible path that
+ * could match template).
+ */
+ if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
+ for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
+ if (_tolower(*cp1) != _tolower(*cp2)) break;
+ segdirs = dirs - totells; /* Min # of dirs we must have left */
+ for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
+ if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
+ memcpy(fspec,cp2+1,end - cp2);
+ return 1;
}
- return 1;
}
- for ( ; cp2 - base > tmplen; base++) {
- if (*base != '/') continue;
- if (!memcmp(base + 1,template,tmplen)) break;
+ /* First off, back up over constant elements at end of path */
+ if (dirs) {
+ for (front = end ; front >= base; front--)
+ if (*front == '/' && !dirs--) { front++; break; }
+ }
+ for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcend + sizeof lcend;
+ cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
+ if (cp1 != '\0') return 0; /* Path too long. */
+ lcend = cp2;
+ *cp2 = '\0'; /* Pick up with memcpy later */
+ lcfront = lcres + (front - base);
+ /* Now skip over each ellipsis and try to match the path in front of it. */
+ while (ells--) {
+ for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
+ if (*(cp1) == '.' && *(cp1+1) == '.' &&
+ *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
+ if (cp1 < template) break; /* template started with an ellipsis */
+ if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
+ ellipsis = cp1; continue;
+ }
+ wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
+ nextell = cp1;
+ for (segdirs = 0, cp2 = tpl;
+ cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
+ cp1++, cp2++) {
+ if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
+ else *cp2 = _tolower(*cp1); /* else lowercase for match */
+ if (*cp2 == '/') segdirs++;
+ }
+ if (cp1 != ellipsis - 1) return 0; /* Path too long */
+ /* Back up at least as many dirs as in template before matching */
+ for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
+ if (*cp1 == '/' && !segdirs--) { cp1++; break; }
+ for (match = 0; cp1 > lcres;) {
+ resdsc.dsc$a_pointer = cp1;
+ if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
+ match++;
+ if (match == 1) lcfront = cp1;
+ }
+ for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
+ }
+ if (!match) return 0; /* Can't find prefix ??? */
+ if (match > 1 && opts & 1) {
+ /* This ... wildcard could cover more than one set of dirs (i.e.
+ * a set of similar dir names is repeated). If the template
+ * contains more than 1 ..., upstream elements could resolve the
+ * ambiguity, but it's not worth a full backtracking setup here.
+ * As a quick heuristic, clip off the current default directory
+ * if it's present to find the trimmed spec, else use the
+ * shortest string that this ... could cover.
+ */
+ char def[NAM$C_MAXRSS+1], *st;
+
+ if (getcwd(def, sizeof def,0) == NULL) return 0;
+ for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
+ if (_tolower(*cp1) != _tolower(*cp2)) break;
+ segdirs = dirs - totells; /* Min # of dirs we must have left */
+ for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
+ if (*cp1 == '\0' && *cp2 == '/') {
+ memcpy(fspec,cp2+1,end - cp2);
+ return 1;
+ }
+ /* Nope -- stick with lcfront from above and keep going. */
+ }
}
-
- if (cp2 - base == tmplen) return 0; /* Not there - not good */
- base++; /* Move past leading '/' */
- if (reslen && cp2 - base > reslen) return 0; /* not enough space */
- /* Copy down remaining portion of filespec, including trailing NUL */
- memmove(fspec,base,cp2 - base + 1);
+ memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
return 1;
+ ellipsis = nextell;
}
} /* end of trim_unixpath() */
#include <libdef.h> /* status codes for various places */
#include <rmsdef.h> /* at which errno and vaxc$errno are */
#include <ssdef.h> /* explicitly set in the perl source code */
+#include <stsdef.h>
/* Suppress compiler warnings from DECC for VMS-specific extensions:
* GLOBALEXT, NOSHAREEXT, READONLYEXT: global[dr]ef declarations
I32 cando_by_name _((I32, I32, char *));
int flex_fstat _((int, struct stat *));
int flex_stat _((char *, struct stat *));
-int trim_unixpath _((char *, char*));
+int trim_unixpath _((char *, char*, int));
int my_vfork _(());
bool vms_do_aexec _((SV *, SV **, SV **));
bool vms_do_exec _((char *));
projects / p5sagit/p5-mst-13.2.git / commitdiff