home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / w3 / w3-parse.el < prev    next >
Encoding:
Text File  |  1995-08-22  |  10.6 KB  |  345 lines
  1. ;;; w3-parse.el,v --- Generalized html/sgml parsing support for emacs-w3
  2. ;; Author: wmperry
  3. ;; Created: 1995/08/20 18:02:45
  4. ;; Version: 1.69
  5. ;; Keywords: faces, help, hypermedia
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com)
  9. ;;;
  10. ;;; This file is not part of GNU Emacs, but the same permissions apply.
  11. ;;;
  12. ;;; GNU Emacs is free software; you can redistribute it and/or modify
  13. ;;; it under the terms of the GNU General Public License as published by
  14. ;;; the Free Software Foundation; either version 2, or (at your option)
  15. ;;; any later version.
  16. ;;;
  17. ;;; GNU Emacs is distributed in the hope that it will be useful,
  18. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20. ;;; GNU General Public License for more details.
  21. ;;;
  22. ;;; You should have received a copy of the GNU General Public License
  23. ;;; along with GNU Emacs; see the file COPYING.  If not, write to
  24. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  25. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26.  
  27. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28. ;;; The parser
  29. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  30. (require 'w3-vars)
  31.  
  32. (defmacro w3-can-safely-ignore (p1 p2 swallow)
  33.   (` (cond
  34.       ((= (, p1) (, p2)) t)
  35.       ((/= (, swallow) 0) nil)
  36.       ((= (abs (- (, p2) (, p1))) 1)
  37.        (memq (or (char-after (, p1)) ?\n) '(?\r ?\t ? )))
  38.       (t
  39.        (let (done)
  40.      (while (and (< (, p1) (, p2)) (not done))
  41.        (if (memq (or (char-after (, p1)) ?\n) '(?\n ?\r ?\t ? ))
  42.            nil
  43.          (setq done t))
  44.        (setq (, p1) (1+ (, p1))))
  45.      (not done))))))
  46.  
  47. (condition-case ()
  48.     (require 'w3-10646)
  49.   (error (fset 'w3-resolve-numeric-entity 'char-to-string)))
  50.  
  51. (defun w3-nuke-entities-in-region (st &optional nd)
  52.   (if (null st)
  53.       nil
  54.     (save-restriction
  55.       (let (entity entity-pos)
  56.     (narrow-to-region st nd)
  57.     (if (not (boundp 'MULE))
  58.         (subst-char-in-region st nd ?\222 ?'))
  59.     (goto-char (point-min))
  60.     (catch 'entity-exit
  61.       (while (not (eobp))
  62.         (skip-chars-forward "^&")
  63.         (setq entity-pos (point))
  64.         (if (eobp)
  65.         (throw 'entity-exit nil)
  66.           (forward-char 1))
  67.         (cond
  68.          ((eobp) (setq entity "&"))
  69.          ((= (char-after (point)) ?#)
  70.           (forward-char 1)
  71.           (setq entity
  72.             (condition-case ()
  73.             (let ((x (read (current-buffer))))
  74.               (if (symbolp x) (setq x (string-to-int
  75.                            (symbol-name x))))
  76.               (w3-resolve-numeric-entity x))
  77.               (error nil)))
  78.           (cond
  79.            ((boundp 'MULE) nil)
  80.            ((string= entity "\231")
  81.         (setq entity (get 'w3-entities 'trade)))
  82.            ((string= entity "\222")
  83.         (setq entity (get 'w3-entities 'rsquo)))
  84.            (t nil)))
  85.          ((memq (char-after (point)) '(?  ?\t ?\n ?\r ?.))
  86.           (setq entity "&"))
  87.          (t
  88.           (setq entity (get 'w3-entities (condition-case ()
  89.                          (read (current-buffer))
  90.                            (error nil))))))
  91.         (if entity
  92.         (progn
  93.           (if (and (not (eobp))
  94.                (= (char-after (point)) ?\;))
  95.               (delete-region entity-pos (1+ (point)))
  96.             (delete-region entity-pos (point)))
  97.           (insert entity))))))
  98.       (goto-char (if (< st nd) (point-max) (point-min))))))
  99.  
  100. (defun w3-preparse-buffer (&optional buff nodraw)
  101.   "Do a preliminary parse of an HTML buffer BUFF.
  102. BUFF defaults to `url-working-buffer'.
  103.  
  104. This returns the parsed HTML a list suitable for use by w3-draw-html."
  105.   (set-buffer (or buff url-working-buffer))
  106.   (setq buff (current-buffer))
  107.   (set-syntax-table w3-parse-args-syntax-table)
  108.   (if (fboundp 'sera-to-fidel-marker) 
  109.       (let ((sera-being-called-by-w3 t))
  110.     (sera-to-fidel-marker)))
  111.   (goto-char (point-min))
  112.   (if (not nodraw)
  113.       (let ((buf (get-buffer-create (url-generate-new-buffer-name
  114.                      "Untitled")))
  115.         (info (mapcar (function (lambda (x) (cons x (symbol-value x))))
  116.               w3-persistent-variables)))
  117.     (setq w3-draw-buffer buf)
  118.     (save-excursion
  119.       (set-window-buffer (selected-window) buf)
  120.       (set-buffer buf)
  121.       (erase-buffer)
  122.       (setq w3-last-fill-pos (point)
  123.         fill-column (- (or w3-strict-width (window-width))
  124.                    w3-right-border)
  125.         fill-prefix "")
  126.       (mapcar (function (lambda (x) (set (car x) (cdr x)))) info)
  127.       (w3-init-state))))
  128.   (let (ptree
  129.     tag
  130.     args
  131.     last-pos
  132.     expendable
  133.     (swallow-newlines 0)
  134.     ctr)
  135.     (setq last-pos (point-min)
  136.       ctr 0)
  137.     (goto-char (point-min))
  138.     (catch 'w3exit
  139.       (while (not (eobp))
  140.     (skip-chars-forward "^<")
  141.     (while (looking-at "< ")
  142.       (forward-char 2)
  143.       (skip-chars-forward "^<"))
  144.     (setq expendable last-pos)
  145.     (if (w3-can-safely-ignore expendable (point) swallow-newlines)
  146.         (if (/= last-pos (point))
  147.         (progn
  148.           (if (not nodraw)
  149.               (w3-handle-single-tag 'text " "))
  150.           (setq ptree (cons (cons 'text " ") ptree))))
  151.       (if (/= swallow-newlines 0)
  152.           (subst-char-in-region last-pos (point) ?\r ? )
  153.         ;; (save-restriction
  154.         (narrow-to-region last-pos (point))
  155.         (goto-char (point-min))
  156.         (while (re-search-forward "[ \t\n\r]+" nil t)
  157.           (replace-match " "))
  158.         (goto-char (point-max))
  159.         (widen))
  160.       (w3-nuke-entities-in-region last-pos (point))
  161.       (setq ptree (cons (cons 'text (buffer-substring last-pos (point)))
  162.                 ptree))
  163.       (if (not nodraw)
  164.           (w3-handle-single-tag 'text (cdr (car ptree)))))
  165.     (setq last-pos (1+ (point)))
  166.     (if (looking-at "<!--")
  167.         (progn
  168.           (forward-char 4)
  169.           (if (re-search-forward "--[ \t\n]*>" nil t)
  170.           (setq last-pos (point))
  171.         (w3-warn 'html "Unterminated comment, attempting to cope.")
  172.         (skip-chars-forward "^>")
  173.         (skip-chars-forward ">")
  174.         (if (eobp)
  175.             (throw 'w3-exit nil)
  176.           (setq last-pos (point)))))
  177.       (condition-case ()
  178.           (forward-sexp 1)
  179.         (error
  180.          (condition-case ()
  181.          (forward-char 1)
  182.            (error (throw 'w3exit nil)))
  183.          (skip-chars-forward "^<>")
  184.          (if (looking-at ">")
  185.          (skip-chars-forward ">"))))
  186.       (url-lazy-message "Parsed %d of %d (%d%%)" (point)
  187.            (point-max) (url-percentage (point) (point-max)))
  188.       (condition-case ()
  189.           (narrow-to-region last-pos (1- (point)))
  190.         (error (throw 'w3exit nil)))
  191.       (setq last-pos (point))
  192.       (goto-char (point-min))
  193.       (skip-chars-forward "^ \t\n\r")
  194.       (downcase-region (point-min) (point))
  195.       (goto-char (point-min))
  196.       (setq tag (condition-case ()
  197.             (read buff)
  198.               (error nil))
  199.         args (if (< (point) last-pos)
  200.              (save-excursion
  201.                (w3-nuke-entities-in-region last-pos (point))))
  202.         args (if (< (point) (point-max))
  203.              (w3-parse-args (point) (point-max))))
  204.       (cond
  205.        ((null tag) nil)
  206.        ((and (eq tag 'ol) (not (assoc "value" args)))
  207.         (setq args (cons (cons "value" 1) args)))
  208.        ((eq tag 'plaintext)
  209.         (widen)
  210.         (skip-chars-forward "> \n")
  211.         (setq ptree (cons
  212.              (cons 'plaintext
  213.                    (list
  214.                 (cons "data"
  215.                       (buffer-substring (point) (point-max)))))
  216.              ptree))
  217.         (if (not nodraw)
  218.         (w3-handle-single-tag (car (car ptree))
  219.                       (cdr (car ptree))))
  220.         (throw 'w3exit nil))
  221.        ((eq tag 'style)
  222.         (let ((case-fold-search t))
  223.           (widen)
  224.           (skip-chars-forward "> \n")
  225.           (setq last-pos (point))
  226.           (if (search-forward "</style" nil t)
  227.           (goto-char (match-beginning 0))
  228.         (w3-warn 'html "Unterminated <style> tag, coping..."))
  229.           (setq args (cons (cons "data" (buffer-substring last-pos
  230.                                   (point)))
  231.                    args))))
  232.        ((eq tag 'xmp)
  233.         (let ((case-fold-search t))
  234.           (widen)
  235.           (skip-chars-forward ">\n")
  236.           (setq last-pos (point))
  237.           (if (search-forward "</xmp" nil t)
  238.           (goto-char (match-beginning 0))
  239.         (w3-warn 'html "Unterminated <xmp> tag.")
  240.         (goto-char (point-max)))
  241.           (setq tag 'xmp
  242.             args (list (cons "data"
  243.                      (buffer-substring last-pos (point)))))))
  244.        ((eq tag 'listing)
  245.         (let ((case-fold-search t))
  246.           (widen)
  247.           (skip-chars-forward "> \n")
  248.           (setq last-pos (point))
  249.           (if (search-forward "</listing" nil t)
  250.           (goto-char (match-beginning 0))
  251.         (w3-warn 'html "Unterminated <listing> tag.")
  252.         (goto-char (point-max)))
  253.           (setq tag 'text
  254.             args (concat
  255.               (if (/= (or (char-after last-pos) ?\n) ?\n)
  256.                   "\n" "")
  257.               (buffer-substring last-pos (point))))))
  258.        ((eq tag 'textarea)
  259.         (let ((case-fold-search t))
  260.           (widen)
  261.           (skip-chars-forward "> \n")
  262.           (setq last-pos (point))
  263.           (if (search-forward "</textarea" nil t)
  264.           (progn
  265.             (goto-char (match-beginning 0))
  266.             (skip-chars-backward " \n"))
  267.         (w3-warn 'html "Unterminated <textarea> tag."))
  268.           (w3-nuke-entities-in-region last-pos (point))
  269.           (setq args (cons (cons "data"
  270.                      (buffer-substring last-pos (point)))
  271.                    args))))
  272.        ((memq tag '(pre lit))
  273.         (setq swallow-newlines (1+ swallow-newlines)))
  274.        ((eq tag 'embed)
  275.         (let* ((case-fold-search t)
  276.            (data (if (re-search-forward "</embed" nil t)
  277.                  (progn
  278.                    (goto-char (match-beginning 0))
  279.                    (buffer-substring last-pos (point))))))
  280.           (if data (setq args (cons (cons "data" data) args)))))
  281.        ((memq tag '(/pre /lit))
  282.         (setq swallow-newlines (max (1- swallow-newlines) 0))))
  283.       (widen)
  284.       (skip-chars-forward ">")
  285.       (setq last-pos (point))
  286.       (if tag
  287.           (progn
  288.         (setq ctr (1+ ctr))
  289.         (if (not nodraw)
  290.             (progn
  291.               (if (and (= (% ctr 15) 0) w3-do-incremental-display)
  292.               (w3-pause))
  293.               (w3-handle-single-tag tag args)))
  294.         (setq ptree (cons (cons tag args) ptree)))))))
  295.     (message "Done")
  296.     (if nodraw
  297.     (nreverse ptree)
  298.       (cons w3-draw-buffer (nreverse ptree)))))
  299.  
  300. (defun w3-parse-args (st nd)
  301.   "Return an assoc list of attribute/value pairs from an SGML-type string"
  302.   (let (
  303.     name                ; From name=
  304.     value                ; its value
  305.     results                ; Assoc list of results
  306.     name-pos            ; Start of XXXX= position
  307.     val-pos                ; Start of value position
  308.     )
  309.     (save-restriction
  310.       (narrow-to-region st nd)
  311.       (goto-char (point-min))
  312.       (while (not (eobp))
  313.     (skip-chars-forward " \n\t")
  314.     (setq name-pos (point))
  315.     (skip-chars-forward "^ \n\t=")
  316.     (downcase-region name-pos (point))
  317.     (setq name (buffer-substring name-pos (point)))
  318.     (skip-chars-forward " \t\n")
  319.     (if (/= (or (char-after (point)) 0)  ?=) ; There is no value
  320.         (setq value nil)
  321.       (skip-chars-forward " \t\n=")
  322.       (setq val-pos (point)
  323.         value
  324.         (cond
  325.          ((or (= (or (char-after val-pos) 0) ?\")
  326.               (= (or (char-after val-pos) 0) ?'))
  327.           (buffer-substring (1+ val-pos)
  328.                     (condition-case ()
  329.                     (prog2
  330.                         (forward-sexp 1)
  331.                         (1- (point))
  332.                       (skip-chars-forward "\""))
  333.                       (error
  334.                        (skip-chars-forward "^ \t\n")
  335.                        (point)))))
  336.          (t
  337.           (buffer-substring val-pos
  338.                     (progn
  339.                       (skip-chars-forward "^ \t\n")
  340.                       (point)))))))
  341.     (setq results (cons (cons name value) results)))
  342.       results)))
  343.  
  344. (provide 'w3-parse)
  345.