viewHtml <-
#
# Uses the gtkhtml widget to display an HTML document in a scrolled window.
#
# Currently this handles internal links, i.e. hyper-links between HTML anchors
# within this document.
# Also handles certain types of embedded objects.
#
# Example:
#  viewHtml(system.file("html", "00Index.html", package="base"))
#
function(fileName = "examples/form.html", createWindow = TRUE)
{
   # Create an HTML widget. Make certain it can handle
   # embedded objects (<OBJECT> tags).
 html <- gtkHTMLNew()
# class(html) <- gtkObjectGetClasses(html, FALSE)
 html$AddCallback("object-requested", embeddedObjectHandler)

  # a list of the previous files visited.
 history <- character(0)
 status <- NULL
   # setBase() is getting the wrong arguments going to the
 tmpBase <- getwd()
 
 Load <-
   # Loads the contents of a file into the HTML widget.
   # Function so that we can call it from menu callbacks.
   function(infile, reload = FALSE) {
     if(!reload)
       addToHistory(fileName)

     if(file.exists(infile)) {
       html$SetBase(infile)
       tmpBase <<- dirname(infile)
       lns <- paste(readLines(infile), collapse="\n")
       html$LoadFromString(lns, -1)
       fileName <<- infile
     } else if(!is.null(status)) {
       status$Push(statusContext, paste(infile,"doesn't exist"))
     }

     TRUE
 }

 addToHistory <-
     # Add the file name to the history list
     # and add it to the menu
   function(name) {
     if(!any(name == history)) {
       HistoryMenu$Append(item <- gtkMenuItem(name))
       item$AddCallback("activate", function(w, cmd) {Load(cmd, FALSE)}, data = name, object = FALSE)
     }
     history <<- c(history, name)     
     TRUE
 }

 sw <- gtkScrolledWindow(show = FALSE)
   # Do not use with viewport. Seg-faults in layout allocation size!
 sw$Add(html)

 if(!createWindow)  {
      # Now actually load the file
   Load(fileName, TRUE)
   return(list(html = html, scrolledWindow = sw))
 }
  # create the window and set its size.
 win <- gtkWindow(show = FALSE)
 win$SetUsize(400, 500)

  # Now create a vertical box and put the menu and the HTML widget (actually
  # the scrolled window in wich it resides) into it.
 box <- gtkVBox(FALSE, 4)  

 mbar <- gtkMenuBar()
 fileMenu <- gtkMenuItem("File")

   # Create a pull-down menu with a function in command.S
   # Each of the entries has the same callback function given in the
   # second argument.
 m <- createSimpleMenu(c("Load", "Reload", "", "Edit", "", "Close"),
                       function(w, cmd) {
                        if(cmd == "Load") {
                         dlg <- gtkFileSelection("Load html file")
                         dlg[["OkButton"]]$AddCallback("clicked",
                                                       function(w) {
                                                         f <- dlg$GetFilename()
                                                         if(f != "") {
                                                           Load(f)
                                                           dlg$Destroy()
                                                         }
                                                       })
                         dlg[["CancelButton"]]$AddCallback("clicked", function(w) dlg$Destroy())
                         dlg$Show()
                        } else if(cmd == "Reload") {
                           Load(fileName, TRUE)
                        } else if(cmd == "Close") {
                           win$Hide()
                        }
                     })
 fileMenu$SetSubmenu(m$menu)
 mbar$Append(fileMenu)

  # Create an empty history menu to which we will add the entries
  # as we load new files and store the previous value
 historyMenu <- gtkMenuItem("History")
 HistoryMenu <- gtkMenu()
 historyMenu$SetSubmenu(HistoryMenu)
 mbar$Append(historyMenu)

  # Put the menu bar into the top-level box.
 box$PackStart(mbar, expand = FALSE) 


  # Now create a row in the box that has a URL label, an entry to type a URL
  # and a button to process that entry if one doesn't want to use the Enter key.
 urlBox  <- gtkHBox(FALSE, 10)
 
 urlBox$PackStart(gtkLabel("URL"), expand = FALSE, fill= FALSE)
 urlEntry <- gtkEntry()
 urlBox$PackStart(urlEntry, expand = TRUE)
   # When the user hits return, load the URL!
 urlEntry$AddCallback("activate", function(w) {
                                  txt <- w$GetText()
                                  if(txt != "") {
                                    Load(txt)
                                  }
                                 })
 btn <- gtkButton("Go") 
 urlBox$PackStart(btn, expand = FALSE, fill= FALSE)
 btn$AddCallback("clicked", function(w) {
                              txt <- urlEntry$GetText()
                              if(txt != "") 
                                Load(txt)
                            })
 
 box$PackStart(urlBox, expand = FALSE)

  # Put the scrolled window for the HTML widget next.
 box$PackStart(sw)

   # Now create status bar at the bottom of the window
   # and use this to display URLs that we mouse-over.
 status <- gtkStatusbar()
 statusContext <- status$GetContextId("description")
 box$PackEnd(status, expand= FALSE)

      # Now actually load the file
 Load(fileName, TRUE)
 
 win$Add(box)
 win$ShowAll()

  # Now setup some handlers for the HTML actions.

  # Callback for user clicking on a link.
 link <- html$AddCallback("link-clicked",
                            function(w, link) {
                              print(link)
                              if(length(grep("^#", link))) {
                                html$JumpToAnchor(gsub("^#","", link))
                              } else if(length(grep("^R:", link))) {
                                eval(parse(text = substring(link, 3)))
                              } else {
                                if(file.exists(link)) {
                                  Load(link)
                                } else if(file.exists(paste(tmpBase, link, sep=.Platform$file.sep)))
                                  Load(paste(tmpBase, link, sep=.Platform$file.sep))
#                                  cat("External Link:",link,"\n")
                              }
                            })

   # These are for mouse-over links and we display the locations
   # in the status bar.
 link <- html$AddCallback("on-url",
                            function(w, link) {
                              if(link != "") {
                                status$Push(statusContext, link)
                              }
                              NULL
                            }) 

   # Handler for when the user clicks on the form submit
 submit <- html$AddCallback("submit",
                            function(w, str1, str2, str3) {
                                 cmd <- parseFormURL(str3)
                                 print(eval(parse(text = cmd["command"])))
                            }) 
 
 invisible(list(win = win, html = html, callbackIds = list(link, submit)))
}

