Instantly share code, notes, and snippets.

@youz /ldrpin.l
Created Dec 18, 2009

Embed
What would you like to do?
ldrpin mode for xyzzy
;;; -*- mode: lisp; package: ldrpin -*-
;;; ldrpin mode for xyzzy
(eval-when (:compile-toplevel :load-toplevel :execute)
(require 'xml-http-request)
(require 'json)
(require 'www/www)
(unless (find-package :ldrpin)
(defpackage :ldrpin
(:use :lisp :editor :xhr))))
(in-package :ldrpin)
(defvar *ldr-url* "http://reader.livedoor.com/reader/")
(defvar *ldr-apiurl* "http://reader.livedoor.com/api/")
(defvar *ldr-apikey* nil)
(defvar *ldr-username* nil)
(defvar *ldr-password* nil)
(defvar *ldrpin-buffer-name* "*ldr-pins*")
(defvar *ldrpin-mode-map* nil)
(defvar ldr-pins nil)
(export '(ldrpin-add ldrpin-del ldrpin-all ldrpin-clear
ldrpin-list ldr-getapikey
*ldr-url* *ldr-apiurl*
*ldr-username* *ldr-password*
*ldrpin-mode-map*))
;;; formatting
(defun entity2char (str)
(reduce #'(lambda (s pair) (apply #'substitute-string s pair))
'(("&amp;" "&") ("&gt;" ">") ("&lt;" "<") ("&quot;" "\""))
:initial-value str))
(defun utc2ut (utc)
(+ utc 2208988800))
(defun format-datetime (utc)
(format-date-string
"%y/%m/%d %H:%M:%S" (utc2ut utc)))
(defun print-elm (contents tag &rest attrs)
(let ((start (point-max)))
(format t "~A~%" contents)
(apply #'set-text-attribute start (1- (point-max)) tag attrs))
contents)
;;; json util
(defmacro json-keys (obj)
`(mapcar #'car ,obj))
(defmacro json-value (obj key)
`(cdr (assoc ,key ,obj :test #'string=)))
(defmacro with-json ((obj keys) &body body)
(let ((binds (mapcar #'(lambda (k)
(list k `(json-value ,obj ,(symbol-name k))))
keys)))
`(let ,binds ,@body)))
(setf (get 'with-json 'ed:lisp-indent-hook) 'let)
;;; ldr api
(defun ldr-getapikey ()
(let ((future (xhr-get-future *ldr-url* :key #'xhr-response-values :since :epoch)))
(multiple-value-bind (res status header) (xhr-future-value future)
(case status
(0 (and (ldr-login)
(ldr-getapikey)))
(200
(if (string-match "ApiKey = \"\\([0-9a-z]+\\)\"" res)
(setq *ldr-apikey* (match-string 1))
(and (msgbox "ApiKey取得失敗") nil)))
(t (and (msgbox "接続エラー: ~A" status) nil))))))
(defun ldr-login ()
(interactive)
(let* ((username (or *ldr-username* (minibuffer-input "user")))
(password (or *ldr-password* (minibuffer-input "pass" t)))
(future (xhr-post-future "http://member.livedoor.com/login/index"
`(:livedoor_id ,username :password ,password)
:key #'xhr:xhr-response-values
:since :epoch)))
(multiple-value-bind (res status header) (xhr-future-value future)
(case status
(200
(if (string-match "認証に失敗しました" res)
(and (msgbox "ログイン失敗") nil)
t))
(t (msgbox "接続エラー: ~A" status) nil)))))
(defun ldr-api (api &optional query ok)
(when (or *ldr-apikey* (ldr-getapikey))
(multiple-value-bind (res status header)
(xhr-post (concat *ldr-apiurl* api)
`(,@query :ApiKey ,*ldr-apikey*)
:key #'xhr-response-text
:since :epoch)
(if ok
(if (string-match "\"isSuccess\":1" res) t nil)
res))))
(defun ldr-api-async (api query &key oncomplete)
nil)
(defun ldrpin-add (link &optional (title ""))
(interactive "sURL: \nsTitle: ")
(let* ((title (or title link))
(ok (ldr-api "pin/add" `(:link ,(map-internal-to-utf-8 link)
:title ,(map-internal-to-utf-8 title))
t)))
(message "~:[Failed~;Done (~A)~]" ok link)
ok))
(defun ldrpin-del (link)
(interactive "sURL: ")
(let* ((ok (ldr-api "pin/remove" `(:link ,(map-internal-to-utf-8 link)) t)))
(message "~:[Failed~;Removed (~A)~]" ok link)
ok))
(defun ldrpin-clear ()
(interactive)
(let* ((ok (ldr-api "pin/clear") t))
(message "~:[Failed~;Cleared~]" ok)
ok))
(defun ldrpin-all ()
(nreverse (json:json-decode (ldr-api "pin/all"))))
(defun ldrpin-list ()
(save-excursion
(with-output-to-selected-buffer
;(princ "[LDR Pinned Entries]")
(let ((pins (ldrpin-all))
(n 0))
(dolist (item pins)
(with-json (item (link title created_on))
(let ((title (entity2char title))
(link (entity2char link)))
(setf (gethash link ldr-pins) t)
(print-elm (format nil "[~2,'0D]~75@{-~}" (incf n) t)
:entry :foreground 14)
(print-elm title :title)
(print-elm link :link)
(print-elm (format-datetime created_on) :date))))))
(not-modified)))
(defun minibuffer-input (prompt &optional (pass nil))
(let ((in (make-vector 16 :element-type 'character :fill-pointer 0 :adjustable t)))
(loop
(if pass
(minibuffer-prompt "~A: ~v@{~a~:*~}" prompt (length in) #\*)
(minibuffer-prompt "~A: ~A" prompt in))
(let ((c (read-char *keyboard*)))
(case c
(#\RET
(return in))
(#\C-g
(quit))
(#\C-q
(vector-push-extend (read-char *keyboard*) in))
(#\C-h
(or (zerop (length in))
(vector-pop in)))
(t
(vector-push-extend c in)))))))
;;; ldrpin-list-mode
(defun current-item (tag)
(save-excursion
(goto-eol)
(let ((entry-start (find-text-attribute :entry :end (point) :from-end t)))
(when entry-start
(goto-char entry-start)
(multiple-value-bind (start end tag)
(find-text-attribute tag :start (point))
(if start
(values (buffer-substring start end) start end)))))))
;;; ldrpin list mode
(defun next-entry ()
(interactive)
(goto-eol)
(multiple-value-bind (start end tag)
(find-text-attribute :entry :start (point))
(when start
(goto-char start)
(recenter 0))))
(defun previouse-entry ()
(interactive)
(goto-bol)
(multiple-value-bind (start end tag)
(find-text-attribute :entry :end (point) :from-end t)
(when start
(goto-char start)
(recenter 0))))
(defun toggle-pin ()
(interactive)
(let ((link (current-item :link))
(title (current-item :title)))
(when link
(multiple-value-bind (s start end) (current-item :entry)
(if #1=(gethash link ldr-pins)
(and (ldrpin-del link)
(set-text-attribute start end :entry :foreground 15)
(setf #1# nil))
(and (ldrpin-add link title)
(set-text-attribute start end :entry :foreground 14)
(setf #1# t)))))))
(defun open-current-link ()
(interactive)
(let ((link (current-item :link)))
(when link
(user::www-open-url link))))
(defun copy-current-link ()
(interactive)
(let ((link (current-item :link)))
(when link
(copy-to-clipboard link)
(message "copied: ~A" link))))
(defun ldrpin-quit ()
(interactive)
(kill-buffer *ldrpin-buffer-name*))
#|
(defun open-hatebu-comment ()
(interactive)
(let ((link (current-item :link)))
(when link
(user::www-open-url
(format nil "http://b.hatena.ne.jp/entry/~A"
(substring link (+ 2 (position #\/ link))))))))
|#
(defvar *hatebu-mode-map* nil)
(setq *hatebu-mode-map* (make-sparse-keymap))
(define-key *hatebu-mode-map* #\j 'next-line)
(define-key *hatebu-mode-map* #\k 'previous-line)
(define-key *hatebu-mode-map* #\q 'quit-hatebu)
(defun show-hatebu-comments ()
(interactive)
(let* ((url (current-item :link))
(res (xhr:xhr-get "http://b.hatena.ne.jp/entry/jsonlite/"
:query `(:url ,url)
:key #'xhr:xhr-response-text))
(buf (get-buffer-create (format nil "*comments on ~A*" url))))
(with-output-to-buffer (buf)
(if (string= res "null")
(format t "No bookmarks on ~A" url)
(let ((o (json:json-decode res)))
(with-json (o (count bookmarks title))
(format t "~A - ~A user~%~%" title count)
(dolist (e bookmarks)
(with-json (e (user tags comment))
(format t "~&~A ~{[~A]~}: ~A" user tags comment)))))))
(set-buffer-modified-p buf nil)
(pop-to-buffer buf t)
(hatebu-mode)))
(defun quit-hatebu ()
(interactive)
(delete-buffer (selected-buffer))
(delete-window))
(defun hatebu-mode ()
(kill-all-local-variables)
(make-local-variable 'indent-tabs-mode)
(setq mode-name "hatebu"
indent-tabs-mode nil
buffer-read-only t
need-not-save t
kept-undo-information nil
auto-save nil)
(toggle-ime nil)
(set-local-window-flags (selected-buffer)
*window-flag-line-number* nil)
(set-local-window-flags (selected-buffer)
*window-flag-newline* nil)
(set-local-window-flags (selected-buffer)
*window-flag-eof* nil)
(set-local-window-flags (selected-buffer)
*window-flag-cursor-line* t)
(use-keymap *hatebu-mode-map*))
(setq *ldrpin-mode-map* (make-sparse-keymap))
(define-key *ldrpin-mode-map* #\p 'toggle-pin)
(define-key *ldrpin-mode-map* #\j 'next-entry)
(define-key *ldrpin-mode-map* #\k 'previouse-entry)
(define-key *ldrpin-mode-map* #\v 'open-current-link)
(define-key *ldrpin-mode-map* #\c 'copy-current-link)
(define-key *ldrpin-mode-map* #\q 'ldrpin-quit)
(define-key *ldrpin-mode-map* #\b 'show-hatebu-comments)
(defun ldrpin-mode ()
(kill-all-local-variables)
(make-local-variable 'indent-tabs-mode)
(setq mode-name "LDR-Pins"
indent-tabs-mode nil
buffer-read-only t
need-not-save t
kept-undo-information nil
auto-save nil)
(toggle-ime nil)
(set-local-window-flags (selected-buffer)
*window-flag-line-number* nil)
(set-local-window-flags (selected-buffer)
*window-flag-newline* nil)
(set-local-window-flags (selected-buffer)
*window-flag-eof* nil)
(set-local-window-flags (selected-buffer)
*window-flag-cursor-line* t)
(set-buffer-fold-width t)
; (make-local-variable 'regexp-keyword-list)
; (setq regexp-keyword-list *ldrpin-regexp-keyword-list*)
(use-keymap *ldrpin-mode-map*))
(defun user::ldrpin ()
(interactive)
(set-buffer (get-buffer-create *ldrpin-buffer-name*))
(setq buffer-read-only nil)
(erase-buffer (selected-buffer))
(setq ldr-pins (make-hash-table :test #'equal))
(ldrpin-list)
(ldrpin-mode))
(defun user::ldrpin-add-region (start end title)
(interactive "r\nsTitle: " :default1 (buffer-name (selected-buffer)))
(let ((url (buffer-substring start end)))
(ldrpin-add url title)))
(provide "ldrpin")
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment