toolchain/gcc/libf2c/libI77/open.c

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