home *** CD-ROM | disk | FTP | other *** search
/ ARM Club 3 / TheARMClub_PDCD3.iso / hensa / programming / tcl / tclsrc / c / WimpInit < prev    next >
Encoding:
Text File  |  1996-03-21  |  24.8 KB  |  1,019 lines
  1. /* Wimp commands for tcl */
  2. /* (c) C.T.Stretch */
  3. /* Sat,25 Jun 1994 */
  4.  
  5. #include "h.WInt"
  6. #include "h.osbyte"
  7. #include "h.taskwindow"
  8. #include "h.taskmanager"
  9. #include "h.RISCOSint"
  10.  
  11. /* Return value from catch if a send script returns an error */
  12.  
  13. #define TCL_REMOTEERROR 5
  14.  
  15. /* Message numbers for the Tcl w_send protocol */
  16.  
  17. #define message_TCL_SCRIPT  0x4cd40
  18. #define message_TCL_RESULT  0x4cd41
  19.  
  20.  
  21. /* The content of the messsages */
  22.  
  23. typedef struct wimp_message_tcl
  24. { char *source;
  25.   int len;
  26.   int resultcode;
  27. } wimp_message_tcl;
  28.  
  29. /* A list of these holds the scripts to be run on null events */
  30.  
  31. typedef struct nullscript
  32. { struct nullscript *next;
  33.   os_t when;
  34.   char *name;
  35.   char *script;
  36. } nullscript;
  37.  
  38. char progname[PNSIZE+1];        /* Program name passed to w_Init */
  39. Tcl_Interp *w_Interp;           /* The interpreter used by all w_ commands */
  40. wimp_block block;               /* Block used when calling wimp SWIs */
  41. char *substr[26];               /* Points to the % substitution strings*/
  42. char subbuffer[128];            /* Holds the values of % substitutions*/
  43. int current_ex,current_ey;      /* Mode information */
  44. wimp_t taskhandle;
  45.  
  46. static int wimpmessages[]={ message_DATA_LOAD,
  47.                             message_DATA_SAVE_ACK,
  48.                             message_MENU_WARNING,
  49.                             message_TASK_WINDOW_OUTPUT,
  50.                             message_TASK_WINDOW_EGO,
  51.                             message_TASK_WINDOW_MORIO,
  52.                             message_TASK_WINDOW_NEW_TASK,
  53.                             message_MODE_CHANGE,
  54.                             message_PALETTE_CHANGE,
  55.                             message_TCL_SCRIPT,
  56.                             message_TCL_RESULT,
  57.                             0 };
  58.  
  59.  
  60. static bits mask=wimp_MASK_NULL;
  61. static char *iconbar_clickproc,*iconbar_dragproc; /* tcl scripts */
  62. static int fontcount[256];                        /* usage count of fonts */
  63. static osspriteop_area *userarea;
  64. static nullscript* nullscripts;                   /* The list of nullscripts */
  65. static os_t nulltime;                             /* Time for next null event */
  66. /*
  67.  * msg --
  68.  *
  69.  *      Reports an error consisting of at most three strings in a wimp
  70.  *      error box. The strings are concatenated and truncated to 250
  71.  *      characters.
  72.  *
  73.  * Results:
  74.  *      None.
  75.  *
  76.  * Side effects:
  77.  *      None.
  78.  *
  79. */
  80.  
  81. void msg(char *s1,char *s2,char *s3)
  82. { os_error e;
  83.   int n=0;
  84.   e.errnum=0;
  85.   if(s1&&n<250) n+=sprintf(e.errmess,"%.*s",250-n,s1);
  86.   if(s2&&n<250) n+=sprintf(e.errmess+n,"%.*s",250-n,s2);
  87.   if(s2&&n<250) n+=sprintf(e.errmess+n,"%.*s",250-n,s3);
  88.   wimp_report_error(&e,wimp_ERROR_BOX_OK_ICON,progname);
  89. }
  90.  
  91. /*
  92.  *  wrong --
  93.  *
  94.  *      Appends one or two strings to the result
  95.  *
  96.  * Results:
  97.  *      Returns TCL_ERROR.
  98.  *
  99.  * Side effects:
  100.  *      Changes w_Interp->result
  101.  *
  102. */
  103.  
  104. int wrong(char *m1,char *m2)
  105. { Tcl_AppendResult(w_Interp,m1,m2,0);
  106.   return TCL_ERROR;
  107. }
  108.  
  109. /*
  110.  *  wrong0 --
  111.  *
  112.  *      Appends one or two strings to the result
  113.  *
  114.  * Results:
  115.  *      Returns 0.
  116.  *
  117.  * Side effects:
  118.  *      Changes w_Interp->result
  119.  *
  120. */
  121.  
  122. void *wrong0(char *m1,char *m2)
  123. { Tcl_AppendResult(w_Interp,m1,m2,0);
  124.   return 0;
  125. }
  126.  
  127. /*
  128.  *   spriteinfo  --
  129.  *      Finds the sprite area and size of a named sprite
  130.  *      in os units if os is TRUE, otherwise pixels.
  131.  *
  132.  * Results:
  133.  *      Copies the size into xx and yy.
  134.  *      Returns a sprite area pointer, 1 for the wimp area, 0 for not found.
  135.  *
  136.  * Side effects:
  137.  *      None.
  138.  *
  139.  */
  140.  
  141. osspriteop_area *spriteinfo(char *s,int *xx,int *yy,bool os)
  142. { int x=68,y=68,ex=0,ey=0;
  143.   os_mode m;
  144.   osspriteop_area *area=0;
  145.   if(userarea&&
  146.      !xosspriteop_read_sprite_size(
  147.            osspriteop_USER_AREA,userarea,(osspriteop_id)s,&x,&y,0,&m))
  148.                area=userarea;
  149.   else
  150.     if(!xwimpspriteop_read_sprite_size(s,&x,&y,0,&m)) area=(osspriteop_area*)1;
  151.   if(area&&os)
  152.   { os_read_mode_variable(m,os_MODEVAR_XEIG_FACTOR,&ex);
  153.     os_read_mode_variable(m,os_MODEVAR_YEIG_FACTOR,&ey);
  154.     *xx=x<<ex;
  155.     *yy=y<<ey;
  156.   }
  157.   else
  158.   { *xx=x;
  159.     *yy=y;
  160.   }
  161.   return area;
  162. }
  163.  
  164. /*
  165.  *   modeinfo  --
  166.  *      Reads mode iformation for the currrent mode.
  167.  *
  168.  * Results:
  169.  *      Sets current_ex and current_ey.
  170.  *
  171.  * Side effects:
  172.  *      None.
  173.  *
  174.  */
  175.  
  176. void modeinfo(void)
  177. { os_read_mode_variable(os_CURRENT_MODE,os_MODEVAR_XEIG_FACTOR,¤t_ex);
  178.   os_read_mode_variable(os_CURRENT_MODE,os_MODEVAR_YEIG_FACTOR,¤t_ey);
  179. }
  180.  
  181. /*
  182.  *  find_font --
  183.  *
  184.  *      Searches for a font. The name is given in the form
  185.  *      <font> = f<name>?@<length>? or F<fontname>?@<length>?
  186.  *      If the length is not given the size is taken from the
  187.  *      variable size in 16ths of a point.
  188.  *      If the font cannot be found Trinity.Medium is used at the
  189.  *      required size. If this cannot be found 0 is returned.
  190.  *      The boolean table t records the fonts used in a particular document
  191.  *      or drawfile, so that they can be lost when it is closed.
  192.  *      The array fontcount holds the number of such tables keeping
  193.  *      a particular font.
  194.  *
  195.  * Results:
  196.  *      Returns a font handle or 0.
  197.  *
  198.  * Side effects:
  199.  *      May open a font. If it does and t->used[handle] is zero it sets
  200.  *      t->used[handle] to 1 and increments fontcount[handle]. Otherwise
  201.  *      it loses the font again, so that the program only contributes
  202.  *      use 1 to the *fontlist table.
  203.  *
  204. */
  205.  
  206. font_f find_font(char *name,int size,font_table *t)
  207. { font_f fontf;
  208.   char *fname;
  209.   char *p=strchr(name,'@');
  210.   if(p)
  211.   { size=getsize(p+1,16*72);
  212.     *p=0;                    /* Terminates the font name temporarily */
  213.   }
  214.   switch(*name)
  215.   { case 'f':fname=Tcl_GetVar2(w_Interp,"fonts",name+1,TCL_GLOBAL_ONLY);
  216.              break;
  217.     case 'F':fname=name+1;
  218.              break;
  219.      default:fname=0;
  220.   }
  221.   if(!fname||xfont_find_font(fname,size,size,0,0,&fontf,0,0))
  222.   { if(xfont_find_font("Trinity.Medium",size,size,0,0,&fontf,0,0))
  223.     fontf=0;
  224.   }
  225.   if(fontf)
  226.   { if(t->used[fontf]) font_lose_font(fontf);
  227.     else
  228.     { t->used[fontf]=1;
  229.       if(fontcount[fontf]>0) font_lose_font(fontf);
  230.       fontcount[fontf]++;
  231.     }
  232.   }
  233.   if(p) *p='@';             /* Restores the size part of the name */
  234.   return fontf;
  235. }
  236.  
  237. /*
  238.  *  wimp_losefont --
  239.  *
  240.  *  Reduces the number of documents using a font.
  241.  *  If it becomes zero lose the font.
  242.  *
  243.  * Results:
  244.  *      None.
  245.  *
  246.  * Side effects:
  247.  *      Decrements fontcount[fontf]. May lose a font.
  248.  *
  249. */
  250.  
  251. static void wimp_losefont(font_f fontf)
  252. { fontcount[fontf]--;
  253.   if(fontcount[fontf]==0) font_lose_font(fontf);
  254. }
  255.  
  256. /*
  257.  * release_fonts  --
  258.  *
  259.  *      Lose all the fonts from a document.
  260.  *
  261.  * Results:
  262.  *      None.
  263.  *
  264.  * Side effects:
  265.  *      Decrements fontcounts. May lose fonts.
  266.  *      Does not zero ft->usage. It is called when the document is closed!
  267.  *
  268. */
  269.  
  270. extern void release_fonts(font_table *ft)
  271. { int i;
  272.   for(i=1;i<256;i++) if(ft->used[i]) wimp_losefont(i);
  273. }
  274.  
  275. /*
  276.  *  lose_all_fonts --
  277.  *
  278.  *  Closes all fonts when the program exits. (called by an atexit procedure)
  279.  *
  280.  * Results:
  281.  *      None.
  282.  *
  283.  * Side effects:
  284.  *      Closes all fonts.
  285.  *
  286. */
  287.  
  288. static void lose_all_fonts(void)
  289. { font_f i;
  290.   for(i=1;i<255;i++) if(fontcount[i]>0) font_lose_font(i);
  291. }
  292.  
  293. /*
  294.  * getcolour  --
  295.  *
  296.  *      Translates a textual description of a colour
  297.  *      "none" gives -1 (transparent)
  298.  *
  299.  * Results:
  300.  *      returns a colour (may have odd bottom byte if the text is incorrect)
  301.  *
  302.  * Side effects:
  303.  *      None.
  304.  *
  305. */
  306.  
  307. os_colour getcolour(char *s)
  308. { int r=0,g=0,b=0;
  309.   if(!strcmp(s,"none")) return os_COLOUR_TRANSPARENT;
  310.   if(*s<'0'||*s>'9')
  311.   { s=Tcl_GetVar2(w_Interp,"colours",s,TCL_GLOBAL_ONLY);
  312.     if(!s) return 0;
  313.   }
  314.   r=strtol(s,&s,10);
  315.   if(*s==':') g=strtol(++s,&s,10);
  316.   if(*s==':') b=strtol(++s,&s,10);
  317.   return r<<8|g<<16|b<<24;
  318. }
  319.  
  320.  
  321. /*
  322.  * getconstant  --
  323.  *
  324.  *      Reads a small integer constant, possiby given as a name.
  325.  *
  326.  * Results:
  327.  *      returns an integer (-1 for unknown)
  328.  *
  329.  * Side effects:
  330.  *      None.
  331.  *
  332. */
  333.  
  334. int getconstant(char *s)
  335. { switch(s[0])
  336.   { case 0:return 0;
  337.     case '0':case'1':case'2':case'3':return s[0]-'0';
  338.     case 'c':if(!strcmp(s,"close")) return 0;
  339.     case 'o':if(!strcmp(s,"off")) return 0;
  340.              if(!strcmp(s,"on")) return 1;
  341.              break;
  342.     case 'f':if(!strcmp(s,"failclose")) return 2;
  343.              if(!strcmp(s,"failshow")) return 3;
  344.              break;
  345.     case 's':if(!strcmp(s,"show")) return 1;
  346.              break;
  347.     case 'h':if(!strcmp(s,"hide")) return 2;
  348.              break;
  349.   }
  350.   return -1;
  351. }
  352.  
  353. /*
  354.  *  unlink --
  355.  *
  356.  *      Removes an object from a linked list.
  357.  *      The first field of the list structure must be the next pointer.
  358.  *      The list must be terminated with a zero pointer.
  359.  *      l points to a place holding a pointer to the first object in the list
  360.  *      v points to the object to be removed.
  361.  *
  362.  * Results:
  363.  *      None.
  364.  *
  365.  * Side effects:
  366.  *      Object removed from list - error if object not on list
  367.  *
  368. */
  369.  
  370. void unlink(void *l,void *v)
  371. { view *w;
  372.   for(w=l;w->next;w=w->next) if(w->next==v)
  373.   { w->next=((view*)v)->next;
  374.     return;
  375.   }
  376.   msg("unlink failed",0,0);
  377. }
  378.  
  379. /*
  380.  *  screensize --
  381.  *
  382.  *  Places the screen size in os units in x and y
  383.  *
  384.  * Results:
  385.  *      None.
  386.  *
  387.  * Side effects:
  388.  *      Changes the contents of x and y.
  389.  *
  390. */
  391.  
  392. void screensize(int *x,int *y)
  393. { int ib[]={ os_MODEVAR_XEIG_FACTOR,os_MODEVAR_YEIG_FACTOR,
  394.              os_MODEVAR_XWIND_LIMIT,os_MODEVAR_YWIND_LIMIT,-1
  395.            };
  396.   int ob[4];
  397.   os_read_vdu_variables((os_vdu_var_list*)ib,ob);
  398.   *x=(ob[2]+1)<<ob[0];
  399.   *y=(ob[3]+1)<<ob[1];
  400. }
  401.  
  402. /*
  403.  *  W_Error --
  404.  *
  405.  *      Sets the tcl global variable "where" to the input string.
  406.  *      Interpets the script pointed to by errorproc if there is
  407.  *      one. Otherwise exits.
  408.  *      If the errorproc script gives an error it displays a wimp error box
  409.  *      and then exits.
  410.  *
  411.  * Results:
  412.  *      None.
  413.  *
  414.  * Side effects:
  415.  *      May interpret a script or exit.
  416.  *
  417. */
  418.  
  419. void W_Error(char *where)
  420. { char *errorproc;
  421.   Tcl_SetVar2(w_Interp,"w_where",0,where,TCL_GLOBAL_ONLY);
  422.   errorproc=Tcl_GetVar2(w_Interp,"w_debug",0,TCL_GLOBAL_ONLY);
  423.   if(errorproc)
  424.   { if(Tcl_Eval(w_Interp,errorproc))
  425.     { msg("Quitting after error in w_debug:- ",w_Interp->result,0);
  426.       exit(0);
  427.     }
  428.   }
  429.   else exit(0);
  430. }
  431.  
  432. /*
  433.  *  checkEval  --
  434.  *
  435.  *      Performs % substitution on the tcl script "s". Then evaluates it.
  436.  *      calls W_Error with "where" passed on if it fails.
  437.  *
  438.  * Results:
  439.  *      None.
  440.  *
  441.  * Side effects:
  442.  *      Interprets a script
  443.  *
  444. */
  445.  
  446. void checkEval(char *s,char *where)
  447. { int code;
  448.   char *p,*q=0,*r;
  449.   int c;
  450.   int n=0,m=0;
  451.   for(p=s;*p;p++) if(*p=='%')     /* find the length of the sustituted string */
  452.   { c=*++p;
  453.     m++;
  454.     if(c==0) break;
  455.     c-='a';
  456.     if((c>=0&&c<26)&&substr[c]) n+=strlen(substr[c]);
  457.   }
  458.   if(m)                           /* copy s with substitution if needed */
  459.   { q=ckalloc(strlen(s)+1+n-m);   /* space for new s */
  460.     p=s;r=q;
  461.     for(p=s;*p;p++) if(*p=='%')
  462.     { c=p[1]-'a';
  463.       if(c>=0&&c<26)
  464.       { p++;
  465.         if(substr[c])
  466.         { n=strlen(substr[c]);
  467.           strcpy(r,substr[c]);
  468.           r+=n;
  469.         }
  470.       }
  471.     }
  472.     else *r++=*p;
  473.     *r=0;
  474.     s=q;
  475.   }                               /* script pointed to by s in either case */
  476.   code=Tcl_Eval(w_Interp,s);
  477.   if(code!=TCL_OK&&code!=TCL_RETURN) W_Error(where);
  478.   ckfree(q);                      /* q may be zero! */
  479. }
  480.  
  481. /*
  482.  *  scopy --
  483.  *
  484.  *  make a new string identical to the input
  485.  *
  486.  * Results:
  487.  *      Returns the new string
  488.  *
  489.  * Side effects:
  490.  *      Calls malloc.
  491.  *
  492. */
  493.  
  494. char *scopy(char *in)
  495. { char *out=ckalloc(strlen(in)+1);
  496.   strcpy(out,in);
  497.   return out;
  498. }
  499.  
  500. /*
  501.  *  gettime --
  502.  *
  503.  *      Reads a time in centiseconds from a string.
  504.  *
  505.  * Results:
  506.  *      Returns the time or -1 for a bad time.
  507.  *
  508.  * Side effects:
  509.  *      None.
  510.  *
  511. */
  512.  
  513. static os_t gettime(char *s)
  514. { double d;
  515.   if(!*s) return -1;
  516.   d=strtod(s,&s);
  517.   switch(*s)
  518.   { case 'c':break;
  519.     case 's':d=d*100;break;
  520.     case 'm':d=d*6000;break;
  521.     case 'h':d=d*360000;break;
  522.     case 'd':d=d*360000*24;break;
  523.     default:return -1;
  524.   }
  525.   return (os_t)d;
  526. }
  527.  
  528. /*
  529.  *  addnull --
  530.  *
  531.  *      Insert an entry in the null scripts list .
  532.  *
  533.  * Results:
  534.  *      None.
  535.  *
  536.  * Side effects:
  537.  *      Adjusts the nullscript list.
  538.  *
  539. */
  540.  
  541. static void freenull(nullscript *n)
  542. { ckfree(n->name);ckfree(n->script);
  543.   ckfree(n);
  544.   nulltime=(nullscripts)?(nullscripts->when):0;
  545.   if(!nullscripts) mask|=wimp_MASK_NULL;
  546. }
  547.  
  548.  
  549. static void addnull(os_t when,nullscript* n)
  550. { nullscript **s=(nullscript**)&nullscripts;
  551.   when+=os_read_monotonic_time();
  552.   for(;*s&&(*s)->when<=when;s=&((*s)->next));
  553.   n->next=*s;
  554.   *s=n;
  555.   n->when=when;
  556.   nulltime=(nullscripts)?(nullscripts->when):0;
  557. }
  558.  
  559. /*
  560.  *  null --
  561.  *
  562.  *      Called on a null event.
  563.  *
  564.  * Results:
  565.  *      None.
  566.  *
  567.  * Side effects:
  568.  *      Runs a script. Adjusts the nullscript list.
  569.  *
  570. */
  571.  
  572.  
  573. static void null(void)
  574. { if(nullscripts)
  575.   { nullscript *now=nullscripts;
  576.     os_t again;
  577.     nullscripts=now->next;
  578.     checkEval(now->script,now->name);
  579.     again=gettime(w_Interp->result);
  580.     if(again<0) freenull(now);
  581.     else addnull(again,now);
  582.   }
  583. }
  584.  
  585. /*
  586.  *  setbutton --
  587.  *
  588.  *      Sets the %b substitution string according to the state of the mouse
  589.  *      buttons and the modifier keys.
  590.  *
  591.  * Results:
  592.  *      None.
  593.  *
  594.  * Side effects:
  595.  *      Changes substr[1].
  596.  *
  597. */
  598.  
  599. void setbutton(void)
  600. { char *p=substr['b'-'a'];
  601.   int k=osbyte_read(osbyte_VAR_KEYBOARD_STATE);
  602.   if(block.pointer.buttons&wimp_CLICK_ADJUST) *p++='a';
  603.   if(block.pointer.buttons&wimp_CLICK_SELECT) *p++='s';
  604.   if(k&8) *p++='S';
  605.   if(k&64) *p++='C';
  606.   *p=0;
  607. }
  608.  
  609. /*
  610.  *  mouse --
  611.  *
  612.  *      Deals with mouse click events from wimp_poll.
  613.  *      Calls menu_open for a menu click.
  614.  *      Otherwise calls box_click. If this returns
  615.  *      FALSE it calls  diagram_click. If this also returns FALSE it
  616.  *      checks for an iconbar click, sets the %b substitution
  617.  *      and interprets the iconbar-click script.
  618.  *
  619.  * Results:
  620.  *      None.
  621.  *
  622.  * Side effects:
  623.  *      May interpret a script, or change substr[1] via setbutton.
  624.  *
  625. */
  626.  
  627. static void mouse(void)
  628. { if(block.pointer.buttons==wimp_CLICK_MENU) {menu_open();return;}
  629.   if(box_click()) return;
  630.   if(diagram_click()) return;
  631.   if(block.pointer.w==wimp_ICON_BAR)
  632.   { if(iconbar_clickproc)
  633.     { setbutton();
  634.       checkEval(iconbar_clickproc,"iconbar click");
  635.     }
  636.     return;
  637.   }
  638. }
  639.  
  640. /*
  641.  *  runs a script sent by another application with send  --
  642.  *
  643.  * Results:
  644.  *      None.
  645.  *
  646.  * Side effects:
  647.  *      Interprets a script
  648.  *
  649. */
  650.  
  651. static void runscript(wimp_message *m)
  652. { wimp_message_tcl *t=(wimp_message_tcl *)&(m->data.data_request);
  653.   wimp_t sender=m->sender;
  654.   int your_ref=m->my_ref;
  655.   char *s=ckalloc(t->len);
  656.   int code;
  657.   xwimp_transfer_block(sender,(byte*)(t->source),taskhandle,(byte*)s,t->len);
  658.   code=Tcl_GlobalEval(w_Interp,s);
  659.   ckfree(s);
  660.   m->size=32;
  661.   m->your_ref=your_ref;
  662.   m->action=message_TCL_RESULT;
  663.   t->source=w_Interp->result;
  664.   t->len=strlen(w_Interp->result)+1;
  665.   t->resultcode=code;
  666.   xwimp_send_message(wimp_USER_MESSAGE,m,sender);
  667. }
  668.  
  669. /*
  670.  *  message --
  671.  *      Deals with wimp message events from wimp poll, mainly by
  672.  *      calling the relevant procedure.
  673.  *      Handles drags to the iconbar by setting the w_file variable
  674.  *      and the %t substitution before evaluating the script.
  675.  *
  676.  * Results:
  677.  *      None.
  678.  *
  679.  * Side effects:
  680.  *      May interpret a script
  681.  *
  682. */
  683.  
  684. static void message(void)
  685. { wimp_message *m=&(block.message);
  686.   switch(m->action)
  687.   { case message_QUIT:exit(0);
  688.     case message_DATA_LOAD:
  689.     { wimp_message_data_request *dr=&(m->data.data_request);
  690.       if(dr->w==wimp_ICON_BAR)
  691.       { if(iconbar_dragproc);
  692.         { Tcl_SetVar2(w_Interp,"w_file",0,
  693.             (char*)(dr->file_types+1),TCL_GLOBAL_ONLY);
  694.           sprintf(substr['t'-'a'],"%d",dr->file_types[0]);
  695.           checkEval(iconbar_dragproc,"file drag");
  696.         }
  697.         break;
  698.       }
  699.       if(box_dragload(m)) break;
  700.     }
  701.     break;
  702.     case message_MENU_WARNING:
  703.     { wimp_message_menu_warning *mw=(void*)&(m->data.reserved);
  704.       box_submenu(mw->sub_menu,substr['w'-'a'],mw->pos.x,mw->pos.y);
  705.     }
  706.     break;
  707.     case message_DATA_SAVE_ACK:box_dragsave(m);break;
  708.     case message_TASK_WINDOW_OUTPUT:
  709.     case message_TASK_WINDOW_EGO:
  710.     case message_TASK_WINDOW_MORIO:
  711.     case message_TASK_WINDOW_NEW_TASK:task_message(m);break;
  712.     case message_MODE_CHANGE:diagram_modechange();break;
  713.     case message_PALETTE_CHANGE:diagram_palettechange();break;
  714.     case message_TCL_SCRIPT:runscript(m);break;
  715.  
  716.   }
  717. }
  718.  
  719. /*
  720.  *  W_Poll --
  721.  *      Calls wimp poll and calls a suitable  procedure to handle the
  722.  *      result.
  723.  *
  724.  * Results:
  725.  *      None.
  726.  *
  727.  * Side effects:
  728.  *      Various.
  729.  *
  730. */
  731.  
  732. void W_Poll(void)
  733. { int e;
  734.   if(!w_Interp) return;
  735.   for(;;)
  736.   { e=wimp_poll_idle(mask,&block,nulltime,0);
  737.     switch(e)
  738.     { case      wimp_NULL_REASON_CODE:null();break;
  739.       case wimp_REDRAW_WINDOW_REQUEST:if(document_redraw()) break;
  740.                                       if(diagram_redraw()) break;
  741.                                       break;
  742.         case wimp_OPEN_WINDOW_REQUEST:wimp_open_window(&block.open);break;
  743.        case wimp_CLOSE_WINDOW_REQUEST:if(diagram_close()) break;
  744.                                       if(document_close()) break;
  745.                                       if(box_close()) break;
  746.                                       wimp_close_window(block.close.w);
  747.                                       break;
  748.                 case wimp_MOUSE_CLICK:mouse();break;
  749.               case wimp_USER_DRAG_BOX:box_dragged();break;
  750.                 case wimp_KEY_PRESSED:if(box_key()) break;
  751.                                       wimp_process_key(block.key.c);
  752.                                       break;
  753.              case wimp_MENU_SELECTION:menu_select();break;
  754.                case wimp_USER_MESSAGE:
  755.       case wimp_USER_MESSAGE_RECORDED:message();break;
  756.     }
  757.   }
  758. }
  759.  
  760. /*
  761.  *  w_SendCmd --
  762.  *      Implements the w_send command
  763.  *
  764.  * Results:
  765.  *      A standard Tcl result.
  766.  *
  767.  * Side effects:
  768.  *
  769.  *
  770. */
  771.  
  772. static int w_SendCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
  773. { taskmanager_task tk;
  774.   wimp_message *m=&(block.message);
  775.   wimp_message_tcl *t=(wimp_message_tcl *)&(m->data.data_request);
  776.   int more=0;
  777.   int e;
  778.   if(argc!=3) return wrong(WNA,"w_send <taskname> <script>");
  779.   for(;;)
  780.   { xtaskmanager_enumerate_tasks(more,&tk,sizeof(taskmanager_task),&more,0);
  781.     if(!strcmp(tk.name,argv[1])) break;
  782.     if(more<0) return wrong("Can't find task named ",argv[1]);
  783.   }
  784.   m->size=28;
  785.   m->your_ref=0;
  786.   m->action=message_TCL_SCRIPT;
  787.   t->source=argv[2];
  788.   t->len=strlen(argv[2])+1;
  789.   xwimp_send_message(wimp_USER_MESSAGE,m,tk.task);
  790.   for(;;)
  791.   { e=wimp_poll(0x2173,&block,0);
  792.     if(e==wimp_USER_MESSAGE||e==wimp_USER_MESSAGE_RECORDED)
  793.     { m=&(block.message);
  794.       if(m->action==message_TCL_RESULT)
  795.       { wimp_message_tcl *t=(wimp_message_tcl *)&(m->data.data_request);
  796.         char *res=ckalloc(t->len);
  797.         xwimp_transfer_block(tk.task,(byte*)(t->source),taskhandle,
  798.         (byte*)res,t->len);
  799.         Tcl_SetResult(w_Interp,res,TCL_DYNAMIC);
  800.         if(t->resultcode==TCL_ERROR) return TCL_REMOTEERROR;
  801.         return t->resultcode;
  802.       }
  803.       message();continue;
  804.     }
  805.     switch(e)
  806.     {            case wimp_LOSE_CARET:/* Deliberate fall through */
  807.                  case wimp_GAIN_CARET:continue;
  808.         case wimp_OPEN_WINDOW_REQUEST:wimp_open_window(&block.open);break;
  809.        case wimp_CLOSE_WINDOW_REQUEST:if(diagram_close()) break;
  810.                                       if(document_close()) break;
  811.                                       if(box_close()) break;
  812.                                       wimp_close_window(block.close.w);
  813.                                       break;
  814.               case wimp_USER_DRAG_BOX:box_dragged();break;
  815.              case wimp_MENU_SELECTION:menu_select();break;
  816.     }
  817.     return wrong("No reply to send from ",argv[1]);
  818.   }
  819. }
  820.  
  821. /*
  822.  *  w_BarCmd --
  823.  *      Implements the w_bar command
  824.  *
  825.  * Results:
  826.  *      A standard Tcl result.
  827.  *
  828.  * Side effects:
  829.  *      May make a menu or set iconbar_clickproc or iconbar_dragproc.
  830.  *      Puts an icon on the bar.
  831.  *
  832. */
  833.  
  834. static int w_BarCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
  835. { wimp_icon_create ic;
  836.   int i;
  837.   int x=68,y=68,ex=0,ey=0;
  838.   os_mode m;
  839.   for(i=1;i<argc-1;i++)
  840.   { if(!strcmp(argv[i],"-menu"))
  841.     { tcl_menu *tm;
  842.       tm=menu_make(argv[++i],"bar");
  843.       if(!tm) return TCL_ERROR;
  844.       menu_bar(tm);
  845.       continue;
  846.     }
  847.     if(!strcmp(argv[i],"-click"))
  848.     { iconbar_clickproc=scopy(argv[++i]);
  849.       continue;
  850.     }
  851.     if(!strcmp(argv[i],"-drag"))
  852.     { iconbar_dragproc=scopy(argv[++i]);
  853.       continue;
  854.     }
  855.     return wrong("Unknown w_bar option: ",argv[i]);
  856.   }
  857.   sprintf(ic.icon.data.text,"!%s",progname);
  858.   if(!xwimpspriteop_read_sprite_size(ic.icon.data.text,&x,&y,0,&m))
  859.   { os_read_mode_variable(m,os_MODEVAR_XEIG_FACTOR,&ex);
  860.     os_read_mode_variable(m,os_MODEVAR_YEIG_FACTOR,&ey);
  861.   }
  862.   ic.w=wimp_ICON_BAR_RIGHT;
  863.   ic.icon.extent.x0=0;ic.icon.extent.y0=0;
  864.   ic.icon.extent.x1=x<<ex;ic.icon.extent.y1=y<<ey;
  865.   ic.icon.flags=wimp_ICON_SPRITE|
  866.   (wimp_BUTTON_CLICK<<wimp_ICON_BUTTON_TYPE_SHIFT);
  867.   wimp_create_icon(&ic);
  868.   return TCL_OK;
  869. }
  870.  
  871. /*
  872.  *  w_NullCmd --
  873.  *      Implements the w_null command
  874.  *
  875.  * Results:
  876.  *      A standard Tcl result.
  877.  *
  878.  * Side effects:
  879.  *      May insert or remove an entry in the nullscript list.
  880.  *      Can change the wimp mask.
  881.  *
  882. */
  883.  
  884. static int w_NullCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
  885. { if(argc<2||argc>4) return wrong(WNA,"w_null <name> ?<script> ?<time>??");
  886.   if(argc==2)
  887.   {  nullscript *w=(nullscript*)&nullscripts;
  888.      for(;w->next;w=w->next) if(!strcmp(w->next->name,argv[1]))
  889.      { nullscript *n=w->next;
  890.        w->next=(w->next)->next;
  891.        freenull(n);
  892.        break;
  893.      }
  894.   }
  895.   else
  896.   { os_t when=100;
  897.     nullscript *n;
  898.     if(argc==4) when=gettime(argv[3]);
  899.     if(when<0) return wrong("Bad time ",argv[3]);
  900.     n=ckalloc(sizeof(nullscript));
  901.     n->name=scopy(argv[1]);
  902.     n->script=scopy(argv[2]);
  903.     addnull(when,n);
  904.     mask&=~wimp_MASK_NULL;
  905.   }
  906.   return TCL_OK;
  907. }
  908.  
  909. /*
  910.  *  w_ErrorCmd --
  911.  *      Implements the w_error command.
  912.  *
  913.  * Results:
  914.  *      A standard tcl result.
  915.  *
  916.  * Side effects:
  917.  *      Displays an error box.
  918.  *
  919. */
  920.  
  921. static int w_ErrorCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
  922. { os_error e;
  923.   bits flags=0;
  924.   int i;
  925.   e.errnum=0;
  926.   if(argc>1) sprintf(e.errmess,"%.200s",argv[1]);
  927.   else e.errmess[0]=0;
  928.   for(i=2;i<argc;i++)
  929.   { if(!strcmp(argv[i],"-ok")) { flags|=wimp_ERROR_BOX_OK_ICON;continue;}
  930.     if(!strcmp(argv[i],"-cancel")) flags|=wimp_ERROR_BOX_CANCEL_ICON;
  931.   }
  932.   flags=wimp_report_error(&e,flags,progname);
  933.   sprintf(interp->result,"%u",2-flags);
  934.   return TCL_OK;
  935. }
  936.  
  937. /*
  938.  *  getsprites --
  939.  *      Load a sprite file into the user area
  940.  *
  941.  * Results:
  942.  *      None.
  943.  *
  944.  * Side effects:
  945.  *      None.
  946.  *
  947. */
  948.  
  949. static void getsprites(char *name)
  950. { char buf[256];
  951.   int n;
  952.   os_error *e;
  953.   sprintf(buf,"<%s$Dir>.%.200s",progname,name);
  954.   n=flen(buf);
  955.   if(n<0) { msg("Couldn't find ",buf,0); return;}
  956.   userarea=ckalloc(n+4);
  957.   userarea->size=n+4;
  958.   userarea->sprite_count=0;
  959.   userarea->first=sizeof(osspriteop_area);
  960.   userarea->used=sizeof(osspriteop_area);
  961.   e=xosspriteop_load_sprite_file(osspriteop_USER_AREA,userarea,buf);
  962.   if(e) wimp_report_error(e,wimp_ERROR_BOX_OK_ICON,progname);
  963. }
  964.  
  965. /*
  966.  *  w_InitCmd --
  967.  *      Implements the w_init command.
  968.  *
  969.  * Results:
  970.  *      A standard Tcl result.
  971.  *
  972.  * Side effects:
  973.  *      Sets w_Interp, progname,taskhandle.
  974.  *      Creates the other w_ commands.
  975.  *      Sets up the buffers to hold % substitutions.
  976.  *      Sets up exit handlers to lose fonts and kill any tasks still running.
  977.  *      Initialises variables w_debug and w_version
  978.  *
  979. */
  980.  
  981. int W_InitCmd(ClientData dummy,Tcl_Interp *interp,int argc,char **argv)
  982. { int version;
  983.   if(argc<2||argc>3) return wrong(WNA,"w_init name ?sprites?");
  984.   if(w_Interp)  return wrong("w_init may only be called once",0);
  985.   w_Interp=interp;
  986.   strncpy(progname,argv[1],PNSIZE);progname[PNSIZE]=0;
  987.   Tcl_InitHashTable(&documentTable,TCL_STRING_KEYS);
  988.   Tcl_InitHashTable(&diagramTable,TCL_STRING_KEYS);
  989.   Tcl_InitHashTable(&boxTable,TCL_STRING_KEYS);
  990.   Tcl_InitHashTable(&taskTable,TCL_STRING_KEYS);
  991.   Tcl_CreateCommand(interp,"w_bar",w_BarCmd,NULL,NULL);
  992.   Tcl_CreateCommand(interp,"w_error",w_ErrorCmd,NULL,NULL);
  993.   Tcl_CreateCommand(interp,"w_text",w_TextCmd,NULL,NULL);
  994.   Tcl_CreateCommand(interp,"w_draw",w_DrawCmd,NULL,NULL);
  995.   Tcl_CreateCommand(interp,"w_box",w_BoxCmd,NULL,NULL);
  996.   Tcl_CreateCommand(interp,"w_task",w_TaskCmd,NULL,NULL);
  997.   Tcl_CreateCommand(interp,"system",w_SystemCmd,NULL,NULL);
  998.   Tcl_CreateCommand(interp,"w_send",w_SendCmd,NULL,NULL);
  999.   Tcl_CreateCommand(interp,"w_null",w_NullCmd,NULL,NULL);
  1000.   Tcl_CreateCommand(interp,"w_info",w_InfoCmd,NULL,NULL);
  1001.   taskhandle=wimp_initialise(wimp_VERSION_RO3,progname,
  1002.     (wimp_message_list*)wimpmessages,&version);
  1003.   sprintf(interp->result,progname);
  1004.   substr['x'-'a']=subbuffer;
  1005.   substr['y'-'a']=subbuffer+12;
  1006.   substr['t'-'a']=subbuffer+24;
  1007.   substr['b'-'a']=subbuffer+36;
  1008.   atexit(lose_all_fonts);
  1009.   atexit(task_killall);
  1010.   modeinfo();
  1011.   Tcl_SetVar2(w_Interp,"w_debug",0,
  1012.     "if {![w_error \"Error in $w_where :- $errorInfo\" -ok -cancel]} exit",
  1013.     TCL_GLOBAL_ONLY);
  1014.   Tcl_SetVar2(w_Interp,"w_version",0,W_VERSION,TCL_GLOBAL_ONLY);
  1015.   if(argc==3) getsprites(argv[2]);
  1016.   return TCL_OK;
  1017. }
  1018.  
  1019.