parseFormURL <-
  #
  # Take the string reported by an HTML form in the format
  #    name1=value1&name2=value2&name3=value3....&name-n=value-n
  # and return a vector of the form
  #  c(name1=value, name2=value2,...)
  # i.e. a named character vector with the values and indexed
  # by the corresponding name.
  #
function(url)
{
    # Do the first level split at the &'s in the string.
   cmd <- strsplit(url,"&")[[1]]
    # Now split by the = 
   cmd <- strsplit(cmd,"=")

    # Get the names and then the values in two separate steps.
    # 
   name <- sapply(cmd, function(x) x[[1]])
   cmd <- sapply(cmd, function(x) if(length(x) > 1) x[[2]] else "")
   names(cmd) <- name

   cmd
}  


htmlOutputFilter <-
  #
  # An ``object'' that provides methods for generating
  # HTML for an S session, giving a representation of
  # a task (expression and result).
  #
function()
{
  # Counter for the number of commands that have been displayed.
 ctr <- 0

  markup <-
    #
    # Create a textual representation of the given
    # command (`cmd') and result (`value').
    #
    function(cmd, value) {
      ctr <<- ctr + 1
        # Using a text connection is convenient, but
        # having the result be stored in a global variable
        # is one of the worst "design" decisions I have seen!
        # In the future, this will be fixed.
      con <- textConnection(".out", open="w")
      sink(con)
      on.exit({sink(); close(con)})
      print(value) # print the value to the text connection so we
                   # we can get the resulting text next.
      out <- get(".out")

      val <- c("<dt>", ctr,
               "<font color='red'>",
               paste("<a href='",cmd,"' name='", ctr, "'>", sep=""),
               cmd, "</a></font></dt>\n",
               "<dd>\n<pre>\n",
               out,
               "\n</pre></dd>\n")

      val
    }

 header <-
   # Called when starting the session
   function() {
    "<body bg='#FFF'><h1>Output</h1>\n<dl>" 
   } 
 footer <-
   # Called each time we append an entry and should provide
   # the closing element to finish off the document.
   # This should provide the corresponding end elements for those
   # in the header.
   function() {
    "</dl></body>"
 }


  # Return the filter methods as a list
  # and give it a particular class for identification purposes.
 m <- list(header = header,
           markup = markup,
           footer = footer,
           getCurrentAnchor = function() as.character(ctr))

 class(m) <- "HTMLCommandOutputFilter"
 
 m
}  

localOutput <-
  #
  # Simple interface with 2 HTML widgets stacked on top of each other
  # The file displayed in the first is expected to present the interface
  # via form so that when it is submitted there is an "command" variable
  # in the data. This is parsed and evaluated and the result
  # is displayed in the lower HTML widget. We markup the output
  # using the `filter' which can do what it wants. In the default
  # case, this makes the expression a link which if clicked re-runs
  # that command. Also, it puts the result in a <PRE> tag
  # and generates the content as if it were printed by R.
  #
