contrib/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;
 137         cllist x;
 138         int ufmt;
 139         FILE *tf;
 140 #ifndef NON_UNIX_STDIO
 141         int n;
 142 #endif
 143         if(f__init != 1) f_init();
 144         f__external = 1;
 145         if(a->ounit>=MXUNIT || a->ounit<0)
 146                 err(a->oerr,101,"open");
 147         f__curunit = b = &f__units[a->ounit];
 148         if(b->ufd) {
 149                 if(a->ofnm==0)
 150                 {
 151                 same:   if (a->oblnk)
 152                                 b->ublnk = *a->oblnk == 'z' || *a->oblnk == 'Z';
 153                         return(0);
 154                 }
 155 #ifdef NON_UNIX_STDIO
 156                 if (b->ufnm
 157                  && strlen(b->ufnm) == a->ofnmlen
 158                  && !strncmp(b->ufnm, a->ofnm, (unsigned)a->ofnmlen))
 159                         goto same;
 160 #else
 161                 g_char(a->ofnm,a->ofnmlen,buf);
 162                 if (f__inode(buf,&n) == b->uinode && n == b->udev)
 163                         goto same;
 164 #endif
 165                 x.cunit=a->ounit;
 166                 x.csta=0;
 167                 x.cerr=a->oerr;
 168                 if ((rv = f_clos(&x)) != 0)
 169                         return rv;
 170                 }
 171         b->url = (int)a->orl;
 172         b->ublnk = a->oblnk && (*a->oblnk == 'z' || *a->oblnk == 'Z');
 173         if(a->ofm==0)
 174         {       if(b->url>0) b->ufmt=0;
 175                 else b->ufmt=1;
 176         }
 177         else if(*a->ofm=='f' || *a->ofm == 'F') b->ufmt=1;
 178         else b->ufmt=0;
 179         ufmt = b->ufmt;
 180 #ifdef url_Adjust
 181         if (b->url && !ufmt)
 182                 url_Adjust(b->url);
 183 #endif
 184         if (a->ofnm) {
 185                 g_char(a->ofnm,a->ofnmlen,buf);
 186                 if (!buf[0])
 187                         opnerr(a->oerr,107,"open");
 188                 }
 189         else
 190                 sprintf(buf, "fort.%ld", (long)a->ounit);
 191         b->uscrtch = 0;
 192         b->uend=0;
 193         b->uwrt = 0;
 194         b->ufd = 0;
 195         b->urw = 3;
 196         switch(a->osta ? *a->osta : 'u')
 197         {
 198         case 'o':
 199         case 'O':
 200 #ifdef NON_POSIX_STDIO
 201                 if (!(tf = fopen(buf,"r")))
 202                         opnerr(a->oerr,errno,"open");
 203                 fclose(tf);
 204 #else
 205                 if (access(buf,0))
 206                         opnerr(a->oerr,errno,"open");
 207 #endif
 208                 break;
 209          case 's':
 210          case 'S':
 211                 b->uscrtch=1;
 212 #ifdef HAVE_TEMPNAM             /* Allow use of TMPDIR preferentially. */
 213                 s = tempnam (0, buf);
 214                 if (strlen (s) >= sizeof (buf))
 215                   err (a->oerr, 132, "open");
 216                 (void) strcpy (buf, s);
 217                 free (s);
 218 #else /* ! defined (HAVE_TEMPNAM) */
 219 #ifdef _POSIX_SOURCE
 220                 tmpnam(buf);
 221 #else
 222                 (void) strcpy(buf,"tmp.FXXXXXX");
 223                 (void) mktemp(buf);
 224 #endif
 225 #endif /* ! defined (HAVE_TEMPNAM) */
 226                 goto replace;
 227         case 'n':
 228         case 'N':
 229 #ifdef NON_POSIX_STDIO
 230                 if ((tf = fopen(buf,"r")) || (tf = fopen(buf,"a"))) {
 231                         fclose(tf);
 232                         opnerr(a->oerr,128,"open");
 233                         }
 234 #else
 235                 if (!access(buf,0))
 236                         opnerr(a->oerr,128,"open");
 237 #endif
 238                 /* no break */
 239         case 'r':       /* Fortran 90 replace option */
 240         case 'R':
 241  replace:
 242                 if (tf = fopen(buf,f__w_mode[0]))
 243                         fclose(tf);
 244         }
 245
 246         b->ufnm=(char *) malloc((unsigned int)(strlen(buf)+1));
 247         if(b->ufnm==NULL) opnerr(a->oerr,113,"no space");
 248         (void) strcpy(b->ufnm,buf);
 249         if ((s = a->oacc) && b->url)
 250                 ufmt = 0;
 251         if(!(tf = fopen(buf, f__w_mode[ufmt|2]))) {
 252                 if (tf = fopen(buf, f__r_mode[ufmt]))
 253                         b->urw = 1;
 254                 else if (tf = fopen(buf, f__w_mode[ufmt])) {
 255                         b->uwrt = 1;
 256                         b->urw = 2;
 257                         }
 258                 else
 259                         err(a->oerr, errno, "open");
 260                 }
 261         b->useek = f__canseek(b->ufd = tf);
 262 #ifndef NON_UNIX_STDIO
 263         if((b->uinode = f__inode(buf,&b->udev)) == -1)
 264                 opnerr(a->oerr,108,"open");
 265 #endif
 266         if(b->useek)
 267                 if (a->orl)
 268                         rewind(b->ufd);
 269                 else if ((s = a->oacc) && (*s == 'a' || *s == 'A')
 270                         && fseek(b->ufd, 0L, SEEK_END))
 271                                 opnerr(a->oerr,129,"open");
 272         return(0);
 273 }
 274 #ifdef KR_headers
 275 fk_open(seq,fmt,n) ftnint n;
 276 #else
 277 fk_open(int seq, int fmt, ftnint n)
 278 #endif
 279 {       char nbuf[10];
 280         olist a;
 281         int rtn;
 282         int save_init;
 283
 284         (void) sprintf(nbuf,"fort.%ld",(long)n);
 285         a.oerr=1;
 286         a.ounit=n;
 287         a.ofnm=nbuf;
 288         a.ofnmlen=strlen(nbuf);
 289         a.osta=NULL;
 290         a.oacc= seq==SEQ?"s":"d";
 291         a.ofm = fmt==FMT?"f":"u";
 292         a.orl = seq==DIR?1:0;
 293         a.oblnk=NULL;
 294         save_init = f__init;
 295         f__init &= ~2;
 296         rtn = f_open(&a);
 297         f__init = save_init | 1;
 298         return rtn;
 299 }