
MODULE ForceMuchMore;

  (* $IFNOT SmallData *)

  IMPORT
    ol := OberonLib,
    d  := Dos,
    e  := Exec,
    es := ExecSupport,
    ic := Icon,
    wb := Workbench,
    SYS:= SYSTEM;

  TYPE
    GetIconProc = PROCEDURE (name{8}:e.STRPTR; icon{9}:wb.DiskObjectPtr; freelist{10}:e.APTR): LONGINT;

  CONST
    version = "\o$VER: forcemuchmore 1.0 (11.3.95)";
    portName = "ForceMuchMore";

  VAR
    oldProc   : GetIconProc;
    sig       : LONGSET;
    base      : e.APTR;
    i         : LONGINT;
    icon      : wb.DiskObjectPtr;
    replace   : e.STRING;
    tools     : e.STRING;
    tt        : e.LSTRPTR;
    wbm       : wb.WBStartupPtr;
    olddir    : d.FileLockPtr;
    port      : e.MsgPortPtr;
    halt      : BOOLEAN;


  (* $StackChk- $RangeChk- $NilChk- $OvflChk- *)

  PROCEDURE StrChk (s1,s2: e.LSTRPTR): BOOLEAN;
    VAR i,j : LONGINT;
        ch  : CHAR;
  BEGIN
    i := 0; j := 0;
    WHILE s1[i] # 0X DO INC(i) END;
    WHILE (i>0) & (s1[i-1] # ":") & (s1[i-1] # "/") DO DEC(i) END;
    REPEAT
      ch := CAP(s2[j]); IF ch="|" THEN ch := 0X END;
      IF CAP(s1[i]) # ch THEN RETURN FALSE END;
      INC(i); INC(j)
    UNTIL s1[i-1] = 0X;
    RETURN TRUE;
  END StrChk;


  (* $SaveRegs+ *)

  PROCEDURE MyGetIcon(name{8}:e.STRPTR; icon{9}:wb.DiskObjectPtr; freelist{10}:e.APTR): LONGINT;
    VAR dt,sp : e.LSTRPTR;
        res,i : LONGINT;
  BEGIN
    res := oldProc(name,icon,freelist);
    IF (res # 0) & (icon.type=wb.project) THEN
      dt := icon.defaultTool;
      IF dt # NIL THEN
        sp := SYS.ADR(tools);
        WHILE sp[0] # 0X DO
          IF StrChk(dt,sp) THEN
            icon.defaultTool := SYS.ADR(replace);
          END;
          i := 0;
          WHILE (sp[i]#0X) & (sp[i]#"|") DO INC(i) END;
          IF sp[i]="|" THEN INC(i) END;
          sp := SYS.ADR(sp[i]);
        END;
      END;
    END;
    RETURN res;
  END MyGetIcon;


  (* $StackChk= $RangeChk= $NilChk= $OvflChk= *)

BEGIN
  IF version[0]=0X THEN END;

  olddir := SYS.VAL(e.APTR,-1);
  halt := FALSE;


  base := ic.base;

  IF (base=NIL) OR (d.base.lib.version<37) THEN
    HALT(d.fail)
  END;


  e.Forbid;

   port := e.FindPort(portName);
   IF port # NIL THEN
     e.Signal(port.sigTask,LONGSET{d.ctrlC});
     port := NIL;
     halt := TRUE;
   END;

  e.Permit;

  IF halt THEN HALT(0) END;


  port := es.CreatePort(portName,0);


  IF ol.wbStarted THEN
    wbm := ol.wbenchMsg;
    olddir := d.CurrentDir(wbm.argList[0].lock);
    COPY(wbm.argList[0].name^,replace);
  ELSE
    IF d.GetProgramName(tools,LEN(tools)) THEN END;
    replace := "PROGDIR:";
    e.CopyMem(d.FilePart(tools)^,replace[8],LEN(replace)-8);
  END;

  icon := ic.GetDiskObject(replace);

  replace := "";
  tools := "";

  IF icon # NIL THEN
    tt := ic.FindToolType(icon.toolTypes,"TOOLS");   IF tt # NIL THEN COPY(tt^,tools) END;
    tt := ic.FindToolType(icon.toolTypes,"REPLACE"); IF tt # NIL THEN COPY(tt^,replace) END;
    ic.FreeDiskObject(icon);
  END;


  oldProc := SYS.VAL(GetIconProc,e.SetFunction(base,-42,SYS.VAL(e.PROC,MyGetIcon)));

  sig := e.Wait(LONGSET{d.ctrlC});
  IF ~ol.wbStarted THEN d.PrintF("***Break\n") END;

CLOSE

  IF oldProc # NIL THEN SYS.SETREG(0,e.SetFunction(base,-42,SYS.VAL(e.PROC,oldProc))); d.Delay(50) END;
  IF SYS.VAL(LONGINT,olddir) # -1 THEN olddir := d.CurrentDir(olddir) END;
  IF port # NIL THEN es.DeletePort(port) END;

  (* $END *)

END ForceMuchMore.


