*
* VMS-specific routines for perl5
*
- * Last revised: 18-Jan-1996 by Charles Bailey bailey@genetics.upenn.edu
- * Version: 5.2.0
+ * Last revised: 14-Oct-1996 by Charles Bailey bailey@genetics.upenn.edu
+ * Version: 5.3.7
*/
#include <acedef.h>
#include <armdef.h>
#include <atrdef.h>
#include <chpdef.h>
+#include <climsgdef.h>
#include <descrip.h>
#include <dvidef.h>
#include <fibdef.h>
#include <uaidef.h>
#include <uicdef.h>
+/* Older versions of ssdef.h don't have these */
+#ifndef SS$_INVFILFOROP
+# define SS$_INVFILFOROP 3930
+#endif
+#ifndef SS$_NOSUCHOBJECT
+# 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"
unsigned short int *retlen;
};
+static char *__mystrtolower(char *str)
+{
+ if (str) for (; *str; ++str) *str= tolower(*str);
+ return str;
+}
+
int
my_trnlnm(char *lnm, char *eqv, unsigned long int idx)
{
{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;
}
else if (retsts & 1) {
eqv[eqvlen] = '\0';
- return 1;
+ return eqvlen;
}
_ckvmssts(retsts); /* Must be an error */
return 0; /* Not reached, assuming _ckvmssts() bails out */
my_getenv(char *lnm)
{
static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
- char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
+ char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
unsigned long int idx = 0;
+ int trnsuccess;
for (cp1 = lnm, cp2= uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
*cp2 = '\0';
*cp2 = '\0';
idx = strtoul(cp2+1,NULL,0);
}
- if (my_trnlnm(uplnm,__my_getenv_eqv,idx)) {
- return __my_getenv_eqv;
- }
+ trnsuccess = my_trnlnm(uplnm,__my_getenv_eqv,idx);
+ /* If we had a translation index, we're only interested in lnms */
+ if (!trnsuccess && cp2 != NULL) return Nullch;
+ if (trnsuccess) return __my_getenv_eqv;
else {
unsigned long int retsts;
struct dsc$descriptor_s symdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
_ckvmssts(retsts);
}
/* Try for CRTL emulation of a Unix/POSIX name */
- else return getenv(lnm);
+ else return getenv(uplnm);
}
}
return Nullch;
} /* end of my_getenv() */
/*}}}*/
+/*{{{ void prime_env_iter() */
+void
+prime_env_iter(void)
+/* Fill the %ENV associative array with all logical names we can
+ * find, in preparation for iterating over it.
+ */
+{
+ static int primed = 0; /* XXX Not thread-safe!!! */
+ HV *envhv = GvHVn(envgv);
+ FILE *sholog;
+ char eqv[LNM$C_NAMLENGTH+1],*start,*end;
+ STRLEN eqvlen;
+ SV *oldrs, *linesv, *eqvsv;
+
+ if (primed) return;
+ /* Perform a dummy fetch as an lval to insure that the hash table is
+ * set up. Otherwise, the hv_store() will turn into a nullop */
+ (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
+ /* Also, set up the four "special" keys that the CRTL defines,
+ * whether or not underlying logical names exist. */
+ (void) hv_fetch(envhv,"HOME",4,TRUE);
+ (void) hv_fetch(envhv,"TERM",4,TRUE);
+ (void) hv_fetch(envhv,"PATH",4,TRUE);
+ (void) hv_fetch(envhv,"USER",4,TRUE);
+
+ /* Now, go get the logical names */
+ if ((sholog = my_popen("$ Show Logical *","r")) == Nullfp)
+ _ckvmssts(vaxc$errno);
+ /* We use Perl's sv_gets to read from the pipe, since my_popen is
+ * tied to Perl's I/O layer, so it may not return a simple FILE * */
+ oldrs = rs;
+ rs = newSVpv("\n",1);
+ linesv = newSVpv("",0);
+ while (1) {
+ if ((start = sv_gets(linesv,sholog,0)) == Nullch) {
+ my_pclose(sholog);
+ SvREFCNT_dec(linesv); SvREFCNT_dec(rs); rs = oldrs;
+ primed = 1;
+ return;
+ }
+ while (*start != '"' && *start != '=' && *start) start++;
+ if (*start != '"') continue;
+ for (end = ++start; *end && *end != '"'; end++) ;
+ if (*end) *end = '\0';
+ else end = Nullch;
+ if ((eqvlen = my_trnlnm(start,eqv,0)) == 0) {
+ if (vaxc$errno == SS$_NOLOGNAM || vaxc$errno == SS$_IVLOGNAM) {
+ if (dowarn)
+ warn("Ill-formed logical name |%s| in prime_env_iter",start);
+ continue;
+ }
+ else _ckvmssts(vaxc$errno);
+ }
+ else {
+ eqvsv = newSVpv(eqv,eqvlen);
+ hv_store(envhv,start,(end ? end - start : strlen(start)),eqvsv,0);
+ }
+ }
+} /* end of prime_env_iter */
+/*}}}*/
+
+
/*{{{ void my_setenv(char *lnm, char *eqv)*/
void
my_setenv(char *lnm,char *eqv)
/*}}}*/
+static char *do_rmsexpand(char *, char *, int, char *, unsigned);
static char *do_fileify_dirspec(char *, char *, int);
static char *do_tovmsspec(char *, char *, int);
int
kill_file(char *name)
{
- char vmsname[NAM$C_MAXRSS+1];
+ char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
- if (!remove(name)) return 0; /* Can we just get rid of it? */
+ /* Expand the input spec using RMS, since the CRTL remove() and
+ * system services won't do this by themselves, so we may miss
+ * a file "hiding" behind a logical name or search list. */
+ if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
+ if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
+ if (!remove(rspec)) return 0; /* Can we just get rid of it? */
+ /* If not, can changing protections help? */
+ if (vaxc$errno != RMS$_PRV) return -1;
/* No, so we get our own UIC to use as a rights identifier,
* and the insert an ACE at the head of the ACL which allows us
* to delete the file.
*/
_ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
- if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
- fildsc.dsc$w_length = strlen(vmsname);
- fildsc.dsc$a_pointer = vmsname;
+ fildsc.dsc$w_length = strlen(rspec);
+ fildsc.dsc$a_pointer = rspec;
cxt = 0;
newace.myace$l_ident = oldace.myace$l_ident;
if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
- set_errno(EVMSERR);
+ switch (aclsts) {
+ case RMS$_FNF:
+ case RMS$_DNF:
+ case RMS$_DIR:
+ case SS$_NOSUCHOBJECT:
+ set_errno(ENOENT); break;
+ case RMS$_DEV:
+ set_errno(ENODEV); break;
+ case RMS$_FNM:
+ case RMS$_SYN:
+ case SS$_INVFILFOROP:
+ set_errno(EINVAL); break;
+ case RMS$_PRV:
+ set_errno(EACCES); break;
+ default:
+ _ckvmssts(aclsts);
+ }
set_vaxc_errno(aclsts);
return -1;
}
}
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);
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 reqult of our IO$_MODIFY $QIO. */
+ * 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];
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);
struct pipe_details
{
struct pipe_details *next;
- FILE *fp; /* stdio file pointer to pipe mailbox */
+ PerlIO *fp; /* stdio file pointer to pipe mailbox */
int pid; /* PID of subprocess */
int mode; /* == 'r' if pipe open for reading */
int done; /* subprocess has completed */
DSC$K_CLASS_S, 0};
+ cmddsc.dsc$w_length=strlen(cmd);
+ cmddsc.dsc$a_pointer=cmd;
+ if (cmddsc.dsc$w_length > 255) {
+ set_errno(E2BIG); set_vaxc_errno(CLI$_BUFOVF);
+ return Nullfp;
+ }
+
New(7001,info,1,struct pipe_details);
/* create mailbox */
create_mbx(&chan,&namdsc);
/* open a FILE* onto it */
- info->fp=fopen(mbxname, mode);
+ info->fp = PerlIO_open(mbxname, mode);
/* give up other channel onto it */
_ckvmssts(sys$dassgn(chan));
if (!info->fp)
return Nullfp;
- cmddsc.dsc$w_length=strlen(cmd);
- cmddsc.dsc$a_pointer=cmd;
-
info->mode = *mode;
info->done = FALSE;
info->completion=0;
/* get here => no such pipe open */
croak("No such pipe open");
- fclose(info->fp);
+ /* If we were writing to a subprocess, insure that someone reading from
+ * the mailbox gets an EOF. It looks like a simple fclose() doesn't
+ * produce an EOF record in the mailbox. */
+ if (info->mode != 'r') {
+ char devnam[NAM$C_MAXRSS+1], *cp;
+ unsigned long int chan, iosb[2], retsts, retsts2;
+ struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
+
+ if (fgetname(info->fp,devnam)) {
+ /* It oughta be a mailbox, so fgetname should give just the device
+ * name, but just in case . . . */
+ if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
+ devdsc.dsc$w_length = strlen(devnam);
+ _ckvmssts(sys$assign(&devdsc,&chan,0,0));
+ retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0);
+ if (retsts & 1) retsts = iosb[0];
+ retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
+ if (retsts & 1) retsts = retsts2;
+ _ckvmssts(retsts);
+ }
+ else _ckvmssts(vaxc$errno); /* Should never happen */
+ }
+ PerlIO_close(info->fp);
if (info->done) retsts = info->completion;
else waitpid(info->pid,(int *) &retsts,0);
}
/*}}}*/
+
+/*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
+/* Shortcut for common case of simple calls to $PARSE and $SEARCH
+ * to expand file specification. Allows for a single default file
+ * specification and a simple mask of options. If outbuf is non-NULL,
+ * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
+ * the resultant file specification is placed. If outbuf is NULL, the
+ * resultant file specification is placed into a static buffer.
+ * The third argument, if non-NULL, is taken to be a default file
+ * specification string. The fourth argument is unused at present.
+ * rmesexpand() returns the address of the resultant string if
+ * successful, and NULL on error.
+ */
+static char *
+do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
+{
+ static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
+ char esa[NAM$C_MAXRSS], *cp, *out = NULL;
+ struct FAB myfab = cc$rms_fab;
+ struct NAM mynam = cc$rms_nam;
+ STRLEN speclen;
+ unsigned long int retsts, haslower = 0;
+
+ if (!filespec || !*filespec) {
+ set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
+ return NULL;
+ }
+ if (!outbuf) {
+ if (ts) out = New(7019,outbuf,NAM$C_MAXRSS+1,char);
+ else outbuf = __rmsexpand_retbuf;
+ }
+
+ myfab.fab$l_fna = filespec;
+ myfab.fab$b_fns = strlen(filespec);
+ myfab.fab$l_nam = &mynam;
+
+ if (defspec && *defspec) {
+ myfab.fab$l_dna = defspec;
+ myfab.fab$b_dns = strlen(defspec);
+ }
+
+ mynam.nam$l_esa = esa;
+ mynam.nam$b_ess = sizeof esa;
+ mynam.nam$l_rsa = outbuf;
+ mynam.nam$b_rss = NAM$C_MAXRSS;
+
+ retsts = sys$parse(&myfab,0,0);
+ if (!(retsts & 1)) {
+ if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
+ retsts == RMS$_DEV || retsts == RMS$_DEV) {
+ mynam.nam$b_nop |= NAM$M_SYNCHK;
+ retsts = sys$parse(&myfab,0,0);
+ if (retsts & 1) goto expanded;
+ }
+ if (out) Safefree(out);
+ set_vaxc_errno(retsts);
+ if (retsts == RMS$_PRV) set_errno(EACCES);
+ else if (retsts == RMS$_DEV) set_errno(ENODEV);
+ else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
+ else set_errno(EVMSERR);
+ return NULL;
+ }
+ retsts = sys$search(&myfab,0,0);
+ if (!(retsts & 1) && retsts != RMS$_FNF) {
+ if (out) Safefree(out);
+ set_vaxc_errno(retsts);
+ if (retsts == RMS$_PRV) set_errno(EACCES);
+ else set_errno(EVMSERR);
+ return NULL;
+ }
+
+ /* 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 = outbuf; speclen = mynam.nam$b_rsl; }
+ else { out = esa; speclen = mynam.nam$b_esl; }
+ if (!(mynam.nam$l_fnb & NAM$M_EXP_VER) &&
+ (!defspec || !*defspec || !strchr(myfab.fab$l_dna,';')))
+ speclen = mynam.nam$l_ver - out;
+ /* If we just had a directory spec on input, $PARSE "helpfully"
+ * adds an empty name and type for us */
+ if (mynam.nam$l_name == mynam.nam$l_type &&
+ mynam.nam$l_ver == mynam.nam$l_type + 1 &&
+ !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
+ speclen = mynam.nam$l_name - out;
+ out[speclen] = '\0';
+ if (haslower) __mystrtolower(out);
+
+ /* Have we been working with an expanded, but not resultant, spec? */
+ if (!mynam.nam$b_rsl) strcpy(outbuf,esa);
+ return outbuf;
+}
+/*}}}*/
+/* External entry points */
+char *rmsexpand(char *spec, char *buf, char *def, unsigned opt)
+{ return do_rmsexpand(spec,buf,0,def,opt); }
+char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
+{ return do_rmsexpand(spec,buf,1,def,opt); }
+
+
/*
** The following routines are provided to make life easier when
** converting among VMS-style and Unix-style directory specifications.
** tounixspec() - convert any file spec into a Unix-style file spec.
** tovmsspec() - convert any file spec into a VMS-style spec.
**
-** Copyright 1995 by Charles Bailey <bailey@genetics.upenn.edu>
-** Permission is given for non-commercial use of this code according
-** to the terms of the GNU General Public License or the Perl
-** Artistic License. Copies of each may be found in the Perl
-** standard distribution. This software is supplied without any
-** warranty whatsoever.
+** Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>
+** Permission is given to distribute this code as part of the Perl
+** standard distribution under the terms of the GNU General Public
+** License or the Perl Artistic License. Copies of each may be
+** found in the Perl standard distribution.
*/
static char *do_tounixspec(char *, char *, int);
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];
set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
}
dirlen = strlen(dir);
- if (dir[dirlen-1] == '/') dir[--dirlen] = '\0';
+ if (dir[dirlen-1] == '/') --dirlen;
if (!dirlen) {
set_errno(ENOTDIR);
set_vaxc_errno(RMS$_DIR);
dir = trndir;
dirlen = strlen(dir);
}
+ else {
+ strncpy(trndir,dir,dirlen);
+ trndir[dirlen] = '\0';
+ dir = trndir;
+ }
/* If we were handed a rooted logical name or spec, treat it like a
* simple directory, so that
* $ Define myroot dev:[dir.]
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);
dirlen -= 1; /* to last element */
lastdir = strrchr(dir,'/');
}
- else if ((cp1 = strstr(trndir,"/.")) != NULL) {
+ else if ((cp1 = strstr(dir,"/.")) != NULL) {
+ /* If we have "/." or "/..", VMSify it and let the VMS code
+ * below expand it, rather than repeating the code to handle
+ * relative components of a filespec here */
do {
if (*(cp1+2) == '.') cp1++;
if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
- addmfd = 1;
- break;
+ if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
+ if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
+ return do_tounixspec(trndir,buf,ts);
}
cp1++;
} while ((cp1 = strstr(cp1,"/.")) != NULL);
- /* If we have a relative path, VMSify it and let the VMS code
- * below expand it, rather than repeating the code here */
- if (addmfd) {
- if (do_tovmsspec(trndir,vmsdir,0) == NULL) return NULL;
- if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
- return do_tounixspec(trndir,buf,ts);
- }
}
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. */
+ 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
return retspec;
}
else { /* VMS-style directory spec */
- char esa[NAM$C_MAXRSS+1], term;
- unsigned long int sts, cmplen, hasdev, hasdir, hastype, hasver;
+ char esa[NAM$C_MAXRSS+1], term, *cp;
+ unsigned long int sts, cmplen, haslower = 0;
struct FAB dirfab = cc$rms_fab;
struct NAM savnam, dirnam = cc$rms_nam;
dirfab.fab$b_dns = 6;
dirnam.nam$b_ess = NAM$C_MAXRSS;
dirnam.nam$l_esa = esa;
+
+ for (cp = dir; *cp; cp++)
+ if (islower(*cp)) { haslower = 1; break; }
if (!((sts = sys$parse(&dirfab))&1)) {
if (dirfab.fab$l_sts == RMS$_DIR) {
dirnam.nam$b_nop |= NAM$M_SYNCHK;
/* We've set up the string up through the filename. Add the
type and version, and we're done. */
strcat(retspec,".DIR;1");
+
+ /* $PARSE may have upcased filespec, so convert output to lower
+ * case if input contained any lowercase characters. */
+ if (haslower) __mystrtolower(retspec);
return retspec;
}
} /* end of do_fileify_dirspec() */
}
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) != '.') {
- 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;
else retpath[retlen-1] = '\0';
}
else { /* VMS-style directory spec */
- char esa[NAM$C_MAXRSS+1];
- unsigned long int sts, cmplen;
+ char esa[NAM$C_MAXRSS+1], *cp;
+ unsigned long int sts, cmplen, haslower;
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] == ']' ||
dirfab.fab$l_nam = &dirnam;
dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
dirnam.nam$l_esa = esa;
- if (!((sts = sys$parse(&dirfab))&1)) {
+
+ for (cp = dir; *cp; cp++)
+ if (islower(*cp)) { haslower = 1; break; }
+
+ if (!(sts = (sys$parse(&dirfab)&1))) {
if (dirfab.fab$l_sts == RMS$_DIR) {
dirnam.nam$b_nop |= NAM$M_SYNCHK;
sts = sys$parse(&dirfab) & 1;
else if (ts) New(7014,retpath,retlen,char);
else retpath = __pathify_retbuf;
strcpy(retpath,esa);
+ /* $PARSE may have upcased filespec, so convert output to lower
+ * case if input contained any lowercase characters. */
+ if (haslower) __mystrtolower(retpath);
}
return retpath;
strcpy(rslt,"./");
return rslt;
}
- else if (*cp2 == '-') {
- while (*cp2 == '-') {
- *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
- cp2++;
- }
- if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
- if (ts) Safefree(rslt); /* filespecs like */
- set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [--foo.bar] */
- return NULL;
- }
- cp2++;
- }
- else if ( *(cp2) != '.') { /* add the implied device into the Unix spec */
- *(cp1++) = '/';
+ else if ( *cp2 != '.' && *cp2 != '-') {
+ *(cp1++) = '/'; /* add the implied device into the Unix spec */
if (getcwd(tmp,sizeof tmp,1) == NULL) {
if (ts) Safefree(rslt);
return NULL;
cp1 = rslt + offset;
}
}
- else cp2++;
+ else if (*cp2 == '.') cp2++;
}
for (; cp2 <= dirend; cp2++) {
if (*cp2 == ':') {
}
if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
if (ts) Safefree(rslt); /* filespecs like */
- set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [--foo.bar] */
+ set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
return NULL;
}
- cp2++;
}
else *(cp1++) = *cp2;
}
int islnm, rooted;
STRLEN trnend;
+ while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
*cp1 = '\0';
islnm = my_trnlnm(rslt,trndev,0);
}
for (; cp2 < dirend; cp2++) {
if (*cp2 == '/') {
+ if (*(cp2-1) == '/') continue;
if (*(cp1-1) != '.') *(cp1++) = '.';
infront = 0;
}
else if (!infront && *cp2 == '.') {
- if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
- else if (*(cp2+1) == '\0') { cp2++; break; }
+ if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
+ else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
else if (*(cp1-2) == '[') *(cp1-1) = '-';
}
}
cp2 += 2;
- if (cp2 == dirend) {
- if (*(cp1-1) == '.') cp1--;
- break;
- }
+ if (cp2 == dirend) break;
}
else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
}
else {
if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
- if (*cp2 == '/') *(cp1++) = '.';
- else if (*cp2 == '.') *(cp1++) = '_';
+ if (*cp2 == '.') *(cp1++) = '_';
else *(cp1++) = *cp2;
infront = 1;
}
{
if (j+1 >= argc)
{
- fprintf(stderr,"No input file after < on command line");
+ PerlIO_printf(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");
+ PerlIO_printf(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");
+ PerlIO_printf(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");
+ PerlIO_printf(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");
+ PerlIO_printf(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");
+ PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
exit(LIB$_INVARGORD);
}
pipe_and_fork(cmargv);
/* Input from a pipe, reopen it in binary mode to disable */
/* carriage control processing. */
- fgetname(stdin, mbxname,1);
+ PerlIO_getname(stdin, mbxname);
mbxnam.dsc$a_pointer = mbxname;
mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
freopen(mbxname, "rb", stdin);
if (errno != 0)
{
- fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
+ PerlIO_printf(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);
+ PerlIO_printf(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);
+ PerlIO_printf(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);
+ PerlIO_printf(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");
+ PerlIO_printf(Perl_debug_log, "Arglist:\n");
for (j = 0; j < *ac; ++j)
- fprintf(stderr, "argv[%d] = '%s'\n", j, argv[j]);
+ PerlIO_printf(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;
for (c = string; *c; ++c)
if (isupper(*c))
*c = tolower(*c);
- if (isunix) trim_unixpath(item,string);
+ if (isunix) trim_unixpath(string,item);
add_item(head, tail, string, count);
++expcount;
}
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");
+ PerlIO_printf(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");
+ PerlIO_printf(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);
+ PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
+ PerlIO_printf(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);
+ PerlIO_printf(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);
+ PerlIO_printf(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);
+ PerlIO_printf(Perl_debug_log, "%s\n", command);
#endif
sprintf(pidstring, "%08X", pid);
- fprintf(stderr, "%s\n", pidstring);
+ PerlIO_printf(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);
* full path). Note that returned filespec is Unix-style, regardless
* of whether input filespec was VMS-style or Unix-style.
*
- * Returns !=0 on success, 0 on failure.
+ * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
+ * determine prefix (both may be in VMS or Unix syntax).
+ *
+ * Returns !=0 on success, with trimmed filespec replacing contents of
+ * fspec, and 0 on failure, with contents of fpsec unchanged.
*/
-/*{{{int trim_unixpath(char *template, char *fspec)*/
+/*{{{int trim_unixpath(char *fspec, char *wildspec)*/
int
-trim_unixpath(char *template, char *fspec)
+trim_unixpath(char *fspec, char *wildspec)
{
- char unixified[NAM$C_MAXRSS+1], *base, *cp1, *cp2;
- register int tmplen;
+ char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
+ *template, *base, *cp1, *cp2;
+ register int tmplen, reslen = 0;
+ if (!wildspec || !fspec) return 0;
+ if (strpbrk(wildspec,"]>:") != NULL) {
+ if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
+ else template = unixified;
+ }
+ else template = wildspec;
if (strpbrk(fspec,"]>:") != NULL) {
if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
else base = unixified;
+ /* reslen != 0 ==> we had to unixify resultant filespec, so we must
+ * check to see that final result fits into (isn't longer than) fspec */
+ reslen = strlen(fspec);
}
else base = fspec;
- for (cp2 = base; *cp2; cp2++) ; /* Find end of filespec */
+
+ /* No prefix or absolute path on wildcard, so nothing to remove */
+ if (!*template || *template == '/') {
+ if (base == fspec) return 1;
+ tmplen = strlen(unixified);
+ if (tmplen > reslen) return 0; /* not enough space */
+ /* Copy unixified resultant, including trailing NUL */
+ memmove(fspec,unixified,tmplen+1);
+ return 1;
+ }
/* Find prefix to template consisting of path elements without wildcards */
if ((cp1 = strpbrk(template,"*%?")) == NULL)
for (cp1 = template; *cp1; cp1++) ;
- else while (cp1 >= template && *cp1 != '/') cp1--;
- if (cp1 == template) return 1; /* Wildcard was up front - no prefix to clip */
- tmplen = cp1 - template;
-
- /* Try to find template prefix on filespec */
- if (!memcmp(base,template,tmplen)) return 1; /* Nothing before prefix - we're done */
- for (; cp2 - base > tmplen; base++) {
- if (*base != '/') continue;
- if (!memcmp(base + 1,template,tmplen)) break;
- }
- if (cp2 - base == tmplen) return 0; /* Not there - not good */
- base++; /* Move past leading '/' */
- /* Copy down remaining portion of filespec, including trailing NUL */
- memmove(fspec,base,cp2 - base + 1);
- return 1;
+ else while (cp1 > template && *cp1 != '/') cp1--;
+ for (cp2 = base; *cp2; cp2++) ; /* Find end of resultant filespec */
+
+ /* Wildcard was in first element, so we don't have a reliable string to
+ * match against. Guess where to trim resultant filespec by counting
+ * directory levels in the Unix template. (We could do this instead of
+ * string matching in all cases, since Unix doesn't have a ... wildcard
+ * that can expand into multiple levels of subdirectory, but we try for
+ * the string match so our caller can interpret foo/.../bar.* as
+ * [.foo...]bar.* if it wants, and only get burned if there was a
+ * wildcard in the first word (in which case, caveat caller). */
+ if (cp1 == template) {
+ int subdirs = 0;
+ for ( ; *cp1; cp1++) if (*cp1 == '/') subdirs++;
+ /* need to back one more '/' than in template, to pick up leading dirname */
+ subdirs++;
+ while (cp2 > base) {
+ if (*cp2 == '/') subdirs--;
+ if (!subdirs) break; /* quit without decrement when we hit last '/' */
+ cp2--;
+ }
+ /* ran out of directories on resultant; allow for already trimmed
+ * resultant, which hits start of string looking for leading '/' */
+ if (subdirs && (cp2 != base || subdirs != 1)) return 0;
+ /* Move past leading '/', if there is one */
+ base = cp2 + (*cp2 == '/' ? 1 : 0);
+ tmplen = strlen(base);
+ if (reslen && tmplen > reslen) return 0; /* not enough space */
+ memmove(fspec,base,tmplen+1); /* copy result to fspec, with trailing NUL */
+ return 1;
+ }
+ /* We have a prefix string of complete directory names, so we
+ * try to find it on the resultant filespec */
+ else {
+ tmplen = cp1 - template;
+ if (!memcmp(base,template,tmplen)) { /* Nothing before prefix; we're done */
+ if (reslen) { /* we converted to Unix syntax; copy result over */
+ tmplen = cp2 - base;
+ if (tmplen > reslen) return 0; /* not enough space */
+ memmove(fspec,base,tmplen+1); /* Copy trimmed spec + trailing NUL */
+ }
+ return 1;
+ }
+ for ( ; cp2 - base > tmplen; base++) {
+ if (*base != '/') continue;
+ if (!memcmp(base + 1,template,tmplen)) break;
+ }
+
+ if (cp2 - base == tmplen) return 0; /* Not there - not good */
+ base++; /* Move past leading '/' */
+ if (reslen && cp2 - base > reslen) return 0; /* not enough space */
+ /* Copy down remaining portion of filespec, including trailing NUL */
+ memmove(fspec,base,cp2 - base + 1);
+ return 1;
+ }
} /* end of trim_unixpath() */
/*}}}*/
}
}
- return SS$_NORMAL;
+ return (VMScmd.dsc$w_length > 255 ? CLI$_BUFOVF : SS$_NORMAL);
+
} /* end of setup_cmddsc() */
+
/* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
bool
vms_do_aexec(SV *really,SV **mark,SV **sp)
set_errno(EVMSERR);
set_vaxc_errno(substs);
if (dowarn)
- warn("Can't exec \"%s\": %s",
+ warn("Can't spawn \"%s\": %s",
hadcmd ? VMScmd.dsc$a_pointer : "", Strerror(errno));
}
vms_execfree();
static struct passwd __pwdcache;
static char __pw_namecache[UAI$S_IDENT+1];
-static char *_mystrtolower(char *str)
-{
- if (str) for (; *str; ++str) *str= tolower(*str);
- return str;
-}
-
/*
* This routine does most of the work extracting the user information.
*/
}
else
strcpy(pwd->pw_unixdir, pwd->pw_dir);
- _mystrtolower(pwd->pw_unixdir);
+ __mystrtolower(pwd->pw_unixdir);
return 1;
}
else { _ckvmssts(status); }
}
__pw_namecache[lname]= '\0';
- _mystrtolower(__pw_namecache);
+ __mystrtolower(__pw_namecache);
__pwdcache = __passwd_empty;
__pwdcache.pw_name = __pw_namecache;
my_gmtime(const time_t *time)
{
static int gmtime_emulation_type;
- static time_t utc_offset_secs;
+ static long int utc_offset_secs;
char *p;
time_t when;
if ((p = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL)
gmtime_emulation_type++;
else
- utc_offset_secs = (time_t) atol(p);
+ utc_offset_secs = atol(p);
}
}
{0,0,0,0}};
if (!fname || !*fname) return FALSE;
+ /* Make sure we expand logical names, since sys$check_access doesn't */
+ if (!strpbrk(fname,"/]>:")) {
+ strcpy(fileified,fname);
+ while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
+ fname = fileified;
+ }
if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
retlen = namdsc.dsc$w_length = strlen(vmsname);
namdsc.dsc$a_pointer = vmsname;
}
retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
- if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJ || retsts == RMS$_FNF ||
- retsts == RMS$_DIR || retsts == RMS$_DEV) return FALSE;
+ if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
+ retsts == SS$_INVFILFOROP || retsts == RMS$_FNF ||
+ retsts == RMS$_DIR || retsts == RMS$_DEV) {
+ set_vaxc_errno(retsts);
+ if (retsts == SS$_NOPRIV) set_errno(EACCES);
+ else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
+ else set_errno(ENOENT);
+ return FALSE;
+ }
if (retsts == SS$_NORMAL) {
if (!privused) return TRUE;
/* We can get access, but only by using privs. Do we have the
/*{{{ 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)
{
char fileified[NAM$C_MAXRSS+1];
- int retval,myretval;
- struct mystat tmpbuf;
+ int retval = -1;
-
if (statbufp == &statcache) do_tovmsspec(fspec,namecache,0);
if (is_null_device(fspec)) { /* Fake a stat() for the null device */
memset(statbufp,0,sizeof *statbufp);
return 0;
}
- if (do_fileify_dirspec(fspec,fileified,0) == NULL) myretval = -1;
- else {
- myretval = stat(fileified,(stat_t *) &tmpbuf);
- }
- retval = stat(fspec,(stat_t *) statbufp);
- if (!myretval) {
- if (retval == -1) {
- *statbufp = tmpbuf;
- retval = 0;
- }
- else if (!retval) { /* Dir with same name. Substitute it. */
- statbufp->st_mode &= ~S_IFDIR;
- statbufp->st_mode |= tmpbuf.st_mode & S_IFDIR;
- strcpy(namecache,fileified);
- }
+ /* Try for a directory name first. If fspec contains a filename without
+ * a type (e.g. sea:[dark.dark]water), and both sea:[wine.dark]water.dir
+ * and sea:[wine.dark]water. exist, we prefer the directory here.
+ * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
+ * not sea:[wine.dark]., if the latter exists. If the intended target is
+ * the file with null type, specify this by calling flex_stat() with
+ * a '.' at the end of fspec.
+ */
+ if (do_fileify_dirspec(fspec,fileified,0) != NULL) {
+ retval = stat(fileified,(stat_t *) statbufp);
+ 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);
return retval;
#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 *
*
* Copies contents and attributes of spec_in to spec_out, except owner
* and protection information. Name and type of spec_in are used as
- * defaults for spec_out. Returns 1 on success; returns 0 and sets
- * errno and vaxc$errno on failure.
+ * defaults for spec_out. The third parameter specifies whether rmscopy()
+ * should try to propagate timestamps from the input file to the output file.
+ * If it is less than 0, no timestamps are preserved. If it is 0, then
+ * rmscopy() will behave similarly to the DCL COPY command: timestamps are
+ * propagated to the output file at creation iff the output file specification
+ * did not contain an explicit name or type, and the revision date is always
+ * updated at the end of the copy operation. If it is greater than 0, then
+ * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
+ * other than the revision date should be propagated, and bit 1 indicates
+ * that the revision date should be propagated.
+ *
+ * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
*
* Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>.
* Incorporates, with permission, some code from EZCOPY by Tim Adye
- * <T.J.Adye@rl.ac.uk>. Permission is given to use and distribute this
- * code under the same terms as Perl itself. (See the GNU General Public
- * License or the Perl Artistic License supplied as part of the Perl
- * distribution.)
+ * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
+ * as part of the Perl standard distribution under the terms of the
+ * GNU General Public License or the Perl Artistic License. Copies
+ * of each may be found in the Perl standard distribution.
*/
-/*{{{int rmscopy(char *src, char *dst)*/
+/*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
int
-rmscopy(char *spec_in, char *spec_out)
+rmscopy(char *spec_in, char *spec_out, int preserve_dates)
{
char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
rsa[NAM$C_MAXRSS], ubf[32256];
fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
fab_in.fab$l_fop = FAB$M_SQO;
fab_in.fab$l_nam = &nam;
- fab_in.fab$l_xab = (void*) &xabdat;
+ fab_in.fab$l_xab = (void *) &xabdat;
nam = cc$rms_nam;
nam.nam$l_rsa = rsa;
nam.nam$b_esl = nam.nam$b_rsl = 0;
xabdat = cc$rms_xabdat; /* To get creation date */
- xabdat.xab$l_nxt = (void*) &xabfhc;
+ xabdat.xab$l_nxt = (void *) &xabfhc;
xabfhc = cc$rms_xabfhc; /* To get record length */
- xabfhc.xab$l_nxt = (void*) &xabsum;
+ xabfhc.xab$l_nxt = (void *) &xabsum;
xabsum = cc$rms_xabsum; /* To get key and area information */
fab_out.fab$b_fns = strlen(vmsout);
fab_out.fab$l_dna = nam.nam$l_name;
fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
+
+ if (preserve_dates == 0) { /* Act like DCL COPY */
+ nam.nam$b_nop = NAM$M_SYNCHK;
+ fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
+ if (!((sts = sys$parse(&fab_out)) & 1)) {
+ set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
+ set_vaxc_errno(sts);
+ return 0;
+ }
+ fab_out.fab$l_xab = (void *) &xabdat;
+ if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
+ }
+ fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
+ if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
+ preserve_dates =0; /* bitmask from this point forward */
+
+ if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
if (!((sts = sys$create(&fab_out)) & 1)) {
set_vaxc_errno(sts);
switch (sts) {
return 0;
}
fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
- /* sys$close() will process xabrdt, not xabdat */
- xabrdt = cc$rms_xabrdt;
- xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
- fab_out.fab$l_xab = &xabrdt;
+ 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;
+ }
rab_in = cc$rms_rab;
rab_in.rab$l_fab = &fab_in;
*/
void
+rmsexpand_fromperl(CV *cv)
+{
+ dXSARGS;
+ char *fspec, *defspec = NULL, *rslt;
+
+ if (!items || items > 2)
+ croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
+ fspec = SvPV(ST(0),na);
+ if (!fspec || !*fspec) XSRETURN_UNDEF;
+ if (items == 2) defspec = SvPV(ST(1),na);
+
+ rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
+ ST(0) = sv_newmortal();
+ if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
+ XSRETURN(1);
+}
+
+void
vmsify_fromperl(CV *cv)
{
dXSARGS;
{
dXSARGS;
char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
+ int date_flag;
struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
unsigned long int sts;
SV *mysv;
IO *io;
- if (items != 2) croak("Usage: File::Copy::rmscopy(from,to)");
+ if (items < 2 || items > 3)
+ croak("Usage: File::Copy::rmscopy(from,to[,date_flag])");
mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
if (SvTYPE(mysv) == SVt_PVGV) {
XSRETURN(1);
}
}
+ date_flag = (items == 3) ? SvIV(ST(2)) : 0;
- ST(0) = rmscopy(inp,outp) ? &sv_yes : &sv_no;
+ ST(0) = rmscopy(inp,outp,date_flag) ? &sv_yes : &sv_no;
XSRETURN(1);
}
{
char* file = __FILE__;
+ newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");