----------------
+Version 5.003_27
+----------------
+
+This release is beta candidate #5: Our last, best hope for a beta.
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Better looks_like_number() function [sv.c]"
+ From: Gisle Aas <aas@bergen.sn.no>
+ Msg-ID: <199702141708.SAA17546@bergen.sn.no>
+ Date: Fri, 14 Feb 1997 18:08:52 +0100
+ Files: sv.c
+
+ Title: "Remove redundant functions UNIVERSAL::{class,is_instance}"
+ From: Gisle Aas <aas@bergen.sn.no>
+ Msg-ID: <hwwsbpeq2.fsf@bergen.sn.no>
+ Date: 14 Feb 1997 15:52:21 +0000
+ Files: pod/perldelta.pod pod/perlobj.pod t/op/universal.t universal.c
+
+ Title: "Allow C<setpgrp $$>"
+ From: Roderick Schertler <roderick@gate.net>
+ Msg-ID: <pzraigyshr.fsf@eeyore.ibcinc.com>
+ Date: 16 Feb 1997 23:19:12 -0500
+ Files: pp_sys.c
+
+ Title: "Fix syntax error on C<&$1>"
+ From: Chip Salzenberg
+ Files: toke.c
+
+ Title: "Fix sub call through magic var (e.g. C<&$1>)"
+ From: Chip Salzenberg
+ Files: pp_hot.c
+
+ Title: "Fix grep() with refs in array context"
+ From: Chip Salzenberg
+ Files: pp.c
+
+ CORE PORTABILITY
+
+ Title: "Eliminate $^S; add C<use vmsish qw(status exit time)>"
+ From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>
+ Msg-ID: <01IFI9CFKL0S004R2V@hmivax.humgen.upenn.edu>
+ Date: Mon, 17 Feb 1997 02:45:26 -0500 (EST)
+ Files: MANIFEST gv.c lib/English.pm lib/ExtUtils/MM_VMS.pm
+ lib/ExtUtils/Mksymlists.pm lib/ExtUtils/xsubpp mg.c op.c
+ perl.c perl.h pod/perldelta.pod pod/perlmod.pod
+ pod/perlvar.pod pp_ctl.c pp_sys.c utils/perldoc.PL
+ vms/Makefile vms/config.vms vms/descrip.mms
+ vms/ext/Stdio/Stdio.pm vms/ext/Stdio/Stdio.xs
+ vms/ext/XSSymSet.pm vms/ext/vmsish.pm vms/vms.c vms/vmsish.h
+ win32/makedef.pl
+
+ Title: "Eliminate FP exceptions under SCO 5"
+ From: Chip Salzenberg
+ Files: hints/sco.sh unixish.h
+
+ Title: "Digital UNIX hints"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199702151906.VAA22999@alpha.hut.fi>
+ Date: Sat, 15 Feb 1997 21:06:33 +0200 (EET)
+ Files: hints/dec_osf.sh
+
+ Title: "Irix6.4 (with 7.1 compilers)"
+ From: John Stoffel <jfs@fluent.com>
+ Msg-ID: <199702130238.VAA24468@jfs.Fluent.COM>
+ Date: Wed, 12 Feb 1997 21:38:51 -0500 (EST)
+ Files: hints/irix_6_2.sh hints/irix_6_4.sh
+
+ Title: "Update Plan 9, Win32, VMS configs with $shortsize and $longsize"
+ From: Chip Salzenberg
+ Files: plan9/config.plan9 plan9/genconfig.pl
+ vms/genconfig.pl win32/config.w32
+
+ OTHER CORE CHANGES
+
+ Title: "Fix core dump when embedding"
+ From: Chip Salzenberg
+ Files: perl.c
+
+ Title: "Re: Fragile signals"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199702130644.BAA07572@monk.mps.ohio-state.edu>
+ Date: Thu, 13 Feb 1997 01:44:39 -0500 (EST)
+ Files: mg.c
+
+ Title: "Make format strings correspond exactly to parameters"
+ From: Roderick Schertler <roderick@gate.net>
+ Msg-ID: <pz7mkc1h0g.fsf@eeyore.ibcinc.com>
+ Date: 13 Feb 1997 17:24:31 -0500
+ Files: doio.c ext/DB_File/DB_File.xs ext/Opcode/Opcode.xs gv.c op.c
+ perl.c pp_ctl.c pp_sys.c regcomp.c toke.c
+
+ Title: "Don't try to attach 'o' magic to read-only values"
+ From: Chip Salzenberg
+ Files: sv.c
+
+ Title: "Fix carriage-return message"
+ From: Chip Salzenberg
+ Files: toke.c
+
+ Title: "In <=>, test for equality first"
+ From: Chip Salzenberg
+ Files: pp.c
+
+ Title: "Don't mark sv_{true,false} PADTMP"
+ From: Chip Salzenberg
+ Files: op.c
+
+ BUILD PROCESS
+
+ Title: "Fix eval "" in Configure"
+ From: allen@gateway.grumman.com (John L. Allen)
+ Msg-ID: <9702141809.AA17001@gateway.grumman.com>
+ Date: Fri, 14 Feb 1997 13:09:53 -0500
+ Files: Configure
+
+ Title: "Don't link with -lsfio if sfio is not requested"
+ From: Chip Salzenberg
+ Files: Configure
+
+ Title: "perl5.003_26 Configure change "win" for AIX 4"
+ From: Tim Mooney <mooney@dogbert.cc.ndsu.NoDak.edu>
+ Msg-ID: <Pine.OSF.3.95.970214135751.32654A-100000@dogbert.cc.ndsu.NoD
+ Date: Fri, 14 Feb 1997 13:59:02 -0600 (CST)
+ Files: Configure
+
+ Title: "Update os2/diff.configure"
+ From: Chip Salzenberg
+ Files: os2/diff.configure
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Remove Fatal.pm"
+ From: Chip Salzenberg
+ Files: MANIFEST lib/Fatal.pm pod/perldelta.pod pod/perlmod.pod
+ pod/roffitall t/lib/fatal.t
+
+ Title: "Refresh MakeMaker to 5.40"
+ From: Andy Dougherty, Andreas Koenig, Tim Bunce
+ Files: lib/ExtUtils/Liblist.pm lib/ExtUtils/MM_Unix.pm
+ lib/ExtUtils/MakeMaker.pm lib/ExtUtils/Mksymlists.pm
+
+ Title: "Refresh CPAN.pm to 1.21"
+ From: Andreas Koenig <a.koenig@mind.de>
+ Files: lib/CPAN.pm lib/CPAN/FirstTime.pm lib/CPAN/Nox.pm
+
+ Title: "Refresh Test::Harness to 1.15"
+ From: Andreas Koenig <a.koenig@mind.de>
+ Files: lib/Test/Harness.pm
+
+ TESTS
+
+ Title: "Remove non-portable locale tests"
+ From: Chip Salzenberg
+ Files: t/pragma/locale.t
+
+ UTILITIES
+
+ Title: "pod2man: missing '-' in name section shouldn't be fatal"
+ From: Ulrich Pfeifer <pfeifer@charly.informatik.uni-dortmund.de>
+ Msg-ID: <yfmzpxcimsa.fsf@ls6.informatik.uni-dortmund.de>
+ Date: 10 Feb 1997 18:38:45 +0100
+ Files: pod/pod2man.PL
+
+ DOCUMENTATION
+
+ Title: "Update To-Do list"
+ From: Tim Bunce <Tim.Bunce@ig.co.uk>
+ Msg-ID: <9702101900.AA25293@toad.ig.co.uk>
+ Date: Mon, 10 Feb 1997 19:00:59 +0000
+ Files: Todo
+
+ Title: "Fix formatting in perldiag"
+ From: Chip Salzenberg
+ Files: pod/perldiag.pod
+
+
+----------------
Version 5.003_26
----------------
exit 1
fi
-: On HP-UX, large Configure scripts may exercise a bug in /bin/sh
-if test -f /hp-ux -a -f /bin/ksh; then
- if (PATH=.; alias -x) >/dev/null 2>&1; then
- : already under /bin/ksh
- else
+: Test and see if we are running under ksh, either blatantly or in disguise.
+if (PATH=.; alias -x) >/dev/null 2>&1; then
+ : running under ksh. Is this a good thing?
+ if test -d /usr/lpp -a -f /usr/bin/bsh -a -f /usr/bin/uname ; then
+ if test X`/usr/bin/uname -v` = X4 ; then
+ : on AIX 4, /bin/sh is really ksh, and it causes us problems.
+ : Avoid it
cat <<'EOM'
-(Feeding myself to ksh to avoid nasty sh bug in "here document" expansion.)
+(Feeding myself to /usr/bin/bsh to avoid AIX 4's /bin/sh.)
EOM
unset ENV
- exec /bin/ksh $0 "$@"
+ exec /usr/bin/bsh $0 "$@"
fi
-else
+ else
+ if test ! -f /hp-ux ; then
: Warn them if they use ksh on other systems
- (PATH=.; alias -x) >/dev/null 2>&1 && \
cat <<EOM
(I see you are using the Korn shell. Some ksh's blow up on $me,
especially on older exotic systems. If yours does, try the Bourne
shell instead.)
EOM
+ fi
+ fi
+else
+ : Not running under ksh. Maybe we should be?
+ : On HP-UX, large Configure scripts may exercise a bug in /bin/sh
+ if test -f /hp-ux -a -f /bin/ksh; then
+ cat <<'EOM'
+(Feeding myself to ksh to avoid nasty sh bug in "here document" expansion.)
+EOM
+ unset ENV
+ exec /bin/ksh $0 "$@"
+ fi
fi
: Configure runs within the UU subdirectory
read answ
set x \$xxxm
shift
- aok=''; eval "ans=\"\$answ\"" && aok=y
+ aok=''; eval ans="\\"\$answ\\"" && aok=y
case "\$answ" in
"\$ans")
case "\$ans" in
y|Y) ;;
*) echo "Ok, avoiding sfio this time. I'll use stdio instead."
val="$undef"
+ : Remove sfio from list of libraries to use
+ set `echo X $libs | $sed -e 's/-lsfio / /' -e 's/-lsfio$//'`
+ shift
+ libs="$*"
+ echo "libs = $libs" >&4
;;
esac
;;
lib/ExtUtils/testlib.pm Fixes up @INC to use just-built extension
lib/ExtUtils/typemap Extension interface types
lib/ExtUtils/xsubpp External subroutine preprocessor
-lib/Fatal.pm Make do-or-die equivalents of functions
lib/File/Basename.pm Emulate the basename program
lib/File/CheckTree.pm Perl module supporting wholesale file mode validation
lib/File/Compare.pm Emulation of cmp command
t/lib/dirhand.t See if DirHandle works
t/lib/english.t See if English works
t/lib/env.t See if Env works
-t/lib/fatal.t See if Fatal works
t/lib/filecache.t See if FileCache works
t/lib/filecopy.t See if File::Copy works
t/lib/filefind.t See if File::Find works
vms/ext/Stdio/Stdio.pm VMS options to stdio routines
vms/ext/Stdio/Stdio.xs VMS options to stdio routines
vms/ext/Stdio/test.pl regression tests for VMS::Stdio
+vms/ext/XSSymSet.pm manage linker symbols when building extensions
vms/ext/filespec.t See if VMS::Filespec funtions work
+vms/ext/vmsish.pm Control VMS-specific behavior of Perl core
vms/fndvers.com parse Perl version from patchlevel.h
vms/gen_shrfls.pl generate options files and glue for shareable image
vms/genconfig.pl retcon config.sh from config.h
*/
struct xpvav {
- char* xav_array; /* pointer to malloced string */
+ char* xav_array; /* pointer to first array element */
SSize_t xav_fill;
SSize_t xav_max;
IV xof_off; /* ptr is incremented by offset */
MAGIC* xmg_magic; /* magic for scalar array */
HV* xmg_stash; /* class package */
- SV** xav_alloc;
+ SV** xav_alloc; /* pointer to malloced string */
SV* xav_arylen;
U8 xav_flags;
};
{
a = SvPV(astr, len);
if (len != infosize)
- croak("Bad arg length for %s, is %d, should be %d",
- op_desc[optype], len, infosize);
+ croak("Bad arg length for %s, is %d, should be %ld",
+ op_desc[optype], len, (long)infosize);
}
}
else
SPAGAIN ;
if (count != 1)
- croak ("DB_File btree_compare: expected 1 return value from %s, got %d\n", count) ;
+ croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ;
retval = POPi ;
SPAGAIN ;
if (count != 1)
- croak ("DB_File btree_prefix: expected 1 return value from %s, got %d\n", count) ;
+ croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ;
retval = POPi ;
SPAGAIN ;
if (count != 1)
- croak ("DB_File hash_cb: expected 1 return value from %s, got %d\n", count) ;
+ croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ;
retval = POPi ;
/* check for attempt to write before start of array */
if (length + value + 1 <= 0)
- croak("Modification of non-creatable array value attempted, subscript %d", value) ;
+ croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ;
value = length + value + 1 ;
}
if (myopcode >= maxo || myopcode < 0)
croak("panic: opcode \"%s\" value %d is invalid", opname, myopcode);
if (opcode_debug >= 2)
- warn("set_opset_bits bit %2d (off=%d, bit=%d) %s on\n",
+ warn("set_opset_bits bit %2d (off=%d, bit=%d) %s %s\n",
myopcode, offset, bit, opname, (on)?"on":"off");
if (on)
bitmap[offset] |= 1 << bit;
while(len-- > 0) bitmap[len] &= ~specbits[len];
}
else
- croak("panic: invalid bitspec for \"%s\" (type %d)",
- opname, SvTYPE(bitspec));
+ croak("panic: invalid bitspec for \"%s\" (type %u)",
+ opname, (unsigned)SvTYPE(bitspec));
}
assert(maxo < OP_MASK_BUF_SIZE);
opset_len = (maxo + 7) / 8;
if (opcode_debug >= 1)
- warn("opset_len %d\n", opset_len);
+ warn("opset_len %ld\n", (long)opset_len);
op_names_init();
}
}
else
- croak("panic: invalid bitspec for \"%s\" (type %d)",
- opname, SvTYPE(bitspec));
+ croak("panic: invalid bitspec for \"%s\" (type %u)",
+ opname, (unsigned)SvTYPE(bitspec));
}
#ifdef VMS
warn("Weird package name \"%s\" truncated", name);
#else
- warn("Weird package name \"%.*s...\" truncated", namelen, name);
+ warn("Weird package name \"%.*s...\" truncated", (int)namelen, name);
#endif
}
Copy(name,tmpbuf,namelen,char);
sv_setpv(GvSV(gv),chopset);
goto magicalize;
+ case '?':
+ if (len > 1)
+ break;
+#ifdef COMPLEX_STATUS
+ sv_upgrade(GvSV(gv), SVt_PVLV);
+#endif
+ goto magicalize;
+
case '#':
case '*':
if (dowarn && len == 1 && sv_type == SVt_PV)
/* FALL THROUGH */
case '[':
case '!':
- case '?':
case '^':
case '~':
case '=':
case '\017':
case '\t':
case '\020':
- case '\023':
case '\024':
case '\027':
if (len > 1)
*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 = *! ;
*ERRNO = *! ;
*EXTENDED_OS_ERROR = *^E ;
use vars qw($VERSION);
# Broken out of MakeMaker from version 4.11
-$VERSION = substr q$Revision: 1.21 $, 10;
+$VERSION = substr q$Revision: 1.22 $, 10;
use Config;
use Cwd 'cwd';
use vars qw($VERSION $Is_Mac $Is_OS2 $Is_VMS
$Verbose %pm %static $Xsubpp_Version);
-$VERSION = substr q$Revision: 1.109_01 $, 10;
-# $Id: MM_Unix.pm,v 1.109 1996/12/17 00:42:32 k Exp k $
+$VERSION = substr q$Revision: 1.113 $, 10;
+# $Id: MM_Unix.pm,v 1.113 1997/02/11 21:54:09 k Exp $
Exporter::import('ExtUtils::MakeMaker',
qw( $Verbose &neatvalue));
push(@m,' $(RANLIB) '."$ldfrom\n");
}
$ldfrom = "-all $ldfrom -none" if ($^O eq 'dec_osf');
- push(@m,' LD_RUN_PATH="$(LD_RUN_PATH)" $(LD) -o $@ $(LDDLFLAGS) '.$ldfrom.
+
+ # Brain dead solaris linker does not use LD_RUN_PATH?
+ # This fixes dynamic extensions which need shared libs
+ my $ldrun = '';
+ $ldrun = join ' ', map "-R$_", split /:/, $self->{LD_RUN_PATH}
+ if ($^O eq 'solaris');
+
+ push(@m,' LD_RUN_PATH="$(LD_RUN_PATH)" $(LD) -o $@ '.$ldrun.' $(LDDLFLAGS) '.$ldfrom.
' $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) $(EXPORT_LIST)');
push @m, '
$(CHMOD) 755 $@
foreach $component ($self->{PERL_SRC}, $self->path(), $Config::Config{binexp}) {
push @defpath, $component if defined $component;
}
- $self->{PERL} =
+ $self->{PERL} ||=
$self->find_perl(5.0, [ $^X, 'miniperl','perl','perl5',"perl$]" ],
- \@defpath, $Verbose ) unless ($self->{PERL});
+ \@defpath, $Verbose );
# don't check if perl is executable, maybe they have decided to
# supply switches with perl
$libperl = "$dir/$libperl";
$lperl ||= "libperl$self->{LIB_EXT}";
$lperl = "$dir/$lperl";
+
+ if (! -f $libperl and ! -f $lperl) {
+ # We did not find a static libperl. Maybe there is a shared one?
+ if ($^O eq 'solaris' or $^O eq 'sunos') {
+ $lperl = $libperl = "$dir/$Config::Config{libperl}";
+ # SUNOS ld does not take the full path to a shared library
+ $libperl = '' if $^O eq 'sunos';
+ }
+ }
+
print STDOUT "Warning: $libperl not found
If you're going to build a static perl binary, make sure perl is installed
otherwise ignore this warning\n"
foreach $catfile (@$extra){
push @m, "\tcat $catfile >> \$\@\n";
}
+ # SUNOS ld does not take the full path to a shared library
+ my $llibperl = ($libperl)?'$(MAP_LIBPERL)':'-lperl';
- push @m, "
+ # Brain dead solaris linker does not use LD_RUN_PATH?
+ # This fixes dynamic extensions which need shared libs
+ my $ldfrom = ($^O eq 'solaris')?
+ join(' ', map "-R$_", split /:/, $self->{LD_RUN_PATH}):'';
+
+push @m, "
\$(MAP_TARGET) :: $tmp/perlmain\$(OBJ_EXT) \$(MAP_LIBPERL) \$(MAP_STATIC) \$(INST_ARCHAUTODIR)/extralibs.all
- \$(MAP_LINKCMD) -o \$\@ \$(OPTIMIZE) $tmp/perlmain\$(OBJ_EXT) \$(MAP_LIBPERL) \$(MAP_STATIC) `cat \$(INST_ARCHAUTODIR)/extralibs.all` \$(MAP_PRELIBS)
+ \$(MAP_LINKCMD) -o \$\@ \$(OPTIMIZE) $tmp/perlmain\$(OBJ_EXT) $ldfrom $llibperl \$(MAP_STATIC) `cat \$(INST_ARCHAUTODIR)/extralibs.all` \$(MAP_PRELIBS)
$self->{NOECHO}echo 'To install the new \"\$(MAP_TARGET)\" binary, call'
$self->{NOECHO}echo ' make -f $makefilename inst_perl MAP_TARGET=\$(MAP_TARGET)'
$self->{NOECHO}echo 'To remove the intermediate files say'
Follows VMS naming conventions for executable files.
If the name passed in doesn't exactly match an executable file,
-appends F<.Exe> to check for executable image, and F<.Com> to check
-for DCL procedure. If this fails, checks F<Sys$System:> for an
-executable file having the name specified. Finally, appends F<.Exe>
-and checks again.
+appends F<.Exe> (or equivalent) to check for executable image, and F<.Com>
+to check for DCL procedure. If this fails, checks directories in DCL$PATH
+and finally F<Sys$System:> for an executable file having the name specified,
+with or without the F<.Exe>-equivalent suffix.
=cut
sub maybe_command {
my($self,$file) = @_;
return $file if -x $file && ! -d _;
- return "$file.exe" if -x "$file.exe";
- return "$file.com" if -x "$file.com";
+ my(@dirs) = ('');
+ my(@exts) = ('',$Config{'exe_ext'},'.exe','.com');
+ my($dir,$ext);
if ($file !~ m![/:>\]]!) {
- my($shrfile) = 'Sys$System:' . $file;
- return $file if -x $shrfile && ! -d _;
- return "$file.exe" if -x "$shrfile.exe";
+ for (my $i = 0; defined $ENV{"DCL\$PATH;$i"}; $i++) {
+ $dir = $ENV{"DCL\$PATH;$i"};
+ $dir .= ':' unless $dir =~ m%[\]:]$%;
+ push(@dirs,$dir);
+ }
+ push(@dirs,'Sys$System:');
+ foreach $dir (@dirs) {
+ my $sysfile = "$dir$file";
+ foreach $ext (@exts) {
+ return $file if -x "$sysfile$ext" && ! -d _;
+ }
+ }
}
return 0;
}
=item perl_script (override)
-If name passed in doesn't specify a readable file, appends F<.pl> and
-tries again, since it's customary to have file types on all files
+If name passed in doesn't specify a readable file, appends F<.com> or
+F<.pl> and tries again, since it's customary to have file types on all files
under VMS.
=cut
sub perl_script {
my($self,$file) = @_;
return $file if -r $file && ! -d _;
- return "$file.pl" if -r "$file.pl" && ! -d _;
+ return "$file.com" if -r "$file.com";
+ return "$file.pl" if -r "$file.pl";
return '';
}
INST_DYNAMIC =
INST_BOOT =
EXPORT_LIST = $(BASEEXT).opt
-PERL_ARCHIVE = ',($ENV{'PERLSHR'} ? $ENV{'PERLSHR'} : 'Sys$Share:PerlShr.Exe'),'
+PERL_ARCHIVE = ',($ENV{'PERLSHR'} ? $ENV{'PERLSHR'} : "Sys\$Share:PerlShr.$Config{'dlext'}"),'
';
}
my $command = "$self->{PERL} \"-I$self->{PERL_LIB}\" $xsubpp -v";
print "Running: $command\n" if $Verbose;
$version = `$command` ;
- warn "Running '$command' exits with status " . $? unless ($? & 1);
+ if ($?) {
+ use vmsish 'status';
+ warn "Running '$command' exits with status $?";
+ }
chop $version ;
return $1 if $version =~ /^xsubpp version (.*)/ ;
push @m, '
$(INST_DYNAMIC) : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt rtls.opt $(INST_ARCHAUTODIR).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP)
$(NOECHO) $(MKPATH) $(INST_ARCHAUTODIR)
- $(NOECHO) If F$TrnLNm("PerlShr").eqs."" Then Define/NoLog/User PerlShr Sys$Share:PerlShr.Exe
+ $(NOECHO) If F$TrnLNm("PerlShr").eqs."" Then Define/NoLog/User PerlShr Sys$Share:PerlShr.',$Config{'dlext'},'
Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) $(BASEEXT).opt/Option,rtls.opt/Option,$(PERL_INC)perlshr_attr.opt/Option
';
}
}
- $target = "Perl.Exe" unless $target;
+ $target = "Perl$Config{'exe_ext'}" unless $target;
($shrtarget,$targdir) = fileparse($target);
$shrtarget =~ s/^([^.]*)/$1Shr/;
$shrtarget = $targdir . $shrtarget;
package ExtUtils::MakeMaker;
-$Version = $VERSION = "5.39";
+$Version = $VERSION = "5.40";
$Version_OK = "5.17"; # Makefiles older than $Version_OK will die
# (Will be checked from MakeMaker version 4.13 onwards)
-($Revision = substr(q$Revision: 1.208 $, 10)) =~ s/\s+$//;
+($Revision = substr(q$Revision: 1.211 $, 10)) =~ s/\s+$//;
MakeMaker object. The following lines will be parsed o.k.:
$VERSION = '1.00';
- ( $VERSION ) = '$Revision: 1.208 $ ' =~ /\$Revision:\s+([^\s]+)/;
+ ( $VERSION ) = '$Revision: 1.211 $ ' =~ /\$Revision:\s+([^\s]+)/;
$FOO::VERSION = '1.10';
but these will fail:
use vars qw( @ISA @EXPORT $VERSION );
@ISA = 'Exporter';
@EXPORT = '&Mksymlists';
-$VERSION = substr q$Revision: 1.12 $, 10;
+$VERSION = substr q$Revision: 1.13 $, 10;
sub Mksymlists {
my(%spec) = @_;
my($data) = @_;
require Config; # a reminder for once we do $^O
+ require ExtUtils::XSSymSet;
my($isvax) = $Config::Config{'arch'} =~ /VAX/i;
+ my($set) = new ExtUtils::XSSymSet;
my($sym);
rename "$data->{FILE}.opt", "$data->{FILE}.opt_old";
# the GSMATCH criteria for a dynamic extension
foreach $sym (@{$data->{FUNCLIST}}) {
- if ($isvax) { print OPT "UNIVERSAL=$sym\n" }
- else { print OPT "SYMBOL_VECTOR=($sym=PROCEDURE)\n"; }
+ my $safe = $set->addsym($sym);
+ if ($isvax) { print OPT "UNIVERSAL=$safe\n" }
+ else { print OPT "SYMBOL_VECTOR=($safe=PROCEDURE)\n"; }
}
foreach $sym (@{$data->{DL_VARS}}) {
+ my $safe = $set->addsym($sym);
print OPT "PSECT_ATTR=${sym},PIC,OVR,RD,NOEXE,WRT,NOSHR\n";
- if ($isvax) { print OPT "UNIVERSAL=$sym\n" }
- else { print OPT "SYMBOL_VECTOR=($sym=DATA)\n"; }
+ if ($isvax) { print OPT "UNIVERSAL=$safe\n" }
+ else { print OPT "SYMBOL_VECTOR=($safe=DATA)\n"; }
}
close OPT;
use vars '$cplusplus';
# Global Constants
-$XSUBPP_version = "1.94001";
+$XSUBPP_version = "1.9401";
$Is_VMS = $^O eq 'VMS';
sub Q ;
my(@XSStack) = ({type => 'none'}); # Stack of conditionals and INCLUDEs
my($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA");
+my($SymSet);
+if ($Is_VMS) {
+ # Establish set of global symbols with max length 28, since xsubpp
+ # will later add the 'XS_' prefix.
+ require ExtUtils::XSSymSet;
+ $SymSet = new ExtUtils::XSSymSet 28;
+}
sub TrimWhitespace
{
($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
($clean_func_name = $func_name) =~ s/^$Prefix//;
$Full_func_name = "${Packid}_$clean_func_name";
+ if ($Is_VMS) { $Full_func_name = $SymSet->addsym($Full_func_name); }
# Check for duplicate function definition
for $tmp (@XSStack) {
sub Exit {
- # VMS error exit: SS$_ABORT.
- exit $errors ? ($Is_VMS ? 44 : 1) : 0;
+# If this is VMS, the exit status has meaning to the shell, so we
+# use a predictable value (SS$_Normal or SS$_Abort) rather than an
+# arbitrary number.
+# exit ($Is_VMS ? ($errors ? 44 : 1) : $errors) ;
+ exit ($errors ? 1 : 0);
}
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)STATUS_POSIX);
+ sv_setiv(sv, (IV)STATUS_CURRENT);
+#ifdef COMPLEX_STATUS
+ LvTARGOFF(sv) = statusvalue;
+ LvTARGLEN(sv) = statusvalue_vms;
+#endif
break;
case '^':
s = IoTOP_NAME(GvIOp(defoutgv));
warn("No such signal: SIG%s", s);
return 0;
}
- if(psig_ptr[i])
- SvREFCNT_dec(psig_ptr[i]);
+ SvREFCNT_dec(psig_name[i]);
+ SvREFCNT_dec(psig_ptr[i]);
psig_ptr[i] = SvREFCNT_inc(sv);
- if(psig_name[i])
- SvREFCNT_dec(psig_name[i]);
- psig_name[i] = newSVpv(s,strlen(s));
SvTEMP_off(sv); /* Make sure it doesn't go away on us */
+ psig_name[i] = newSVpv(s, strlen(s));
SvREADONLY_on(psig_name[i]);
}
if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
}
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 '?':
- STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+#ifdef COMPLEX_STATUS
+ if (localizing == 2) {
+ statusvalue = LvTARGOFF(sv);
+ statusvalue_vms = LvTARGLEN(sv);
+ }
+ else
+#endif
+#ifdef VMSISH_STATUS
+ if (VMSISH_STATUS)
+ STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
+ else
+#endif
+ STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
break;
case '!':
SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv),
SV *sv;
CV *cv;
AV *oldstack;
-
- if(!psig_ptr[sig])
- die("Signal SIG%s received, but no signal handler set.\n",
- sig_name[sig]);
+ bool long_savestack = (savestack_ix + 14) < savestack_max;
+ bool long_cxstack = (cxstack_ix + 1) < cxstack_max;
+
+ /* Protect PUSHXXX in progress. */
+ if (long_cxstack)
+ cxstack_ix++;
+
+ if (!psig_ptr[sig])
+ die("Signal SIG%s received, but no signal handler set.\n",
+ sig_name[sig]);
+
+ /*
+ * Protect save in progress. Max number of items pushed there is
+ * 3*n or 4. We cannot fix infinity, so we fix 4 (in fact 5).
+ */
+ if (long_savestack)
+ savestack_ix += 5;
cv = sv_2cv(psig_ptr[sig],&st,&gv,TRUE);
if (!cv || !CvROOT(cv)) {
if(psig_name[sig])
sv = SvREFCNT_inc(psig_name[sig]);
else {
- sv = sv_newmortal();
- sv_setpv(sv,sig_name[sig]);
+ sv = sv_newmortal();
+ sv_setpv(sv,sig_name[sig]);
}
PUSHMARK(sp);
PUSHs(sv);
perl_call_sv((SV*)cv, G_DISCARD);
SWITCHSTACK(signalstack, oldstack);
-
+ if (long_savestack)
+ savestack_ix -= 5; /* Unprotect save in progress. */
+ if (long_cxstack)
+ cxstack_ix--; /* Unprotect PUSHXXX in progress. */
+
return;
}
if (!po)
croak("panic: pad_free po");
DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad free %d\n", po));
- if (curpad[po] && curpad[po] != &sv_undef)
+ if (curpad[po] && !SvIMMORTAL(curpad[po]))
SvPADTMP_off(curpad[po]);
if ((I32)po < padix)
padix = po - 1;
DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad reset\n"));
if (!tainting) { /* Can't mix tainted and non-tainted temporaries. */
for (po = AvMAX(comppad); po > padix_floor; po--) {
- if (curpad[po] && curpad[po] != &sv_undef)
+ if (curpad[po] && !SvIMMORTAL(curpad[po]))
SvPADTMP_off(curpad[po]);
}
padix = padix_floor;
}
cop->op_flags = flags;
cop->op_private = 0 | (flags >> 8);
+#ifdef NATIVE_HINTS
+ cop->op_private |= NATIVE_HINTS;
+#endif
cop->op_next = (OP*)cop;
if (label) {
OP *newop = newAVREF(newGVOP(OP_GV, 0,
gv_fetchpv(name, TRUE, SVt_PVAV) ));
if (dowarn)
- warn("Array @%s missing the @ in argument %d of %s()",
- name, numargs, op_desc[type]);
+ warn("Array @%s missing the @ in argument %ld of %s()",
+ name, (long)numargs, op_desc[type]);
op_free(kid);
kid = newop;
kid->op_sibling = sibl;
OP *newop = newHVREF(newGVOP(OP_GV, 0,
gv_fetchpv(name, TRUE, SVt_PVHV) ));
if (dowarn)
- warn("Hash %%%s missing the %% in argument %d of %s()",
- name, numargs, op_desc[type]);
+ warn("Hash %%%s missing the %% in argument %ld of %s()",
+ name, (long)numargs, op_desc[type]);
op_free(kid);
kid = newop;
kid->op_sibling = sibl;
#define PATCHLEVEL 3
-#define SUBVERSION 26
+#define SUBVERSION 27
/*
local_patches -- list of locally applied less-than-subversion patches.
LEAVE;
FREETMPS;
- /* We must account for everything. First the syntax tree. */
+ /* We must account for everything. */
+
+ /* Destroy the main CV and syntax tree */
if (main_root) {
curpad = AvARRAY(comppad);
op_free(main_root);
- main_root = 0;
+ main_root = Nullop;
}
+ main_start = Nullop;
+ SvREFCNT_dec(main_cv);
+ main_cv = Nullcv;
+
if (sv_objcount) {
/*
* Try to destruct global references. We do this first so that the
FREETMPS;
if (destruct_level >= 2) {
if (scopestack_ix != 0)
- warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix);
+ warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
+ (long)scopestack_ix);
if (savestack_ix != 0)
- warn("Unbalanced saves: %d more saves than restores\n", savestack_ix);
+ warn("Unbalanced saves: %ld more saves than restores\n",
+ (long)savestack_ix);
if (tmps_floor != -1)
- warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1);
+ warn("Unbalanced tmps: %ld more allocs than frees\n",
+ (long)tmps_floor + 1);
if (cxstack_ix != -1)
- warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1);
+ warn("Unbalanced context: %ld more PUSHes than POPs\n",
+ (long)cxstack_ix + 1);
}
/* Now absolutely destruct everything, somehow or other, loops or no. */
SvREFCNT_dec(strtab);
if (sv_count != 0)
- warn("Scalars leaked: %d\n", sv_count);
+ warn("Scalars leaked: %ld\n", (long)sv_count);
sv_free_arenas();
return 0;
}
- SvREFCNT_dec(main_cv);
- if (main_root)
+ if (main_root) {
+ curpad = AvARRAY(comppad);
op_free(main_root);
- main_cv = 0;
- main_start = main_root = 0;
+ main_root = Nullop;
+ }
+ main_start = Nullop;
+ SvREFCNT_dec(main_cv);
+ main_cv = Nullcv;
time(&basetime);
(void)PerlIO_close(rsfp);
if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
PerlIO_printf(rsfp,
-"User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
-(Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
- uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
- statbuf.st_dev, statbuf.st_ino,
+"User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
+(Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
+ (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
+ (long)statbuf.st_dev, (long)statbuf.st_ino,
SvPVX(GvSV(curcop->cop_filegv)),
- statbuf.st_uid, statbuf.st_gid);
+ (long)statbuf.st_uid, (long)statbuf.st_gid);
(void)my_pclose(rsfp);
}
croak("Permission denied\n");
STATUS_NATIVE_SET(44);
}
else {
- if (!vaxc$errno && errno) /* someone must have set $^E = 0 */
+ if (!vaxc$errno && errno) /* unlikely */
STATUS_NATIVE_SET(44);
else
STATUS_NATIVE_SET(vaxc$errno);
POPBLOCK(cx,curpm);
LEAVE;
}
+
Siglongjmp(top_env, 2);
}
# endif
#endif
-#define STATUS_POSIX statusvalue
-#define STATUS_POSIX_SET(n) \
- STMT_START { \
- statusvalue = (n); \
- if (statusvalue != -1) \
- statusvalue &= 0xFFFF; \
- } STMT_END
-
#ifdef VMS
# define STATUS_NATIVE statusvalue_vms
# define STATUS_NATIVE_EXPORT \
- ((I32)statusvalue_vms == -1 ? 4 : statusvalue_vms)
+ ((I32)statusvalue_vms == -1 ? 44 : statusvalue_vms)
# define STATUS_NATIVE_SET(n) \
STMT_START { \
statusvalue_vms = (n); \
else \
statusvalue = (statusvalue_vms & STS$M_SEVERITY) << 8; \
} STMT_END
+# define STATUS_POSIX statusvalue
+# ifdef VMSISH_STATUS
+# define STATUS_CURRENT (VMSISH_STATUS ? STATUS_NATIVE : STATUS_POSIX)
+# else
+# define STATUS_CURRENT STATUS_POSIX
+# endif
+# define STATUS_POSIX_SET(n) \
+ STMT_START { \
+ statusvalue = (n); \
+ if (statusvalue != -1) { \
+ statusvalue &= 0xFFFF; \
+ statusvalue_vms = statusvalue ? 44 : 1; \
+ } \
+ else statusvalue_vms = -1; \
+ } STMT_END
# define STATUS_ALL_SUCCESS (statusvalue = 0, statusvalue_vms = 1)
-# define STATUS_ALL_FAILURE (statusvalue = 1, statusvalue_vms = 4)
+# define STATUS_ALL_FAILURE (statusvalue = 1, statusvalue_vms = 44)
#else
# define STATUS_NATIVE STATUS_POSIX
# define STATUS_NATIVE_EXPORT STATUS_POSIX
# define STATUS_NATIVE_SET STATUS_POSIX_SET
+# define STATUS_POSIX statusvalue
+# define STATUS_POSIX_SET(n) \
+ STMT_START { \
+ statusvalue = (n); \
+ if (statusvalue != -1) \
+ statusvalue &= 0xFFFF; \
+ } STMT_END
+# define STATUS_CURRENT STATUS_POSIX
# define STATUS_ALL_SUCCESS (statusvalue = 0)
# define STATUS_ALL_FAILURE (statusvalue = 1)
#endif
# ifdef convex
# define Quad_t long long
# else
-# if defined(VMS) && defined(__ALPHA)
-# define Quad_t __int64
-# else
-# if BYTEORDER > 0xFFFF
-# define Quad_t long
-# endif
+# if BYTEORDER > 0xFFFF
+# define Quad_t long
# endif
# endif
#endif
IEXT int Imultiline; /* $*--do strings hold >1 line? */
IEXT I32 Istatusvalue; /* $? */
#ifdef VMS
-IEXT U32 Istatusvalue_vms; /* $^S */
+IEXT U32 Istatusvalue_vms;
#endif
IEXT struct stat Istatcache; /* _ */
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
# implies:
A->VERSION(1.2);
-=item class()
-
-C<class> returns the class name of its object.
-
-=item is_instance()
-
-C<is_instance> returns true if its object is an instance of some
-class, false if its object is the class (package) itself. Example
-
- A->is_instance(); # False
-
- $var = 'A';
- $var->is_instance(); # False
-
- $ref = bless [], 'A';
- $ref->is_instance(); # True
-
-This can be useful for methods that wish to easily distinguish
-whether they were invoked as class or as instance methods.
-
- sub some_meth {
- my $classname = shift;
- if ($classname->is_instance()) {
- die "unexpectedly called as instance not class method";
- }
- .....
- }
-
=back
B<NOTE:> C<can> directly uses Perl's internal code for method lookup, and
=head1 Pragmata
-Three new pragmatic modules exist:
+Four new pragmatic modules exist:
=over
Disable unsafe opcodes, or any named opcodes, when compiling Perl code.
+=item use vmsish
+
+Enable VMS-specific language features. Currently, there are three
+VMS-specific feature available: 'status', which makes C<$?> and
+C<system> return genuine VMS status values instead of emulating POSIX;
+'exit', which makes C<exit> take a genuine VMS status value instead of
+assuming that C<exit 1> is an error; and 'time', which makes all times
+relative to the local time zone, in the VMS tradition.
+
=back
=head1 Modules
ExtUtils/Embed.pm Utilities for embedding Perl in C programs
ExtUtils/testlib.pm Fixes up @INC to use just-built extension
- Fatal.pm Make do-or-die equivalents of functions
FindBin.pm Find path of currently executing program
Class/Template.pm Structure/member template builder
pre-declare sub names
+=item vmsish
+
+adopt certain VMS-specific behaviors
+
=item vars
pre-declare global variable names
add blib/* directories to @INC
-=item Fatal
-
-replace functions with equivalents which succeed or die
-
=item Fcntl
load the C Fcntl.h defines
# implies:
A->VERSION(1.2);
-=item class()
-
-C<class> returns the class name of its object.
-
-=item is_instance()
-
-C<is_instance> returns true if its object is an instance of some
-class, false if its object is the class (package) itself. Example
-
- A->is_instance(); # False
-
- $var = 'A';
- $var->is_instance(); # False
-
- $ref = bless [], 'A';
- $ref->is_instance(); # True
-
=back
B<NOTE:> C<can> directly uses Perl's internal code for method lookup, and
tells Perl that the script is embedded in a message. Leading
garbage will be discarded until the first line that starts with #! and
contains the string "perl". Any meaningful switches on that line will
-be applied (but only one group of switches, as with normal #!
-processing). If a directory name is specified, Perl will switch to
+be applied. If a directory name is specified, Perl will switch to
that directory before running the script. The B<-x> switch controls
only the disposal of leading garbage. The script must be
terminated with C<__END__> if there is trailing garbage to be ignored (the
=item New and Changed Built-in Variables
-$^E, $^H, $^M, $^S
+$^E, $^H, $^M
=item New and Changed Built-in Functions
=item New Built-in Methods
-isa(CLASS), can(METHOD), VERSION( [NEED] ), class(), is_instance()
+isa(CLASS), can(METHOD), VERSION( [NEED] )
=item TIEHANDLE Now Supported
=item Pragmata
-use blib, use blib 'dir', use locale, use ops
+use blib, use blib 'dir', use locale, use ops, use vmsish
=item Modules
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, $?, $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}
+$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}
=back
=item Pragmatic Modules
blib, diagnostics, integer, less, lib, locale, ops, overload, sigtrap,
-strict, subs, vars
+strict, subs, vmsish, vars
=item Standard Modules
DirHandle, DynaLoader, English, Env, Exporter, ExtUtils::Embed,
ExtUtils::Install, ExtUtils::Liblist, ExtUtils::MM_OS2, ExtUtils::MM_Unix,
ExtUtils::MM_VMS, ExtUtils::MakeMaker, ExtUtils::Manifest,
-ExtUtils::Mkbootstrap, ExtUtils::Mksymlists, ExtUtils::testlib, Fatal,
-Fcntl, File::Basename, File::CheckTree, File::Compare, File::Copy,
-File::Find, File::Path, File::stat, FileCache, FileHandle, FindBin,
-GDBM_File, Getopt::Long, Getopt::Std, I18N::Collate, IO, IO::File,
-IO::Handle, IO::Pipe, IO::Seekable, IO::Select, IO::Socket, IPC::Open2,
-IPC::Open3, Math::BigFloat, Math::BigInt, Math::Complex, NDBM_File,
-Net::Ping, Net::hostent, Net::netent, Net::protoent, Net::servent, Opcode,
-Pod::Text, POSIX, SDBM_File, Safe, Search::Dict, SelectSaver, SelfLoader,
-Shell, Socket, Symbol, Sys::Hostname, Sys::Syslog, Term::Cap,
-Term::Complete, Term::ReadLine, Test::Harness, Text::Abbrev,
-Text::ParseWords, Text::Soundex, Text::Tabs, Text::Wrap, Tie::Hash,
-Tie::RefHash, Tie::Scalar, Tie::SubstrHash, Time::Local, Time::gmtime,
-Time::localtime, Time::tm, UNIVERSAL, User::grent, User::pwent
+ExtUtils::Mkbootstrap, ExtUtils::Mksymlists, ExtUtils::testlib, Fcntl,
+File::Basename, File::CheckTree, File::Compare, File::Copy, File::Find,
+File::Path, File::stat, FileCache, FileHandle, FindBin, GDBM_File,
+Getopt::Long, Getopt::Std, I18N::Collate, IO, IO::File, IO::Handle,
+IO::Pipe, IO::Seekable, IO::Select, IO::Socket, IPC::Open2, IPC::Open3,
+Math::BigFloat, Math::BigInt, Math::Complex, NDBM_File, Net::Ping,
+Net::hostent, Net::netent, Net::protoent, Net::servent, Opcode, Pod::Text,
+POSIX, SDBM_File, Safe, Search::Dict, SelectSaver, SelfLoader, Shell,
+Socket, Symbol, Sys::Hostname, Sys::Syslog, Term::Cap, Term::Complete,
+Term::ReadLine, Test::Harness, Text::Abbrev, Text::ParseWords,
+Text::Soundex, Text::Tabs, Text::Wrap, Tie::Hash, Tie::RefHash,
+Tie::Scalar, Tie::SubstrHash, Time::Local, Time::gmtime, Time::localtime,
+Time::tm, UNIVERSAL, User::grent, User::pwent
=item Extension Modules
=item Default UNIVERSAL methods
-isa(CLASS), can(METHOD), VERSION( [NEED] ), class(), is_instance()
+isa(CLASS), can(METHOD), VERSION( [NEED] )
=item Destructors
=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 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 Fatal - replace functions with equivalents which succeed or die
-
-=item SYNOPSIS
-
-=item DESCRIPTION
-
-=item AUTHOR
-
=head2 Fcntl - load the C Fcntl.h defines
=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 (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>.)
+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). 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.)
+Under VMS, the pragma C<use vmsish 'status'> make C<$?> reflect the
+actual VMS exit status, instead of the default emulation of POSIX
+status.
=item $OS_ERROR
$libdir/ExtUtils::Manifest.3 \
$libdir/ExtUtils::Mkbootstrap.3 \
$libdir/ExtUtils::Mksymlists.3 \
- $libdir/Fatal.3 \
$libdir/Fcntl.3 \
$libdir/File::Basename.3 \
$libdir/File::CheckTree.3 \
dPOPTOPnnrl;
I32 value;
- if (left < right)
- value = -1;
- else if (left == right)
+ if (left == right)
value = 0;
+ else if (left < right)
+ value = -1;
else if (left > right)
value = 1;
else {
if (ix >= max || !(*lelem = firstrelem[ix]))
*lelem = &sv_undef;
}
- if (!is_something_there && (SvOKp(*lelem) || SvGMAGICAL(*lelem)))
+ if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
is_something_there = TRUE;
}
if (is_something_there)
if (MAXARG < 1)
anum = 0;
- else
+ else {
anum = SvIVx(POPs);
+#ifdef VMSISH_EXIT
+ if (anum == 1 && VMSISH_EXIT)
+ anum = 0;
+#endif
+ }
my_exit(anum);
PUSHs(&sv_undef);
RETURN;
/* switch to eval mode */
SAVESPTR(compiling.cop_filegv);
- sprintf(tmpbuf, "_<(eval %d)", ++evalseq);
+ sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++evalseq);
compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
compiling.cop_line = 1;
/* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
mg = mg_find(sv, 'q') ;
if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
- warn("untie attempted while %d inner references still exist",
- SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
+ warn("untie attempted while %lu inner references still exist",
+ (unsigned long)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
}
}
STATUS_NATIVE_SET(result == -1 ? -1 : status);
do_execfree(); /* free any memory child malloced on vfork */
SP = ORIGMARK;
- PUSHi(STATUS_POSIX);
+ PUSHi(STATUS_CURRENT);
RETURN;
}
if (op->op_flags & OPf_STACKED) {
STATUS_NATIVE_SET(value);
do_execfree();
SP = ORIGMARK;
- PUSHi(STATUS_POSIX);
+ PUSHi(STATUS_CURRENT);
#endif /* !FORK or VMS */
RETURN;
}
#ifdef BSD_GETPGRP
value = (I32)BSD_GETPGRP(pid);
#else
- if (pid != 0)
+ if (pid != 0 && pid != getpid()) {
DIE("POSIX getpgrp can't take an argument");
value = (I32)getpgrp();
#endif
#ifdef BSD_SETPGRP
SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
#else
- if ((pgrp != 0) || (pid != 0)) {
+ if ((pgrp != 0 && pgrp != getpid())) || (pid != 0 && pid != getpid())) {
DIE("POSIX setpgrp can't take an argument");
}
SETi( setpgrp() >= 0 );
break;
case '$':
case '@':
- croak("Sequence (?%c...) not implemented", paren);
+ croak("Sequence (?%c...) not implemented", (int)paren);
break;
case '#':
while (*regparse && *regparse != ')')
register char *s;
register char *send;
register char *sbegin;
- I32 numtype = 1;
+ I32 numtype;
STRLEN len;
if (SvPOK(sv)) {
s = sbegin;
while (isSPACE(*s))
s++;
- if (s >= send)
- return 0;
if (*s == '+' || *s == '-')
s++;
- while (isDIGIT(*s))
- s++;
- if (s == send)
- return numtype;
- if (*s == '.') {
- numtype = 1;
- s++;
+
+ /* next must be digit or '.' */
+ if (isDIGIT(*s)) {
+ do {
+ s++;
+ } while (isDIGIT(*s));
+ if (*s == '.') {
+ s++;
+ while (isDIGIT(*s)) /* optional digits after "." */
+ s++;
+ }
}
- else if (s == SvPVX(sv))
- return 0;
- while (isDIGIT(*s))
- s++;
- if (s == send)
- return numtype;
+ else if (*s == '.') {
+ s++;
+ /* no digits before '.' means we need digits after it */
+ if (isDIGIT(*s)) {
+ do {
+ s++;
+ } while (isDIGIT(*s));
+ }
+ else
+ return 0;
+ }
+ else
+ return 0;
+
+ /*
+ * we return 1 if the number can be converted to _integer_ with atol()
+ * and 2 if you need (int)atof().
+ */
+ numtype = 1;
+
+ /* we can have an optional exponent part */
if (*s == 'e' || *s == 'E') {
numtype = 2;
s++;
if (*s == '+' || *s == '-')
s++;
- while (isDIGIT(*s))
- s++;
+ if (isDIGIT(*s)) {
+ do {
+ s++;
+ } while (isDIGIT(*s));
+ }
+ else
+ return 0;
}
while (isSPACE(*s))
s++;
Safefree(mg->mg_ptr);
s = SvPV(sv, len);
if ((xf = mem_collxfrm(s, len, &xlen))) {
+ if (SvREADONLY(sv)) {
+ SAVEFREEPV(xf);
+ *nxp = xlen;
+ return xf;
+ }
if (! mg) {
sv_magic(sv, 0, 'o', 0, 0);
mg = mg_find(sv, 'o');
mg->mg_len = xlen;
}
else {
- mg->mg_ptr = NULL;
- mg->mg_len = -1;
+ if (mg) {
+ mg->mg_ptr = NULL;
+ mg->mg_len = -1;
+ }
}
}
if (mg && mg->mg_ptr) {
# check UNIVERSAL
#
-print "1..4\n";
-
-# explicit bless
+print "1..11\n";
$a = {};
bless $a, "Bob";
-if ($a->class eq "Bob") {print "ok 1\n";} else {print "not ok 1\n";}
+print "not " unless $a->isa("Bob");
+print "ok 1\n";
-# bless through a package
+package Human;
+sub eat {}
-package Fred;
+package Female;
+@ISA=qw(Human);
-$b = {};
-bless $b;
-if ($b->class eq "Fred") {print "ok 2\n";} else {print "not ok 2\n";}
+package Alice;
+@ISA=qw(Bob Female);
+sub drink {}
+sub new { bless {} }
package main;
+$a = new Alice;
-# same as test 1 and 2, but with other object syntax
+print "not " unless $a->isa("Alice");
+print "ok 2\n";
-# explicit bless
+print "not " unless $a->isa("Bob");
+print "ok 3\n";
-$a = {};
-bless $a, "Bob";
-if (class $a eq "Bob") {print "ok 3\n";} else {print "not ok 3\n";}
+print "not " unless $a->isa("Female");
+print "ok 4\n";
+
+print "not " unless $a->isa("Human");
+print "ok 5\n";
+
+print "not " if $a->isa("Male");
+print "ok 6\n";
+
+print "not " unless $a->can("drink");
+print "ok 7\n";
+
+print "not " unless $a->can("eat");
+print "ok 8\n";
-# bless through a package
+print "not " if $a->can("sleep");
+print "ok 9\n";
-package Fred;
+print "not " unless UNIVERSAL::isa([], "ARRAY");
+print "ok 10\n";
-$b = {};
-bless $b;
-if (class $b eq "Fred") {print "ok 4\n";} else {print "not ok 4\n";}
+print "not " unless UNIVERSAL::isa({}, "HASH");
+print "ok 11\n";
die("Can't upgrade filter_add data to SVt_PVIO");
IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
if (filter_debug)
- warn("filter_add func %lx (%s)", funcp, SvPV(datasv,na));
+ warn("filter_add func %p (%s)", funcp, SvPV(datasv,na));
av_unshift(rsfp_filters, 1);
av_store(rsfp_filters, 0, datasv) ;
return(datasv);
filter_t funcp;
{
if (filter_debug)
- warn("filter_del func %lx", funcp);
+ warn("filter_del func %p", funcp);
if (!rsfp_filters || AvFILL(rsfp_filters)<0)
return;
/* if filter is on top of stack (usual case) just pop it off */
/* Get function pointer hidden within datasv */
funcp = (filter_t)IoDIRP(datasv);
if (filter_debug)
- warn("filter_read %d: via function %lx (%s)\n",
+ warn("filter_read %d: via function %p (%s)\n",
idx, funcp, SvPV(datasv,na));
/* Call function. The function is expected to */
/* call "FILTER_READ(idx+1, buf_sv)" first. */
}
goto retry;
case '\r':
- croak("Illegal character \\%03o (carriage return)");
+ croak("Illegal character \\%03o (carriage return)", '\r');
case ' ': case '\t': case '\f': case 013:
s++;
goto retry;
if (strnEQ(s,"=>",2)) {
if (dowarn)
warn("Ambiguous use of -%c => resolved to \"-%c\" =>",
- tmp, tmp);
+ (int)tmp, (int)tmp);
s = force_word(bufptr,WORD,FALSE,FALSE,FALSE);
OPERATOR('-'); /* unary minus */
}
case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
default:
- croak("Unrecognized file test: -%c", tmp);
+ croak("Unrecognized file test: -%c", (int)tmp);
break;
}
}
if (tmp == '~')
PMop(OP_MATCH);
if (dowarn && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
- warn("Reversed %c= operator",tmp);
+ warn("Reversed %c= operator",(int)tmp);
s--;
if (expect == XSTATE && isALPHA(tmp) &&
(s == linestart+1 || s[-2] == '\n') )
return s;
}
if (*s == '$' && s[1] &&
- (isALPHA(s[1]) || strchr("$_{", s[1]) || strnEQ(s+1,"::",2)) )
+ (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
return s;
if (*s == '{') {
bracket = s;
if (multi_start < multi_end && (U32)(curcop->cop_line - multi_end) <= 1) {
sprintf(buf+strlen(buf),
" (Might be a runaway multi-line %c%c string starting on line %ld)\n",
- multi_open,multi_close,(long)multi_start);
+ (int)multi_open,(int)multi_close,(long)multi_start);
multi_end = 0;
}
if (in_eval & 2)
}
static
-XS(XS_UNIVERSAL_is_instance)
-{
- dXSARGS;
- ST(0) = SvROK(ST(0)) ? &sv_yes : &sv_no;
- XSRETURN(1);
-}
-
-static
-XS(XS_UNIVERSAL_class)
-{
- dXSARGS;
- if(SvROK(ST(0)) && SvOBJECT(SvRV(ST(0)))) {
- SV *sv = sv_newmortal();
- sv_setpv(sv, HvNAME(SvSTASH(SvRV(ST(0)))));
- ST(0) = sv;
- }
- XSRETURN(1);
-}
-
-static
XS(XS_UNIVERSAL_VERSION)
{
dXSARGS;
newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
- newXS("UNIVERSAL::class", XS_UNIVERSAL_class, file);
- newXS("UNIVERSAL::is_instance", XS_UNIVERSAL_is_instance, file);
newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
}
$Is_VMS = $^O eq 'VMS';
sub usage{
- warn "@_\n" if @_;
- # Make sure exit status is success under VMS, so shell doesn't
- # display error messages left over from startup.
- ($! = 0, $^E = 1) if $^O eq 'VMS';
+ warn "@_\n" if @_;
+ # Erase evidence of previous errors (if any), so exit status is simple.
+ $! = 0;
die <<EOF;
perldoc [options] PageName|ModuleName|ProgramName...
perldoc [options] -f BuiltinFunction
OBJVAL = $@
# Updated by fndvers.com -- do not edit by hand
-PERL_VERSION = 5_00326#
+PERL_VERSION = 5_00327#
ARCHDIR = [.lib.$(ARCH).$(PERL_VERSION)]
$(XSUBPP) $< >$(MMS$SOURCE_NAME).c
$(CC) $(CFLAGS) $(MMS$SOURCE_NAME).c
+# Modules which must be installed before we can build extensions
+LIBPREREQ = $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib]vmsish.pm [.lib.VMS]Filespec.pm [.lib.ExtUtils]XSSymSet.pm
+
utils1 = [.lib.pod]perldoc.com [.lib.ExtUtils]Miniperl.pm [.utils]c2ph.com [.utils]h2ph.com [.utils]h2xs.com [.lib]perlbug.com
utils2 = [.lib]splain.com [.utils]pl2pm.com
@ $(NOOP)
extras : Fcntl IO Opcode $(POSIX) libmods utils podxform
@ $(NOOP)
-libmods : [.lib]Config.pm $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm
+libmods : $(LIBPREREQ)
@ $(NOOP)
utils : $(utils1) $(utils2)
@ $(NOOP)
@ $(NOOP)
pod1 = [.lib.pod]perl.pod [.lib.pod]perlapio.pod [.lib.pod]perlbook.pod [.lib.pod]perlbot.pod [.lib.pod]perlcall.pod
-pod2 = [.lib.pod]perldata.pod [.lib.pod]perldebug.pod [.lib.pod]perldiag.pod [.lib.pod]perldsc.pod
+pod2 = [.lib.pod]perldata.pod [.lib.pod]perldebug.pod [.lib.pod]perldelta.pod [.lib.pod]perldiag.pod [.lib.pod]perldsc.pod
pod3 = [.lib.pod]perlembed.pod [.lib.pod]perlform.pod [.lib.pod]perlfunc.pod [.lib.pod]perlguts.pod
pod4 = [.lib.pod]perlipc.pod [.lib.pod]perllocale.pod [.lib.pod]perllol.pod [.lib.pod]perlmod.pod [.lib.pod]perlobj.pod
-pod5 = [.lib.pod]perlop.pod [.lib.pod]perlpod.pod [.lib.pod]perlre.pod
-pod6 = [.lib.pod]perlref.pod [.lib.pod]perlrun.pod [.lib.pod]perlsec.pod [.lib.pod]perlstyle.pod
-pod7 = [.lib.pod]perlsub.pod [.lib.pod]perlsyn.pod [.lib.pod]perltie.pod [.lib.pod]perltoc.pod
+pod5 = [.lib.pod]perlop.pod [.lib.pod]perlpod.pod [.lib.pod]perlre.pod [.lib.pod]perlref.pod [.lib.pod]perlrun.pod
+pod6 = [.lib.pod]perlsec.pod [.lib.pod]perlstyle.pod [.lib.pod]perlsub.pod [.lib.pod]perlsyn.pod
+pod7 = [.lib.pod]perltie.pod [.lib.pod]perltoc.pod [.lib.pod]perltoot.pod
pod8 = [.lib.pod]perltrap.pod [.lib.pod]perlvar.pod [.lib.pod]perlxs.pod [.lib.pod]perlxstut.pod
perlpods : $(pod1) $(pod2) $(pod3) $(pod4) $(pod5) $(pod6) $(pod7) $(pod8) [.lib.pod]perlvms.pod
@ Delete/NoLog/NoConfirm genconfig.opt;
$(MINIPERL) ConfigPM.
-[.ext.dynaloader]dl_vms.c : [.ext.dynaloader]dl_vms.xs $(MINIPERL_EXE)
+[.ext.dynaloader]dl_vms.c : [.ext.dynaloader]dl_vms.xs [.lib.ExtUtils]XSSymSet.pm $(MINIPERL_EXE)
$(XSUBPP) [.ext.dynaloader]dl_vms.xs >$@
[.ext.dynaloader]dl_vms$(O) : [.ext.dynaloader]dl_vms.c
# Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir>
# ${@} necessary to distract different versions of MM[SK]/make
-[.ext.Opcode]Makefile : [.ext.Opcode]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E)
+[.ext.Opcode]Makefile : [.ext.Opcode]Makefile.PL $(LIBPREREQ) $(DBG)perlshr$(E)
$(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Opcode]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
Fcntl : [.lib]Fcntl.pm [.lib.auto.Fcntl]Fcntl$(E)
# Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir>
# ${@} necessary to distract different versions of MM[SK]/make
-[.ext.Fcntl]Makefile : [.ext.Fcntl]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E)
+[.ext.Fcntl]Makefile : [.ext.Fcntl]Makefile.PL $(LIBPREREQ) $(DBG)perlshr$(E)
$(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Fcntl]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
POSIX : [.lib]POSIX.pm [.lib.auto.POSIX]POSIX$(E)
# Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir>
# ${@} necessary to distract different versions of MM[SK]/make
-[.ext.POSIX]Makefile : [.ext.POSIX]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E)
+[.ext.POSIX]Makefile : [.ext.POSIX]Makefile.PL $(LIBPREREQ) $(DBG)perlshr$(E)
$(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.POSIX]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
IO : [.lib]IO.pm [.lib.IO]File.pm [.lib.IO]Handle.pm [.lib.IO]Pipe.pm [.lib.IO]Seekable.pm [.lib.IO]Socket.pm [.lib.auto.IO]IO$(E)
# Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir>
# ${@} necessary to distract different versions of MM[SK]/make
-[.ext.IO]Makefile : [.ext.IO]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E)
+[.ext.IO]Makefile : [.ext.IO]Makefile.PL $(LIBPREREQ) $(DBG)perlshr$(E)
$(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.IO]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
+[.lib]vmsish.pm : [.vms.ext]vmsish.pm
+ Copy/Log/NoConfirm [.vms.ext]vmsish.pm $@
+
[.lib.VMS]Filespec.pm : [.vms.ext]Filespec.pm
@ If f$$Search("[.lib]VMS.Dir").eqs."" Then Create/Directory [.lib.VMS]
Copy/Log/NoConfirm [.vms.ext]Filespec.pm $@
+[.lib.ExtUtils]XSSymSet.pm : [.vms.ext]XSSymSet.pm
+ @ If f$$Search("[.lib]VMS.Dir").eqs."" Then Create/Directory [.lib.VMS]
+ Copy/Log/NoConfirm [.vms.ext]XSSymSet.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
$(MINIPERL) [.pod]pod2text.PL
Rename/Log [.pod]pod2text.com $@
-preplibrary : $(MINIPERL_EXE) $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm $(SOCKPM)
+preplibrary : $(MINIPERL_EXE) $(LIBPREREQ) $(SOCKPM)
@ Write sys$$Output "Autosplitting Perl library . . ."
@ Create/Directory [.lib.auto]
@ $(MINIPERL) -e "use AutoSplit; autosplit_lib_modules(@ARGV)" [.lib]*.pm [.lib.*]*.pm
- If f$$Search("[.Lib]Socket.pm;-1").nes."" Then Purge/NoConfirm/Log [.Lib]Socket.pm
- If f$$Search("[.Lib]Config.pm;-1").nes."" Then Purge/NoConfirm/Log [.Lib]Config.pm
- If f$$Search("$(ARCHDIR)Config.pm;-1").nes."" Then Purge/NoConfirm/Log $(ARCHDIR)Config.pm
+ - If f$$Search("[.lib.ExtUtils]Miniperl.pm").nes."" Then Purge/NoConfirm/Log [.lib.ExtUtils]Miniperl.pm;*
+ - If f$$Search("[.lib.ExtUtils]XSSymSet.pm").nes."" Then Purge/NoConfirm/Log [.lib.ExtUtils]XSSymSet.pm;*
- 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("[.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("[.lib.ExtUtils]XSSymSet.pm").nes."" Then Delete/NoConfirm/Log [.lib.ExtUtils]XSSymSet.pm;*
- If f$$Search("[.lib.pod]*.pod").nes."" Then Delete/NoConfirm/Log [.lib.pod]*.pod;*
- 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;*
* 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_00326" /**/
+#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_00327" /**/
#define ARCHLIB ARCHLIB_EXP /*config-skip*/
/* ARCHNAME:
*/
#undef HAS_BCMP /**/
+#include <string.h> /* Check whether new DECC has #defined bcopy and bzero */
/* HAS_BCOPY:
* This symbol is defined if the bcopy() routine is available to
* copy blocks of memory.
*/
#undef HAS_BCOPY /**/
+#ifdef bcopy
+# define HAS_BCOPY /*config-skip*/
+#endif
/* HAS_BZERO:
* This symbol is defined if the bzero() routine is available to
* set a memory block to 0.
*/
#undef HAS_BZERO /**/
+#ifdef bzero
+# define HAS_BZERO /*config-skip*/
+#endif
/* CASTNEGFLOAT:
* This symbol is defined if the C compiler can cast negative
.endif
# Updated by fndvers.com -- do not edit by hand
-PERL_VERSION = 5_00326#
+PERL_VERSION = 5_00327#
ARCHDIR = [.lib.$(ARCH).$(PERL_VERSION)]
$(CC) $(CFLAGS) $(MMS$SOURCE_NAME).c
.endif
+# Modules which must be installed before we can build extensions
+LIBPREREQ = $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib]vmsish.pm [.lib.VMS]Filespec.pm [.lib.ExtUtils]XSSymSet.pm
+
utils1 = [.lib.pod]perldoc.com [.lib.ExtUtils]Miniperl.pm [.utils]c2ph.com [.utils]h2ph.com [.utils]h2xs.com [.lib]perlbug.com
utils2 = [.lib]splain.com [.utils]pl2pm.com
@ $(NOOP)
extras : Fcntl IO Opcode $(POSIX) libmods utils podxform
@ $(NOOP)
-libmods : [.lib]Config.pm $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm
+libmods : $(LIBPREREQ)
@ $(NOOP)
utils : $(utils1) $(utils2)
@ $(NOOP)
@ $(NOOP)
pod1 = [.lib.pod]perl.pod [.lib.pod]perlapio.pod [.lib.pod]perlbook.pod [.lib.pod]perlbot.pod [.lib.pod]perlcall.pod
-pod2 = [.lib.pod]perldata.pod [.lib.pod]perldebug.pod [.lib.pod]perldiag.pod [.lib.pod]perldsc.pod
+pod2 = [.lib.pod]perldata.pod [.lib.pod]perldebug.pod [.lib.pod]perldelta.pod [.lib.pod]perldiag.pod [.lib.pod]perldsc.pod
pod3 = [.lib.pod]perlembed.pod [.lib.pod]perlform.pod [.lib.pod]perlfunc.pod [.lib.pod]perlguts.pod
pod4 = [.lib.pod]perlipc.pod [.lib.pod]perllocale.pod [.lib.pod]perllol.pod [.lib.pod]perlmod.pod [.lib.pod]perlobj.pod
-pod5 = [.lib.pod]perlop.pod [.lib.pod]perlpod.pod [.lib.pod]perlre.pod
-pod6 = [.lib.pod]perlref.pod [.lib.pod]perlrun.pod [.lib.pod]perlsec.pod [.lib.pod]perlstyle.pod
-pod7 = [.lib.pod]perlsub.pod [.lib.pod]perlsyn.pod [.lib.pod]perltie.pod [.lib.pod]perltoc.pod
+pod5 = [.lib.pod]perlop.pod [.lib.pod]perlpod.pod [.lib.pod]perlre.pod [.lib.pod]perlref.pod [.lib.pod]perlrun.pod
+pod6 = [.lib.pod]perlsec.pod [.lib.pod]perlstyle.pod [.lib.pod]perlsub.pod [.lib.pod]perlsyn.pod
+pod7 = [.lib.pod]perltie.pod [.lib.pod]perltoc.pod [.lib.pod]perltoot.pod
pod8 = [.lib.pod]perltrap.pod [.lib.pod]perlvar.pod [.lib.pod]perlxs.pod [.lib.pod]perlxstut.pod
perlpods : $(pod1) $(pod2) $(pod3) $(pod4) $(pod5) $(pod6) $(pod7) $(pod8) [.lib.pod]perlvms.pod
@ Delete/NoLog/NoConfirm genconfig.opt;
$(MINIPERL) ConfigPM.
-[.ext.dynaloader]dl_vms.c : [.ext.dynaloader]dl_vms.xs $(MINIPERL_EXE)
+[.ext.dynaloader]dl_vms.c : [.ext.dynaloader]dl_vms.xs [.lib.ExtUtils]XSSymSet.pm $(MINIPERL_EXE)
$(XSUBPP) $(MMS$SOURCE) >$(MMS$TARGET)
[.ext.dynaloader]dl_vms$(O) : [.ext.dynaloader]dl_vms.c
# Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir>
# ${@} necessary to distract different versions of MM[SK]/make
-[.ext.Opcode]Descrip.MMS : [.ext.Opcode]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E)
+[.ext.Opcode]Descrip.MMS : [.ext.Opcode]Makefile.PL $(LIBPREREQ) $(DBG)perlshr$(E)
$(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Opcode]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
Fcntl : [.lib]Fcntl.pm [.lib.auto.Fcntl]Fcntl$(E)
# Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir>
# ${@} necessary to distract different versions of MM[SK]/make
-[.ext.Fcntl]Descrip.MMS : [.ext.Fcntl]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E)
+[.ext.Fcntl]Descrip.MMS : [.ext.Fcntl]Makefile.PL $(LIBPREREQ) $(DBG)perlshr$(E)
$(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Fcntl]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
POSIX : [.lib]POSIX.pm [.lib.auto.POSIX]POSIX$(E)
# Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir>
# ${@} necessary to distract different versions of MM[SK]/make
-[.ext.POSIX]Descrip.MMS : [.ext.POSIX]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E)
+[.ext.POSIX]Descrip.MMS : [.ext.POSIX]Makefile.PL $(LIBPREREQ) $(DBG)perlshr$(E)
$(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.POSIX]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
IO : [.lib]IO.pm [.lib.IO]File.pm [.lib.IO]Handle.pm [.lib.IO]Pipe.pm [.lib.IO]Seekable.pm [.lib.IO]Socket.pm [.lib.auto.IO]IO$(E)
# Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir>
# ${@} necessary to distract different versions of MM[SK]/make
-[.ext.IO]Descrip.MMS : [.ext.IO]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E)
+[.ext.IO]Descrip.MMS : [.ext.IO]Makefile.PL $(LIBPREREQ) $(DBG)perlshr$(E)
$(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.IO]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
+[.lib]vmsish.pm : [.vms.ext]vmsish.pm
+ Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET)
+
[.lib.VMS]Filespec.pm : [.vms.ext]Filespec.pm
@ If F$Search("[.lib]VMS.Dir").eqs."" Then Create/Directory [.lib.VMS]
Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET)
+[.lib.ExtUtils]XSSymSet.pm : [.vms.ext]XSSymSet.pm
+ @ If F$Search("[.lib]VMS.Dir").eqs."" Then Create/Directory [.lib.VMS]
+ Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET)
+
[.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)
$(MINIPERL) $(MMS$SOURCE)
Rename/Log [.pod]pod2text.com $(MMS$TARGET)
-preplibrary : $(MINIPERL_EXE) $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm $(SOCKPM)
+preplibrary : $(MINIPERL_EXE) $(LIBPREREQ) $(SOCKPM)
@ Write Sys$Output "Autosplitting Perl library . . ."
@ Create/Directory [.lib.auto]
@ $(MINIPERL) -e "use AutoSplit; autosplit_lib_modules(@ARGV)" [.lib]*.pm [.lib.*]*.pm
[.ext.Socket]Socket$(O) : [.ext.Socket]Socket.c
$(CC) $(CFLAGS) /Object=$(MMS$TARGET) $(MMS$SOURCE)
-[.ext.Socket]Socket.c : [.ext.Socket]Socket.xs $(MINIPERL_EXE)
+[.ext.Socket]Socket.c : [.ext.Socket]Socket.xs [.lib.ExtUtils]XSSymSet.pm $(MINIPERL_EXE)
$(XSUBPP) $(MMS$SOURCE) >$(MMS$TARGET)
.endif # !LINK_ONLY
- If F$Search("[.Lib]Socket.pm;-1").nes."" Then Purge/NoConfirm/Log [.Lib]Socket.pm
- If F$Search("[.Lib]Config.pm;-1").nes."" Then Purge/NoConfirm/Log [.Lib]Config.pm
- If F$Search("$(ARCHDIR)Config.pm;-1").nes."" Then Purge/NoConfirm/Log $(ARCHDIR)Config.pm
+ - If F$Search("[.lib.ExtUtils]Miniperl.pm").nes."" Then Purge/NoConfirm/Log [.lib.ExtUtils]Miniperl.pm;*
+ - If F$Search("[.lib.ExtUtils]XSSymSet.pm").nes."" Then Purge/NoConfirm/Log [.lib.ExtUtils]XSSymSet.pm;*
- 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("[.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("[.lib.ExtUtils]XSSymSet.pm").nes."" Then Delete/NoConfirm/Log [.lib.ExtUtils]XSSymSet.pm;*
- If F$Search("[.lib.pod]*.pod").nes."" Then Delete/NoConfirm/Log [.lib.pod]*.pod;*
- 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;*
# VMS::Stdio - VMS extensions to Perl's stdio calls
#
# Author: Charles Bailey bailey@genetics.upenn.edu
-# Version: 2.01
-# Revised: 10-Dec-1996
+# Version: 2.02
+# Revised: 15-Feb-1997
package VMS::Stdio;
use DynaLoader ();
use Exporter ();
-$VERSION = '2.01';
+$VERSION = '2.02';
@ISA = qw( Exporter DynaLoader IO::File );
@EXPORT = qw( &O_APPEND &O_CREAT &O_EXCL &O_NDELAY &O_NOWAIT
&O_RDONLY &O_RDWR &O_TRUNC &O_WRONLY );
/* VMS::Stdio - VMS extensions to stdio routines
*
- * Version: 2.0
+ * Version: 2.02
* Author: Charles Bailey bailey@genetics.upenn.edu
- * Revised: 28-Feb-1996
+ * Revised: 15-Feb-1997
*
*/
CODE:
FILE *fp = Nullfp;
if (SvOK(sv)) fp = IoIFP(sv_2io(sv));
- ST(0) = fflush(fp) ? &sv_undef : &sv_yes;
+ if (fflush(fp)) { ST(0) = &sv_undef; }
+ else { clearerr(fp); ST(0) = &sv_yes; }
char *
getname(fp)
FILE * fp
PROTOTYPE: $
CODE:
- ST(0) = fsync(fileno(fp)) ? &sv_undef : &sv_yes;
+ if (fsync(fileno(fp))) { ST(0) = &sv_undef; }
+ else { clearerr(fp); ST(0) = &sv_yes; }
char *
tmpnam()
--- /dev/null
+package ExtUtils::XSSymSet;
+
+use Carp qw( &carp );
+use strict;
+use vars qw( $VERSION );
+$VERSION = '1.0';
+
+
+sub new {
+ my($pkg,$maxlen,$silent) = @_;
+ $maxlen ||= 31;
+ $silent ||= 0;
+ my($obj) = { '__M@xLen' => $maxlen, '__S!lent' => $silent };
+ bless $obj, $pkg;
+}
+
+
+sub trimsym {
+ my($self,$name,$maxlen,$silent) = @_;
+
+ unless (defined $maxlen) {
+ if (ref $self) { $maxlen ||= $self->{'__M@xLen'}; }
+ $maxlen ||= 31;
+ }
+ unless (defined $silent) {
+ if (ref $self) { $silent ||= $self->{'__S!lent'}; }
+ $silent ||= 0;
+ }
+ return $name if (length $name <= $maxlen);
+
+ my $trimmed = $name;
+ # First, just try to remove duplicated delimiters
+ $trimmed =~ s/__/_/g;
+ if (length $trimmed > $maxlen) {
+ # Next, all duplicated chars
+ $trimmed =~ s/(.)\1+/$1/g;
+ if (length $trimmed > $maxlen) {
+ my $squeezed = $trimmed;
+ my($xs,$prefix,$func) = $trimmed =~ /^(XS_)?(.*)_([^_]*)$/;
+ if (length $func <= 12) { # Try to preserve short function names
+ my $frac = int(length $prefix / (length $trimmed - $maxlen) + 0.5);
+ my $pat = '([^_])';
+ if ($frac > 1) { $pat .= '[^A-Z_]{' . ($frac - 1) . '}'; }
+ $prefix =~ s/$pat/$1/g;
+ $squeezed = "$xs$prefix" . "_$func";
+ if (length $squeezed > $maxlen) {
+ $pat =~ s/A-Z//;
+ $prefix =~ s/$pat/$1/g;
+ $squeezed = "$xs$prefix" . "_$func";
+ }
+ }
+ else {
+ my $frac = int(length $trimmed / (length $trimmed - $maxlen) + 0.5);
+ my $pat = '([^_])';
+ if ($frac > 1) { $pat .= '[^A-Z_]{' . ($frac - 1) . '}'; }
+ $squeezed = "$prefix$func";
+ $squeezed =~ s/$pat/$1/g;
+ if (length "$xs$squeezed" > $maxlen) {
+ $pat =~ s/A-Z//;
+ $squeezed =~ s/$pat/$1/g;
+ }
+ $squeezed = "$xs$squeezed";
+ }
+ if (length $squeezed <= $maxlen) { $trimmed = $squeezed; }
+ else {
+ my $frac = int((length $trimmed - $maxlen) / length $trimmed + 0.5);
+ my $pat = '(.).{$frac}';
+ $trimmed =~ s/$pat/$1/g;
+ }
+ }
+ }
+ carp "Warning: long symbol $name\n\ttrimmed to $trimmed\n\t" unless $silent;
+ return $trimmed;
+}
+
+
+sub addsym {
+ my($self,$sym,$maxlen,$silent) = @_;
+ my $trimmed = $self->get_trimmed($sym);
+
+ return $trimmed if defined $trimmed;
+
+ $maxlen ||= $self->{'__M@xLen'} || 31;
+ $silent ||= $self->{'__S!lent'} || 0;
+ $trimmed = $self->trimsym($sym,$maxlen,1);
+ if (exists $self->{$trimmed}) {
+ my($i) = "00";
+ $trimmed = $self->trimsym($sym,$maxlen-3,$silent);
+ while (exists $self->{"${trimmed}_$i"}) { $i++; }
+ carp "Warning: duplicate symbol $trimmed\n\tchanged to ${trimmed}_$i\n\t(original was $sym)\n\t"
+ unless $silent;
+ $trimmed .= "_$i";
+ }
+ elsif (not $silent and $trimmed ne $sym) {
+ carp "Warning: long symbol $sym\n\ttrimmed to $trimmed\n\t";
+ }
+ $self->{$trimmed} = $sym;
+ $self->{'__N+Map'}->{$sym} = $trimmed;
+ $trimmed;
+}
+
+
+sub delsym {
+ my($self,$sym) = @_;
+ my $trimmed = $self->{'__N+Map'}->{$sym};
+ if (defined $trimmed) {
+ delete $self->{'__N+Map'}->{$sym};
+ delete $self->{$trimmed};
+ }
+ $trimmed;
+}
+
+
+sub get_trimmed {
+ my($self,$sym) = @_;
+ $self->{'__N+Map'}->{$sym};
+}
+
+
+sub get_orig {
+ my($self,$trimmed) = @_;
+ $self->{$trimmed};
+}
+
+
+sub all_orig { (keys %{$_[0]->{'__N+Map'}}); }
+sub all_trimmed { (grep { /^\w+$/ } keys %{$_[0]}); }
+
+__END__
+
+=head1 NAME
+
+VMS::XSSymSet - keep sets of symbol names palatable to the VMS linker
+
+=head1 SYNOPSIS
+
+ use VMS::XSSymSet;
+
+ $set = new VMS::XSSymSet;
+ while ($sym = make_symbol()) { $set->addsym($sym); }
+ foreach $safesym ($set->all_trimmed) {
+ print "Processing $safesym (derived from ",$self->get_orig($safesym),")\n";
+ do_stuff($safesym);
+ }
+
+ $safesym = VMS::XSSymSet->trimsym($onesym);
+
+=head1 DESCRIPTION
+
+Since the VMS linker distinguishes symbols based only on the first 31
+characters of their names, it is occasionally necessary to shorten
+symbol names in order to avoid collisions. (This is especially true of
+names generated by xsubpp, since prefixes generated by nested package
+names can become quite long.) C<VMS::XSSymSet> provides functions to
+shorten names in a consistent fashion, and to track a set of names to
+insure that each is unique. While designed with F<xsubpp> in mind, it
+may be used with any set of strings.
+
+This package supplies the following functions, all of which should be
+called as methods.
+
+=over 4
+
+=item new([$maxlen[,$silent]])
+
+Creates an empty C<VMS::XSSymset> set of symbols. This function may be
+called as a static method or via an existing object. If C<$maxlen> or
+C<$silent> are specified, they are used as the defaults for maximum
+name length and warning behavior in future calls to addsym() or
+trimsym() via this object.
+
+=item addsym($name[,$maxlen[,$silent]])
+
+Creates a symbol name from C<$name>, using the methods described
+under trimsym(), which is unique in this set of symbols, and returns
+the new name. C<$name> and its resultant are added to the set, and
+any future calls to addsym() specifying the same C<$name> will return
+the same result, regardless of the value of C<$maxlen> specified.
+Unless C<$silent> is true, warnings are output if C<$name> had to be
+trimmed or changed in order to avoid collision with an existing symbol
+name. C<$maxlen> and C<$silent> default to the values specified when
+this set of symbols was created. This method must be called via an
+existing object.
+
+=item trimsym($name[,$maxlen[,$silent]])
+
+Creates a symbol name C<$maxlen> or fewer characters long from
+C<$name> and returns it. If C<$name> is too long, it first tries to
+shorten it by removing duplicate characters, then by periodically
+removing non-underscore characters, and finally, if necessary, by
+periodically removing characters of any type. C<$maxlen> defaults
+to 31. Unless C<$silent> is true, a warning is output if C<$name>
+is altered in any way. This function may be called either as a
+static method or via an existing object, but in the latter case no
+check is made to insure that the resulting name is unique in the
+set of symbols.
+
+=item delsym($name)
+
+Removes C<$name> from the set of symbols, where C<$name> is the
+original symbol name passed previously to addsym(). If C<$name>
+existed in the set of symbols, returns its "trimmed" equivalent,
+otherwise returns C<undef>. This method must be called via an
+existing object.
+
+=item get_orig($trimmed)
+
+Returns the original name which was trimmed to C<$trimmed> by a
+previous call to addsym(), or C<undef> if C<$trimmed> does not
+correspond to a member of this set of symbols. This method must be
+called via an existing object.
+
+=item get_trimmed($name)
+
+Returns the trimmed name which was generated from C<$name> by a
+previous call to addsym(), or C<undef> if C<$name> is not a member
+of this set of symbols. This method must be called via an
+existing object.
+
+=item all_orig()
+
+Returns a list containing all of the original symbol names
+from this set.
+
+=item all_trimmed()
+
+Returns a list containing all of the trimmed symbol names
+from this set.
+
+=back
+
+=head1 AUTHOR
+
+Charles Bailey E<lt>I<bailey@genetics.upenn.edu>E<gt>
+
+=head1 REVISION
+
+Last revised 14-Feb-1997, for Perl 5.004.
+
--- /dev/null
+package vmsish;
+
+=head1 NAME
+
+vmsish - Perl pragma to control VMS-specific language features
+
+=head1 SYNOPSIS
+
+ use vmsish;
+
+ use vmsish 'status'; # or '$?'
+ use vmsish 'exit';
+ use vmsish 'time';
+
+ use vmsish;
+ no vmsish 'time';
+
+=head1 DESCRIPTION
+
+If no import list is supplied, all possible VMS-specific features are
+assumed. Currently, there are three VMS-specific features available:
+'status' (a.k.a '$?'), 'exit', and 'time'.
+
+=over 6
+
+=item C<vmsish status>
+
+This makes C<$?> and C<system> return the native VMS exit status
+instead of emulating the POSIX exit status.
+
+=item C<vmsish exit>
+
+This makes C<exit 1> produce a successful exit (with status SS$_NORMAL),
+instead of emulating UNIX exit(), which considers C<exit 1> to indicate
+an error. As with the CRTL's exit() function, C<exit 0> is also mapped
+to an exit status of SS$_NORMAL, and any other argument to exit() is
+used directly as Perl's exit status.
+
+=item C<vmsish time>
+
+This makes all times relative to the local time zone, instead of the
+default of Universal Time (a.k.a Greenwich Mean Time, or GMT).
+
+=back
+
+See L<perlmod/Pragmatic Modules>.
+
+=cut
+
+if ($^O ne 'VMS') {
+ require Carp;
+ Carp::croak("This isn't VMS");
+}
+
+sub bits {
+ my $bits = 0;
+ my $sememe;
+ foreach $sememe (@_) {
+ $bits |= 0x01000000, next if $sememe eq 'status' || $sememe eq '$?';
+ $bits |= 0x02000000, next if $sememe eq 'exit';
+ $bits |= 0x04000000, next if $sememe eq 'time';
+ }
+ $bits;
+}
+
+sub import {
+ shift;
+ $^H |= bits(@_ ? @_ : qw(status exit time));
+}
+
+sub unimport {
+ shift;
+ $^H &= ~ bits(@_ ? @_ : qw(status exit time));
+}
+
+1;
$
$! Make the environment look a little friendlier to tests which assume Unix
$ cat = "Type"
-$ Macro/NoDebug/Object=Echo.Obj Sys$Input
+$ Macro/NoDebug/NoList/Object=Echo.Obj Sys$Input
.title echo
.psect data,wrt,noexe
dsc:
movl #1,r0
ret
.end echo
-$ Link/NoTrace/Exe=Echo.Exe Echo.Obj;
+$ Link/NoMap/NoTrace/Exe=Echo.Exe Echo.Obj;
$ Delete/Log/NoConfirm Echo.Obj;*
$ echo = "$" + F$Parse("Echo.Exe")
$
*
* VMS-specific routines for perl5
*
- * Last revised: 29-Jan-1997 by Charles Bailey bailey@genetics.upenn.edu
- * Version: 5.3.24
+ * Last revised: 15-Feb-1997 by Charles Bailey bailey@genetics.upenn.edu
+ * Version: 5.3.27
*/
#include <acedef.h>
} /* end of kill_file() */
/*}}}*/
-/* my_utime - update modification time of a file
- * calling sequence is identical to POSIX utime(), but under
- * VMS only the modification time is changed; ODS-2 does not
- * maintain access times. Restrictions differ from the POSIX
- * definition in that the time can be changed as long as the
- * caller has permission to execute the necessary IO$_MODIFY $QIO;
- * no separate checks are made to insure that the caller is the
- * owner of the file or has special privs enabled.
- * Code here is based on Joe Meadows' FILE utility.
- */
-
-/* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
- * to VMS epoch (01-JAN-1858 00:00:00.00)
- * in 100 ns intervals.
- */
-static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
-
-/*{{{int my_utime(char *path, struct utimbuf *utimes)*/
-int my_utime(char *file, struct utimbuf *utimes)
-{
- register int i;
- long int bintime[2], len = 2, lowbit, unixtime,
- secscale = 10000000; /* seconds --> 100 ns intervals */
- unsigned long int chan, iosb[2], retsts;
- char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
- struct FAB myfab = cc$rms_fab;
- struct NAM mynam = cc$rms_nam;
-#if defined (__DECC) && defined (__VAX)
- /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
- * at least through VMS V6.1, which causes a type-conversion warning.
- */
-# pragma message save
-# pragma message disable cvtdiftypes
-#endif
- struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
- struct fibdef myfib;
-#if defined (__DECC) && defined (__VAX)
- /* This should be right after the declaration of myatr, but due
- * to a bug in VAX DEC C, this takes effect a statement early.
- */
-# pragma message restore
-#endif
- struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
- devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
- fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
-
- if (file == NULL || *file == '\0') {
- set_errno(ENOENT);
- set_vaxc_errno(LIB$_INVARG);
- return -1;
- }
- if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
-
- if (utimes != NULL) {
- /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
- * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
- * Since time_t is unsigned long int, and lib$emul takes a signed long int
- * as input, we force the sign bit to be clear by shifting unixtime right
- * one bit, then multiplying by an extra factor of 2 in lib$emul().
- */
- lowbit = (utimes->modtime & 1) ? secscale : 0;
- unixtime = (long int) utimes->modtime;
- unixtime >> 1; secscale << 1;
- retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
- if (!(retsts & 1)) {
- set_errno(EVMSERR);
- set_vaxc_errno(retsts);
- return -1;
- }
- retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
- if (!(retsts & 1)) {
- set_errno(EVMSERR);
- set_vaxc_errno(retsts);
- return -1;
- }
- }
- else {
- /* Just get the current time in VMS format directly */
- retsts = sys$gettim(bintime);
- if (!(retsts & 1)) {
- set_errno(EVMSERR);
- set_vaxc_errno(retsts);
- return -1;
- }
- }
-
- myfab.fab$l_fna = vmsspec;
- myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
- myfab.fab$l_nam = &mynam;
- mynam.nam$l_esa = esa;
- mynam.nam$b_ess = (unsigned char) sizeof esa;
- mynam.nam$l_rsa = rsa;
- mynam.nam$b_rss = (unsigned char) sizeof rsa;
-
- /* Look for the file to be affected, letting RMS parse the file
- * specification for us as well. I have set errno using only
- * values documented in the utime() man page for VMS POSIX.
- */
- retsts = sys$parse(&myfab,0,0);
- if (!(retsts & 1)) {
- set_vaxc_errno(retsts);
- if (retsts == RMS$_PRV) set_errno(EACCES);
- else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
- else set_errno(EVMSERR);
- return -1;
- }
- retsts = sys$search(&myfab,0,0);
- if (!(retsts & 1)) {
- set_vaxc_errno(retsts);
- if (retsts == RMS$_PRV) set_errno(EACCES);
- else if (retsts == RMS$_FNF) set_errno(ENOENT);
- else set_errno(EVMSERR);
- return -1;
- }
-
- devdsc.dsc$w_length = mynam.nam$b_dev;
- devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
-
- retsts = sys$assign(&devdsc,&chan,0,0);
- if (!(retsts & 1)) {
- set_vaxc_errno(retsts);
- if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
- else if (retsts == SS$_NOPRIV) set_errno(EACCES);
- else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
- else set_errno(EVMSERR);
- return -1;
- }
-
- fnmdsc.dsc$a_pointer = mynam.nam$l_name;
- fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
-
- memset((void *) &myfib, 0, sizeof myfib);
-#ifdef __DECC
- for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
- for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
- /* This prevents the revision time of the file being reset to the current
- * time as a result of our IO$_MODIFY $QIO. */
- myfib.fib$l_acctl = FIB$M_NORECORD;
-#else
- for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
- for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
- myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
-#endif
- retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
- _ckvmssts(sys$dassgn(chan));
- if (retsts & 1) retsts = iosb[0];
- if (!(retsts & 1)) {
- set_vaxc_errno(retsts);
- if (retsts == SS$_NOPRIV) set_errno(EACCES);
- else set_errno(EVMSERR);
- return -1;
- }
-
- return 0;
-} /* end of my_utime() */
-/*}}}*/
-
static void
create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
{
/*}}}*/
-/* my_gmtime
- * If the CRTL has a real gmtime(), use it, else look for the logical
- * name SYS$TIMEZONE_DIFFERENTIAL used by the native UTC routines on
- * VMS >= 6.0. Can be manually defined under earlier versions of VMS
- * to translate to the number of seconds which must be added to UTC
- * to get to the local time of the system.
- * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
+/* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
+ * my_utime(), and flex_stat(), all of which operate on UTC unless
+ * VMSISH_TIMES is true.
+ */
+/* method used to handle UTC conversions:
+ * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
*/
+static int gmtime_emulation_type;
+/* number of secs to add to UTC POSIX-style time to get local time */
+static long int utc_offset_secs;
-/*{{{struct tm *my_gmtime(const time_t *time)*/
-/* We #defined 'gmtime' as 'my_gmtime' in vmsish.h. #undef it here
- * so we can call the CRTL's routine to see if it works.
+/* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
+ * in vmsish.h. #undef them here so we can call the CRTL routines
+ * directly.
*/
#undef gmtime
-struct tm *
-my_gmtime(const time_t *time)
+#undef localtime
+#undef time
+
+/* my_time(), my_localtime(), my_gmtime()
+ * By default traffic in UTC time values, suing CRTL gmtime() or
+ * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
+ * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
+ * Modified by Charles Bailey <bailey@genetics.upenn.edu>
+ */
+
+/*{{{time_t my_time(time_t *timep)*/
+time_t my_time(time_t *timep)
{
- static int gmtime_emulation_type;
- static long int utc_offset_secs;
- char *p;
time_t when;
if (gmtime_emulation_type == 0) {
+ struct tm *tm_p;
+ time_t base = 15 * 86400; /* 15jan71; to avoid month ends */
+
gmtime_emulation_type++;
- when = 300000000;
- if (gmtime(&when) == NULL) { /* CRTL gmtime() is just a stub */
+ if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
+ char *off;
+
gmtime_emulation_type++;
- if ((p = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL)
+ if ((off = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL) {
gmtime_emulation_type++;
- else
- utc_offset_secs = atol(p);
+ warn("no UTC offset information; assuming local time is UTC");
+ }
+ else { utc_offset_secs = atol(off); }
+ }
+ else { /* We've got a working gmtime() */
+ struct tm gmt, local;
+
+ gmt = *tm_p;
+ tm_p = localtime(&base);
+ local = *tm_p;
+ utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
+ utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
+ utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
+ utc_offset_secs += (local.tm_sec - gmt.tm_sec);
}
}
- switch (gmtime_emulation_type) {
- case 1:
- return gmtime(time);
- case 2:
- when = *time - utc_offset_secs;
- return localtime(&when);
- default:
- warn("gmtime not supported on this system");
- return NULL;
- }
+ when = time(NULL);
+ if (
+# ifdef VMSISH_TIME
+ !VMSISH_TIME &&
+# endif
+ when != -1) when -= utc_offset_secs;
+ if (timep != NULL) *timep = when;
+ return when;
+
+} /* end of my_time() */
+/*}}}*/
+
+
+/*{{{struct tm *my_gmtime(const time_t *timep)*/
+struct tm *
+my_gmtime(const time_t *timep)
+{
+ char *p;
+ time_t when;
+
+ if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
+
+ when = *timep;
+# ifdef VMSISH_TIME
+ if (VMSISH_TIME) when -= utc_offset_secs; /* Input was local time */
+# endif
+ /* CRTL localtime() wants local time as input, so does no tz correction */
+ return localtime(&when);
+
} /* end of my_gmtime() */
-/* Reset definition for later calls */
-#define gmtime(t) my_gmtime(t)
/*}}}*/
+/*{{{struct tm *my_localtime(const time_t *timep)*/
+struct tm *
+my_localtime(const time_t *timep)
+{
+ time_t when;
+
+ if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
+
+ when = *timep;
+# ifdef VMSISH_TIME
+ if (!VMSISH_TIME) when += utc_offset_secs; /* Input was UTC */
+# endif
+ /* CRTL localtime() wants local time as input, so does no tz correction */
+ return localtime(&when);
+
+} /* end of my_localtime() */
+/*}}}*/
+
+/* Reset definitions for later calls */
+#define gmtime(t) my_gmtime(t)
+#define localtime(t) my_localtime(t)
+#define time(t) my_time(t)
+
+
+/* my_utime - update modification time of a file
+ * calling sequence is identical to POSIX utime(), but under
+ * VMS only the modification time is changed; ODS-2 does not
+ * maintain access times. Restrictions differ from the POSIX
+ * definition in that the time can be changed as long as the
+ * caller has permission to execute the necessary IO$_MODIFY $QIO;
+ * no separate checks are made to insure that the caller is the
+ * owner of the file or has special privs enabled.
+ * Code here is based on Joe Meadows' FILE utility.
+ */
+
+/* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
+ * to VMS epoch (01-JAN-1858 00:00:00.00)
+ * in 100 ns intervals.
+ */
+static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
+
+/*{{{int my_utime(char *path, struct utimbuf *utimes)*/
+int my_utime(char *file, struct utimbuf *utimes)
+{
+ register int i;
+ long int bintime[2], len = 2, lowbit, unixtime,
+ secscale = 10000000; /* seconds --> 100 ns intervals */
+ unsigned long int chan, iosb[2], retsts;
+ char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
+ struct FAB myfab = cc$rms_fab;
+ struct NAM mynam = cc$rms_nam;
+#if defined (__DECC) && defined (__VAX)
+ /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
+ * at least through VMS V6.1, which causes a type-conversion warning.
+ */
+# pragma message save
+# pragma message disable cvtdiftypes
+#endif
+ struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
+ struct fibdef myfib;
+#if defined (__DECC) && defined (__VAX)
+ /* This should be right after the declaration of myatr, but due
+ * to a bug in VAX DEC C, this takes effect a statement early.
+ */
+# pragma message restore
+#endif
+ struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
+ devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
+ fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
+
+ if (file == NULL || *file == '\0') {
+ set_errno(ENOENT);
+ set_vaxc_errno(LIB$_INVARG);
+ return -1;
+ }
+ if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
+
+ if (utimes != NULL) {
+ /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
+ * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
+ * Since time_t is unsigned long int, and lib$emul takes a signed long int
+ * as input, we force the sign bit to be clear by shifting unixtime right
+ * one bit, then multiplying by an extra factor of 2 in lib$emul().
+ */
+ lowbit = (utimes->modtime & 1) ? secscale : 0;
+ unixtime = (long int) utimes->modtime;
+# ifdef VMSISH_TIME
+ if (!VMSISH_TIME) { /* Input was UTC; convert to local for sys svc */
+ if (!gmtime_emulation_type) (void) time(NULL); /* Initialize UTC */
+ unixtime += utc_offset_secs;
+ }
+# endif
+ unixtime >> 1; secscale << 1;
+ retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
+ if (!(retsts & 1)) {
+ set_errno(EVMSERR);
+ set_vaxc_errno(retsts);
+ return -1;
+ }
+ retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
+ if (!(retsts & 1)) {
+ set_errno(EVMSERR);
+ set_vaxc_errno(retsts);
+ return -1;
+ }
+ }
+ else {
+ /* Just get the current time in VMS format directly */
+ retsts = sys$gettim(bintime);
+ if (!(retsts & 1)) {
+ set_errno(EVMSERR);
+ set_vaxc_errno(retsts);
+ return -1;
+ }
+ }
+
+ myfab.fab$l_fna = vmsspec;
+ myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
+ myfab.fab$l_nam = &mynam;
+ mynam.nam$l_esa = esa;
+ mynam.nam$b_ess = (unsigned char) sizeof esa;
+ mynam.nam$l_rsa = rsa;
+ mynam.nam$b_rss = (unsigned char) sizeof rsa;
+
+ /* Look for the file to be affected, letting RMS parse the file
+ * specification for us as well. I have set errno using only
+ * values documented in the utime() man page for VMS POSIX.
+ */
+ retsts = sys$parse(&myfab,0,0);
+ if (!(retsts & 1)) {
+ set_vaxc_errno(retsts);
+ if (retsts == RMS$_PRV) set_errno(EACCES);
+ else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
+ else set_errno(EVMSERR);
+ return -1;
+ }
+ retsts = sys$search(&myfab,0,0);
+ if (!(retsts & 1)) {
+ set_vaxc_errno(retsts);
+ if (retsts == RMS$_PRV) set_errno(EACCES);
+ else if (retsts == RMS$_FNF) set_errno(ENOENT);
+ else set_errno(EVMSERR);
+ return -1;
+ }
+
+ devdsc.dsc$w_length = mynam.nam$b_dev;
+ devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
+
+ retsts = sys$assign(&devdsc,&chan,0,0);
+ if (!(retsts & 1)) {
+ set_vaxc_errno(retsts);
+ if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
+ else if (retsts == SS$_NOPRIV) set_errno(EACCES);
+ else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
+ else set_errno(EVMSERR);
+ return -1;
+ }
+
+ fnmdsc.dsc$a_pointer = mynam.nam$l_name;
+ fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
+
+ memset((void *) &myfib, 0, sizeof myfib);
+#ifdef __DECC
+ for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
+ for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
+ /* This prevents the revision time of the file being reset to the current
+ * time as a result of our IO$_MODIFY $QIO. */
+ myfib.fib$l_acctl = FIB$M_NORECORD;
+#else
+ for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
+ for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
+ myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
+#endif
+ retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
+ _ckvmssts(sys$dassgn(chan));
+ if (retsts & 1) retsts = iosb[0];
+ if (!(retsts & 1)) {
+ set_vaxc_errno(retsts);
+ if (retsts == SS$_NOPRIV) set_errno(EACCES);
+ else set_errno(EVMSERR);
+ return -1;
+ }
+
+ return 0;
+} /* end of my_utime() */
+/*}}}*/
+
/*
* flex_stat, flex_fstat
* basic stat, but gets it right when asked to stat
if (!fstat(fd,(stat_t *) statbufp)) {
if (statbufp == &statcache) *namecache == '\0';
statbufp->st_dev = encode_dev(statbufp->st_devnam);
+# ifdef VMSISH_TIME
+ if (!VMSISH_TIME) { /* Return UTC instead of local time */
+# else
+ if (1) {
+# endif
+ if (!gmtime_emulation_type) (void)time(NULL);
+ statbufp->st_mtime -= utc_offset_secs;
+ statbufp->st_atime -= utc_offset_secs;
+ statbufp->st_ctime -= utc_offset_secs;
+ }
return 0;
}
return -1;
if (!retval && statbufp == &statcache) strcpy(namecache,fileified);
}
if (retval) retval = stat(fspec,(stat_t *) statbufp);
- if (!retval) statbufp->st_dev = encode_dev(statbufp->st_devnam);
+ if (!retval) {
+ statbufp->st_dev = encode_dev(statbufp->st_devnam);
+# ifdef VMSISH_TIME
+ if (!VMSISH_TIME) { /* Return UTC instead of local time */
+# else
+ if (1) {
+# endif
+ if (!gmtime_emulation_type) (void)time(NULL);
+ statbufp->st_mtime -= utc_offset_secs;
+ statbufp->st_atime -= utc_offset_secs;
+ statbufp->st_ctime -= utc_offset_secs;
+ }
+ }
return retval;
} /* end of flex_stat() */
# define vmsreaddirversions Perl_vmsreaddirversions
# define getredirection Perl_getredirection
# define my_gmtime Perl_my_gmtime
+# define my_localtime Perl_my_localtime
+# define my_time Perl_my_time
# define cando_by_name Perl_cando_by_name
# define flex_fstat Perl_flex_fstat
# define flex_stat Perl_flex_stat
# define set_vaxc_errno(v) (vaxc$errno = (v))
#endif
+/* Support for 'vmsish' behaviors enabled with C<use vmsish> pragma */
+
+#define COMPLEX_STATUS 1 /* We track both "POSIX" and VMS values */
+
+#define HINT_S_VMSISH 24
+#define HINT_M_VMSISH_STATUS 0x01000000 /* system, $? return VMS status */
+#define HINT_M_VMSISH_EXIT 0x02000000 /* exit(1) ==> SS$_NORMAL */
+#define HINT_M_VMSISH_TIME 0x04000000 /* times are local, not UTC */
+#define NATIVE_HINTS (hints >> HINT_S_VMSISH) /* used in op.c */
+
+#define TEST_VMSISH(h) (curcop->op_private & ((h) >> HINT_S_VMSISH))
+#define VMSISH_STATUS TEST_VMSISH(HINT_M_VMSISH_STATUS)
+#define VMSISH_EXIT TEST_VMSISH(HINT_M_VMSISH_EXIT)
+#define VMSISH_TIME TEST_VMSISH(HINT_M_VMSISH_TIME)
+
/* Handy way to vet calls to VMS system services and RTL routines. */
#define _ckvmssts(call) STMT_START { register unsigned long int __ckvms_sts; \
if (!((__ckvms_sts=(call))&1)) { \
/* Prior to VMS 7.0, the CRTL gmtime() routine was a stub which always
* returned NULL. Substitute our own routine, which uses the logical
* SYS$TIMEZONE_DIFFERENTIAL, whcih the native UTC support routines
- * in VMS 6.0 or later use.*
+ * in VMS 6.0 or later use. We also add shims for time() and localtime()
+ * so we can run on UTC by default.
*/
#define gmtime(t) my_gmtime(t)
+#define localtime(t) my_localtime(t)
+#define time(t) my_time(t)
/* VMS doesn't use a real sys_nerr, but we need this when scanning for error
* messages in text strings . . .
void seekdir _((DIR *, long));
void closedir _((DIR *));
void vmsreaddirversions _((DIR *, int));
-struct tm *my_gmtime _((const time_t *));
+struct tm * my_gmtime _((const time_t *));
+struct tm * my_localtime _((const time_t *));
+time_t my_time _((time_t *));
I32 cando_by_name _((I32, I32, char *));
int flex_fstat _((int, struct stat *));
int flex_stat _((char *, struct stat *));
-
#!../miniperl
# Written: 10 April 1996 Gary Ng (71564.1743@compuserve.com)
perl_requirepv
siggv
stack
+statusvalue_vms
tainting
Perl_safexcalloc
Perl_safexmalloc
YYSTYPE yyvs[YYSTACKSIZE];
#define yystacksize YYSTACKSIZE
#line 396 "a2p.y"
+
+int yyparse _((void));
+
#include "a2py.c"
-#line 2005 "y.tab.c"
+#line 2008 "y.tab.c"
#define YYABORT goto yyabort
#define YYACCEPT goto yyaccept
#define YYERROR goto yyerrlab
#line 392 "a2p.y"
{ yyval = oper3(OBLOCK,oper2(OJUNK,yyvsp[-3],yyvsp[-2]),Nullop,yyvsp[0]); }
break;
-#line 2671 "y.tab.c"
+#line 2674 "y.tab.c"
}
yyssp -= yym;
yystate = *yyssp;
;
%%
+
+int yyparse _((void));
+
#include "a2py.c"
projects / p5sagit/p5-mst-13.2.git / commitdiff