Mercurial > hg > xemacs-beta

comparison lisp/hm--html-menus/hm--html.el @ 46:6a22abad6937 r19-15

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15
author cvs
date Mon, 13 Aug 2007 08:55:31 +0200
parents 8b8b7f3559a2
children 131b0175ea99
comparison
equal deleted inserted replaced
45:7705b7aa3b8a 46:6a22abad6937
1 ;;; $Id: hm--html.el,v 1.5 1997/03/24 01:26:53 steve Exp $ 1 ;;; $Id: hm--html.el,v 1.6 1997/03/26 22:42:39 steve Exp $
2 ;;; 2 ;;;
3 ;;; Copyright (C) 1993 - 1997 Heiko Muenkel 3 ;;; Copyright (C) 1993 - 1997 Heiko Muenkel
4 ;;; email: muenkel@tnt.uni-hannover.de 4 ;;; email: muenkel@tnt.uni-hannover.de
5 ;;; 5 ;;;
6 ;;; This program is free software; you can redistribute it and/or modify 6 ;;; This program is free software; you can redistribute it and/or modify
151 151
152 (defun hm--html-add-basefont (size) 152 (defun hm--html-add-basefont (size)
153 "Adds the HTML tag for a basefont." 153 "Adds the HTML tag for a basefont."
154 (interactive (list (hm--html-read-font-size t))) 154 (interactive (list (hm--html-read-font-size t)))
155 (hm--html-add-tags 'hm--html-insert-start-tag 155 (hm--html-add-tags 'hm--html-insert-start-tag
156 (concate "<BASEFONT SIZE=" size ">"))) 156 (concat "<BASEFONT SIZE=" size ">")))
157 157
158 (defun hm--html-add-line-break () 158 (defun hm--html-add-line-break ()
159 "Adds the HTML tag for a line break." 159 "Adds the HTML tag for a line break."
160 (interactive) 160 (interactive)
161 (hm--html-add-tags 'hm--html-insert-start-tag "<BR>")) 161 (hm--html-add-tags 'hm--html-insert-start-tag "<BR>"))
205 (let ((point (point))) 205 (let ((point (point)))
206 (if (and end-point (< (point) end-point)) 206 (if (and end-point (< (point) end-point))
207 (point) 207 (point)
208 (goto-char (point-min)) 208 (goto-char (point-min))
209 (if (re-search-forward 209 (if (re-search-forward
210 (concat "\\(<title\\)\\|\\(<head\\)\\|\\(<html\\)\\|" 210 (concat ;"\\(<title\\)\\|\\(<head\\)\\|\\(<html\\)\\|"
211 "\\(<isindex\\)\\|\\(<base\\)\\|\\(<link\\)\\|" 211 "\\(<title\\)\\|"
212 "\\(<meta") 212 "\\(<isindex\\)\\|\\(<base\\)\\|\\(<link\\)\\|"
213 "\\(<meta\\)")
213 end-point 214 end-point
214 t) 215 t)
215 (beginning-of-line) 216 (beginning-of-line)
216 point)))) 217 end-point))))
217 218
218 (defun hm--html-add-isindex (prompt) 219 (defun hm--html-add-isindex (prompt)
219 "Inserts the isindex tag. PROMPT is the value of the prompt attribute." 220 "Inserts the isindex tag. PROMPT is the value of the prompt attribute."
220 (interactive "sPrompt: ") 221 (interactive "sPrompt: ")
221 (save-excursion 222 (save-excursion
224 (head-end-point)) 225 (head-end-point))
225 (goto-char (point-min)) 226 (goto-char (point-min))
226 (setq head-end-point (when (re-search-forward 227 (setq head-end-point (when (re-search-forward
227 "\\(</head\\)\\|\\(<body\\)\\|\\(</html\\)") 228 "\\(</head\\)\\|\\(<body\\)\\|\\(</html\\)")
228 (beginning-of-line) 229 (beginning-of-line)
229 (point)))) 230 (point)))
230 (cond ((re-search-forward "<isindex[^>]*>" head-end-point t) 231 (goto-char (point-min))
231 (delete-region (match-beginning 0) (match-end 0))) 232 (cond ((re-search-forward "<isindex[^>]*>" head-end-point t)
232 (t (goto-char point) 233 (delete-region (match-beginning 0) (match-end 0)))
233 (hm--html-search-place-for-element-in-head head-end-point))) 234 (t (goto-char point)
234 (hm--html-add-tags 'hm--html-insert-start-tag 235 (hm--html-search-place-for-element-in-head head-end-point)))
235 (concat "<ISINDEX " 236 (hm--html-add-tags 'hm--html-insert-start-tag-with-newline
236 (if (and prompt 237 (concat "<ISINDEX "
237 (not (string= prompt ""))) 238 (if (and prompt
238 (concat " PROMPT=\"" prompt "\">") 239 (not (string= prompt "")))
239 ">"))))) 240 (concat " PROMPT=\"" prompt "\">")
241 ">"))))))
240 242
241 (defun hm--html-add-base (href) 243 (defun hm--html-add-base (href)
242 "Inserts the base tag. HREF is the value of the href attribute." 244 "Inserts the base tag. HREF is the value of the href attribute."
243 (interactive (list (hm--html-read-url "URL of this document: " 245 (interactive (list (hm--html-read-url "URL of this document: "
244 nil 246 nil
251 (head-end-point)) 253 (head-end-point))
252 (goto-char (point-min)) 254 (goto-char (point-min))
253 (setq head-end-point (when (re-search-forward 255 (setq head-end-point (when (re-search-forward
254 "\\(</head\\)\\|\\(<body\\)\\|\\(</html\\)") 256 "\\(</head\\)\\|\\(<body\\)\\|\\(</html\\)")
255 (beginning-of-line) 257 (beginning-of-line)
256 (point)))) 258 (point)))
257 (cond ((re-search-forward "<base[^>]*>" head-end-point t) 259 (goto-char (point-min))
258 (delete-region (match-beginning 0) (match-end 0))) 260 (cond ((re-search-forward "<base[^>]*>" head-end-point t)
259 (t (goto-char point) 261 (delete-region (match-beginning 0) (match-end 0)))
260 (hm--html-search-place-for-element-in-head head-end-point))) 262 (t (goto-char point)
261 (hm--html-add-tags 'hm--html-insert-start-tag 263 (hm--html-search-place-for-element-in-head head-end-point)))
262 (concat "<BASE " 264 (hm--html-add-tags 'hm--html-insert-start-tag-with-newline
263 (if (and href 265 (concat "<BASE "
264 (not (string= href ""))) 266 (if (and href
265 (concat " HREF=\"" href "\">") 267 (not (string= href "")))
266 ">"))))) 268 (concat " HREF=\"" href "\">")
269 ">"))))))
267 270
268 (defun hm--html-add-meta (name content &optional name-instead-of-http-equiv) 271 (defun hm--html-add-meta (name content &optional name-instead-of-http-equiv)
269 "Inserts the meta tag." 272 "Inserts the meta tag."
270 (interactive (list (completing-read "Name: " hm--html-meta-name-alist) 273 (interactive (list (completing-read "Name: " hm--html-meta-name-alist)
271 (read-string "Content: "))) 274 (read-string "Content: ")))
278 "\\(</head\\)\\|\\(<body\\)\\|\\(</html\\)") 281 "\\(</head\\)\\|\\(<body\\)\\|\\(</html\\)")
279 (beginning-of-line) 282 (beginning-of-line)
280 (point))) 283 (point)))
281 (goto-char point) 284 (goto-char point)
282 (hm--html-search-place-for-element-in-head head-end-point) 285 (hm--html-search-place-for-element-in-head head-end-point)
283 (hm--html-add-tags 'hm--html-insert-start-tag 286 (hm--html-add-tags 'hm--html-insert-start-tag-with-newline
284 (concat "<META " 287 (concat "<META "
285 (if name-instead-of-http-equiv 288 (if name-instead-of-http-equiv
286 "NAME=\"" 289 "NAME=\""
287 "HTTP-EQUIV=\"") 290 "HTTP-EQUIV=\"")
288 name 291 name
440 "") 443 "")
441 "\nSHAPE=" shape 444 "\nSHAPE=" shape
442 "\nCOORDS=\"" coords "\"" 445 "\nCOORDS=\"" coords "\""
443 ">"))) 446 ">")))
444 447
448
449 (when (adapt-emacs19p)
450 (defvar :ask ':ask))
451
445 (defvar hm--html-use-image-as-map ':ask 452 (defvar hm--html-use-image-as-map ':ask
446 "Internal variable of `hm--html-add-image'. 453 "Internal variable of `hm--html-add-image'.
447 nil => insert the image element without an usemap attribute. 454 nil => insert the image element without an usemap attribute.
448 t => insert the image element with an usemap attribute. 455 t => insert the image element with an usemap attribute.
449 :ask => ask, if the image element should have an usemap attribute.") 456 :ask => ask, if the image element should have an usemap attribute.")
547 "\" VALUE=\"" 554 "\" VALUE=\""
548 value 555 value
549 "\">"))) 556 "\">")))
550 557
551 558
552 (defun hm--html-add-server-side-include-file (file)
553 "This function adds a server side include file directive in the buffer.
554 The directive is only supported by the NCSA http daemon."
555 (interactive "FInclude File: ")
556 (let ((start (point)))
557 (if (string= file "")
558 (error "ERROR: No filename specified !")
559 (insert "<INC SRV \"" file "\">"))))
560
561
562 (defun hm--html-add-server-side-include-command-with-isindex-parameter
563 (command)
564 "This function adds a server side include command directive in the buffer.
565 The include command uses the \"isindex\"- parameter for the specified command."
566 (interactive (list
567 (completing-read "Include Command: "
568 hm--html-server-side-include-command-alist)))
569 (hm--html-add-server-side-include-command command t))
570
571
572 (defun hm--html-add-server-side-include-command (command &optional srvurl)
573 "This function adds a server side include command directive in the buffer.
574 The directive is only supported by the NCSA http daemon.
575 If SRVURL is t, then the attribute srvurl instead of srv is used for the
576 include command. With srvurl, the include command uses the \"isindex\"-
577 parameter for the specified command."
578 (interactive (list
579 (completing-read "Include Command: "
580 hm--html-server-side-include-command-alist)))
581 (let ((start (point))
582 (attribute (if srvurl "SRVURL" "SRV")))
583 (if (string= command "")
584 (error "ERROR: No command specified !")
585 (if (= ?| (string-to-char command))
586 (insert "<INC " attribute" \"" command "\">")
587 (insert "<INC " attribute " \"|" command "\">")))))
588
589 559
590 ;;; Functions, which adds tags of the form <starttag> ... </endtag> 560 ;;; Functions, which adds tags of the form <starttag> ... </endtag>
591 561
592 (defun hm--html-add-big () 562 (defun hm--html-add-big ()
593 "Adds the HTML tags for Big at the point in the current buffer." 563 "Adds the HTML tags for Big at the point in the current buffer."
863 (concat "<DIV ALIGN=\"" alignment "\">") 833 (concat "<DIV ALIGN=\"" alignment "\">")
864 'hm--html-insert-end-tag-with-newline 834 'hm--html-insert-end-tag-with-newline
865 "</DIV>")) 835 "</DIV>"))
866 836
867 837
868 (defun hm--html-add-document-division-to-region () 838 (defun hm--html-add-document-division-to-region (alignment)
869 "Adds the HTML tags for document division to the region." 839 "Adds the HTML tags for document division to the region."
870 (interactive (list (hm--html-read-alignment "Alignment of the division: "))) 840 (interactive (list (hm--html-read-alignment "Alignment of the division: ")))
871 (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline 841 (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline
872 (concat "<DIV ALIGN=\"" alignment "\">") 842 (concat "<DIV ALIGN=\"" alignment "\">")
873 'hm--html-insert-end-tag-with-newline 843 'hm--html-insert-end-tag-with-newline
1069 ">") 1039 ">")
1070 'hm--html-insert-end-tag-with-newline 1040 'hm--html-insert-end-tag-with-newline
1071 "</FONT>")) 1041 "</FONT>"))
1072 1042
1073 1043
1074 (defun hm--html-add-font-to-region () 1044 (defun hm--html-add-font-to-region (size color)
1075 "Adds the HTML tags for Font to the region." 1045 "Adds the HTML tags for Font to the region."
1076 (interactive (list (hm--html-read-font-size) 1046 (interactive (list (hm--html-read-font-size)
1077 (hm--html-read-font-color))) 1047 (hm--html-read-font-color)))
1078 (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline 1048 (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline
1079 (concat "<FONT" 1049 (concat "<FONT"
1973 SERVERNAME:PORT-PARAMETER-LIST, PATH+FILE-PARAMETER-LIST and 1943 SERVERNAME:PORT-PARAMETER-LIST, PATH+FILE-PARAMETER-LIST and
1974 ANCHOR-PARAMETER-LIST are lists with a prompt string, an alist, a default 1944 ANCHOR-PARAMETER-LIST are lists with a prompt string, an alist, a default
1975 value and an example string. The ANCHOR-PARAMETER-LIST has as an additional 1945 value and an example string. The ANCHOR-PARAMETER-LIST has as an additional
1976 element an anchor seperator string. All these elements are used to read and 1946 element an anchor seperator string. All these elements are used to read and
1977 construct the link." 1947 construct the link."
1978 (let ((point nil)) 1948 ; (let ((point nil))
1979 (save-window-excursion 1949 (save-window-excursion
1980 (let ((html-buffer (current-buffer)) 1950 (let ((html-buffer (current-buffer))
1981 (html-help-buffer (hm--html-generate-add-link-help-buffer 1951 (html-help-buffer (hm--html-generate-add-link-help-buffer
1982 scheme-parameter-list 1952 scheme-parameter-list
1983 host-name:port-parameter-list 1953 host-name:port-parameter-list
1984 servername:port-parameter-list 1954 servername:port-parameter-list
1985 path+file-parameter-list 1955 path+file-parameter-list
1986 anchor-parameter-list)) 1956 anchor-parameter-list))
1987 (scheme (hm--html-completing-read scheme-parameter-list)) 1957 (scheme (hm--html-completing-read scheme-parameter-list))
1988 (hostname:port (hm--html-completing-read 1958 (hostname:port (hm--html-completing-read
1989 host-name:port-parameter-list)) 1959 host-name:port-parameter-list))
1990 (servername:port (hm--html-completing-read 1960 (servername:port (hm--html-completing-read
1991 servername:port-parameter-list)) 1961 servername:port-parameter-list))
1992 (path+file (hm--html-read-filename path+file-parameter-list)) 1962 (path+file (hm--html-read-filename path+file-parameter-list))
1993 (anchor (hm--html-completing-read anchor-parameter-list)) 1963 (anchor (hm--html-completing-read anchor-parameter-list))
1994 ; (hrefname (setq html-link-counter (1+ html-link-counter))) 1964 ; (hrefname (setq html-link-counter (1+ html-link-counter)))
1995 (anchor-seperator 1965 (anchor-seperator
1996 (hm--html-get-anchor-seperator-from-parameter-list 1966 (hm--html-get-anchor-seperator-from-parameter-list
1997 anchor-parameter-list))) 1967 anchor-parameter-list)))
1998 (if (not (string= scheme "")) 1968 (if (not (string= scheme ""))
1999 (if (string= hostname:port "") 1969 (if (string= hostname:port "")
2000 (setq scheme (concat scheme ":")) 1970 (setq scheme (concat scheme ":"))
2001 (setq scheme (concat scheme "://")))) 1971 (setq scheme (concat scheme "://"))))
2002 (if (and (not (string= hostname:port "")) 1972 (if (and (not (string= hostname:port ""))
2003 (not (string= servername:port "")) 1973 (not (string= servername:port ""))
2004 (not (string= (substring servername:port 0 1) "/"))) 1974 (not (string= (substring servername:port 0 1) "/")))
2005 (setq servername:port (concat "/" servername:port))) 1975 (setq servername:port (concat "/" servername:port)))
2006 (if (and (not (string= path+file "")) 1976 (if (and (not (string= path+file ""))
2007 (not (string= "/" (substring path+file 0 1)))) 1977 (not (string= "/" (substring path+file 0 1))))
2008 (setq path+file (concat "/" path+file))) 1978 (setq path+file (concat "/" path+file)))
2009 (if (not (string= anchor "")) 1979 (if (not (string= anchor ""))
2010 (setq anchor (concat anchor-seperator anchor))) 1980 (setq anchor (concat anchor-seperator anchor)))
2011 (kill-buffer html-help-buffer) 1981 (kill-buffer html-help-buffer)
2012 (pop-to-buffer html-buffer) 1982 (pop-to-buffer html-buffer)
2013 (eval (list function-add-tags 1983 (eval (list function-add-tags
2014 ''hm--html-insert-start-tag 1984 ''hm--html-insert-start-tag
2015 (concat "<A" 1985 (concat "<A"
2016 ; "<A Name=" 1986 ; "<A Name="
2017 ; hrefname 1987 ; hrefname
2018 " HREF=\"" 1988 " HREF=\""
2019 scheme 1989 scheme
2020 hostname:port 1990 hostname:port
2021 servername:port 1991 servername:port
2022 path+file 1992 path+file
2023 anchor 1993 anchor
2024 "\">") 1994 "\">")
2025 ''hm--html-insert-end-tag 1995 ''hm--html-insert-end-tag
2026 "</A>"))) 1996 "</A>")))
2027 (setq point (point)))) 1997 ; (setq point (point))))
2028 (goto-char (point))) 1998 ; (goto-char (point)))
2029 1999 ))
2030 2000
2031 (defun hm--html-add-info-link-1 (function-add-tags) 2001 (defun hm--html-add-info-link-1 (function-add-tags)
2032 "Internal function. Adds the HTML tags for a link on a GNU Info file." 2002 "Internal function. Adds the HTML tags for a link on a GNU Info file."
2033 (hm--html-add-link function-add-tags 2003 (hm--html-add-link function-add-tags
2034 (list ; scheme 2004 (list ; scheme
2621 2591
2622 2592
2623 (defun hm--html-add-mail-box-link () 2593 (defun hm--html-add-mail-box-link ()
2624 "Adds the HTML tags for a link to a mail box." 2594 "Adds the HTML tags for a link to a mail box."
2625 (interactive) 2595 (interactive)
2626 (hm--html-add-mail-link-1 'hm--html-add-tags)) 2596 (hm--html-add-mail-box-link-1 'hm--html-add-tags))
2627 2597
2628 2598
2629 (defun hm--html-add-mail-box-link-to-region () 2599 (defun hm--html-add-mail-box-link-to-region ()
2630 "Adds the HTML tags for a link to a mail box to the region." 2600 "Adds the HTML tags for a link to a mail box to the region."
2631 (interactive) 2601 (interactive)
2632 (hm--html-add-mail-link-1 'hm--html-add-tags-to-region)) 2602 (hm--html-add-mail-box-link-1 'hm--html-add-tags-to-region))
2633 2603
2634 2604
2635 (defun hm--html-add-mailto-link-1 (function-add-tags) 2605 (defun hm--html-add-mailto-link-1 (function-add-tags)
2636 "Internal function. Adds the HTML tags for a mailto link." 2606 "Internal function. Adds the HTML tags for a mailto link."
2637 (let ((mailto-alist (if (and (boundp 'user-mail-address) 2607 (let ((mailto-alist (if (and (boundp 'user-mail-address)
2799 (point-max))))) 2769 (point-max)))))
2800 (goto-char (point-min)) 2770 (goto-char (point-min))
2801 (if (not (search-forward "</title>" end-of-head t)) 2771 (if (not (search-forward "</title>" end-of-head t))
2802 (if (not noerror) 2772 (if (not noerror)
2803 (error "ERROR: Please insert a title in the document !")) 2773 (error "ERROR: Please insert a title in the document !"))
2804 (let ((end-of-title-position (point))) 2774 ; (let ((end-of-title-position (point)))
2805 (if (search-forward "<!-- Created by: " end-of-head t) 2775 (if (search-forward "<!-- Created by: " end-of-head t)
2806 (if (yes-or-no-p 2776 (if (yes-or-no-p
2807 "Replace the old comment \"<!-- Created by: \" ") 2777 "Replace the old comment \"<!-- Created by: \" ")
2808 (progn 2778 (progn
2809 (goto-char (match-beginning 0)) 2779 (goto-char (match-beginning 0))
2810 (kill-line) 2780 (kill-line)
2811 (hm--html-add-comment) 2781 (hm--html-add-comment)
2812 (insert "Created by: " 2782 (insert "Created by: "
2813 (or hm--html-username (user-full-name)) 2783 (or hm--html-username (user-full-name))
2814 ", " 2784 ", "
2815 (hm--date)))) 2785 (hm--date))))
2816 (newline) 2786 (newline)
2817 (hm--html-add-comment) 2787 (hm--html-add-comment)
2818 (insert "Created by: " 2788 (insert "Created by: "
2819 (or hm--html-username (user-full-name)) 2789 (or hm--html-username (user-full-name))
2820 ", " 2790 ", "
2821 (hm--date) 2791 (hm--date)
2822 ))))))) 2792 ))))))
2823 2793
2824 2794
2825 (defun hm--html-insert-changed-comment-1 (newline username) 2795 (defun hm--html-insert-changed-comment-1 (newline username)
2826 "Internal function of 'hm--html-insert-changed-comment'. 2796 "Internal function of 'hm--html-insert-changed-comment'.
2827 Inserts a newline if NEWLINE is t, before the comment is inserted. 2797 Inserts a newline if NEWLINE is t, before the comment is inserted.