1 ;; lj.el --- LiveJournal meets SXEmacs -*- Emacs-Lisp -*-
3 ;; Copyright (C) 2008 - 2014 Steve Youngs
5 ;; Author: Steve Youngs <steve@sxemacs.org>
6 ;; Maintainer: Steve Youngs <steve@sxemacs.org>
7 ;; Created: <2008-06-15>
8 ;; Based On: jwz-lj.el by Jamie Zawinski <jwz@jwz.org>
9 ;; Keywords: blog, lj, livejournal
10 ;; Homepage: <http://www.sxemacs.org/lj.el>
12 ;; This file is part of SLH (Steve's Lisp Hacks).
14 ;; Redistribution and use in source and binary forms, with or without
15 ;; modification, are permitted provided that the following conditions
18 ;; 1. Redistributions of source code must retain the above copyright
19 ;; notice, this list of conditions and the following disclaimer.
21 ;; 2. Redistributions in binary form must reproduce the above copyright
22 ;; notice, this list of conditions and the following disclaimer in the
23 ;; documentation and/or other materials provided with the distribution.
25 ;; 3. Neither the name of the author nor the names of any contributors
26 ;; may be used to endorse or promote products derived from this
27 ;; software without specific prior written permission.
29 ;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
30 ;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
31 ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
32 ;; DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
33 ;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
34 ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
35 ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
36 ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
37 ;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
38 ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
39 ;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
43 ;; First up, let me say that this would not have been possible if
44 ;; it weren't for JWZ's jwz-lj.el. In fact, large portions of
45 ;; lj.el were lifted directly from jwz-lj.el. So, thank you very
48 ;;; *** IMPORTANT BIT ***
50 ;; You MUST compose your LJ posts in raw HTML (XHTML 1.0 Transitional
51 ;; if you plan on validating the markup before you submit the post).
52 ;; Don't bitch and complain about how hard or inconvenient that is.
53 ;; I'm not listening. The buffer where you write your posts is in a
54 ;; derivative of html-mode so you've got everything you need right at
55 ;; your fingertips. And anyway, writing your LJ posts in raw HTML
56 ;; gives you much more control over what the finished post will look
59 ;; Another important step before you can use lj.el is to log into
60 ;; your LiveJournal a/c with your web browser and check the "remember
61 ;; me" box on the login page. This is the only way to have your
62 ;; password stored in your cookies. Don't worry, it is encrypted.
64 ;;; A Note about validating your markup:
66 ;; Before you can validate your posts (with psgml) you need to
69 ;; o You have both, the psgml, and psgml-dtds XEmacs packages
70 ;; installed. Well, duh!
72 ;; o You have a working sgml toolchain. It is way beyond the
73 ;; scope of this lib (or my patience) to show you how.
74 ;; Instead, do what the pros do and see:
76 ;; http://www.linuxfromscratch.org/blfs/view/svn/pst/sgml.html
78 ;; o psgml needs to know where your catalog files are. The
79 ;; easiest way to do that is to set SGML_CATALOG_FILES in
80 ;; your shell environment...
82 ;; export SGML_CATALOG_FILES=/etc/sgml/catalog:/path/to/psgml-dtds/CATALOG
86 ;; Whack this lib into your load-path somewhere and...
88 ;; (setq lj-user-id "your_lj_id")
90 ;; When you want to compose a new LJ entry... M-x lj RET
92 ;; There's nothing hard or overly complicated here. Take a look at
93 ;; describe-mode (`C-h m') which will show you the keybindings
94 ;; available. All of the "lj-mode specific" interactive commands
95 ;; have a binding. There are 5 "global" commands that don't...
100 ;; #'lj-edit-old-post
101 ;; #'lj-delete-old-post
103 ;; The only reason they don't have keybindings is that I think it'd
104 ;; be bad form on my part to set global keys for you. Assign them
105 ;; to keys if you want.
107 ;; All of the "headers" have completion too. A couple of tips
108 ;; about the completion...
110 ;; - By default iso-left-tab (that's shift-tab for the clueless)
111 ;; will cycle backwards.
113 ;; - The trick to getting multiple tags is to type a comma (`,')
114 ;; plus the first letter or two of the next tag you wanna use
115 ;; after the last inserted tag.
121 ;; o Make "Writer's Block" a bit friendlier. Add the ability to
122 ;; choose different qotd's after one has been selected. Also, be
123 ;; able to view older qotd's.
129 ;; I've tried to make this compatible with XEmacs 21.5 and 21.4,
130 ;; but I don't have either of those installed so I'm not 100%
131 ;; certain. As for GNU/Emacs... absolutely no idea, but I'd doubt
132 ;; that this is anywhere near compatible.
136 (defconst lj-version 1.31
137 "Version number of SXEmacs/LJ.")
141 (autoload #'html-mode "psgml-html" nil t)
142 (autoload #'executable-find "executable")
143 (autoload #'completing-read-multiple "crm")
144 (autoload #'sgml-indent-or-tab "psgml" nil t)
145 (autoload #'sgml-parse-prolog "psgml-parse" nil t)
146 (autoload #'sgml-validate "psgml" nil t)
147 (autoload #'sgml-default-validate-command "psgml")
148 (autoload #'browse-url-of-buffer "browse-url" nil t)
149 (autoload #'customize-apropos "cus-edit" nil t)
150 (autoload #'customize-group "cus-edit" nil t)
151 (autoload #'regexp-opt "regexp-opt")
152 (autoload #'sqlite-open "ffi-sqlite")
153 (autoload #'sqlite-rows "ffi-sqlite")
154 (autoload #'sqlite-close "ffi-sqlite")
155 (autoload #'url-cookie-retrieve "url-cookie")
156 (autoload #'url-cookie-name "url-cookie")
157 (autoload #'url-cookie-value "url-cookie")
158 (defvar sxemacs-codename)
159 (defvar xemacs-codename)
160 (defvar url-cookie-secure-storage)
161 (defvar url-cookie-file))
164 (require 'hm--html-configuration)
165 (require 'psgml-html)
167 (unless (fboundp #'when-fboundp)
169 (autoload #'mm-url-insert "mm-url"))
174 :link '(url-link "http://www.livejournal.com/")
177 (defun lj-customise-faces ()
178 "Customise the lj.el faces."
180 (customize-apropos "^lj-" 'faces))
182 (defun lj-customise-group ()
183 "Customise lj.el user options."
185 (customize-group "lj"))
187 (defcustom lj-self-promote t
188 "When non-nil, a \"Posted via...\" byline is added to a post.
190 The text is a single line in small print (8pt) right justified at the
191 very end of your post. It should be quite inconspicuous, but you are
192 welcome to turn this off if you are too bashful to let the world know
193 what software you use."
197 (defcustom lj-user-id (user-login-name)
202 (defcustom lj-signature nil
203 "A signature to add to the bottom of a post.
205 This is analogous to an email signature. Set this any HTML marked up
206 text you like, or something that returns such. Remember to use valid
207 XHTML 1.0 Transitional if you plan to validate before posting."
211 (defcustom lj-cookie-flavour 'auto
212 "*The default cookie flavour \(browser\) to search for cookies."
214 (symbol :tag "Automatic" :value auto)
215 (symbol :tag "Chrome" :value chrome)
216 (symbol :tag "Firefox" :value firefox)
217 (symbol :tag "Seamonkey" :value seamonkey)
218 (symbol :tag "Mozilla" :value mozilla)
219 (symbol :tag "Galeon" :value galeon)
220 (symbol :tag "Safari" :value safari)
221 (symbol :tag "Netscape" :value netscape)
222 (symbol :tag "Midori" :value midori)
223 (symbol :tag "Emacs-W3" :value w3))
226 (defcustom lj-default-security-level "public"
227 "*The default security level LJ posts will have."
229 (string :tag "Public" :value "public")
230 (string :tag "Private" :value "private")
231 (string :tag "All Friends" :value "usemask")
232 (string :tag "Group..."))
235 (defcustom lj-directory (paths-construct-path
236 (list (user-home-directory) ".lj"))
237 "*Directory for storing tags and archiving posts."
241 (defcustom lj-tags-file (expand-file-name "ljtags" lj-directory)
242 "*File to store list of LJ tags."
246 (defcustom lj-groups-file (expand-file-name "ljgrps" lj-directory)
247 "*File to store list of LJ friends groups."
251 (defcustom lj-moods-file (expand-file-name "ljmoods" lj-directory)
252 "*File to store list of LJ \"moods\"."
256 (defcustom lj-pickws-file (expand-file-name "pickws" lj-directory)
257 "*File to store list of LJ user picture keywords."
261 (defcustom lj-userpic-directory
262 (file-name-as-directory
263 (expand-file-name "images" lj-directory))
264 "*Directory to store LJ userpic files."
268 (defcustom lj-drafts-directory
269 (file-name-as-directory
270 (expand-file-name "drafts" lj-directory))
271 "*Directory where post drafts are stored."
276 "A list of LJ tags.")
278 (defvar lj-groups nil
279 "A list of LJ friends groups.")
282 "LiveJournal \"moods\".")
284 (defvar lj-pickws nil
285 "A list of LJ userpic keywords.")
287 (defvar lj-default-pickw nil
288 "The default LJ userpic keyword.")
290 ;; See mpd.el in the same repo as lj.el
291 (defcustom lj-music (and (featurep 'mpd) #'mpd-now-playing)
292 "*A function to retrieve current song for LJ music header.
293 This function should return a formatted string, or nil."
297 (defcustom lj-archive-posts t
298 "*Keep an archive copy of LJ posts when non-nil."
302 (defcustom lj-archive-directory
303 (file-name-as-directory
304 (expand-file-name "archive" lj-directory))
305 "*Directory where LJ posts are archived."
309 (defcustom lj-bcc-address nil
310 "*Email address to send a copy of LJ posts to.
311 Set to nil to disable."
315 (defcustom lj-default-location nil
316 "*Default for the Location header."
320 (defcustom lj-before-preview-hook nil
321 "*Hook run before previewing a post."
325 (defcustom lj-after-preview-hook nil
326 "*Hook run as the last thing from `lj-preview'."
330 (defcustom lj-before-validate-hook nil
331 "*Hook run before validating a post."
335 (defcustom lj-after-validate-hook nil
336 "*Hook run as the last thing from `lj-validate'."
340 (defcustom lj-init-hook nil
341 "*Hook run before anything else is done when starting lj."
345 (defcustom lj-before-post-hook nil
346 "*Hook run before posting."
350 (defcustom lj-after-post-hook nil
351 "*Hook run after posting."
355 (defcustom lj-cut-hook nil
356 "*Hooks run after inserting an LJ-CUT."
360 (defcustom lj-poll-hook nil
361 "*Hooks run after inserting a LJ Poll."
365 (defcustom lj-journal-hook nil
366 "*Hooks run after inserting a LJ Journal link."
370 (defcustom lj-youtube-hook nil
371 "*Hooks run after inserting a youtube/google video."
375 (defconst lj-clientversion
376 (concat (when (featurep 'sxemacs) "S")
378 emacs-program-version
379 (format "/LJ: %.2f" lj-version))
380 "Client version string.")
382 (defconst lj-useragent
384 (when (featurep 'sxemacs) "S")
386 emacs-program-version
387 (format " [%s]:LJ-%.2f; steve@sxemacs.org)"
388 (if (featurep 'sxemacs)
392 "Useragent string sent to livejournal.com.")
394 (defconst lj-validate-header
395 "<?xml version=\"1.0\" encoding=\"utf-8\"?>
396 <!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\"
397 \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">
399 <html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\" lang=\"en\">
401 <title>LJ Post Preview</title>
403 <style type=\"text/css\">
405 background: rgb(204,204,255);
409 font-family: times new roman, verdana, helvetica, sans-serif;
414 background: rgb(255,235,205);
434 "Header used to construct HTML doc for previewing and validating LJ posts.")
436 (defconst lj-validate-footer
441 <!-- Leave this comment at the end of this file
443 sgml-validate-command:\"onsgmls -E0 -wall -wno-unused-param -wfully-tagged -wfully-declared -wtype-valid -wintegral -s %s %s\"
446 sgml-namecase-general:nil
447 sgml-general-insert-case:lower
448 sgml-minimize-attributes:nil
449 sgml-always-quote-attributes:t
452 sgml-parent-document:nil
453 sgml-exposed-tags:nil
454 sgml-local-catalogs:nil
455 sgml-local-ecat-files:nil
459 "Footer used to construct HTML doc for previewing and validating LJ posts.")
461 (defconst lj-base-url
462 "http://www.livejournal.com/interface/flat"
463 "The base URL where LJ posts are submitted etc.")
465 (defvar lj-last-entry-btime nil
466 "The date/time of the last posted entry as a big integer.")
468 (defun lj-parse-time-string (string)
469 "Parse a time STRING of the format \"YYYY-MM-DD HH:MM:SS\".
471 The seconds field can be ommitted and in that case 0 is used.
473 Returns a list suitable for passing to `encode-time' or `encode-btime'."
474 (let ((regexp (concat "^\\([12][0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\)\\s-"
475 "\\([0-9]+\\):\\([0-9]+\\)\\(:\\([0-9]+\\)\\)?$")))
476 (if (string-match regexp string)
477 (let ((year (string-to-int (substring string
480 (month (string-to-int (substring string
483 (day (string-to-int (substring string
486 (hour (string-to-int (substring string
489 (min (string-to-int (substring string
492 (sec (if (eq (length string) 19)
493 (string-to-int (substring string (match-beginning 7)
496 (unless (and (>= year 1970)
498 (error 'invalid-argument year))
499 (unless (and (>= month 1)
501 (error 'invalid-argument month))
502 (unless (and (>= day 1)
504 (error 'invalid-argument day))
505 (unless (and (>= hour 0)
507 (error 'invalid-argument hour))
508 (unless (and (>= min 0)
510 (error 'invalid-argument min))
511 (unless (and (>= sec 0)
513 (error 'invalid-argument sec))
514 (list sec min hour day month year))
515 (error 'invalid-argument string))))
517 ;; Probably should set up a proper prefix
519 (let ((map (make-sparse-keymap)))
520 (set-keymap-name map 'lj-mode-map)
521 (define-key map [(control ?c) (control return)] #'lj-post)
522 (define-key map [(control ?c) ?F] #'lj-customise-faces)
523 (define-key map [(control ?c) ?G] #'lj-customise-group)
524 (define-key map [(control ?c) ?P] #'lj-insert-poll)
525 (define-key map [(control ?c) ?c] #'lj-cut-region)
526 (define-key map [(control ?c) ?j] #'lj-insert-journal)
527 (define-key map [(control ?c) ?p] #'lj-preview)
528 (define-key map [(control ?c) ?w] #'lj-writers-block)
529 (define-key map [(control ?c) ?y] #'lj-insert-youtube)
530 (define-key map [(control ?c) (control ?f) ?M] #'lj-goto-mood)
531 (define-key map [(control ?c) (control ?f) ?S] #'lj-goto-security)
532 (define-key map [(control ?c) (control ?f) ?b] #'lj-goto-bcc)
533 (define-key map [(control ?c) (control ?f) ?c] #'lj-goto-community)
534 (define-key map [(control ?c) (control ?f) ?f] #'lj-goto-fcc)
535 (define-key map [(control ?c) (control ?f) ?l] #'lj-goto-location)
536 (define-key map [(control ?c) (control ?f) ?m] #'lj-goto-music)
537 (define-key map [(control ?c) (control ?f) ?s] #'lj-goto-subject)
538 (define-key map [(control ?c) (control ?f) ?t] #'lj-goto-tags)
539 (define-key map [(control ?c) (control ?f) ?u] #'lj-goto-userpic)
540 (define-key map [(control ?c) (control ?b)] #'lj-goto-body)
541 (define-key map [(control meta ?v)] #'lj-validate)
542 (define-key map [tab] #'lj-sgml-indent-tab-or-complete)
543 (define-key map [iso-left-tab] #'lj-complete-header-backwards)
546 (defvar lj-header-separator "--text follows this line--"
547 "Text to denote the end of the headers and beginning of the message.")
549 ;; Faces (defaults are probably crap for a light background)
550 (defun lj-face-p (face)
551 "Call facep on FACE."
552 (facep (find-face face)))
554 (make-face 'lj-header-name "Face used for LJ headers.")
555 (set-face-parent 'lj-header-name (or (and (lj-face-p 'message-header-name)
556 'message-header-name)
557 (and (lj-face-p 'message-header-name-face)
558 'message-header-name-face)
561 (make-face 'lj-header-subject "Face used for LJ Subject header content.")
562 (set-face-parent 'lj-header-subject
563 (or (and (lj-face-p 'message-header-subject)
564 'message-header-subject)
565 (and (lj-face-p 'message-header-subject-face)
566 'message-header-subject-face)
569 (make-face 'lj-header-fcc "Face used for LJ FCC header content.")
570 (set-face-parent 'lj-header-fcc 'font-lock-comment-face)
571 (make-face 'lj-header-bcc "Face used for LJ BCC header content.")
572 (set-face-parent 'lj-header-bcc (or (and (lj-face-p 'message-header-cc)
574 (and (lj-face-p 'message-header-cc-face)
575 'message-header-cc-face)
578 (make-face 'lj-header-security "Face used for LJ Security header content.")
579 (set-face-parent 'lj-header-security 'font-lock-warning-face)
581 (make-face 'lj-header-music "Face used for LJ Music header content.")
582 (set-face-parent 'lj-header-music
583 (or (and (lj-face-p 'message-header-xheader)
584 'message-header-xheader)
585 (and (lj-face-p 'message-header-xheader-face)
586 'message-header-xheader-face)
587 'font-lock-builtin-face))
589 (make-face 'lj-header-mood "Face used for LJ Mood header content.")
590 (set-face-parent 'lj-header-mood
591 (or (and (lj-face-p 'message-header-other)
592 'message-header-other)
593 (and (lj-face-p 'message-header-other-face)
594 'message-header-other-face)
595 'font-lock-function-name-face))
597 (make-face 'lj-header-userpic "Face used for LJ Userpic header content.")
598 (set-face-parent 'lj-header-userpic
599 (or (and (lj-face-p 'message-header-other)
600 'message-header-other)
601 (and (lj-face-p 'message-header-other-face)
602 'message-header-other-face)
603 'font-lock-function-name-face))
605 (make-face 'lj-header-tags "Face used for LJ Tags header content.")
606 (set-face-parent 'lj-header-tags
607 (or (and (lj-face-p 'message-header-newsgroups)
608 'message-header-newsgroups)
609 (and (lj-face-p 'message-header-newsgroups-face)
610 'message-header-newsgroups-face)
611 'font-lock-keyword-face))
613 (make-face 'lj-header-community "Face used for LJ Community header content.")
614 (set-face-parent 'lj-header-community 'lj-header-userpic)
616 (make-face 'lj-header-location "Face used for LJ Location header content.")
617 (set-face-parent 'lj-header-location 'lj-header-userpic)
619 (make-face 'lj-separator "Face used for the LJ header separator.")
620 (copy-face 'bold 'lj-separator)
621 (set-face-foreground 'lj-separator "red")
623 (make-face 'lj-header-itemid "Face used for LJ ItemID header content.")
624 (set-face-parent 'lj-header-itemid 'lj-separator)
626 (make-face 'lj-header-url "Face used for LJ URL header content.")
627 (set-face-parent 'lj-header-url 'lj-separator)
629 ;; compatibility hoohar
630 (unless (featurep 'sxemacs)
631 (fset #'defregexp #'defvar))
633 (defun lj-utf-emacs-p ()
634 "Return non-nil if this S?XEmacs has utf-8 coding-system."
635 (and (featurep 'mule)
636 (declare-fboundp (find-coding-system 'utf-8))))
638 (defregexp lj-header-regexp
639 (let ((headers '("Subject" "FCC" "BCC" "Security" "Community"
640 "Location" "Mood" "Music" "Userpic" "Tags"
641 "X-LJ-URL" "X-LJ-ItemID")))
642 (concat (regexp-opt headers t) ":"))
643 "Regular expression matching LJ headers.")
645 (defvar lj-font-lock-keywords
647 `((,lj-header-regexp 0 lj-header-name)
648 ("^Subject: \\(.*$\\)" 1 lj-header-subject)
649 ("^FCC: \\(.*$\\)" 1 lj-header-fcc)
650 ("^BCC: \\(.*$\\)" 1 lj-header-bcc)
651 ("^Security: \\(.*$\\)" 1 lj-header-security)
652 ("^Community: \\(.*$\\)" 1 lj-header-community)
653 ("^Music: \\(.*$\\)" 1 lj-header-music)
654 ("^Mood: \\(.*$\\)" 1 lj-header-mood)
655 ("^Location: \\(.*$\\)" 1 lj-header-location)
656 ("^Userpic: \\(.*$\\)" 1 lj-header-userpic)
657 ("^Tags: \\(.*$\\)" 1 lj-header-tags)
658 ("^X-LJ-URL: \\(.*$\\)" 1 lj-header-url)
659 ("^X-LJ-ItemID: \\(.*$\\)" 1 lj-header-itemid)
660 (,(regexp-quote lj-header-separator) 0 lj-separator))
661 hm--html-font-lock-keywords
662 html-font-lock-keywords)
663 "Font lock keywords for `lj-mode'.")
665 ;; kill/yank'd from jwz-lj.el
666 (defconst lj-entity-table
667 '(("iexcl" . ?\¡) ("cent" . ?\¢) ("pound" . ?\£) ("euro" . ?\~)
668 ("curren" . ?\¤) ("yen" . ?\¥) ("brvbar" . ?\¦) ("sect" . ?\§)
669 ("uml" . ?\¨) ("copy" . ?\©) ("ordf" . ?\ª) ("laquo" . ?\«)
670 ("not" . ?\¬) ("shy" . ?\) ("reg" . ?\®) ("macr" . ?\¯)
671 ("deg" . ?\°) ("plusmn" . ?\±) ("sup2" . ?\²) ("sup3" . ?\³)
672 ("acute" . ?\´) ("micro" . ?\µ) ("para" . ?\¶) ("middot" . ?\·)
673 ("cedil" . ?\¸) ("sup1" . ?\¹) ("ordm" . ?\º) ("raquo" . ?\»)
674 ("frac14" . ?\¼) ("frac12" . ?\½) ("frac34" . ?\¾) ("iquest" . ?\¿)
675 ("Agrave" . ?\À) ("Aacute" . ?\Á) ("Acirc" . ?\Â) ("Atilde" . ?\Ã)
676 ("Auml" . ?\Ä) ("Aring" . ?\Å) ("AElig" . ?\Æ) ("Ccedil" . ?\Ç)
677 ("Egrave" . ?\È) ("Eacute" . ?\É) ("Ecirc" . ?\Ê) ("Euml" . ?\Ë)
678 ("Igrave" . ?\Ì) ("Iacute" . ?\Í) ("Icirc" . ?\Î) ("Iuml" . ?\Ï)
679 ("ETH" . ?\Ð) ("Ntilde" . ?\Ñ) ("Ograve" . ?\Ò) ("Oacute" . ?\Ó)
680 ("Ocirc" . ?\Ô) ("Otilde" . ?\Õ) ("Ouml" . ?\Ö) ("times" . ?\×)
681 ("Oslash" . ?\Ø) ("Ugrave" . ?\Ù) ("Uacute" . ?\Ú) ("Ucirc" . ?\Û)
682 ("Uuml" . ?\Ü) ("Yacute" . ?\Ý) ("THORN" . ?\Þ) ("szlig" . ?\ß)
683 ("agrave" . ?\à) ("aacute" . ?\á) ("acirc" . ?\â) ("atilde" . ?\ã)
684 ("auml" . ?\ä) ("aring" . ?\å) ("aelig" . ?\æ) ("ccedil" . ?\ç)
685 ("egrave" . ?\è) ("eacute" . ?\é) ("ecirc" . ?\ê) ("euml" . ?\ë)
686 ("igrave" . ?\ì) ("iacute" . ?\í) ("icirc" . ?\î) ("iuml" . ?\ï)
687 ("eth" . ?\ð) ("ntilde" . ?\ñ) ("ograve" . ?\ò) ("oacute" . ?\ó)
688 ("ocirc" . ?\ô) ("otilde" . ?\õ) ("ouml" . ?\ö) ("divide" . ?\÷)
689 ("oslash" . ?\ø) ("ugrave" . ?\ù) ("uacute" . ?\ú) ("ucirc" . ?\û)
690 ("uuml" . ?\ü) ("yacute" . ?\ý) ("thorn" . ?\þ) ("yuml" . ?\ÿ)
692 "HTML entities to Latin1 characters.")
694 ;; adapted from jwz-lj.el
695 (defun lj-entify-region (beg end)
696 "Convert non-ASCII chars in the region BEG - END to HTML entities."
697 (let ((regex (if (featurep 'sxemacs)
699 ;; ho-hum, life would be simpler if XEmacs enabled
701 (concat "[" (mapconcat
703 (make-string 1 (cdr c)))
706 (case-fold-search nil))
709 (setq end (copy-marker end))
710 (while (re-search-forward regex end t)
711 (let* ((char (preceding-char))
712 (entity (or (car (rassq char lj-entity-table))
713 (error "No entity %c" char))))
715 (insert-before-markers "&" entity ";")))))
716 (and-fboundp #'charsets-in-region
717 (delq 'ascii (charsets-in-region beg end))
718 (error "Non-ASCII characters exist in this buffer")))
720 (defconst lj-unreserved-chars
721 '(?a ?b ?c ?d ?e ?f ?g ?h ?i ?j ?k ?l ?m
722 ?n ?o ?p ?q ?r ?s ?t ?u ?v ?w ?x ?y ?z
723 ?A ?B ?C ?D ?E ?F ?G ?H ?I ?J ?K ?L ?M
724 ?N ?O ?P ?Q ?R ?S ?T ?U ?V ?W ?X ?Y ?Z
725 ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9
726 ?- ?_ ?. ?! ?~ ?* ?' ?\( ?\))
727 "A list of characters that are _NOT_ reserved in the URL spec.
728 This is taken from RFC 2396.")
730 (defun lj-hexify-string (str &optional http-entify)
731 "Escape characters STR so STR can be used in a URL.
733 With non-nil HTTP-ENTIFY, convert non-ASCII characters to HTTP
738 (lj-entify-region (point-min) (point-max)))
741 (if (not (memq char lj-unreserved-chars))
743 (format "%%0%X" char)
745 (error "Hexifying multibyte character %s" str))
746 (format "%%%X" char))
747 (char-to-string char)))
748 (buffer-string) "")))
750 (when-fboundp #'ffi-defun
752 (require 'ffi-sqlite)
753 (require 'ffi-curl)))
755 ;; adapted from jwz-lj.el
756 (defun lj-extract-sql-cookies (file chromep)
757 "Extract LJ cookie data from SQL cookies FILE.
759 Non-nil CHROMEP forces a Google Chrome compatible sql query."
760 (let ((sql (if chromep
761 ;; chrome sql cookies
762 (concat "SELECT name,value FROM cookies "
763 "WHERE host_key=\".www.livejournal.com\" "
764 "OR host_key=\".livejournal.com\"")
765 ;; mozilla based sql cookies
766 (concat "SELECT name,value FROM moz_cookies "
767 "WHERE host=\".www.livejournal.com\" "
768 "OR host=\".livejournal.com\""))))
769 (if (featurep 'ffi-sqlite)
770 ;; Try SXEmacs' sexy ffi-sqlite if it's available
771 (let* ((db (sqlite-open file))
772 (rows (sqlite-rows db sql)))
778 (concat (car c) "=" (cadr c)))
781 ;; The old fashioned way
782 (unless (executable-find "sqlite3")
783 (error "Can't find sqlite3"))
784 (let* ((sql (shell-command-to-string
785 (concat "sqlite3 " file "'" sql ";'")))
787 (split-string-by-char
788 (replace-regexp-in-string "\n" "|" sql) ?|)))
791 (push (cons (car slist) (cadr slist)) cookies)
792 (setq slist (cddr slist)))
797 (concat (car c) "=" (cdr c)))
798 (reverse cookies) "; ")
801 ;;; FIXME: redo this with #'xml-parse-file. Just as soon as I can get
802 ;; me grubby little hands on one of these xml cookie files.
803 ;; kill/yank'd from jwz-lj.el
804 ;;; FIXME: this will now be broken!
805 (defun lj-extract-xml-cookies (file)
806 "Extract LJ data from XML cookies FILE."
809 (narrow-to-region (point) (point))
810 (insert-file-contents file nil nil nil t)
811 (goto-char (point-min))
812 (search-forward "<dict>")
816 domain path name value)
817 (while (search-forward "</dict>" nil t)
821 ((search-forward "livejournal.com" end t) ; bail fast
824 (re-search-forward (concat "<key>Domain</key>[ \t\n\r]*"
825 "<string>\\([^<>]+\\)</string>")
827 (setq domain (match-string 1))
829 (re-search-forward (concat "<key>Path</key>[ \t\n\r]*"
830 "<string>\\([^<>]+\\)</string>")
832 (setq path (match-string 1))
834 (re-search-forward (concat "<key>Name</key>[ \t\n\r]*"
835 "<string>\\([^<>]+\\)</string>")
837 (setq name (match-string 1))
839 (re-search-forward (concat "<key>Value</key>[ \t\n\r]*"
840 "<string>\\([^<>]+\\)</string>")
842 (setq value (match-string 1))
843 (if (string-match "\\blivejournal\\.com$" domain)
845 (concat domain "\tTRUE\t" path "\tFALSE\t0\t"
850 (delete-region (point-min) (point-max))
854 (defun lj-extract-text-cookies (file)
855 "Extract LJ data from text based cookies FILE."
856 (let ((host-match "\\.livejournal\\.com$")
859 (insert-file-contents-literally file)
860 (goto-char (point-min))
862 (when (looking-at (concat "^\\([^\t\r\n]+\\)\t" ; 1 host
863 "\\([^\t\r\n]+\\)\t" ; 2 bool
864 "\\([^\t\r\n]+\\)\t" ; 3 path
865 "\\([^\t\r\n]+\\)\t" ; 4 bool
866 "\\([^\t\r\n]+\\)\t" ; 5 time_t
867 "\\([^\t\r\n]+\\)\t" ; 6 key
868 "\\([^\t\r\n]+\\)$")) ; 7 val
869 (let ((host (match-string 1))
870 (key (match-string 6))
871 (val (match-string 7)))
872 (when (and (string-match host-match host)
873 (not (assoc key cookies)))
874 (setq cookies (cons (cons key val) cookies))))
880 (concat (car c) "=" (cdr c)))
881 (nreverse cookies) "; ")
884 (defun lj-extract-w3-cookies ()
885 "Extract LJ cookie data from Emacs-W3 cookies."
886 (let* ((secure (and url-cookie-secure-storage t))
887 (w3cookies (remove-duplicates
888 (append (url-cookie-retrieve
889 "www.livejournal.com" "/" secure)
891 ".livejournal.com" "/" secure))
894 (replace-regexp-in-string
899 (unless (string-equal (url-cookie-name c) "HttpOnly")
900 (concat (url-cookie-name c) "=" (url-cookie-value c))))
901 (nreverse w3cookies) "; ")
904 ;; adapted from jwz-lj.el, but rewritten from scratch
905 (defun lj-get-cookies (flavour)
906 "Return a string of LJ cookie data suitable for HTTP POST'ing.
908 Argument FLAVOUR specifies which browser's cookies to check. If it is
909 the symbol `auto' \(the default\) all browsers will be searched in the
912 Google Chrome, Firefox, SeaMonkey, Mozilla, Galeon, Safari, Nescape,
913 Midori, and Emacs-W3 for cookie data."
918 (when (or (eq flavour 'chrome)
920 (let ((dir (paths-construct-path
921 '(".config" "google-chrome" "Default")
922 (user-home-directory))))
923 (and (file-exists-p (expand-file-name "Cookies" dir))
924 (setq cookies (lj-extract-sql-cookies
925 (expand-file-name "Cookies" dir) t))))
927 (throw 'found cookies)
928 (when (not (eq flavour 'auto))
929 (lj-get-cookies 'auto))))
931 ;; Firefox 1-3 (works for sqlite cookies, plain text cookies are
933 (when (or (eq flavour 'firefox)
935 (let ((d1 (paths-construct-path
936 '("Library" "Application Support" "Firefox" "Profiles")
937 (user-home-directory)))
938 (d2 (paths-construct-path
939 '(".mozilla" "firefox") (user-home-directory)))
941 (if (file-directory-p d1)
942 (setq dir (car (directory-files d1 t "\\.default$" nil 'dirs)))
943 (setq dir (car (directory-files d2 t "\\.default$" nil 'dirs))))
944 (or (and (file-exists-p (expand-file-name "cookies.txt" dir))
945 (setq cookies (lj-extract-text-cookies
946 (expand-file-name "cookies.txt" dir))))
947 (and (file-exists-p (expand-file-name "cookies.sqlite" dir))
948 (setq cookies (lj-extract-sql-cookies
949 (expand-file-name "cookies.sqlite" dir) nil)))))
951 (throw 'found cookies)
952 (when (not (eq flavour 'auto))
953 (lj-get-cookies 'auto))))
955 ;; SeaMonkey (untested)
956 (when (or (eq flavour 'seamonkey)
958 (when (file-directory-p (expand-file-name ".mozilla/seamonkey"
959 (user-home-directory)))
960 (let ((dir (car (directory-files "~/.mozilla/seamonkey"
961 t "\\.default$" nil 'dirs))))
962 (or (and (file-exists-p (expand-file-name "cookies.txt" dir))
963 (setq cookies (lj-extract-text-cookies
964 (expand-file-name "cookies.txt" dir))))
965 (and (file-exists-p (expand-file-name "cookies.sqlite" dir))
966 (setq cookies (lj-extract-sql-cookies
967 (expand-file-name "cookies.sqlite" dir) nil))))))
969 (throw 'found cookies)
970 (when (not (eq flavour 'auto))
971 (lj-get-cookies 'auto))))
973 ;; Mozilla (untested)
974 (when (or (eq flavour 'mozilla)
976 (when (file-directory-p (expand-file-name ".mozilla"
977 (user-home-directory)))
978 (let ((d1 (paths-construct-path '(".mozilla" "default")
979 (user-home-directory)))
980 (d2 (paths-construct-path `(".mozilla" ,(user-login-name))
981 (user-home-directory)))
983 (if (file-directory-p d1)
984 (setq dir (car (directory-files d1 t "\\.slt$" nil 'dirs)))
985 (setq dir (car (directory-files d2 t "\\.slt$" nil 'dirs))))
986 (and (file-exists-p (expand-file-name "cookies.txt" dir))
987 (setq cookies (lj-extract-text-cookies
988 (expand-file-name "cookies.txt" dir))))))
990 (throw 'found cookies)
991 (when (not (eq flavour 'auto))
992 (lj-get-cookies 'auto))))
995 (when (or (eq flavour 'galeon)
997 (let ((dir (paths-construct-path
998 '(".galeon" "mozilla" "galeon") (user-home-directory))))
999 (and (file-exists-p (expand-file-name "cookies.txt" dir))
1000 (setq cookies (lj-extract-text-cookies
1001 (expand-file-name "cookies.txt" dir)))))
1003 (throw 'found cookies)
1004 (when (not (eq flavour 'auto))
1005 (lj-get-cookies 'auto))))
1007 ;; Safari (untested)
1008 (when (or (eq flavour 'safari)
1010 (let ((dir (paths-construct-path '("Library" "Cookies")
1011 (user-home-directory))))
1012 (and (file-exists-p (expand-file-name "Cookies.plist" dir))
1013 (setq cookies (lj-extract-xml-cookies
1014 (expand-file-name "Cookies.plist" dir)))))
1016 (throw 'found cookies)
1017 (when (not (eq flavour 'auto))
1018 (lj-get-cookies 'auto))))
1020 ;; Netscape (untested)
1021 (when (or (eq flavour 'netscape)
1023 (let ((dir (paths-construct-path '(".netscape")
1024 (user-home-directory))))
1025 (and (file-exists-p (expand-file-name "cookies" dir))
1026 (setq cookies (lj-extract-text-cookies
1027 (expand-file-name "cookies" dir)))))
1029 (throw 'found cookies)
1030 (when (not (eq flavour 'auto))
1031 (lj-get-cookies 'auto))))
1033 ;; Midori (works, but Midori doesn't take too much care about
1034 ;; invalid or broken cookies so YMMV here)
1035 (when (or (eq flavour 'midori)
1037 (let ((dir (paths-construct-path '(".config" "midori")
1038 (user-home-directory))))
1039 (and (file-exists-p (expand-file-name "cookies.txt" dir))
1040 (setq cookies (lj-extract-text-cookies
1041 (expand-file-name "cookies.txt" dir)))))
1043 (throw 'found cookies)
1044 (when (not (eq flavour 'auto))
1045 (lj-get-cookies 'auto))))
1047 ;; Emacs-W3 URL (works with W3 in XE packages)
1048 (when (or (eq flavour 'w3)
1050 (and (file-exists-p url-cookie-file)
1051 (setq cookies (lj-extract-w3-cookies)))
1053 (throw 'found cookies)
1054 (when (not (eq flavour 'auto))
1055 (lj-get-cookies 'auto))))
1057 ;; Gah! no cookes anywhere!
1058 (error 'search-failed "LJ Cookie data"))))
1060 (defvar lj-cookies (lj-get-cookies lj-cookie-flavour)
1061 "Alist of cookie data to send to LJ.")
1063 ;; adapted from jwz-lj.el
1064 (defun lj-http-post (url cookies parser)
1065 "Sends a HTTP POST to URL with COOKIES.
1067 Argument PARSER is a function to handle parsing the output received."
1068 (unless (string-match "\\`https?://\\([^/]+\\)\\([^?&]+\\)\\?\\(.*\\)\\'" url)
1069 (error "Unparsable url: %s" url))
1070 (let* ((host (match-string 1 url))
1072 (path (match-string 2 url))
1073 (args (match-string 3 url))
1075 (concat "POST " path " HTTP/1.0\r\n"
1076 "Content-Type: application/x-www-form-urlencoded\r\n"
1077 "Content-Length: " (int-to-string (length args)) "\r\n"
1078 "Host: " host "\r\n"
1079 "X-LJ-Auth: cookie\r\n"
1083 (buf (generate-new-buffer " *LJ-process*"))
1085 (setq proc (open-network-stream "LiveJournal" buf host port))
1086 (when (lj-utf-emacs-p)
1087 (set-process-coding-system proc 'utf-8 'utf-8))
1088 (process-send-string proc post-cmd)
1089 (message "HTTP POST sent to %s" host)
1090 (while (eq (process-status proc) 'open)
1091 (unless (accept-process-output proc 60)
1092 (delete-process proc)
1093 (error "[LJ] Server error: timeout")))
1094 (funcall parser buf)))
1096 (defun lj-proc-success ()
1097 "Return t when LJ processes are successful.
1099 By \"successful\" we mean that livejournal.com didn't complain about
1100 anything we sent it."
1101 (let ((regex "^success\n\\(.*$\\)")
1104 (goto-char (point-min))
1105 (if (re-search-forward regex nil t)
1106 (setq result (match-string 1))
1107 (error "[LJ] Server error: try again later"))
1108 (cond ((string= result "OK")
1110 ((string= result "FAIL")
1111 (let ((ereg "^errmsg\n\\(.*$\\)"))
1113 (goto-char (point-min))
1114 (re-search-forward ereg)
1115 (if (string-match "Incorrect time value" (match-string 1))
1116 (lj-post 'out-of-order)
1117 (error "[LJ]: %s" (match-string 1))))))
1119 (error "[LJ]: Unknown error"))))))
1121 (defun lj-friends-proc-parser (buf)
1122 "Processes the output from `lj-get-friends-groups'.
1123 Argument BUF is the process buffer used."
1124 (let ((regexp "^frgrp_\\([0-9]+\\)_name\n\\(.*$\\)")
1126 (with-current-buffer buf
1127 (when (lj-proc-success)
1128 (goto-char (point-min))
1129 (while (re-search-forward regexp nil t)
1131 (cons (cons (match-string 2) (string-to-int (match-string 1)))
1135 (or (file-directory-p lj-directory)
1136 (make-directory-path lj-directory))
1137 (with-current-buffer (find-file-noselect lj-groups-file)
1139 (insert ";;; Automatically generated DO NOT EDIT -*- Emacs-Lisp -*-\n"
1140 (format "(setq lj-groups (quote %S))" groups))
1142 (eval-current-buffer nil)
1143 (kill-buffer nil))))))
1145 (defun lj-get-friends-groups ()
1146 "Retrieve an alist of groups/groupids from Livejournal."
1147 (let ((cookies (or lj-cookies
1148 (error "No LJ cookies found")))
1149 (url (concat lj-base-url
1150 "?mode=getfriendgroups"
1152 "&auth_method=cookie"
1153 (format "&ver=%d" (if (lj-utf-emacs-p) 1 0)))))
1154 (lj-http-post url cookies #'lj-friends-proc-parser)))
1156 (defun lj-tags-proc-parser (buf)
1157 "Process the output from `lj-get-tags'.
1158 Argument BUF is the process buffer used."
1159 (let ((regexp "tag_[0-9]+_name\n\\(.*$\\)")
1161 (with-current-buffer buf
1162 (when (lj-proc-success)
1163 (goto-char (point-min))
1164 (while (re-search-forward regexp nil t)
1165 (push (match-string 1) tags))
1168 (or (file-directory-p lj-directory)
1169 (make-directory-path lj-directory))
1170 (with-current-buffer (find-file-noselect lj-tags-file)
1172 (insert ";;; Automatically generated DO NOT EDIT -*- Emacs-Lisp -*-\n"
1173 (format "(setq lj-tags (quote %S))" tags))
1175 (eval-current-buffer nil)
1176 (kill-buffer nil))))))
1178 (defun lj-get-tags ()
1179 "Retrieve a list of defined tags from Livejournal."
1180 (let ((cookies (or lj-cookies
1181 (error "No LJ cookies found")))
1182 (url (concat lj-base-url
1185 "&auth_method=cookie"
1186 (format "&ver=%d" (if (lj-utf-emacs-p) 1 0)))))
1187 (lj-http-post url cookies #'lj-tags-proc-parser)))
1189 (defun lj-get-userpic-noffi (url file)
1190 "Download userpic from URL to FILE."
1191 (if (executable-find "curl")
1192 (shell-command (concat "curl " url " -so " file) nil)
1193 (error 'unimplemented "non-FFI leeching")))
1195 (defun lj-get-userpics ()
1196 "Leech your userpics from livejournal.com."
1197 (unless (file-directory-p lj-userpic-directory)
1198 (make-directory-path lj-userpic-directory))
1199 (let ((pics (mapcar #'car lj-pickws)))
1202 (unless (file-exists-p
1203 (expand-file-name p lj-userpic-directory))
1204 (let ((file (expand-file-name p lj-userpic-directory))
1205 (url (cdr (assoc p lj-pickws))))
1206 (if (featurep '(and sxemacs ffi-curl))
1207 (declare-fboundp (curl:download url file))
1208 (lj-get-userpic-noffi url file)))))
1211 (defun lj-pickws-proc-parser (buf)
1212 "Process the output from `lj-get-pickws'.
1213 Argument BUF is the process buffer used."
1214 (let ((msg "^message\n\\(.*$\\)")
1215 defaultk defaultu keywords)
1216 (with-current-buffer buf
1217 (when (lj-proc-success)
1218 (goto-char (point-min))
1220 (re-search-forward "defaultpicurl\n\\(.*$\\)")
1221 (setq defaultu (match-string 1))
1224 (re-search-forward (concat "^pickwurl_\\([0-9]+\\)\n"
1227 (goto-char (point-min))
1228 (re-search-forward (concat "^pickw_" defidx "\n\\(.*$\\)") nil t)
1229 (setq defaultk (match-string 1))
1230 (setq keywords (cons (cons defaultk defaultu) keywords))))
1232 (while (re-search-forward "^pickw_\\([0-9]+\\)\n\\(.*$\\)" nil t)
1233 (let* ((key (match-string 2))
1234 (url (save-excursion
1235 (goto-char (point-min))
1236 (and (re-search-forward
1238 (match-string 1) "\n\\(.*$\\)") nil t)
1239 (match-string 1)))))
1240 (unless (string= key defaultk)
1241 (setq keywords (cons (cons key url) keywords))))))
1242 (when (re-search-forward msg nil t)
1243 (pop-to-buffer (get-buffer-create "*LJ Message*"))
1244 (insert "Important Message From LiveJournal:\n"
1245 "==================================\n\n")
1246 (insert (match-string 1)))
1249 (or (file-directory-p lj-directory)
1250 (make-directory-path lj-directory))
1251 (with-current-buffer (find-file-noselect lj-pickws-file)
1253 (insert ";;; Automatically generated DO NOT EDIT -*- Emacs-Lisp -*-\n"
1254 (format "(setq lj-pickws (quote %S))" keywords))
1255 (insert (format "\n(setq lj-default-pickw %S)" defaultk))
1257 (eval-current-buffer nil)
1258 (kill-buffer nil))))
1261 (defun lj-get-pickws ()
1262 "Retieve an alist of userpic keyword/url pairs."
1263 (let ((cookies (or lj-cookies
1264 (error "No LJ cookies found")))
1265 (url (concat lj-base-url
1268 "&auth_method=cookie"
1269 (format "&ver=%d" (if (lj-utf-emacs-p) 1 0))
1270 "&clientversion=" lj-clientversion
1272 "&getpickwurls=1")))
1273 (lj-http-post url cookies #'lj-pickws-proc-parser)))
1275 (defun lj-moods-proc-parser (buf)
1276 "Process the output from `lj-get-moods'.
1277 Argument BUF is the process buffer used."
1278 (let ((regexp "mood_[0-9]+_id\n\\(.*\\)\nmood_[0-9]+_name\n\\(.*\\)")
1279 (msg "^message\n\\(.*$\\)")
1281 (with-current-buffer buf
1282 (when (lj-proc-success)
1283 (goto-char (point-min))
1285 (while (re-search-forward regexp nil t)
1286 (setq moods (cons (cons (match-string 2)
1287 (string-to-int (match-string 1)))
1289 (when (re-search-forward msg nil t)
1290 (pop-to-buffer (get-buffer-create "*LJ Message*"))
1291 (insert "Important Message From LiveJournal:\n"
1292 "==================================\n\n")
1293 (insert (match-string 1)))
1295 (or (file-directory-p lj-directory)
1296 (make-directory-path lj-directory))
1297 (with-current-buffer (find-file-noselect lj-moods-file)
1299 (insert ";;; Automatically generated DO NOT EDIT -*- Emacs-Lisp -*-\n"
1300 (format "(setq lj-moods (quote %S))" moods))
1302 (eval-current-buffer nil)
1303 (kill-buffer nil)))))
1305 (defun lj-get-moods ()
1306 "Retieve an alist of mood/moodid pairs."
1307 (let ((cookies (or lj-cookies
1308 (error "No LJ cookies found")))
1309 (url (concat lj-base-url
1312 "&auth_method=cookie"
1313 (format "&ver=%d" (if (lj-utf-emacs-p) 1 0))
1314 "&clientversion=" lj-clientversion
1316 (lj-http-post url cookies #'lj-moods-proc-parser)))
1318 (defvar lj-last-user-set-time nil)
1320 ;; adapted from jwz-lj.el
1321 (defun lj-construct-url (subject body user
1322 &optional security tags community
1323 auto-format no-comments mood location
1324 music pickw date backdated itemid)
1325 "Construct a URL to use for posting to LiveJournal.
1327 Argument SUBJECT, a string, which is the title of the post.
1328 Argument BODY, a string, is the body of the post.
1329 Argument USER, a string, is the LJ userid to post as.
1331 Optional argument SECURITY, a string, is the security level this post
1332 will have. The default is `lj-default-security-level'.
1334 Optional argument TAGS, a string, which is a comma delimited list of
1335 tags to add to this post.
1337 Optional argument COMMUNITY, a string, which is the name of a LJ forum
1338 to send this post to instead of the user's blog.
1340 Optional argument AUTO-FORMAT, when non-nil request that the LJ server
1341 automatically formats the post. The default is nil, which means the
1342 post should NOT be auto formatted by LJ.
1344 Optional argument NO-COMMENTS, when non-nil means to turn off comments
1347 Optional argument MOOD, a string or an integer, is the post's \"mood\"
1348 header. If it is an integer, it is a \"mood id\" which is mapped to a
1351 Optional argument LOCATION, a string, free-form text describing your
1352 current location. Livejournal turns it into a search URL to google
1355 Optional argument MUSIC, a string, of the currently playing mp3/ogg.
1357 Optional argument PICKW, a string, of the userpic keyword to use. If
1358 omitted, your default LJ userpic will be used.
1360 Optional argument DATE, an internal time value as returned by
1361 `encode-time'. Used to set a date/time on a post, if omitted the
1362 current time is used.
1364 Optional boolean argument BACKDATED, causes the \"backdated\" flag to be
1365 set which will prevent the post from showing up on friends pages."
1366 (let* ((friends-mask nil)
1367 (tl (split-string-by-char
1368 (format-time-string "%Y,%m,%d,%H,%M"
1369 (or date (current-time))) ?,))
1375 (ctime (apply #'encode-btime (lj-parse-time-string
1376 (format "%s-%s-%s %s:%s"
1377 year month day hour minute))))
1378 (ltime (or lj-last-entry-btime (and (lj-get-last-entry-btime)
1379 lj-last-entry-btime)))
1381 ;; save custom date in case something goes wrong (not for edits)
1383 (not (zerop (length itemid))))
1384 (setq lj-last-user-set-time date)
1385 (setq lj-last-user-set-time nil))
1386 (setq subject (lj-hexify-string subject t))
1387 (setq body (lj-hexify-string body t))
1389 (if (not (string-match "p\\(ublic\\|rivate\\)" security))
1390 (if (string= "usemask" security)
1391 (setq friends-mask 1)
1392 (let* ((groups (or lj-groups (lj-get-friends-groups)))
1393 (id (cdr (assoc security groups))))
1395 (setq security "usemask"
1396 friends-mask (lsh 1 id))
1397 (error "Unknown friends group: %s" security)))))
1398 (setq security (lj-hexify-string security t))
1400 (if (> (length tags) 0)
1401 (setq tags (lj-hexify-string tags t))
1404 (cond ((cdr (assoc mood lj-moods))
1405 (setq mood (cdr (assoc mood lj-moods))))
1406 ((and (stringp mood)
1407 (> (length mood) 0))
1408 (setq mood (lj-hexify-string mood t)))
1409 ((integerp mood) nil)
1413 (if (> (length music) 0)
1414 (setq music (lj-hexify-string music t))
1417 (if (> (length pickw) 0)
1418 (setq pickw (lj-hexify-string pickw t))
1421 (if (> (length community) 0)
1422 (setq community (lj-hexify-string community t))
1423 (setq community nil))
1425 (if (> (length location) 0)
1426 (setq location (lj-hexify-string location t))
1427 (setq location nil))
1428 ;; maybe force opt_backdated (not touching for edits)
1429 (when (and (> ltime ctime)
1430 (not (zerop (length itemid))))
1435 (format "?mode=%sevent" (if (zerop (length itemid))
1439 "&auth_method=cookie"
1440 (format "&ver=%d" (if (lj-utf-emacs-p) 1 0))
1442 "&security=" security
1444 (format "&allowmask=%d" friends-mask))
1446 (format "&prop_taglist=%s" tags))
1448 (format "&usejournal=%s" community))
1449 (when (zerop (length itemid)) ; leave date alone when editing
1451 "&year=%s&mon=%s&day=%s&hour=%s&min=%s"
1452 year month day hour minute))
1455 (format "&prop_current_moodid=%d" mood)
1456 (format "&prop_current_mood=%s" mood)))
1458 (format "&prop_current_music=%s" music))
1460 (format "&prop_current_location=%s" location))
1462 (format "&prop_picture_keyword=%s" pickw))
1463 (unless (zerop lj-qotd)
1464 (format "&prop_qotdid=%d" lj-qotd))
1465 "&prop_opt_backdated=" (if backdated "1" "0")
1466 "&prop_opt_preformatted=" (if auto-format "0" "1")
1467 "&prop_opt_nocomments=" (if no-comments "1" "0")
1468 "&prop_useragent=" (lj-hexify-string lj-useragent)
1469 (unless (zerop (length itemid))
1470 (format "&itemid=%s" itemid))
1474 (defun lj-cut-toggle-top ()
1475 "Toggle view of LJ CUT text."
1478 (goto-char (point-at-eol))
1480 (set-extent-property
1481 (extent-at (point) nil 'ljcut)
1482 'invisible (not (extent-property
1483 (extent-at (point) nil 'ljcut) 'invisible)))))
1486 (defun lj-cut-mouse-toggle-top (event)
1487 "Toggle view of LJ CUT text under EVENT."
1489 (let ((epoint (event-point event)))
1492 (goto-char (point-at-eol))
1494 (set-extent-property
1495 (extent-at (point) nil 'ljcut)
1496 'invisible (not (extent-property
1497 (extent-at (point) nil 'ljcut) 'invisible))))))
1499 (defun lj-cut-toggle-bottom ()
1500 "Toggle view of LJ CUT text."
1503 (goto-char (point-at-bol))
1505 (set-extent-property
1506 (extent-at (point) nil 'ljcut)
1507 'invisible (not (extent-property
1508 (extent-at (point) nil 'ljcut) 'invisible)))))
1510 (defun lj-cut-mouse-toggle-bottom (event)
1511 "Toggle view of LJ CUT text under EVENT."
1513 (let ((epoint (event-point event)))
1516 (goto-char (point-at-bol))
1518 (set-extent-property
1519 (extent-at (point) nil 'ljcut)
1520 'invisible (not (extent-property
1521 (extent-at (point) nil 'ljcut) 'invisible))))))
1523 (defvar lj-cut-keymap-top
1524 (let ((map (make-sparse-keymap)))
1525 (set-keymap-name map 'lj-cut-keymap-top)
1526 (define-key map [return] #'lj-cut-toggle-top)
1527 (define-key map [button2] #'lj-cut-mouse-toggle-top)
1529 "Keymap for LJ CUT extents.")
1531 (defvar lj-cut-keymap-bottom
1532 (let ((map (make-sparse-keymap)))
1533 (set-keymap-name map 'lj-cut-keymap-bottom)
1534 (define-key map [return] #'lj-cut-toggle-bottom)
1535 (define-key map [button2] #'lj-cut-mouse-toggle-bottom)
1537 "Keymap for LJ CUT extents.")
1539 (defun lj-cut-region (b e)
1540 "Mark text in the region B to E as an LJ CUT.
1542 The text that is to be hidden behind the LJ CUT is made invisible in
1543 the buffer. The visibility can be toggled with Return or Button2 on
1544 either of the lj-cut delimiters."
1546 (let ((echo "Ret / Button2 Toggle View")
1549 (narrow-to-region b e)
1550 (lj-text-to-html (point-min) (point-max))
1551 (set-extent-properties
1552 (setq ext (make-extent (point-min) (point-max)))
1553 '(start-open t end-open t invisible t ljcut t))
1554 (goto-char (point-min))
1555 (set-extent-properties
1556 (insert-face "<lj-cut text=\"---More---\">" 'widget-button-face)
1559 keymap ,lj-cut-keymap-top
1560 mouse-face font-lock-warning-face))
1562 (goto-char (point-max))
1563 (set-extent-properties
1564 (insert-face "</lj-cut>" 'widget-button-face)
1567 keymap ,lj-cut-keymap-bottom
1568 mouse-face font-lock-warning-face))
1570 (set-extent-properties
1572 '(start-open nil end-open nil))
1573 (run-hooks 'lj-cut-hook)))
1575 (defvar lj-poll-types '("radio" "check" "drop" "text" "scale")
1578 (defun lj-insert-poll (name type question)
1579 "Insert a poll into a LJ post.
1580 Argument NAME is the title of the poll.
1581 Argument TYPE is the type of poll \(see `lj-poll-types'\).
1582 Argument QUESTION is the poll question, or \"topic\"."
1584 (list (read-string "Poll Title: " nil nil "unnamed poll")
1585 (completing-read "Poll Type (default \"radio\"): "
1586 (mapcar #'list lj-poll-types)
1587 nil t nil nil "radio")
1588 (read-string "Poll Question: ")))
1589 (let ((voters (completing-read "Who can vote (default \"all\"): "
1590 (mapcar #'list '("all" "friends"))
1591 nil t nil nil "all"))
1592 (viewers (completing-read "Who can view results (default \"all\"): "
1593 (mapcar #'list '("all" "friends" "none"))
1594 nil t nil nil "all"))
1597 (format "\n<lj-poll name=\"%s\" whovote=\"%s\" whoview=\"%s\">"
1598 name voters viewers)
1599 (format "\n<lj-pq type=\"%s\"" type))
1601 ((string= "scale" type)
1602 (let ((low (read-number "Scale low mark (int): " t "1"))
1603 (high (read-number "Scale high mark (int): " t "10"))
1604 (step (read-number "Stepping: " t "1")))
1605 (insert (format " from=\"%d\" to=\"%d\" by=\"%d\">"
1607 (format "\n%s" question))))
1608 ((string= "text" type)
1609 (let* ((size (read-number "Text box size: " t "50"))
1610 (max (read-number "Max answer length: " t
1611 (number-to-string (1- size)))))
1612 (insert (format " size=\"%d\" maxlength=\"%d\">" size max)
1613 (format "\n%s" question))))
1614 (t (insert (format ">\n%s" question))))
1615 (unless (string-match "scale\\|text" type)
1617 (while (not (zerop (length x)))
1618 (setq x (read-string "Poll Answer (RET to finish): "))
1619 (or (zerop (length x))
1620 (insert (format "\n<lj-pi>%s</lj-pi>" x))))))
1621 (insert "\n</lj-pq>"
1623 (indent-region p (point) nil)
1624 (run-hooks 'lj-poll-hook)))
1626 ;; Apparantly the _VALID_ markup that this function produces causes
1627 ;; some (all?) versions of M$ Internet Exploiter to buffer the entire
1628 ;; movie before beginning playback. Hey, lets call it a FEATURE!
1629 (defun lj-insert-youtube (url)
1630 "Insert a Google or Youtube video URL into a LJ post."
1631 (interactive "sVideo URL: ")
1632 (let* ((googlep (string-match "^http://video\\.google\\.com/.*$" url))
1633 (youtubep (string-match "^http://\\(www\\.\\)?youtube\\.com/.*$" url))
1634 (w (if googlep 420 400))
1635 (h (if googlep 352 338))
1637 (unless (or googlep youtubep)
1638 (error "Invalid Google/Youtube URL: %s" url))
1639 (insert (format "\n<object width=\"%d\" height=\"%d\"" w h)
1640 "\ntype=\"application/x-shockwave-flash\"")
1642 (setq url (replace-regexp-in-string "/videoplay\\?"
1643 "/googleplayer.swf?" url))
1644 (setq url (replace-regexp-in-string "\\(/watch\\)?\\?v=" "/v/" url)))
1645 (setq url (replace-regexp-in-string "&.*$" "" url))
1646 (insert (format "\ndata=\"%s\">" url)
1647 "\n<param name=\"movie\""
1648 (format "\nvalue=\"%s\" />" url)
1650 (indent-region p (point) nil)
1651 (run-hooks 'lj-youtube-hook)))
1653 (defun lj-insert-journal (name &optional community)
1654 "Insert a link to NAME journal or LJ community into an LJ post.
1656 Optional prefix argument, COMMUNITY means the link is to a LJ community
1657 instead of a LJ user's journal."
1658 (interactive "sUser or Community name: \nP")
1659 (let ((type (if current-prefix-arg "comm" "user"))
1661 (insert (format "\n<lj %s=\"%s\" />\n" type name))
1662 (indent-region p (point) nil)
1663 (run-hooks 'lj-journal-hook)))
1665 (defvar lj-abbrev-table nil
1666 "Abbrev table to use in `lj-mode'.")
1667 (define-abbrev-table 'lj-abbrev-table ())
1669 (define-derived-mode lj-mode html-mode "LJ"
1670 "This is a mode for composing LiveJournal posts.
1671 Its parent modes are `html-mode' and `sgml-mode' so everything you
1672 need to construct good clean HTML should be right at your fingertips.
1674 LJ specific bindings:
1676 \\[lj-post]\tSubmit post to LiveJournal
1677 \\[lj-preview]\t\tPreview post in web browser
1678 \\[lj-validate]\t\tValidate the markup in the post
1680 \\[lj-writers-block]\t\tAnswer a LJ \"Writer's Block\" question
1682 \\[lj-cut-region]\t\tHide text behind a LJ \"cut\"
1683 \\[lj-insert-journal]\t\tInsert a journal link
1684 \\[lj-insert-poll]\t\tInsert a poll
1685 \\[lj-insert-youtube]\t\tInsert a Google or YouTube Video
1687 \\[lj-goto-subject]\tMove to the Subject header
1688 \\[lj-goto-fcc]\tMove to the FCC header
1689 \\[lj-goto-bcc]\tMove to the BCC header
1690 \\[lj-goto-community]\tMove to the Community header
1691 \\[lj-goto-music]\tMove to the Music header
1692 \\[lj-goto-security]\tMove to the Security header
1693 \\[lj-goto-mood]\tMove to the Mood header
1694 \\[lj-goto-location]\tMove to the Location header
1695 \\[lj-goto-userpic]\tMove to the Userpic header
1696 \\[lj-goto-tags]\tMove to the Tags header
1697 \\[lj-goto-body]\tMove to the post body
1699 \\[lj-customise-faces]\t\tSet the header faces
1700 \\[lj-customise-group]\t\tSet the user options
1707 :abbrev-table lj-abbrev-table
1711 (add-hook 'lj-mode-hook #'font-lock-mode)
1713 (defun lj-make-archive-name ()
1714 "Compute a filename for archiving LJ posts.
1716 The filenames are of the format... `ljp-YYYYMMDDHHMM'."
1717 (let ((file (format-time-string "ljp-%Y%m%d%H%M"))
1718 (dir lj-archive-directory))
1719 (expand-file-name file dir)))
1721 (defun lj-generate-new-buffer ()
1722 "Create a new buffer for writing a new LJ post."
1723 (or (file-directory-p lj-drafts-directory)
1724 (make-directory-path lj-drafts-directory))
1727 (expand-file-name (format-time-string "ljd-%Y%m%d%H%M")
1728 lj-drafts-directory)))
1729 (rename-buffer "*LJ-Post*" 'unique)
1730 (when (lj-utf-emacs-p)
1731 (set-buffer-file-coding-system 'utf-8))
1733 (make-extent (point-min) (point-at-eol))
1734 (insert "Subject: \n")
1735 (when lj-archive-posts
1736 (or (file-directory-p lj-archive-directory)
1737 (make-directory-path lj-archive-directory))
1738 (insert (format "FCC: %s\n" (lj-make-archive-name))))
1739 (when (stringp lj-bcc-address)
1740 (insert (format "BCC: %s\n" lj-bcc-address)))
1741 (insert (format "Security: %s\n" lj-default-security-level))
1742 (when (stringp lj-default-location)
1743 (insert (format "Location: %s\n" lj-default-location)))
1744 (when (functionp (symbol-value 'lj-music))
1745 (insert (format "Music: %s\n" (funcall lj-music))))
1747 (when-boundp 'lj-default-pickw
1748 (insert (format "Userpic: %s\n" lj-default-pickw))
1749 (lj-update-userpic-glyph (expand-file-name lj-default-pickw
1750 lj-userpic-directory)))
1753 (set-extent-property
1754 (insert-face "</head>\n" 'default) 'invisible t)
1755 (insert lj-header-separator "\n")
1757 (save-excursion (insert "\n\n" lj-signature)))
1760 (defun lj-goto-subject (&optional nocreate)
1761 "Move to the Subject header of an LJ post buffer.
1763 The header is created if it doesn't exist, unless optional argument
1764 NOCREATE is non-nil."
1766 (goto-char (point-min))
1767 (or (re-search-forward "^Subject: " nil 'missing)
1769 (goto-char (point-min))
1770 (insert "Subject: ")
1771 (backward-char 1))))
1773 (defun lj-goto-fcc (&optional nocreate)
1774 "Move to the FCC header of an LJ post buffer.
1776 The header is created if it doesn't exist, unless optional argument
1777 NOCREATE is non-nil."
1779 (goto-char (point-min))
1780 (or (re-search-forward "^FCC: " nil 'missing)
1782 (goto-char (point-min))
1784 (backward-char 1))))
1786 (defun lj-goto-bcc (&optional nocreate)
1787 "Move to the BCC header of an LJ post buffer.
1789 The header is created if it doesn't exist, unless optional argument
1790 NOCREATE is non-nil."
1792 (goto-char (point-min))
1793 (or (re-search-forward "^BCC: " nil 'missing)
1795 (goto-char (point-min))
1797 (backward-char 1))))
1799 (defun lj-goto-security (&optional nocreate)
1800 "Move to the Security header of an LJ post buffer.
1802 The header is created if it doesn't exist, unless optional argument
1803 NOCREATE is non-nil."
1805 (goto-char (point-min))
1806 (or (re-search-forward "^Security: " nil 'missing)
1808 (goto-char (point-min))
1809 (insert "Security: \n")
1810 (backward-char 1))))
1812 (defun lj-goto-community (&optional nocreate)
1813 "Move to the Community header of an LJ post buffer.
1815 The header is created if it doesn't exist, unless optional argument
1816 NOCREATE is non-nil."
1818 (goto-char (point-min))
1819 (or (re-search-forward "^Community: " nil 'missing)
1821 (goto-char (point-min))
1822 (insert "Community: \n")
1823 (backward-char 1))))
1825 (defun lj-goto-location (&optional nocreate)
1826 "Move to the Location header of an LJ post buffer.
1828 The header is created if it doesn't exist, unless optional argument
1829 NOCREATE is non-nil."
1831 (goto-char (point-min))
1832 (or (re-search-forward "^Location: " nil 'missing)
1834 (goto-char (point-min))
1835 (insert "Location: \n")
1836 (backward-char 1))))
1838 (defun lj-goto-mood (&optional nocreate)
1839 "Move to the Mood header of an LJ post buffer.
1841 The header is created if it doesn't exist, unless optional argument
1842 NOCREATE is non-nil."
1844 (goto-char (point-min))
1845 (or (re-search-forward "^Mood: " nil 'missing)
1847 (goto-char (point-min))
1849 (backward-char 1))))
1851 (defun lj-goto-music (&optional nocreate)
1852 "Move to the Music header of an LJ post buffer.
1854 The header is created if it doesn't exist, unless optional argument
1855 NOCREATE is non-nil."
1857 (goto-char (point-min))
1858 (or (re-search-forward "^Music: " nil 'missing)
1860 (goto-char (point-min))
1861 (insert "Music: \n")
1862 (backward-char 1))))
1864 (defun lj-goto-userpic (&optional nocreate)
1865 "Move to the Userpic header of an LJ post buffer.
1867 The header is created if it doesn't exist, unless optional argument
1868 NOCREATE is non-nil."
1870 (goto-char (point-min))
1871 (or (re-search-forward "^Userpic: " nil 'missing)
1873 (goto-char (point-min))
1874 (insert "Userpic: \n")
1875 (backward-char 1))))
1877 (defun lj-goto-tags (&optional nocreate)
1878 "Move to the Tags header of an LJ post buffer.
1879 The header is created if it doesn't exist unless NOCREATE is non-nil."
1881 (goto-char (point-min))
1882 (or (re-search-forward "^Tags: " nil 'missing)
1884 (goto-char (point-min))
1886 (backward-char 1))))
1888 (defun lj-goto-x-lj-itemid (&optional nocreate)
1889 "Move to the X-LJ-ItemID header."
1890 (goto-char (point-min))
1891 (re-search-forward "^X-LJ-ItemID: " nil 'missing))
1893 (defun lj-goto-x-lj-url (&optional nocreate)
1894 "Move to the X-LJ-URL header."
1895 (goto-char (point-min))
1896 (re-search-forward "^X-LJ-URL: " nil 'missing))
1898 (defun lj-goto-body ()
1899 "Move to the body of an LJ post buffer."
1901 (goto-char (point-min))
1902 (re-search-forward (regexp-quote lj-header-separator) nil t)
1904 (goto-char (point-at-bol)))
1906 (defun lj-current-header ()
1907 "Return the name of the LJ header on the current line, or nil."
1908 (let ((hregex lj-header-regexp)
1909 (separator (regexp-quote lj-header-separator)))
1910 (if (save-excursion (re-search-forward separator nil t))
1912 (narrow-to-region (point-at-bol) (point-at-eol))
1913 (string-match hregex (buffer-string))
1914 (substring (buffer-string) (match-beginning 1) (match-end 1)))
1917 (defun lj-header-content (header)
1918 "Return the content of HEADER as a string."
1919 (let ((goto (intern-soft (concat "lj-goto-" (downcase header)))))
1921 (funcall goto 'nocreate)
1922 (buffer-substring-no-properties (point) (point-at-eol)))))
1924 (defun lj-update-userpic-glyph (glyph)
1925 "Update the userpic, GLYPH, displayed in the LJ-Post buffer."
1926 (let ((ext (extent-at (point-min)))
1927 (type (if (featurep '(and sxemacs ffi-magic))
1928 (downcase (car (split-string-by-char
1930 (magic:file-type glyph)) ?\ )))
1932 (cadr (split-string-by-char
1933 (shell-command-to-string (concat "file " glyph))
1935 (set-extent-begin-glyph
1937 (list (vector (intern-soft type)
1938 :data (with-temp-buffer
1939 (insert-file-contents-literally glyph)
1940 (buffer-string))))))))
1942 ;; Header completion
1943 (defvar lj-completion-time 3
1944 "Time in seconds before completion list is reset.")
1946 (defvar lj-completion-timer (make-itimer)
1947 "Completion timer.")
1949 (defvar lj-completion-list nil
1952 (defvar lj-header-syntax-table
1953 (let ((table (copy-syntax-table text-mode-syntax-table)))
1954 (modify-syntax-entry ?~ "w " table)
1955 (modify-syntax-entry ?` "w " table)
1956 (modify-syntax-entry ?- "w " table)
1957 (modify-syntax-entry ?_ "w " table)
1958 (modify-syntax-entry ?+ "w " table)
1959 (modify-syntax-entry ?{ "w " table)
1960 (modify-syntax-entry ?[ "w " table)
1961 (modify-syntax-entry ?} "w " table)
1962 (modify-syntax-entry ?] "w " table)
1963 (modify-syntax-entry ?\\ "w " table)
1964 (modify-syntax-entry ?| "w " table)
1965 (modify-syntax-entry ?\; "w " table)
1966 (modify-syntax-entry ?' "w " table)
1967 (modify-syntax-entry ?< "w " table)
1968 (modify-syntax-entry ?> "w " table)
1969 (modify-syntax-entry ?# "w " table)
1970 (modify-syntax-entry ?\ "w " table)
1971 (modify-syntax-entry ?. "w " table)
1973 "Syntax table used in funky header cycling completion.")
1975 (defun lj-init-completion-timer ()
1976 "Initialise the completion timer."
1977 (let ((timer lj-completion-timer))
1978 (set-itimer-function timer #'(lambda ()
1979 (setq lj-completion-list nil)))
1980 (set-itimer-value timer lj-completion-time)))
1981 (add-hook 'lj-init-hook #'lj-init-completion-timer)
1983 (defsubst lj-cycle-list (list &optional reverse)
1984 "Return a list of head of LIST, and LIST rotated 1 place forward.
1986 If optional argument, REVERSE is non-nil, rotate the list in the other
1988 (if (featurep 'sxemacs)
1989 (let ((list (apply #'dllist list))
1992 (dllist-rrotate list)
1993 (dllist-lrotate list))
1994 (setq name (dllist-car list))
1995 (list name (dllist-to-list list)))
1998 (let* ((name (car (last list)))
1999 (l1 (cdr (reverse list)))
2003 (let* ((name (cadr list))
2006 (list (append list (list oldcar))))
2007 (list name list)))))
2009 (defsubst lj-set-completion-timer ()
2010 "(Re)set completion timer's value."
2011 (let ((timer lj-completion-timer))
2012 (and (itimerp timer)
2013 (set-itimer-value timer lj-completion-time))))
2015 (defun lj-complete-header-backwards ()
2016 "Complete header, cycling backwards."
2018 (and (lj-current-header)
2019 (lj-complete-header 'reverse)
2020 (when (string-match (lj-current-header) "Userpic")
2021 (when (file-exists-p (expand-file-name
2022 (lj-header-content "userpic")
2023 lj-userpic-directory))
2024 (lj-update-userpic-glyph
2025 (expand-file-name (lj-header-content "userpic")
2026 lj-userpic-directory))))))
2028 (defun lj-complete-header (&optional reverse)
2029 "Completion for LJ headers.
2031 This completion does not pop up any completion buffers, instead it
2032 cycles through the possible completions \"in-place\" with each
2035 With non-nil optional argument, REVERSE, the cycling goes in the other
2038 (unless lj-completion-list
2039 (unless (itimer-live-p lj-completion-timer)
2040 (lj-set-completion-timer)
2041 (activate-itimer lj-completion-timer))
2042 (let* ((completion-ignore-case t)
2043 (type (lj-current-header))
2044 (table (cond ((string= type "Security")
2045 (let ((groups (copy-sequence
2049 ("usemask" . ?c))))))
2050 (sort* groups #'string-lessp :key #'car)))
2051 ((string= type "Mood")
2052 (let ((moods (copy-sequence lj-moods)))
2053 (sort* moods #'string-lessp :key #'car)))
2054 ((string= type "Userpic")
2055 (let ((pics (copy-sequence lj-pickws)))
2056 (sort* pics #'string-lessp :key #'car)))
2057 ((string= type "Tags")
2058 (let ((tags (mapcar #'(lambda (e) (cons e ?a))
2060 (sort* tags #'string-lessp :key #'car)))
2061 (t (error 'invalid-argument type))))
2062 (current (if (string-match (current-word) type)
2065 (completion (try-completion current table))
2066 (all (all-completions current table)))
2067 (if (null completion)
2068 (message "Can't find completion for \"%s\"" current)
2069 (setq lj-completion-list all))))
2070 (when lj-completion-list
2071 (multiple-value-bind (completion newlist)
2072 (lj-cycle-list lj-completion-list reverse)
2073 (setq lj-completion-list newlist)
2074 (with-syntax-table lj-header-syntax-table
2075 (unless (string= "" (current-word))
2078 (unless (string-match (lj-current-header) (current-word))
2079 (backward-delete-word)))
2080 (insert " " completion)))
2081 (lj-set-completion-timer)))
2083 (defun lj-sgml-indent-tab-or-complete (&optional refresh)
2084 "Does completion if in LJ headers, `sgml-indent-or-tab' otherwise.
2086 If point is after the header separator, this function simply calls
2087 `sgml-indent-or-tab'. If point is in the headers section it will do
2088 completion relevent to the header on the current line.
2090 Please note that this is \"inline\" completion, that means you won't
2091 be prompted for anything in the minibuffer. The completions will
2092 cycle directly in the LJ-post buffer.
2094 The different header completions are:
2096 Subject: Sweet bugger all. Sorry, haven't perfected read-mind-mode
2099 FCC: Computes a new archive filename.
2101 BCC: BBDB email addresses
2103 Security: Completes valid security levels. With prefix arg REFRESH,
2104 update your list of friends groups from livejournal.com
2106 Community: No completion, just insert a TAB.
2108 Music: Refreshes to the currently current song
2110 Mood: Completes moods. With prefix arg REFRESH, update the list
2111 of moods from livejournal.com.
2113 Location: No completion.
2115 Userpic: Completes list of LJ userpic keywords you have defined.
2116 With prefix arg REFRESH, update you list of userpic
2119 Tags: Multiple completion from your list of previously used tags.
2120 With prefix arg REFRESH, update your list of tags from
2123 (let ((header (lj-current-header)))
2125 (cond ((string= header "Subject")
2126 (error "Sorry, me crystal ball is in for repairs"))
2127 ((string= header "FCC")
2128 (let ((new (lj-make-archive-name)))
2129 (goto-char (point-at-bol))
2130 (re-search-forward "^FCC: " (point-at-eol))
2131 (delete-region (point) (point-at-eol))
2133 ((string= header "BCC")
2134 (if-fboundp #'bbdb-complete-name
2136 (goto-char (point-at-eol))
2137 (bbdb-complete-name))
2139 ((string= header "Security")
2140 (when (or refresh (not lj-groups))
2141 (lj-get-friends-groups))
2142 (goto-char (point-at-bol))
2143 (re-search-forward "^Security: " (point-at-eol))
2144 (lj-complete-header))
2145 ((string= header "Community")
2146 (goto-char (point-at-eol))
2148 ((string= header "Music")
2149 (let ((current (and (functionp (symbol-value 'lj-music))
2150 (funcall lj-music))))
2152 (goto-char (point-at-bol))
2153 (re-search-forward "^Music: " (point-at-eol))
2154 (delete-region (point) (point-at-eol))
2156 ((string= header "Mood")
2157 (when (or refresh (not lj-moods))
2159 (goto-char (point-at-bol))
2160 (re-search-forward "^Mood: " (point-at-eol))
2161 (lj-complete-header))
2162 ((string= header "Location")
2163 (error "If you don't know, I can't help you"))
2164 ((string= header "Userpic")
2165 (when (or refresh (not lj-pickws))
2167 (goto-char (point-at-bol))
2168 (re-search-forward "^Userpic: " (point-at-eol))
2169 (lj-complete-header)
2170 (when (file-exists-p (expand-file-name
2171 (lj-header-content "userpic")
2172 lj-userpic-directory))
2173 (lj-update-userpic-glyph
2174 (expand-file-name (lj-header-content "userpic")
2175 lj-userpic-directory))))
2176 ((string= header "Tags")
2177 (when (or refresh (not lj-tags))
2179 (lj-complete-header))
2181 (error "Unknown LJ header: %s" header)))
2182 (sgml-indent-or-tab))))
2184 (defregexp lj-url-regexp
2185 (concat "\\(https?://\\|s?ftp://\\|gopher://\\|telnet://"
2186 "\\|wais://\\|file:/\\|s?news:\\)"
2187 "[^]\t\n \"'()<>[^`{}]*[^]\t\n \"'()<>[^`{}.,;\\(>\\)]+")
2188 "A regular expression matching URL's.")
2190 (defregexp lj-email-regexp
2191 "[-a-zA-Z0-9._]+@\\([-a-zA-z0-9_]+\\.\\)+[a-zA-Z0-9]+"
2192 "A regular expression matching email addresses.")
2194 (defun lj-text-to-html (beg end &optional nopbr)
2195 "Convert the plain text in the region BEG - END to html.
2197 With optional argument, NOPBR, don't add <p>..</p> or <br /> tags.
2199 This is an extremely basic converter. All it really does is wrap
2200 paragraphs in <p>...</p>, and add <br /> to the end of each non-blank
2201 line. It will also convert old 70's style text highlighting to the
2202 HTML equivalent. e.g. _text_ -> <u>text</u>, *text* -> <b>text</b>.
2203 It also converts non-ASCII to HTML entities, and converts URL's and
2204 email addresses to hyperlinks. Email addresses are obfuscated in an
2205 attempt to protect against spam harvesters.
2207 Apart from the bold, underline, and hyperlink stuff, that's all the
2208 eye-candy you'll get. Forget fonts, colours, tables, and lists.
2209 That's not what this is about. The idea is to keep the text as close
2210 to \"as-is\" without resorting to using <pre>...</pre> tags.
2212 Calling this function on text that contains \"<lj*>\" will break those
2213 tags. So take note of what you are doing."
2214 (let ((replacements '(("&" . "&")
2215 ("\\.\\.\\." . "…")
2219 ("_\\(.*\\)_" . "<u>\\1</u>")
2220 ("\\*\\(.*\\)\\*" . "<b>\\1</b>")))
2222 (email lj-email-regexp))
2224 (add-to-list 'replacements
2225 (cons (if (featurep 'sxemacs)
2226 "\\([[:alnum:][:punct:]]\\)\n"
2227 "\\([a-zA-Z0-9]\\|\\s.\\)\n")
2228 "\\1<br />\n") 'append))
2230 (narrow-to-region beg end)
2231 (goto-char (point-min))
2236 (while (re-search-forward (car rep) nil t)
2237 (replace-match (cdr rep) t))))
2245 (narrow-to-region (point) (mark))
2246 (goto-char (point-min))
2248 (goto-char (point-max))
2250 (forward-paragraph))))
2253 (while (re-search-forward url nil t)
2254 (replace-match "<a href=\"\\&\">\\&</a>")))
2257 (while (re-search-forward email nil t)
2258 (replace-match "<a href=\"mailto:\\&\">\\&</a>"))
2259 (while (search-backward "@" nil t)
2260 (replace-match "@" nil t)))
2263 (lj-entify-region (point-min) (point-max))))
2264 (when (region-exists-p)
2265 (zmacs-deactivate-region))))
2267 (defun lj-ljtags-to-html ()
2268 "Convert \"<lj-*>\" tags to something resembling HTML.
2270 This function is used so that the markup in a post can be validated
2271 before it is submitted, and also so the post can be previewed before
2272 it is submitted. Do not expect anything fancy."
2273 (goto-char (point-min))
2276 (while (re-search-forward "<lj-\\(poll\\)" nil t)
2277 (let ((p (point-at-bol)))
2278 (search-forward (concat "</lj-" (match-string 1) ">") nil t)
2280 (narrow-to-region p (point))
2281 (lj-text-to-html (point-min) (point-max) 'nopbr)
2282 (goto-char (point-min))
2283 (insert "<div class=\"ljpoll\">\n<pre>\n")
2284 (goto-char (point-max))
2285 (insert "\n</pre>\n</div>")))))
2288 (while (re-search-forward "^</?lj-cut\\( text=\"---More---\"\\)?>$" nil t)
2289 (lj-text-to-html (match-beginning 0) (match-end 0) 'nopbr)))
2291 (while (re-search-forward "<lj-cut" nil t)
2292 (replace-match "<div class=\"ljcut\">\n\\&")
2293 (re-search-forward "</lj-cut>" nil t)
2294 (replace-match "\\&\n</div>")))
2297 (while (re-search-forward "<lj user=\"\\(.*\\)\" />" nil t)
2298 (replace-match "<a href=\"http://\\1.livejournal.com/profile\">
2299 <img src=\"http://p-stat.livejournal.com/img/userinfo.gif\"
2300 alt=\"[info]\" width=\"17\" height=\"17\"
2301 style=\"vertical-align: bottom; border: 0; padding-right: 1px;\" />
2303 <a href=\"http://\\1.livejournal.com/\"><b>\\1</b></a>")))
2306 (while (re-search-forward "<lj-template name=\"qotd\" id=\"[0-9]+\" />"
2308 (replace-match "<h3>Writer's Block Answer</h3>" t))))
2311 (format (concat "<br />"
2312 "<p style=\"text-align:right;font-family:verdana,"
2313 "helvetica,sans-serif;font-size:8pt;\">"
2314 "Posted via: <a href=\"http://www.sxemacs.org/lj.el\""
2315 " title=\"Download SXEmacs/LJ\">"
2316 "SXEmacs/LJ</a> (%s)</p>")
2318 "A client by-line to add to bottom of a post.
2320 It is also included when validating or previewing a post.")
2322 (defun lj-validate ()
2323 "Check the markup in a LJ post.
2325 Please note that livejournal.com is quite forgiving when it comes to
2326 HTML in journal entries, lj.el, on the other hand... isn't. For
2327 your entry to pass this validation it needs to be valid XHTML 1.0
2330 (run-hooks 'lj-before-validate-hook)
2331 (let ((vf (make-temp-name (expand-file-name "LJ-" (temp-directory))))
2332 (pb (current-buffer)))
2333 (with-current-buffer (get-buffer-create vf)
2335 (insert lj-validate-header)
2341 (narrow-to-region (point) (point-max))
2343 (and lj-self-promote
2345 (insert lj-validate-footer)
2347 (write-region (point-min) (point-max) vf))
2353 (sgml-validate (sgml-default-validate-command))
2354 (let ((proc (get-buffer-process "*sgml validation*")))
2355 (while (process-live-p proc)
2357 (message "Validating markup, please wait..."))
2358 (message "Validation complete!")
2359 (when (> (process-exit-status proc) 0)
2360 (error 'syntax-error (process-name proc)))))
2363 (switch-to-buffer pb))
2364 (run-hooks 'lj-after-validate-hook)))
2366 (defun lj-preview-headers (buf)
2367 "Add htmlised LJ headers in buffer, BUF for `lj-preview'."
2372 (setq pic (lj-header-content "userpic"))
2374 (narrow-to-region (point-min) (point))
2375 (setq text (buffer-substring-no-properties)))
2379 (lj-text-to-html (point-min) (point-max))
2380 (goto-char (point-min))
2381 (insert "<div class=\"ljhead\">\n")
2382 (and (search-forward "<p>")
2383 (insert (format "<img src=\"%s\" align=\"right\" alt=\"Userpic\" />"
2384 (cdr (assoc pic lj-pickws)))))
2385 (while (search-forward "</head>" nil t)
2386 (replace-match "" nil t))
2387 (goto-char (point-max))
2388 (insert "\n</div>\n\n")
2391 (defun lj-preview ()
2392 "Preview the LJ post in a web browser.
2394 Please note that this is far from a true representation of what the
2395 thing will look like once it has been submitted to LiveJournal. But
2396 it should give you a rough idea."
2398 (run-hooks 'lj-before-preview-hook)
2399 (let ((vf (make-temp-name (expand-file-name "LJ-" (temp-directory))))
2400 (pb (current-buffer)))
2401 (with-current-buffer (get-buffer-create vf)
2403 (insert lj-validate-header)
2404 (insert (lj-preview-headers pb))
2405 (insert "<div class=\"lj\">\n")
2411 (narrow-to-region (point) (point-max))
2413 (and lj-self-promote
2416 (insert lj-validate-footer)
2418 (browse-url-of-buffer))
2419 (when (region-exists-p)
2420 (zmacs-deactivate-region))
2421 (run-hooks 'lj-after-preview-hook)))
2423 (defvar lj-last-url "No URL yet, got nothing to blog about?"
2424 "The URL to your last posted blog entry on LiveJournal.")
2426 (defvar lj-item-id ""
2427 "The itemid of the last post.")
2429 (defun lj-post-proc-parser (buf)
2430 "Process parser for `lj-post'.
2431 Argument BUF is the process buffer used."
2432 (let ((url "^url\n\\(.*$\\)")
2433 (itemid "^itemid\n\\(.*$\\)"))
2434 (with-current-buffer buf
2435 (when (lj-proc-success)
2436 (setq lj-last-user-set-time nil)
2437 (goto-char (point-min))
2439 (if (re-search-forward url nil t)
2440 (setq lj-last-url (match-string 1))
2441 (setq lj-last-url "NO URL RETURNED FROM LiveJournal")))
2443 (and (re-search-forward itemid nil t)
2444 (setq lj-item-id (match-string 1))))
2445 (kill-buffer nil)))))
2447 (defun lj-archive-post (archive)
2448 "Archive the current post to ARCHIVE."
2449 (let ((buf (current-buffer)))
2450 (with-current-buffer (find-file-noselect archive)
2451 (when (zerop (length (lj-header-content "x-lj-itemid")))
2452 (insert (format "\nX-LJ-URL: %s\n" lj-last-url)
2453 (format "X-LJ-ItemID: %s" lj-item-id))
2454 (insert-buffer buf))
2456 (kill-buffer nil))))
2458 (defun lj-send-bcc (subject security tags comm mood music location body)
2459 "Send a copy of a LJ post via email to `lj-bcc-address'.
2461 Argument SUBJECT is the subject header from the post.
2463 Argument SECURITY is the security level from the post, it is added to
2464 them mail as X-LJ-Auth header.
2466 Argument TAGS are the tags from the post, added as Keywords header.
2468 Argument COMM is the community from the post, added as X-LJ-Community
2471 Argument MOOD is the mood from the post, added as X-LJ-Mood header.
2473 Argument MUSIC is the music from the post, added as X-Now-Playing
2476 Argument LOCATION is the location from the post, added as X-LJ-Location
2479 Argument BODY is of course the post's body."
2480 (let* ((from (concat user-full-name
2481 " <" lj-user-id "@livejournal.com>"))
2482 (headers `(("From" . ,from)
2483 ("Keywords" . ,tags)
2484 ("X-LJ-Auth" . ,security)
2485 ("X-LJ-Community" . ,comm)
2486 ("X-LJ-Location" . ,location)
2487 ("X-LJ-Mood" . ,mood)
2488 ("X-Now-Playing" . ,music)
2489 ("X-URL" . ,lj-last-url)
2490 ("MIME-Version" . "1.0")
2491 ("Content-Type" . "text/html")))
2492 (mail-user-agent 'sendmail-user-agent))
2493 (compose-mail lj-bcc-address subject headers)
2494 (goto-char (point-max))
2496 (declare-fboundp (mail-send-and-exit nil))))
2498 (defun lj-last-entry-proc-parser (buf)
2499 "Process the output from `lj-get-last-entry-btime'.
2500 Argument BUF is the process buffer used."
2501 (let ((regexp "^events_1_eventtime\n\\(.*$\\)"))
2502 (with-current-buffer buf
2503 (when (lj-proc-success)
2504 (goto-char (point-min))
2505 (re-search-forward regexp nil t)
2506 (setq lj-last-entry-btime
2507 (apply #'encode-btime (lj-parse-time-string
2509 (kill-buffer nil)))))
2511 (defun lj-get-last-entry-btime ()
2512 "Leech the last entry from LJ to get it's date/time."
2513 (let ((cookies (or lj-cookies
2514 (error "No LJ cookies found")))
2515 (url (concat lj-base-url
2518 "&auth_method=cookie"
2519 (format "&ver=%d" (if (lj-utf-emacs-p) 1 0))
2523 (lj-http-post url cookies #'lj-last-entry-proc-parser)))
2525 (defun lj-delete-post-proc-parser (buf)
2526 "Process the output from `lj-delete-post'.
2528 Argument BUF is the process buffer that was used."
2529 (with-current-buffer buf
2530 (when (lj-proc-success)
2531 (message "Your post has been successfully removed from LiveJournal.")
2532 (kill-buffer nil))))
2534 (defun lj-stringify-id (id)
2535 "Returns a string version of the number, ID."
2539 (number-to-string id))))
2541 (defun lj-delete-post-internal (itemid)
2542 "Delete the post with ITEMID."
2543 (let ((cookies (or lj-cookies
2544 (error "No LJ cookies found")))
2545 (url (concat lj-base-url
2548 "&auth_method=cookie"
2549 (format "&ver=%d" (if (lj-utf-emacs-p) 1 0))
2550 "&itemid=" (lj-stringify-id itemid)
2551 "&prop_useragent=" (lj-hexify-string lj-useragent)
2553 (lj-http-post url cookies #'lj-delete-post-proc-parser)))
2555 (defun lj-set-date/time ()
2556 "Return an internal time value to use as post date/time.
2558 This will prompt for a date string of the format yyyy-mm-dd, and a
2559 time string in the format HH:MM \(24hr\). If either are given a null
2560 string the current date/time are used.
2562 The value returned is that same as from `encode-time'."
2563 (let* ((date (read-string (format-time-string "New date [%Y-%m-%d]: ")
2565 (format-time-string "%Y-%m-%d")))
2566 (time (read-string (format-time-string "New time [%H:%M]: ")
2568 (format-time-string "%H:%M")))
2569 (timestr (concat date " " time))
2570 (btime (apply #'encode-btime (lj-parse-time-string timestr))))
2571 (btime-to-time btime)))
2573 (defun lj-compress-url (url)
2574 "Compress URL using tinyurl.com."
2577 (concat "http://tinyurl.com/api-create.php?url="
2578 (lj-hexify-string url t)))
2581 (defun lj-check-limits (bodlen sublen taglen muslen loclen)
2582 "Make sure we don't exceed any LJ size limits.
2584 Argument BODLEN: length of the body of a post. Max is 65535 bytes.
2585 Argument SUBLEN: length of the subject header. Max is 255 chars.
2586 Argument TAGLEN: length of the tags header. Max is 100 chars.
2587 Argument MUSLEN: length of the music header. Max is 100 chars.
2588 Argument LOCLEN: length of the location header. Max is 100 chars."
2589 (let ((maxbod 65535)
2594 (and (> bodlen maxbod)
2595 (error 'invalid-argument
2596 (format "Post body exceeds maximum by %d chars"
2597 (- bodlen maxbod))))
2598 (and (> sublen maxsub)
2599 (error 'invalid-argument
2600 (format "Subject exceeds maximum by %d chars"
2601 (- sublen maxsub))))
2602 (and (> taglen maxtag)
2603 (error 'invalid-argument
2604 (format "Tags exceed maximum by %d chars"
2605 (- taglen maxtag))))
2606 (and (> muslen maxmus)
2607 (error 'invalid-argument
2608 (format "Music header exceeds maximum by %d chars"
2609 (- muslen maxmus))))
2610 (and (> loclen maxloc)
2611 (error 'invalid-argument
2612 (format "Location header exceeds maximum by %d chars"
2613 (- loclen maxloc))))))
2615 (defun lj-post (&optional out-of-order)
2616 "Submit a new post to LiveJournal.
2618 With a single prefix argument, OUT-OF-ORDER, prompt for a date/time to
2621 With two prefix args, also set a \"date out of order\" flag."
2623 (run-hooks 'lj-before-post-hook)
2624 (let ((subject (lj-header-content "subject"))
2625 (body (and (lj-goto-body)
2628 (buffer-substring-no-properties (point) (point-max))
2630 (buffer-substring-no-properties (point) (point-max)))))
2632 (security (lj-header-content "security"))
2633 (tags (lj-header-content "tags"))
2634 (comm (lj-header-content "community"))
2635 (mood (lj-header-content "mood"))
2636 (location (lj-header-content "location"))
2637 (music (lj-header-content "music"))
2638 (pickw (lj-header-content "userpic"))
2639 (itemid (lj-header-content "x-lj-itemid"))
2640 (cookies (or lj-cookies
2641 (error "No LJ cookies found")))
2644 (draftid (buffer-file-name))
2646 (when (and out-of-order
2647 (null current-prefix-arg))
2649 date lj-last-user-set-time))
2650 (cond ((eq (car current-prefix-arg) 4)
2651 (setq date (lj-set-date/time)))
2652 ((eq (car current-prefix-arg) 16)
2653 (setq date (lj-set-date/time)
2655 (lj-check-limits (length body)
2660 (setq url (lj-construct-url subject body user security tags comm nil nil
2661 mood location music pickw date backdated
2663 ;; lets save the draft out to disc just in case something goes wrong
2665 (lj-http-post url cookies #'lj-post-proc-parser)
2666 (and lj-archive-posts
2667 (lj-archive-post (lj-header-content "fcc")))
2669 (lj-send-bcc subject security tags comm mood music location body))
2670 ;; If there is a itemid don't delete the draft because it is our
2672 (when (zerop (length itemid))
2673 (delete-file draftid))
2674 (run-hooks 'lj-after-post-hook)))
2676 ;; keep track of the date of the last entry for backdating purposes
2677 (add-hook 'lj-after-post-hook #'lj-get-last-entry-btime)
2680 (defvar lj-qotd-buffer "*LJ Writer's Block*"
2681 "Buffer displaying a list of LJ Writer's Block questions.")
2683 (defun lj-parse-qotd-archive ()
2684 "Leech the qotd archive and make it presentable for human consumption."
2685 (let ((buf (get-buffer-create lj-qotd-buffer))
2686 (bregexp "<!-- Content -->")
2687 (eregexp "<p class='skiplinks'>")
2688 (qregexp "<p class='qotd-archive-item-question'>\\(.*\\)</p><p")
2690 (concat "<div class=\"b-qotd-question\">"
2691 "<p class='qotd-archive-item-date'>\\(.*[0-9]+\\)</p>"))
2692 (idregexp "^.*qotd=\\([0-9]+\\).*\n.*$")
2693 (url "http://www.livejournal.com/misc/qotdarchive.bml")
2695 (with-current-buffer buf
2696 (when (lj-utf-emacs-p)
2697 (set-buffer-file-coding-system 'utf-8))
2700 (goto-char (point-min))
2701 (setq b (and (search-forward bregexp nil t)
2704 e (and (search-forward eregexp nil t)
2706 (narrow-to-region b e)
2707 (goto-char (point-min))
2708 (insert (make-string 72 ?=) "\n")
2710 (while (re-search-forward dregexp nil t)
2711 (replace-match (format "%s:\n\n" (match-string 1)) t)))
2713 (while (re-search-forward qregexp nil t)
2714 (replace-match (format "QOTD: %s\n" (match-string 1)) t)))
2716 (while (re-search-forward "^QOTD:" nil t)
2717 (fill-paragraph nil)))
2719 (while (re-search-forward idregexp nil t)
2720 (replace-match (concat (format "\nWriter's Block ID: %s\n"
2722 (make-string 72 ?=)) t))))))
2724 (defun lj-qotd-subject (qotd)
2725 "Update the Subject header with title of QOTD."
2726 (let ((url (format "http://www.livejournal.com/update.bml?qotd=%d"
2731 (goto-char (point-min))
2732 (when (re-search-forward "Writer's Block: \\(.*\\)\" name="
2734 (setq subject (match-string 1))))
2736 (goto-char (point-at-eol))
2741 (defun lj-narrow-to-qotd (qotd)
2742 "Narrow Writer's Block buffer to a single QOTD."
2743 (let ((delim (make-string 72 ?=))
2745 (goto-char (point-max))
2746 (setq e (and (search-backward (format "ID: %d" qotd))
2748 b (search-backward delim))
2749 (narrow-to-region b e)
2751 (shrink-window-if-larger-than-buffer)
2753 (unless (eq major-mode 'lj-mode)
2754 (switch-to-buffer "*LJ-Post*"))
2755 (unless (zerop lj-qotd)
2757 (insert (format "<lj-template name=\"qotd\" id=\"%d\" />\n\n"
2759 (lj-qotd-subject lj-qotd))))
2761 (defun lj-cleanup-qotd ()
2762 "Reset `lj-qotd' to zero and kill the qotd buffer."
2765 (delete-other-windows)
2766 (when (buffer-live-p (get-buffer lj-qotd-buffer))
2767 (kill-buffer lj-qotd-buffer))))
2769 (defun lj-qotd-quit ()
2770 "Cancel a LJ \"Writer's Block\" composition."
2773 (unless (eq major-mode 'lj-mode)
2774 (switch-to-buffer "*LJ-Post*"))
2776 (kill-region (lj-goto-subject) (point-at-eol))
2777 (kill-region (lj-goto-tags) (point-at-eol))
2779 (remove-hook 'lj-after-post-hook #'lj-cleanup-qotd))
2781 (defun lj-writers-block ()
2782 "Compose an answer to a LJ \"Writer's Block\" question."
2784 (and (kill-region (lj-goto-subject) (point-at-eol))
2785 (insert "Writer's Block: "))
2786 (and (kill-region (lj-goto-tags) (point-at-eol))
2787 (insert "writer's block"))
2788 (let ((b (lj-goto-body))
2789 (e (or (and (goto-char (point-max))
2790 (search-backward lj-signature nil t))
2794 (lj-sgml-indent-tab-or-complete)
2795 (lj-parse-qotd-archive)
2796 (pop-to-buffer lj-qotd-buffer)
2797 (local-set-key [space] #'scroll-up)
2798 (local-set-key [delete] #'scroll-down)
2799 (local-set-key [return]
2802 (setq lj-qotd (read-number "Select Writer's Block ID: " t))
2803 (lj-narrow-to-qotd lj-qotd)))
2804 (local-set-key [q] #'lj-qotd-quit)
2805 (message "[SPC]/[DEL] to scroll, [q] to cancel, [RET] to enter QOTD ID")
2806 (add-one-shot-hook 'lj-after-post-hook #'lj-cleanup-qotd 'append))
2808 (defun lj-session-auto-save-files ()
2809 "Return a list of auto-save files in `lj-drafts-directory'."
2810 (directory-files lj-drafts-directory nil
2811 #'auto-save-file-name-p 'list t))
2813 (defun lj-recover-drafts (files)
2814 "Recover auto-saved FILES in `lj-drafts-directory'."
2815 (let ((default-directory lj-drafts-directory))
2817 (recover-file (auto-save-original-name (car files)))
2818 (lj-edit-draft (auto-save-original-name (car files)))
2819 (setq files (cdr files)))))
2824 "Compose a new LiveJournal entry."
2826 (run-hooks 'lj-init-hook)
2827 ;; Maybe update tags, groups, moods, pic keywords
2828 (or lj-tags (lj-get-tags))
2829 (or lj-groups (lj-get-friends-groups))
2830 (or lj-moods (lj-get-moods))
2831 (or lj-default-pickw (lj-get-pickws))
2832 (let ((auto-saves (lj-session-auto-save-files)))
2834 (y-or-n-p "Auto saved drafts exist, do you wish to recover "))
2835 (lj-recover-drafts auto-saves)
2836 (lj-generate-new-buffer))))
2838 (defun lj-blog-buffer (buffer &optional noformat)
2839 "Use contents of BUFFER to compose LJ entry.
2841 With optional prefix arg, NOFORMAT, don't attempt to convert the text
2843 (interactive "bBuffer to blog: \nP")
2844 (let ((blog (with-temp-buffer
2845 (insert-buffer buffer)
2846 (unless current-prefix-arg
2847 (lj-text-to-html (point-min) (point-max)))
2848 (buffer-substring-no-properties))))
2852 (defun lj-blog-region (beg end &optional noformat)
2853 "Compose LJ entry using content of region BEG - END.
2855 With optional prefix arg, NOFORMAT, dont' attempt to convert the text
2857 (interactive "r\nP")
2858 (let ((blog (buffer-substring beg end)))
2859 (unless current-prefix-arg
2862 (lj-text-to-html (point-min) (point-max))
2863 (setq blog (buffer-substring-no-properties))))
2867 (defun lj-edit-draft (draft)
2868 "Edit an existing draft previously saved from lj.el."
2870 (read-file-name "Edit draft: "
2871 lj-drafts-directory "" t)))
2872 (if (or (zerop (length draft))
2873 (not (file-readable-p (expand-file-name draft))))
2874 (error 'invalid-argument draft)
2875 (switch-to-buffer (find-file-noselect (expand-file-name draft)))
2876 (rename-buffer "*LJ-draft*" 'unique)
2877 (goto-char (point-min))
2878 (make-extent (point) (point-at-eol))
2879 (lj-update-userpic-glyph
2880 (expand-file-name (lj-header-content "userpic")
2881 lj-userpic-directory))
2882 (re-search-forward lj-header-separator nil t)
2884 (set-extent-property
2885 (make-extent (point-at-bol) (1+ (point-at-eol))) 'invisible t)
2889 (defun lj-edit-old-post (post)
2890 "Edit an already posted LJ entry."
2892 (read-file-name "Edit Post: "
2893 lj-archive-directory "" t)))
2894 (if (or (zerop (length post))
2895 (not (file-readable-p (expand-file-name post))))
2896 (error 'invalid-argument post)
2897 (switch-to-buffer (find-file-noselect (expand-file-name post)))
2898 (rename-buffer "*LJ-EDIT*" 'unique)
2899 (and (zerop (length (lj-header-content "x-lj-itemid")))
2900 (error "ItemID missing, CANNOT edit this post from SXEmacs/LJ"))
2901 (goto-char (point-min))
2902 (make-extent (point) (point-at-eol))
2903 (lj-update-userpic-glyph
2904 (expand-file-name (lj-header-content "userpic")
2905 lj-userpic-directory))
2906 (re-search-forward lj-header-separator nil t)
2908 (set-extent-property
2909 (make-extent (point-at-bol) (1+ (point-at-eol))) 'invisible t)
2913 (defun lj-delete-old-post (post)
2914 "Delete a post from Livejournal."
2916 (read-file-name "Delete Old Post: "
2917 lj-archive-directory "" t)))
2918 (if (or (zerop (length post))
2919 (not (file-readable-p (expand-file-name post))))
2920 (error 'invalid-argument post)
2921 (switch-to-buffer (find-file-noselect (expand-file-name post)))
2922 (rename-buffer "*LJ-EDIT*" 'unique)
2923 (let ((itemid (lj-header-content "x-lj-itemid")))
2924 (and (zerop (length itemid))
2925 (error "ItemID missing, CANNOT delete this post from SXEmacs/LJ"))
2926 (goto-char (point-min))
2927 (make-extent (point) (point-at-eol))
2928 (lj-update-userpic-glyph
2929 (expand-file-name (lj-header-content "userpic")
2930 lj-userpic-directory))
2931 (re-search-forward lj-header-separator nil t)
2933 (set-extent-property
2934 (make-extent (point-at-bol) (1+ (point-at-eol))) 'invisible t)
2937 (and (y-or-n-p "Are you sure you want to delete this post? ")
2940 (lj-delete-post-internal itemid))))))
2945 (and (file-exists-p lj-tags-file)
2946 (load-file lj-tags-file))
2947 (and (file-exists-p lj-groups-file)
2948 (load-file lj-groups-file))
2949 (and (file-exists-p lj-moods-file)
2950 (load-file lj-moods-file))
2951 (and (file-exists-p lj-pickws-file)
2952 (load-file lj-pickws-file))
projects / slh / blob