home *** CD-ROM | disk | FTP | other *** search
- /* RISC OS commands for tcl */
- /* (c) C.T.Stretch */
- /* Sat,25 Jun 1994 */
-
-
- #include "tclInt.h"
- #undef UCHAR
- #include "h.tclRISCOS"
- #include "h.RISCOSint"
- #include "h.osfile"
- #include "h.osgbpb"
- #include "h.osfscontrol"
- #include "h.osword"
- #include "h.territory"
- #include <time.h>
-
- static Tcl_HashTable fileTable;
-
- static char *clk(ClientData d,Tcl_Interp *interp,char *n1,char *n2,int flags)
- { char buf[16];
- sprintf(buf,"%d",clock());
- Tcl_SetVar2(interp,n1,n2,buf,flags&TCL_GLOBAL_ONLY);
- return 0;
- }
-
- static char *rnd(ClientData d,Tcl_Interp *interp,char *n1,char *n2,int flags)
- { char buf[16];
- sprintf(buf,"%d",rand());
- Tcl_SetVar2(interp,n1,n2,buf,flags&TCL_GLOBAL_ONLY);
- return 0;
- }
-
- int typenumber(char *s)
- { int result;
- char *context=0;
- char buf[16];
- int used,i;
- char *q,*t=s;
- while(*t==' ') t++;
- result=strtol(t,&q,0);
- if(t!=q)
- { while(*q==' ')q++;
- if(*q==0) return result; /* it was a number */
- }
- if(!strcmp(t,"directory")) return 0x1000;
- if(!strcmp(t,"application")) return 0x2000;
- for(;;)
- { if(xos_read_var_val("File$Type_###",
- buf,16,(int)context,0,&used,(int*)&context,0)) break;
- if(!used) break;
- if(used<=8) for(i=0;i<used;i++)
- { if(s[i]==0) break;
- if(toupper(s[i])!=toupper(buf[i])) break;
- }
- if(i==used&&s[i]==0)
- return (int) strtol(context+10,0,16); /* Found a match */
- }
- return -1;
- }
-
- void RiscOS_Init(void)
- { int new;
- Tcl_InitHashTable(&fileTable,TCL_STRING_KEYS);
- Tcl_SetHashValue(Tcl_CreateHashEntry(&fileTable,"stdin",&new),stdin);
- Tcl_SetHashValue(Tcl_CreateHashEntry(&fileTable,"stdout",&new),stdout);
- Tcl_SetHashValue(Tcl_CreateHashEntry(&fileTable,"stderr",&new),stderr);
- }
-
- void RiscOS_InitVars(Tcl_Interp *ti)
- { Tcl_TraceVar(ti,"clock",TCL_TRACE_READS|TCL_GLOBAL_ONLY,clk,0);
- Tcl_TraceVar(ti,"rand",TCL_TRACE_READS|TCL_GLOBAL_ONLY,rnd,0);
- srand(time(0));
- Tcl_SetVar2(ti,"riscos_version",0,TCL_RISCOS_VERSION,TCL_GLOBAL_ONLY);
- }
-
- int flen(char* name)
- { int type,len;
- if(xosfile_read_no_path(name,&type,0,0,&len,0)) return -1;
- if(!type) return -1;
- return len;
- }
-
- static char *getfile(char* name)
- { int filelen;
- char *buf;
- filelen=flen(name);
- if(filelen<0) return 0;
- buf=ckalloc(filelen+1);
- if(!xosfile_load_stamped_no_path(name,(byte*)buf,0,0,0,0,0))
- { buf[filelen]=0;
- return buf;
- }
- ckfree(buf);
- return 0;
- }
-
- static int gettype(char *name)
- { bits ft;
- if(xosfile_read_stamped_no_path(name,0,0,0,0,0,&ft)) return 0;
- return (int)ft;
- }
-
- int Tcl_GetenvCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
- { char *s;
- if(argc!=2)
- { sprintf(interp->result,"wrong # args: should be getenv name");
- return TCL_ERROR;
- }
- s=getenv(argv[1]);
- if(s) Tcl_SetResult(interp,s,TCL_VOLATILE);
- return TCL_OK;
- }
-
- int Tcl_SystemCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
- { if(argc!=2)
- { sprintf(interp->result,"wrong # args: should be system string");
- return TCL_ERROR;
- }
- sprintf(interp->result,"%d",system(argv[1]));
- return TCL_OK;
- }
-
- int Tcl_FileCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
- { if(argc!=3)
- { Tcl_AppendResult(interp,"wrong # args: should be ", argv[0],
- " option name ",NULL);
- return TCL_ERROR;
- }
- if(!strcmp(argv[1],"size"))
- { int size=flen(argv[2]);
- if(size<0)
- { Tcl_AppendResult(interp, "couldn't read length of ",argv[2],NULL);
- return TCL_ERROR;
- }
- sprintf(interp->result,"%d",size);
- return TCL_OK;
- }
- if(!strcmp(argv[1],"type"))
- { sprintf(interp->result,"%d",gettype(argv[2]));
- return TCL_OK;
- }
- if(!strcmp(argv[1],"exists"))
- { sprintf(interp->result,"%d",osfile_read_no_path(argv[2],0,0,0,0));
- return TCL_OK;
- }
- if(!strcmp(argv[1],"access"))
- { bits attr;
- char *p;
- int i;
- if(!osfile_read_no_path(argv[2],0,0,0,&attr))
- { Tcl_AppendResult(interp, "can't read access detail of ", argv[2],0);
- }
- p=interp->result;
- for(i=0;i<8;i++) if(attr&(1<<i)) *p++=("rwxlRWXL")[i];
- *p=0;
- return TCL_OK;
- }
- if(!strcmp(argv[1],"full"))
- { int len;
- char *buf;
- xosfscontrol_canonicalise_path(argv[2],0,0,0,0,&len);
- buf=ckalloc(1-len);
- xosfscontrol_canonicalise_path(argv[2],buf,0,0,1-len,&len);
- if(len==1) Tcl_AppendResult(interp,buf,0);
- ckfree(buf);
- return TCL_OK;
- }
- Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": should be full, exists, time, access or size",
- (char *) NULL);
- return TCL_ERROR;
- }
-
- int Tcl_EvalFile(Tcl_Interp *interp, char *fileName)
- { char *script=getfile(fileName);
- Interp *iPtr=(Interp*) interp;
- char *oldScriptFile=iPtr->scriptFile;
- int result;
- iPtr->scriptFile=fileName;
- if(script==0)
- { Tcl_AppendResult(interp, "couldn't read file ", fileName,NULL);
- iPtr->scriptFile=oldScriptFile;
- return TCL_ERROR;
- }
- result=Tcl_Eval(interp,script);
- if (result == TCL_RETURN) result = TCL_OK;
- if (result == TCL_ERROR)
- { char msg[200];
- sprintf(msg,"\n (file \"%.150s\" line %d)",
- fileName,interp->errorLine);
- Tcl_AddErrorInfo(interp, msg);
- }
- ckfree(script);
- iPtr->scriptFile=oldScriptFile;
- return result;
- }
-
- int Tcl_SourceCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
- { if(argc!=2)
- { sprintf(interp->result,"wrong # args: should be source filename");
- return TCL_ERROR;
- }
- return Tcl_EvalFile(interp,argv[1]);
- }
-
- int Tcl_ExitCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
- { int value;
- if ((argc != 1) && (argc != 2))
- { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " ?returnCode?\"", (char *) NULL);
- return TCL_ERROR;
- }
- if (argc == 1) exit(0);
- if (Tcl_GetInt(interp, argv[1], &value) != TCL_OK) return TCL_ERROR;
- exit(value);
- return TCL_OK;
- }
-
- int Tcl_GlobCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
- { char *leaf,*dir,buf[256];
- int con=0,rc,ftype;
- osgbpb_info_stamped_list *il;
- il=(osgbpb_info_stamped_list*)&buf;
- if(argc<2||argc>3)
- { sprintf(interp->result,"wrong # args: should be glob filename ?type?");
- return TCL_ERROR;
- }
- leaf=strrchr(argv[1],'.');
- if(leaf) { dir=argv[1];*leaf++=0;}
- else {dir="";leaf=argv[1];}
- if(argc==3) ftype=typenumber(argv[2]);
- for(;;)
- { if(xosgbpb_dir_entries_info_stamped(dir,il,1,con,256,leaf,&rc,&con))
- { sprintf(interp->result,"bad directory read");
- return TCL_ERROR;
- }
- if(con==osgbpb_NO_MORE) break;
- if(argc==3&&il->info[0].file_type!=ftype) continue;
- if(rc) Tcl_AppendResult(interp," ",il->info[0].name,0);
- }
- return TCL_OK;
- }
-
- int Tcl_GetsCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
- { FILE *file;
- Tcl_HashEntry *entryPtr;
- #define BUFSIZE 256
- char buf[BUFSIZE+1];
- int done=0,flags=TCL_LEAVE_ERR_MSG,count=0,n;
- char *s;
- if(argc<2||argc>3) sprintf(interp->result,
- "wrong # args: should be gets fileId ?var?");
- entryPtr=Tcl_FindHashEntry(&fileTable,argv[1]);
- if(entryPtr) file=Tcl_GetHashValue(entryPtr);
- else
- { Tcl_AppendResult(interp,"bad file identifier ",argv[1],0);
- return TCL_ERROR;
- }
- while(!done)
- { s=fgets(buf,BUFSIZE,file);
- if(!s) break;
- n=strlen(buf);
- if(buf[n-1]=='\n')
- { n--;buf[n]=0;
- done=1;
- }
- count+=n;
- if(argc==2) Tcl_AppendResult(interp,buf,0);
- else
- { if(!Tcl_SetVar(interp,argv[2],buf,flags)) return TCL_ERROR;
- flags|=TCL_APPEND_VALUE;
- }
- }
- if(argc==3) sprintf(interp->result,"%d",count);
- return TCL_OK;
- }
-
-
- int Tcl_PutsCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
- { FILE *file;
- Tcl_HashEntry *entryPtr;
- char *string;
- int nonew=0;
- if(argc<2) goto badargs;
- if(!strcmp("-nonewline",argv[1]))
- { nonew=1;
- argv++;argc--;
- }
- switch(argc)
- { case 2:file=stdout;string=argv[1];break;
- case 3:entryPtr=Tcl_FindHashEntry(&fileTable,argv[1]);
- if(entryPtr)
- { file=Tcl_GetHashValue(entryPtr);
- string=argv[2];
- break;
- }
- Tcl_AppendResult(interp,"bad file identifier ",argv[1],0);
- return TCL_ERROR;
- default:goto badargs;
- }
- fputs(string,file);
- if(!nonew) fputc('\n',file);
- return TCL_OK;
- badargs:sprintf(interp->result,
- "bad arguments, should be puts ?-nonewline? ?fileId? string");
- return TCL_ERROR;
- }
-
- int Tcl_EofCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
- { Tcl_HashEntry *entryPtr;
- FILE *file;
- if(argc!=2)
- { sprintf(interp->result,"wrong # args: should be eof fileId");
- return TCL_ERROR;
- }
- entryPtr=Tcl_FindHashEntry(&fileTable,argv[1]);
- if(entryPtr)
- { file=Tcl_GetHashValue(entryPtr);
- sprintf(interp->result,(feof(file))?"1":"0");
- return TCL_OK;
- }
- Tcl_AppendResult(interp,"bad file identifier ",argv[1],0);
- return TCL_ERROR;
- }
-
- int Tcl_FlushCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
- { Tcl_HashEntry *entryPtr;
- FILE *file;
- if(argc!=2)
- { sprintf(interp->result,"wrong # args: should be flush fileId");
- return TCL_ERROR;
- }
- entryPtr=Tcl_FindHashEntry(&fileTable,argv[1]);
- if(entryPtr)
- { file=Tcl_GetHashValue(entryPtr);
- fflush(file);
- return TCL_OK;
- }
- Tcl_AppendResult(interp,"bad file identifier ",argv[1],0);
- return TCL_ERROR;
- }
-
- int Tcl_CloseCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
- { Tcl_HashEntry *entryPtr;
- FILE *file;
- if(argc!=2)
- { sprintf(interp->result,"wrong # args: should be close fileId");
- return TCL_ERROR;
- }
- entryPtr=Tcl_FindHashEntry(&fileTable,argv[1]);
- if(entryPtr)
- { file=Tcl_GetHashValue(entryPtr);
- fclose(file);
- Tcl_DeleteHashEntry(entryPtr);
- }
- return TCL_OK;
- }
-
- int Tcl_OpenCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
- { char *mode="rb";
- FILE *file;
- static int id=0;
- int new;
- Tcl_HashEntry *entryPtr;
- if(argc==3) mode=argv[2];
- else if(argc!=2)
- { sprintf(interp->result,"wrong # args: should be open name ?mode?");
- return TCL_ERROR;
- }
- file=fopen(argv[1],mode);
- if(!file)
- { Tcl_AppendResult(interp,"couldn't open \"",argv[1],
- "\": no such file or directory",NULL);
- return TCL_ERROR;
- }
- do
- { sprintf(interp->result,"f%d",id++);
- entryPtr=Tcl_CreateHashEntry(&fileTable,interp->result,&new);
- } while(!new);
- Tcl_SetHashValue(entryPtr,file);
- return TCL_OK;
- }
-
- int Tcl_DateCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
- { oswordreadclock_utc_block b;
- os_error *e;
- char *f="%24:%mi:%se %dy-%m3-%ce%yr";
- if(argc>2)
- { sprintf(interp->result,"wrong # args: should be date ?<format>?");
- return TCL_ERROR;
- }
- if(argc==2) f=argv[1];
- b.op=oswordreadclock_OP_UTC;
- xoswordreadclock_utc(&b);
- e=xterritory_convert_date_and_time(territory_CURRENT,
- &(b.utc),interp->result,199,f,0);
- if(e) {sprintf(interp->result,"Bad date format string");return TCL_ERROR;}
- return TCL_OK;
- }
-