home *** CD-ROM | disk | FTP | other *** search
/ ARM Club 3 / TheARMClub_PDCD3.iso / hensa / programming / tcl / tclsrc / c / tclRISCOS < prev    next >
Text File  |  1996-02-07  |  11KB  |  400 lines
  1. /* RISC OS commands for tcl */
  2. /* (c) C.T.Stretch */
  3. /* Sat,25 Jun 1994 */
  4.  
  5.  
  6. #include "tclInt.h"
  7. #undef UCHAR
  8. #include "h.tclRISCOS"
  9. #include "h.RISCOSint"
  10. #include "h.osfile"
  11. #include "h.osgbpb"
  12. #include "h.osfscontrol"
  13. #include "h.osword"
  14. #include "h.territory"
  15. #include <time.h>
  16.  
  17. static Tcl_HashTable fileTable;
  18.  
  19. static char *clk(ClientData d,Tcl_Interp *interp,char *n1,char *n2,int flags)
  20. { char buf[16];
  21.   sprintf(buf,"%d",clock());
  22.   Tcl_SetVar2(interp,n1,n2,buf,flags&TCL_GLOBAL_ONLY);
  23.   return 0;
  24. }
  25.  
  26. static char *rnd(ClientData d,Tcl_Interp *interp,char *n1,char *n2,int flags)
  27. { char buf[16];
  28.   sprintf(buf,"%d",rand());
  29.   Tcl_SetVar2(interp,n1,n2,buf,flags&TCL_GLOBAL_ONLY);
  30.   return 0;
  31. }
  32.  
  33. int typenumber(char *s)
  34. { int result;
  35.   char *context=0;
  36.   char buf[16];
  37.   int used,i;
  38.   char *q,*t=s;
  39.   while(*t==' ') t++;
  40.   result=strtol(t,&q,0);
  41.   if(t!=q)
  42.   { while(*q==' ')q++;
  43.     if(*q==0) return result; /* it was a number */
  44.   }
  45.   if(!strcmp(t,"directory")) return 0x1000;
  46.   if(!strcmp(t,"application")) return 0x2000;
  47.   for(;;)
  48.   { if(xos_read_var_val("File$Type_###",
  49.                  buf,16,(int)context,0,&used,(int*)&context,0)) break;
  50.     if(!used) break;
  51.     if(used<=8) for(i=0;i<used;i++)
  52.     { if(s[i]==0) break;
  53.       if(toupper(s[i])!=toupper(buf[i])) break;
  54.     }
  55.     if(i==used&&s[i]==0)
  56.         return (int) strtol(context+10,0,16); /* Found a match */
  57.   }
  58.   return -1;
  59. }
  60.  
  61. void RiscOS_Init(void)
  62. { int new;
  63.   Tcl_InitHashTable(&fileTable,TCL_STRING_KEYS);
  64.   Tcl_SetHashValue(Tcl_CreateHashEntry(&fileTable,"stdin",&new),stdin);
  65.   Tcl_SetHashValue(Tcl_CreateHashEntry(&fileTable,"stdout",&new),stdout);
  66.   Tcl_SetHashValue(Tcl_CreateHashEntry(&fileTable,"stderr",&new),stderr);
  67. }
  68.  
  69. void RiscOS_InitVars(Tcl_Interp *ti)
  70. { Tcl_TraceVar(ti,"clock",TCL_TRACE_READS|TCL_GLOBAL_ONLY,clk,0);
  71.   Tcl_TraceVar(ti,"rand",TCL_TRACE_READS|TCL_GLOBAL_ONLY,rnd,0);
  72.   srand(time(0));
  73.   Tcl_SetVar2(ti,"riscos_version",0,TCL_RISCOS_VERSION,TCL_GLOBAL_ONLY);
  74. }
  75.  
  76. int flen(char* name)
  77. { int type,len;
  78.   if(xosfile_read_no_path(name,&type,0,0,&len,0)) return -1;
  79.   if(!type) return -1;
  80.   return len;
  81. }
  82.  
  83. static char *getfile(char* name)
  84. { int filelen;
  85.   char *buf;
  86.   filelen=flen(name);
  87.   if(filelen<0) return 0;
  88.   buf=ckalloc(filelen+1);
  89.   if(!xosfile_load_stamped_no_path(name,(byte*)buf,0,0,0,0,0))
  90.   { buf[filelen]=0;
  91.     return buf;
  92.   }
  93.   ckfree(buf);
  94.   return 0;
  95. }
  96.  
  97. static int gettype(char *name)
  98. { bits ft;
  99.   if(xosfile_read_stamped_no_path(name,0,0,0,0,0,&ft)) return 0;
  100.   return (int)ft;
  101. }
  102.  
  103. int Tcl_GetenvCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
  104. { char *s;
  105.   if(argc!=2)
  106.   { sprintf(interp->result,"wrong # args: should be getenv name");
  107.     return TCL_ERROR;
  108.   }
  109.   s=getenv(argv[1]);
  110.   if(s) Tcl_SetResult(interp,s,TCL_VOLATILE);
  111.   return TCL_OK;
  112. }
  113.  
  114. int Tcl_SystemCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
  115. { if(argc!=2)
  116.   { sprintf(interp->result,"wrong # args: should be system string");
  117.     return TCL_ERROR;
  118.   }
  119.   sprintf(interp->result,"%d",system(argv[1]));
  120.   return TCL_OK;
  121. }
  122.  
  123. int Tcl_FileCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
  124. { if(argc!=3)
  125.   { Tcl_AppendResult(interp,"wrong # args: should be ", argv[0],
  126.        " option name ",NULL);
  127.     return TCL_ERROR;
  128.   }
  129.   if(!strcmp(argv[1],"size"))
  130.   { int size=flen(argv[2]);
  131.     if(size<0)
  132.     { Tcl_AppendResult(interp, "couldn't read length of ",argv[2],NULL);
  133.       return TCL_ERROR;
  134.     }
  135.     sprintf(interp->result,"%d",size);
  136.     return TCL_OK;
  137.   }
  138.   if(!strcmp(argv[1],"type"))
  139.   { sprintf(interp->result,"%d",gettype(argv[2]));
  140.     return TCL_OK;
  141.   }
  142.   if(!strcmp(argv[1],"exists"))
  143.   { sprintf(interp->result,"%d",osfile_read_no_path(argv[2],0,0,0,0));
  144.     return TCL_OK;
  145.   }
  146.   if(!strcmp(argv[1],"access"))
  147.   { bits attr;
  148.     char *p;
  149.     int i;
  150.     if(!osfile_read_no_path(argv[2],0,0,0,&attr))
  151.     { Tcl_AppendResult(interp, "can't read access detail of ", argv[2],0);
  152.     }
  153.     p=interp->result;
  154.     for(i=0;i<8;i++) if(attr&(1<<i)) *p++=("rwxlRWXL")[i];
  155.     *p=0;
  156.     return TCL_OK;
  157.   }
  158.   if(!strcmp(argv[1],"full"))
  159.   { int len;
  160.     char *buf;
  161.     xosfscontrol_canonicalise_path(argv[2],0,0,0,0,&len);
  162.     buf=ckalloc(1-len);
  163.     xosfscontrol_canonicalise_path(argv[2],buf,0,0,1-len,&len);
  164.     if(len==1) Tcl_AppendResult(interp,buf,0);
  165.     ckfree(buf);
  166.     return TCL_OK;
  167.   }
  168.   Tcl_AppendResult(interp, "bad option \"", argv[1],
  169.   "\": should be full, exists, time, access or size",
  170.   (char *) NULL);
  171.   return TCL_ERROR;
  172. }
  173.  
  174. int Tcl_EvalFile(Tcl_Interp *interp, char *fileName)
  175. { char *script=getfile(fileName);
  176.   Interp *iPtr=(Interp*) interp;
  177.   char *oldScriptFile=iPtr->scriptFile;
  178.   int result;
  179.   iPtr->scriptFile=fileName;
  180.   if(script==0)
  181.   { Tcl_AppendResult(interp, "couldn't read file ", fileName,NULL);
  182.     iPtr->scriptFile=oldScriptFile;
  183.     return TCL_ERROR;
  184.   }
  185.   result=Tcl_Eval(interp,script);
  186.   if (result == TCL_RETURN) result = TCL_OK;
  187.   if (result == TCL_ERROR)
  188.   { char msg[200];
  189.     sprintf(msg,"\n    (file \"%.150s\" line %d)",
  190.        fileName,interp->errorLine);
  191.     Tcl_AddErrorInfo(interp, msg);
  192.   }
  193.   ckfree(script);
  194.   iPtr->scriptFile=oldScriptFile;
  195.   return result;
  196. }
  197.  
  198. int Tcl_SourceCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
  199. { if(argc!=2)
  200.   { sprintf(interp->result,"wrong # args: should be source filename");
  201.     return TCL_ERROR;
  202.   }
  203.   return Tcl_EvalFile(interp,argv[1]);
  204. }
  205.  
  206. int Tcl_ExitCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
  207. { int value;
  208.   if ((argc != 1) && (argc != 2))
  209.   { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  210.        " ?returnCode?\"", (char *) NULL);
  211.     return TCL_ERROR;
  212.   }
  213.   if (argc == 1) exit(0);
  214.   if (Tcl_GetInt(interp, argv[1], &value) != TCL_OK) return TCL_ERROR;
  215.   exit(value);
  216.   return TCL_OK;
  217. }
  218.  
  219. int Tcl_GlobCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
  220. {  char *leaf,*dir,buf[256];
  221.    int con=0,rc,ftype;
  222.    osgbpb_info_stamped_list *il;
  223.    il=(osgbpb_info_stamped_list*)&buf;
  224.    if(argc<2||argc>3)
  225.    { sprintf(interp->result,"wrong # args: should be glob filename ?type?");
  226.      return TCL_ERROR;
  227.    }
  228.    leaf=strrchr(argv[1],'.');
  229.    if(leaf) { dir=argv[1];*leaf++=0;}
  230.    else {dir="";leaf=argv[1];}
  231.    if(argc==3) ftype=typenumber(argv[2]);
  232.    for(;;)
  233.    { if(xosgbpb_dir_entries_info_stamped(dir,il,1,con,256,leaf,&rc,&con))
  234.      { sprintf(interp->result,"bad directory read");
  235.        return TCL_ERROR;
  236.      }
  237.      if(con==osgbpb_NO_MORE) break;
  238.      if(argc==3&&il->info[0].file_type!=ftype) continue;
  239.      if(rc) Tcl_AppendResult(interp," ",il->info[0].name,0);
  240.    }
  241.    return TCL_OK;
  242. }
  243.  
  244. int Tcl_GetsCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
  245. { FILE *file;
  246.   Tcl_HashEntry *entryPtr;
  247. #define BUFSIZE 256
  248.   char buf[BUFSIZE+1];
  249.   int done=0,flags=TCL_LEAVE_ERR_MSG,count=0,n;
  250.   char *s;
  251.   if(argc<2||argc>3) sprintf(interp->result,
  252.      "wrong # args: should be gets fileId ?var?");
  253.   entryPtr=Tcl_FindHashEntry(&fileTable,argv[1]);
  254.   if(entryPtr) file=Tcl_GetHashValue(entryPtr);
  255.   else
  256.   { Tcl_AppendResult(interp,"bad file identifier ",argv[1],0);
  257.     return TCL_ERROR;
  258.   }
  259.   while(!done)
  260.   { s=fgets(buf,BUFSIZE,file);
  261.     if(!s) break;
  262.     n=strlen(buf);
  263.     if(buf[n-1]=='\n')
  264.     { n--;buf[n]=0;
  265.       done=1;
  266.     }
  267.     count+=n;
  268.     if(argc==2) Tcl_AppendResult(interp,buf,0);
  269.     else
  270.     { if(!Tcl_SetVar(interp,argv[2],buf,flags)) return TCL_ERROR;
  271.       flags|=TCL_APPEND_VALUE;
  272.     }
  273.   }
  274.   if(argc==3) sprintf(interp->result,"%d",count);
  275.   return TCL_OK;
  276. }
  277.  
  278.  
  279. int Tcl_PutsCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
  280. { FILE *file;
  281.   Tcl_HashEntry *entryPtr;
  282.   char *string;
  283.   int nonew=0;
  284.   if(argc<2) goto badargs;
  285.   if(!strcmp("-nonewline",argv[1]))
  286.   { nonew=1;
  287.     argv++;argc--;
  288.   }
  289.   switch(argc)
  290.   { case 2:file=stdout;string=argv[1];break;
  291.     case 3:entryPtr=Tcl_FindHashEntry(&fileTable,argv[1]);
  292.            if(entryPtr)
  293.            { file=Tcl_GetHashValue(entryPtr);
  294.              string=argv[2];
  295.              break;
  296.            }
  297.            Tcl_AppendResult(interp,"bad file identifier ",argv[1],0);
  298.            return TCL_ERROR;
  299.     default:goto badargs;
  300.   }
  301.   fputs(string,file);
  302.   if(!nonew) fputc('\n',file);
  303.   return TCL_OK;
  304.   badargs:sprintf(interp->result,
  305.     "bad arguments, should be puts ?-nonewline? ?fileId? string");
  306.   return TCL_ERROR;
  307. }
  308.  
  309. int Tcl_EofCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
  310. { Tcl_HashEntry *entryPtr;
  311.   FILE *file;
  312.   if(argc!=2)
  313.   { sprintf(interp->result,"wrong # args: should be eof fileId");
  314.     return TCL_ERROR;
  315.   }
  316.   entryPtr=Tcl_FindHashEntry(&fileTable,argv[1]);
  317.   if(entryPtr)
  318.   { file=Tcl_GetHashValue(entryPtr);
  319.     sprintf(interp->result,(feof(file))?"1":"0");
  320.     return TCL_OK;
  321.   }
  322.   Tcl_AppendResult(interp,"bad file identifier ",argv[1],0);
  323.   return TCL_ERROR;
  324. }
  325.  
  326. int Tcl_FlushCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
  327. { Tcl_HashEntry *entryPtr;
  328.   FILE *file;
  329.   if(argc!=2)
  330.   { sprintf(interp->result,"wrong # args: should be flush fileId");
  331.     return TCL_ERROR;
  332.   }
  333.   entryPtr=Tcl_FindHashEntry(&fileTable,argv[1]);
  334.   if(entryPtr)
  335.   { file=Tcl_GetHashValue(entryPtr);
  336.     fflush(file);
  337.     return TCL_OK;
  338.   }
  339.   Tcl_AppendResult(interp,"bad file identifier ",argv[1],0);
  340.   return TCL_ERROR;
  341. }
  342.  
  343. int Tcl_CloseCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
  344. { Tcl_HashEntry *entryPtr;
  345.   FILE *file;
  346.   if(argc!=2)
  347.   { sprintf(interp->result,"wrong # args: should be close fileId");
  348.     return TCL_ERROR;
  349.   }
  350.   entryPtr=Tcl_FindHashEntry(&fileTable,argv[1]);
  351.   if(entryPtr)
  352.   { file=Tcl_GetHashValue(entryPtr);
  353.     fclose(file);
  354.     Tcl_DeleteHashEntry(entryPtr);
  355.   }
  356.   return TCL_OK;
  357. }
  358.  
  359. int Tcl_OpenCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
  360. { char *mode="rb";
  361.   FILE *file;
  362.   static int id=0;
  363.   int new;
  364.   Tcl_HashEntry *entryPtr;
  365.   if(argc==3) mode=argv[2];
  366.   else if(argc!=2)
  367.   { sprintf(interp->result,"wrong # args: should be open name ?mode?");
  368.     return TCL_ERROR;
  369.   }
  370.   file=fopen(argv[1],mode);
  371.   if(!file)
  372.   { Tcl_AppendResult(interp,"couldn't open \"",argv[1],
  373.                      "\": no such file or directory",NULL);
  374.     return TCL_ERROR;
  375.   }
  376.   do
  377.   { sprintf(interp->result,"f%d",id++);
  378.     entryPtr=Tcl_CreateHashEntry(&fileTable,interp->result,&new);
  379.   } while(!new);
  380.   Tcl_SetHashValue(entryPtr,file);
  381.   return TCL_OK;
  382. }
  383.  
  384. int Tcl_DateCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
  385. { oswordreadclock_utc_block b;
  386.   os_error *e;
  387.   char *f="%24:%mi:%se %dy-%m3-%ce%yr";
  388.   if(argc>2)
  389.   { sprintf(interp->result,"wrong # args: should be date ?<format>?");
  390.     return TCL_ERROR;
  391.   }
  392.   if(argc==2) f=argv[1];
  393.   b.op=oswordreadclock_OP_UTC;
  394.   xoswordreadclock_utc(&b);
  395.   e=xterritory_convert_date_and_time(territory_CURRENT,
  396.     &(b.utc),interp->result,199,f,0);
  397.   if(e) {sprintf(interp->result,"Bad date format string");return TCL_ERROR;}
  398.   return TCL_OK;
  399. }
  400.