1 /*- 2 * Copyright (c) 1980 The Regents of the University of California. 3 * All rights reserved. 4 * 5 * %sccs.include.proprietary.c% 6 */ 7 8 #ifndef lint 9 static char sccsid[] = "@(#)close.c 5.4 (Berkeley) 04/12/91"; 10 #endif /* not lint */ 11 12 /* 13 * f_clos(): f77 file close 14 * t_runc(): truncation 15 * f_exit(): I/O library exit routines 16 */ 17 18 #include "fio.h" 19 20 static char FROM_OPEN[] = "\2"; 21 static char clse[] = "close"; 22 23 f_clos(a) cllist *a; 24 { unit *b; 25 int n; 26 27 lfname = NULL; 28 elist = NO; 29 external = YES; 30 errflag = a->cerr; 31 lunit = a->cunit; 32 if(not_legal(lunit)) return(OK); 33 if(lunit==STDERR && (!a->csta || *a->csta != FROM_OPEN[0])) 34 err(errflag,F_ERUNIT,"can't close stderr"); 35 b= &units[lunit]; 36 if(!b->ufd) return(OK); 37 if(a->csta && *a->csta != FROM_OPEN[0]) 38 switch(lcase(*a->csta)) 39 { 40 delete: 41 case 'd': 42 fclose(b->ufd); 43 if(b->ufnm) unlink(b->ufnm); /*SYSDEP*/ 44 break; 45 default: 46 keep: 47 case 'k': 48 if(b->uwrt && (n=t_runc(b,errflag,clse))) return(n); 49 fclose(b->ufd); 50 break; 51 } 52 else if(b->uscrtch) goto delete; 53 else goto keep; 54 if(b->ufnm) free(b->ufnm); 55 b->ufnm=NULL; 56 b->ufd=NULL; 57 return(OK); 58 } 59 60 f_exit() 61 { 62 ftnint lu, dofirst = YES; 63 cllist xx; 64 xx.cerr=1; 65 xx.csta=FROM_OPEN; 66 for(lu=STDOUT; (dofirst || lu!=STDOUT); lu = ++lu % MXUNIT) 67 { 68 xx.cunit=lu; 69 f_clos(&xx); 70 dofirst = NO; 71 } 72 } 73 74 t_runc (b, flg, str) 75 unit *b; 76 ioflag flg; 77 char *str; 78 { 79 long loc; 80 81 if (b->uwrt) 82 fflush (b->ufd); 83 if (b->url || !b->useek || !b->ufnm) 84 return (OK); /* don't truncate direct access files, etc. */ 85 loc = ftell (b->ufd); 86 if (truncate (b->ufnm, loc) != 0) 87 err (flg, errno, str) 88 if (b->uwrt && ! nowreading(b)) 89 err (flg, errno, str) 90 return (OK); 91 } 92