linse/sics
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

unified some functions with fit. M.Z.

Browse Source
This commit is contained in:
cvs
2003-05-20 13:22:03 +00:00
parent b6c6868f24
commit 3231e3e630
23 changed files with 802 additions and 1190 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
tecs/make_gen
View File

@@ -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 \ SERV_OBJ =tecs.o coc_server.o tecs_lsc.o tecs_serial.o coc_logfile.o \
tecs_data.o $(LIBR_OBJ) tecs_data.o $(LIBR_OBJ)
CLI_OBJ =tecs_cli.o coc_client.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 \ TECLI_OBJ =tecs_client.o tecs_plot.o str.o instr_hosts.o \
$(TCLI_OBJ) $(TCLI_OBJ)

2
tecs/makefile_alpha
View File

@@ -19,7 +19,7 @@ FFLAGS = -u -g
ARFLAGS = cr ARFLAGS = cr
# -- system dependent routines # -- system dependent routines
SYS_FILE =sys_aunix SYS_OPEN = _alpha
# -- PGPLOT library # -- PGPLOT library
PGLIB =$(PGPLOT_DIR)/libpgplot.a -L/usr/X11R6/lib -lX11 PGLIB =$(PGPLOT_DIR)/libpgplot.a -L/usr/X11R6/lib -lX11

1
tecs/makefile_linux
View File

@@ -19,7 +19,6 @@ FFLAGS = -u -fvxt -g
ARFLAGS = cr ARFLAGS = cr
# -- system dependent routines # -- system dependent routines
SYS_FILE =sys_linux
# -- PGPLOT library # -- PGPLOT library
#PGPLOT =/afs/psi.ch/project/sinq/linux/pgplot/ #PGPLOT =/afs/psi.ch/project/sinq/linux/pgplot/

96
tecs/myc_tmp.c Normal file
View File

@@ -0,0 +1,96 @@
#include <unistd.h>
#include <stdio.h>
#include <stdlib.h>
#include <time.h>
#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();
}

9
tecs/myc_tmp.h Normal file
View File

@@ -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)
*/

369
tecs/sys_aunix.f
View File

@@ -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

203
tecs/sys_aunix_c.c
View File

@@ -1,203 +0,0 @@
#include <termios.h>
#include <sys/time.h>
#include <assert.h>
#include <unistd.h>
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#include <setjmp.h>
#include <signal.h>
#include <limits.h>
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; i<p_len; i++)
{ fputc(prompt[i], stderr);
};
ires=fflush(stdin);
ires=fflush(stderr);
*reslen=0;
if (prompt[0]=='\0') { ntmo=10; }
else { ntmo=200; }; /* wait 2 sec. for the first char */
while (*reslen<r_len)
{ chr=fgetc(stdin);
if (chr==EOF)
{ while ((chr==EOF) & (ntmo>0))
{ 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");};
}

23
tecs/sys_cmdpar.f Executable file
View File

@@ -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

18
tecs/sys_date.f Executable file
View File

@@ -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

179
tecs/sys_env.c Executable file
View File

@@ -0,0 +1,179 @@
#include <sys/stat.h>
#include <sys/types.h>
#include <termios.h>
#include <unistd.h>
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#include <time.h>
#include <utmp.h>
#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;
}

52
tecs/sys_get_key.f Normal file
View File

@@ -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

75
tecs/sys_getenv.f Executable file
View File

@@ -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

374
tecs/sys_linux.f
View File

@@ -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

200
tecs/sys_linux_c.c
View File

@@ -1,200 +0,0 @@
#include <termios.h>
#include <sys/time.h>
#include <assert.h>
#include <unistd.h>
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#include <setjmp.h>
#include <signal.h>
#include <limits.h>
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; i<p_len; i++)
{ fputc(prompt[i], stderr);
};
ires=fflush(stdin);
ires=fflush(stderr);
*reslen=0;
if (prompt[0]=='\0') { ntmo=10; }
else { ntmo=200; }; /* wait 2 sec. for the first char */
while (*reslen<r_len)
{ chr=fgetc(stdin);
if (chr==EOF)
{ while ((chr==EOF) & (ntmo>0))
{ 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");};
}

43
tecs/sys_lun.f Executable file
View File

@@ -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

55
tecs/sys_open.f Executable file
View File

@@ -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

54
tecs/sys_open_alpha.f Executable file
View File

@@ -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

37
tecs/sys_rdline.c Executable file
View File

@@ -0,0 +1,37 @@
#include <assert.h>
#include <unistd.h>
#include <string.h>
#include <stdlib.h>
#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;
}
}

133
tecs/sys_unix.c Executable file
View File

@@ -0,0 +1,133 @@
#include <sys/stat.h>
#include <sys/types.h>
#include <termios.h>
#include <unistd.h>
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#include <time.h>
#include <utmp.h>
#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; i<p_len; i++)
{ fputc(prompt[i], stderr);
};
ires=fflush(stdin);
ires=fflush(stderr);
*reslen=0;
if (prompt[0]=='\0') { ntmo=10; }
else { ntmo=200; }; /* wait 2 sec. for the first char */
while (*reslen<r_len)
{ chr=fgetc(stdin);
if (chr==EOF)
{ while ((chr==EOF) & (ntmo>0))
{ 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");};
}

38
tecs/sys_util.c
View File

@@ -1,38 +0,0 @@
#include <signal.h>
#include <stdlib.h>
#include "myc_str.h"
#include "sys_util.h"
#if __VMS
#include <unixio.h>
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 <unistd.h>
int sys_remove_file_(F_CHAR(file), int file_len) {
char buf[128];
STR_TO_C(buf, file);
return(unlink(buf));
}
#endif

20
tecs/sys_wait.f Executable file
View File

@@ -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

4
tecs/tecs_client.f
View File

@@ -18,7 +18,7 @@
integer tecs_get_par, tecs_quit_server, tecs_set_par, tecs_watch_log integer tecs_get_par, tecs_quit_server, tecs_set_par, tecs_watch_log
integer tecs_get, tecs_rights, show_log, instr_host, tecs_start 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) call sys_getenv('CHOOSER_GDEV', line)
if (line .ne. ' ') then if (line .ne. ' ') then
call sys_setenv('PGPLOT_DEV', '/'//line) call sys_setenv('PGPLOT_DEV', '/'//line)
@@ -100,7 +100,7 @@
else else
call sys_get_lun(luns(idx)) call sys_get_lun(luns(idx))
endif endif
call sys_open_read(luns(idx), line(2:), i) call sys_open(luns(idx), line(2:), 'R', i)
if (i .ne. 0) then if (i .ne. 0) then
print *,'error opening ',line(2:) print *,'error opening ',line(2:)
close(luns(idx)) close(luns(idx))

2
tecs/tecs_for.f
View File

@@ -121,7 +121,7 @@ c if INIT exists, read it to get the port number and the start command
startcmd=' ' 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) port
if (ios .eq. 0) read (lun, *, iostat=ios) ! skip options line if (ios .eq. 0) read (lun, *, iostat=ios) ! skip options line
if (ios .eq. 0) read (lun, '(a)', iostat=ios) startcmd if (ios .eq. 0) read (lun, '(a)', iostat=ios) startcmd