Created
December 18, 2009 09:52
-
-
Save youz/259404 to your computer and use it in GitHub Desktop.
ldrpin mode for xyzzy
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
;;; -*- 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)) | |
'(("&" "&") (">" ">") ("<" "<") (""" "\"")) | |
: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