TinyURL

へなちょこ。xml-http-requestとjunk/httpの両方を使っているのは単なる手抜き。

(require "xml-http-request")
(require "junk/http")

(defvar *tinyurl-base-url*
  "http://tinyurl.com/api-create.php?url=")

(defun tinyurl-create-url (url)
  (let ((api-url
         (concat *tinyurl-base-url* url)))
      (multiple-value-bind (response status)
          (msxml::http-get api-url)
        (cond ((= status 200)
               response)
              (t
               (error "~S~%~%~S" status response))))))

(defun tinyurl-url ()
  (let (url)
    (save-excursion
      (or (selection-start-end (beg end)
            (setq url (buffer-substring beg end)))
          (and (skip-syntax-spec-backward "w_")
               (looking-at "https?://[^ \t\r\n\"]+")
               (setq url (match-string 0)))
          (let ((temp (get-clipboard-data)))
            (when (string-match "https?://[^ \t\r\n]+" temp)
              (setq url (match-string 0))))))
    (read-string "URL: " :default url)))

(defun tinyurl-lookup-url (url)
  (unless (string-match "http://tinyurl.com/[a-z0-9]+" url)
    (error "Invalid TinyURL: ~S" url))
  (multiple-value-bind (sock status headers)
      (junk::junk-http-get-url url)
    (cond ((equal status "301")
           (junk::junk-http-get-header-value "location" headers))
          (t
           (error "ERROR: ~S" status)))))

(defun tinyurl-create ()
  "URLをTinyURLに変換する。成功すれば変換後のURLをクリップボードにコピーする。"
  (interactive)
  (let ((url (tinyurl-url))
        tinyurl)
    (when url
      (when (setq tinyurl (tinyurl-create-url url))
        (copy-to-clipboard tinyurl)
        (message "~A" tinyurl)))))

(defun tinyurl-lookup ()
  "TinyURLをURLに戻す。成功すれば戻したURLをクリップボードにコピーする。"
  (interactive)
  (let ((url (tinyurl-url))
        original-url)
    (when (and url
               (setq original-url (tinyurl-lookup-url url)))
      (copy-to-clipboard original-url)
      (message "~A" original-url))))