*
* VMS-specific routines for perl5
*
- * Last revised: 21-Jun-1996 by Charles Bailey bailey@genetics.upenn.edu
- * Version: 5.2.2
+ * Last revised: 18-Jul-1996 by Charles Bailey bailey@genetics.upenn.edu
+ * Version: 5.3.1
*/
#include <acedef.h>
#include <uaidef.h>
#include <uicdef.h>
+#ifndef SS$_NOSUCHOBJECT /* Older versions of ssdef.h don't have this */
+# define SS$_NOSUCHOBJECT 2696
+#endif
+
+/* Don't intercept calls to vfork, since my_vfork below needs to
+ * get to the underlying CRTL routine. */
+#define __DONT_MASK_VFORK
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
{LNM$C_NAMLENGTH, LNM$_STRING, 0, &eqvlen},
{0, 0, 0, 0}};
+ if (!lnm || idx > LNM$_MAX_INDEX) {
+ set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
+ }
if (!eqv) eqv = __my_trnlnm_eqv;
lnmlst[1].bufadr = (void *)eqv;
lnmdsc.dsc$a_pointer = lnm;
}
yourroom:
- if (rmsts) {
- fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
- if (aclsts & 1) aclsts = fndsts;
- }
+ fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
+ /* We just deleted it, so of course it's not there. Some versions of
+ * VMS seem to return success on the unlock operation anyhow (after all
+ * the unlock is successful), but others don't.
+ */
+ if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts == SS$_NORMAL;
+ if (aclsts & 1) aclsts = fndsts;
if (!(aclsts & 1)) {
set_errno(EVMSERR);
set_vaxc_errno(aclsts);
static char *do_fileify_dirspec(char *dir,char *buf,int ts)
{
static char __fileify_retbuf[NAM$C_MAXRSS+1];
- unsigned long int dirlen, retlen, addmfd = 0;
+ unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
char *retspec, *cp1, *cp2, *lastdir;
char trndir[NAM$C_MAXRSS+1], vmsdir[NAM$C_MAXRSS+1];
dir[dirlen-1] = ']';
}
- if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */
+ if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
+ /* If we've got an explicit filename, we can just shuffle the string. */
+ if (*(cp1+1)) hasfilename = 1;
+ /* Similarly, we can just back up a level if we've got multiple levels
+ of explicit directories in a VMS spec which ends with directories. */
+ else {
+ for (cp2 = cp1; cp2 > dir; cp2--) {
+ if (*cp2 == '.') {
+ *cp2 = *cp1; *cp1 = '\0';
+ hasfilename = 1;
+ break;
+ }
+ if (*cp2 == '[' || *cp2 == '<') break;
+ }
+ }
+ }
+
+ if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
if (dir[0] == '.') {
if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
return do_fileify_dirspec("[]",buf,ts);
} while ((cp1 = strstr(cp1,"/.")) != NULL);
}
else {
- if (!(lastdir = cp1 = strrchr(dir,'/'))) cp1 = dir;
+ if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
+ !(lastdir = cp1 = strrchr(dir,']')) &&
+ !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
- if (toupper(*(cp2+1)) == 'D' && /* Yep. Is it .dir? */
- toupper(*(cp2+2)) == 'I' &&
- toupper(*(cp2+3)) == 'R') {
- if ((cp1 = strchr(cp2,';')) || (cp1 = strchr(cp2+1,'.'))) {
- if (*(cp1+1) != '1' || *(cp1+2) != '\0') { /* Version is not ;1 */
- set_errno(ENOTDIR); /* Bzzt. */
- set_vaxc_errno(RMS$_DIR);
- return NULL;
- }
- }
- dirlen = cp2 - dir;
- }
- else { /* There's a type, and it's not .dir. Bzzt. */
- set_errno(ENOTDIR);
+ int ver; char *cp3;
+ if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
+ !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
+ !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
+ (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
+ (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
+ (ver || *cp3)))))) {
+ set_errno(ENOTDIR);
set_vaxc_errno(RMS$_DIR);
return NULL;
}
+ dirlen = cp2 - dir;
}
}
/* If we lead off with a device or rooted logical, add the MFD
}
dir = trndir;
- if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */
+ if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
if (*dir == '.' && (*(dir+1) == '\0' ||
(*(dir+1) == '.' && *(dir+2) == '\0')))
retlen = 2 + (*(dir+1) != '\0');
else {
- if (!(cp1 = strrchr(dir,'/'))) cp1 = dir;
- if ((cp2 = strchr(cp1,'.')) && (*(cp2+1) != '.' && *(cp2+1) != '\0')) {
- if (toupper(*(cp2+1)) == 'D' && /* They specified .dir. */
- toupper(*(cp2+2)) == 'I' && /* Trim it off. */
- toupper(*(cp2+3)) == 'R') {
- retlen = cp2 - dir + 1;
- }
- else { /* Some other file type. Bzzt. */
+ if ( !(cp1 = strrchr(dir,'/')) &&
+ !(cp1 = strrchr(dir,']')) &&
+ !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
+ if ((cp2 = strchr(cp1,'.')) != NULL) {
+ int ver; char *cp3;
+ if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
+ !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
+ !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
+ (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
+ (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
+ (ver || *cp3)))))) {
set_errno(ENOTDIR);
set_vaxc_errno(RMS$_DIR);
return NULL;
}
+ retlen = cp2 - dir + 1;
}
else { /* No file type present. Treat the filename as a directory. */
retlen = strlen(dir) + 1;
struct FAB dirfab = cc$rms_fab;
struct NAM savnam, dirnam = cc$rms_nam;
+ /* If we've got an explicit filename, we can just shuffle the string. */
+ if ( ( (cp1 = strrchr(dir,']')) != NULL ||
+ (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
+ if ((cp2 = strchr(cp1,'.')) != NULL) {
+ int ver; char *cp3;
+ if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
+ !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
+ !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
+ (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
+ (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
+ (ver || *cp3)))))) {
+ set_errno(ENOTDIR);
+ set_vaxc_errno(RMS$_DIR);
+ return NULL;
+ }
+ }
+ else { /* No file type, so just draw name into directory part */
+ for (cp2 = cp1; *cp2; cp2++) ;
+ }
+ *cp2 = *cp1;
+ *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
+ *cp1 = '.';
+ /* We've now got a VMS 'path'; fall through */
+ }
dirfab.fab$b_fns = strlen(dir);
dirfab.fab$l_fna = dir;
if (dir[dirfab.fab$b_fns-1] == ']' ||
int islnm, rooted;
STRLEN trnend;
- while (*(++cp2) == '/') ; /* Skip multiple /s */
+ while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
*cp1 = '\0';
islnm = my_trnlnm(rslt,trndev,0);
{
if (j+1 >= argc)
{
- fprintf(stderr,"No input file after < on command line");
+ fprintf(Perl_debug_log,"No input file after < on command line");
exit(LIB$_WRONUMARG);
}
in = argv[++j];
{
if (j+1 >= argc)
{
- fprintf(stderr,"No output file after > on command line");
+ fprintf(Perl_debug_log,"No output file after > on command line");
exit(LIB$_WRONUMARG);
}
out = argv[++j];
out = 1 + ap;
if (j >= argc)
{
- fprintf(stderr,"No output file after > or >> on command line");
+ fprintf(Perl_debug_log,"No output file after > or >> on command line");
exit(LIB$_WRONUMARG);
}
continue;
err = 2 + ap;
if (j >= argc)
{
- fprintf(stderr,"No output file after 2> or 2>> on command line");
+ fprintf(Perl_debug_log,"No output file after 2> or 2>> on command line");
exit(LIB$_WRONUMARG);
}
continue;
{
if (j+1 >= argc)
{
- fprintf(stderr,"No command into which to pipe on command line");
+ fprintf(Perl_debug_log,"No command into which to pipe on command line");
exit(LIB$_WRONUMARG);
}
cmargc = argc-(j+1);
{
if (out != NULL)
{
- fprintf(stderr,"'|' and '>' may not both be specified on command line");
+ fprintf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
exit(LIB$_INVARGORD);
}
pipe_and_fork(cmargv);
freopen(mbxname, "rb", stdin);
if (errno != 0)
{
- fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
+ fprintf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
exit(vaxc$errno);
}
}
if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
{
- fprintf(stderr,"Can't open input file %s as stdin",in);
+ fprintf(Perl_debug_log,"Can't open input file %s as stdin",in);
exit(vaxc$errno);
}
if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
{
- fprintf(stderr,"Can't open output file %s as stdout",out);
+ fprintf(Perl_debug_log,"Can't open output file %s as stdout",out);
exit(vaxc$errno);
}
if (err != NULL) {
FILE *tmperr;
if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
{
- fprintf(stderr,"Can't open error file %s as stderr",err);
+ fprintf(Perl_debug_log,"Can't open error file %s as stderr",err);
exit(vaxc$errno);
}
fclose(tmperr);
- if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
+ if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
{
exit(vaxc$errno);
}
}
#ifdef ARGPROC_DEBUG
- fprintf(stderr, "Arglist:\n");
+ fprintf(Perl_debug_log, "Arglist:\n");
for (j = 0; j < *ac; ++j)
- fprintf(stderr, "argv[%d] = '%s'\n", j, argv[j]);
+ fprintf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
#endif
+ /* Clear errors we may have hit expanding wildcards, so they don't
+ show up in Perl's $! later */
+ set_errno(0); set_vaxc_errno(1);
} /* end of getredirection() */
/*}}}*/
$DESCRIPTOR(resultspec, "");
unsigned long int zero = 0, sts;
- if (strcspn(item, "*%") == strlen(item))
+ if (strcspn(item, "*%") == strlen(item) || strchr(item,' ') != NULL)
{
add_item(head, tail, item, count);
return;
switch (sts)
{
case RMS$_FNF:
+ case RMS$_DNF:
case RMS$_DIR:
set_errno(ENOENT); break;
case RMS$_DEV:
case RMS$_PRV:
set_errno(EACCES); break;
default:
- _ckvmssts(sts);
+ _ckvmssts_noperl(sts);
}
}
if (expcount == 0)
add_item(head, tail, item, count);
- _ckvmssts(lib$sfree1_dd(&resultspec));
- _ckvmssts(lib$find_file_end(&context));
+ _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
+ _ckvmssts_noperl(lib$find_file_end(&context));
}
static int child_st[2];/* Event Flag set when child process completes */
if (0 == child_st[0])
{
#ifdef ARGPROC_DEBUG
- fprintf(stderr, "Waiting for Child Process to Finish . . .\n");
+ fprintf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
#endif
fflush(stdout); /* Have to flush pipe for binary data to */
/* terminate properly -- <tp@mccall.com> */
static void sig_child(int chan)
{
#ifdef ARGPROC_DEBUG
- fprintf(stderr, "Child Completion AST\n");
+ fprintf(Perl_debug_log, "Child Completion AST\n");
#endif
if (child_st[0] == 0)
child_st[0] = 1;
create_mbx(&child_chan,&mbxdsc);
#ifdef ARGPROC_DEBUG
- fprintf(stderr, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
- fprintf(stderr, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
+ fprintf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
+ fprintf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
#endif
- _ckvmssts(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
- 0, &pid, child_st, &zero, sig_child,
- &child_chan));
+ _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
+ 0, &pid, child_st, &zero, sig_child,
+ &child_chan));
#ifdef ARGPROC_DEBUG
- fprintf(stderr, "Subprocess's Pid = %08X\n", pid);
+ fprintf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
#endif
sys$dclexh(&exit_block);
if (NULL == freopen(mbxname, "wb", stdout))
{
- fprintf(stderr,"Can't open output pipe (name %s)",mbxname);
+ fprintf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
}
}
}
value.dsc$a_pointer = command;
value.dsc$w_length = strlen(value.dsc$a_pointer);
- _ckvmssts(lib$set_symbol(&cmd, &value));
+ _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
- _ckvmssts(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
+ _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
}
else {
- _ckvmssts(retsts);
+ _ckvmssts_noperl(retsts);
}
#ifdef ARGPROC_DEBUG
- fprintf(stderr, "%s\n", command);
+ fprintf(Perl_debug_log, "%s\n", command);
#endif
sprintf(pidstring, "%08X", pid);
- fprintf(stderr, "%s\n", pidstring);
+ fprintf(Perl_debug_log, "%s\n", pidstring);
pidstr.dsc$a_pointer = pidstring;
pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
lib$set_symbol(&pidsymbol, &pidstr);
}
retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
-#ifndef SS$_NOSUCHOBJECT /* Older versions of ssdef.h don't have this */
-# define SS$_NOSUCHOBJECT 2696
-#endif
if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
retsts == RMS$_FNF || retsts == RMS$_DIR ||
retsts == RMS$_DEV) {
/*{{{ int flex_fstat(int fd, struct stat *statbuf)*/
+#undef stat
int
-flex_fstat(int fd, struct stat *statbuf)
+flex_fstat(int fd, struct mystat *statbufp)
{
- char fspec[NAM$C_MAXRSS+1];
-
- if (!getname(fd,fspec,1)) return -1;
- return flex_stat(fspec,statbuf);
+ if (!fstat(fd,(stat_t *) statbufp)) {
+ statbufp->st_dev = encode_dev(statbufp->st_devnam);
+ return 0;
+ }
+ return -1;
} /* end of flex_fstat() */
/*}}}*/
* to the system version here, since we're actually calling their
* stat().
*/
-#undef stat
int
flex_stat(char *fspec, struct mystat *statbufp)
{
#define stat mystat
/*}}}*/
+/* Insures that no carriage-control translation will be done on a file. */
+/*{{{FILE *my_binmode(FILE *fp, char iotype)*/
+FILE *
+my_binmode(FILE *fp, char iotype)
+{
+ char filespec[NAM$C_MAXRSS], *acmode;
+ fpos_t pos;
+
+ if (!fgetname(fp,filespec)) return NULL;
+ if (fgetpos(fp,&pos) == -1) return NULL;
+ switch (iotype) {
+ case '<': case 'r': acmode = "rb"; break;
+ case '>': case 'w': acmode = "wb"; break;
+ case '+': case '|': case 's': acmode = "rb+"; break;
+ case 'a': acmode = "ab"; break;
+ case '-': acmode = fileno(fp) ? "wb" : "rb"; break;
+ }
+ if (freopen(filespec,acmode,fp) == NULL) return NULL;
+ if (fsetpos(fp,&pos) == -1) return NULL;
+} /* end of my_binmode() */
+/*}}}*/
+
+
/*{{{char *my_getlogin()*/
/* VMS cuserid == Unix getlogin, except calling sequence */
char *
if (preserve_dates & 2) {
/* sys$close() will process xabrdt, not xabdat */
xabrdt = cc$rms_xabrdt;
+#ifndef __GNUC__
xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
+#else
+ /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
+ * is unsigned long[2], while DECC & VAXC use a struct */
+ memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
+#endif
fab_out.fab$l_xab = (void *) &xabrdt;
}
STRLEN speclen;
unsigned long int retsts, haslower = 0;
+ if (items > 2) croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
+
myfab.fab$l_fna = SvPV(ST(0),speclen);
myfab.fab$b_fns = speclen;
myfab.fab$l_nam = &mynam;
+ if (items == 2) {
+ myfab.fab$l_dna = SvPV(ST(1),speclen);
+ myfab.fab$b_dns = speclen;
+ }
+
mynam.nam$l_esa = esa;
mynam.nam$b_ess = sizeof esa;
mynam.nam$l_rsa = rsa;
retsts = sys$parse(&myfab,0,0);
if (!(retsts & 1)) {
+ if (retsts == RMS$_DNF) {
+ mynam.nam$b_nop |= NAM$M_SYNCHK;
+ retsts = sys$parse(&myfab,0,0);
+ if (retsts & 1) goto expanded;
+ }
set_vaxc_errno(retsts);
if (retsts == RMS$_PRV) set_errno(EACCES);
else if (retsts == RMS$_DEV) set_errno(ENODEV);
else set_errno(EVMSERR);
XSRETURN_UNDEF;
}
+
/* If the input filespec contained any lowercase characters,
* downcase the result for compatibility with Unix-minded code. */
+ expanded:
for (out = myfab.fab$l_fna; *out; out++)
if (islower(*out)) { haslower = 1; break; }
if (mynam.nam$b_rsl) { out = rsa; speclen = mynam.nam$b_rsl; }
projects / p5sagit/p5-mst-13.2.git / commitdiff