mirror of
https://github.com/rkd77/elinks.git
synced 2024-11-02 08:57:19 -04:00
163 lines
5.0 KiB
Scheme
163 lines
5.0 KiB
Scheme
|
;;; USER CODE
|
||
|
|
|
||
|
|
(use-modules (ice-9 optargs) ;let-optional
|
||
|
|
(ice-9 regex)
|
||
|
|
(srfi srfi-2) ;and-let*
|
||
|
|
(srfi srfi-8) ;receive
|
||
|
|
(srfi srfi-13) ;string-lib
|
||
|
|
)
|
||
|
|
|
||
|
|
|
||
|
|
;;; goto-url-hooks
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;; Handle search URLs
|
||
|
|
|
||
|
|
;; Makes a searcher routine. If the routine is called without any
|
||
|
|
;; arguments, return the home page location. Otherwise, construct a
|
||
|
|
;; URL searching for the arguments specified.
|
||
|
|
;; e.g.
|
||
|
|
;; (define f (make-searcher "http://www.google.com/"
|
||
|
|
;; "http://www.google.com/search?q="
|
||
|
|
;; "&btnG=Google%20Search"))
|
||
|
|
;; (f '())
|
||
|
|
;; => "http://www.google.com/"
|
||
|
|
;; (f '("google" "me"))
|
||
|
|
;; => "http://www.google.com/search?q=google%20me&btnG=Google%20Search"
|
||
|
|
(define (make-searcher home-page prefix . maybe-postfix)
|
||
|
|
(let-optional maybe-postfix ((postfix ""))
|
||
|
|
(lambda (words)
|
||
|
|
(if (null? words)
|
||
|
|
home-page
|
||
|
|
(string-append prefix (string-join words "%20") postfix)))))
|
||
|
|
|
||
|
|
;; TODO: ,gg -> gg: format update to the standard ELinks one. --pasky
|
||
|
|
|
||
|
|
(define goto-url-searchers
|
||
|
|
`((",gg" . ,(make-searcher "http://www.google.com/"
|
||
|
|
"http://www.google.com/search?q=" "&btnG=Google%20Search"))
|
||
|
|
(",fm" . ,(make-searcher "http://www.freshmeat.net/"
|
||
|
|
"http://www.freshmeat.net/search/?q="))
|
||
|
|
(",dict" . ,(make-searcher "http://www.dictionary.com/"
|
||
|
|
"http://www.dictionary.com/cgi-bin/dict.pl?db=%2A&term="))
|
||
|
|
(",wtf" . ,(make-searcher "http://www.ucc.ie/cgi-bin/acronym?wtf"
|
||
|
|
"http://www.ucc.ie/cgi-bin/acronym?"))))
|
||
|
|
|
||
|
|
(add-hook! goto-url-hooks
|
||
|
|
(lambda (url)
|
||
|
|
(let* ((words (string-tokenize url))
|
||
|
|
(key (car words))
|
||
|
|
(rest (cdr words)))
|
||
|
|
(cond ((assoc key goto-url-searchers) =>
|
||
|
|
(lambda (x) ((cdr x) rest)))
|
||
|
|
(else #f)))))
|
||
|
|
|
||
|
|
|
||
|
|
;;; goto-url-hooks
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;; Handle simple URLs
|
||
|
|
|
||
|
|
(define goto-url-simples
|
||
|
|
`((",forecast" . "http://www.bom.gov.au/cgi-bin/wrap_fwo.pl?IDV10450.txt")
|
||
|
|
(",local" . "XXXXXXXXXXXXXXXXXXX")
|
||
|
|
))
|
||
|
|
|
||
|
|
(add-hook! goto-url-hooks
|
||
|
|
(lambda (url)
|
||
|
|
(cond ((assoc url goto-url-simples) => cdr)
|
||
|
|
(else #f))))
|
||
|
|
|
||
|
|
|
||
|
|
;;; goto-url-hooks
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;; Expand ~/ and ~user/ URLs
|
||
|
|
|
||
|
|
(define (home-directory . maybe-user)
|
||
|
|
(let-optional maybe-user ((user (cuserid)))
|
||
|
|
(and-let* ((user (catch 'misc-error
|
||
|
|
(lambda () (getpwnam user))
|
||
|
|
(lambda ignore #f))))
|
||
|
|
(passwd:dir user))))
|
||
|
|
|
||
|
|
(define (expand-tilde-file-name file-name)
|
||
|
|
(and (string-prefix? "~" file-name)
|
||
|
|
(let* ((slash/end (or (string-index file-name #\/)
|
||
|
|
(string-length file-name)))
|
||
|
|
(user (substring file-name 1 slash/end)))
|
||
|
|
(string-append (if user
|
||
|
|
(home-directory)
|
||
|
|
(home-directory user))
|
||
|
|
(substring file-name slash/end)))))
|
||
|
|
|
||
|
|
(add-hook! goto-url-hooks
|
||
|
|
(lambda (url)
|
||
|
|
(and (string-prefix? "~" url)
|
||
|
|
(expand-tilde-file-name url))))
|
||
|
|
|
||
|
|
|
||
|
|
;;; pre-format-html-hooks
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;; Mangle linuxgames.com pages
|
||
|
|
|
||
|
|
(add-hook! pre-format-html-hooks
|
||
|
|
(lambda (url html)
|
||
|
|
(and (string-contains url "linuxgames.com")
|
||
|
|
(and-let* ((start (string-contains html "<CENTER>"))
|
||
|
|
(end (string-contains html "</center>" (+ start 1))))
|
||
|
|
(string-append (substring/shared html 0 start)
|
||
|
|
(substring/shared html (+ end 10)))))))
|
||
|
|
|
||
|
|
|
||
|
|
;;; pre-format-html-hooks
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;; Mangle dictionary.com result pages
|
||
|
|
|
||
|
|
(add-hook! pre-format-html-hooks
|
||
|
|
(lambda (url html)
|
||
|
|
(and (string-contains url "dictionary.reference.com/search?")
|
||
|
|
(and-let* ((m (string-match
|
||
|
|
(string-append
|
||
|
|
"<table border=\"0\" cellpadding=\"2\" width=\"100%\">"
|
||
|
|
".*<td width=\"120\" align=\"center\">")
|
||
|
|
html)))
|
||
|
|
(string-append "<html><head><title>Dictionary.com lookup</title>"
|
||
|
|
"</head><body>"
|
||
|
|
(regexp-substitute/global #f
|
||
|
|
"<br>\n<p><b>" (match:substring m 0)
|
||
|
|
'pre "<br>\n<hr>\n<p><b>" 'post))))))
|
||
|
|
|
||
|
|
|
||
|
|
;;; get-proxy-hooks
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;; Some addresses require a special proxy
|
||
|
|
|
||
|
|
(add-hook! get-proxy-hooks
|
||
|
|
(lambda (url)
|
||
|
|
(and (or (string-contains url "XXXXXXXXXXXXXX")
|
||
|
|
(string-contains url "XXXXXXXXXXXXXX"))
|
||
|
|
"XXXXXXXXXXXXXXXXXXXXXXXXXXX")))
|
||
|
|
|
||
|
|
|
||
|
|
;;; get-proxy-hooks
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;; Some addresses work better without a proxy
|
||
|
|
|
||
|
|
(add-hook! get-proxy-hooks
|
||
|
|
(lambda (url)
|
||
|
|
(and (or (string-contains url "XXXXXXXXXXXXXXXXXXX")
|
||
|
|
(string-contains url "XXXXXXXXXX"))
|
||
|
|
"")))
|
||
|
|
|
||
|
|
|
||
|
|
;;; quit-hooks
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;; Delete temporary files when quitting
|
||
|
|
|
||
|
|
(define temporary-files '())
|
||
|
|
|
||
|
|
(add-hook! quit-hooks
|
||
|
|
(lambda ()
|
||
|
|
(for-each delete-file temporary-files)))
|
||
|
|
|
||
|
|
;;; The end
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|