*
* VMS-specific routines for perl5
*
- * Last revised: 20-Mar-1996 by Charles Bailey bailey@genetics.upenn.edu
- * Version: 5.2.1
+ * Last revised: 24-Jun-1996 by Charles Bailey bailey@genetics.upenn.edu
+ * Version: 5.3.0
*/
#include <acedef.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)
{
** tovmsspec() - convert any file spec into a VMS-style spec.
**
** Copyright 1996 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.
+** 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);
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.]
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;
}
dirlen = cp2 - dir;
}
- else { /* There's a type, and it's not .dir. Bzzt. */
- set_errno(ENOTDIR);
+ else { /* There's a type, and it's not .dir. Bzzt. */
+ set_errno(ENOTDIR);
set_vaxc_errno(RMS$_DIR);
return NULL;
}
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() */
retlen = 2 + (*(dir+1) != '\0');
else {
if (!(cp1 = strrchr(dir,'/'))) cp1 = dir;
- if ((cp2 = strchr(cp1,'.')) && *(cp2+1) != '.') {
+ 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') {
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;
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) == '/') ; /* 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;
}
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;
{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;
*
* 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 preserve_dates)*/
int
*/
void
+rmsexpand_fromperl(CV *cv)
+{
+ dXSARGS;
+ char esa[NAM$C_MAXRSS], rsa[NAM$C_MAXRSS], *cp, *out;
+ struct FAB myfab = cc$rms_fab;
+ struct NAM mynam = cc$rms_nam;
+ STRLEN speclen;
+ unsigned long int retsts, haslower = 0;
+
+ myfab.fab$l_fna = SvPV(ST(0),speclen);
+ myfab.fab$b_fns = speclen;
+ myfab.fab$l_nam = &mynam;
+
+ mynam.nam$l_esa = esa;
+ mynam.nam$b_ess = sizeof esa;
+ mynam.nam$l_rsa = rsa;
+ mynam.nam$b_rss = sizeof rsa;
+
+ retsts = sys$parse(&myfab,0,0);
+ if (!(retsts & 1)) {
+ 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);
+ XSRETURN_UNDEF;
+ }
+ retsts = sys$search(&myfab,0,0);
+ if (!(retsts & 1) && retsts != RMS$_FNF) {
+ set_vaxc_errno(retsts);
+ if (retsts == RMS$_PRV) set_errno(EACCES);
+ else set_errno(EVMSERR);
+ XSRETURN_UNDEF;
+ }
+ /* If the input filespec contained any lowercase characters,
+ * downcase the result for compatibility with Unix-minded code. */
+ 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; }
+ else { out = esa; speclen = mynam.nam$b_esl; }
+ if (!(mynam.nam$l_fnb & NAM$M_EXP_VER))
+ speclen = mynam.nam$l_type - out;
+ out[speclen] = '\0';
+ if (haslower) __mystrtolower(out);
+
+ ST(0) = sv_2mortal(newSVpv(out, speclen));
+}
+
+void
vmsify_fromperl(CV *cv)
{
dXSARGS;
{
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,"$");
projects / p5sagit/p5-mst-13.2.git / commitdiff