diff --git a/tecs/make_gen b/tecs/make_gen index ef00c4f1..fdc675ff 100644 --- a/tecs/make_gen +++ b/tecs/make_gen @@ -9,7 +9,10 @@ LIBR_OBJ =coc_util.o myc_err.o myc_str.o myc_buf.o myc_time.o SERV_OBJ =tecs.o coc_server.o tecs_lsc.o tecs_serial.o coc_logfile.o \ tecs_data.o $(LIBR_OBJ) CLI_OBJ =tecs_cli.o coc_client.o $(LIBR_OBJ) -TCLI_OBJ =$(SYS_FILE).o $(SYS_FILE)_c.o $(CLI_OBJ) +TCLI_OBJ =sys_getenv.o sys_env.o myc_tmp.o sys_cmdpar.o \ + sys_date.o sys_wait.o sys_lun.o sys_rdline.o \ + sys_get_key.o sys_unix.o sys_open$(SYS_OPEN).o \ + $(CLI_OBJ) TECLI_OBJ =tecs_client.o tecs_plot.o str.o instr_hosts.o \ $(TCLI_OBJ) diff --git a/tecs/makefile_alpha b/tecs/makefile_alpha index 583f1947..b3873b17 100644 --- a/tecs/makefile_alpha +++ b/tecs/makefile_alpha @@ -19,7 +19,7 @@ FFLAGS = -u -g ARFLAGS = cr # -- system dependent routines -SYS_FILE =sys_aunix +SYS_OPEN = _alpha # -- PGPLOT library PGLIB =$(PGPLOT_DIR)/libpgplot.a -L/usr/X11R6/lib -lX11 diff --git a/tecs/makefile_linux b/tecs/makefile_linux index f9b35a27..eda4593e 100644 --- a/tecs/makefile_linux +++ b/tecs/makefile_linux @@ -19,7 +19,6 @@ FFLAGS = -u -fvxt -g ARFLAGS = cr # -- system dependent routines -SYS_FILE =sys_linux # -- PGPLOT library #PGPLOT =/afs/psi.ch/project/sinq/linux/pgplot/ diff --git a/tecs/myc_tmp.c b/tecs/myc_tmp.c new file mode 100644 index 00000000..bde43979 --- /dev/null +++ b/tecs/myc_tmp.c @@ -0,0 +1,96 @@ +#include +#include +#include +#include +#include "myc_fortran.h" +#include "myc_mem.h" +#include "myc_err.h" +#include "myc_str.h" + +int MycTmpName(char *result, const char *name, int reslen) { + char tmp[128]; + char *u; + + if (strlen(name)+64 > sizeof(tmp)) + ERR_MSG("destination string too short"); /* do not accept too long names */ + u=getenv("USER"); + if (u==NULL) + ERR_MSG("USER undefined"); + sprintf(tmp, "/tmp/%s_%s.%d", name, u, getpid()); + ERR_I(str_ncpy(result, tmp, reslen)); + return 0; + OnError: + return -1; +} + +int MycCleanTmp(void) { + time_t tim; + static time_t last=0; + char file[128], line[1024], fullid[16]; + char *sess=NULL, *files=NULL; + char *list, *id, *nxt, *nextline; + int i; + + time(&tim); + if (tim < last+3600) return 0; /* do not clean up before an hour after last time */ + last=tim; + file[0]='\0'; + ERR_I(MycTmpName(file, ".cleanup", sizeof(file))); + unlink(file); + /* make a list of used session and process id's */ + sprintf(line, "ps -U $USER -o pid,sess > %s", file); + system(line); + ERR_P(sess=str_read_file(file)); + unlink(file); + for (i=0; i<2; i++) { + if (i==0) { + sprintf(line, + "find /tmp/. ! -name . -prune -name \".*_$USER.*\" > %s", file); + } else { + sprintf(line, + "find /tmp/. ! -name . -prune -name \"*_$USER.*\" -mtime +7 > %s", file); + } + system(line); + ERR_P(files=str_read_file(file)); + unlink(file); + str_replace_char(sess, '\n', ' '); + list=files; + while (*list != '\0') { + nextline=str_split1(list, '\n'); + id=NULL; + nxt=list; + while (nxt != NULL) { /* find last dot */ + id=nxt+1; + nxt=strchr(nxt+1, '.'); + } + if (id!=NULL) { /* file contains a dot */ + sprintf(fullid, " %.12s ", id); + if (strstr(sess, fullid)==NULL) { + unlink(list); + } + } + list=nextline; + } + FREE(files); files=NULL; + } + FREE(sess); sess=NULL; + return 0; + OnError: + if (file[0] != '\0') unlink(file); + if (sess!=NULL) FREE(sess); + if (files!=NULL) FREE(files); + return -1; +} + +void F_FUN(sys_temp_name) ( F_CHAR(name), F_CHAR(path) F_CLEN(name) F_CLEN(path)) { + char nam[128]; + char pat[1024]; + + STR_TO_C(nam, name); + MycTmpName(pat, nam, sizeof(pat)); + STR_TO_F(path, pat); +} + +void F_FUN(sys_clean_tmp) (void) { + MycCleanTmp(); +} diff --git a/tecs/myc_tmp.h b/tecs/myc_tmp.h new file mode 100644 index 00000000..c9e1e38a --- /dev/null +++ b/tecs/myc_tmp.h @@ -0,0 +1,9 @@ +int MycTmpName(char *result, const char *name, int reslen); +/* generate a temporary filename containing 'name'. + * the filename is stored in 'result' with less than 'reslen' characters. + */ + +int MycCleanTmp(void); +/* deletes temporary files from closed sessions. files not beginning with a + * dot will be kept at least for 7 days (if the system does not delete then) + */ diff --git a/tecs/sys_aunix.f b/tecs/sys_aunix.f deleted file mode 100644 index 05d9b263..00000000 --- a/tecs/sys_aunix.f +++ /dev/null @@ -1,369 +0,0 @@ -!!------------------------------------------------------------------------------ -!! MODULE SYS -!!------------------------------------------------------------------------------ -!! 10.9.97 M. Zolliker -!! -!! System dependent subroutines for ALPHA UNIX -!!------------------------------------------------------------------------------ -!! - subroutine SYS_GETENV(NAME, VALUE) !! -!! ================================== -!! -!! Get logical name NAME -!! If the logical name is not in any table, VALUE will be blank - - implicit none -!! Arguments: - character*(*) NAME !! logical name - character*(*) VALUE !! result - - integer l - integer lnblnk - - l=lnblnk(name) - call getenv(name(1:l), value) - end - -!!----------------------------------------------------------------------------- -!! - subroutine SYS_DATE(YEAR, MONTH, DAY) !! -!! ------------------------------------- -!! -!! get actual date -!! - integer YEAR, MONTH, DAY !! 4-Digits year, month and day - - integer tarray(9) - external time - integer time - - call ltime(time(), tarray) - day=tarray(4) - month=tarray(5)+1 ! tarray(5): months since january (0-11)! - year=tarray(6)+1900 ! tarray(6): years since 1900, no y2k problem - end - -!!----------------------------------------------------------------------------- -!! - subroutine SYS_REMOTE_HOST(STR, TYPE) !! -!! -!! get remote host name/number -!! -!! type: TN telnet, RT: decnet, XW: X-window -!! - character STR*(*), TYPE*(*) !! - - character host*128 - integer i,j - integer lnblnk - - call sys_getenv('HOST', host) - call sys_getenv('DISPLAY', str) - i=index(str,':') - if (i .gt. 1) then - str=str(1:i-1) - type='XW' - else - call sys_getenv('REMOTEHOST', str) - if (str .ne. ' ') then - type='TN' - else - str=host - type='LO' - endif - endif - -! add domain to short host names - i=index(str, '.') - j=index(host, '.') - if (j .gt. 0 .and. i .eq. 0) then - i=lnblnk(str) - str(i+1:)=host(j:) - endif - end - -!!----------------------------------------------------------------------------- -!! - subroutine SYS_TEMP_NAME(NAME, PATH) !! -!! ==================================== -!! get a temporary file name -!! - character*(*) NAME !! (in) name - character*(*) PATH !! (out) path - - character line*64, pid*5 - integer i, l - - integer getppid - - call sys_getenv('USER', line) - if (line .eq. ' ') then - call str_trim(line, '/tmp/.'//name, l) - else - call str_trim(line, '/tmp/.'//name//'_'//line, l) - endif - - write(pid,'(i5)') getppid() - i=1 -1 if (pid(i:i) .eq. ' ') then - i=i+1 - goto 1 - endif - path=line(1:l)//'.'//pid(i:5) - end - -!!----------------------------------------------------------------------------- -!! - subroutine SYS_LOAD_ENV(FILE) !! -!! ============================= -!! load environment from temporary file -!! - character*(*) FILE !! filename - - character path*128, line*128 - integer lun, i, l - - integer getppid - - call sys_temp_name(file, path) - call sys_get_lun(lun) - open(lun,file=path,status='old',readonly,err=9) -5 read(lun,'(q,a)',end=8) l, line - l=min(l,len(line)) - i=index(line,'=') - if (i .eq. 0) then - if (l .gt. 0) call sys_setenv(line(1:l), ' ') - elseif (i .gt. 1 .and. i .lt. l) then - call sys_setenv(line(1:i-1),line(i+1:l)) - endif - goto 5 -8 close(lun) -9 call sys_free_lun(lun) - end - -!!----------------------------------------------------------------------------- -!! - subroutine SYS_SAVE_ENV(FILE, NAMES, N_NAMES) !! -!! ============================================= -!! save environment on temporary file -!! - character*(*) FILE !! filename - integer N_NAMES !! number of names - character*(*) NAMES(N_NAMES) !! names of variables to save - - character path*128, line*128 - integer lun, i, j, l - - call sys_temp_name(file, path) - call sys_get_lun(lun) - - open(lun,file=path,status='unknown',carriagecontrol='list' - 1,err=19) - - do i=1,n_names - call sys_getenv(names(i), line) - call str_trim(names(i),names(i), j) - call str_trim(line,line, l) - write(lun,'(3a)') names(i)(1:j),'=',line(1:l) - enddo - - close(lun) -9 call sys_free_lun(lun) - return - -19 print *,'SYS_SAVE_ENV: can not open tmp. file' - goto 9 - end - -!!----------------------------------------------------------------------------- -!! - subroutine SYS_WAIT(SECONDS) !! -!! ============================ -!! wait for SECONDS - real SECONDS !! resolution should be better than 0.1 sec. - - real tim, del - - tim=secnds(0.0) -1 del=seconds-secnds(tim) - if (del .ge. 0.999) then - call sleep(int(del)) - goto 1 - endif - if (del .gt. 0) then - call usleep(int(del*1E6)) - goto 1 - endif - end - -!!----------------------------------------------------------------------------- -!! - subroutine SYS_GET_LUN(LUN) !! -!! -!! allocate logical unit number - - integer LUN !! out - - logical*1 act(50:100)/51*.false./ - save act - - integer l - - l=50 - do while (l .lt. 99 .and. act(l)) - l=l+1 - enddo - if (l .eq. 100) stop 'SYS_GET_LUN: no more luns available' - lun=l - act(l)=.true. - return -!! - entry SYS_FREE_LUN(LUN) !! -!! -!! deallocate logical unit number - - if (act(lun)) then - act(lun)=.false. - else - stop 'SYS_FREE_LUN: lun already free' - endif - end - -!!----------------------------------------------------------------------------- -!! - subroutine SYS_RENAME_FILE(OLD, NEW) !! -!! ==================================== -!! - character OLD*(*), NEW*(*) !! (in) old, new filename - - call rename(OLD, NEW) - end - -!!----------------------------------------------------------------------------- -!! - subroutine SYS_DELETE_FILE(NAME) !! -!! ================================ -!! - character NAME*(*) !! (in) filename - - call unlink(NAME) - end - -!!----------------------------------------------------------------------------- -!! - subroutine SYS_HOME(HOME) !! -!! ========================= -!! -!! get home directory (+ dot) - - character HOME*(*) !! (out) filename - - integer l - integer lnblnk - - call sys_getenv('HOME',home) - l=lnblnk(home) - if (l .lt. len(home)-1) then - if (home(l:l) .ne. '/') then - home(l+1:l+1)='/' - l=l+1 - endif - home(l+1:l+1)='.' - l=l+1 - endif - end - -!!------------------------------------------------------------------------------ -!! - subroutine SYS_CHECK_SYSTEM(CODE) !! -!! ================================= -!! - character CODE*(*) !! - - code='ALPHA_UNIX' !! - end - -!!----------------------------------------------------------------------------- -!! - subroutine SYS_GET_CMDPAR(STR, L) !! -!! --------------------------------- -!! - character*(*) STR !! - integer L !! - - integer i - integer lnblnk, iargc - - l=0 - str=' ' - do i=1,iargc() - if (l .lt. len(str)) then - call getarg(i, str(l+1:)) - l=lnblnk(str) - l=l+1 - endif - enddo - if (l .gt. 0) then - if (str(1:l) .eq. ' ') l=0 - endif - end - -!!----------------------------------------------------------------------------- -!! - subroutine SYS_GET_KEY(KEY, TMO) !! -!! -!! read for keyboard with timeout, without echo -!! - character KEY*1 !! - integer TMO !! timeout in seconds (<100) - - parameter esc=char(27), csi=char(155), ss3=char(143) - - call sys_get_raw_key(key, tmo) -1 if (key .eq. esc) then - call sys_get_raw_key(key, tmo) - if (key .eq. 'O') then - key=ss3 - goto 1 - elseif (key .eq. '[') then - key=csi - goto 1 - endif - elseif (key .eq. csi) then - call sys_get_raw_key(key, tmo) - do while (key .ge. '0' .and. key .le. '9') - call sys_get_raw_key(key, tmo) - enddo - key=' ' - elseif (key .eq. ss3) then - call sys_get_raw_key(key, tmo) - if (key .eq. 'm') then - key='-' - elseif (key .eq. 'l') then - key='+' - elseif (key .eq. 'n') then - key='.' - elseif (key .eq. 'M') then - key=char(13) - elseif (key .eq. 'S') then - key='*' - elseif (key .eq. 'R') then - key='/' - elseif (key .eq. 'Q') then - key='=' - else - key=' ' - endif - endif - end - -!----------------------------------------------------------------------------- -! - subroutine sys_open_read(lun, name, ios) -! -! open a file as read only (needed to open files with read-only access) - integer lun, ios - character name*(*) - - open (lun, file=name, status='old', readonly, iostat=ios) - end diff --git a/tecs/sys_aunix_c.c b/tecs/sys_aunix_c.c deleted file mode 100644 index 8687f4f9..00000000 --- a/tecs/sys_aunix_c.c +++ /dev/null @@ -1,203 +0,0 @@ -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include - -static char *last_line = NULL; - -int lnblnk_(char *c, int c_len); -char *readline(char *prompt); -void add_history(char *line_read); -/* -int usleep(time_t delay); -*/ - -void sys_rd_line_(char *cmd, int *retlen, char *prompt, int clen, int plen) -{ - char *line_read, p[64]; - - assert(plen < sizeof(p)); - strncpy(p,prompt,plen); p[plen] = '\0'; - if (last_line == NULL) { last_line =malloc(1); last_line[0] = '\0';}; - - line_read = readline(p); - - if (line_read) - { - if (*line_read && strcmp(last_line, line_read)!=0) - add_history (line_read); - free (last_line); - strncpy(cmd, line_read, clen); - *retlen=strlen(line_read); - last_line = line_read; - if (*retlen>clen) *retlen=clen; - } else { - *retlen=-1; - } -} - - -void intcatch(int sig) -{ printf("\nuse quit (normally ctrl-\\) to interrupt\n"); -} - -int called=0; /* env is valid only if called==1 */ -jmp_buf env; - -void (*inthdl)(int sig); -void (*errhdl)(void); - -void sighdl(int sig) -{ if (called) longjmp(env,sig); -} - -void sys_err_hdl_(void errhdl0()) -{ errhdl=errhdl0; } - -void sys_int_hdl_(void inthdl0(int sig)) -{ inthdl=inthdl0; } - -void sys_try_(void proc()) -{ int sig, status; - void (*sgh[32]) (int); - - assert(!called); /* nested calls not allowed */ - called=1; - sgh[SIGFPE] =signal(SIGFPE, sighdl); - sgh[SIGINT] =signal(SIGINT, *inthdl); - status=setjmp(env); - if (status==0) /* first return of setjmp */ - { proc(); } - else - { (*errhdl)(); }; - signal(SIGFPE, sgh[SIGFPE]); - signal(SIGINT, intcatch); - called=0; -} - -void sys_abort_() -{ if (called) longjmp(env,-2); -} - - -void sys_exit_hdl_(void hdl()) -{ int res; - res=atexit(hdl); -} - -struct termios atts; - -void sys_get_raw_key_(char *key, int *tmo, int k_len) -{ - struct termios attr; - int ires, ntmo, chr; - - ires=tcgetattr(STDIN_FILENO,&attr); - atts=attr; /* save term. attr. */ - if (ires!=0) {perror("***\n");} - attr.c_lflag &= ~(ICANON) & ~(ECHO); /* canonical mode off, echo off */ - attr.c_cc[VMIN]=0; - ires= tcsetattr(STDIN_FILENO,TCSANOW,&attr); - if (ires!=0) {perror("***\n");} - -/* - ires=fflush(stdin); - ires=fflush(stderr); -*/ - - ntmo=*tmo*100; - chr=fgetc(stdin); - if (chr==EOF) { - while ((chr==EOF) & (ntmo>0)) { - usleep(10000); /* wait 10 ms */ - chr=fgetc(stdin); - ntmo--; - } - } - if (chr==EOF) chr=0; - - *key=chr; - - ires=tcsetattr(STDIN_FILENO,TCSANOW,&atts); /* restore term. attributes */ - if (ires!=0) {perror("***\n");}; -} - - -void usleep_(int *usec) { usleep(*usec); } -int getppid_(void) { return getppid(); } - -int sys_setenv_(ename,evalue,ilen1,ilen2) -char *ename, *evalue; -int ilen1, ilen2; -{ - int setenv(char *p1, char *p2, int ow), i1, i2, ow, rc; - char *p1, *p2; - - i1 = lnblnk_(ename,ilen1); - i2 = lnblnk_(evalue,ilen2); - - p1 = malloc((unsigned) i1+1); if( p1 == NULL ) return (-1); - p2 = malloc((unsigned) i2+1); if( p2 == NULL ) { free(p1); return (-1); } - - strncpy(p1,ename,i1); p1[i1] = '\0'; - strncpy(p2,evalue,i2); p2[i2] = '\0'; - - ow = 1; - - rc = setenv(p1, p2, ow); - free(p1); free(p2); - return(rc); -} - - -void sys_rd_tmo_(char *prompt, char *result, int *reslen, int p_len, int r_len) -{ - struct termios atts; - struct termios attr; - int ires, i, ntmo, chr; - - ires=tcgetattr(STDIN_FILENO,&attr); - atts=attr; /* save term. attr. */ - if (ires!=0) {perror("***\n");} - attr.c_lflag &= ~(ICANON) & ~(ECHO); /* canonical mode off, echo off */ - attr.c_cc[VMIN]=0; - ires= tcsetattr(STDIN_FILENO,TCSANOW,&attr); - if (ires!=0) {perror("***\n");} - - do { chr=fgetc(stdin); } while (chr!=EOF); - - for (i=0; i0)) - { usleep(10000); /* wait 10 ms */ - chr=fgetc(stdin); - ntmo--; - }; - if (chr==EOF) break; - if (chr==10) {ntmo=10;} else {ntmo=100;}; /* wait 0.1 sec after LF, 1 sec else */ - }; - result[(*reslen)++]=(char)chr; - if (chr==24) {(*reslen)=0;}; /* ctrl-X purges buffer */ - }; - if (result[(*reslen)-1]=10) {(*reslen)--;}; /* strip trailing LF */ - - ires=tcsetattr(STDIN_FILENO,TCSANOW,&atts); /* restore term. attributes */ - if (ires!=0) {perror("***\n");}; -} diff --git a/tecs/sys_cmdpar.f b/tecs/sys_cmdpar.f new file mode 100755 index 00000000..1bed707b --- /dev/null +++ b/tecs/sys_cmdpar.f @@ -0,0 +1,23 @@ +!!----------------------------------------------------------------------------- +!! + subroutine SYS_GET_CMDPAR(STR, L) !! +!! --------------------------------- +!! + character*(*) STR !! + integer L !! + + integer i,iargc + + l=0 + str=' ' + do i=1,iargc() + if (l .lt. len(str)) then + call getarg(i, str(l+1:)) + call str_trim(str, str, l) + l=l+1 + endif + enddo + if (l .gt. 0) then + if (str(1:l) .eq. ' ') l=0 + endif + end diff --git a/tecs/sys_date.f b/tecs/sys_date.f new file mode 100755 index 00000000..b92a8767 --- /dev/null +++ b/tecs/sys_date.f @@ -0,0 +1,18 @@ +!!----------------------------------------------------------------------------- +!! + subroutine SYS_DATE(YEAR, MONTH, DAY) !! +!! ------------------------------------- +!! +!! get actual date +!! + integer YEAR, MONTH, DAY !! 4-Digits year, month and day + + integer tarray(9) + external time + integer time + + call ltime(time(), tarray) + day=tarray(4) + month=tarray(5)+1 ! tarray(5): months since january (0-11)! + year=tarray(6)+1900 ! tarray(6): years since 1900, no y2k problem + end diff --git a/tecs/sys_env.c b/tecs/sys_env.c new file mode 100755 index 00000000..6a8d2ef8 --- /dev/null +++ b/tecs/sys_env.c @@ -0,0 +1,179 @@ +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include "myc_tmp.h" +#include "myc_str.h" +#include "myc_fortran.h" + +#define ENAM_LEN 128 +#define EVAL_LEN 1024 + +int lnblnk_(const char *str, int len); +#ifdef __alpha + int setenv(char *p1, char *p2, int ow); +#endif + +typedef struct _EnvList { struct _EnvList *next; char *name; char *value; } EnvList; +static EnvList *envlist; +static char tmpfil[128]; +static char senv_id[16]; +static char *empty=""; +static int loaded=0; +static int dirty=0; + +EnvList *sys_findenv(char *name) { + EnvList *p; + for (p=envlist; p!=NULL; p=p->next) { + if (0==strcmp(name, p->name)) { + return p; + } + } + return NULL; +} + +int F_FUN(sys_loadenv)(void) { + FILE *fil; + char buf[ENAM_LEN+EVAL_LEN+10]; + char old[EVAL_LEN], userid[32]; + char *nam, *val, *pold, *u, *ret, *v; + int l; + EnvList *p; + + if (!loaded) { + loaded=-1; /* assume failure */ + /* u=cuserid(userid); */ + u=getenv("USER"); + if (u==NULL) { + strcpy(userid, "Anonymous"); + } else { + strncpy(userid, u, sizeof(userid)); + } + val=getenv("senv_id"); + if (val==NULL) { + sprintf(senv_id, "%d", getppid()); + } else { + strcpy(senv_id, val); + } + sprintf(tmpfil, "/tmp/.senv_%s.%s", userid, senv_id); + fil=fopen(tmpfil, "r"); + if (fil==NULL) { + loaded=1; + return 1; + } + while (1) { + + ret=fgets(buf, sizeof(buf), fil); + if (!ret || buf[0]=='#') break; + l=strlen(buf); + if (l<10 || buf[l-1]!='\n') return -1; + buf[l-1]='\0'; + buf[6]='\0'; + if (0!=strcmp(buf, "setenv")) return -1; + nam=buf+7; + val=strchr(nam, ' '); + if (val==NULL) return -1; + *val='\0'; val++; + if (*val=='"') { + if (buf[l-2]!='"') return -1; + buf[l-2]='\0'; + val++; + } + + ret=fgets(old, sizeof(old), fil); + if (!ret) break; + l=strlen(old); + if (l==0 || old[0]!='#' || old[l-1]!='\n') return -1; + old[l-1]='\0'; + pold=old+1; + + v=getenv(nam); + if (v==NULL) v=empty; + if (0==strcmp(v,pold)) { /* take value from file only if env. variable not changed in the meantime */ + p = malloc(sizeof(*p)); if (p == NULL) goto senv; + if (NULL==(p->name = strdup(nam))) goto senv; + if (NULL==(p->value = strdup(v))) goto senv; + p->next = envlist; + envlist=p; + senv: + setenv(nam, val, 1); + } + } + if (0>fclose(fil)) return -1; + loaded=1; + } + return loaded; +} + +int F_FUN(sys_setenv)(char *enam, char *eval, int snam, int sval) { + int lnam, lval; + char *v, nam[ENAM_LEN], val[EVAL_LEN]; + EnvList *p=NULL; + + lnam = lnblnk_(enam,snam); + if (lnam>=sizeof(nam)) lnam=sizeof(nam)-1; + strncpy(nam,enam,lnam); nam[lnam] = '\0'; + + lval = lnblnk_(eval,sval); + if (lval>=sizeof(val)) lval=sizeof(val)-1; + strncpy(val,eval,lval); val[lval] = '\0'; + + if (loaded>0) { + v=getenv(nam); + if (v == NULL) v=empty; + if (!dirty) { + dirty = 0 != strcmp(val,v); + } + p=sys_findenv(nam); + if (p==NULL) { + p = malloc(sizeof(*p)); if (p == NULL) goto senv; + if (NULL==(p->name = strdup(nam))) goto senv; + if (NULL==(p->value = strdup(v))) goto senv; + p->next = envlist; + envlist=p; + } + } + senv: + return setenv(nam, val, 1); +} + +int F_FUN(sys_saveenv)(void) { + FILE *fil; + char *v; + EnvList *p; + + if (F_FUN(sys_loadenv)()<0 || !dirty) return loaded; + + fil=fopen(tmpfil, "w"); + if (fil==NULL) return -1; + + for (p=envlist; p!=NULL; p=p->next) { + v=getenv(p->name); + if (0!=strcmp(v, p->value)) { + if (0>fputs("setenv ", fil)) return -1; + if (0>fputs(p->name, fil)) return -1; + if (0>fputs(" \"", fil)) return -1; + if (0>fputs(v, fil)) return -1; + if (0>fputs("\"\n#", fil)) return -1; + if (0>fputs(p->value, fil)) return -1; + if (0>fputs("\n", fil)) return -1; + } + } + if (0>fputs("#\nif ($$ == ", fil)) return -1; + if (0>fputs(senv_id, fil)) return -1; + if (0>fputs(") then\n /bin/rm ", fil)) return -1; + if (0>fputs(tmpfil, fil)) return -1; +/* + if (0>fputs("\n echo \"#\" > ", fil)) return -1; + if (0>fputs(tmpfil, fil)) return -1; +*/ + if (0>fputs("\nendif\n", fil)) return -1; + if (0>fclose(fil)) return -1; + dirty=0; + return 0; +} diff --git a/tecs/sys_get_key.f b/tecs/sys_get_key.f new file mode 100644 index 00000000..8ae39114 --- /dev/null +++ b/tecs/sys_get_key.f @@ -0,0 +1,52 @@ +!!----------------------------------------------------------------------------- +!! + subroutine SYS_GET_KEY(KEY, TMO) !! +!! +!! read for keyboard with timeout, without echo +!! + character KEY*1 !! + integer TMO !! timeout in seconds (<100) + + character esc*1, csi*1, ss3*1 + + esc=char(27) + csi=char(155) + ss3=char(143) + + call sys_get_raw_key(key, tmo) +1 if (key .eq. esc) then + call sys_get_raw_key(key, tmo) + if (key .eq. 'O') then + key=ss3 + goto 1 + elseif (key .eq. '[') then + key=csi + goto 1 + endif + elseif (key .eq. csi) then + call sys_get_raw_key(key, tmo) + do while (key .ge. '0' .and. key .le. '9') + call sys_get_raw_key(key, tmo) + enddo + key=' ' + elseif (key .eq. ss3) then + call sys_get_raw_key(key, tmo) + if (key .eq. 'm') then + key='-' + elseif (key .eq. 'l') then + key='+' + elseif (key .eq. 'n') then + key='.' + elseif (key .eq. 'M') then + key=char(13) + elseif (key .eq. 'S') then + key='*' + elseif (key .eq. 'R') then + key='/' + elseif (key .eq. 'Q') then + key='=' + else + key=' ' + endif + endif + end diff --git a/tecs/sys_getenv.f b/tecs/sys_getenv.f new file mode 100755 index 00000000..ca1243a1 --- /dev/null +++ b/tecs/sys_getenv.f @@ -0,0 +1,75 @@ +!!------------------------------------------------------------------------------ +!! + subroutine SYS_GETENV(NAME, VALUE) !! +!! ================================== +!! +!! Get environment variable NAME +!! try all uppercase also + + implicit none +!! Arguments: + character*(*) NAME !! logical name + character*(*) VALUE !! result + + integer l + character nam*128 + + call sys_loadenv + call str_trim(nam, name, l) + call getenv(nam(1:l), value) + if (value .ne. ' ') RETURN + if (nam(1:1) .ge. 'a') then + call str_upcase(nam(1:l), nam(1:l)) + else + call str_lowcase(nam(1:l), nam(1:l)) + endif + call getenv(nam(1:l), value) + end + +!!------------------------------------------------------------------------------ +!! + subroutine SYS_GETENV_IDX(NAME, VALUE, IDX) !! +!! =========================================== +!! +!! Get environment variable NAME, only list element IDX (start with 0) +!! (separated by comma) + + implicit none +!! Arguments: + character*(*) NAME !! logical name + character*(*) VALUE !! result + integer IDX !! index + + integer l,pos,j,i + character nam*128, list*1024 + + call str_trim(nam, name, l) + call getenv(nam(1:l), list) + if (list .eq. ' ') then + if (nam(1:1) .ge. 'a') then + call str_upcase(nam(1:l), nam(1:l)) + else + call str_lowcase(nam(1:l), nam(1:l)) + endif + call getenv(nam(1:l), list) + endif + pos=0 + do i=1,idx + j=index(list(pos+1:), ',') + if (j .eq. 0) then + value=' ' + RETURN + endif + pos=pos+j + enddo + j=index(list(pos+1:), ',') + if (j .eq. 1) then + value=' ' + RETURN + endif + if (j .le. 0) then + value=list(pos+1:) + else + value=list(pos+1:pos+j-1) + endif + end diff --git a/tecs/sys_linux.f b/tecs/sys_linux.f deleted file mode 100644 index e4e517c2..00000000 --- a/tecs/sys_linux.f +++ /dev/null @@ -1,374 +0,0 @@ -!!------------------------------------------------------------------------------ -!! MODULE SYS -!!------------------------------------------------------------------------------ -!! 10.9.97 M. Zolliker -!! -!! System dependent subroutines for LINUX -!!------------------------------------------------------------------------------ -!! - subroutine SYS_GETENV(NAME, VALUE) !! -!! ================================== -!! -!! Get logical name NAME -!! If the logical name is not in any table, VALUE will be blank - - implicit none -!! Arguments: - character*(*) NAME !! logical name - character*(*) VALUE !! result - - integer l - integer lnblnk - - l=lnblnk(name) - call getenv(name(1:l), value) - end - -!!----------------------------------------------------------------------------- -!! - subroutine SYS_DATE(YEAR, MONTH, DAY) !! -!! ------------------------------------- -!! -!! get actual date -!! - integer YEAR, MONTH, DAY !! 4-Digits year, month and day - - integer tarray(9) - external time - integer time - - call ltime(time(), tarray) - day=tarray(4) - month=tarray(5)+1 ! tarray(5): months since january (0-11)! - year=tarray(6)+1900 ! tarray(6): years since 1900, no y2k problem - end - -!!----------------------------------------------------------------------------- -!! - subroutine SYS_REMOTE_HOST(STR, TYPE) !! -!! -!! get remote host name/number -!! -!! type: TN telnet, RT: decnet, XW: X-window -!! - character STR*(*), TYPE*(*) !! - - character host*128 - integer i,j - integer lnblnk - - call sys_getenv('HOST', host) - call sys_getenv('DISPLAY', str) - i=index(str,':') - if (i .gt. 1) then - str=str(1:i-1) - type='XW' - else - call sys_getenv('REMOTEHOST', str) - if (str .ne. ' ') then - type='TN' - else - str=host - type='LO' - endif - endif - -! add domain to short host names - i=index(str, '.') - j=index(host, '.') - if (j .gt. 0 .and. i .eq. 0) then - i=lnblnk(str) - str(i+1:)=host(j:) - endif - end - -!!----------------------------------------------------------------------------- -!! - subroutine SYS_TEMP_NAME(NAME, PATH) !! -!! ==================================== -!! get a temporary file name -!! - character*(*) NAME !! (in) name - character*(*) PATH !! (out) path - - character line*64, pid*5, nam*64 - integer i, l - - integer getppid - - nam='/tmp/.' - nam(7:)=name - call sys_getenv('USER', line) - if (line .eq. ' ') then - call str_trim(line, nam, l) - else - call str_trim(nam, nam, l) - call str_trim(line, nam(1:l)//'_'//line, l) - endif - - write(pid,'(i5)') getppid() - i=1 -1 if (pid(i:i) .eq. ' ') then - i=i+1 - goto 1 - endif - path=line(1:l)//'.'//pid(i:5) - end - -!!----------------------------------------------------------------------------- -!! - subroutine SYS_LOAD_ENV(FILE) !! -!! ============================= -!! load environment from temporary file -!! - character*(*) FILE !! filename - - character path*128, line*128 - integer lun, i, l - - integer getppid - - call sys_temp_name(file, path) - call sys_get_lun(lun) - open(lun,file=path,status='old',err=9) -5 read(lun,'(q,a)',end=8) l, line - l=min(l,len(line)) - i=index(line,'=') - if (i .eq. 0) then - if (l .gt. 0) call sys_setenv(line(1:l), ' ') - elseif (i .gt. 1 .and. i .lt. l) then - call sys_setenv(line(1:i-1),line(i+1:l)) - endif - goto 5 -8 close(lun) -9 call sys_free_lun(lun) - end - -!!----------------------------------------------------------------------------- -!! - subroutine SYS_SAVE_ENV(FILE, NAMES, N_NAMES) !! -!! ============================================= -!! save environment on temporary file -!! - character*(*) FILE !! filename - integer N_NAMES !! number of names - character*(*) NAMES(N_NAMES) !! names of variables to save - - character path*128, line*128 - integer lun, i, j, l - - call sys_temp_name(file, path) - call sys_get_lun(lun) - - open(lun,file=path,status='unknown',err=19) - - do i=1,n_names - call sys_getenv(names(i), line) - call str_trim(names(i),names(i), j) - call str_trim(line,line, l) - write(lun,'(3a)') names(i)(1:j),'=',line(1:l) - enddo - - close(lun) -9 call sys_free_lun(lun) - return - -19 print *,'SYS_SAVE_ENV: can not open tmp. file' - goto 9 - end - -!!----------------------------------------------------------------------------- -!! - subroutine SYS_WAIT(SECONDS) !! -!! ============================ -!! wait for SECONDS - real SECONDS !! resolution should be better than 0.1 sec. - - real tim, del - - tim=secnds(0.0) -1 del=seconds-secnds(tim) - if (del .ge. 0.999) then - call sleep(int(del)) - goto 1 - endif - if (del .gt. 0) then - call usleep(int(del*1E6)) - goto 1 - endif - end - -!!----------------------------------------------------------------------------- -!! - subroutine SYS_GET_LUN(LUN) !! -!! -!! allocate logical unit number - - integer LUN !! out - - logical*1 act(50:100)/51*.false./ - save act - - integer l - - l=50 - do while (l .lt. 99 .and. act(l)) - l=l+1 - enddo - if (l .eq. 100) stop 'SYS_GET_LUN: no more luns available' - lun=l - act(l)=.true. - return -!! - entry SYS_FREE_LUN(LUN) !! -!! -!! deallocate logical unit number - - if (act(lun)) then - act(lun)=.false. - else - stop 'SYS_FREE_LUN: lun already free' - endif - end - -!!----------------------------------------------------------------------------- -!! - subroutine SYS_RENAME_FILE(OLD, NEW) !! -!! ==================================== -!! - character OLD*(*), NEW*(*) !! (in) old, new filename - - call rename(OLD, NEW) - end - -!!----------------------------------------------------------------------------- -!! - subroutine SYS_DELETE_FILE(NAME) !! -!! ================================ -!! - character NAME*(*) !! (in) filename - - call unlink(NAME) - end - -!!----------------------------------------------------------------------------- -!! - subroutine SYS_HOME(HOME) !! -!! ========================= -!! -!! get home directory (+ dot) - - character HOME*(*) !! (out) filename - - integer l - integer lnblnk - - call sys_getenv('HOME',home) - l=lnblnk(home) - if (l .lt. len(home)-1) then - if (home(l:l) .ne. '/') then - home(l+1:l+1)='/' - l=l+1 - endif - home(l+1:l+1)='.' - l=l+1 - endif - end - -!!------------------------------------------------------------------------------ -!! - subroutine SYS_CHECK_SYSTEM(CODE) !! -!! ================================= -!! - character CODE*(*) !! - - code='ALPHA_UNIX' !! - end - -!!----------------------------------------------------------------------------- -!! - subroutine SYS_GET_CMDPAR(STR, L) !! -!! --------------------------------- -!! - character*(*) STR !! - integer L !! - - integer i - integer lnblnk, iargc - - l=0 - str=' ' - do i=1,iargc() - if (l .lt. len(str)) then - call getarg(i, str(l+1:)) - l=lnblnk(str) - l=l+1 - endif - enddo - if (l .gt. 0) then - if (str(1:l) .eq. ' ') l=0 - endif - end - -!!----------------------------------------------------------------------------- -!! - subroutine SYS_GET_KEY(KEY, TMO) !! -!! -!! read for keyboard with timeout, without echo -!! - character KEY*1 !! - integer TMO !! timeout in seconds (<100) - - character esc*1, csi*1, ss3*1 - - esc=char(27) - csi=char(155) - ss3=char(143) - - call sys_get_raw_key(key, tmo) -1 if (key .eq. esc) then - call sys_get_raw_key(key, tmo) - if (key .eq. 'O') then - key=ss3 - goto 1 - elseif (key .eq. '[') then - key=csi - goto 1 - endif - elseif (key .eq. csi) then - call sys_get_raw_key(key, tmo) - do while (key .ge. '0' .and. key .le. '9') - call sys_get_raw_key(key, tmo) - enddo - key=' ' - elseif (key .eq. ss3) then - call sys_get_raw_key(key, tmo) - if (key .eq. 'm') then - key='-' - elseif (key .eq. 'l') then - key='+' - elseif (key .eq. 'n') then - key='.' - elseif (key .eq. 'M') then - key=char(13) - elseif (key .eq. 'S') then - key='*' - elseif (key .eq. 'R') then - key='/' - elseif (key .eq. 'Q') then - key='=' - else - key=' ' - endif - endif - end -!----------------------------------------------------------------------------- -! - subroutine sys_open_read(lun, name, ios) -! -! open a file as read only (needed to open files with read-only access) - integer lun, ios - character name*(*) - - open (lun, file=name, status='old', iostat=ios) - end diff --git a/tecs/sys_linux_c.c b/tecs/sys_linux_c.c deleted file mode 100644 index 8411c51d..00000000 --- a/tecs/sys_linux_c.c +++ /dev/null @@ -1,200 +0,0 @@ -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include - -static char *last_line = NULL; - -int lnblnk_(char *c, int c_len); -char *readline(char *prompt); -void add_history(char *line_read); - -void sys_rd_line__(char *cmd, int *retlen, char *prompt, int clen, int plen) -{ - char *line_read, p[64]; - - assert(plen < sizeof(p)); - strncpy(p,prompt,plen); p[plen] = '\0'; - if (last_line == NULL) { last_line =malloc(1); last_line[0] = '\0';}; - - line_read = readline(p); - - if (line_read) - { - if (*line_read && strcmp(last_line, line_read)!=0) - add_history (line_read); - free (last_line); - strncpy(cmd, line_read, clen); - *retlen=strlen(line_read); - last_line = line_read; - if (*retlen>clen) *retlen=clen; - } else { - *retlen=-1; - } -} - - -void intcatch(int sig) -{ printf("\nuse quit (normally ctrl-\\) to interrupt\n"); -} - -int called=0; /* env is valid only if called==1 */ -jmp_buf env; - -void (*inthdl)(int sig); -void (*errhdl)(void); - -void sighdl(int sig) -{ if (called) longjmp(env,sig); -} - -void sys_err_hdl__(void errhdl0()) -{ errhdl=errhdl0; } - -void sys_int_hdl__(void inthdl0(int sig)) -{ inthdl=inthdl0; } - -void sys_try__(void proc()) -{ int sig, status; - void (*sgh[32]) (int); - - assert(!called); /* nested calls not allowed */ - called=1; - sgh[SIGFPE] =signal(SIGFPE, sighdl); - sgh[SIGINT] =signal(SIGINT, *inthdl); - status=setjmp(env); - if (status==0) /* first return of setjmp */ - { proc(); } - else - { (*errhdl)(); }; - signal(SIGFPE, sgh[SIGFPE]); - signal(SIGINT, intcatch); - called=0; -} - -void sys_abort__() -{ if (called) longjmp(env,-2); -} - - -void sys_exit_hdl__(void hdl()) -{ int res; - res=atexit(hdl); -} - -struct termios atts; - -void sys_get_raw_key__(char *key, int *tmo, int k_len) -{ - struct termios attr; - int ires, ntmo, chr; - - ires=tcgetattr(STDIN_FILENO,&attr); - atts=attr; /* save term. attr. */ - if (ires!=0) {perror("***\n");} - attr.c_lflag &= ~(ICANON) & ~(ECHO); /* canonical mode off, echo off */ - attr.c_cc[VMIN]=0; - ires= tcsetattr(STDIN_FILENO,TCSANOW,&attr); - if (ires!=0) {perror("***\n");} - -/* - ires=fflush(stdin); - ires=fflush(stderr); -*/ - - ntmo=*tmo*100; - chr=fgetc(stdin); - if (chr==EOF) { - while ((chr==EOF) & (ntmo>0)) { - usleep(10000); /* wait 10 ms */ - chr=fgetc(stdin); - ntmo--; - } - } - if (chr==EOF) chr=0; - - *key=chr; - - ires=tcsetattr(STDIN_FILENO,TCSANOW,&atts); /* restore term. attributes */ - if (ires!=0) {perror("***\n");}; -} - - -void usleep_(int *usec) { usleep(*usec); } -int getppid_(void) { return getppid(); } - -int sys_setenv__(ename,evalue,ilen1,ilen2) -char *ename, *evalue; -int ilen1, ilen2; -{ - int i1, i2, ow, rc; - char *p1, *p2; - - i1 = lnblnk_(ename,ilen1); - i2 = lnblnk_(evalue,ilen2); - - p1 = malloc((unsigned) i1+1); if( p1 == NULL ) return (-1); - p2 = malloc((unsigned) i2+1); if( p2 == NULL ) { free(p1); return (-1); } - - strncpy(p1,ename,i1); p1[i1] = '\0'; - strncpy(p2,evalue,i2); p2[i2] = '\0'; - - ow = 1; - - rc = setenv(p1, p2, ow); - free(p1); free(p2); - return(rc); -} - - -void sys_rd_tmo__(char *prompt, char *result, int *reslen, int p_len, int r_len) -{ - struct termios atts; - struct termios attr; - int ires, i, ntmo, chr; - - ires=tcgetattr(STDIN_FILENO,&attr); - atts=attr; /* save term. attr. */ - if (ires!=0) {perror("***\n");} - attr.c_lflag &= ~(ICANON) & ~(ECHO); /* canonical mode off, echo off */ - attr.c_cc[VMIN]=0; - ires= tcsetattr(STDIN_FILENO,TCSANOW,&attr); - if (ires!=0) {perror("***\n");} - - do { chr=fgetc(stdin); } while (chr!=EOF); - - for (i=0; i0)) - { usleep(10000); /* wait 10 ms */ - chr=fgetc(stdin); - ntmo--; - }; - if (chr==EOF) break; - if (chr==10) {ntmo=10;} else {ntmo=100;}; /* wait 0.1 sec after LF, 1 sec else */ - }; - result[(*reslen)++]=(char)chr; - if (chr==24) {(*reslen)=0;}; /* ctrl-X purges buffer */ - }; - if (result[(*reslen)-1]=10) {(*reslen)--;}; /* strip trailing LF */ - - ires=tcsetattr(STDIN_FILENO,TCSANOW,&atts); /* restore term. attributes */ - if (ires!=0) {perror("***\n");}; -} diff --git a/tecs/sys_lun.f b/tecs/sys_lun.f new file mode 100755 index 00000000..4b2f703e --- /dev/null +++ b/tecs/sys_lun.f @@ -0,0 +1,43 @@ +!!----------------------------------------------------------------------------- +!! + subroutine SYS_GET_LUN(LUN) !! +!! +!! allocate logical unit number +!! + integer LUN !! out + + logical*1 act(50:100)/51*.false./ + common /sys_lun/act + + integer l + + l=50 + do while (l .lt. 99 .and. act(l)) + l=l+1 + enddo + if (l .eq. 100) stop 'SYS_GET_LUN: no more luns available' + lun=l + act(l)=.true. + end + + +!!----------------------------------------------------------------------------- +!! + subroutine SYS_FREE_LUN(LUN) !! +!! +!! deallocate logical unit number +!! + integer LUN !! in + + logical*1 act(50:100)/51*.false./ + common /sys_lun/act + + if (lun .lt. 50 .or. lun .gt. 99) then + stop 'SYS_FREE_LUN: illegal lun' + endif + if (act(lun)) then + act(lun)=.false. + else + stop 'SYS_FREE_LUN: lun already free' + endif + end diff --git a/tecs/sys_open.f b/tecs/sys_open.f new file mode 100755 index 00000000..9ccf0a9d --- /dev/null +++ b/tecs/sys_open.f @@ -0,0 +1,55 @@ +!!----------------------------------------------------------------------------- +!! + subroutine SYS_OPEN(LUN, FILE, ACCESS, IOSTAT) !! +!! ============================================== +!! +!! ACCESS='r': open file for read +!! ACCESS='w': open or create file for write (on vms: new version, on unix: overwrite) +!! ACCESS='wo': overwrite existing file (do not make a new version) +!! ACCESS='wn': keep old file (on unix systems, a tilde '~' is appended to the name) +!! ACCESS='a': open or create file for append + + integer LUN !! (in) logical unit number + character FILE*(*) !! (in) filename + character ACCESS*(*) !! (in) access mode + integer IOSTAT !! (out) status + + character acc*2 + character amnt*128 + integer i,j,l,ios + real s + + call str_upcase(acc, access) + + if (acc .eq. 'R') then + open(lun, name=file, iostat=iostat, status='old') + if (iostat .eq. 0) RETURN ! success + l=0 + i=1 + do while (i .ne. 0) + l=l+i + i=index(file(l+1:),'/') + enddo + if (l .eq. 1) RETURN ! no directory given + open(lun, name=file(1:l-1), iostat=ios, status='old') + if (ios .eq. 0) then + close(lun) + RETURN ! directory exists -> already mounted + endif + call sys_getenv('dat_automount', amnt) + if (amnt .eq. ' ') RETURN + call sys_cmd(amnt) !try to mount + open(lun, name=file, iostat=iostat, status='old') + else if (acc .eq. 'W' .or. acc .eq. 'WO') then + open(lun, name=file, iostat=iostat, status='unknown') + else if (acc .eq. 'WN') then + ! rename to be done + open(lun, name=file, iostat=iostat, status='unknown') + else if (acc .eq. 'A') then + open(lun, name=file, iostat=iostat, status='unknown' + 1, access='append') + else + print *,'unknown access mode: ',acc + stop 'error in SYS_OPEN' + endif + end diff --git a/tecs/sys_open_alpha.f b/tecs/sys_open_alpha.f new file mode 100755 index 00000000..185db865 --- /dev/null +++ b/tecs/sys_open_alpha.f @@ -0,0 +1,54 @@ +!!----------------------------------------------------------------------------- +!! + subroutine SYS_OPEN(LUN, FILE, ACCESS, IOSTAT) !! +!! ============================================== +!! +!! ACCESS='r': open file for read +!! ACCESS='w': open or create file for write (on vms: new version, on unix: overwrite) +!! ACCESS='wo': overwrite existing file (do not make a new version) +!! ACCESS='wn': keep old file (on unix systems, a tilde '~' is appended to the name) +!! ACCESS='a': open or create file for append + + integer LUN !! (in) logical unit number + character FILE*(*) !! (in) filename + character ACCESS*(*) !! (in) access mode + integer IOSTAT !! (out) status + + character acc*2 + character amnt*128 + integer i,j,l,ios + + call str_upcase(acc, access) + + if (acc .eq. 'R') then + open(lun, name=file, iostat=iostat, status='old', readonly) + if (iostat .eq. 0) RETURN + l=0 + i=1 + do while (i .ne. 0) + l=l+i + i=index(file(l+1:),'/') + enddo + if (l .eq. 1) RETURN ! no directory given + open(lun, name=file(1:l-1), iostat=ios, status='old') + if (ios .eq. 0) then + close(lun) + RETURN ! directory exists -> already mounted + endif + call sys_getenv('dat_automount', amnt) + if (amnt .eq. ' ') RETURN + call sys_cmd(amnt) !try to mount + open(lun, name=file, iostat=iostat, status='old', readonly) + else if (acc .eq. 'W' .or. acc .eq. 'WO') then + open(lun, name=file, iostat=iostat, status='unknown') + else if (acc .eq. 'WN') then + ! rename to be done + open(lun, name=file, iostat=iostat, status='unknown') + else if (acc .eq. 'A') then + open(lun, name=file, iostat=iostat, status='unknown' + 1, access='append') + else + print *,'unknown access mode: ',acc + stop 'error in SYS_OPEN' + endif + end diff --git a/tecs/sys_rdline.c b/tecs/sys_rdline.c new file mode 100755 index 00000000..61a4af6d --- /dev/null +++ b/tecs/sys_rdline.c @@ -0,0 +1,37 @@ +#include +#include +#include +#include +#include "myc_str.h" +#include "myc_fortran.h" + +static char *last_line = NULL; + +char *readline (char *prompt); +void add_history(const char *line); + +void F_FUN(sys_rd_line)(F_CHAR(cmd), int *retlen, F_CHAR(prompt) F_CLEN(cmd) F_CLEN(prompt)) +{ + char *line_read; + char p0[64], p[64]; + + STR_TO_C(p0, prompt); + str_copy(p, "\n"); + str_append(p, p0); + if (last_line == NULL) { last_line =malloc(1); last_line[0] = '\0';}; + + line_read = readline(p); + + if (line_read) + { + if (*line_read && strcmp(last_line, line_read)!=0) + add_history (line_read); + free (last_line); + STR_TO_F(cmd, line_read); + *retlen=strlen(line_read); + last_line = line_read; + if (*retlen>F_LEN(cmd)) *retlen=F_LEN(cmd); + } else { + *retlen=-1; + } +} diff --git a/tecs/sys_unix.c b/tecs/sys_unix.c new file mode 100755 index 00000000..b660d47e --- /dev/null +++ b/tecs/sys_unix.c @@ -0,0 +1,133 @@ +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include "myc_tmp.h" +#include "myc_str.h" +#include "myc_fortran.h" + +void F_FUN(usleep)(int *usec) { usleep(*usec); } +int F_FUN(getppid)(void) { return getppid(); } +int lnblnk_(const char *str, int len); + +void F_FUN(sys_check_system)(F_CHAR(code) F_CLEN(code)) { +#if defined __alpha + STR_TO_F(code, "TRU64"); +#elif defined __GNUC__ + STR_TO_F(code, "GNU"); +#else + "sys_check_system: unsupported machine" +#endif +} + +void F_FUN(sys_realpath)(F_CHAR(rpath), int *reslen, + F_CHAR(path) F_CLEN(rpath) F_CLEN(path)) { + char p[PATH_MAX], rp[PATH_MAX], *pt; + + STR_TO_C(p, path); + pt=realpath(p, rp); + if (pt==NULL) str_copy(rp, p); + *reslen=strlen(rp); + STR_TO_F(rpath, rp); +} + +void F_FUN(sys_cmd)(char *command, int clen) { + int rc, l; + char *p; + + l = lnblnk_(command, clen); + p = malloc((unsigned) l+1); if( p == NULL ) return; + strncpy(p,command,l); p[l] = '\0'; + rc = system(p); + free(p); +} + +static struct termios atts; + +void F_FUN(sys_rd_tmo)(char *prompt, char *result, int *reslen, int p_len, int r_len) { + struct termios attr; + int ires, i, ntmo, chr; + + ires=tcgetattr(STDIN_FILENO,&attr); + atts=attr; /* save term. attr. */ + if (ires!=0) { + perror("error in terinq/tcgetattr "); + (*reslen)=0; + *result='\0'; + return; + } + attr.c_lflag &= ~(ICANON) & ~(ECHO); /* canonical mode off, echo off */ + attr.c_cc[VMIN]=0; + ires= tcsetattr(STDIN_FILENO,TCSANOW,&attr); + if (ires!=0) {perror("error in terinq/tcsetattr ");} + + do { chr=fgetc(stdin); } while (chr!=EOF); + + for (i=0; i0)) + { usleep(10000); /* wait 10 ms */ + chr=fgetc(stdin); + ntmo--; + }; + if (chr==EOF) break; + if (chr==10) {ntmo=10;} else {ntmo=100;}; /* wait 0.1 sec after LF, 1 sec else */ + }; + result[(*reslen)++]=(char)chr; + if (chr==24) {(*reslen)=0;}; /* ctrl-X purges buffer */ + }; + if (result[(*reslen)-1]==10) {(*reslen)--;}; /* strip trailing LF */ + + ires=tcsetattr(STDIN_FILENO,TCSANOW,&atts); /* restore term. attributes */ + clearerr(stdin); + if (ires!=0) { + perror("error in terinq/tcsetattr "); + } +} + +void F_FUN(sys_get_raw_key)(char *key, int *tmo, int k_len) +{ + struct termios attr; + int ires, ntmo, chr; + + ires=tcgetattr(STDIN_FILENO,&attr); + atts=attr; /* save term. attr. */ + if (ires!=0) {perror("***\n");} + attr.c_lflag &= ~(ICANON) & ~(ECHO); /* canonical mode off, echo off */ + attr.c_cc[VMIN]=0; + ires= tcsetattr(STDIN_FILENO,TCSANOW,&attr); + if (ires!=0) {perror("***\n");} + + ntmo=*tmo*100; + chr=fgetc(stdin); + if (chr==EOF) { + while ((chr==EOF) & (ntmo>0)) { + usleep(10000); /* wait 10 ms */ + chr=fgetc(stdin); + ntmo--; + } + } + if (chr==EOF) chr=0; + + *key=chr; + + ires=tcsetattr(STDIN_FILENO,TCSANOW,&atts); /* restore term. attributes */ + if (ires!=0) {perror("***\n");}; +} + diff --git a/tecs/sys_util.c b/tecs/sys_util.c deleted file mode 100644 index 1b684461..00000000 --- a/tecs/sys_util.c +++ /dev/null @@ -1,38 +0,0 @@ -#include -#include -#include "myc_str.h" -#include "sys_util.h" - -#if __VMS - -#include - -int sys_remove_file(F_CHAR(file), int file_len) { - char buf[128]; - STR_TO_C(buf, file); - return(delete(buf)); -} - -int sys_gmt_off() { - return(0); -} - -void sys_ctrl_init(void) { - static int init=1; - if (init) { - init=0; - DECC$CRTL_INIT(); - } -} - -#else - -#include - -int sys_remove_file_(F_CHAR(file), int file_len) { - char buf[128]; - STR_TO_C(buf, file); - return(unlink(buf)); -} - -#endif diff --git a/tecs/sys_wait.f b/tecs/sys_wait.f new file mode 100755 index 00000000..ee5bdeb1 --- /dev/null +++ b/tecs/sys_wait.f @@ -0,0 +1,20 @@ +!!----------------------------------------------------------------------------- +!! + subroutine SYS_WAIT(SECONDS) !! +!! ============================ +!! wait for SECONDS + real SECONDS !! resolution should be better than 0.1 sec. + + real tim, del + + tim=secnds(0.0) +1 del=seconds-secnds(tim) + if (del .ge. 0.999) then + call sleep(int(del)) + goto 1 + endif + if (del .gt. 0) then + call usleep(int(del*1E6)) + goto 1 + endif + end diff --git a/tecs/tecs_client.f b/tecs/tecs_client.f index 289b203f..3865bd4b 100644 --- a/tecs/tecs_client.f +++ b/tecs/tecs_client.f @@ -18,7 +18,7 @@ integer tecs_get_par, tecs_quit_server, tecs_set_par, tecs_watch_log integer tecs_get, tecs_rights, show_log, instr_host, tecs_start - call sys_load_env('cho') + call sys_loadenv call sys_getenv('CHOOSER_GDEV', line) if (line .ne. ' ') then call sys_setenv('PGPLOT_DEV', '/'//line) @@ -100,7 +100,7 @@ else call sys_get_lun(luns(idx)) endif - call sys_open_read(luns(idx), line(2:), i) + call sys_open(luns(idx), line(2:), 'R', i) if (i .ne. 0) then print *,'error opening ',line(2:) close(luns(idx)) diff --git a/tecs/tecs_for.f b/tecs/tecs_for.f index a07f3e32..3ad923d3 100644 --- a/tecs/tecs_for.f +++ b/tecs/tecs_for.f @@ -121,7 +121,7 @@ c if INIT exists, read it to get the port number and the start command startcmd=' ' - call sys_open_read(lun, init, ios) + call sys_open(lun, init, 'R', ios) if (ios .eq. 0) read (lun, *, iostat=ios) port if (ios .eq. 0) read (lun, *, iostat=ios) ! skip options line if (ios .eq. 0) read (lun, '(a)', iostat=ios) startcmd