Download
(eval-when-compile (require 'cl))
(unless (and (intern-soft "*IS-MON-OBARRAY*")
(bound-and-true-p *IS-MON-OBARRAY*))
(setq *IS-MON-OBARRAY* (make-vector 17 nil)))
(require 'mon-regexp-symbols)
(require 'htmlfontify nil t)
(require 'w3m nil t)
(require 'url)
(require 'url-util)
(declare-function w3m-print-this-url "ext:w3m" t t)
(declare-function w3m-view-this-url "ext:w3m" t t)
(declare-function w3m-find-file "ext:w3m" t t )
(defgroup mon-url-utils nil
"Variables required by various `mon-*' web and url related functions.\n
:SEE-ALSO .\n►►►"
:link '(url-link
:tag "\n:EMACSWIKI-FILE (URL `http://www.emacswiki.org/emacs/mon-url-utils.el')"
"http://www.emacswiki.org/emacs/mon-url-utils.el")
:link '(emacs-library-link
:tag "\n:FILE mon-url-utils.el"
"mon-url-utils.el")
:group 'mon-base)
(defcustom *mon-url-utils-xrefs*
'(mon-its-all-text-purge-on-quit mon-html-fontify-generate-file-name
mon-htmlfontify-dir-purge-on-quit mon-htmlfontify-buffer-to-firefox
mon-htmlfontify-region-to-firefox mon-hexcolor-add-to-font-lock
mon-url-encode mon-url-decode mon-search-ulan mon-search-ulan-for-name
mon-search-wikipedia mon-search-loc mon-search-bnf mon-insert-dbc-link
mon-insert-dbc-doc-link mon-wrap-one-url mon-wrap-all-urls mon-wrap-url
mon-wrap-span mon-make-html-table-string mon-make-html-table
mon-url-retrieve-to-new-buffer mon-get-host-address mon-w3m-dired-file
mon-w3m-kill-url-at-point mon-get-w3m-url-at-point-maybe
mon-get-w3m-url-at-point mon-w3m-goto-url-at-point
mon-w3m-read-gnu-lists-nxt-prv mon-tld-tld mon-tld-name mon-tld-find-tld
mon-tld-find-name mon-tld
*mon-url-search-paths* *mon-purge-on-its-all-text-on-quit*
**mon-purge-htmlfontify-dir-on-quit* *regexp-hexcolor-keywords*
*mon-tld-list* *mon-url-utils-xrefs*)
"Xrefing list of mon url related functions, constants, and variables.\n
The symbols contained of this list are defined in :FILE mon-url-utils.el\n
:SEE-ALSO `*mon-default-loads-xrefs*', `*mon-default-start-loads-xrefs*',
`*mon-dir-locals-alist-xrefs*', `*mon-dir-utils-xrefs*',
`*mon-keybindings-xrefs*', `*mon-testme-utils-xrefs*',
`*mon-button-utils-xrefs*', `*mon-bzr-utils-xrefs*', `*mon-buffer-utils-xrefs*',
`*mon-env-proc-utils-xrefs*', `*mon-error-utils-xrefs*',
`*mon-line-utils-xrefs*', `*mon-macs-xrefs*', `*mon-plist-utils-xrefs*',
`*mon-post-load-hooks-xrefs*', `*mon-seq-utils-xrefs*',
`*mon-string-utils-xrefs*', `*mon-type-utils-xrefs*',
`*mon-window-utils-xrefs*', `*naf-mode-xref-of-xrefs*', `*mon-slime-xrefs*',
`*naf-mode-faces-xrefs*', `*naf-mode-date-xrefs*', `*mon-ulan-utils-xrefs*',
`*google-define-redux-xrefs*', `*mon-xrefs-xrefs'.\n►►►"
:type '(repeat symbol)
:group 'mon-url-utils
:group 'mon-xrefs)
(defcustom *mon-url-search-paths*
'(
(bnf .
"http://catalogue.bnf.fr/jsp/recherche_autorites_bnf.jsp?nouvelleRecherche=O&host=catalogue")
(loc .
"http://authorities.loc.gov/cgi-bin/Pwebrecon.cgi?DB=local&PAGE=First")
(ulan .
"http://www.getty.edu/vow/ULANServlet?english=Y&find=")
(ulan-flbk .
"http://www.getty.edu/research/conducting_research/vocabularies/ulan/")
(wiki .
"http://en.wikipedia.org/wiki/")
(ietf .
"http://tools.ietf.org/rfc/rfc%s.txt")
(unicode .
"http://www.unicode.org/Public/UNIDATA/")
(cmu-ai .
"http://www.cs.cmu.edu/Groups/AI/lang/lisp/")
(comp-lang-lisp
. "http://groups.google.com/group/comp.lang.lisp/search?group=comp.lang.lisp&q=")
)
"List conses KEY is a symbol mapping to value a URL string to search.\n
Each element of list has the format:\n
( <SYMBOL> . <URL-STRING> )\n
:EXAMPLE\n\n(assq 'bnf *mon-url-search-paths*)\n
\(cdr (assq 'loc *mon-url-search-paths*\)\)\n
\(assq 'loc '\(\(loc . \"http://authorities.loc.gov/cgi-bin/Pwebrecon.cgi?DB=local&PAGE=First\"\)
\(ulan . \"http://www.getty.edu/vow/ULANServlet?english=Y&find=\"\)\)\)\n
:SEE-ALSO `webjump-sample-sites', `mon-search-bnf', `mon-search-loc',
`mon-search-ulan', `mon-search-ulan-for-name', `mon-search-wiki',
`mon-search-wikipedia', `mon-wget-rfc', `*mon-unidata-file-list*',
`mon-help-cl-pkgs'.\n►►►"
:type '(alist :key-type symbol
:value-type string)
:group 'mon-url-utils)
(defcustom *mon-purge-on-its-all-text-on-quit* nil
"Whether to evaluate `mon-its-all-text-purge-on-quit'.\n
:SEE-ALSO `mon-htmlfontify-dir-purge-on-quit',
`mon-purge-doc-view-cache-directory', `mon-purge-thumbs-directory',
`mon-purge-temporary-file-directory',
`*mon-purge-emacs-temp-file-dir-fncns*'.\n►►►"
:type 'boolean
:group 'mon-url-utils)
(defcustom *mon-purge-htmlfontify-dir-on-quit* nil
"Whether to evaluate `mon-htmlfontify-dir-purge-on-quit'.\n
:SEE-ALSO `*mon-purge-on-its-all-text-on-quit*',
`mon-htmlfontify-dir-purge-on-quit', `mon-purge-doc-view-cache-directory',
`mon-purge-thumbs-directory', `mon-purge-temporary-file-directory',
`*mon-purge-emacs-temp-file-dir-fncns*'.\n►►►"
:type 'boolean
:group 'mon-url-utils)
(defcustom *regexp-hexcolor-keywords* nil
"Regexp keyword match patterns for font-locking hex color values \(e.g. CSS\).\n
:SEE-ALSO `mon-hexcolor-add-to-font-lock', `mon-string-from-hex-list',
`mon-string-to-hex-list', `mon-string-to-hex-string',
`mon-string-to-hex-list-cln-chars', `url-hexify-string', `url-unhex-string',
`url-unhex', `hexl-hex-string-to-integer', `*regexp-rgb-hex*',
`*css-color:hex-chars*', `*regexp-rgb-hex*', `*regexp-css-color-hex*',
`mon-help-css-color', `mon-help-color-chart', `mon-help-color-functions'.\n►►►"
:type '(repeat (list regexp (list integer sexp)))
:group 'mon-regexp-symbols
:group 'mon-url-utils
:group 'mon-css-color)
(unless (and (intern-soft "*regexp-hexcolor-keywords*" obarray)
(bound-and-true-p *regexp-hexcolor-keywords*))
(setq *regexp-hexcolor-keywords*
'(("#[abcdefABCDEF[:digit:]]\\{6\\}"
(0 (put-text-property
(match-beginning 0)
(match-end 0)
'face (list :background
(match-string-no-properties 0)))))))
(custom-note-var-changed '*regexp-hexcolor-keywords*))
(defun mon-its-all-text-purge-on-quit ()
"Remove .txt files in the current user's Mozilla profile itsalltext directory.\n
On w32 these may get left behind when remoting field text from Firefox using the
itsalltext add-on extension.\n
Signal an error when `*mon-purge-on-its-all-text-on-quit*' is null or
`*mon-misc-path-alist*' does not satisfy `bound-and-true-p'.\n
This procedure invokes `file-expand-wildcards' with the following pattern:\n
\"/Mozilla/Firefox/Profiles/*.default/itsalltext/*.txt*\"\n
:NOTE You _should_ set/verify the path value associated with the key
`the-itsalltext-temp-dir` in the variable `*mon-misc-path-alist*'.\n
The intent of this procedure that it be run as a hook on `kill-emacs-hook'.\n
When `IS-MON-SYSTEM-P', this function is evaluated with:`n
`mon-purge-emacs-temp-files-on-quit' on the `kill-emacs-hook'.\n
:SEE (URL `https://addons.mozilla.org/en-US/firefox/addon/4125')\n
:SEE (URL `http://trac.gerf.org/itsalltext')\n
:SEE-ALSO `mon-htmlfontify-dir-purge-on-quit',
`mon-purge-doc-view-cache-directory', `mon-purge-thumbs-directory',
`mon-purge-temporary-file-directory',
`*mon-purge-emacs-temp-file-dir-fncns*'.\n►►►"
(let (chk-i-a-t)
(when (and
(and (intern-soft "*mon-purge-on-its-all-text-on-quit*" obarray)
(not (null *mon-purge-on-its-all-text-on-quit*))
)
(or (and (intern-soft "*mon-misc-path-alist*" obarray)
(bound-and-true-p *mon-misc-path-alist*)
(not (null (setq chk-i-a-t (cadr (assq 'the-itsalltext-temp-dir *mon-misc-path-alist*))))))
(mon-format :w-fun #'error
:w-spec '(":FUNCTION `mon-its-all-text-purge-on-quit' "
"-- :VARIABLE `*mon-misc-path-alist*' null or not present"))))
(when (and chk-i-a-t (file-exists-p chk-i-a-t))
(dolist (i-a-t (file-expand-wildcards (concat chk-i-a-t "/*.txt*") t))
(unless (car (file-attributes i-a-t))
(delete-file i-a-t)))))))
(when (featurep 'htmlfontify)
(defun mon-html-fontify-generate-file-name ()
"Generate a temporary file-name for `mon-htmlfontify-*' procedures.\n
:EXAMPLE\n\n(mon-html-fontify-generate-file-name)\n
:NOTE Variables `*mon-html-fontify-file-name-template*', `*emacs2html-temp*' in:
:FILE mon-dir-locals-alist.el\n
:SEE-ALSO `mon-htmlfontify-region-to-firefox', `mon-htmlfontify-dir-purge-on-quit'.\n►►►"
(and (or (and (intern-soft "*mon-html-fontify-file-name-template*" obarray)
(bound-and-true-p *mon-html-fontify-file-name-template*))
(mon-format :w-fun #'error
:w-spec '(":FUNCTION `mon-html-fontify-generate-file-name' "
"-- :VARIABLE `*mon-html-fontify-file-name-template*' "
"null or not present")))
(or (and (intern-soft "*emacs2html-temp*" obarray)
(bound-and-true-p *emacs2html-temp*))
(mon-format :w-fun #'error
:w-spec '(":FUNCTION `mon-html-fontify-generate-file-name' "
"-- :VARIABLE `*emacs2html-temp*' null or not present"))))
(let ((mhfgfn #'(lambda ()
(format *mon-html-fontify-file-name-template*
*emacs2html-temp* (random t))))
mhfgfn-myb-regen)
(setq mhfgfn-myb-regen (funcall mhfgfn))
(while (file-exists-p mhfgfn-myb-regen)
(setq mhfgfn-myb-regen (funcall mhfgfn)))
mhfgfn-myb-regen))
(defun mon-htmlfontify-dir-purge-on-quit ()
"Delete files in `*emacs2html-temp*' matching \"emacs2firefox-.*\.html\".\n
These are temp files generated with `mon-htmlfontify-buffer-to-firefox' and
`mon-htmlfontify-region-to-firefox'.\n
This procedure is meant to be run as a hook on `kill-emacs-hook'.\n
Signals an error when any of the following occur:\n
`*mon-purge-htmlfontify-dir-on-quit*' is null;
`*emacs2html-temp*' does not satisfy `bound-and-true-p';
`*emacs2html-temp*' does not satisfy `file-exists-p';
`file-directory-p' does not satisfy `file-exists-p';\n
:NOTE When `IS-MON-SYSTEM-P', this function is evaluated with
`mon-purge-emacs-temp-files-on-quit' on the `kill-emacs-hook'.\n
:EXAMPLE\n\(directory-files *emacs2html-temp* t \"emacs2firefox-.*\.html\")\n
\n\(mon-htmlfontify-dir-purge-on-quit\)\n
:SEE-ALSO `mon-its-all-text-purge-on-quit', `mon-purge-doc-view-cache-directory',
`mon-purge-thumbs-directory', `mon-purge-temporary-file-directory'.\n►►►"
(interactive)
(when (and (or *mon-purge-htmlfontify-dir-on-quit*
(mon-format :w-fun #'error
:w-spec '(":FUNCTION `mon-htmlfontify-dir-purge-on-quit' "
"-- :VARIABLE `*mon-purge-htmlfontify-dir-on-quit*' null")))
(and (or (and (intern-soft "*emacs2html-temp*")
(bound-and-true-p *emacs2html-temp*))
(mon-format :w-fun #'error
:w-spec '(":FUNCTION `mon-htmlfontify-dir-purge-on-quit' "
"-- :VARIABLE `*emacs2html-temp*' null or not present")))
(or (file-exists-p *emacs2html-temp*)
(mon-format :w-fun #'error
:w-spec '(":FUNCTION `mon-htmlfontify-dir-purge-on-quit' "
"-- :VARIABLE `*emacs2html-temp*' does not satisfy `file-exists-p'")))
(or (file-directory-p *emacs2html-temp*)
(mon-format :w-fun #'error
:w-spec '(":FUNCTION `mon-htmlfontify-dir-purge-on-quit' "
"-- :VARIABLE `*emacs2html-temp*' does not satisfy `file-directory-p'")))))
(let ((cln-emacs2html-temp
(directory-files *emacs2html-temp* t "emacs2firefox-.*\.html~?")))
(dolist (prg cln-emacs2html-temp)
(unless (car (file-attributes prg))
(delete-file prg))))))
(defun mon-htmlfontify-buffer-to-firefox ()
"Convert fontified buffer to an HTML file display it with Firefox.\n
:SEE `hfy-tags-cache', `hfy-load-tags-cache', `hfy-etags-cmd', `hfy-parse-tags-buffer'
:SEE-ALSO `mon-htmlfontify-region-to-firefox', `*emacs2html-temp*',
`mon-html-fontify-generate-file-name', `*mon-html-fontify-file-name-template*',
`mon-htmlfontify-dir-purge-on-quit'.\n►►►"
(interactive)
(let* ((ffox-fname (mon-html-fontify-generate-file-name))
(this-bfr-file (buffer-file-name))
(this-bfr-dir
(when this-bfr-file
(directory-file-name (file-name-directory this-bfr-file))))
(this-bfr-has-TAGS
(when this-bfr-dir
(car (member "TAGS" (directory-files this-bfr-dir)))))
h-fnty-bfr)
(with-current-buffer
(get-buffer
(if this-bfr-has-TAGS
(setq h-fnty-bfr (htmlfontify-buffer this-bfr-dir this-bfr-file))
(setq h-fnty-bfr (htmlfontify-buffer))))
(set (make-local-variable 'delete-auto-save-files) t)
(set (make-local-variable 'backup-inhibited) t)
(setq h-fnty-bfr (current-buffer))
(write-file ffox-fname))
(when (get-buffer h-fnty-bfr)
(kill-buffer h-fnty-bfr))
(browse-url-firefox (format "file:///%s" ffox-fname))))
(defun mon-htmlfontify-region-to-firefox (fontify-from fontify-to)
"Convert fontified region to an html file and display it with Firefox.\n
:SEE-ALSO `mon-htmlfontify-region-to-firefox',
`mon-htmlfontify-dir-purge-on-quit', `mon-html-fontify-generate-file-name',
`*mon-html-fontify-file-name-template*', `*emacs2html-temp*'.\n►►►"
(interactive "r")
(let ((ffox-rg-fname (mon-html-fontify-generate-file-name))
mhr2f-fontify-this
h-fnty-bfr)
(setq mhr2f-fontify-this
(buffer-substring fontify-from fontify-to))
(unwind-protect
(with-current-buffer (get-buffer-create ffox-rg-fname)
(set (make-local-variable 'delete-auto-save-files) t)
(set (make-local-variable 'backup-inhibited) t)
(insert mhr2f-fontify-this)
(emacs-lisp-mode)
(setq h-fnty-bfr (htmlfontify-buffer))
(write-file ffox-rg-fname)
(kill-buffer (get-buffer ffox-rg-fname)))
(when (get-buffer h-fnty-bfr)
(kill-buffer (get-buffer h-fnty-bfr))))
(browse-url-firefox (format "file:///%s" ffox-rg-fname))))
)
(defun mon-hexcolor-add-to-font-lock ()
"Add font-lock keywords for hex code color values for fontification.\n
:SEE-ALSO `mon-string-from-hex-list', `mon-string-to-hex-list',
`mon-string-to-hex-string', `mon-string-to-hex-list-cln-chars',
`hexl-hex-string-to-integer', `url-hexify-string', `url-unhex-string',
`url-unhex', `*regexp-hexcolor-keywords*', `*regexp-rgb-hex*',
`*css-color:hex-chars*', `*regexp-rgb-hex*', `*regexp-css-color-hex*', .\n►►►"
(font-lock-add-keywords nil *regexp-hexcolor-keywords*))
(defun mon-url-encode (url-enc-str &optional insrtp intrp)
"Return the encoded url string URL-ENC-STR.\n
When optional arg INSRTP is non-nil or called-interactively insert return value
at point. Moves point.\n
:EXAMPLE\n\n\(mon-url-encode
\"www.encode-me.com/ cash$<change[@+make:some|steal&&lie]\"\)\n
:ALIASED-BY `mon-url-escape'\n
:ALIASED-BY `mon-encode-url'\n
:SEE-ALSO `mon-url-decode', `url-insert-entities-in-string',
`url-unhex', `url-unhex-string', `url-hexify-string'.\n►►►"
(interactive "s:FUNCTION `mon-url-encode' -- URL-encode: \ni\p")
(let ((mud-encd (url-hexify-string url-enc-str)))
(if (or intrp insrtp)
(insert (format " %s " mud-encd))
mud-encd)))
(defun mon-url-decode (url-dec-str &optional insrtp intrp)
"Return the decoded url string URL-DEC-STR.\n
When optional arg insrtp is non-nil or called-interactively insert return value
at point. Moves point.\n
:EXAMPLE\n\n\(mon-url-decode
\"www.encode-me.com%2f%20cash%24%3cchange%5b%40%2bmake%3asome%7csteal%26%26lie%5d\"\)\n
\(mon-url-decode
\(mon-url-encode \"www.encode-me.com/ cash$<change[@+make:some|steal&&lie]\"\)\)\n
:ALIASED-BY `mon-url-unescape'\n
:ALIASED-BY `mon-decode-url'\n
:SEE-ALSO `mon-url-encode', `url-insert-entities-in-string', `url-unhex',
`url-unhex-string', `url-hexify-string'.\n►►►"
(interactive "s:FUNCTION `mon-url-decode' -- URL-decode: \ni\p")
(let ((mud-decd (decode-coding-string (url-unhex-string url-dec-str) 'utf-8)))
(if (or insrtp intrp)
(insert (format " %s " mud-decd))
mud-decd)))
(defun mon-search-ulan (&optional w-ulan-query)
"Open ULAN in web browser.\n
When W-ULAN-QUERY is non-nil search the ULAN artist name.\n
When the region is active search ULAN for name between point and mark. Attempts to rotate
the nameform intelligently to catch one of three different configurations:\n
A\) Lastname \(Firstname\)
B\) Lastname, Firstname
C\) Firstname Lastname\n
A, B, and C are each transformed to ==> Lastname%2C+Fristname and then wrapped
for ULAN query to \(URL `http://www.getty.edu/vow/ULANFullDisplay?find='\).\n When region
is not active and W-ULAN-QUERY is ommitted or null open a blank ULAN query in browser at:\n
\(URL `http://www.getty.edu/research/conducting_research/vocabularies/ulan/'\)\n
:EXAMPLE\n\n\(mon-search-ulan\)\n
\(mon-search-ulan \"Pyle, Howard\"\)\n
\(mon-search-ulan t\)\n
:NOTE for an interactive version which automatically defaults to a prompt for
ULAN name to search use: `mon-search-ulan-for-name'.\n
:SEE-ALSO `mon-search-wikipedia', `mon-search-loc', `mon-search-bnf'.\nUsed in `naf-mode'.\n►►►"
(interactive "p")
(let* ((use-empty-active-region nil)
(msu-base (cdr (assoc 'ulan *mon-url-search-paths*)))
(msu-uqp (cond
((and w-ulan-query (not (use-region-p)) (stringp w-ulan-query))
(concat msu-base
(replace-regexp-in-string
", " "%2C+"
(read-string (concat ":FUCNTION `mon-search-ulan' "
"-- Artist Name to Query \"Lastname, Firstname\"?: "))
"&role=&page=1&nation=")))
((stringp w-ulan-query)
(concat msu-base
(replace-regexp-in-string ", " "%2C+" w-ulan-query t)
"&role=&page=1&nation="))
((and w-ulan-query (use-region-p) (not (stringp w-ulan-query))) t)
((and w-ulan-query (not (use-region-p)))
(mon-format :w-fun #'error
:w-spec '(":FUNCTION `mon-search-ulan' "
" -- arg W-ULAN-QUERY not a string and no active-region")))))
(msu-rgn-url (when (and (use-region-p) (not (stringp msu-uqp)))
(buffer-substring-no-properties (region-beginning) (region-end))))
(msu-tst-rgn (when msu-rgn-url
(save-match-data
(cond ((string-match
"\\(\\([A-Z][a-z]+\\)\\([[:blank:]](\\)\\([A-Z][a-z]+\\)\\()\\)\\)" msu-rgn-url)
(concat (match-string 2 msu-rgn-url) "%2C+" (match-string 4 msu-rgn-url)))
((string-match
"\\(\\([A-Z][a-z]+\\)\\(,[[:blank:]]\\)\\([A-Z][a-z]+\\)\\)" msu-rgn-url)
(concat (match-string 2 msu-rgn-url) "%2C+" (match-string 4 msu-rgn-url)))
((string-match
"\\(\\([A-Z][a-z]+\\)\\([[:blank:]]\\)\\([A-Z][a-z]+\\)\\)" msu-rgn-url)
(concat (match-string 4 msu-rgn-url) "%2C+" (match-string 2 msu-rgn-url)))))))
(msu-bld-url (when msu-tst-rgn
(concat msu-base
msu-tst-rgn "&role=&page=1&nation=")))
(msu-ulan-url (cond (msu-bld-url msu-bld-url)
(msu-uqp msu-uqp)
((and (not msu-bld-url) (not msu-uqp))
(cdr (assoc 'ulan-flbk *mon-url-search-paths*))))))
(browse-url-firefox msu-ulan-url)))
(defun mon-search-ulan-for-name ()
"Interactive version of `mon-search-ulan'.
Default behavior is to prompt for name to search.\n
:SEE-ALSO `mon-search-wikipedia'.\nUsed in `naf-mode'.\n►►►"
(interactive)
(mon-search-ulan t))
(defun mon-search-wikipedia (&optional wiki-word)
"Look up word or phrase on Wikipedia.\n
Generate a url from with the a word or phrase in the active region
opens it in a browser.\n
When optional arg WIKI-WORD is non-nil use it instead.
:EXAMPLE\n\n(mon-search-wikipedia \"monkey meat\")\n
:SEE-ALSO `mon-search-ulan', `mon-search-ulan-for-name',
`mon-search-loc', `mon-search-bnf'.\n\nUsed in `naf-mode'.►►►"
(interactive "s:FUNCTION `mon-search-wikipedia' -- search wiki for: ")
(let ((msw-word wiki-word))
(when (null msw-word)
(setq msw-word
(if (use-region-p)
(mon-buffer-sub-no-prop (region-beginning) (region-end))
(thing-at-point 'symbol))))
(setq msw-word
(concat (cdr (assoc 'wiki *mon-url-search-paths*))
(replace-regexp-in-string " " "_" msw-word t)))
(browse-url msw-word)))
(defun mon-search-loc ()
"Open the LOC Authority Headings Search Page in the default browser.\n
:SEE \(URL `http://authorities.loc.gov/cgi-bin/Pwebrecon.cgi?DB=local&PAGE=First')\n
:USED-IN `naf-mode'.
:SEE-ALSO `*mon-url-search-paths*', `mon-search-ulan',
`mon-search-ulan-for-name', `mon-search-bnf', `mon-search-wikipedia'.\n►►►"
(interactive)
(or (and (intern-soft "*mon-url-search-paths*" obarray)
(bound-and-true-p *mon-url-search-paths*) t)
(mon-format :w-fun #'error
:w-spec '(":FUNCTION `mon-search-loc' "
"-- :VARIABLE `*mon-url-search-paths*' null or not present")))
(browse-url (cdr (assoc 'loc *mon-url-search-paths*))))
(defun mon-search-bnf ()
"Open the BNF Authority Headings Search Page in the default browser.\n
:SEE \(URL `http://catalogue.bnf.fr/jsp/recherche_autorites_bnf.jsp?host=catalogue')\n
:USED-IN `naf-mode'.\n
:SEE-ALSO `*mon-url-search-paths*', `mon-search-ulan',
`mon-search-ulan-for-name', `mon-search-loc', `mon-search-wikipedia'.\n►►►"
(interactive)
(or (and (intern-soft "*mon-url-search-paths*" obarray)
(bound-and-true-p *mon-url-search-paths*) t)
(mon-format :w-fun #'error
:w-spec '(":FUNCTION `mon-search-bnf' "
"-- :VARIABLE `*mon-url-search-paths*' null or not present")))
(browse-url (cdr (assoc 'bnf *mon-url-search-paths*))))
(defun mon-insert-dbc-link ()
"Insert a vanilla (relative path) href template at point.
Inserts the following:\n
<a class=\"link_green_bold\" href=\"../insert-path-here\" \"> insert-link-text </a>\n
Link will be colored according to to DBC .css for link_gree_bold.\n
:USED-IN `naf-mode'.\n
For a pre-formatted href to doc-detail page:
:SEE `mon-insert-dbc-doc-link'
:SEE-ALSO .\n►►►"
(interactive)
(insert "<a class=\"link_green_bold\" href=\"../insert-path-here\" \"> insert-link-text </a>"))
(defun mon-insert-dbc-doc-link (&optional doc-num doc-type link-text)
"Insert a vanilla \(relative path\) href template at point.\n
Called interactively prompts for:
DOC-NUM (a 3-4 digit number), default is \"####\";
DOC-TYPE (artist, author, brand, book, people), default is \"naf-type\";
LINK-TEXT (text with .css class \"link_green_bold\") default is \" insert link text \".
Inserts:\n
<a class=\"link_green_bold\" href=\"../doc-details-DOC-NUM-DOC-TYPE.htm\" \">LINK-TEXT</a>\n
:NOTE CSS .link_green_bold is:\n
,----
| .link_green_bold {
| font-family: Verdana, Arial, Helvetica, sans-serif;
| font-size: 9px;
| color: #5A8F5D;
| font-weight:bold;
| }
`----\n
:USED-IN `naf-mode'.\n
:SEE-ALSO `mon-insert-dbc-link'.\n►►►"
(interactive "n3-4 digit document number:\nsDoc's NAF type:\nsText for link title: ")
(let* ((dn (if (and doc-num)
doc-num
"####"))
(dt (if (and doc-type)
(downcase doc-type)
"naf-type"))
(lt (if (and link-text)
link-text
" insert link text "))
(dbc-url (format
(concat "<a class=\"link_green_bold\""
"href=\"../doc-details-%d-%s.htm\" \">%s</a>")
dn dt lt)))
(insert dbc-url)))
(defun mon-wrap-one-url (&optional intrp)
"Wrap 1\(one\)the URL _after point_ with \(URL `<SOME-URL>'\).\n
Conditional prefix matching regexps in variable `*regexp-wrap-url-schemes*'.
Won't replace recursively on pre-existing wrapped URLs.\n
Utilizes `thing-at-point' to wrap Uniform Resource Identifers per the 'uri arg
and is therefor dependent on the variables:\n
`thing-at-point-uri-schemes'\n `thing-at-point-url-path-regexp'
`thing-at-point-short-url-regexp'\n `thing-at-point-url-regexp'\n
:SEE (URL `http://www.rfc-editor.org/rfc/rfc4395.txt')\n
:SEE (URL `http://www.iana.org/assignments/uri-schemes.html')\n
:SEE-ALSO `mon-wrap-all-urls', `thing-at-point-url-at-point',
`mon-wrap-url', `mon-wrap-text', `mon-wrap-span', `mon-wrap-with',
`mon-wrap-selection'.\n►►►"
(interactive "p")
(save-excursion
(let* ((thing-at-point-url-regexp *regexp-wrap-url-schemes*)
(mwou-bnds (bounds-of-thing-at-point 'url))
(mwou-bnd-beg (car mwou-bnds))
(mwou-bnd-end (cdr mwou-bnds))
(mwou-rplc-url nil))
(if mwou-bnds
(progn
(setq mwou-rplc-url
(concat "(URL `" (mon-buffer-sub-no-prop mwou-bnd-beg mwou-bnd-end) "')"))
(goto-char mwou-bnd-beg)
(delete-region mwou-bnd-beg mwou-bnd-end)
(insert mwou-rplc-url))
(let ((skpabl (concat "^" url-get-url-filename-chars ","))
myb)
(if (and (or (setq myb (url-get-url-at-point))
(> (skip-chars-forward skpabl (line-end-position)) 0)
(< (skip-chars-backward skpabl (line-beginning-position)) 0))
(or myb (setq myb (url-get-url-at-point))))
(cond ((looking-at-p myb)
(delete-region (point) (+ (point) (length myb)))
(insert (concat "(URL `" myb "')")))
(t (goto-char (line-beginning-position))
(search-forward-regexp myb (line-end-position) t)
(replace-match (concat "(URL `" myb "')"))))
(when intrp
(mon-message :msg-fun 'minibuffer-message
:msg-spec '(":FUNCTION `mon-wrap-one-url' "
"-- can not find a URL to wrap at point: %d")
:msg-args (point)))))))))
(defun mon-wrap-all-urls ()
"Wraps all URLs in buffer _after point_ with \(URL `<SOME-URL>'\).\n
Matches are per the regexp in variable `*regexp-wrap-url-schemes*'.\n
Won't replace recursively on pre-existing wrapped URLs.\n
:EXAMPLE\(with-temp-buffer
\(save-excursion \(insert \"http://www.somethign.xomthing.com/blotto\\n\"
\"ftp://some.site.com\\n\"
\"git://repo.or.cz/w/sbcl.git\\n\"\)\)
\(mon-wrap-all-urls\)
\(buffer-substring-no-properties \(buffer-end 0\)\(buffer-end 1\)\)\)=n
:SEE-ALSO `thing-at-point-url-at-point', `mon-wrap-url', `mon-wrap-text',
`mon-wrap-span', `mon-wrap-selection', `mon-wrap-with'.\n►►►"
(interactive)
(let ((thing-at-point-url-regexp *regexp-wrap-url-schemes*))
(save-excursion
(while
(if (search-forward-regexp *regexp-wrap-url-schemes* nil t)
(let* ((mwau-bnds (bounds-of-thing-at-point 'url))
(mwau-bnd-beg (car mwau-bnds))
(mwau-bnd-end (cdr mwau-bnds))
(mwau-bnd-pre (and mwau-bnds (- mwau-bnd-beg 6)))
(mwau-thng-at (when mwau-bnds (thing-at-point-url-at-point)))
(mwau-rplc-url (concat "(URL `" mwau-thng-at "')")))
(with-no-warnings
(cond ((and mwau-bnd-pre (< mwau-bnd-pre 0))
(delete-region mwau-bnd-beg mwau-bnd-end)
(insert mwau-rplc-url)
(skip-syntax-forward "^w"))
((and mwau-bnd-pre
(not (string-match-p "(URL `"
(mon-buffer-sub-no-prop mwau-bnd-pre mwau-bnd-beg))))
(skip-syntax-backward "^-")
(delete-region mwau-bnd-beg mwau-bnd-end)
(insert mwau-rplc-url)
(skip-syntax-forward "^w"))))))))))
(defun mon-wrap-url ()
"Make thing at cursor point into an HTML link.\n
:EXAMPLE\n http://wikipedia.org\nbecomes:\n
<a href=\"http://en.wikipedia.org/\">http://wikipedia.org/</a>\n
Or:\n'test' becomes <a href=\"test\">test</a>\n
:SEE-ALSO `mon-wrap-all-urls', `mon-wrap-one-url', `*regexp-wrap-url-schemes*',
`thing-at-point-url-at-point',`mon-wrap-text', `mon-wrap-span',
`mon-wrap-selection', `mon-wrap-with'.\n►►►"
(interactive)
(search-backward-regexp "[\n\t ()]" nil t)
(looking-at "[\n\t ()]?\\([^\n\t ()]+\\)")
(let ((mwu-p1 (match-beginning 1))
(mwu-p2 (match-end 1))
(mwu-url (match-string 1)))
(delete-region mwu-p1 mwu-p2)
(goto-char mwu-p1)
(insert "<a href=\"" mwu-url "\">" mwu-url "</a>" )))
(defun mon-wrap-span ()
"Wrap a HTML <span> tag around current word or region.
Uses MON's link_green_bold CSS.\n
:EXAMPLE\n
,----
| .link_green_bold {
| font-family: Verdana, Arial, Helvetica, sans-serif;
| font-size: 9px;
| color: #5A8F5D;
| font-weight:bold;
| }
`----\n
:SEE-ALSO `mon-wrap-selection', `mon-wrap-text', `mon-wrap-with',
`mon-wrap-url', `mon-wrap-all-urls'.\n►►►"
(interactive)
(mon-wrap-text "<span class=\"link_green_bold\">" "</span>"))
(defun mon-make-html-table-string (textblock delim)
"Turn a text string into an HTML table.\n
Helper function for `mon-make-html-table'.\n
:EXAMPLE
\(mon-make-html-table-string
\(mon-string-justify-left
\(car \(mon-string-wonkify
\"THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS''
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR\" 1\)\) 18 4\)\"A\"\)\n :)
:SEE-ALSO .\n►►►"
(let (
(mmhts-txtblk textblock)
(mmhts-dlm delim))
(setq mmhts-txtblk
(replace-regexp-in-string mmhts-dlm "</td><td>" mmhts-txtblk))
(setq mmhts-txtblk
(replace-regexp-in-string "\n" "</td></tr>\n<tr><td>" mmhts-txtblk))
(setq mmhts-txtblk (substring mmhts-txtblk 0 -8))
(concat "<table border=\"1\""
"cellpadding=\"5\""
"cellspacing=\"0\">\n<tr><td>"
mmhts-txtblk
"</table>")))
(defun mon-make-html-table (col-sep)
"Turn the current paragraph into a HTML table.
Where \"current paragraph\" has empty lines before and after the block of
text after point.\n
:EXAMPLE
With \"-\" as separator transforms this:\n
a-b-c\n 1-2-3\n this-and-that\n
Into the following html table:\n
<table border=\"1\" cellpadding=\"5\" cellspacing=\"0\">
<tr><td>a</td><td>b</td><td>c</td></tr>
<tr><td>1</td><td>2</td><td>3</td></tr>
<tr><td>this</td><td>and</td><td>that</td></tr>\n </table>\n
:SEE-ALSO `mon-make-html-table-string'.\n►►►"
(interactive "s:FUNCTION `mon-make-html-table' -- enter string pattern for column separation: ")
(let (mmht-bnds mmht-par1 mmht-par2 mmht-str)
(setq mmht-bnds (bounds-of-thing-at-point 'paragraph))
(setq mmht-par1 (+ (car mmht-bnds) 1))
(setq mmht-par2 (cdr mmht-bnds))
(setq mmht-str (buffer-substring-no-properties mmht-par1 mmht-par2))
(delete-region mmht-par1 mmht-par2)
(insert (mon-make-html-table-string mmht-str col-sep) "\n")))
(defun mon-url-retrieve-to-new-buffer (fetch-this-url)
"Returbrn FETCH-THIS-URL displayed in an new buffer-window.\n
Fetches URL as with `url-retrieve-synchronously'.\n
:EXAMPLE\n\n\(mon-url-retrieve-to-new-buffer
\"http://tools.ietf.org/rfc/rfc2822.txt\")\n
:ALIASED-BY `mon-buffer-get-retrieved-url'\n
:SEE-ALSO `url-copy-file', `url-retrieve', `url-retrieve-synchronously',
`url-http', `mon-get-w3m-url-at-point-maybe', `google-define',
`mon-get-host-address', `mon-url-encode', `mon-url-decode',
`mon-get-w3m-url-at-point', `mon-w3m-dired-file'.\n►►►"
(let ((murtnb-bfr (url-retrieve-synchronously fetch-this-url)))
(when (get-buffer murtnb-bfr) (display-buffer murtnb-bfr t))))
(defun mon-get-host-address (name-or-number)
"Return IP host name or address corresponding to NAME-OR-NUMBER using host\(1\).
If the arg is an IP number, return the host name, else return the address
corresponding to the host name arg.\n
:EXAMPLE\n\(mon-get-host-address \"google.com\"\)\n
:SEE-ALSO `mon-url-retrieve-to-new-buffer'.\n►►►"
(if (string-match-p "^[[:digit:]]+\\(\\.[[:digit:]]+\\)\\{3\\}$" name-or-number)
name-or-number
(let ((str (shell-command-to-string
(concat "host " (shell-quote-argument name-or-number)))))
(string-match "\\s-+\\([[:digit:]]+\\(\\.[[:digit:]]+\\)\\{3\\}\\)$" str)
(match-string 1 str))))
(defun mon-w3m-dired-file (&optional file-to-w3m)
"Browse dired file at point with w3m.\n
:ALIASED-BY `mon-get-w3m-dired-file'\n
:SEE-ALSO `mon-w3m-kill-url-at-point', `mon-get-w3m-url-at-point-maybe',
`mon-get-w3m-url-at-point', `mon-w3m-read-gnu-lists-nxt-prv',
`mon-copy-file-dired-as-list', `mon-copy-file-dired-as-string',
`dired-get-marked-files', `mon-keybind-w3m', `mon-set-w3m-init'.\n►►►"
(interactive)
(w3m-find-file
(or file-to-w3m (car (dired-get-marked-files)))))
(defun mon-w3m-kill-url-at-point ()
"Put the w3m URL at point on the kill ring.\n
Examines for URL with `get-text-property' the 'w3m-href-anchor property if found
the property value on the kill ring and message user.\n
:SEE-ALSO `mon-get-w3m-dired-file', `mon-get-w3m-url-at-point-maybe',
`mon-get-w3m-url-at-point', `mon-w3m-read-gnu-lists-nxt-prv',
`w3m-print-this-url', `mon-get-w3m-url-at-point-maybe',
`mon-get-w3m-url-at-point', `mon-keybind-w3m', `mon-set-w3m-init'.\n►►►"
(interactive)
(let ((w3mgtp (get-text-property (point) 'w3m-href-anchor)))
(when (and w3mgtp (stringp w3mgtp))
(kill-new w3mgtp)
(message w3mgtp))))
(defun mon-get-w3m-url-at-point-maybe ()
"Return two elt list as \(MEHTOD \"URL\"\) when text-properties at point has
w3m-href-anchor value and is a 'file 'http 'https.\n
:ALIASED-BY `mon-w3m-get-url-at-point-maybe'\n
:SEE-ALSO `mon-get-w3m-url-at-point', `mon-w3m-read-gnu-lists-nxt-prv',
`mon-w3m-dired-file', `w3m-print-this-url', `mon-get-w3m-url-at-point-maybe',
`mon-get-w3m-url-at-point', `mon-keybind-w3m', `mon-set-w3m-init'.\n►►►"
(let* ((is-url (get-text-property (point) 'w3m-href-anchor))
(match-with "\\(file\\|http\\|https\\)")
(is-match (and (stringp is-url)
(string-match match-with is-url)))
(got-match (and (and is-url is-match)
(match-string-no-properties 0 is-url))))
(if got-match
(cond ((string= got-match "file") `(file ,is-url))
((string= got-match "http") `(http ,is-url))
((string= got-match "https") `(https ,is-url))
(t nil)))))
(defun mon-get-w3m-url-at-point (&optional insrtp buffer intrp)
"Return w3m-href-anchor value and its type/method as file, http, or https.\n
Return value has the form:\n
\(<TYPE/METHOD> <\"URL-STRING\">\)\n
When INSRTP in non-nil and BUFFER names an existing buffer insert the w3m URL in
BUFFER. If BUFFER is nil or does no exist return URL.\n
:ALIASED-BY `mon-w3m-get-url-at-point'\n
:SEE-ALSO `mon-get-w3m-url-at-point-maybe', `mon-w3m-read-gnu-lists-nxt-prv',
`mon-w3m-kill-url-at-point', `mon-w3m-dired-file', `w3m-print-this-url',
`mon-get-w3m-url-at-point-maybe', `mon-get-w3m-url-at-point',
`mon-keybind-w3m', `mon-set-w3m-init'.\n►►►"
(interactive "i\ni\np")
(let ((url-maybe (mon-get-w3m-url-at-point-maybe))
(do-buff (if buffer (get-buffer buffer))))
(when url-maybe
(cond (intrp (princ (cadr url-maybe)))
((and insrtp do-buff)
(save-excursion
(princ (concat "\n" (cadr url-maybe)) do-buff)))
(t url-maybe)))))
(defun mon-w3m-goto-url-at-point (&optional w-new-session w-intrp-msg intrp)
"Find the w3m URL at point in a new or existing w3m session.\n
When a URL is at point return URL as a list if by `mon-get-w3m-url-at-point-maybe'.\n
When optional arg W-NEW-SESSION is non-nil find url as if by `w3m-goto-url-new-session'.
Default is to find the url as if by `w3m-goto-url'.
When optional arg W-INTRP-MSG is non-nil or called-interactively and there is
not a URL at point message the user as such.\n
:SEE-ALSO `mon-get-w3m-url-at-point', `w3m-find-file'.\n►►►"
(interactive "P\ni\np")
(let* ((u-at-pnt (mon-get-w3m-url-at-point-maybe))
(u-at-pnt-p (cadr u-at-pnt)))
(cond ((and u-at-pnt-p w-new-session)
(w3m-goto-url-new-session u-at-pnt-p))
(u-at-pnt-p (w3m-goto-url u-at-pnt-p))
((or w-intrp-msg intrp)
(mon-message :msg-fun #'minibuffer-message
:msg-spec '(":FUNCTION `mon-w3m-goto-url-at-point' "
"-- can't find URL at point: %d")
:msg-args (point))))
(when u-at-pnt u-at-pnt)))
(defun mon-w3m-read-gnu-lists-nxt-prv (prev next)
"Browse GNU mailing lists with w3m selecting next in thread prev in thread.\n
:ALIASED-BY `mon-get-w3m-read-gnu-lists-nxt-prv'\n
:SEE \(URL `http://lists.gnu.org/archive/html/emacs-devel/'\)
:SEE \(URL `http://lists.gnu.org'\)\n
:SEE-ALSO `mon-get-w3m-url-at-point', `mon-get-w3m-url-at-point-maybe',
`mon-w3m-dired-file', `w3m-print-this-url', `mon-get-w3m-url-at-point-maybe',
`mon-get-w3m-url-at-point', `mon-keybind-w3m', `mon-set-w3m-init'.\n►►►"
(let ((nxt-prev-p
(save-match-data
(and (save-excursion
(mon-g2be -1)
(search-forward-regexp
(cond (prev "Prev in Thread")
(next "Next in Thread"))
nil t))
(match-end 0)))))
(if nxt-prev-p
(progn
(goto-char (1- nxt-prev-p))
(let ((is-http (mon-get-w3m-url-at-point-maybe)))
(if (equal (cadr is-http) w3m-current-url)
(cond (prev (message "No previous in thread"))
(next (message "No next in thread" )))
(if (eq (car is-http) 'http)
(prog1
(message (cadr is-http))
(w3m-view-this-url))
(message
(cond (prev (message "Can't locate previous in thread"))
(next (message "Can't locate next in thread")))))))))))
(defcustom *mon-tld-list* nil
"Hash table associating list of TLDs per ISO-3166 codes.\n
:NOTE Country abbreviations are per ISO 3166 spec. There is an U.S. FIPS that
specifies a different set of two-letter country abbreviations.
Updated by the RIPE Network Coordination Centre.
:SOURCE ISO 3166 Maintenance Agency - :VERSION 2007-11-15.
:SEE \(URL `http://www.iso.org/iso/en/prods-services/iso3166ma/02iso-3166-code-lists/list-en1-semic.txt');
:SEE \(URL `http://www.iana.org/domain-names.htm');
:SEE \(URL `http://www.iana.org/cctld/cctld-whois.htm').\n
:SEE-ALSO `mon-tld-find-name', `mon-tld-tld', `mon-tld-find-tld', `mon-tld-name', `mon-tld'.\n►►►"
:type 'sexp
:group 'mon-regexp-symbols)
(unless (and (intern-soft "*mon-tld-list*" obarray)
(bound-and-true-p *mon-tld-list*))
(setq *mon-tld-list*
(mon-hash-from-alist
'(
("AC" . "Ascension Island")
("AD" . "Andorra")
("AE" . "United Arab Emirates")
("AF" . "Afghanistan")
("AG" . "Antigua and Barbuda")
("AI" . "Anguilla")
("AL" . "Albania")
("AM" . "Armenia")
("AN" . "Netherlands Antilles")
("AO" . "Angola")
("AQ" . "Antarctica")
("AR" . "Argentina")
("AS" . "American Samoa")
("AT" . "Austria")
("AU" . "Australia")
("AW" . "Aruba")
("AX" . "Aland Islands")
("AZ" . "Azerbaijan")
("BA" . "Bosnia-Herzegovina")
("BB" . "Barbados")
("BD" . "Bangladesh")
("BE" . "Belgium")
("BF" . "Burkina Faso")
("BG" . "Bulgaria")
("BH" . "Bahrain")
("BI" . "Burundi")
("BJ" . "Benin")
("BL" . "Saint Barthelemy")
("BM" . "Bermuda")
("BN" . "Brunei Darussalam")
("BO" . "Bolivia")
("BR" . "Brazil")
("BS" . "Bahamas")
("BT" . "Bhutan")
("BV" . "Bouvet Island")
("BW" . "Botswana")
("BY" . "Belarus")
("BZ" . "Belize")
("CA" . "Canada")
("CC" . "Cocos (Keeling) Islands")
("CD" . "Congo")
("CF" . "Central African Republic")
("CG" . "Congo")
("CH" . "Switzerland")
("CI" . "Ivory Coast")
("CK" . "Cook Islands")
("CL" . "Chile")
("CM" . "Cameroon")
("CN" . "China")
("CO" . "Colombia")
("CR" . "Costa Rica")
("CU" . "Cuba")
("CV" . "Cape Verde")
("CX" . "Christmas Island")
("CY" . "Cyprus")
("CZ" . "Czech Republic")
("DE" . "Germany")
("DJ" . "Djibouti")
("DK" . "Denmark")
("DM" . "Dominica")
("DO" . "Dominican Republic")
("DZ" . "Algeria")
("EC" . "Ecuador")
("EE" . "Estonia")
("EG" . "Egypt")
("EH" . "Western Sahara")
("ER" . "Eritrea")
("ES" . "Spain")
("ET" . "Ethiopia")
("EU" . "European Union")
("FI" . "Finland")
("FJ" . "Fiji")
("FK" . "Falkland Islands (Malvinas)")
("FM" . "Micronesia")
("FO" . "Faroe Islands")
("FR" . "France")
("GA" . "Gabon")
("GB" . "United Kingdom")
("GD" . "Grenada")
("GE" . "Georgia")
("GF" . "French Guiana")
("GG" . "Guernsey")
("GH" . "Ghana")
("GI" . "Gibraltar")
("GL" . "Greenland")
("GM" . "Gambia")
("GN" . "Guinea")
("GP" . "Guadeloupe (Fr.)")
("GQ" . "Equatorial Guinea")
("GR" . "Greece")
("GS" . "South Georgia and The South Sandwich Islands")
("GT" . "Guatemala")
("GU" . "Guam (U.S.)")
("GW" . "Guinea-Bissau")
("GY" . "Guyana")
("HK" . "Hong Kong")
("HM" . "Heard Island and Mcdonald Islands")
("HN" . "Honduras")
("HR" . "Croatia")
("HT" . "Haiti")
("HU" . "Hungary")
("ID" . "Indonesia")
("IE" . "Ireland")
("IL" . "Israel")
("IM" . "Isle of Man")
("IN" . "India")
("IO" . "British Indian Ocean Territory")
("IQ" . "Iraq")
("IR" . "Iran")
("IS" . "Iceland")
("IT" . "Italy")
("JE" . "Jersey")
("JM" . "Jamaica")
("JO" . "Jordan")
("JP" . "Japan")
("KE" . "Kenya")
("KG" . "Kyrgyzstan")
("KH" . "Cambodia")
("KI" . "Kiribati")
("KM" . "Comoros")
("KN" . "Saint Kitts and Nevis")
("KP" . "Korea (North)")
("KR" . "Korea (South)")
("KW" . "Kuwait")
("KY" . "Cayman Islands")
("KZ" . "Kazakhstan")
("LA" . "Lao People's Democratic Republic")
("LB" . "Lebanon")
("LC" . "Saint Lucia")
("LI" . "Liechtenstein")
("LK" . "Sri Lanka")
("LR" . "Liberia")
("LS" . "Lesotho")
("LT" . "Lithuania")
("LU" . "Luxembourg")
("LV" . "Latvia")
("LY" . "Libyan Arab Jamahiriya")
("MA" . "Morocco")
("MC" . "Monaco")
("MD" . "Moldova")
("ME" . "Montenegro")
("MF" . "Saint Martin (French part)")
("MG" . "Madagascar")
("MH" . "Marshall Islands")
("MK" . "Macedonia")
("ML" . "Mali")
("MM" . "Myanmar")
("MN" . "Mongolia")
("MO" . "Macao")
("MP" . "Northern Mariana Islands")
("MQ" . "Martinique")
("MR" . "Mauritania")
("MS" . "Montserrat")
("MT" . "Malta")
("MU" . "Mauritius")
("MV" . "Maldives")
("MW" . "Malawi")
("MX" . "Mexico")
("MY" . "Malaysia")
("MZ" . "Mozambique")
("NA" . "Namibia")
("NC" . "New Caledonia (Fr.)")
("NE" . "Niger")
("NF" . "Norfolk Island")
("NG" . "Nigeria")
("NI" . "Nicaragua")
("NL" . "Netherlands")
("NO" . "Norway")
("NP" . "Nepal")
("NR" . "Nauru")
("NU" . "Niue")
("NZ" . "New Zealand")
("OM" . "Oman")
("PA" . "Panama")
("PE" . "Peru")
("PF" . "French Polynesia")
("PG" . "Papua New Guinea")
("PH" . "Philippines")
("PK" . "Pakistan")
("PL" . "Poland")
("PM" . "Saint Pierre and Miquelon")
("PN" . "Pitcairn")
("PR" . "Puerto Rico (U.S.)")
("PS" . "Palestinian Territory, Occupied")
("PT" . "Portugal")
("PW" . "Palau")
("PY" . "Paraguay")
("QA" . "Qatar")
("RE" . "Reunion (Fr.)")
("RO" . "Romania")
("RS" . "Serbia")
("RU" . "Russia")
("RW" . "Rwanda")
("SA" . "Saudi Arabia")
("SB" . "Solomon Islands")
("SC" . "Seychelles")
("SD" . "Sudan")
("SE" . "Sweden")
("SG" . "Singapore")
("SH" . "Saint Helena")
("SI" . "Slovenia")
("SJ" . "Svalbard and Jan Mayen")
("SK" . "Slovakia")
("SL" . "Sierra Leone")
("SM" . "San Marino")
("SN" . "Senegal")
("SO" . "Somalia")
("SR" . "Suriname")
("ST" . "Sao Tome and Principe")
("SU" . "U.S.S.R.")
("SV" . "El Salvador")
("SY" . "Syrian Arab Republic")
("SZ" . "Swaziland")
("TC" . "Turks and Caicos Islands")
("TD" . "Chad")
("TF" . "French Southern Territories")
("TG" . "Togo")
("TH" . "Thailand")
("TJ" . "Tajikistan")
("TK" . "Tokelau")
("TL" . "East Timor")
("TM" . "Turkmenistan")
("TN" . "Tunisia")
("TO" . "Tonga")
("TP" . "East Timor")
("TR" . "Turkey")
("TT" . "Trinidad and Tobago")
("TV" . "Tuvalu")
("TW" . "Taiwan")
("TZ" . "Tanzania" )
("UA" . "Ukraine")
("UG" . "Uganda")
("UK" . "United Kingdom")
("UM" . "United States Minor Outlying Islands")
("US" . "United States")
("UY" . "Uruguay")
("UZ" . "Uzbekistan")
("VA" . "Holy See (Vatican City State)")
("VC" . "Saint Vincent and the Grenadines")
("VE" . "Venezuela")
("VG" . "Virgin Islands, British")
("VI" . "Virgin Islands, U.S.")
("VN" . "Vietnam")
("VU" . "Vanuatu")
("WF" . "Wallis and Futuna")
("WS" . "Samoa")
("YE" . "Yemen")
("YT" . "Mayotte")
("YU" . "Yugoslavia")
("ZA" . "South Africa")
("ZM" . "Zambia")
("ZW" . "Zimbabwe")
("AERO" . "Air Transport Industry")
("ASIA" . "Pan-Asia and Asia Pacific community")
("BIZ" . "Businesses")
("CAT" . "Catalan language and culture")
("COM" . "Commercial")
("COOP" . "Cooperative Associations")
("INFO" . "Info")
("JOBS" . "Employment")
("MOBI" . "Mobile products")
("MUSEUM" . "Museums")
("NAME" . "Individuals")
("NET" . "Network")
("ORG" . "Non-profit Organization")
("PRO" . "Credentialed professionals")
("TEL" . "Contact data")
("TRAVEL" . "Travel industry")
("GOV" . "United States Government")
("EDU" . "Educational")
("MIL" . "United States Military")
("INT" . "International Treaties")
("UUCP" . "Unix to Unix CoPy")
("ARPA" . "Advanced Research Projects Agency (U.S. DoD)"))))
(custom-note-var-changed '*mon-tld-list*))
(defsubst mon-tld-tld (tld)
"Return the TLD portion of a TLD pair.\n
:SEE-ALSO `mon-tld-find-name',`mon-tld-find-tld', `mon-tld-name',
`mon-tld',`*mon-tld-list*'.\n►►►"
(car tld))
(defsubst mon-tld-name (tld)
"Return the name portion of a TLD pair.\n
:SEE-ALSO `mon-tld-find-name', `mon-tld-tld', `mon-tld-find-tld',
`mon-tld',`*mon-tld-list*'.\n►►►"
(cdr tld))
(defun mon-tld-find-tld (tld)
"Lookup a TLD.\n
If found a (TLD . NAME) pair is returned.\n
:SEE-ALSO `mon-tld-find-name', `mon-tld-tld',`mon-tld-name', `mon-tld',
`*mon-tld-list*'.\n►►►"
(assoc-string (upcase tld) *mon-tld-list*) t)
(defun mon-tld-find-name (name)
"Lookup a TLD name. Returns a list of hits.\n
:SEE-ALSO `mon-tld-tld', `mon-tld-find-tld', `mon-tld-name', `mon-tld',
`*mon-tld-list*'.\n►►►"
(let ((case-fold-search t))
(loop for tld in *mon-tld-list*
when (string-match-p name (mon-tld-name tld))
collect tld)))
(defun mon-tld (search-tld)
"Search `*mon-tld-list*' for SEARCH-TLD.\n
:EXAMPLE\n\n\(mon-tld \"UUCP\"\)\n
\(call-interactively 'mon-tld\)\n
:SEE-ALSO `mon-tld-find-name', `mon-tld-tld', `mon-tld-find-tld', `mon-tld-name',
`*mon-tld-list*'.\n►►►"
(interactive "s:FUNCTION `mon-tld' -- search TLD: ")
(let* ((mtld-lkup (string= (substring search-tld 0 1) "."))
(mtld-rslt (if mtld-lkup
(mon-tld-find-tld (substring search-tld 1))
(mon-tld-find-name search-tld))))
(if mtld-rslt
(flet ((message-tld (msg-tld)
(message "%s is %s" (mon-tld-tld msg-tld) (mon-tld-name msg-tld))))
(if mtld-lkup
(message-tld mtld-rslt)
(if (= (length mtld-rslt) 1)
(message-tld (car mtld-rslt))
(with-output-to-temp-buffer "*MON-TLD*"
(princ "TLD Name\n====== ========================================\n\n")
(loop for mltd-loop-tlds in mtld-rslt
do (princ (format "%-6s %s\n"
(mon-tld-tld mltd-loop-tlds)
(mon-tld-name mltd-loop-tlds))))))))
(if (and (not mtld-lkup) (< (length search-tld) 7))
(mon-tld (concat "." search-tld))
(mon-format :w-fun #'error
:w-spec ":FUNCTION `mon-tld' -- no matches for SEARCH-TLD found")))))
(provide 'mon-url-utils)