function(fileName = "examples/form.html", filter = htmlOutputFilter())
{
   # Create a basic HTML widget without the window
 w <- viewHtml(fileName, createWindow = FALSE)

   # 
 html <- w$html
 w$scrolledWindow$SetUsize(500,400)

  # Now create the window
 win <- gtkWindow(show = FALSE)
 win$SetUsize(500,600)

  # Create a split pane that the user can adjust directly
  # The top contains the HTML document with the form, and
  # the bottom one shows the output from the commands.
 pane <- gtkVPaned()
 pane$Add(w$scrolledWindow)

  # The output HTML widget for the commands.
 output <- gtkHTMLNew()
   # Will be done when the bindings are done.
# class(output) <- gtkObjectGetClasses(output, FALSE)

 sw <- gtkScrolledWindow()
 sw$Add(output)
 pane$Add(sw)

  # Get the header for the output page.
 txt <- filter$header()

  # When the user clicks on the submit button in form in the top HTML widget,
  # process the settings and evaluate the `command' value.
 submit <- html$AddCallback("submit",
                            function(w, str1, str2, str3) {
                              cmd <- parseFormURL(str3)
                              evalCommand(cmd["command"], show = as.logical(cmd["show"]))
                            })

   # Arrange to re-evaluate the command when the user clicks on it
   # in the output area.
 output$AddCallback("link-clicked",
                     function(w, link) {
                       evalCommand(link, show = TRUE)
                     })

 evalCommand <-
     # Evaluate a command, put the command and result
     # in the output window by transforming the {expression, value}
     # pair through the filter.
   function(cmd, show = TRUE) {
      val <- eval(parse(text = cmd))

      if(!show)
        return(val)

        # Now display the result, marking it up as we want.
      txt <<- c(txt, filter$markup(cmd, val))
      contents <- paste(txt, filter$footer(), collapse="\n", sep="")

      output$LoadFromString(contents, nchar(contents))
       # And scroll to this new entry.
      output$JumpToAnchor(filter$getCurrentAnchor())

      val
  }
 
 win$Add(pane)

 win$ShowAll()
 
 return(list(win = win, output = output, html = html))
}  


embeddedObjectHandler <-
  #
  # called when an HTML widget needs to act on an
  # <OBJECT> tag for an embedded object.
  # This returns TRUE or FALSE depending on whether it understood
  # and processed the request or not.
  # We can have built-in types or just evaluate the script
  # in the init parameter
  # <PARAM name="init" value="script but must contain ; between expressions">
  #
  #
function(html, obj)
{
     type <- obj[["Type"]]

     if(type == "app/x-color") {
         # Create a color selection dialog.
       obj$Add(gtkColorSelection())
     } else if(type == "app/x-button") {
        # Create a button and a simple callback.
       label <- obj$GetParameter("label")
       if(label == "")
         label <- "Embedded Widget"
       btn <- gtkButton(label)
       obj$Add(btn)
       btn$AddCallback("clicked", function(w) {print("Callback from embedded widget")})
     } else if(type == "app/x-slider") {
        # Create a slider, using values from the parameters for the min, max and value
        # if provided.
       mn <- obj$GetParameter("min")
       mn <- ifelse(mn != "", as.numeric(mn), 0)
       mx <- obj$GetParameter("max")
       mx <- ifelse(mn != "", as.numeric(mx), 0)
       val <- obj$GetParameter("value")
       val <- ifelse(val != "", as.numeric(val), mn)              

       adj <- gtkAdjustment(val, mn, mx, .1, 1, 1)
       scale <- gtkHScale(adj)
       obj$Add(scale)
     } else if(type == "app/x-R-device") {
       dev <- gtk(no.window = TRUE);
       class(dev) <- gtkObjectGetClasses(dev, check=FALSE)
       dev$Show()
       box <- gtkHBox(TRUE,10)
       box$PackStart(dev)
       obj$Add(box)
     } else {
        # Check if there is an init paramter and if so,
        # attempt to evaluate it as an S command/expression.
       init <- obj$GetParameter("init")       
       if(init != "") {
         val <-  eval(parse(text = init))
          # If the result is a GtkWidget, then add it to the
          # embedded widget container.
         add <- as.logical(obj$GetParameter("addWidget"))
         if(inherits(val, "GtkWidget") && (is.na(add) || add == TRUE)) {
           obj$Add(val)
           val$Reparent(obj)
         } else if(is.function(val)) {
           val(html, obj)
         }
       } else {
           # say that we did't handle this.
         return(FALSE)
       }
     }

     TRUE
}