integer f_inqu(inlist *a) #endif { flag byfile; int i, n; unit *p; char buf[256]; long x; if(a->infile!=NULL) { byfile=1; g_char(a->infile,a->infilen,buf); #ifdef NON_UNIX_STDIO x = access(buf,0) ? -1 : 0; for(i=0,p=NULL;i<MXUNIT;i++) if(f__units[i].ufd != NULL && f__units[i].ufnm != NULL && !strcmp(f__units[i].ufnm,buf)) { p = &f__units[i]; break; } #else x=f__inode(buf, &n); for(i=0,p=NULL;i<MXUNIT;i++) if(f__units[i].uinode==x && f__units[i].ufd!=NULL && f__units[i].udev == n) { p = &f__units[i]; break; } #endif } else { byfile=0; if(a->inunit<MXUNIT && a->inunit>=0) { p= &f__units[a->inunit]; } else { p=NULL; } } if(a->inex!=NULL) if(byfile && x != -1 || !byfile && p!=NULL) *a->inex=1; else *a->inex=0; if(a->inopen!=NULL) if(byfile) *a->inopen=(p!=NULL); else *a->inopen=(p!=NULL && p->ufd!=NULL); if(a->innum!=NULL) *a->innum= p-f__units; if(a->innamed!=NULL) if(byfile || p!=NULL && p->ufnm!=NULL) *a->innamed=1; else *a->innamed=0; if(a->inname!=NULL) if(byfile) b_char(buf,a->inname,a->innamlen); else if(p!=NULL && p->ufnm!=NULL) b_char(p->ufnm,a->inname,a->innamlen); if(a->inacc!=NULL && p!=NULL && p->ufd!=NULL) if(p->url) b_char("DIRECT",a->inacc,a->inacclen); else b_char("SEQUENTIAL",a->inacc,a->inacclen); if(a->inseq!=NULL) if(p!=NULL && p->url) b_char("NO",a->inseq,a->inseqlen); else b_char("YES",a->inseq,a->inseqlen); if(a->indir!=NULL) if(p==NULL || p->url) b_char("YES",a->indir,a->indirlen); else b_char("NO",a->indir,a->indirlen); if(a->infmt!=NULL) if(p!=NULL && p->ufmt==0) b_char("UNFORMATTED",a->infmt,a->infmtlen); else b_char("FORMATTED",a->infmt,a->infmtlen); if(a->inform!=NULL) if(p!=NULL && p->ufmt==0) b_char("NO",a->inform,a->informlen); else b_char("YES",a->inform,a->informlen); if(a->inunf) if(p!=NULL && p->ufmt==0) b_char("YES",a->inunf,a->inunflen); else if (p!=NULL) b_char("NO",a->inunf,a->inunflen); else b_char("UNKNOWN",a->inunf,a->inunflen); if(a->inrecl!=NULL && p!=NULL) *a->inrecl=p->url; if(a->innrec!=NULL && p!=NULL && p->url>0) *a->innrec=ftell(p->ufd)/p->url+1; if(a->inblank && p!=NULL && p->ufmt) if(p->ublnk) b_char("ZERO",a->inblank,a->inblanklen); else b_char("NULL",a->inblank,a->inblanklen); return(0); }
integer f_open (olist * a) { unit *b; integer rv; char buf[256], *s, *env; cllist x; int ufmt; FILE *tf; int fd, len; #ifndef NON_UNIX_STDIO int n; #endif if (f__init != 1) f_init (); f__external = 1; if (a->ounit >= MXUNIT || a->ounit < 0) err (a->oerr, 101, "open"); f__curunit = b = &f__units[a->ounit]; if (b->ufd) { if (a->ofnm == 0) { same:if (a->oblnk) b->ublnk = *a->oblnk == 'z' || *a->oblnk == 'Z'; return (0); } #ifdef NON_UNIX_STDIO if (b->ufnm && strlen (b->ufnm) == a->ofnmlen && !strncmp (b->ufnm, a->ofnm, (unsigned) a->ofnmlen)) goto same; #else g_char (a->ofnm, a->ofnmlen, buf); if (f__inode (buf, &n) == b->uinode && n == b->udev) goto same; #endif x.cunit = a->ounit; x.csta = 0; x.cerr = a->oerr; if ((rv = f_clos (&x)) != 0) return rv; } b->url = (int) a->orl; b->ublnk = a->oblnk && (*a->oblnk == 'z' || *a->oblnk == 'Z'); if (a->ofm == 0) if ((a->oacc) && (*a->oacc == 'D' || *a->oacc == 'd')) b->ufmt = 0; else b->ufmt = 1; else if (*a->ofm == 'f' || *a->ofm == 'F') b->ufmt = 1; else b->ufmt = 0; ufmt = b->ufmt; #ifdef url_Adjust if (b->url && !ufmt) url_Adjust (b->url); #endif if (a->ofnm) { g_char (a->ofnm, a->ofnmlen, buf); if (!buf[0]) opnerr (a->oerr, 107, "open"); } else sprintf (buf, "fort.%ld", (long) a->ounit); b->uscrtch = 0; b->uend = 0; b->uwrt = 0; b->ufd = 0; b->urw = 3; switch (a->osta ? *a->osta : 'u') { case 'o': case 'O': #ifdef NON_POSIX_STDIO if (!(tf = fopen (buf, "r"))) opnerr (a->oerr, errno, "open"); fclose (tf); #else if (access (buf, 0)) opnerr (a->oerr, errno, "open"); #endif break; case 's': case 'S': b->uscrtch = 1; #ifdef HAVE_MKSTEMP /* Allow use of TMPDIR preferentially. */ env = getenv ("TMPDIR"); if (!env) env = getenv ("TEMP"); if (!env) env = "/tmp"; len = strlen (env); if (len > 256 - (int) sizeof ("/tmp.FXXXXXX")) err (a->oerr, 132, "open"); strcpy (buf, env); strcat (buf, "/tmp.FXXXXXX"); fd = mkstemp (buf); if (fd == -1 || close (fd)) err (a->oerr, 132, "open"); #else /* ! defined (HAVE_MKSTEMP) */ #ifdef HAVE_TEMPNAM /* Allow use of TMPDIR preferentially. */ s = tempnam (0, buf); if (strlen (s) >= sizeof (buf)) err (a->oerr, 132, "open"); (void) strcpy (buf, s); free (s); #else /* ! defined (HAVE_TEMPNAM) */ #ifdef HAVE_TMPNAM tmpnam (buf); #else (void) strcpy (buf, "tmp.FXXXXXX"); (void) mktemp (buf); #endif #endif /* ! defined (HAVE_TEMPNAM) */ #endif /* ! defined (HAVE_MKSTEMP) */ goto replace; case 'n': case 'N': #ifdef NON_POSIX_STDIO if ((tf = fopen (buf, "r")) || (tf = fopen (buf, "a"))) { fclose (tf); opnerr (a->oerr, 128, "open"); } #else if (!access (buf, 0)) opnerr (a->oerr, 128, "open"); #endif /* no break */ case 'r': /* Fortran 90 replace option */ case 'R': replace: if ((tf = fopen (buf, f__w_mode[0]))) fclose (tf); } b->ufnm = (char *) malloc ((unsigned int) (strlen (buf) + 1)); if (b->ufnm == NULL) opnerr (a->oerr, 113, "no space"); (void) strcpy (b->ufnm, buf); if ((s = a->oacc) && b->url) ufmt = 0; if (!(tf = fopen (buf, f__w_mode[ufmt | 2]))) { if ((tf = fopen (buf, f__r_mode[ufmt]))) b->urw = 1; else if ((tf = fopen (buf, f__w_mode[ufmt]))) { b->uwrt = 1; b->urw = 2; } else err (a->oerr, errno, "open"); } b->useek = f__canseek (b->ufd = tf); #ifndef NON_UNIX_STDIO if ((b->uinode = f__inode (buf, &b->udev)) == -1) opnerr (a->oerr, 108, "open"); #endif if (b->useek) { if (a->orl) FSEEK (b->ufd, 0, SEEK_SET); else if ((s = a->oacc) && (*s == 'a' || *s == 'A') && FSEEK (b->ufd, 0, SEEK_END)) opnerr (a->oerr, 129, "open"); } return (0); }