return ('', '', $crtlstr, '');
}
- my(@dirs,@libs,$dir,$lib,%sh,%olb,%obj,$ldlib);
+ my(@dirs,@libs,$dir,$lib,%found,@fndlibs,$ldlib);
my $cwd = cwd();
my($so,$lib_ext,$obj_ext) = @Config{'so','lib_ext','obj_ext'};
# List of common Unix library names and there VMS equivalents
warn "\tChecking $name\n" if $verbose > 2;
if (-f ($test = VMS::Filespec::rmsexpand($name))) {
# It's got its own suffix, so we'll have to figure out the type
- if ($test =~ /(?:$so|exe)$/i) { $type = 'sh'; }
- elsif ($test =~ /(?:$lib_ext|olb)$/i) { $type = 'olb'; }
+ if ($test =~ /(?:$so|exe)$/i) { $type = 'SHR'; }
+ elsif ($test =~ /(?:$lib_ext|olb)$/i) { $type = 'OLB'; }
elsif ($test =~ /(?:$obj_ext|obj)$/i) {
warn "Note (probably harmless): "
."Plain object file $test found in library list\n";
- $type = 'obj';
+ $type = 'OBJ';
}
else {
warn "Note (probably harmless): "
."Unknown library type for $test; assuming shared\n";
- $type = 'sh';
+ $type = 'SHR';
}
}
elsif (-f ($test = VMS::Filespec::rmsexpand($name,$so)) or
-f ($test = VMS::Filespec::rmsexpand($name,'.exe'))) {
- $type = 'sh';
+ $type = 'SHR';
$name = $test unless $test =~ /exe;?\d*$/i;
}
elsif (not length($ctype) and # If we've got a lib already, don't bother
( -f ($test = VMS::Filespec::rmsexpand($name,$lib_ext)) or
-f ($test = VMS::Filespec::rmsexpand($name,'.olb')))) {
- $type = 'olb';
+ $type = 'OLB';
$name = $test unless $test =~ /olb;?\d*$/i;
}
elsif (not length($ctype) and # If we've got a lib already, don't bother
-f ($test = VMS::Filespec::rmsexpand($name,'.obj')))) {
warn "Note (probably harmless): "
."Plain object file $test found in library list\n";
- $type = 'obj';
+ $type = 'OBJ';
$name = $test unless $test =~ /obj;?\d*$/i;
}
if (defined $type) {
$ctype = $type; $cand = $name;
- last if $ctype eq 'sh';
+ last if $ctype eq 'SHR';
}
}
if ($ctype) {
- eval '$' . $ctype . "{'$cand'}++";
- die "Error recording library: $@" if $@;
+ # This has to precede any other CRTLs, so just make it first
+ if ($cand eq 'VAXCCURSE') { unshift @{$found{$ctype}}, $cand; }
+ else { push @{$found{$ctype}}, $cand; }
warn "\tFound as $cand (really $test), type $ctype\n" if $verbose > 1;
next LIB;
}
."No library found for $lib\n";
}
- @libs = sort keys %obj;
- # This has to precede any other CRTLs, so just make it first
- if ($olb{VAXCCURSE}) {
- push(@libs,"$olb{VAXCCURSE}/Library");
- delete $olb{VAXCCURSE};
- }
- push(@libs, map { "$_/Library" } sort keys %olb);
- push(@libs, map { "$_/Share" } sort keys %sh);
- $lib = join(' ',@libs);
+ push @fndlibs, @{$found{OBJ}} if exists $found{OBJ};
+ push @fndlibs, map { "$_/Library" } @{$found{OLB}} if exists $found{OLB};
+ push @fndlibs, map { "$_/Share" } @{$found{SHR}} if exists $found{SHR};
+ $lib = join(' ',@fndlibs);
$ldlib = $crtlstr ? "$lib $crtlstr" : $lib;
warn "Result:\n\tEXTRALIBS: $lib\n\tLDLOADLIBS: $ldlib\n" if $verbose;
push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST)',"\n");
}
- foreach $lib (split $self->{EXTRALIBS}) {
- $lib = '""' if $lib eq '"';
+ push @m, "\t\$(NOECHO) \$(PERL) -e 1 >\$(INST_ARCHAUTODIR)extralibs.ld\n";
+ foreach $lib (split ' ', $self->{EXTRALIBS}) {
push(@m,"\t",'$(NOECHO) $(PERL) -e "print qq{',$lib,'\n}" >>$(INST_ARCHAUTODIR)extralibs.ld',"\n");
}
push @m, $self->dir_target('$(INST_ARCHAUTODIR)');
$tmp = $self->fixpath($tmp,1);
if (@optlibs) { $extralist = join(' ',@optlibs); }
else { $extralist = ''; }
- # Let ExtUtils::Liblist find the necessary for us (but skip PerlShr;
+ # Let ExtUtils::Liblist find the necessary libs for us (but skip PerlShr)
# that's what we're building here).
push @optlibs, grep { !/PerlShr/i } split +($self->ext())[2];
if ($libperl) {
print "# $@\nnot " if $@;
print "ok ",$i++,"\n";
-END { unlink 'bleah.pm'; }
+END { 1 while unlink 'bleah.pm'; }
# ***interaction with pod (don't put any thing after here)***
umask 0;
$xref = \ "";
+$runme = ($^O eq 'VMS' ? 'MCR ' : '') . $^X;
@a = (1..5);
%h = (1..6);
$aref = \@a;
$href = \%h;
-open OP, qq{$^X -le "print 'aaa Ok ok' for 1..100"|};
+open OP, qq{$runme -le "print 'aaa Ok ok' for 1..100"|};
$chopit = 'aaaaaa';
@chopar = (113 .. 119);
$posstr = '123456';
__END__
ref $xref # ref
ref $cstr # ref nonref
-`ls` # backtick skip(MSWin32)
+`$runme -e "print qq[1\n]"` # backtick skip(MSWin32)
`$undefed` # backtick undef skip(MSWin32)
<*> # glob
<OP> # readline
'???' # fork
'???' # wait
'???' # waitpid
-system "$^X -e 0" # system
+system "$runme -e 0" # system skip(VMS)
'???' # exec
'???' # kill
getppid # getppid
END {
\$ENV{PATH} = '';
warn "# Note: logical name 'PATH' may have been deleted\n";
- @ENV{keys %old} = values %old;
+ \@ENV{keys %old} = values %old;
}
EndOfCleanup
}
unless ($opt_m) {
if ($Is_VMS) {
my($i,$trn);
- for ($i = 0; $trn = $ENV{'DCL$PATH'.$i}; $i++) {
+ for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) {
push(@searchdirs,$trn);
}
push(@searchdirs,'perl_root:[lib.pod]') # installed pods
# VMS::Stdio - VMS extensions to Perl's stdio calls
#
# Author: Charles Bailey bailey@genetics.upenn.edu
-# Version: 2.1
-# Revised: 24-Mar-1998
+# Version: 2.2
+# Revised: 19-Jul-1998
# Docs revised: 13-Oct-1998 Dan Sugalski <sugalskd@ous.edu>
package VMS::Stdio;
use DynaLoader ();
use Exporter ();
-$VERSION = '2.1';
+$VERSION = '2.2';
@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 );
-@EXPORT_OK = qw( &flush &getname &remove &rewind &sync &setdef &tmpnam
+@EXPORT_OK = qw( &binmode &flush &getname &remove &rewind &sync &setdef &tmpnam
&vmsopen &vmssysopen &waitfh &writeof );
%EXPORT_TAGS = ( CONSTANTS => [ qw( &O_APPEND &O_CREAT &O_EXCL &O_NDELAY
&O_NOWAIT &O_RDONLY &O_RDWR &O_TRUNC
&O_WRONLY ) ],
- FUNCTIONS => [ qw( &flush &getname &remove &rewind &setdef
- &sync &tmpnam &vmsopen &vmssysopen
+ FUNCTIONS => [ qw( &binmode &flush &getname &remove &rewind
+ &setdef &sync &tmpnam &vmsopen &vmssysopen
&waitfh &writeof ) ] );
bootstrap VMS::Stdio $VERSION;
close($fh);
remove("another.file");
writeof($pipefh);
+ binmode($fh);
=head1 DESCRIPTION
=over
+=item binmode
+
+This function causes the file handle to be reopened with the CRTL's
+carriage control processing disabled; its effect is the same as that
+of the C<b> access mode in C<vmsopen>. After the file is reopened,
+the file pointer is positioned as close to its position before the
+call as possible (I<i.e.> as close as fsetpos() can get it -- for
+some record-structured files, it's not possible to return to the
+exact byte offset in the file). Because the file must be reopened,
+this function cannot be used on temporary-delete files. C<binmode>
+returns true if successful, and C<undef> if not.
+
+Note that the effect of C<binmode> differs from that of the binmode()
+function on operating systems such as Windows and MSDOS, and is not
+needed to process most types of file.
+
=item flush
This function causes the contents of stdio buffers for the specified
/* VMS::Stdio - VMS extensions to stdio routines
*
- * Version: 2.1
- * Author: Charles Bailey bailey@genetics.upenn.edu
- * Revised: 24-Mar-1998
+ * Version: 2.2
+ * Author: Charles Bailey bailey@newman.upenn.edu
+ * Revised: 18-Jul-1998
*
*/
ST(0) = &PL_sv_undef;
void
+binmode(fh)
+ SV * fh
+ PROTOTYPE: $
+ CODE:
+ IO *io = sv_2io(fh);
+ FILE *fp = io ? IoOFP(io) : NULL;
+ char iotype = io ? IoTYPE(io) : '\0';
+ char filespec[NAM$C_MAXRSS], *acmode, *s, *colon, *dirend = Nullch;
+ int ret = 0, saverrno = errno, savevmserrno = vaxc$errno;
+ fpos_t pos;
+ if (fp == NULL || strchr(">was+-|",iotype) == Nullch) {
+ set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN); XSRETURN_UNDEF;
+ }
+ if (!fgetname(fp,filespec)) XSRETURN_UNDEF;
+ for (s = filespec; *s; s++) {
+ if (*s == ':') colon = s;
+ else if (*s == ']' || *s == '>') dirend = s;
+ }
+ /* Looks like a tmpfile, which will go away if reopened */
+ if (s == dirend + 3) {
+ set_errno(EBADF); set_vaxc_errno(RMS$_IOP); XSRETURN_UNDEF;
+ }
+ /* If we've got a non-file-structured device, clip off the trailing
+ * junk, and don't lose sleep if we can't get a stream position. */
+ if (dirend == Nullch) *(colon+1) = '\0';
+ if (iotype != '-' && (ret = fgetpos(fp, &pos)) == -1 && dirend)
+ XSRETURN_UNDEF;
+ switch (iotype) {
+ case '<': case 'r': acmode = "rb"; break;
+ case '>': case 'w': case '|':
+ /* use 'a' instead of 'w' to avoid creating new file;
+ fsetpos below will take care of restoring file position */
+ case 'a': acmode = "ab"; break;
+ case '+': case 's': acmode = "rb+"; break;
+ case '-': acmode = fileno(fp) ? "ab" : "rb"; break;
+ /* iotype'll be null for the SYS$INPUT:/SYS$OUTPUT:/SYS$ERROR: files */
+ /* since we didn't really open them and can't really */
+ /* reopen them */
+ case 0: XSRETURN_UNDEF;
+ default:
+ if (PL_dowarn) warn("Unrecognized iotype %c for %s in binmode",
+ iotype, filespec);
+ acmode = "rb+";
+ }
+ if (freopen(filespec,acmode,fp) == NULL) XSRETURN_UNDEF;
+ if (iotype != '-' && ret != -1 && fsetpos(fp,&pos) == -1) XSRETURN_UNDEF;
+ if (ret == -1) { set_errno(saverrno); set_vaxc_errno(savevmserrno); }
+ XSRETURN_YES;
+
+
+void
flush(fp)
FILE * fp
PROTOTYPE: $
IO *io = sv_2io(mysv);
FILE *fp = io ? IoOFP(io) : NULL;
if (fp == NULL || strchr(">was+-|",IoTYPE(io)) == Nullch) {
- set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN);
- ST(0) = &PL_sv_undef; XSRETURN(1);
+ set_errno(EBADF); set_vaxc_errno(SS$_IVCHAN); XSRETURN_UNDEF;
}
if (fgetname(fp,devnam) == Nullch) { ST(0) = &PL_sv_undef; XSRETURN(1); }
if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
-# Tests for VMS::Stdio v2.1
+# Tests for VMS::Stdio v2.2
use VMS::Stdio;
import VMS::Stdio qw(&flush &getname &rewind &sync &tmpnam);
@compexcl=('cpp.t');
@ioexcl=('argv.t','dup.t','fs.t','pipe.t');
@libexcl=('db-btree.t','db-hash.t','db-recno.t',
- 'gdbm.t','io_dup.t', 'io_pipe.t', 'io_sel.t', 'io_sock.t',
+ 'gdbm.t','io_dup.t', 'io_pipe.t', 'io_poll.t', 'io_sel.t',
+ 'io_sock.t', 'io_unix.t',
'ndbm.t','odbm.t','open2.t','open3.t', 'ph.t', 'posix.t');
# Note: POSIX is not part of basic build, but can be built
*
* VMS-specific C header file for perl5.
*
- * Last revised: 18-Feb-1997 by Charles Bailey bailey@genetics.upenn.edu
- * Version: 5.3.28
+ * Last revised: 16-Sep-1998 by Charles Bailey bailey@newman.upenn.edu
+ * Version: 5.5.2
*/
#ifndef __vmsish_h_included
# define DONT_MASK_RTL_CALLS
#endif
- /* defined for vms.c so we can see CRTL | defined for a2p */
+/* Note that we do, in fact, have this */
+#define HAS_GETENV_SV
+
#ifndef DONT_MASK_RTL_CALLS
# ifdef getenv
# undef getenv
# endif
-# define getenv(v) my_getenv(v) /* getenv used for regular logical names */
+ /* getenv used for regular logical names */
+# define getenv(v) my_getenv(v,TRUE)
#endif
+#define getenv_sv(v) my_getenv_sv(v,TRUE)
/* DECC introduces this routine in the RTL as of VMS 7.0; for now,
* we'll use ours, since it gives us the full VMS exit status. */
#define DONT_DECLARE_STD 1
/* Our own contribution to PerlShr's global symbols . . . */
-# define my_trnlnm Perl_my_trnlnm
-# define my_getenv Perl_my_getenv
-# define prime_env_iter Perl_prime_env_iter
-# define my_setenv Perl_my_setenv
-# define my_crypt Perl_my_crypt
-# define my_waitpid Perl_my_waitpid
-# define my_gconvert Perl_my_gconvert
-# define do_rmdir Perl_do_rmdir
-# define kill_file Perl_kill_file
-# define my_mkdir Perl_my_mkdir
-# define my_utime Perl_my_utime
-# define rmsexpand Perl_rmsexpand
-# define rmsexpand_ts Perl_rmsexpand_ts
-# define fileify_dirspec Perl_fileify_dirspec
-# define fileify_dirspec_ts Perl_fileify_dirspec_ts
-# define pathify_dirspec Perl_pathify_dirspec
-# define pathify_dirspec_ts Perl_pathify_dirspec_ts
-# define tounixspec Perl_tounixspec
-# define tounixspec_ts Perl_tounixspec_ts
-# define tovmsspec Perl_tovmsspec
-# define tovmsspec_ts Perl_tovmsspec_ts
-# define tounixpath Perl_tounixpath
-# define tounixpath_ts Perl_tounixpath_ts
-# define tovmspath Perl_tovmspath
-# define tovmspath_ts Perl_tovmspath_ts
-# define vms_image_init Perl_vms_image_init
-# define opendir Perl_opendir
-# define readdir Perl_readdir
-# define telldir Perl_telldir
-# define seekdir Perl_seekdir
-# define closedir Perl_closedir
-# define vmsreaddirversions Perl_vmsreaddirversions
-# define my_gmtime Perl_my_gmtime
-# define my_localtime Perl_my_localtime
-# define my_time Perl_my_time
-# define my_sigemptyset Perl_my_sigemptyset
-# define my_sigfillset Perl_my_sigfillset
-# define my_sigaddset Perl_my_sigaddset
-# define my_sigdelset Perl_my_sigdelset
-# define my_sigismember Perl_my_sigismember
-# define my_sigprocmask Perl_my_sigprocmask
-# define cando_by_name Perl_cando_by_name
-# define flex_fstat Perl_flex_fstat
-# define flex_stat Perl_flex_stat
-# define trim_unixpath Perl_trim_unixpath
-# define my_vfork Perl_my_vfork
-# define vms_do_aexec Perl_vms_do_aexec
-# define vms_do_exec Perl_vms_do_exec
-# define do_aspawn Perl_do_aspawn
-# define do_spawn Perl_do_spawn
-# define my_fwrite Perl_my_fwrite
-# define my_flush Perl_my_flush
-# define my_binmode Perl_my_binmode
-# define my_getpwnam Perl_my_getpwnam
-# define my_getpwuid Perl_my_getpwuid
-# define my_getpwent Perl_my_getpwent
-# define my_endpwent Perl_my_endpwent
-# define my_getlogin Perl_my_getlogin
-# define rmscopy Perl_rmscopy
-# define init_os_extras Perl_init_os_extras
+#define vmstrnenv Perl_vmstrnenv
+#define my_trnlnm Perl_my_trnlnm
+#define my_getenv Perl_my_getenv
+#define my_getenv_sv Perl_my_getenv_sv
+#define prime_env_iter Perl_prime_env_iter
+#define vmssetenv Perl_vmssetenv
+#define my_setenv Perl_my_setenv
+#define my_crypt Perl_my_crypt
+#define my_waitpid Perl_my_waitpid
+#define my_gconvert Perl_my_gconvert
+#define do_rmdir Perl_do_rmdir
+#define kill_file Perl_kill_file
+#define my_mkdir Perl_my_mkdir
+#define my_utime Perl_my_utime
+#define rmsexpand Perl_rmsexpand
+#define rmsexpand_ts Perl_rmsexpand_ts
+#define fileify_dirspec Perl_fileify_dirspec
+#define fileify_dirspec_ts Perl_fileify_dirspec_ts
+#define pathify_dirspec Perl_pathify_dirspec
+#define pathify_dirspec_ts Perl_pathify_dirspec_ts
+#define tounixspec Perl_tounixspec
+#define tounixspec_ts Perl_tounixspec_ts
+#define tovmsspec Perl_tovmsspec
+#define tovmsspec_ts Perl_tovmsspec_ts
+#define tounixpath Perl_tounixpath
+#define tounixpath_ts Perl_tounixpath_ts
+#define tovmspath Perl_tovmspath
+#define tovmspath_ts Perl_tovmspath_ts
+#define vms_image_init Perl_vms_image_init
+#define opendir Perl_opendir
+#define readdir Perl_readdir
+#define telldir Perl_telldir
+#define seekdir Perl_seekdir
+#define closedir Perl_closedir
+#define vmsreaddirversions Perl_vmsreaddirversions
+#define my_gmtime Perl_my_gmtime
+#define my_localtime Perl_my_localtime
+#define my_time Perl_my_time
+#define my_sigemptyset Perl_my_sigemptyset
+#define my_sigfillset Perl_my_sigfillset
+#define my_sigaddset Perl_my_sigaddset
+#define my_sigdelset Perl_my_sigdelset
+#define my_sigismember Perl_my_sigismember
+#define my_sigprocmask Perl_my_sigprocmask
+#define cando_by_name Perl_cando_by_name
+#define flex_fstat Perl_flex_fstat
+#define flex_stat Perl_flex_stat
+#define trim_unixpath Perl_trim_unixpath
+#define my_vfork Perl_my_vfork
+#define vms_do_aexec Perl_vms_do_aexec
+#define vms_do_exec Perl_vms_do_exec
+#define do_aspawn Perl_do_aspawn
+#define do_spawn Perl_do_spawn
+#define my_fwrite Perl_my_fwrite
+#define my_flush Perl_my_flush
+#define my_getpwnam Perl_my_getpwnam
+#define my_getpwuid Perl_my_getpwuid
+#define my_getpwent Perl_my_getpwent
+#define my_endpwent Perl_my_endpwent
+#define my_getlogin Perl_my_getlogin
+#define rmscopy Perl_rmscopy
+#define init_os_extras Perl_init_os_extras
/* Delete if at all possible, changing protections if necessary. */
#define unlink kill_file
#define VMSISH_EXIT TEST_VMSISH(HINT_M_VMSISH_EXIT)
#define VMSISH_TIME TEST_VMSISH(HINT_M_VMSISH_TIME)
+/* Flags for vmstrnenv() */
+#define PERL__TRNENV_SECURE 0x01
+
/* 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)) { \
* that a file is in "binary" mode -- that is, that no translation
* of bytes occurs on read or write operations.
*/
-#define USEMYBINMODE
+#undef USEMYBINMODE
/* Stat_t:
* This symbol holds the type used to declare buffers for information
#define DYNAMIC_ENV_FETCH 1
#define ENV_HV_NAME "%EnV%VmS%"
/* Special getenv function for retrieving %ENV elements. */
-#define ENV_getenv(v) my_getenv(v)
+#define ENVgetenv(v) my_getenv(v,FALSE)
+#define ENVgetenv_sv(v) my_getenv_sv(v,FALSE)
/* Thin jacket around cuserid() tomatch Unix' calling sequence */
void init_os_extras _(());
/* prototype section start marker; `typedef' passes through cpp */
typedef char __VMS_PROTOTYPES__;
-int my_trnlnm _((char *, char *, unsigned long int));
-char * my_getenv _((const char *));
+int vmstrnenv _((const char *, char *, unsigned long int, struct dsc$descriptor_s **, unsigned long int));
+int my_trnlnm _((const char *, char *, unsigned long int));
+char * my_getenv _((const char *, bool));
+SV * my_getenv_sv _((const char *, bool));
+int vmssetenv _((char *, char *, struct dsc$descriptor_s **));
char * my_crypt _((const char *, const char *));
Pid_t my_waitpid _((Pid_t, int *, int));
char * my_gconvert _((double, int, int, char *));
unsigned long int do_spawn _((char *));
int my_fwrite _((void *, size_t, size_t, FILE *));
int my_flush _((FILE *));
-FILE * my_binmode _((FILE *, char));
struct passwd * my_getpwnam _((char *name));
struct passwd * my_getpwuid _((Uid_t uid));
struct passwd * my_getpwent _(());
projects / p5sagit/p5-mst-13.2.git / commitdiff