← Back to branch summary

~ubuntu-branches/ubuntu/feisty/elinks/feisty-updates

« back to all changes in this revision

Viewing changes to contrib/guile/guile/user-hooks.scm

  • Committer: Bazaar Package Importer
  • Author(s): Peter Gervai
  • Date: 2004-01-21 22:13:45 UTC
  • Revision ID: james.westby@ubuntu.com-20040121221345-ju33hai1yhhqt6kn
Tags: upstream-0.9.1
Import upstream version 0.9.1

Show diffs side-by-side

added added

removed removed

Lines of Context:
contrib/guile/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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;