emacs/external/ljupdate/lj-compose.el

   1 ;;; lj-compose.el --- post composition for ljupdate
   2
   3 ;; Copyright (C) 2002, 2003, 2004, 2005 Edward O'Connor <ted@oconnor.cx>
   4
   5 ;; Author: Edward O'Connor <ted@oconnor.cx>
   6 ;; Keywords: convenience
   7
   8 ;; This file is part of ljupdate, a LiveJournal client for Emacs.
   9
  10 ;; ljupdate is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or
  13 ;; {at your option} any later version.
  14
  15 ;; ljupdate is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING, or type `C-h C-c'. If
  22 ;; not, write to the Free Software Foundation at this address:
  23
  24 ;;   Free Software Foundation
  25 ;;   51 Franklin Street, Fifth Floor
  26 ;;   Boston, MA 02110-1301
  27 ;;   USA
  28
  29 ;;; Commentary:
  30 ;;
  31
  32 ;;; History:
  33 ;;
  34
  35 ;;; Code:
  36
  37 (require 'cl)
  38 (require 'message)
  39 (require 'sendmail)
  40
  41 (require 'lj-custom)
  42 (require 'lj-acct)
  43 (require 'lj-compat)
  44 (require 'lj-fill)
  45 (require 'lj-pcomplete)
  46 (require 'lj-protocol)
  47 (require 'lj-login)
  48 (require 'lj-util)
  49
  50 (eval-when-compile
  51   ;; for `viper-change-state'
  52   (require 'viper-cmd)
  53   ;; from viper-init.el
  54   (defvar viper-current-state)
  55   ;; from viper.el
  56   (defvar viper-mode))
  57
  58 ;;; Utilities
  59
  60 (defun lj-compose-fetch-field (field)
  61   "Return this buffer's value of FIELD."
  62   (save-excursion
  63     (save-restriction
  64       (widen)
  65       (message-narrow-to-headers)
  66       (message-fetch-field field))))
  67
  68 (defun lj-this-header ()
  69   "Return the header of line at point."
  70   (save-excursion
  71     (beginning-of-line)
  72     (when (looking-at "\\([^:]+\\)[:]")
  73       (match-string 1))))
  74
  75 (defun lj-this-server ()
  76   "Return the current value of the Server header."
  77   (lj-compose-fetch-field "Server"))
  78
  79 (defun lj-this-user ()
  80   "Return the current value of the User header."
  81   (lj-compose-fetch-field "User"))
  82
  83 ;;; Code for submitting this post to LiveJournal.
  84
  85 (defun lj-compose-prepare-body ()
  86   "Massage this buffer's body for submittal to LiveJournal and return as string."
  87   (save-excursion
  88     (save-restriction
  89       (widen)
  90       (message-goto-body)
  91       (narrow-to-region (point) (point-max))
  92       (run-hooks 'lj-compose-pre-prepare-body-hook)
  93       (funcall lj-fill-function)
  94       (run-hooks 'lj-compose-post-prepare-body-hook)
  95       (buffer-substring-no-properties (point-min) (point-max)))))
  96
  97 (defun lj-compose-submit ()
  98   "Submit this entry to the server."
  99   (interactive)
 100   (let* ((buf (current-buffer))
 101          ;; The text of the entry.
 102          (event (lj-compose-prepare-body))
 103
 104          ;; Some convenience variables for oft-used headers
 105          (server (lj-compose-fetch-field "Server"))
 106          (user   (lj-compose-fetch-field "User"))
 107
 108          ;; The current time -- or use the specified time if it exists
 109          (time-field (lj-compose-fetch-field "Time"))
 110          (timestamp (if (eq nil time-field)
 111                         ()
 112                       (date-to-time (concat time-field " " (cadr (current-time-zone))))))
 113
 114          (time (split-string (format-time-string "%Y:%m:%d:%H:%M" timestamp) "[:]"))
 115          (year (pop time))
 116          (month (pop time))
 117          (day (pop time))
 118          (hour (pop time))
 119          (minute (pop time))
 120
 121          ;; LJ Authentication information
 122          challenge
 123
 124          ;; The actual request packet, and the response we receive from
 125          ;; the server.
 126          (request (list '("auth_method" . "challenge")
 127                         '("ver"         . "1")
 128                         (cons "year" year)
 129                         (cons "mon" month)
 130                         (cons "day" day)
 131                         (cons "hour" hour)
 132                         (cons "min" minute)
 133                         (cons "event" event))))
 134
 135     ;; Build up the request packet.
 136     (add-to-list 'request (cons "user" user))
 137     (let ((itemid (lj-compose-fetch-field "Itemid")))
 138       (if itemid
 139           (progn (add-to-list 'request (cons "itemid" itemid))
 140                  (add-to-list 'request '("mode" . "editevent")))
 141         (add-to-list 'request '("mode" . "postevent"))))
 142     (let ((subject (lj-compose-fetch-field "Subject")))
 143       (when subject
 144         (add-to-list 'request (cons "subject" subject))))
 145
 146     ;; FIXME: use moodid if available
 147     (let ((mood (lj-compose-fetch-field "Mood")))
 148       (when mood
 149         (add-to-list 'request (cons "prop_current_mood" mood))))
 150
 151     (let ((location (lj-compose-fetch-field "Location")))
 152       (when location
 153         (add-to-list 'request (cons "prop_current_location" location))))
 154
 155     (let ((tags (lj-compose-fetch-field "Tags")))
 156       (when tags
 157         (add-to-list 'request (cons "prop_taglist" tags))))
 158
 159     (let ((music (lj-compose-fetch-field "Music")))
 160       (when music
 161         (add-to-list 'request (cons "prop_current_music" music))))
 162
 163     (let ((community (lj-compose-fetch-field "Community")))
 164       (when community
 165         (add-to-list 'request (cons "usejournal" community))))
 166
 167     (let ((picture (lj-compose-fetch-field "Picture")))
 168       (when picture
 169         (add-to-list 'request (cons "prop_picture_keyword" picture))))
 170
 171     (let ((comments (lj-compose-fetch-field "Allow-Comments")))
 172       (when (and comments (string-match "[Nn][Oo]" comments))
 173         (add-to-list 'request '("prop_opt_nocomments" . "1"))))
 174
 175     (let ((email (lj-compose-fetch-field "Receive-Mail-Notification")))
 176       (when (and email (string-match "[Nn][Oo]" email))
 177         (add-to-list 'request '("prop_opt_noemail" . "1"))))
 178
 179     (let* ((access (lj-compose-fetch-field "Access"))
 180            (friends-group-number
 181             (cdr (assoc access (lj-user-get server user :friends-groups)))))
 182       (if (stringp access)
 183           (cond ((string-match "public" access)
 184                  (add-to-list 'request '("security" . "public")))
 185                 ((string-match "private" access)
 186                  (add-to-list 'request '("security" . "private")))
 187                 ((string-match "friends" access)
 188                  (add-to-list 'request '("allowmask" . "1"))
 189                  (add-to-list 'request '("security" . "usemask")))
 190                 (friends-group-number
 191                  (add-to-list 'request (cons "allowmask"
 192                                              (lj-exp2 friends-group-number)))
 193                  (add-to-list 'request '("security" . "usemask")))
 194                 (t
 195                  (lj-warn
 196                   "Unable to understand Access: %s; presuming private."
 197                   access)
 198                  (add-to-list 'request '("security" . "private"))))
 199         (add-to-list 'request '("security" . "public"))))
 200
 201     ;; Actually talk to the LJ server.
 202     (message "Connecting to `%s' as `%s'. Please wait." server user)
 203     (setq challenge (lj-getchallenge server))
 204
 205     (add-to-list 'request (cons "auth_challenge" challenge))
 206     (add-to-list 'request
 207                  (cons "auth_response"
 208                        (lj-md5 (concat challenge (lj-password server user)))))
 209
 210     (message "Submitting to `%s' as `%s'. Please wait." server user)
 211
 212     (let ((response (lj-protocol-send-request server request)))
 213       (set-buffer buf)              ; return to the *LiveJournal* buffer
 214       (if (and (hash-table-p response)
 215                (string= (gethash "success" response) "OK"))
 216           (progn
 217             (set-buffer-modified-p nil)
 218             (message "Successfully posted as %s." (gethash "url" response))
 219             t)
 220         (let ((errmsg (gethash "errmsg" response)))
 221           (if errmsg
 222               (message "Posting to %s failed: %s" server errmsg)
 223             (message "Posting to %s failed!" server)))
 224         nil))))
 225
 226 (defun lj-compose-submit-then-exit ()
 227   "Submit this entry to the server, and exit if successful."
 228   (interactive)
 229   (when (lj-compose-submit)
 230     (quit-window)))
 231
 232 ;;; Code for handling the separator between headers and body.
 233
 234 (defvar lj-compose-header/body-marker nil
 235   "The marker between the lj message's header and body sections.
 236 Anything before this marker will be in `message-mode' and anything below
 237 in `html-mode'.")
 238 (make-variable-buffer-local 'lj-compose-header/body-marker)
 239 (put 'lj-compose-header/body-marker 'permanent-local t)
 240
 241 (defun lj-compose-find-separator ()
 242   "If non-null, the position of mail-header-separator in this buffer."
 243   (save-excursion
 244     (goto-char (point-min))
 245     (re-search-forward (regexp-quote mail-header-separator) nil t)))
 246
 247 (defun lj-compose-propertize-separator (&optional pos)
 248   "Puts the `mail-header-separator' property on the header separator."
 249   (save-excursion
 250     (goto-char (or pos (lj-compose-find-separator)))
 251     (let ((beg (line-beginning-position))
 252           (end (line-end-position)))
 253       (put-text-property beg end 'category 'mail-header-separator))))
 254
 255 (defun lj-compose-mark-separator (&optional pos)
 256   "Initialize `lj-compose-header/body-marker' "
 257   (set (make-local-variable 'lj-compose-header/body-marker)
 258        (let ((marker (make-marker))
 259              (sep-pos (or pos (lj-compose-find-separator))))
 260          (lj-compose-propertize-separator sep-pos)
 261          (set-marker marker sep-pos)
 262          marker)))
 263
 264 ;;; Major modes for editing LiveJournal posts.
 265
 266 (defun lj-compose-check-mode ()
 267   "Ensure we're using the correct major mode for this part of the buffer."
 268   (let ((there (if (and (boundp 'lj-compose-header/body-marker)
 269                         (markerp lj-compose-header/body-marker))
 270                    (marker-position lj-compose-header/body-marker)
 271                  (lj-compose-mark-separator)))
 272         (here (point))
 273         (lj-saved-viper-state (and (boundp 'viper-current-state)
 274                                    viper-current-state)))
 275     (cond ((and (< here there)
 276                 (not (eq major-mode 'lj-compose-header-mode)))
 277            (lj-compose-header-mode))
 278           ((and (> here there)
 279                 (not (eq major-mode 'lj-compose-body-mode)))
 280            (lj-compose-body-mode)))
 281     (when (and (boundp 'viper-mode) viper-mode)
 282       (viper-change-state lj-saved-viper-state))))
 283
 284 (define-derived-mode lj-compose-header-mode message-mode "LJ:H"
 285   (mml-mode -1)
 286   (set (make-local-variable 'message-auto-save-directory) "~/.ljupdate/drafts")
 287   (lj-pcomplete-setup)
 288   (define-key lj-compose-header-mode-map "\t" 'pcomplete)
 289   (run-hooks 'lj-compose-common-hook)
 290   (add-hook 'post-command-hook 'lj-compose-check-mode nil t))
 291
 292 (define-derived-mode lj-compose-body-mode html-mode "LJ:B"
 293   (run-hooks 'lj-compose-common-hook)
 294   (add-hook 'post-command-hook 'lj-compose-check-mode nil t))
 295
 296 ;;;###autoload
 297 (defun lj-compose-mode ()
 298   "Major mode for editing LiveJournal posts."
 299   (lj-compose-mark-separator)
 300   (lj-compose-check-mode))
 301
 302 ;;;###autoload
 303 (add-to-list 'auto-mode-alist '("\\.lj\\'" . lj-compose-mode))
 304
 305 ;;; Key bindings.
 306
 307 (define-key lj-compose-header-mode-map (kbd "C-c C-s") 'lj-compose-submit)
 308 (define-key lj-compose-body-mode-map (kbd "C-c C-s") 'lj-compose-submit)
 309
 310 (define-key lj-compose-header-mode-map (kbd "C-c C-c") 'lj-compose-submit-then-exit)
 311 (define-key lj-compose-body-mode-map (kbd "C-c C-c") 'lj-compose-submit-then-exit)
 312
 313 ;; (define-key lj-compose-body-mode-map (kbd "C-c <TAB>") 'lj-complete-body)
 314
 315 ;; Ensure that unwanted Message bindings get shadowed.
 316 ;; I should probably do this in a nicer way.
 317 (mapc (lambda (key)
 318         (define-key lj-compose-header-mode-map key 'undefined))
 319       (list (kbd "C-c C-a")     (kbd "C-c C-e")       (kbd "C-c C-f a")
 320             (kbd "C-c C-f s")   (kbd "C-c C-f t")     (kbd "C-c C-f w")
 321             (kbd "C-c C-f x")   (kbd "C-c C-f C-a")   (kbd "C-c C-f C-b")
 322             (kbd "C-c C-f C-c") (kbd "C-c C-f C-d")   (kbd "C-c C-f C-f")
 323             (kbd "C-c C-f C-k") (kbd "C-c C-f C-n")   (kbd "C-c C-f C-o")
 324             (kbd "C-c C-f C-r") (kbd "C-c C-f C-t")   (kbd "C-c C-f C-u")
 325             (kbd "C-c C-f <RET>")       ; (kbd "C-c C-f <TAB>")
 326             (kbd "C-c C-j")     (kbd "C-c C-l")       (kbd "C-c C-n")
 327             (kbd "C-c C-q")     (kbd "C-c C-r")       (kbd "C-c C-t")
 328             (kbd "C-c C-u")     (kbd "C-c C-v")       (kbd "C-c C-w")
 329             (kbd "C-c C-y")     (kbd "C-c C-z")       (kbd "C-c <ESC> f")
 330             (kbd "C-c <ESC> h") (kbd "C-c <ESC> m")   (kbd "C-c <ESC> n")
 331             (kbd "C-c <ESC> r") (kbd "C-c <ESC> y") ; (kbd "C-c <TAB>")
 332             ))
 333
 334 ;; Ensure that unwanted HTML mode bindings get shadowed.
 335 (mapc (lambda (key)
 336         (define-key lj-compose-body-mode-map key 'undefined))
 337       (list (kbd "C-c C-v")))
 338
 339 ;;; `lj-compose' is the major interactive entry point into this file.
 340
 341 ;;;###autoload
 342 (defun lj-compose ()
 343   "Compose a new LiveJournal post."
 344   (interactive)
 345
 346   ;; Create the composition buffer.
 347   (switch-to-buffer (get-buffer-create "*LiveJournal*"))
 348
 349   (unless (buffer-modified-p)
 350     (delete-region (point-min) (point-max))
 351     (lj-compose-populate-buffer)
 352     (goto-char (point-min))
 353     (lj-compose-header-mode)
 354     (if (or lj-last-username lj-default-username)
 355         (message-position-on-field "Subject")
 356       (message-position-on-field "User"))))
 357
 358 (defun lj-compose-populate-buffer (&optional values)
 359   "Populate the current buffer as a LiveJournal post."
 360   ;; Insert the essential headers.
 361   (unless (hash-table-p values)
 362     (setq values (make-hash-table)))
 363   (insert "Server: " (or (gethash :server values)
 364                          lj-last-server
 365                          lj-default-server
 366                          "www.livejournal.com")
 367           "\n"
 368
 369           "User: " (or (gethash :username values)
 370                        lj-last-username
 371                        lj-default-username
 372                        "")
 373           "\n"
 374
 375           "Community: " (or (gethash :community values) "") "\n"
 376           "Mood: " (or (gethash :mood values) "") "\n"
 377           "Location: " (or (gethash :location values) "") "\n"
 378           "Picture: " (or (gethash :picture values) "") "\n"
 379           "Access: " (or (gethash :access values) "public") "\n"
 380           "Subject: " (or (gethash :subject values) "") "\n"
 381           "Tags: " (or (gethash :tags values) "") "\n")
 382
 383   ;; Give the user an opportunity to add additional headers to the
 384   ;; buffer.
 385   (insert lj-default-headers)
 386   (run-hooks 'lj-compose-init-headers-hook)
 387
 388   (insert mail-header-separator)
 389   (lj-compose-mark-separator)
 390   (insert "\n")
 391
 392   (insert (gethash :body values ""))
 393
 394   ;; Give the user an opportunity to pre-populate the buffer in some
 395   ;; way.
 396   (run-hooks 'lj-compose-init-body-hook)
 397
 398   ;; The user hasn't actually done anything to this buffer, so it
 399   ;; shouldn't be marked as modified.
 400   (set-buffer-modified-p nil))
 401
 402 (provide 'lj-compose)
 403
 404 ;;; lj-compose.el ends here