316 lines
6.3 KiB
C
316 lines
6.3 KiB
C
/* Define _XOPEN_SOURCE to get tempnam prototype with glibc et al --
|
|
more general than _INCLUDE_XOPEN_SOURCE used elsewhere `for HP-UX'. */
|
|
#define _XOPEN_SOURCE 1
|
|
#include "config.h"
|
|
#include "f2c.h"
|
|
#include "fio.h"
|
|
#include <string.h>
|
|
#ifndef NON_POSIX_STDIO
|
|
#ifdef MSDOS
|
|
#include "io.h"
|
|
#else
|
|
#include "unistd.h" /* for access */
|
|
#endif
|
|
#endif
|
|
|
|
#ifdef KR_headers
|
|
extern char *malloc();
|
|
#ifdef NON_ANSI_STDIO
|
|
extern char *mktemp();
|
|
#endif
|
|
extern integer f_clos();
|
|
#else
|
|
#undef abs
|
|
#undef min
|
|
#undef max
|
|
#include <stdlib.h>
|
|
extern int f__canseek(FILE*);
|
|
extern integer f_clos(cllist*);
|
|
#endif
|
|
|
|
#ifdef NON_ANSI_RW_MODES
|
|
char *f__r_mode[2] = {"r", "r"};
|
|
char *f__w_mode[4] = {"w", "w", "r+w", "r+w"};
|
|
#else
|
|
char *f__r_mode[2] = {"rb", "r"};
|
|
char *f__w_mode[4] = {"wb", "w", "r+b", "r+"};
|
|
#endif
|
|
|
|
static char f__buf0[400], *f__buf = f__buf0;
|
|
int f__buflen = (int)sizeof(f__buf0);
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
f__bufadj(n, c) int n, c;
|
|
#else
|
|
f__bufadj(int n, int c)
|
|
#endif
|
|
{
|
|
unsigned int len;
|
|
char *nbuf, *s, *t, *te;
|
|
|
|
if (f__buf == f__buf0)
|
|
f__buflen = 1024;
|
|
while(f__buflen <= n)
|
|
f__buflen <<= 1;
|
|
len = (unsigned int)f__buflen;
|
|
if (len != f__buflen || !(nbuf = (char*)malloc(len)))
|
|
f__fatal(113, "malloc failure");
|
|
s = nbuf;
|
|
t = f__buf;
|
|
te = t + c;
|
|
while(t < te)
|
|
*s++ = *t++;
|
|
if (f__buf != f__buf0)
|
|
free(f__buf);
|
|
f__buf = nbuf;
|
|
}
|
|
|
|
int
|
|
#ifdef KR_headers
|
|
f__putbuf(c) int c;
|
|
#else
|
|
f__putbuf(int c)
|
|
#endif
|
|
{
|
|
char *s, *se;
|
|
int n;
|
|
|
|
if (f__hiwater > f__recpos)
|
|
f__recpos = f__hiwater;
|
|
n = f__recpos + 1;
|
|
if (n >= f__buflen)
|
|
f__bufadj(n, f__recpos);
|
|
s = f__buf;
|
|
se = s + f__recpos;
|
|
if (c)
|
|
*se++ = c;
|
|
*se = 0;
|
|
for(;;) {
|
|
fputs(s, f__cf);
|
|
s += strlen(s);
|
|
if (s >= se)
|
|
break; /* normally happens the first time */
|
|
putc(*s++, f__cf);
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
void
|
|
#ifdef KR_headers
|
|
x_putc(c)
|
|
#else
|
|
x_putc(int c)
|
|
#endif
|
|
{
|
|
if (f__recpos >= f__buflen)
|
|
f__bufadj(f__recpos, f__buflen);
|
|
f__buf[f__recpos++] = c;
|
|
}
|
|
|
|
#define opnerr(f,m,s) \
|
|
do {if(f) {f__init &= ~2; errno= m;} else opn_err(m,s,a); return(m);} while(0)
|
|
|
|
static void
|
|
#ifdef KR_headers
|
|
opn_err(m, s, a) int m; char *s; olist *a;
|
|
#else
|
|
opn_err(int m, char *s, olist *a)
|
|
#endif
|
|
{
|
|
if (a->ofnm) {
|
|
/* supply file name to error message */
|
|
if (a->ofnmlen >= f__buflen)
|
|
f__bufadj((int)a->ofnmlen, 0);
|
|
g_char(a->ofnm, a->ofnmlen, f__curunit->ufnm = f__buf);
|
|
}
|
|
f__fatal(m, s);
|
|
}
|
|
|
|
#ifdef KR_headers
|
|
integer f_open(a) olist *a;
|
|
#else
|
|
integer f_open(olist *a)
|
|
#endif
|
|
{ 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(b->url>0) 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 - 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);
|
|
}
|
|
#ifdef KR_headers
|
|
fk_open(seq,fmt,n) ftnint n;
|
|
#else
|
|
fk_open(int seq, int fmt, ftnint n)
|
|
#endif
|
|
{ char nbuf[10];
|
|
olist a;
|
|
int rtn;
|
|
int save_init;
|
|
|
|
(void) sprintf(nbuf,"fort.%ld",(long)n);
|
|
a.oerr=1;
|
|
a.ounit=n;
|
|
a.ofnm=nbuf;
|
|
a.ofnmlen=strlen(nbuf);
|
|
a.osta=NULL;
|
|
a.oacc= seq==SEQ?"s":"d";
|
|
a.ofm = fmt==FMT?"f":"u";
|
|
a.orl = seq==DIR?1:0;
|
|
a.oblnk=NULL;
|
|
save_init = f__init;
|
|
f__init &= ~2;
|
|
rtn = f_open(&a);
|
|
f__init = save_init | 1;
|
|
return rtn;
|
|
}
|