libf2c/libI77/endfile.c

   1 #include "config.h"
   2 #include "f2c.h"
   3 #include "fio.h"
   4
   5 #include <sys/types.h>
   6 #include <unistd.h>
   7
   8 #ifdef KR_headers
   9 extern char *strcpy();
  10 extern FILE *tmpfile();
  11 #else
  12 #undef abs
  13 #undef min
  14 #undef max
  15 #include <stdlib.h>
  16 #include <string.h>
  17 #endif
  18
  19 extern char *f__r_mode[], *f__w_mode[];
  20
  21 #ifdef KR_headers
  22 integer f_end(a) alist *a;
  23 #else
  24 integer f_end(alist *a)
  25 #endif
  26 {
  27         unit *b;
  28         FILE *tf;
  29
  30         if (f__init & 2)
  31                 f__fatal (131, "I/O recursion");
  32         if(a->aunit>=MXUNIT || a->aunit<0) err(a->aerr,101,"endfile");
  33         b = &f__units[a->aunit];
  34         if(b->ufd==NULL) {
  35                 char nbuf[10];
  36                 sprintf(nbuf,"fort.%ld",(long)a->aunit);
  37                 if (tf = fopen(nbuf, f__w_mode[0]))
  38                         fclose(tf);
  39                 return(0);
  40                 }
  41         b->uend=1;
  42         return(b->useek ? t_runc(a) : 0);
  43 }
  44
  45 #ifndef HAVE_FTRUNCATE
  46  static int
  47 #ifdef KR_headers
  48 copy(from, len, to) FILE *from, *to; register long len;
  49 #else
  50 copy(FILE *from, register long len, FILE *to)
  51 #endif
  52 {
  53         int len1;
  54         char buf[BUFSIZ];
  55
  56         while(fread(buf, len1 = len > BUFSIZ ? BUFSIZ : (int)len, 1, from)) {
  57                 if (!fwrite(buf, len1, 1, to))
  58                         return 1;
  59                 if ((len -= len1) <= 0)
  60                         break;
  61                 }
  62         return 0;
  63         }
  64 #endif /* !defined(HAVE_FTRUNCATE) */
  65
  66  int
  67 #ifdef KR_headers
  68 t_runc(a) alist *a;
  69 #else
  70 t_runc(alist *a)
  71 #endif
  72 {
  73         long loc, len;
  74         unit *b;
  75         int rc;
  76         FILE *bf;
  77 #ifndef HAVE_FTRUNCATE
  78         FILE *tf;
  79 #endif /* !defined(HAVE_FTRUNCATE) */
  80
  81         b = &f__units[a->aunit];
  82         if(b->url)
  83                 return(0);      /*don't truncate direct files*/
  84         loc=ftell(bf = b->ufd);
  85         fseek(bf,0L,SEEK_END);
  86         len=ftell(bf);
  87         if (loc >= len || b->useek == 0 || b->ufnm == NULL)
  88                 return(0);
  89 #ifndef HAVE_FTRUNCATE
  90         rc = 0;
  91         fclose(b->ufd);
  92         if (!loc) {
  93                 if (!(bf = fopen(b->ufnm, f__w_mode[b->ufmt])))
  94                         rc = 1;
  95                 if (b->uwrt)
  96                         b->uwrt = 1;
  97                 goto done;
  98                 }
  99         if (!(bf = fopen(b->ufnm, f__r_mode[0]))
 100          || !(tf = tmpfile())) {
 101 #ifdef NON_UNIX_STDIO
 102  bad:
 103 #endif
 104                 rc = 1;
 105                 goto done;
 106                 }
 107         if (copy(bf, loc, tf)) {
 108  bad1:
 109                 rc = 1;
 110                 goto done1;
 111                 }
 112         if (!(bf = freopen(b->ufnm, f__w_mode[0], bf)))
 113                 goto bad1;
 114         rewind(tf);
 115         if (copy(tf, loc, bf))
 116                 goto bad1;
 117         b->uwrt = 1;
 118         b->urw = 2;
 119 #ifdef NON_UNIX_STDIO
 120         if (b->ufmt) {
 121                 fclose(bf);
 122                 if (!(bf = fopen(b->ufnm, f__w_mode[3])))
 123                         goto bad;
 124                 fseek(bf,0L,SEEK_END);
 125                 b->urw = 3;
 126                 }
 127 #endif
 128 done1:
 129         fclose(tf);
 130 done:
 131         f__cf = b->ufd = bf;
 132 #else  /* !defined(HAVE_FTRUNCATE) */
 133         fflush(b->ufd);
 134         /* The cast of loc is helpful on FreeBSD.  It helps
 135         in any case where ftruncate() prototype is somehow missing
 136         even though autoconf test found it properly.  */
 137         rc = ftruncate(fileno(b->ufd), (off_t)loc);
 138 #endif /* !defined(HAVE_FTRUNCATE) */
 139         if (rc)
 140                 err(a->aerr,111,"endfile");
 141         return 0;
 142         }