contrib/guile/user-hooks.scm

   1 ;;; USER CODE
   2
   3 (use-modules (ice-9 optargs)            ;let-optional
   4              (ice-9 regex)
   5              (srfi srfi-2)              ;and-let*
   6              (srfi srfi-8)              ;receive
   7              (srfi srfi-13)             ;string-lib
   8              )
   9
  10
  11 ;;; goto-url-hooks
  12 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13 ;;; Handle search URLs
  14
  15 ;; Makes a searcher routine.  If the routine is called without any
  16 ;; arguments, return the home page location.  Otherwise, construct a
  17 ;; URL searching for the arguments specified.
  18 ;; e.g.
  19 ;;  (define f (make-searcher "http://www.google.com/"
  20 ;;                           "http://www.google.com/search?q="
  21 ;;                           "&btnG=Google%20Search"))
  22 ;;  (f '())
  23 ;;   => "http://www.google.com/"
  24 ;;  (f '("google" "me"))
  25 ;;   => "http://www.google.com/search?q=google%20me&btnG=Google%20Search"
  26 (define (make-searcher home-page prefix . maybe-postfix)
  27   (let-optional maybe-postfix ((postfix ""))
  28     (lambda (words)
  29       (if (null? words)
  30           home-page
  31           (string-append prefix (string-join words "%20") postfix)))))
  32
  33 ;; TODO: ,gg -> gg: format update to the standard ELinks one. --pasky
  34
  35 (define goto-url-searchers
  36   `((",gg"   . ,(make-searcher "http://www.google.com/"
  37                                "http://www.google.com/search?q=" "&btnG=Google%20Search"))
  38     (",fm"   . ,(make-searcher "http://www.freshmeat.net/"
  39                                "http://www.freshmeat.net/search/?q="))
  40     (",dict" . ,(make-searcher "http://www.dictionary.com/"
  41                                "http://www.dictionary.com/cgi-bin/dict.pl?db=%2A&term="))
  42     (",wtf"  . ,(make-searcher "http://www.ucc.ie/cgi-bin/acronym?wtf"
  43                                "http://www.ucc.ie/cgi-bin/acronym?"))))
  44
  45 (add-hook! goto-url-hooks
  46            (lambda (url)
  47              (let* ((words (string-tokenize url))
  48                     (key (car words))
  49                     (rest (cdr words)))
  50                (cond ((assoc key goto-url-searchers) =>
  51                       (lambda (x) ((cdr x) rest)))
  52                      (else #f)))))
  53
  54
  55 ;;; goto-url-hooks
  56 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  57 ;;; Handle simple URLs
  58
  59 (define goto-url-simples
  60   `((",forecast" . "http://www.bom.gov.au/cgi-bin/wrap_fwo.pl?IDV10450.txt")
  61     (",local" . "XXXXXXXXXXXXXXXXXXX")
  62     ))
  63
  64 (add-hook! goto-url-hooks
  65            (lambda (url)
  66              (cond ((assoc url goto-url-simples) => cdr)
  67                    (else #f))))
  68
  69
  70 ;;; goto-url-hooks
  71 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  72 ;;; Expand ~/ and ~user/ URLs
  73
  74 (define (home-directory . maybe-user)
  75   (let-optional maybe-user ((user (cuserid)))
  76     (and-let* ((user (catch 'misc-error
  77                             (lambda () (getpwnam user))
  78                             (lambda ignore #f))))
  79               (passwd:dir user))))
  80
  81 (define (expand-tilde-file-name file-name)
  82   (and (string-prefix? "~" file-name)
  83        (let* ((slash/end (or (string-index file-name #\/)
  84                              (string-length file-name)))
  85               (user (substring file-name 1 slash/end)))
  86          (string-append (if user
  87                             (home-directory)
  88                             (home-directory user))
  89                         (substring file-name slash/end)))))
  90
  91 (add-hook! goto-url-hooks
  92            (lambda (url)
  93              (and (string-prefix? "~" url)
  94                   (expand-tilde-file-name url))))
  95
  96
  97 ;;; pre-format-html-hooks
  98 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  99 ;;; Mangle linuxgames.com pages
 100
 101 (add-hook! pre-format-html-hooks
 102            (lambda (url html)
 103              (and (string-contains url "linuxgames.com")
 104                   (and-let* ((start (string-contains html "<CENTER>"))
 105                              (end (string-contains html "</center>" (+ start 1))))
 106                             (string-append (substring/shared html 0 start)
 107                                            (substring/shared html (+ end 10)))))))
 108
 109
 110 ;;; pre-format-html-hooks
 111 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 112 ;;; Mangle dictionary.com result pages
 113
 114 (add-hook! pre-format-html-hooks
 115   (lambda (url html)
 116     (and (string-contains url "dictionary.reference.com/search?")
 117          (and-let* ((m (string-match
 118                         (string-append
 119                          "<table border=\"0\" cellpadding=\"2\" width=\"100%\">"
 120                          ".*<td width=\"120\" align=\"center\">")
 121                         html)))
 122            (string-append "<html><head><title>Dictionary.com lookup</title>"
 123                           "</head><body>"
 124                           (regexp-substitute/global #f
 125                               "<br>\n<p><b>" (match:substring m 0)
 126                             'pre "<br>\n<hr>\n<p><b>" 'post))))))
 127
 128
 129 ;;; get-proxy-hooks
 130 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 131 ;;; Some addresses require a special proxy
 132
 133 (add-hook! get-proxy-hooks
 134            (lambda (url)
 135              (and (or (string-contains url "XXXXXXXXXXXXXX")
 136                       (string-contains url "XXXXXXXXXXXXXX"))
 137                   "XXXXXXXXXXXXXXXXXXXXXXXXXXX")))
 138
 139
 140 ;;; get-proxy-hooks
 141 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 142 ;;; Some addresses work better without a proxy
 143
 144 (add-hook! get-proxy-hooks
 145            (lambda (url)
 146              (and (or (string-contains url "XXXXXXXXXXXXXXXXXXX")
 147                       (string-contains url "XXXXXXXXXX"))
 148                   "")))
 149
 150
 151 ;;; quit-hooks
 152 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 153 ;;; Delete temporary files when quitting
 154
 155 (define temporary-files '())
 156
 157 (add-hook! quit-hooks
 158            (lambda ()
 159              (for-each delete-file temporary-files)))
 160
 161 ;;; The end
 162 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;