[bpt/emacs.git] / lisp / net / webjump.el

;;; webjump.el --- programmable Web hotlist

;; Copyright (C) 1996, 1997, 2001, 2002, 2003, 2004,
;;   2005, 2006, 2007 Free Software Foundation, Inc.

;; Author:    Neil W. Van Dyke <nwv@acm.org>
;; Created:   09-Aug-1996
;; Keywords:  comm www

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;; WebJump provides a sort of ``programmable hotlist'' of Web sites that can
;; quickly be invoked in your Web browser.  Each Web site in the hotlist has a
;; name, and you select the desired site name via a completing string prompt in
;; the minibuffer.  The URL for each Web site is defined as a static string or
;; a built-in or custom function, allowing interactive prompting for
;; site-specific queries and options.

;; Note that WebJump was originally intended to complement your conventional
;; browser-based hotlist, not replace it.  (Though there's no reason you
;; couldn't use WebJump for your entire hotlist if you were so inclined.)

;; The `webjump-sites' variable, which defines the hotlist, defaults to some
;; example sites.  You'll probably want to override it with your own favorite
;; sites.  The documentation for the variable describes the syntax.

;; You may wish to add something like the following to your `.emacs' file:
;;
;;   (require 'webjump)
;;   (global-set-key "\C-cj" 'webjump)
;;   (setq webjump-sites
;;         (append '(
;;                   ("My Home Page" . "www.someisp.net/users/joebobjr/")
;;                   ("Pop's Site"   . "www.joebob-and-son.com/")
;;                   )
;;                 webjump-sample-sites))
;;
;; The above loads this package, binds `C-c j' to invoke WebJump, and adds your
;; personal favorite sites to the hotlist.

;; The `webjump-sample-sites' variable mostly contains some site entries that
;; are expected to be generally relevant to many users, but excluding
;; those that the GNU project would not want to recommend.

;; The `browse-url' package is used to submit URLs to the browser, so any
;; browser-specific configuration should be done there.

;;; Code:

;;-------------------------------------------------------- Package Dependencies

(require 'browse-url)

;;------------------------------------------------------------------- Constants

(defvar webjump-sample-sites
  '(
    ;; FSF, not including Emacs-specific.
    ("GNU Project FTP Archive" .
     ;; GNU FTP Mirror List from http://www.gnu.org/order/ftp.html
     [mirrors "ftp://ftp.gnu.org/pub/gnu/"
              ;; United States
              "ftp://mirrors.kernel.org/gnu"
              "ftp://gatekeeper.dec.com/pub/GNU/"
              "ftp://ftp.keystealth.org/pub/gnu/"
              "ftp://mirrors.usc.edu/pub/gnu/"
              "ftp://cudlug.cudenver.edu/pub/mirrors/ftp.gnu.org/"
              "ftp://ftp.cise.ufl.edu/pub/mirrors/GNU/"
              "ftp://uiarchive.cso.uiuc.edu/pub/ftp/ftp.gnu.org/gnu/"
              "ftp://gnu.cs.lewisu.edu/gnu/"
              "ftp://ftp.in-span.net/pub/mirrors/ftp.gnu.org/"
              "ftp://gnu.ms.uky.edu/pub/mirrors/gnu/"
              "ftp://ftp.algx.net/pub/gnu/"
              "ftp://aeneas.mit.edu/pub/gnu/"
              "ftp://ftp.egr.msu.edu/pub/gnu/"
              "ftp://ftp.wayne.edu/pub/gnu/"
              "ftp://wuarchive.wustl.edu/mirrors/gnu/"
              "ftp://gnu.teleglobe.net/ftp.gnu.org/"
              "ftp://ftp.cs.columbia.edu/archives/gnu/prep/"
              "ftp://ftp.ece.cornell.edu/pub/mirrors/gnu/"
              "ftp://ftp.ibiblio.org/pub/mirrors/gnu/"
              "ftp://ftp.cis.ohio-state.edu/mirror/gnu/"
              "ftp://ftp.club.cc.cmu.edu/gnu/"
              "ftp://ftp.sunsite.utk.edu/pub/gnu/ftp/"
              "ftp://thales.memphis.edu/pub/gnu/"
              "ftp://gnu.wwc.edu"
              "ftp://ftp.twtelecom.net/pub/GNU/"
              ;; Africa
              "ftp://ftp.sun.ac.za/mirrorsites/ftp.gnu.org"
              ;; The Americas
              "ftp://ftp.unicamp.br/pub/gnu/"
              "ftp://master.softaplic.com.br/pub/gnu/"
              "ftp://ftp.matrix.com.br/pub/gnu/"
              "ftp://ftp.pucpr.br/gnu"
              "ftp://ftp.linorg.usp.br/gnu"
              "ftp://ftp.cs.ubc.ca/mirror2/gnu/"
              "ftp://cs.ubishops.ca/pub/ftp.gnu.org/"
              "ftp://ftp.inf.utfsm.cl/pub/gnu/"
              "ftp://sunsite.ulatina.ac.cr/Mirrors/GNU/"
              "ftp://www.gnu.unam.mx/pub/gnu/software/"
              "ftp://gnu.cem.itesm.mx/pub/mirrors/gnu.org/"
              "ftp://ftp.azc.uam.mx/mirrors/gnu/"
              ;; Australia
              "ftp://mirror.aarnet.edu.au/pub/gnu/"
              "ftp://gnu.mirror.pacific.net.au/gnu/"
              ;; Asia
              "ftp://ftp.cs.cuhk.edu.hk/pub/gnu/gnu/"
              "ftp://sunsite.ust.hk/pub/gnu/"
              "ftp://ftp.gnupilgrims.org/pub/gnu"
              "ftp://www.imtech.res.in/mirror/gnuftp/"
              "ftp://kambing.vlsm.org/gnu"
              "ftp://ftp.cs.huji.ac.il/mirror/GNU/"
              "ftp://tron.um.u-tokyo.ac.jp/pub/GNU/"
              "ftp://core.ring.gr.jp/pub/GNU/"
              "ftp://ftp.ring.gr.jp/pub/GNU/"
              "ftp://mirrors.hbi.co.jp/gnu/"
              "ftp://ftp.cs.titech.ac.jp/pub/gnu/"
              "ftp://ftpmirror.hanyang.ac.kr/GNU/"
              "ftp://ftp.linux.sarang.net/mirror/gnu/gnu/"
              "ftp://ftp.xgate.co.kr/pub/mirror/gnu/"
              "ftp://ftp://gnu.xinicks.com/"
              "ftp://ftp.isu.net.sa/pub/gnu/"
              "ftp://ftp.nctu.edu.tw/UNIX/gnu/"
              "ftp://coda.nctu.edu.tw/UNIX/gnu/"
              "ftp://ftp1.sinica.edu.tw/pub3/GNU/gnu/"
              "ftp://gnu.cdpa.nsysu.edu.tw/gnu"
              "ftp://ftp.nectec.or.th/pub/mirrors/gnu/"
              ;; Europe
              "ftp://ftp.gnu.vbs.at/"
              "ftp://ftp.univie.ac.at/packages/gnu/"
              "ftp://gd.tuwien.ac.at/gnu/gnusrc/"
              "ftp://ftp.belnet.be/mirror/ftp.gnu.org/"
              "ftp://gnu.blic.net/pub/gnu/"
              "ftp://ftp.fi.muni.cz/pub/gnu/"
              "ftp://ftp.dkuug.dk/pub/gnu/"
              "ftp://sunsite.dk/mirrors/gnu"
              "ftp://ftp.funet.fi/pub/gnu/prep/"
              "ftp://ftp.irisa.fr/pub/gnu/"
              "ftp://ftp.cs.univ-paris8.fr/mirrors/ftp.gnu.org/"
              "ftp://ftp.cs.tu-berlin.de/pub/gnu/"
              "ftp://ftp.leo.org/pub/comp/os/unix/gnu/"
              "ftp://ftp.informatik.rwth-aachen.de/pub/gnu/"
              "ftp://ftp.de.uu.net/pub/gnu/"
              "ftp://ftp.freenet.de/pub/ftp.gnu.org/gnu/"
              "ftp://ftp.cs.uni-bonn.de/pub/gnu/"
              "ftp://ftp-stud.fht-esslingen.de/pub/Mirrors/ftp.gnu.org/"
              "ftp://ftp.stw-bonn.de/pub/mirror/ftp.gnu.org/"
              "ftp://ftp.math.uni-bremen.de/pub/gnu"
              "ftp://ftp.forthnet.gr/pub/gnu/"
              "ftp://ftp.ntua.gr/pub/gnu/"
              "ftp://ftp.duth.gr/pub/gnu/"
              "ftp://ftp.physics.auth.gr/pub/gnu/"
              "ftp://ftp.esat.net/pub/gnu/"
              "ftp://ftp.heanet.ie/mirrors/ftp.gnu.org"
              "ftp://ftp.lugroma2.org/pub/gnu/"
              "ftp://ftp.gnu.inetcosmos.org/pub/gnu/"
              "ftp://ftp.digitaltrust.it/pub/gnu"
              "ftp://ftp://rm.mirror.garr.it/mirrors/gnuftp"
              "ftp://ftp.nluug.nl/pub/gnu/"
              "ftp://ftp.mirror.nl/pub/mirror/gnu/"
              "ftp://ftp.nl.uu.net/pub/gnu/"
              "ftp://mirror.widexs.nl/pub/gnu/"
              "ftp://ftp.easynet.nl/mirror/GNU/"
              "ftp://ftp.win.tue.nl/pub/gnu"
              "ftp://gnu.mirror.vuurwerk.net/pub/GNU/"
              "ftp://gnu.kookel.org/pub/ftp.gnu.org/"
              "ftp://ftp.uninett.no/pub/gnu/"
              "ftp://ftp.task.gda.pl/pub/gnu/"
              "ftp://sunsite.icm.edu.pl/pub/gnu/"
              "ftp://ftp.man.poznan.pl/pub/gnu"
              "ftp://ftp.ist.utl.pt/pub/GNU/gnu/"
              "ftp://ftp.telepac.pt/pub/gnu/"
              "ftp://ftp.timisoara.roedu.net/mirrors/ftp.gnu.org/pub/gnu"
              "ftp://ftp.chg.ru/pub/gnu/"
              "ftp://gnuftp.axitel.ru/"
              "ftp://ftp.arnes.si/software/gnu/"
              "ftp://ftp.etsimo.uniovi.es/pub/gnu/"
              "ftp://ftp.rediris.es/pub/gnu/"
              "ftp://ftp.chl.chalmers.se/pub/gnu/"
              "ftp://ftp.isy.liu.se/pub/gnu/"
              "ftp://ftp.luth.se/pub/unix/gnu/"
              "ftp://ftp.stacken.kth.se/pub/gnu/"
              "ftp://ftp.sunet.se/pub/gnu/"
              "ftp://sunsite.cnlab-switch.ch/mirror/gnu/"
              "ftp://ftp.ulak.net.tr/gnu/"
              "ftp://ftp.gnu.org.ua"
              "ftp://ftp.mcc.ac.uk/pub/gnu/"
              "ftp://ftp.mirror.ac.uk/sites/ftp.gnu.org/gnu/"
              "ftp://ftp.warwick.ac.uk/pub/gnu/"
              "ftp://ftp.hands.com/ftp.gnu.org/"
              "ftp://gnu.teleglobe.net/ftp.gnu.org/"])
    ("GNU Project Home Page" . "www.gnu.org")

    ;; Emacs.
    ("Emacs Home Page" .
     "www.gnu.org/software/emacs/emacs.html")
    ("Savannah Emacs page" .
     "savannah.gnu.org/projects/emacs")
    ("Emacs Lisp List" .
     "www.damtp.cam.ac.uk/user/eglen/emacs/ell.html")
    ("Emacs Wiki" .
     [simple-query "www.emacswiki.org"
		   "www.emacswiki.org/cgi-bin/wiki/" ""])

    ;; Internet search engines.
    ("Google" .
     [simple-query "www.google.com"
		   "www.google.com/search?q=" ""])
    ("Google Groups" .
     [simple-query "groups.google.com"
		   "groups.google.com/groups?q=" ""])
    ("Yahoo" .
     [simple-query "www.yahoo.com" "search.yahoo.com/search?p=" ""])
    ("Yahoo: Reference" . "www.yahoo.com/Reference/")

    ;; Misc. general interest.
    ("Interactive Weather Information Network" . webjump-to-iwin)
    ("Usenet FAQs" .
     "www.faqs.org/faqs/")
    ("RTFM Usenet FAQs by Group" .
     "ftp://rtfm.mit.edu/pub/usenet-by-group/")
    ("RTFM Usenet FAQs by Hierachy" .
     "ftp://rtfm.mit.edu/pub/usenet-by-hierarchy/")
    ("X Consortium Archive" . "ftp.x.org")

    ;; Computer social issues, privacy, professionalism.
    ("Association for Computing Machinery" . "www.acm.org")
    ("Computer Professionals for Social Responsibility" . "www.cpsr.org")
    ("Electronic Frontier Foundation" . "www.eff.org")
    ("IEEE Computer Society" . "www.computer.org")
    ("Risks Digest" . webjump-to-risks)

    ;; More.
    ("Supplemental Web site list for webjump" .
     "www.neilvandyke.org/webjump/")

    )
  "Sample hotlist for WebJump.  See the documentation for the `webjump'
function and the `webjump-sites' variable.")

(defvar webjump-state-to-postal-alist
  '(("Alabama" . "al") ("Alaska" . "ak") ("Arizona" . "az") ("Arkansas" . "ar")
    ("California" . "ca") ("Colorado" . "co") ("Connecticut" . "ct")
    ("Delaware" . "de") ("Florida" . "fl") ("Georgia" . "ga") ("Hawaii" . "hi")
    ("Idaho" . "id") ("Illinois" . "il") ("Indiana" . "in") ("Iowa" . "ia")
    ("Kansas" . "ks") ("Kentucky" . "ky") ("Louisiana" . "la") ("Maine" . "me")
    ("Maryland" . "md") ("Massachusetts" . "ma") ("Michigan" . "mi")
    ("Minnesota" . "mn") ("Mississippi" . "ms") ("Missouri" . "mo")
    ("Montana" . "mt") ("Nebraska" . "ne") ("Nevada" . "nv")
    ("New Hampshire" . "nh") ("New Jersey" . "nj") ("New Mexico" . "nm")
    ("New York" . "ny") ("North Carolina" . "nc") ("North Dakota" . "nd")
    ("Ohio" . "oh") ("Oklahoma" . "ok") ("Oregon" . "or")
    ("Pennsylvania" . "pa") ("Rhode Island" . "ri") ("South Carolina" . "sc")
    ("South Dakota" . "sd") ("Tennessee" . "tn") ("Texas" . "tx")
    ("Utah" . "ut") ("Vermont" . "vt") ("Virginia" . "va")
    ("Washington" . "wa") ("West Virginia" . "wv") ("Wisconsin" . "wi")
    ("Wyoming" . "wy")))

;;------------------------------------------------------------ Option Variables

(defvar webjump-sites
  webjump-sample-sites
  "*Hotlist for WebJump.

The hotlist is represented as an association list, with the CAR of each cell
being the name of the Web site, and the CDR being the definition for the URL of
that site.  The URL definition can be a string (the URL), a vector (specifying
a special \"builtin\" which returns a URL), a symbol (name of a function which
returns a URL), or a list (which when `eval'ed yields a URL).

If the URL definition is a vector, then a \"builtin\" is used.  A builtin has a
Lisp-like syntax, with the name as the first element of the vector, and any
arguments as the following elements.  The three current builtins are `name',
which returns the name of the site as the URL, `simple-query', which
returns a URL that is a function of a query entered by the user, and `mirrors',
which allows the user to select from among multiple mirror sites for the same
content.

The first argument to the `simple-query' builtin is a static URL to use if the
user enters a blank query.  The second and third arguments are the prefix and
suffix, respectively, to add to the encoded query the user enters.  This
builtin covers Web sites that have single-string searches with the query
embedded in the URL.

The arguments to the `mirrors' builtin are URLs of mirror sites.

If the symbol of a function is given, then the function will be called with the
Web site name (the one you specified in the CAR of the alist cell) as a
parameter.  This might come in handy for various kludges.

For convenience, if the `http://', `ftp://', or `file://' prefix is missing
from a URL, WebJump will make a guess at what you wanted and prepend it before
submitting the URL.")

;;------------------------------------------------------- Sample Site Functions

(defun webjump-to-iwin (name)
  (let ((prefix "http://iwin.nws.noaa.gov/")
        (state (webjump-read-choice name "state"
                                    (append '(("Puerto Rico" . "pr"))
                                            webjump-state-to-postal-alist))))
    (if state
        (concat prefix "iwin/" state "/"
                (webjump-read-choice name "option"
                                     '(("Hourly Report" . "hourly")
                                       ("State Forecast" . "state")
                                       ("Local Forecast" . "local")
                                       ("Zone Forecast" . "zone")
                                       ("Short-Term Forecast" . "shortterm")
                                       ("Weather Summary" . "summary")
                                       ("Public Information" . "public")
                                       ("Climatic Data" . "climate")
                                       ("Aviation Products" . "aviation")
                                       ("Hydro Products" . "hydro")
                                       ("Special Weather" . "special")
                                       ("Watches and Warnings" . "warnings"))
                                     "zone")
                ".html")
      prefix)))

(defun webjump-to-risks (name)
  (let (issue volume)
    (if (and (setq volume (webjump-read-number (concat name " volume")))
	     (setq issue  (webjump-read-number (concat name " issue"))))
	(format "catless.ncl.ac.uk/Risks/%d.%02d.html" volume issue)
      "catless.ncl.ac.uk/Risks/")))

;;-------------------------------------------------------------- Core Functions

;;;###autoload
(defun webjump ()
  "Jumps to a Web site from a programmable hotlist.

See the documentation for the `webjump-sites' variable for how to customize the
hotlist.

Please submit bug reports and other feedback to the author, Neil W. Van Dyke
<nwv@acm.org>."
  (interactive)
  (let* ((completion-ignore-case t)
	 (item (assoc-string
		(completing-read "WebJump to site: " webjump-sites nil t)
		webjump-sites t))
	 (name (car item))
	 (expr (cdr item)))
    (browse-url (webjump-url-fix
		 (cond ((not expr) "")
		       ((stringp expr) expr)
		       ((vectorp expr) (webjump-builtin expr name))
		       ((listp expr) (eval expr))
		       ((symbolp expr)
			(if (fboundp expr)
			    (funcall expr name)
			  (error "WebJump URL function \"%s\" undefined"
				 expr)))
		       (t (error "WebJump URL expression for \"%s\" invalid"
				 name)))))))

(defun webjump-builtin (expr name)
  (if (< (length expr) 1)
      (error "WebJump URL builtin for \"%s\" empty" name))
  (let ((builtin (aref expr 0)))
    (cond
     ((eq builtin 'mirrors)
      (if (= (length expr) 1)
          (error
           "WebJump URL builtin \"mirrors\" for \"%s\" needs at least 1 arg"
	   name))
      (webjump-choose-mirror name (cdr (append expr nil))))
     ((eq builtin 'name)
      name)
     ((eq builtin 'simple-query)
      (webjump-builtin-check-args expr name 3)
      (webjump-do-simple-query name (aref expr 1) (aref expr 2) (aref expr 3)))
     (t (error "WebJump URL builtin \"%s\" for \"%s\" invalid"
	       builtin name)))))

(defun webjump-builtin-check-args (expr name count)
  (or (= (length expr) (1+ count))
      (error "WebJump URL builtin \"%s\" for \"%s\" needs %d args"
	     (aref expr 0) name count)))

(defun webjump-choose-mirror (name urls)
  (webjump-read-url-choice (concat name " mirror")
                           urls
                           (webjump-mirror-default urls)))

(defun webjump-do-simple-query (name noquery-url query-prefix query-suffix)
  (let ((query (webjump-read-string (concat name " query"))))
    (if query
	(concat query-prefix (webjump-url-encode query) query-suffix)
      noquery-url)))

(defun webjump-mirror-default (urls)
  ;; Note: This should be modified to apply some simple kludges/heuristics to
  ;; pick a site which is likely "close".  As a tie-breaker among candidates
  ;; judged equally desirable, randomness might be used.
  (car urls))

(defun webjump-read-choice (name what choices &optional default)
  (let* ((completion-ignore-case t)
         (choice (completing-read (concat name " " what ": ") choices nil t)))
    (if (webjump-null-or-blank-string-p choice)
        default
      (cdr (assoc choice choices)))))

(defun webjump-read-number (prompt)
  ;; Note: I should make this more robust someday.
  (let ((input (webjump-read-string prompt)))
    (if input (string-to-number input))))

(defun webjump-read-string (prompt)
  (let ((input (read-string (concat prompt ": "))))
    (if (webjump-null-or-blank-string-p input) nil input)))

(defun webjump-read-url-choice (what urls &optional default)
  ;; Note: Convert this to use `webjump-read-choice' someday.
  (let* ((completions (mapcar (function (lambda (n) (cons n n)))
                              urls))
	 (input (completing-read (concat what
                                         ;;(if default " (RET for default)" "")
                                         ": ")
                                 completions
                                 nil
                                 t)))
    (if (webjump-null-or-blank-string-p input)
        default
      (car (assoc input completions)))))

(defun webjump-null-or-blank-string-p (str)
  (or (null str) (string-match "^[ \t]*$" str)))

(defun webjump-url-encode (str)
  (mapconcat '(lambda (c)
		(cond ((= c 32) "+")
		      ((or (and (>= c ?a) (<= c ?z))
			   (and (>= c ?A) (<= c ?Z))
			   (and (>= c ?0) (<= c ?9)))
		       (char-to-string c))
		      (t (upcase (format "%%%02x" c)))))
	     str
	     ""))

