<* PRAGMA LL *>

MODULE WebVBT;

IMPORT CIText, Filter, Fmt, Font, HTML, HTMLVBT, HTMLVBTText, HTMLVBTG,
       Images, MultiClass, MultiSplit, Pixmap, PixmapVBT, Point,
       RefList, SimpleWeb, Split, TextExtras, TextList, TextEditVBT,
       TextPort, TextureVBT, TextVBT, Thread, URLCache, VBT, Web, Image,
       Rd, TextRd, PaintOp;

REVEAL Private = Filter.T BRANDED OBJECT END;

REVEAL
  T = Public BRANDED OBJECT
        <* LL=VBT.mu *>
        t: Thread.T := NIL;
      OVERRIDES
        init     := Init;
        fetch    := Fetch;
        fromText := FromText;
        stop     := Stop;
        getLinks := GetLinks;
        search   := Search;
        ready    := Ready;
        hotlink  := Hotlink;
        isindex  := Isindex;
        ismap    := Ismap;
        form     := Form;
      END;

PROCEDURE Init (v: T): T =
  BEGIN
    RETURN Filter.T.init(v, TextureVBT.New(txt:=Pixmap.Gray))
  END Init;

PROCEDURE FromText (v             : T;
                    contents      : TEXT;
                    contentType   : Web.MIMEType := Web.MIMEType.Text;
                    contentSubType: TEXT         := "html";
                    url           : TEXT         := "text:";
                    style         : Style        := Style.Normal;
                    zippers       : BOOLEAN      := FALSE;
                    reload        : BOOLEAN      := FALSE;
                    server        : Web.T        := NIL;
                    scrollBar     : BOOLEAN      := TRUE) =

  VAR webpage := NEW(Web.Page);
  BEGIN
    v.stop();
    webpage.header.contentType := contentType;
    webpage.header.contentSubType := contentSubType;
    webpage.header.location := url;
    webpage.contents := contents;
    v.t :=
      Thread.Fork(NEW(FromTextClosure, v := v, webpage := webpage,
                      url := url, style := style, zippers := zippers,
                      reload := reload, server := server,
                      scrollBar := scrollBar))
  END FromText;

TYPE
  Closure = Thread.Closure OBJECT
                      v        : T;
                      style    : Style;
                      zippers  : BOOLEAN;
                      reload   : BOOLEAN;
                      server   : Web.T;
                      scrollBar: BOOLEAN;
                    END;

TYPE
  FromTextClosure = Closure OBJECT
                      webpage : Web.Page;
                      url     : TEXT;
                    OVERRIDES
                      apply := FromTextWrapper;
                    END;

PROCEDURE FromTextWrapper (cl: FromTextClosure): REFANY =
  BEGIN
    Display(cl.webpage, cl.v, cl.url, cl.style, cl.zippers, cl.reload,
            cl.server, cl.scrollBar);
    RETURN NIL
  END FromTextWrapper;

PROCEDURE Fetch (v        : T;
                 url      : TEXT;
                 style    : Style   := Style.Normal;
                 zippers  : BOOLEAN := FALSE;
                 reload   : BOOLEAN := FALSE;
                 server   : Web.T   := NIL;
                 scrollBar: BOOLEAN := TRUE) =
  BEGIN
    v.stop();
    v.t := Thread.Fork(
             NEW(FetchClosure, v := v, url := url, style := style,
                 zippers := zippers, reload := reload, server := server,
                 scrollBar := scrollBar))
  END Fetch;

TYPE
  FetchClosure = Closure OBJECT
                   url    : TEXT;
                 OVERRIDES
                   apply := FetchWrapper;
                 END;

PROCEDURE FetchWrapper (cl: FetchClosure): REFANY =
  VAR webpage: Web.Page; base: TEXT;
  BEGIN
    TRY
      webpage :=
          SimpleWeb.Fetch(cl.url, reload := cl.reload, server := cl.server);
      base := webpage.header.location;
                   (* SimpleWeb.Fetch always fills in header.location *)
      Display(webpage, cl.v, base, cl.style, cl.zippers, cl.reload, cl.server,
              cl.scrollBar);
    EXCEPT
      Thread.Alerted =>
    END;
    RETURN NIL
  END FetchWrapper;

CONST
    FontName = "-*-fixed-medium-r-semicondensed-*-*-120-*-*-*-*-iso8859-1";

