|
|
1.1 ! root 1: #include "sys/types.h" ! 2: #include "sys/stat.h" ! 3: #include "f2c.h" ! 4: #include "fio.h" ! 5: #include "string.h" ! 6: #include "fcntl.h" ! 7: #include "rawio.h" ! 8: #ifndef O_WRONLY ! 9: #define O_RDONLY 0 ! 10: #define O_WRONLY 1 ! 11: #endif ! 12: ! 13: #ifdef KR_headers ! 14: extern char *malloc(), *mktemp(); ! 15: extern FILE *fdopen(); ! 16: extern integer f_clos(); ! 17: #else ! 18: #undef abs ! 19: #undef min ! 20: #undef max ! 21: #include "stdlib.h" ! 22: extern int f__canseek(FILE*); ! 23: extern integer f_clos(cllist*); ! 24: #endif ! 25: ! 26: #ifdef NON_ANSI_RW_MODES ! 27: char *f__r_mode[2] = {"r", "r"}; ! 28: char *f__w_mode[2] = {"w", "w"}; ! 29: #else ! 30: char *f__r_mode[2] = {"rb", "r"}; ! 31: char *f__w_mode[2] = {"wb", "w"}; ! 32: #endif ! 33: ! 34: #ifdef KR_headers ! 35: f__isdev(s) char *s; ! 36: #else ! 37: f__isdev(char *s) ! 38: #endif ! 39: { ! 40: #ifdef MSDOS ! 41: int i, j; ! 42: ! 43: i = open(s,O_RDONLY); ! 44: if (i == -1) ! 45: return 0; ! 46: j = isatty(i); ! 47: close(i); ! 48: return j; ! 49: #else ! 50: struct stat x; ! 51: ! 52: if(stat(s, &x) == -1) return(0); ! 53: #ifdef S_IFMT ! 54: switch(x.st_mode&S_IFMT) { ! 55: case S_IFREG: ! 56: case S_IFDIR: ! 57: return(0); ! 58: } ! 59: #else ! 60: #ifdef S_ISREG ! 61: /* POSIX version */ ! 62: if(S_ISREG(x.st_mode) || S_ISDIR(x.st_mode)) ! 63: return(0); ! 64: else ! 65: #else ! 66: Help! How does stat work on this system? ! 67: #endif ! 68: #endif ! 69: return(1); ! 70: #endif ! 71: } ! 72: #ifdef KR_headers ! 73: integer f_open(a) olist *a; ! 74: #else ! 75: integer f_open(olist *a) ! 76: #endif ! 77: { unit *b; ! 78: int n; ! 79: char buf[256]; ! 80: cllist x; ! 81: #ifndef MSDOS ! 82: struct stat stb; ! 83: #endif ! 84: if(a->ounit>=MXUNIT || a->ounit<0) ! 85: err(a->oerr,101,"open") ! 86: f__curunit = b = &f__units[a->ounit]; ! 87: if(b->ufd) { ! 88: if(a->ofnm==0) ! 89: { ! 90: same: if (a->oblnk) ! 91: b->ublnk = *a->oblnk == 'z' || *a->oblnk == 'Z'; ! 92: return(0); ! 93: } ! 94: #ifdef MSDOS ! 95: if (b->ufnm ! 96: && strlen(b->ufnm) == a->ofnmlen ! 97: && !strncmp(b->ufnm, b->ufnm, (unsigned)a->ofnmlen)) ! 98: goto same; ! 99: #else ! 100: g_char(a->ofnm,a->ofnmlen,buf); ! 101: if (f__inode(buf,&n) == b->uinode && n == b->udev) ! 102: goto same; ! 103: #endif ! 104: x.cunit=a->ounit; ! 105: x.csta=0; ! 106: x.cerr=a->oerr; ! 107: if((n=f_clos(&x))!=0) return(n); ! 108: } ! 109: b->url=a->orl; ! 110: b->ublnk = a->oblnk && (*a->oblnk == 'z' || *a->oblnk == 'Z'); ! 111: if(a->ofm==0) ! 112: { if(b->url>0) b->ufmt=0; ! 113: else b->ufmt=1; ! 114: } ! 115: else if(*a->ofm=='f' || *a->ofm == 'F') b->ufmt=1; ! 116: else b->ufmt=0; ! 117: #ifdef url_Adjust ! 118: if (b->url && !b->ufmt) ! 119: url_Adjust(b->url); ! 120: #endif ! 121: if (a->ofnm) { ! 122: g_char(a->ofnm,a->ofnmlen,buf); ! 123: if (!buf[0]) ! 124: err(a->oerr,107,"open") ! 125: } ! 126: else ! 127: sprintf(buf, "fort.%ld", a->ounit); ! 128: b->uscrtch = 0; ! 129: switch(a->osta ? *a->osta : 'u') ! 130: { ! 131: case 'o': ! 132: case 'O': ! 133: #ifdef MSDOS ! 134: if(access(buf,0)) ! 135: #else ! 136: if(stat(buf,&stb)) ! 137: #endif ! 138: err(a->oerr,errno,"open") ! 139: break; ! 140: case 's': ! 141: case 'S': ! 142: b->uscrtch=1; ! 143: #ifdef _POSIX_SOURCE ! 144: tmpnam(buf); ! 145: #else ! 146: (void) strcpy(buf,"tmp.FXXXXXX"); ! 147: (void) mktemp(buf); ! 148: #endif ! 149: (void) close(creat(buf, 0666)); ! 150: break; ! 151: case 'n': ! 152: case 'N': ! 153: #ifdef MSDOS ! 154: if(!access(buf,0)) ! 155: #else ! 156: if(!stat(buf,&stb)) ! 157: #endif ! 158: err(a->oerr,128,"open") ! 159: /* no break */ ! 160: case 'r': /* Fortran 90 replace option */ ! 161: case 'R': ! 162: (void) close(creat(buf, 0666)); ! 163: break; ! 164: } ! 165: ! 166: b->ufnm=(char *) malloc((unsigned int)(strlen(buf)+1)); ! 167: if(b->ufnm==NULL) err(a->oerr,113,"no space"); ! 168: (void) strcpy(b->ufnm,buf); ! 169: b->uend=0; ! 170: b->uwrt = 0; ! 171: if(f__isdev(buf)) ! 172: { b->ufd = fopen(buf,f__r_mode[b->ufmt]); ! 173: if(b->ufd==NULL) err(a->oerr,errno,buf) ! 174: } ! 175: else { ! 176: if((b->ufd = fopen(buf, f__r_mode[b->ufmt])) == NULL) { ! 177: if ((n = open(buf,O_WRONLY)) >= 0) { ! 178: b->uwrt = 2; ! 179: } ! 180: else { ! 181: n = creat(buf, 0666); ! 182: b->uwrt = 1; ! 183: } ! 184: if (n < 0 ! 185: || (b->ufd = fdopen(n, f__w_mode[b->ufmt])) == NULL) ! 186: err(a->oerr, errno, "open"); ! 187: } ! 188: } ! 189: b->useek=f__canseek(b->ufd); ! 190: #ifndef MSDOS ! 191: if((b->uinode=f__inode(buf,&b->udev))==-1) ! 192: err(a->oerr,108,"open") ! 193: #endif ! 194: if(a->orl && b->useek) rewind(b->ufd); ! 195: return(0); ! 196: } ! 197: #ifdef KR_headers ! 198: fk_open(seq,fmt,n) ftnint n; ! 199: #else ! 200: fk_open(int seq, int fmt, ftnint n) ! 201: #endif ! 202: { char nbuf[10]; ! 203: olist a; ! 204: (void) sprintf(nbuf,"fort.%ld",n); ! 205: a.oerr=1; ! 206: a.ounit=n; ! 207: a.ofnm=nbuf; ! 208: a.ofnmlen=strlen(nbuf); ! 209: a.osta=NULL; ! 210: a.oacc= seq==SEQ?"s":"d"; ! 211: a.ofm = fmt==FMT?"f":"u"; ! 212: a.orl = seq==DIR?1:0; ! 213: a.oblnk=NULL; ! 214: return(f_open(&a)); ! 215: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.