;;; LCD Archive Entry:
;;; w3-mode|William M. Perry|wmperry@indiana.edu|
;;; Major mode for browsing World Wide Web nodes|
;;; 93-9-4|.98Beta|Location undetermined
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This is a major mode for browsing documents written in Hypertext Markup ;;;
;;; Language (HTML).  These documents are typicallly part of the World Wide ;;;
;;; Web (WWW), a project to create a global information net in hypertext    ;;;
;;; format.				                                    ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Known bugs: 			                             	    ;;;
;;; 1. No image support for lucid emacs                                     ;;;
;;; 2. No support for limiting # of colors displayed                        ;;;
;;; 3. <IMG SRC="http:..."> links aren't supported (only local or relative  ;;;
;;; 4. Searching in the hypertext gopher doesn't work yet                   ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Todo:			                                            ;;;
;;; 1. Ability to edit group and personal annotations                       ;;;
;;; 2. Support for more than one annotation server.                         ;;;
;;; 3. Wais support (Gateway or native?)                                    ;;;
;;; 4. Variable to control whether old buffers are kept or not              ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Copyright (c) 1993 by William M. Perry (wmperry@indiana.edu)	    ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(require 'w3-vars)

(if (not (fboundp 'gopher-dispatch-object))
    (progn
      (autoload 'gopher-dispatch-object "gopher"    "Fetch gopher dir" t)))

(if (not (fboundp 'html-mode))
    (autoload 'html-mode "html-mode" "Edit HTML docs" t))

(if (not noninteractive) (progn
			   (require 'ange-ftp)
			   (require 'nntp)))

(defun w3-load-flavors ()
  "Load the correct zone/font info for each flavor of emacs"
  (cond
   (w3-running-lemacs (require 'w3-lucid))
   (w3-running-epoch  (progn
			(require 'w3-epoch)
			(w3-epoch-frob-resources)))
   (w3-running-FSF19  (require 'w3-emacs19))
   (t                 (require 'w3-emacs))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Automatic bug submission.                                               ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun w3-submit-bug ()
  "Function to submit a bug to the programs maintainer"
  (interactive)
  (if w3-mutable-windows (mail-other-window) (mail))
  (mail-to)
  (insert "wmperry@indiana.edu")
  (mail-subject)
  (insert "Bug found in w3-mode")
  (re-search-forward mail-header-separator nil t)
  (next-line 1)
  (while (< (current-column) 29) (insert "-"))
  (insert "Description of System:")
  (while (< (current-column) 75) (insert "-"))
  (insert "\n")
  (string-match "WWW \\([^ ]*\\) \\(.*\\)" w3-version)
  (insert "WWW Browser Version: "
	  (substring w3-version (match-beginning 1) (match-end 1))
	  ", of "
	  (substring w3-version (match-beginning 2) (match-end 2))
	  "\n"
	  "      Emacs Version: "
	  (substring (emacs-version) 0 (string-match " of" (emacs-version)))
	  "\n"
	  "        System Type: "
	  (prin1-to-string system-type) "\n")
  (while (< (current-column) 29) (insert "-"))
  (insert "Description of Problem:")
  (while (< (current-column) 75) (insert "-"))
  (insert "\n\n"))
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Support for searching						    ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun w3-nuke-spaces-in-search (x)
  "Remove spaces from search strings . . ."
  (let ((new ""))
    (while (not (equal x ""))
      (setq new (concat new (if (= (string-to-char x) 32) "+" 
			      (substring x 0 1)))
	    x (substring x 1 nil)))
    new))

(defun w3-search ()
  "Perform a search, if this is a searchable index."
  (interactive)
  (cond
   ((not w3-current-isindex) (message "Not a searchable index!"))
   ((not (equal w3-current-type "http"))
    (message "Sorry, searching is not implemented on local files yet."))
   (t
    (let ((querystring (w3-nuke-spaces-in-search
			(read-string "Search on (+ separates keywords): "))))
      (w3-fetch (concat "http://" w3-current-server ":" w3-current-port
			w3-current-file "?" querystring))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Mailing of documents						    ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun w3-mail-current-document ()
  "Mail the current-document to someone"
  (interactive)
  (let* ((user (read-string "To: "))
	 (title (buffer-name))
	 (str (buffer-string)))
    (mail-other-window)
    (mail-subject)
    (insert "WWW Formatted File:" title)
    (re-search-forward mail-header-separator nil)
    (forward-char 1)
    (while (< (current-column) 79) (insert "-"))
    (insert "\n" str "\n")
    (while (< (current-column) 79) (insert "-"))
    (mail-to)
    (insert user)
    (re-search-forward mail-header-separator nil)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Auto documentation, etc                                                 ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun w3-help ()
  "Print documentation on w3 mode."
  (interactive)
  (let* ((funcs w3-doc-functions)
	 (funcstr "")
	 (vars w3-doc-variables)
	 (varstr "")
	 (keys nil))
    (while funcs
      (if (fboundp (car funcs))
	  (setq keys (where-is-internal (car funcs) w3-mode-map t)
		funcstr (format "%s\n<LI>%5s: %s" funcstr
				(if (null keys)
				    (format "M-x %s" (car funcs))
				  (if w3-running-FSF19
				      (key-description (car keys))
				    (key-description keys)))
				(documentation (car funcs)))))
      (setq funcs (cdr funcs)))
    (while vars
      (if (boundp (car vars))
	  (let* ((thevar (prin1-to-string (car vars)))
		 (doc (documentation-property (car vars)
					      'variable-documentation)))
	    (setq varstr
		  (format "%s\n<LI>%20s: %s\n" varstr thevar
			  (if (> (+ (length thevar) (length doc)) 80)
			      (concat "\n" doc)
			    doc)))))
      (setq vars (cdr vars)))
    (set-buffer (get-buffer-create " *W3*"))
    (if buffer-read-only (toggle-read-only))
    (erase-buffer)
    (insert (format "<TITLE>Help For W3 V%s</TITLE>\n" w3-version-number))
    (insert "<H1>Current keybindings:</H1>\n====================<P>\n"
	    "<UL>" funcstr "</UL>")
    (insert "<P><H1>Modifiable variables:</H1>\n=====================<P>\n"
	    "<UL>" varstr "</UL>")
    (setq w3-current-type "fake"
	  w3-current-file "help.html")	  
    (goto-char (point-min))
    (w3-sentinel nil nil)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Remove . & .. from path names                                           ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun w3-remove-relative-links-helper (name)
  (let* ((result ""))
    (cond
     ((string-match "\\\.\\\./" name)
      (let ((tmp (substring name (match-end 0) nil)))
	(if (= 0 (match-beginning 0)) (setq result
					    (concat
					     (w3-basepath
					      (w3-basepath w3-current-file))
					     "/" tmp))
	  (setq result (concat
			(w3-basepath (substring name 0
						(1- (match-beginning 0))))
			"/" tmp)))))
     ((string-match "\\\./" name)
      (if (= 0 (match-beginning 0))
	  (setq result (substring name 2 nil))
	(setq result (concat
		      (substring name 0 (match-beginning 0))
		      (substring name (match-end 0) nil))))))))

(defun w3-remove-relative-links (name)
  (while (string-match "\\\.+/" name)
    (setq name (w3-remove-relative-links-helper name)))
  name)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Mode definition, etc.                                                   ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun w3-install-documents-menu ()
  "Install documents menu if in emacs 19 or lucid"
  (if w3-documents-menu
      (let ((tmp w3-documents-menu)
	    nam url mnu)
	(while tmp
	  (setq nam (car (car tmp))
		url (cdr (car tmp))
		mnu (cons (vector nam (list 'w3-fetch url) t) mnu)
		tmp (cdr tmp)))
	(add-menu '() "Documents" mnu))))

(defun w3-version ()
  "Show the version # of W3 in the minibuffer"
  (interactive)
  (message w3-version))

(defun w3 ()
  "Start a w3 session.  Goes to w3-default-homepage as home page."
  (interactive)
  (if (not (string-match ".*:.*" w3-default-homepage))
      (w3-fetch (concat "file:" w3-default-homepage))
    (w3-fetch w3-default-homepage)))

(defun w3-relative-link (url)
  "Try to resolve a link like \"library/io.html\""
  (let ((resolved (cond ((equal w3-current-type "http")
			 (concat "http://" w3-current-server ":" 
				 w3-current-port))
			((equal w3-current-type "ftp")
			 (concat "file://" w3-current-server "/"))
			(t "file:"))))
    (if (equal "#" (substring url 0 1))
	(progn
	  (goto-char (point-min))
	  (w3-find-specific-link (substring url 1 nil)))
      (progn
	(setq url (w3-remove-relative-links url))
	(cond
	 ((equal (string-to-char url) 47)
	  (setq resolved (concat resolved url)))
	 (t (setq resolved (concat resolved
				   (w3-basepath w3-current-file) "/" url))))
	(w3-fetch resolved)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Mode definition							    ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun w3-reload-document ()
  "Reload the current document"
  (interactive)
  (let ((tmp (w3-view-url t)))
    (kill-buffer (current-buffer))
    (w3-fetch tmp)))

(defun w3-quit ()
  "Quit WWW mode"
  (interactive)
  (if (and w3-running-FSF19
	   (eq window-system 'x))
      (setq lucid-menu-bar-dirty-flag t))
  (let ((lb w3-current-last-buffer))
    (kill-buffer (current-buffer))
    (if w3-mutable-windows
	(pop-to-buffer lb)
      (switch-to-buffer lb))))

(defun w3-view-url (&optional no-show)
  "View the current document's URL"
  (interactive)
  (let ((url ""))
    (cond
     ((equal w3-current-type "gopher")
      (setq url (format "%s://%s%s/%s/%s"
			w3-current-type w3-current-server
			(if (string= "70" w3-current-port) ""
			  (concat ":" w3-current-port))
			"1"
			(if (= ?/ (string-to-char w3-current-file))
			    (substring w3-current-file 1 nil)
			  w3-current-file))))
     ((equal w3-current-type "http")
      (setq url (format  "%s://%s%s/%s" w3-current-type w3-current-server
			 (if (string= "80" w3-current-port) ""
			   (concat ":" w3-current-port))
			 (if (= ?/ (string-to-char w3-current-file))
			     (substring w3-current-file 1 nil)
			   w3-current-file))))
     ((equal w3-current-type "ftp")
      (setq url (format "%s://%s/%s" w3-current-type w3-current-server 
			(if (= 47 (string-to-char w3-current-file))
			    (substring w3-current-file 1 nil)
			  w3-current-file))))
     ((equal w3-current-type nil)
      (setq url (format "file:%s" w3-current-file))))
    (if (not no-show) (message url) url)))
    
(defun w3-document-source ()
  "View this documents source"
  (interactive)
  (cond
   ((equal w3-current-type "http")
    (w3-http (format "http://%s:%s/%s" w3-current-server
		     w3-current-port w3-current-file) t))
   ((equal w3-current-type "gopher")
    (w3-do-gopher w3-current-server w3-current-port "" w3-current-file t))
   ((equal w3-current-type "ftp")
    (w3-file (format "ftp://%s/%s" w3-current-server w3-current-file) t))
   ((equal w3-current-type nil)
    (w3-open-local (concat "file:" w3-current-file) t))))

(defun w3-save-url ()
  "Save current url in the kill ring"
  (interactive)
  (setq kill-ring (cons (w3-view-url t) kill-ring)))

(defun w3-mode ()
  "Mode for viewing HTML documents.  Will try to bring up the document
specified by w3-default-homepage.

Current keymap is:
\\{w3-mode-map}"
  (interactive)
  (let ((tmp (list w3-current-file w3-current-server
		   w3-current-type w3-current-port
		   w3-current-isindex
		   w3-zones-list
		   w3-current-last-buffer
		   w3-current-mime-viewer
		   w3-current-mime-server-type
		   w3-current-mime-type
		   w3-current-mime-encoding))) ; keep some variables
    (kill-all-local-variables)
    (use-local-map w3-mode-map)
    (setq major-mode 'w3-mode)
    (setq mode-name "WWW")
    (run-hooks 'w3-mode-hooks)
    (setq				; restore buffer-local variables
     w3-current-file (nth 0 tmp)
     w3-current-server (nth 1 tmp)
     w3-current-type (nth 2 tmp)
     w3-current-port (nth 3 tmp)
     w3-current-isindex (nth 4 tmp)
     w3-zones-list (nth 5 tmp)
     w3-current-last-buffer (nth 6 tmp)
     w3-current-mime-viewer (nth 7 tmp)
     w3-current-mime-server-type (nth 8 tmp)
     w3-current-mime-type (nth 9 tmp)
     w3-current-mime-encoding (nth 10 tmp))
    (if w3-running-epoch (use-local-mouse-map w3-mouse-map))
    (if (boundp 'w3-NeXT-mousemap) (use-local-mousemap w3-NeXT-mousemap))
    (if (and w3-running-FSF19
	     (eq window-system 'x))
	(progn
	  (w3-build-FSF19-menu)
	  (w3-install-documents-menu)))
    (if w3-running-lemacs
	(progn
	  (w3-build-lemacs-menu)
	  (w3-install-documents-menu)
	  (if (w3-is-personal-annotation (w3-view-url t))
	      (enable-menu-item '("WWW" "Personal Annotations" "Delete Annotation))
	    (disable-menu-item '("WWW" "Personal Annotations" "Delete Annotation")))
	  (if (w3-is-annotation)
	      (enable-menu-item '("WWW" "Group Annotations" "Delete Annotation"))
	    (disable-menu-item '("WWW" "Group Annotations" "Delete Annotation)))
	  (add-hook 'activate-menubar-hook 'w3-add-hotlist-menu)))
    (if (and w3-current-isindex (equal w3-current-type "http"))
	(setq mode-line-process "-Searchable"))))

(or (fboundp 'add-hook)
    (defun add-hook (hook-var function &optional at-end)
      "Add a function to a hook.
First argument HOOK-VAR (a symbol) is the name of a hook, second
 argument FUNCTION is the function to add.
Third (optional) argument AT-END means to add the function at the end
 of the hook list instead of the beginning.  If the function is already
 present, this has no effect.
Returns nil if FUNCTION was already present in HOOK-VAR, else new
 value of HOOK-VAR."
      (if (not (boundp hook-var)) (set hook-var nil))
      (let ((old (symbol-value hook-var)))
	(if (or (not (listp old)) (eq (car old) 'lambda))
	    (setq old (list old)))
	(if (w3-member function old)
	    nil
	  (set hook-var
	       (if at-end
		   (append old (list function)) ; don't nconc
		 (cons function old)))))))

(if (not (memq 'w3 features))
    (run-hooks 'w3-load-hooks))

(provide 'w3)

(require 'w3-url)
(require 'w3-html+)
(require 'w3-mime)
(require 'w3-misc)
(require 'w3-print)
(require 'w3-parse)
(require 'w3-lists)
(require 'w3-mosaic)
(require 'w3-gopher)
(require 'w3-forms)

(w3-load-flavors)
(or w3-hotlist (w3-parse-hotlist))
(or w3-personal-annotations (w3-parse-personal-annotations))

(defun gopher-www-object (obj oldbuf)
  "Get a WWW address."
  (if (fboundp 'w3-fetch)
      (w3-fetch (gopher-object-selector obj))
    (gopher-unimplemented-object obj oldbuf)))

(defun w3-change-gopher ()
  "Add html handling to gopher mode"
  (if (not (assoc ?w gopher-object-type-alist))
      (setq gopher-object-type-alist
	    (cons '(?w " <WWW>"  gopher-www-object)
		  gopher-object-type-alist))))
      
(add-hook 'gopher-directory-mode-hook 'w3-change-gopher)