PROCEDURE Display (webpage  : Web.Page;
                   v        : T;
                   base     : TEXT;
                   style    : Style;
                   zippers  : BOOLEAN;
                   reload   : BOOLEAN;
                   server   : Web.T;
                   scrollBar: BOOLEAN) =

  PROCEDURE NewTextPage (t: TEXT) RAISES {Thread.Alerted} =
    VAR page := NEW(TextPage);
    BEGIN
      page.vbt := NEW(TextEditVBT.T).init();
      WITH tp = page.vbt.tp DO
        TextPort.SetText(tp, t);
        tp.setReadOnly(TRUE);
        tp.setFont(Font.FromName(ARRAY OF TEXT{FontName}));
      END;
      NewPage(page, page.vbt)
    END NewTextPage;

  PROCEDURE NewHTMLPage (h: HTML.T) RAISES {Thread.Alerted} =
    VAR
      page              := NEW(HTMLPage);
      toLoad: RefList.T;

    BEGIN
      IF h.base = NIL THEN h.base := base END;
      page.html := h;

      URLCache.PutHTML (base, h);

      CASE style OF

      | Style.Ugly =>
          page.vbt := NEW(TextHTMLVBT, parent := v).init(page.html);
          NewPage(page, page.vbt);

      | Style.NoImages =>
          page.vbt := NEW(GraphicsHTMLVBT, parent := v).init(
                        page.html, TRUE, zippers, toLoad, scrollBar);
          NewPage(page, page.vbt);

      | Style.Normal =>
          page.vbt := NEW(GraphicsHTMLVBT, parent := v).init(
                        page.html, FALSE, zippers, toLoad, scrollBar);
          LoadResources(v, reload, server, toLoad, FALSE);
          NewPage(page, page.vbt);

      | Style.Background =>
          page.vbt := NEW(GraphicsHTMLVBT, parent := v).init(
                        page.html, FALSE, zippers, toLoad, scrollBar);
          NewPage(page, page.vbt, RefList.Length(toLoad));
          LoadResources(v, reload, server, toLoad, TRUE);

      END;
    END NewHTMLPage;

  PROCEDURE NewImagePage (pm: Pixmap.T) RAISES {Thread.Alerted} =
    VAR
      page := NEW(ImagePage);
      (* op := PaintOp.BgFg; *)
      op := PaintOp.Copy;
    BEGIN
      page.vbt := NEW(PixmapVBT.T).init(pm, op := op);
      NewPage(page, page.vbt);
    END NewImagePage;

  PROCEDURE NewPage (page: Page; vbt: VBT.T; imageCt := 0)
    RAISES {Thread.Alerted} =
    BEGIN
      LOCK VBT.mu DO
        IF Thread.TestAlert() THEN RAISE Thread.Alerted END;
        IF v.t # Thread.Self() THEN RETURN END;
        EVAL Filter.Replace(v, vbt);
        page.header := webpage.header;
        page.contents := webpage.contents;
        v.url := base;
        v.page := page;
        v.ready(imageCt);
      END
    END NewPage;

  BEGIN
    TRY
      WITH hdr   = webpage.header,
           stuff = webpage.contents DO
        IF hdr.contentType = Web.MIMEType.Text THEN
          IF CIText.Equal(hdr.contentSubType, "html") THEN
            NewHTMLPage(HTML.FromRd(TextRd.New(stuff)))
          ELSE
            NewTextPage(stuff);
          END;
        ELSIF hdr.contentType = Web.MIMEType.Image THEN
          TRY
            IF CIText.Equal(hdr.contentSubType, "jpeg") THEN
              NewImagePage(Images.FromJPEG(stuff));
            ELSIF CIText.Equal(hdr.contentSubType, "gif") THEN
              NewImagePage(Images.FromGIF(stuff))
            ELSIF CIText.Equal(hdr.contentSubType, "ppm") OR
                  CIText.Equal(hdr.contentSubType, "pnm") OR
                  CIText.Equal(hdr.contentSubType, "pbm") OR
                  CIText.Equal(hdr.contentSubType, "pgm") THEN
              WITH rd = TextRd.New(stuff) DO
                NewImagePage(Image.Unscaled(Image.FromRd(rd)));
              END;
            ELSE
              NewTextPage("cannot handle '" & hdr.contentSubType & "'");
            END
          EXCEPT
            Rd.Failure, Image.Error, Images.Error =>
                NewTextPage("cannot display image");
          END
        END
      END
    EXCEPT
      Thread.Alerted =>
    END
  END Display;

PROCEDURE LoadResources (v              : T;
                         reload         : BOOLEAN;
                         server         : Web.T;
                         list           : RefList.T;
                         callReadyMethod: BOOLEAN    )
  RAISES {Thread.Alerted} =
  VAR
    ct  : INTEGER;
    info: HTMLVBTG.Info;
    page: Web.Page;
  BEGIN
    ct := RefList.Length(list);
    WHILE list # NIL DO
      info := list.head;
      page :=
        SimpleWeb.Fetch(info.url, reload := reload, server := server);
      info.load(page);
      DEC(ct);
      IF callReadyMethod THEN InvokeReadyMethod(v, ct) END;
      list := list.tail;
    END;
    IF callReadyMethod THEN InvokeReadyMethod(v, 0) END;
  END LoadResources;

PROCEDURE InvokeReadyMethod (v: T; arg: INTEGER) RAISES {Thread.Alerted} =
  BEGIN
    LOCK VBT.mu DO
      IF Thread.TestAlert() THEN RAISE Thread.Alerted END;
      IF v.t # Thread.Self() THEN RETURN END;
      v.ready(arg)
    END;
  END InvokeReadyMethod;