(defun webjump-url-fix (url)
  (if (webjump-null-or-blank-string-p url)
      ""
    (webjump-url-fix-trailing-slash
     (cond
      ((string-match "^[a-zA-Z]+:" url) url)
      ((string-match "^/" url) (concat "file://" url))
      ((string-match "^\\([^\\./]+\\)" url)
       (concat (if (string= (downcase (match-string 1 url)) "ftp")
		   "ftp"
		 "http")
	       "://"
	       url))
      (t url)))))

(defun webjump-url-fix-trailing-slash (url)
  (if (string-match "^[a-zA-Z]+://[^/]+$" url)
      (concat url "/")
    url))

;;-----------------------------------------------------------------------------

(provide 'webjump)

;;; arch-tag: f1d20156-0a6f-488b-bd91-f69ee8b6d5cc
;;; webjump.el ends here
Commit	Line	Data
8749abea	1	;;; webjump.el --- programmable Web hotlist
a1506d29	2
f2e3589a	3	;; Copyright (C) 1996, 1997, 2001, 2002, 2003, 2004,
d7a0267c	4	;; 2005, 2006, 2007 Free Software Foundation, Inc.
8749abea GM	5
	6	;; Author: Neil W. Van Dyke <nwv@acm.org>
	7	;; Created: 09-Aug-1996
	8	;; Keywords: comm www
	9
	10	;; This file is part of GNU Emacs.
	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 the
3a35cf56 LK	24	;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
3a35cf56 LK	25	;; Boston, MA 02110-1301, USA.
8749abea GM	26
	27	;;; Commentary:
	28
	29	;; WebJump provides a sort of ``programmable hotlist'' of Web sites that can
	30	;; quickly be invoked in your Web browser. Each Web site in the hotlist has a
	31	;; name, and you select the desired site name via a completing string prompt in
	32	;; the minibuffer. The URL for each Web site is defined as a static string or
	33	;; a built-in or custom function, allowing interactive prompting for
	34	;; site-specific queries and options.
	35
	36	;; Note that WebJump was originally intended to complement your conventional
	37	;; browser-based hotlist, not replace it. (Though there's no reason you
	38	;; couldn't use WebJump for your entire hotlist if you were so inclined.)
	39
	40	;; The `webjump-sites' variable, which defines the hotlist, defaults to some
	41	;; example sites. You'll probably want to override it with your own favorite
	42	;; sites. The documentation for the variable describes the syntax.
	43
	44	;; You may wish to add something like the following to your `.emacs' file:
	45	;;
	46	;; (require 'webjump)
	47	;; (global-set-key "\C-cj" 'webjump)
	48	;; (setq webjump-sites
	49	;; (append '(
	50	;; ("My Home Page" . "www.someisp.net/users/joebobjr/")
	51	;; ("Pop's Site" . "www.joebob-and-son.com/")
	52	;; )
	53	;; webjump-sample-sites))
	54	;;
	55	;; The above loads this package, binds `C-c j' to invoke WebJump, and adds your
	56	;; personal favorite sites to the hotlist.
	57
	58	;; The `webjump-sample-sites' variable mostly contains some site entries that
	59	;; are expected to be generally relevant to many users, but excluding
	60	;; those that the GNU project would not want to recommend.
	61
	62	;; The `browse-url' package is used to submit URLs to the browser, so any
	63	;; browser-specific configuration should be done there.
	64
	65	;;; Code:
	66
	67	;;-------------------------------------------------------- Package Dependencies
	68
	69	(require 'browse-url)
	70
	71	;;------------------------------------------------------------------- Constants
	72
	73	(defvar webjump-sample-sites
	74	'(
8749abea GM	75	;; FSF, not including Emacs-specific.
8749abea GM	76	("GNU Project FTP Archive" .
2122c750	77	;; GNU FTP Mirror List from http://www.gnu.org/order/ftp.html
8749abea	78	[mirrors "ftp://ftp.gnu.org/pub/gnu/"
2122c750 JL	79	;; United States
	80	"ftp://mirrors.kernel.org/gnu"
	81	"ftp://gatekeeper.dec.com/pub/GNU/"
	82	"ftp://ftp.keystealth.org/pub/gnu/"
	83	"ftp://mirrors.usc.edu/pub/gnu/"
	84	"ftp://cudlug.cudenver.edu/pub/mirrors/ftp.gnu.org/"
	85	"ftp://ftp.cise.ufl.edu/pub/mirrors/GNU/"
	86	"ftp://uiarchive.cso.uiuc.edu/pub/ftp/ftp.gnu.org/gnu/"
	87	"ftp://gnu.cs.lewisu.edu/gnu/"
	88	"ftp://ftp.in-span.net/pub/mirrors/ftp.gnu.org/"
	89	"ftp://gnu.ms.uky.edu/pub/mirrors/gnu/"
	90	"ftp://ftp.algx.net/pub/gnu/"
	91	"ftp://aeneas.mit.edu/pub/gnu/"
	92	"ftp://ftp.egr.msu.edu/pub/gnu/"
	93	"ftp://ftp.wayne.edu/pub/gnu/"
	94	"ftp://wuarchive.wustl.edu/mirrors/gnu/"
	95	"ftp://gnu.teleglobe.net/ftp.gnu.org/"
	96	"ftp://ftp.cs.columbia.edu/archives/gnu/prep/"
	97	"ftp://ftp.ece.cornell.edu/pub/mirrors/gnu/"
	98	"ftp://ftp.ibiblio.org/pub/mirrors/gnu/"
	99	"ftp://ftp.cis.ohio-state.edu/mirror/gnu/"
	100	"ftp://ftp.club.cc.cmu.edu/gnu/"
	101	"ftp://ftp.sunsite.utk.edu/pub/gnu/ftp/"
	102	"ftp://thales.memphis.edu/pub/gnu/"
	103	"ftp://gnu.wwc.edu"
	104	"ftp://ftp.twtelecom.net/pub/GNU/"
	105	;; Africa
	106	"ftp://ftp.sun.ac.za/mirrorsites/ftp.gnu.org"
	107	;; The Americas
	108	"ftp://ftp.unicamp.br/pub/gnu/"
	109	"ftp://master.softaplic.com.br/pub/gnu/"
	110	"ftp://ftp.matrix.com.br/pub/gnu/"
	111	"ftp://ftp.pucpr.br/gnu"
	112	"ftp://ftp.linorg.usp.br/gnu"
	113	"ftp://ftp.cs.ubc.ca/mirror2/gnu/"
	114	"ftp://cs.ubishops.ca/pub/ftp.gnu.org/"
	115	"ftp://ftp.inf.utfsm.cl/pub/gnu/"
	116	"ftp://sunsite.ulatina.ac.cr/Mirrors/GNU/"
	117	"ftp://www.gnu.unam.mx/pub/gnu/software/"
	118	"ftp://gnu.cem.itesm.mx/pub/mirrors/gnu.org/"
	119	"ftp://ftp.azc.uam.mx/mirrors/gnu/"
	120	;; Australia
	121	"ftp://mirror.aarnet.edu.au/pub/gnu/"
	122	"ftp://gnu.mirror.pacific.net.au/gnu/"
	123	;; Asia
	124	"ftp://ftp.cs.cuhk.edu.hk/pub/gnu/gnu/"
	125	"ftp://sunsite.ust.hk/pub/gnu/"
	126	"ftp://ftp.gnupilgrims.org/pub/gnu"
	127	"ftp://www.imtech.res.in/mirror/gnuftp/"
	128	"ftp://kambing.vlsm.org/gnu"
	129	"ftp://ftp.cs.huji.ac.il/mirror/GNU/"
	130	"ftp://tron.um.u-tokyo.ac.jp/pub/GNU/"
	131	"ftp://core.ring.gr.jp/pub/GNU/"
	132	"ftp://ftp.ring.gr.jp/pub/GNU/"
	133	"ftp://mirrors.hbi.co.jp/gnu/"
	134	"ftp://ftp.cs.titech.ac.jp/pub/gnu/"
	135	"ftp://ftpmirror.hanyang.ac.kr/GNU/"
	136	"ftp://ftp.linux.sarang.net/mirror/gnu/gnu/"
	137	"ftp://ftp.xgate.co.kr/pub/mirror/gnu/"
	138	"ftp://ftp://gnu.xinicks.com/"
	139	"ftp://ftp.isu.net.sa/pub/gnu/"
	140	"ftp://ftp.nctu.edu.tw/UNIX/gnu/"
	141	"ftp://coda.nctu.edu.tw/UNIX/gnu/"
	142	"ftp://ftp1.sinica.edu.tw/pub3/GNU/gnu/"
143	"ftp://gnu.cdpa.nsysu.edu.tw/gnu"
144	"ftp://ftp.nectec.or.th/pub/mirrors/gnu/"
145	;; Europe
146	"ftp://ftp.gnu.vbs.at/"
147	"ftp://ftp.univie.ac.at/packages/gnu/"
148	"ftp://gd.tuwien.ac.at/gnu/gnusrc/"
149	"ftp://ftp.belnet.be/mirror/ftp.gnu.org/"
150	"ftp://gnu.blic.net/pub/gnu/"
151	"ftp://ftp.fi.muni.cz/pub/gnu/"
152	"ftp://ftp.dkuug.dk/pub/gnu/"
153	"ftp://sunsite.dk/mirrors/gnu"
154	"ftp://ftp.funet.fi/pub/gnu/prep/"
155	"ftp://ftp.irisa.fr/pub/gnu/"
156	"ftp://ftp.cs.univ-paris8.fr/mirrors/ftp.gnu.org/"
157	"ftp://ftp.cs.tu-berlin.de/pub/gnu/"
158	"ftp://ftp.leo.org/pub/comp/os/unix/gnu/"
159	"ftp://ftp.informatik.rwth-aachen.de/pub/gnu/"
160	"ftp://ftp.de.uu.net/pub/gnu/"
161	"ftp://ftp.freenet.de/pub/ftp.gnu.org/gnu/"
162	"ftp://ftp.cs.uni-bonn.de/pub/gnu/"
163	"ftp://ftp-stud.fht-esslingen.de/pub/Mirrors/ftp.gnu.org/"
164	"ftp://ftp.stw-bonn.de/pub/mirror/ftp.gnu.org/"
165	"ftp://ftp.math.uni-bremen.de/pub/gnu"
166	"ftp://ftp.forthnet.gr/pub/gnu/"
167	"ftp://ftp.ntua.gr/pub/gnu/"
168	"ftp://ftp.duth.gr/pub/gnu/"
169	"ftp://ftp.physics.auth.gr/pub/gnu/"
170	"ftp://ftp.esat.net/pub/gnu/"
171	"ftp://ftp.heanet.ie/mirrors/ftp.gnu.org"
172	"ftp://ftp.lugroma2.org/pub/gnu/"
173	"ftp://ftp.gnu.inetcosmos.org/pub/gnu/"
174	"ftp://ftp.digitaltrust.it/pub/gnu"
175	"ftp://ftp://rm.mirror.garr.it/mirrors/gnuftp"
176	"ftp://ftp.nluug.nl/pub/gnu/"
177	"ftp://ftp.mirror.nl/pub/mirror/gnu/"
178	"ftp://ftp.nl.uu.net/pub/gnu/"
179	"ftp://mirror.widexs.nl/pub/gnu/"
180	"ftp://ftp.easynet.nl/mirror/GNU/"
8749abea	181	"ftp://ftp.win.tue.nl/pub/gnu"
2122c750 JL	182	"ftp://gnu.mirror.vuurwerk.net/pub/GNU/"
	183	"ftp://gnu.kookel.org/pub/ftp.gnu.org/"
	184	"ftp://ftp.uninett.no/pub/gnu/"
	185	"ftp://ftp.task.gda.pl/pub/gnu/"
	186	"ftp://sunsite.icm.edu.pl/pub/gnu/"
	187	"ftp://ftp.man.poznan.pl/pub/gnu"
	188	"ftp://ftp.ist.utl.pt/pub/GNU/gnu/"
	189	"ftp://ftp.telepac.pt/pub/gnu/"
	190	"ftp://ftp.timisoara.roedu.net/mirrors/ftp.gnu.org/pub/gnu"
	191	"ftp://ftp.chg.ru/pub/gnu/"
	192	"ftp://gnuftp.axitel.ru/"
	193	"ftp://ftp.arnes.si/software/gnu/"
	194	"ftp://ftp.etsimo.uniovi.es/pub/gnu/"
	195	"ftp://ftp.rediris.es/pub/gnu/"
	196	"ftp://ftp.chl.chalmers.se/pub/gnu/"
	197	"ftp://ftp.isy.liu.se/pub/gnu/"
	198	"ftp://ftp.luth.se/pub/unix/gnu/"
	199	"ftp://ftp.stacken.kth.se/pub/gnu/"
	200	"ftp://ftp.sunet.se/pub/gnu/"
	201	"ftp://sunsite.cnlab-switch.ch/mirror/gnu/"
	202	"ftp://ftp.ulak.net.tr/gnu/"
	203	"ftp://ftp.gnu.org.ua"
	204	"ftp://ftp.mcc.ac.uk/pub/gnu/"
	205	"ftp://ftp.mirror.ac.uk/sites/ftp.gnu.org/gnu/"
	206	"ftp://ftp.warwick.ac.uk/pub/gnu/"
	207	"ftp://ftp.hands.com/ftp.gnu.org/"
	208	"ftp://gnu.teleglobe.net/ftp.gnu.org/"])
8749abea GM	209	("GNU Project Home Page" . "www.gnu.org")
	210
	211	;; Emacs.
2122c750 JL	212	("Emacs Home Page" .
	213	"www.gnu.org/software/emacs/emacs.html")
	214	("Savannah Emacs page" .
	215	"savannah.gnu.org/projects/emacs")
	216	("Emacs Lisp List" .
	217	"www.damtp.cam.ac.uk/user/eglen/emacs/ell.html")
	218	("Emacs Wiki" .
	219	[simple-query "www.emacswiki.org"
	220	"www.emacswiki.org/cgi-bin/wiki/" ""])
8749abea GM	221
8749abea GM	222	;; Internet search engines.
2122c750 JL	223	("Google" .
	224	[simple-query "www.google.com"
	225	"www.google.com/search?q=" ""])
	226	("Google Groups" .
	227	[simple-query "groups.google.com"
	228	"groups.google.com/groups?q=" ""])
a1506d29	229	("Yahoo" .
2122c750 JL	230	[simple-query "www.yahoo.com" "search.yahoo.com/search?p=" ""])
2122c750 JL	231	("Yahoo: Reference" . "www.yahoo.com/Reference/")
8749abea GM	232
	233	;; Misc. general interest.
	234	("Interactive Weather Information Network" . webjump-to-iwin)
a1506d29	235	("Usenet FAQs" .
2122c750	236	"www.faqs.org/faqs/")
8749abea GM	237	("RTFM Usenet FAQs by Group" .
	238	"ftp://rtfm.mit.edu/pub/usenet-by-group/")
	239	("RTFM Usenet FAQs by Hierachy" .
	240	"ftp://rtfm.mit.edu/pub/usenet-by-hierarchy/")
	241	("X Consortium Archive" . "ftp.x.org")
8749abea GM	242
	243	;; Computer social issues, privacy, professionalism.
	244	("Association for Computing Machinery" . "www.acm.org")
2122c750	245	("Computer Professionals for Social Responsibility" . "www.cpsr.org")
8749abea GM	246	("Electronic Frontier Foundation" . "www.eff.org")
	247	("IEEE Computer Society" . "www.computer.org")
	248	("Risks Digest" . webjump-to-risks)
	249
2122c750 JL	250	;; More.
	251	("Supplemental Web site list for webjump" .
	252	"www.neilvandyke.org/webjump/")
8749abea GM	253
	254	)
	255	"Sample hotlist for WebJump. See the documentation for the `webjump'
	256	function and the `webjump-sites' variable.")
	257
	258	(defvar webjump-state-to-postal-alist
	259	'(("Alabama" . "al") ("Alaska" . "ak") ("Arizona" . "az") ("Arkansas" . "ar")
	260	("California" . "ca") ("Colorado" . "co") ("Connecticut" . "ct")
	261	("Delaware" . "de") ("Florida" . "fl") ("Georgia" . "ga") ("Hawaii" . "hi")
	262	("Idaho" . "id") ("Illinois" . "il") ("Indiana" . "in") ("Iowa" . "ia")
	263	("Kansas" . "ks") ("Kentucky" . "ky") ("Louisiana" . "la") ("Maine" . "me")
	264	("Maryland" . "md") ("Massachusetts" . "ma") ("Michigan" . "mi")
	265	("Minnesota" . "mn") ("Mississippi" . "ms") ("Missouri" . "mo")
	266	("Montana" . "mt") ("Nebraska" . "ne") ("Nevada" . "nv")
	267	("New Hampshire" . "nh") ("New Jersey" . "nj") ("New Mexico" . "nm")
	268	("New York" . "ny") ("North Carolina" . "nc") ("North Dakota" . "nd")
	269	("Ohio" . "oh") ("Oklahoma" . "ok") ("Oregon" . "or")
	270	("Pennsylvania" . "pa") ("Rhode Island" . "ri") ("South Carolina" . "sc")
	271	("South Dakota" . "sd") ("Tennessee" . "tn") ("Texas" . "tx")
	272	("Utah" . "ut") ("Vermont" . "vt") ("Virginia" . "va")
	273	("Washington" . "wa") ("West Virginia" . "wv") ("Wisconsin" . "wi")
	274	("Wyoming" . "wy")))
	275
	276	;;------------------------------------------------------------ Option Variables
	277
	278	(defvar webjump-sites
	279	webjump-sample-sites
	280	"*Hotlist for WebJump.
	281
	282	The hotlist is represented as an association list, with the CAR of each cell
	283	being the name of the Web site, and the CDR being the definition for the URL of
	284	that site. The URL definition can be a string (the URL), a vector (specifying
	285	a special \"builtin\" which returns a URL), a symbol (name of a function which
	286	returns a URL), or a list (which when `eval'ed yields a URL).
	287
	288	If the URL definition is a vector, then a \"builtin\" is used. A builtin has a
	289	Lisp-like syntax, with the name as the first element of the vector, and any
	290	arguments as the following elements. The three current builtins are `name',
	291	which returns the name of the site as the URL, `simple-query', which
	292	returns a URL that is a function of a query entered by the user, and `mirrors',
	293	which allows the user to select from among multiple mirror sites for the same
	294	content.
	295
	296	The first argument to the `simple-query' builtin is a static URL to use if the
	297	user enters a blank query. The second and third arguments are the prefix and
	298	suffix, respectively, to add to the encoded query the user enters. This
	299	builtin covers Web sites that have single-string searches with the query
	300	embedded in the URL.
	301
	302	The arguments to the `mirrors' builtin are URLs of mirror sites.
	303
	304	If the symbol of a function is given, then the function will be called with the
	305	Web site name (the one you specified in the CAR of the alist cell) as a
	306	parameter. This might come in handy for various kludges.
	307
	308	For convenience, if the `http://', `ftp://', or `file://' prefix is missing
	309	from a URL, WebJump will make a guess at what you wanted and prepend it before
	310	submitting the URL.")
	311
	312	;;------------------------------------------------------- Sample Site Functions
	313
	314	(defun webjump-to-iwin (name)
	315	(let ((prefix "http://iwin.nws.noaa.gov/")
	316	(state (webjump-read-choice name "state"
317	(append '(("Puerto Rico" . "pr"))
318	webjump-state-to-postal-alist))))
319	(if state
320	(concat prefix "iwin/" state "/"
321	(webjump-read-choice name "option"
322	'(("Hourly Report" . "hourly")
323	("State Forecast" . "state")
324	("Local Forecast" . "local")
325	("Zone Forecast" . "zone")
326	("Short-Term Forecast" . "shortterm")
327	("Weather Summary" . "summary")
328	("Public Information" . "public")
329	("Climatic Data" . "climate")
330	("Aviation Products" . "aviation")
331	("Hydro Products" . "hydro")
332	("Special Weather" . "special")
333	("Watches and Warnings" . "warnings"))
334	"zone")
335	".html")
336	prefix)))
337
338	(defun webjump-to-risks (name)
339	(let (issue volume)
340	(if (and (setq volume (webjump-read-number (concat name " volume")))
341	(setq issue (webjump-read-number (concat name " issue"))))
342	(format "catless.ncl.ac.uk/Risks/%d.%02d.html" volume issue)
343	"catless.ncl.ac.uk/Risks/")))
344
345	;;-------------------------------------------------------------- Core Functions
346
347	;;;###autoload
348	(defun webjump ()
349	"Jumps to a Web site from a programmable hotlist.
350
351	See the documentation for the `webjump-sites' variable for how to customize the
352	hotlist.
353
354	Please submit bug reports and other feedback to the author, Neil W. Van Dyke
355	<nwv@acm.org>."
356	(interactive)
357	(let* ((completion-ignore-case t)
af2c6038	358	(item (assoc-string
8749abea	359	(completing-read "WebJump to site: " webjump-sites nil t)
af2c6038	360	webjump-sites t))
8749abea GM	361	(name (car item))
	362	(expr (cdr item)))
	363	(browse-url (webjump-url-fix
	364	(cond ((not expr) "")
	365	((stringp expr) expr)
	366	((vectorp expr) (webjump-builtin expr name))
	367	((listp expr) (eval expr))
	368	((symbolp expr)
	369	(if (fboundp expr)
	370	(funcall expr name)
a1506d29	371	(error "WebJump URL function \"%s\" undefined"
8749abea	372	expr)))
e8af40ee	373	(t (error "WebJump URL expression for \"%s\" invalid"
8749abea GM	374	name)))))))
	375
	376	(defun webjump-builtin (expr name)
	377	(if (< (length expr) 1)
e8af40ee	378	(error "WebJump URL builtin for \"%s\" empty" name))
8749abea GM	379	(let ((builtin (aref expr 0)))
	380	(cond
	381	((eq builtin 'mirrors)
	382	(if (= (length expr) 1)
	383	(error
d7f9eef0 AS	384	"WebJump URL builtin \"mirrors\" for \"%s\" needs at least 1 arg"
d7f9eef0 AS	385	name))
8749abea GM	386	(webjump-choose-mirror name (cdr (append expr nil))))
	387	((eq builtin 'name)
	388	name)
	389	((eq builtin 'simple-query)
	390	(webjump-builtin-check-args expr name 3)
	391	(webjump-do-simple-query name (aref expr 1) (aref expr 2) (aref expr 3)))
e8af40ee	392	(t (error "WebJump URL builtin \"%s\" for \"%s\" invalid"
8749abea GM	393	builtin name)))))
	394
	395	(defun webjump-builtin-check-args (expr name count)
	396	(or (= (length expr) (1+ count))
e8af40ee	397	(error "WebJump URL builtin \"%s\" for \"%s\" needs %d args"
8749abea GM	398	(aref expr 0) name count)))
	399
	400	(defun webjump-choose-mirror (name urls)
	401	(webjump-read-url-choice (concat name " mirror")
	402	urls
	403	(webjump-mirror-default urls)))
	404
	405	(defun webjump-do-simple-query (name noquery-url query-prefix query-suffix)
	406	(let ((query (webjump-read-string (concat name " query"))))
	407	(if query
	408	(concat query-prefix (webjump-url-encode query) query-suffix)
	409	noquery-url)))
	410
	411	(defun webjump-mirror-default (urls)
	412	;; Note: This should be modified to apply some simple kludges/heuristics to
	413	;; pick a site which is likely "close". As a tie-breaker among candidates
	414	;; judged equally desirable, randomness might be used.
	415	(car urls))
	416
	417	(defun webjump-read-choice (name what choices &optional default)
	418	(let* ((completion-ignore-case t)
	419	(choice (completing-read (concat name " " what ": ") choices nil t)))
	420	(if (webjump-null-or-blank-string-p choice)
	421	default
	422	(cdr (assoc choice choices)))))
	423
	424	(defun webjump-read-number (prompt)
	425	;; Note: I should make this more robust someday.
	426	(let ((input (webjump-read-string prompt)))
	427	(if input (string-to-number input))))
a1506d29	428
8749abea GM	429	(defun webjump-read-string (prompt)
	430	(let ((input (read-string (concat prompt ": "))))
	431	(if (webjump-null-or-blank-string-p input) nil input)))
a1506d29	432
8749abea GM	433	(defun webjump-read-url-choice (what urls &optional default)
	434	;; Note: Convert this to use `webjump-read-choice' someday.
	435	(let* ((completions (mapcar (function (lambda (n) (cons n n)))
	436	urls))
	437	(input (completing-read (concat what
	438	;;(if default " (RET for default)" "")
	439	": ")
	440	completions
	441	nil
	442	t)))
	443	(if (webjump-null-or-blank-string-p input)
	444	default
	445	(car (assoc input completions)))))
	446
	447	(defun webjump-null-or-blank-string-p (str)
	448	(or (null str) (string-match "^[ \t]*$" str)))
	449
	450	(defun webjump-url-encode (str)
	451	(mapconcat '(lambda (c)
	452	(cond ((= c 32) "+")
	453	((or (and (>= c ?a) (<= c ?z))
	454	(and (>= c ?A) (<= c ?Z))
	455	(and (>= c ?0) (<= c ?9)))
	456	(char-to-string c))
	457	(t (upcase (format "%%%02x" c)))))
	458	str
	459	""))
	460
	461	(defun webjump-url-fix (url)
	462	(if (webjump-null-or-blank-string-p url)
	463	""
	464	(webjump-url-fix-trailing-slash
	465	(cond
	466	((string-match "^[a-zA-Z]+:" url) url)
	467	((string-match "^/" url) (concat "file://" url))
	468	((string-match "^\\([^\\./]+\\)" url)
	469	(concat (if (string= (downcase (match-string 1 url)) "ftp")
	470	"ftp"
	471	"http")
	472	"://"
	473	url))
	474	(t url)))))
	475
	476	(defun webjump-url-fix-trailing-slash (url)
	477	(if (string-match "^[a-zA-Z]+://[^/]+$" url)
	478	(concat url "/")
	479	url))
	480
	481	;;-----------------------------------------------------------------------------
	482
	483	(provide 'webjump)
	484
ab5796a9	485	;;; arch-tag: f1d20156-0a6f-488b-bd91-f69ee8b6d5cc
e8af40ee	486	;;; webjump.el ends here