libf2c/libI77/open.c

   1 /* Define _XOPEN_SOURCE to get tempnam prototype with glibc et al --
   2    more general than _INCLUDE_XOPEN_SOURCE used elsewhere `for HP-UX'.  */
   3 #define _XOPEN_SOURCE 1
   4 #include "f2c.h"
   5 #include "fio.h"
   6 #include <string.h>
   7 #ifndef NON_POSIX_STDIO
   8 #ifdef MSDOS
   9 #include "io.h"
  10 #else
  11 #include "unistd.h"     /* for access */
  12 #endif
  13 #endif
  14
  15 #ifdef KR_headers
  16 extern char *malloc();
  17 #ifdef NON_ANSI_STDIO
  18 extern char *mktemp();
  19 #endif
  20 extern integer f_clos();
  21 #else
  22 #undef abs
  23 #undef min
  24 #undef max
  25 #include <stdlib.h>
  26 extern int f__canseek(FILE*);
  27 extern integer f_clos(cllist*);
  28 #endif
  29
  30 #ifdef NON_ANSI_RW_MODES
  31 char *f__r_mode[2] = {"r", "r"};
  32 char *f__w_mode[4] = {"w", "w", "r+w", "r+w"};
  33 #else
  34 char *f__r_mode[2] = {"rb", "r"};
  35 char *f__w_mode[4] = {"wb", "w", "r+b", "r+"};
  36 #endif
  37
  38  static char f__buf0[400], *f__buf = f__buf0;
  39  int f__buflen = (int)sizeof(f__buf0);
  40
  41  static void
  42 #ifdef KR_headers
  43 f__bufadj(n, c) int n, c;
  44 #else
  45 f__bufadj(int n, int c)
  46 #endif
  47 {
  48         unsigned int len;
  49         char *nbuf, *s, *t, *te;
  50
  51         if (f__buf == f__buf0)
  52                 f__buflen = 1024;
  53         while(f__buflen <= n)
  54                 f__buflen <<= 1;
  55         len = (unsigned int)f__buflen;
  56         if (len != f__buflen || !(nbuf = (char*)malloc(len)))
  57                 f__fatal(113, "malloc failure");
  58         s = nbuf;
  59         t = f__buf;
  60         te = t + c;
  61         while(t < te)
  62                 *s++ = *t++;
  63         if (f__buf != f__buf0)
  64                 free(f__buf);
  65         f__buf = nbuf;
  66         }
  67
  68  int
  69 #ifdef KR_headers
  70 f__putbuf(c) int c;
  71 #else
  72 f__putbuf(int c)
  73 #endif
  74 {
  75         char *s, *se;
  76         int n;
  77
  78         if (f__hiwater > f__recpos)
  79                 f__recpos = f__hiwater;
  80         n = f__recpos + 1;
  81         if (n >= f__buflen)
  82                 f__bufadj(n, f__recpos);
  83         s = f__buf;
  84         se = s + f__recpos;
  85         if (c)
  86                 *se++ = c;
  87         *se = 0;
  88         for(;;) {
  89                 fputs(s, f__cf);
  90                 s += strlen(s);
  91                 if (s >= se)
  92                         break;  /* normally happens the first time */
  93                 putc(*s++, f__cf);
  94                 }
  95         return 0;
  96         }
  97
  98  void
  99 #ifdef KR_headers
 100 x_putc(c)
 101 #else
 102 x_putc(int c)
 103 #endif
 104 {
 105         if (f__recpos >= f__buflen)
 106                 f__bufadj(f__recpos, f__buflen);
 107         f__buf[f__recpos++] = c;
 108         }
 109
 110 #define opnerr(f,m,s) \
 111   do {if(f) {f__init &= ~2; errno= m;} else opn_err(m,s,a); return(m);} while(0)
 112
 113  static void
 114 #ifdef KR_headers
 115 opn_err(m, s, a) int m; char *s; olist *a;
 116 #else
 117 opn_err(int m, char *s, olist *a)
 118 #endif
 119 {
 120         if (a->ofnm) {
 121                 /* supply file name to error message */
 122                 if (a->ofnmlen >= f__buflen)
 123                         f__bufadj((int)a->ofnmlen, 0);
 124                 g_char(a->ofnm, a->ofnmlen, f__curunit->ufnm = f__buf);
 125                 }
 126         f__fatal(m, s);
 127         }
 128
 129 #ifdef KR_headers
 130 integer f_open(a) olist *a;
 131 #else
 132 integer f_open(olist *a)
 133 #endif
 134 {       unit *b;
 135         integer rv;
 136         char buf[256], *s, *env;
 137         cllist x;
 138         int ufmt;
 139         FILE *tf;
 140         int fd, len;
 141 #ifndef NON_UNIX_STDIO
 142         int n;
 143 #endif
 144         if(f__init != 1) f_init();
 145         f__external = 1;
 146         if(a->ounit>=MXUNIT || a->ounit<0)
 147                 err(a->oerr,101,"open");
 148         f__curunit = b = &f__units[a->ounit];
 149         if(b->ufd) {
 150                 if(a->ofnm==0)
 151                 {
 152                 same:   if (a->oblnk)
 153                                 b->ublnk = *a->oblnk == 'z' || *a->oblnk == 'Z';
 154                         return(0);
 155                 }
 156 #ifdef NON_UNIX_STDIO
 157                 if (b->ufnm
 158                  && strlen(b->ufnm) == a->ofnmlen
 159                  && !strncmp(b->ufnm, a->ofnm, (unsigned)a->ofnmlen))
 160                         goto same;
 161 #else
 162                 g_char(a->ofnm,a->ofnmlen,buf);
 163                 if (f__inode(buf,&n) == b->uinode && n == b->udev)
 164                         goto same;
 165 #endif
 166                 x.cunit=a->ounit;
 167                 x.csta=0;
 168                 x.cerr=a->oerr;
 169                 if ((rv = f_clos(&x)) != 0)
 170                         return rv;
 171                 }
 172         b->url = (int)a->orl;
 173         b->ublnk = a->oblnk && (*a->oblnk == 'z' || *a->oblnk == 'Z');
 174         if(a->ofm==0)
 175         {       if(b->url>0) b->ufmt=0;
 176                 else b->ufmt=1;
 177         }
 178         else if(*a->ofm=='f' || *a->ofm == 'F') b->ufmt=1;
 179         else b->ufmt=0;
 180         ufmt = b->ufmt;
 181 #ifdef url_Adjust
 182         if (b->url && !ufmt)
 183                 url_Adjust(b->url);
 184 #endif
 185         if (a->ofnm) {
 186                 g_char(a->ofnm,a->ofnmlen,buf);
 187                 if (!buf[0])
 188                         opnerr(a->oerr,107,"open");
 189                 }
 190         else
 191                 sprintf(buf, "fort.%ld", (long)a->ounit);
 192         b->uscrtch = 0;
 193         b->uend=0;
 194         b->uwrt = 0;
 195         b->ufd = 0;
 196         b->urw = 3;
 197         switch(a->osta ? *a->osta : 'u')
 198         {
 199         case 'o':
 200         case 'O':
 201 #ifdef NON_POSIX_STDIO
 202                 if (!(tf = fopen(buf,"r")))
 203                         opnerr(a->oerr,errno,"open");
 204                 fclose(tf);
 205 #else
 206                 if (access(buf,0))
 207                         opnerr(a->oerr,errno,"open");
 208 #endif
 209                 break;
 210          case 's':
 211          case 'S':
 212                 b->uscrtch=1;
 213 #ifdef HAVE_MKSTEMP             /* Allow use of TMPDIR preferentially. */
 214                 env = getenv("TMPDIR");
 215                 if (!env) env = getenv("TEMP");
 216                 if (!env) env = "/tmp";
 217                 len = strlen(env);
 218                 if (len > 256 - sizeof "/tmp.FXXXXXX")
 219                   err (a->oerr, 132, "open");
 220                 strcpy(buf, env);
 221                 strcat(buf, "/tmp.FXXXXXX");
 222                 fd = mkstemp(buf);
 223                 if (fd == -1 || close(fd))
 224                   err (a->oerr, 132, "open");
 225 #else /* ! defined (HAVE_MKSTEMP) */
 226 #ifdef HAVE_TEMPNAM             /* Allow use of TMPDIR preferentially. */
 227                 s = tempnam (0, buf);
 228                 if (strlen (s) >= sizeof (buf))
 229                   err (a->oerr, 132, "open");
 230                 (void) strcpy (buf, s);
 231                 free (s);
 232 #else /* ! defined (HAVE_TEMPNAM) */
 233 #ifdef _POSIX_SOURCE
 234                 tmpnam(buf);
 235 #else
 236                 (void) strcpy(buf,"tmp.FXXXXXX");
 237                 (void) mktemp(buf);
 238 #endif
 239 #endif /* ! defined (HAVE_TEMPNAM) */
 240 #endif /* ! defined (HAVE_MKSTEMP) */
 241                 goto replace;
 242         case 'n':
 243         case 'N':
 244 #ifdef NON_POSIX_STDIO
 245                 if ((tf = fopen(buf,"r")) || (tf = fopen(buf,"a"))) {
 246                         fclose(tf);
 247                         opnerr(a->oerr,128,"open");
 248                         }
 249 #else
 250                 if (!access(buf,0))
 251                         opnerr(a->oerr,128,"open");
 252 #endif
 253                 /* no break */
 254         case 'r':       /* Fortran 90 replace option */
 255         case 'R':
 256  replace:
 257                 if (tf = fopen(buf,f__w_mode[0]))
 258                         fclose(tf);
 259         }
 260
 261         b->ufnm=(char *) malloc((unsigned int)(strlen(buf)+1));
 262         if(b->ufnm==NULL) opnerr(a->oerr,113,"no space");
 263         (void) strcpy(b->ufnm,buf);
 264         if ((s = a->oacc) && b->url)
 265                 ufmt = 0;
 266         if(!(tf = fopen(buf, f__w_mode[ufmt|2]))) {
 267                 if (tf = fopen(buf, f__r_mode[ufmt]))
 268                         b->urw = 1;
 269                 else if (tf = fopen(buf, f__w_mode[ufmt])) {
 270                         b->uwrt = 1;
 271                         b->urw = 2;
 272                         }
 273                 else
 274                         err(a->oerr, errno, "open");
 275                 }
 276         b->useek = f__canseek(b->ufd = tf);
 277 #ifndef NON_UNIX_STDIO
 278         if((b->uinode = f__inode(buf,&b->udev)) == -1)
 279                 opnerr(a->oerr,108,"open");
 280 #endif
 281         if(b->useek)
 282                 if (a->orl)
 283                         rewind(b->ufd);
 284                 else if ((s = a->oacc) && (*s == 'a' || *s == 'A')
 285                         && fseek(b->ufd, 0L, SEEK_END))
 286                                 opnerr(a->oerr,129,"open");
 287         return(0);
 288 }
 289 #ifdef KR_headers
 290 fk_open(seq,fmt,n) ftnint n;
 291 #else
 292 fk_open(int seq, int fmt, ftnint n)
 293 #endif
 294 {       char nbuf[10];
 295         olist a;
 296         int rtn;
 297         int save_init;
 298
 299         (void) sprintf(nbuf,"fort.%ld",(long)n);
 300         a.oerr=1;
 301         a.ounit=n;
 302         a.ofnm=nbuf;
 303         a.ofnmlen=strlen(nbuf);
 304         a.osta=NULL;
 305         a.oacc= seq==SEQ?"s":"d";
 306         a.ofm = fmt==FMT?"f":"u";
 307         a.orl = seq==DIR?1:0;
 308         a.oblnk=NULL;
 309         save_init = f__init;
 310         f__init &= ~2;
 311         rtn = f_open(&a);
 312         f__init = save_init | 1;
 313         return rtn;
 314 }