TYPE GraphicsHTMLVBT = HTMLVBTG.T OBJECT
    parent: T;
  OVERRIDES
    hotlink := HTMLVBTHotlink;
    ismap   := HTMLVBTIsmap;
    isindex := HTMLVBTIsindex;
  END;

TYPE TextHTMLVBT = HTMLVBTText.T OBJECT
    parent: T;
  OVERRIDES
    hotlink := HTMLVBTHotlink;
    ismap   := HTMLVBTIsmap;
    isindex := HTMLVBTIsindex;
  END;

PROCEDURE HTMLVBTHotlink (         ch : HTMLVBT.T;
                                   url: TEXT;
                          READONLY cd : VBT.MouseRec) =
  BEGIN
    TYPECASE ch OF
    | GraphicsHTMLVBT (v) => v.parent.hotlink(url, cd)
    ELSE
    END
  END HTMLVBTHotlink;

PROCEDURE HTMLVBTIsmap (         ch : HTMLVBT.T;
                                 url: TEXT;
                        READONLY pt : Point.T;
                        READONLY cd : VBT.MouseRec) =
  BEGIN
    TYPECASE ch OF
    | GraphicsHTMLVBT (v) =>
        v.parent.ismap(url & "?" & Fmt.Int(pt.h) & "," & Fmt.Int(pt.v), cd)
    ELSE
    END
  END HTMLVBTIsmap;

PROCEDURE HTMLVBTIsindex (ch: HTMLVBT.T; typein: TEXT) =
  VAR p: T;
  BEGIN
    TYPECASE ch OF
    | GraphicsHTMLVBT (v) => p := v.parent;
    | TextHTMLVBT (v) => p := v.parent;
    ELSE <* ASSERT FALSE *>
    END;
    p.isindex(p.url & "?" & typein);
  END HTMLVBTIsindex;

PROCEDURE Stop (self: T) =
  BEGIN
    IF self.t # NIL THEN Thread.Alert(self.t) END
  END Stop;

PROCEDURE Hotlink (<* UNUSED *> self: T;
                   <* UNUSED *> link: TEXT;
                   <* UNUSED *> READONLY cd: VBT.MouseRec) =
  BEGIN
  END Hotlink;

PROCEDURE Isindex (<* UNUSED *> self: T; <* UNUSED *> typein: TEXT) =
  BEGIN
  END Isindex;

PROCEDURE Ismap (<* UNUSED *>          self  : T;
                 <* UNUSED *>          absURL: TEXT;
                 <* UNUSED *> READONLY cd    : VBT.MouseRec) =
  BEGIN
  END Ismap;

PROCEDURE Form (<* UNUSED *> self: T) =
  BEGIN
  END Form;

PROCEDURE Ready (<* UNUSED *> self: T; <* UNUSED *> remImages: CARDINAL) =
  BEGIN
  END Ready;

PROCEDURE GetLinks (self: T): TextList.T =
  BEGIN
    TYPECASE self.page OF
    | NULL =>
    | HTMLPage (h) => RETURN HTML.GetLinks(h.html)
    ELSE
    END;
    RETURN NIL
  END GetLinks;

PROCEDURE Search (self: T; pattern: TEXT): BOOLEAN =
  BEGIN
    TYPECASE self.page OF
    | NULL =>
    | TextPage (t) => RETURN SearchVBTTree(t.vbt, pattern)
    | HTMLPage (h) => RETURN SearchVBTTree(h.vbt, pattern)
    ELSE
    END;
    RETURN FALSE
  END Search;

PROCEDURE SearchVBTTree (v: VBT.T; pattern: TEXT): BOOLEAN =
  <* FATAL MultiSplit.NotAChild *>
  BEGIN
    TYPECASE v OF
    | TextVBT.T (textvbt) =>
        WITH text = TextVBT.Get(textvbt) DO
          RETURN TextSearch(text, pattern)
        END;
    | TextPort.T (textport) =>
        WITH text = TextPort.GetText(textport) DO
          RETURN TextSearch(text, pattern)
        END
    ELSE
      IF MultiClass.Resolve(v) # NIL OR ISTYPE(v, Split.T) THEN
        VAR ch := MultiSplit.Succ(v, NIL);
        BEGIN
          WHILE ch # NIL DO
            IF SearchVBTTree(ch, pattern) THEN
              RETURN TRUE
            ELSE
              ch := MultiSplit.Succ(v, ch)
            END
          END;
          RETURN FALSE
        END
      ELSE
        RETURN FALSE
      END
    END;
  END SearchVBTTree;

PROCEDURE TextSearch (text, pattern: TEXT): BOOLEAN =
  VAR index: CARDINAL := 0;
  BEGIN
    RETURN TextExtras.FindSub(text, pattern, index)
  END TextSearch;

BEGIN
END WebVBT.