;;; html.ol -- objective lisp support for the WWW HTML format
;;; $Id: html.ol,v 1.1 92/08/19 18:37:59 connolly Exp $
;;;

(require 'SGML)

(defClass HTML SGML
  (ignore anchor-content)
  )

(defMethod HTML :pcdata (data)
  (or ignore (send-super :pcdata data))
  (setq anchor-content t)
  )

(defMethod HTML :end-record ()
  ;; nothing
  )

(defMethod HTML :isnew (stream)
  (send-super :isnew stream)
  [self :doctype 'HTML]
  )

(defMethod HTML :started (gi)
  (or (member gi gi-stack)
      [self :start gi])
  )

(defMethod HTML :ended (gi)
  (do ()
      ((null (member gi gi-stack)))
      [self :end (first gi-stack)]
      (send-super :end-record)
      ) )

(defMethod HTML :restore (gi)
  (do ()
      ((eq gi (first gi-stack)))
      [self :end (first gi-stack)]
      (send-super :end-record)
      ) )

(defMethod HTML :reset-paragraph-format (tag fmt)
  (if (eq tag 'TITLE)
      [self :started tag]
    (unless (eq tag (first gi-stack))
	    [self :started 'document]
	    [self :restore 'document]
	    [self :started tag]))
  (case tag
	((DIR MENU OL UL)
	 [self :empty 'LI])
	(DL
	 [self :empty 'DT]
	 )
  ) )

(defMethod HTML :reset-character-format (tag foo)
  [self :end-anchor]
  )
(defMethod HTML :change-paragraph-format (foo)
  )
(defMethod HTML :change-character-format (foo)
  [self :end-anchor]
  )
(defMethod HTML :save-character-format ()
  (setq ignore t)
  )
(defMethod HTML :restore-character-format ()
  (setq ignore nil)
  )

(defMethod HTML :end-paragraph ()
  [self :end-anchor]
  (case (first gi-stack)
	
	(document
	 [self :empty 'P]
	 (send-super :end-record))
	((ul ol dir menu dl)
	 ;;nothing
	 )
	(t [self :end (first gi-stack)]
	   (send-super :end-record))
  ))

(defMethod HTML :end-section ()
  [self :ended 'DOCUMENT]
  )

(defMethod HTML :tab ()
  [self :end-anchor]
  (case (first gi-stack)
	(DL
	 [self :empty 'DD]
	 )
	) )

(defMethod HTML :newline ()
  (case (first gi-stack)
	((XMP LISTING)
	 (send-super :end-record)
	 )
	) )

(defMethod HTML :start-anchor (name href &aux attrs)
  (if name (push `(name ,name) attrs))
  (if href (push `(href ,href) attrs))
  [self :start 'a attrs]
  (setq anchor-content nil)
  )

(defMethod HTML :end-anchor ()
  (if anchor-content [self :ended 'a])
  )

(defMethod HTML :marker (type text)
  (case type
	(8 (let* ((str (make-string-input-stream text))
		  (command (read str))
		  )
	     (case command
		   (newlink (peek-char t str)
			    [self :start-anchor (read-line str) nil])
		   (gotolink [self :start-anchor nil (read-href str)])
		   (message (let ((client (read str))
				  )
			      (peek-char t str) ;; skip whitespace
			      (case client
				    (www [self :start-anchor nil
					       (read-line str)] )
				    ) ))
		   )
	     ))
	) )

(defun read-href (str)
  ;; parse foo:bar -> file:foo#bar
  ;;       bar -> #bar
  ;;       foo:firstpage -> file:foo
  (peek-char t str)
  (do (file
       anchor ex
       href
       (char (read-char str) (read-char str))
       )
      ((null char) ;; reached end of string
       (if file
	   (setq href (concatenate 'string "file:" file)) )
       (cond ((null anchor) )
	     ((eq 'firstpage (intern (concatenate 'string anchor))) )
	     (t (setq href (concatenate 'string href "#"
					anchor) )) )
       href
       )
      
      ;; body of do loop...
      (case char
	    (#\: (setq file anchor)
	     (setq anchor nil)
	     (setq ex nil) )
	    (t (let ((cell (cons char nil))
		     )
		 (if ex (setf (cdr ex) cell)
		   (setf anchor cell) )
		 (setf ex cell) ))
	    )
      ) )

(provide 'html)