;;; pkg-blog.el --- Blog workflow for monthly posts -*- lexical-binding: t -*-
;; Copyright (C) 2024 Cytrogen
;; This file contains:
;; - Monthly blog post creation and management
;; - Refile to monthly functionality
;; - Export to Hexo markdown
;;; Commentary:
;; Implements a capture → refile → export workflow for monthly blog posts.
;; Monthly posts use Chinese calendar naming (天干地支 + 月份).
;;; Code:
(require 'org)
(require 'org-element)
;;; Configuration
(defgroup my/blog nil
"Blog workflow configuration."
:group 'org)
(defcustom my/blog-org-dir "~/Documents/Org/blog/"
"Directory for blog org source files."
:type 'directory
:group 'my/blog)
(defcustom my/blog-monthly-dir "monthly/"
"Subdirectory for monthly posts (relative to `my/blog-org-dir')."
:type 'string
:group 'my/blog)
(defcustom my/blog-export-dir "~/Projects/blog/source/_posts/"
"Directory for exported markdown files."
:type 'directory
:group 'my/blog)
;;; Dynamic Directory Setup
(defvar my/blog-dirs-config-file (concat user-emacs-directory ".blog-dirs")
"File to store the user's Blog directories.")
(defun my/setup-blog-directories ()
"Load Blog directories from config file or prompt user."
(let ((source-dir nil)
(export-dir nil)
(config-changed nil))
;; 1. Try to read from file
(when (file-exists-p my/blog-dirs-config-file)
(with-temp-buffer
(insert-file-contents my/blog-dirs-config-file)
(goto-char (point-min))
(while (not (eobp))
(let ((line-start (point)))
(end-of-line)
(let ((line (buffer-substring-no-properties line-start (point))))
(cond
((string-match "^SOURCE=\\(.*\\)" line)
(setq source-dir (string-trim (match-string 1 line))))
((string-match "^EXPORT=\\(.*\\)" line)
(setq export-dir (string-trim (match-string 1 line))))))
(forward-line 1)))))
;; 2. Validate Source Dir
(unless (and source-dir (file-directory-p source-dir))
(setq source-dir (read-directory-name "请选择博客 Org 源码目录 (Select Blog Source Dir): " (bound-and-true-p org-directory)))
(unless (file-directory-p source-dir)
(make-directory source-dir t))
(setq config-changed t))
;; 3. Validate Export Dir
(unless (and export-dir (file-directory-p export-dir))
(setq export-dir (read-directory-name "请选择博客发布目录 (Select Blog Export Dir, e.g. source/_posts): " "D:/"))
(unless (file-directory-p export-dir)
(make-directory export-dir t))
(setq config-changed t))
;; 4. Save if changed
(when config-changed
(with-temp-file my/blog-dirs-config-file
(insert (format "SOURCE=%s\nEXPORT=%s\n" source-dir export-dir))))
;; 5. Apply settings
(setq my/blog-org-dir (file-name-as-directory source-dir))
(setq my/blog-export-dir (file-name-as-directory export-dir))
(message "Blog directories loaded.\nSource: %s\nExport: %s" my/blog-org-dir my/blog-export-dir)))
;; Execute setup immediately
(my/setup-blog-directories)
(defcustom my/blog-monthly-sections
'(("商业与社会" . "商业与社会")
("心理与关系" . "心理与关系")
("技术与创造" . "技术与创造")
("技术与创造/有趣项目" . "有趣项目")
("生活与文娱" . "生活与文娱"))
"Sections available in monthly posts. Format: ((display . headline) ...)."
:type '(alist :key-type string :value-type string)
:group 'my/blog)
;;; Chinese Calendar Names
(defconst my/blog--tiangan
["甲" "乙" "丙" "丁" "戊" "己" "庚" "辛" "壬" "癸"]
"天干 (Heavenly Stems).")
(defconst my/blog--dizhi
["子" "丑" "寅" "卯" "辰" "巳" "午" "未" "申" "酉" "戌" "亥"]
"地支 (Earthly Branches).")
(defconst my/blog--month-names
["正月" "二月" "三月" "四月" "五月" "六月"
"七月" "八月" "九月" "十月" "冬月" "腊月"]
"Traditional Chinese month names.")
(defconst my/blog--month-alt-names
'((1 . "正月") (2 . "杏月") (3 . "桃月") (4 . "槐月")
(5 . "蒲月") (6 . "荷月") (7 . "巧月") (8 . "桂月")
(9 . "菊月") (10 . "阳月") (11 . "冬月") (12 . "腊月"))
"Alternative traditional month names (花名).")
(defun my/blog--chinese-year (year)
"Convert YEAR to Chinese 天干地支 format."
(let* ((offset (- year 4)) ; 公元4年是甲子年
(tiangan-idx (mod offset 10))
(dizhi-idx (mod offset 12)))
(concat (aref my/blog--tiangan tiangan-idx)
(aref my/blog--dizhi dizhi-idx))))
(defun my/blog--chinese-month (month)
"Convert MONTH (1-12) to traditional Chinese name."
(aref my/blog--month-names (1- month)))
;;; Utility Functions
(defun my/blog--monthly-dir-full ()
"Return full path to monthly directory."
(expand-file-name my/blog-monthly-dir my/blog-org-dir))
(defun my/blog--ensure-directories ()
"Create blog directories if they don't exist."
(let ((monthly-dir (my/blog--monthly-dir-full)))
(unless (file-exists-p my/blog-org-dir)
(make-directory my/blog-org-dir t))
(unless (file-exists-p monthly-dir)
(make-directory monthly-dir t))))
(defun my/blog--monthly-filename (year month)
"Generate filename for monthly post. YEAR and MONTH are integers."
(format "%04d-%02d.org" year month))
(defun my/blog--monthly-filepath (year month)
"Return full path for monthly file."
(expand-file-name (my/blog--monthly-filename year month)
(my/blog--monthly-dir-full)))
(defun my/blog--current-monthly-file ()
"Return filepath for current month's monthly file."
(let ((now (decode-time)))
(my/blog--monthly-filepath (nth 5 now) (nth 4 now))))
(defun my/blog--slugify (text)
"Convert TEXT to URL-friendly slug."
(let ((slug text))
(setq slug (replace-regexp-in-string "[《》「」『』【】]" "" slug))
(setq slug (replace-regexp-in-string "[[:punct:]]" "" slug))
(setq slug (replace-regexp-in-string "[[:space:]]+" "-" slug))
(downcase slug)))
(defun my/blog--collect-monthly-posts (year month)
"Scan _posts directory and return posts from YEAR-MONTH.
Returns list of (title . url) pairs."
(let ((posts-dir (expand-file-name "_posts" (file-name-directory my/blog-export-dir)))
(target-prefix (format "%04d-%02d" year month))
(results '()))
(when (file-directory-p posts-dir)
(dolist (file (directory-files posts-dir t "\\.md$"))
(with-temp-buffer
(insert-file-contents file nil 0 1000) ; Read first 1000 chars for front matter
(goto-char (point-min))
(when (looking-at "---")
(forward-line 1)
(let ((fm-end (save-excursion
(when (re-search-forward "^---$" nil t)
(point))))
(title nil)
(abbrlink nil)
(date nil))
(when fm-end
;; Extract title
(goto-char (point-min))
(when (re-search-forward "^title: \\(.+\\)$" fm-end t)
(setq title (string-trim (match-string-no-properties 1))))
;; Extract abbrlink
(goto-char (point-min))
(when (re-search-forward "^abbrlink: \\(.+\\)$" fm-end t)
(setq abbrlink (string-trim (match-string-no-properties 1))))
;; Extract date
(goto-char (point-min))
(when (re-search-forward "^date: \\(.+\\)$" fm-end t)
(setq date (string-trim (match-string-no-properties 1))))
;; Check if date matches target month
(when (and title abbrlink date
(string-prefix-p target-prefix date)
;; Exclude monthly posts themselves
(not (string-match-p "想法在.*迭代" title)))
(push (cons title (format "/posts/%s.html" abbrlink))
results))))))))
(nreverse results)))
;;; Monthly Creation
(defun my/blog--monthly-template (year month chinese-year chinese-month)
"Generate org content for a new monthly post."
(format "#+TITLE: 想法在%s%s迭代
#+DATE: %04d-%02d-01
#+HUGO_BASE_DIR: ~/Projects/blog
#+HUGO_SECTION: _posts
#+CATEGORIES: 想法迭代
#+HUGO_CUSTOM_FRONT_MATTER: :lang zh :mathjax false :hidden false
开场白...
* 商业与社会
:PROPERTIES:
:CUSTOM_ID: 商业与社会
:END:
* 心理与关系
:PROPERTIES:
:CUSTOM_ID: 心理与关系
:END:
* 科学与自然
:PROPERTIES:
:CUSTOM_ID: 科学与自然
:END:
* 技术与创造
:PROPERTIES:
:CUSTOM_ID: 技术与创造
:END:
** 有趣项目
:PROPERTIES:
:CUSTOM_ID: 有趣项目
:END:
* 折腾博客
:PROPERTIES:
:CUSTOM_ID: 折腾博客
:END:
* 我写的文章
:PROPERTIES:
:CUSTOM_ID: 我写的文章
:END:
* 编程历程
:PROPERTIES:
:CUSTOM_ID: 编程历程
:END:
* 书籍
:PROPERTIES:
:CUSTOM_ID: 书籍
:END:
* 影视
:PROPERTIES:
:CUSTOM_ID: 影视
:END:
* 音乐
:PROPERTIES:
:CUSTOM_ID: 音乐
:END:
* 日记片段
:PROPERTIES:
:CUSTOM_ID: 日记片段
:END:
"
chinese-year chinese-month year month))
(defun my/blog-create-monthly ()
"Create a new monthly org file.
Prompts for month name and year."
(interactive)
(my/blog--ensure-directories)
(let* ((now (decode-time))
(default-year (nth 5 now))
(default-month (nth 4 now))
(chinese-month (read-string "月份名称 (如 腊月、冬月): "))
(year (read-number "年份: " default-year))
(month (read-number "月份数字 (1-12): " default-month))
(chinese-year (my/blog--chinese-year year))
(filepath (my/blog--monthly-filepath year month)))
(when (string-empty-p chinese-month)
(setq chinese-month (my/blog--chinese-month month)))
(if (file-exists-p filepath)
(progn
(find-file filepath)
(message "Monthly file already exists: %s" filepath))
(find-file filepath)
(insert (my/blog--monthly-template year month chinese-year chinese-month))
(save-buffer)
(message "Created monthly: 想法在%s%s迭代" chinese-year chinese-month))))
(defun my/blog-open-current-monthly ()
"Open the current month's monthly file, creating if needed."
(interactive)
(let ((filepath (my/blog--current-monthly-file)))
(if (file-exists-p filepath)
(find-file filepath)
(call-interactively 'my/blog-create-monthly))))
;;; Refile to Monthly
(defun my/blog-refile-to-monthly ()
"Refile current org entry to a section in the current monthly."
(interactive)
(unless (org-at-heading-p)
(org-back-to-heading t))
(let* ((monthly-file (my/blog--current-monthly-file))
(sections (mapcar #'car my/blog-monthly-sections))
(target-selection (completing-read "Refile to section: " sections nil t))
;; Get the actual headline from the alist (handles paths like "技术与创造/有趣项目")
(target-headline (cdr (assoc target-selection my/blog-monthly-sections))))
;; Ensure monthly file exists
(unless (file-exists-p monthly-file)
(my/blog-create-monthly))
;; Special handling for "有趣项目" - convert to list item
(if (string= target-headline "有趣项目")
(my/blog--refile-as-list-item monthly-file target-headline)
;; Normal refile for other sections
(let* ((entry-title (org-get-heading t t t t))
(custom-id (my/blog--slugify entry-title)))
(org-set-property "CUSTOM_ID" custom-id)
(let ((org-refile-targets `((,monthly-file :maxlevel . 3))))
(org-refile nil nil
(list target-headline monthly-file nil
(with-current-buffer (find-file-noselect monthly-file)
(org-find-exact-headline-in-buffer target-headline)))))))))
(defun my/blog--refile-as-list-item (file headline)
"Convert current entry to a list item and insert under HEADLINE in FILE."
(let* ((title (org-get-heading t t t t))
(url (org-entry-get nil "URL"))
(content (save-excursion
(org-back-to-heading t)
(let ((start (progn
(org-end-of-meta-data t)
(point)))
(end (org-end-of-subtree t t)))
(string-trim (buffer-substring-no-properties start end)))))
(list-item (if (and url (not (string-empty-p url)))
(if (string-empty-p content)
(format "- [[%s][%s]]" url title)
(format "- [[%s][%s]]: %s" url title content))
(if (string-empty-p content)
(format "- %s" title)
(format "- %s: %s" title content)))))
;; Delete original entry
(org-cut-subtree)
;; Insert as list item in target
(with-current-buffer (find-file-noselect file)
(goto-char (point-min))
(if (re-search-forward (format "^\\*+ %s" (regexp-quote headline)) nil t)
(progn
(org-end-of-meta-data t)
;; Move to end of existing list items or end of section
(let ((section-end (save-excursion (org-end-of-subtree t t))))
(while (and (< (point) section-end)
(looking-at "^[ \t]*\\(-\\|$\\)"))
(forward-line 1))
;; Back up if we went past list items
(when (and (> (point) (point-min))
(not (looking-at "^[ \t]*-")))
(forward-line -1)
(end-of-line)))
(insert "\n" list-item)
(save-buffer)
(message "Added to %s: %s" headline title))
(error "Headline '%s' not found in %s" headline file)))))
;;; Export Functions
(defun my/blog--get-org-property (prop)
"Get PROP from current org buffer's keywords."
(save-excursion
(goto-char (point-min))
(when (re-search-forward (format "^#\\+%s:[ \t]*\\(.*\\)$" prop) nil t)
(string-trim (match-string-no-properties 1)))))
(defun my/blog--collect-structure (buffer)
"Collect document structure from org BUFFER.
Returns list of (level title properties content subsections)."
(with-current-buffer buffer
(let ((result '())
(intro-text ""))
;; Get intro text (before first heading)
(save-excursion
(goto-char (point-min))
(when (re-search-forward "^\\*" nil t)
(let ((first-heading (line-beginning-position)))
(goto-char (point-min))
;; Skip keywords
(while (and (< (point) first-heading)
(looking-at "^#\\+"))
(forward-line 1))
;; Skip blank lines
(while (and (< (point) first-heading)
(looking-at "^[ \t]*$"))
(forward-line 1))
(when (< (point) first-heading)
(setq intro-text (string-trim
(buffer-substring-no-properties
(point) first-heading)))))))
;; Parse headings
(org-element-map (org-element-parse-buffer) 'headline
(lambda (hl)
(let* ((level (org-element-property :level hl))
(title (org-element-property :raw-value hl))
(begin (org-element-property :contents-begin hl))
(end (org-element-property :contents-end hl))
(props (org-entry-properties (org-element-property :begin hl)))
(source (cdr (assoc "SOURCE" props)))
(custom-id (cdr (assoc "CUSTOM_ID" props)))
(content ""))
;; Get content (only direct content, not sub-headlines)
;; Skip PROPERTIES drawer
(when (and begin end)
(save-excursion
(goto-char begin)
;; Skip PROPERTIES drawer if present
(when (looking-at "[ \t]*:PROPERTIES:")
(when (re-search-forward "^[ \t]*:END:" end t)
(forward-line 1)))
(let* ((content-start (point))
(content-end (if (re-search-forward "^\\*+ " end t)
(line-beginning-position)
end)))
(setq content (string-trim
(buffer-substring-no-properties content-start content-end))))))
(push (list :level level
:title title
:source source
:custom-id (or custom-id (my/blog--slugify title))
:content content)
result))))
(list :intro intro-text :sections (reverse result)))))
(defun my/blog--generate-hexo-toc (sections)
"Generate Hexo-style TOC from SECTIONS."
(let ((toc "{% details 本期导读 %}\n\n")
(input-sections '("商业与社会" "心理与关系" "科学与自然" "技术与创造"))
;; Output sections (excluding 书籍/影视/音乐 which have special format)
(output-main-sections '("折腾博客" "我写的文章" "编程历程"))
(media-sections '("书籍" "影视" "音乐"))
(current-section nil)
(found-media nil))
;; Build 输入 section
(setq toc (concat toc "## 输入\n\n"))
(dolist (sec sections)
(let ((title (plist-get sec :title))
(level (plist-get sec :level))
(slug (plist-get sec :custom-id)))
(when (and (= level 1) (member title input-sections))
(setq current-section title)
(setq toc (concat toc (format "#### %s\n\n" title))))
(when (and (= level 2) current-section (member current-section input-sections))
(setq toc (concat toc (format "- [%s](#%s)\n" title slug))))))
;; Build 输出 section
(setq toc (concat toc "\n## 输出\n\n"))
;; Main output sections (skip empty ones except 我写的文章 which has auto-fill)
(let ((skippable '("折腾博客" "编程历程")))
(dolist (sec sections)
(let ((title (plist-get sec :title))
(level (plist-get sec :level))
(slug (plist-get sec :custom-id))
(content (plist-get sec :content)))
(when (and (= level 1) (member title output-main-sections))
;; Skip if it's skippable and empty
(unless (and (member title skippable)
(or (null content) (string-empty-p content)))
(setq toc (concat toc (format "- [%s](#%s)\n" title slug))))))))
;; 书籍/影视/音乐 special format
(dolist (sec sections)
(when (and (= (plist-get sec :level) 1)
(member (plist-get sec :title) media-sections))
(setq found-media t)))
(when found-media
(setq toc (concat toc "- [书籍](#书籍) / [影视](#影视) / [音乐](#音乐)\n")))
;; 日记片段 -> 真生活
(dolist (sec sections)
(when (and (= (plist-get sec :level) 1)
(string= (plist-get sec :title) "日记片段"))
(setq toc (concat toc "- [真生活](#日记片段)\n"))))
(concat toc "\n{% enddetails %}\n")))
(defun my/blog--convert-org-to-md (content)
"Convert org CONTENT to markdown, preserving code block contents."
(with-temp-buffer
(insert content)
;; Step 1: Extract and protect code blocks with placeholders
(let ((code-blocks '())
(counter 0))
(goto-char (point-min))
(while (re-search-forward "^#\\+BEGIN_SRC\\s-*\\(.*\\)$" nil t)
(let ((lang (string-trim (match-string-no-properties 1)))
(start (match-beginning 0)))
(when (re-search-forward "^#\\+END_SRC" nil t)
(let* ((end (match-end 0))
(block-content (buffer-substring (save-excursion
(goto-char start)
(forward-line 1)
(point))
(save-excursion
(goto-char end)
(beginning-of-line)
(point))))
(placeholder (format "<<<CODEBLOCK%d>>>" counter))
(md-block (format "```%s\n%s```" lang block-content)))
(push (cons placeholder md-block) code-blocks)
(delete-region start end)
(goto-char start)
(insert placeholder)
(setq counter (1+ counter))))))
;; Step 2: All conversions on non-code content
;; Convert org headings to markdown headings
(goto-char (point-min))
(while (re-search-forward "^\\(\\*+\\) " nil t)
(let* ((stars (match-string 1))
(level (length stars))
(hashes (make-string level ?#)))
(replace-match (concat hashes " "))))
;; Convert #+MORE -> <!--more--> (case insensitive)
(goto-char (point-min))
(let ((case-fold-search t))
(while (re-search-forward "^#\\+MORE\\s-*$" nil t)
(replace-match "<!--more-->")))
;; Convert \\\\ -> <br> (line break within paragraph)
(goto-char (point-min))
(while (re-search-forward "\\\\\\\\\\s-*$" nil t)
(replace-match "<br>"))
;; Convert bold: *text* -> **text**
(goto-char (point-min))
(while (re-search-forward "\\*\\([^*\n]+\\)\\*" nil t)
(replace-match "**\\1**"))
;; Convert italic: /text/ -> *text*
(goto-char (point-min))
(while (re-search-forward "/\\([^/\n]+\\)/" nil t)
(replace-match "*\\1*"))
;; Convert underline: _text_ -> <u>text</u>
(goto-char (point-min))
(while (re-search-forward "_\\([^_\n]+\\)_" nil t)
(replace-match "<u>\\1</u>"))
;; Convert image links BEFORE other link conversions
;; [[file:path/image.png][alt]] or [[./path/image.png][alt]] → 
(goto-char (point-min))
(while (re-search-forward "\\[\\[\\(?:file:\\|\\.?/\\)?\\([^]]*\\.\\(png\\|jpg\\|jpeg\\|gif\\|webp\\|svg\\)\\)\\]\\[\\([^]]+\\)\\]\\]" nil t)
(replace-match ""))
;; [[file:image.png]] or [[./image.png]] → 
(goto-char (point-min))
(while (re-search-forward "\\[\\[\\(?:file:\\|\\.?/\\)?\\([^]]*\\.\\(png\\|jpg\\|jpeg\\|gif\\|webp\\|svg\\)\\)\\]\\]" nil t)
(replace-match ""))
;; Convert links: [[url][text]] -> [text](url)
(goto-char (point-min))
(while (re-search-forward "\\[\\[\\([^]]+\\)\\]\\[\\([^]]+\\)\\]\\]" nil t)
(replace-match "[\\2](\\1)"))
;; Convert plain links: [[url]] -> <url>
(goto-char (point-min))
(while (re-search-forward "\\[\\[\\([^]]+\\)\\]\\]" nil t)
(replace-match "<\\1>"))
;; Convert code: ~text~ -> `text`
(goto-char (point-min))
(while (re-search-forward "~\\([^~\n]+\\)~" nil t)
(replace-match "`\\1`"))
;; Convert verbatim: =text= -> `text`
(goto-char (point-min))
(while (re-search-forward "=\\([^=\n]+\\)=" nil t)
(replace-match "`\\1`"))
;; Convert BEGIN_QUOTE blocks
(goto-char (point-min))
(while (re-search-forward "^#\\+BEGIN_QUOTE" nil t)
(replace-match ""))
(goto-char (point-min))
(while (re-search-forward "^#\\+END_QUOTE" nil t)
(replace-match ""))
;; Convert other special blocks to Hexo tags (but not SRC/QUOTE)
(goto-char (point-min))
(while (re-search-forward "^#\\+BEGIN_\\([A-Za-z]+\\)\\(.*\\)$" nil t)
(let ((tag (downcase (match-string-no-properties 1)))
(args (string-trim (or (match-string-no-properties 2) ""))))
(unless (member tag '("src" "quote"))
(replace-match (if (string-empty-p args)
(format "{%% %s %%}" tag)
(format "{%% %s %s %%}" tag args))))))
(goto-char (point-min))
(while (re-search-forward "^#\\+END_\\([A-Za-z]+\\)" nil t)
(let ((tag (downcase (match-string-no-properties 1))))
(unless (member tag '("src" "quote"))
(replace-match (format "{%% end%s %%}" tag)))))
;; Remove any remaining PROPERTIES drawers
(goto-char (point-min))
(while (re-search-forward "^[ \t]*:PROPERTIES:[ \t]*\n\\(?:.*\n\\)*?[ \t]*:END:[ \t]*\n?" nil t)
(replace-match ""))
;; Step 2.5: Clean up spaces around CJK characters and style markers
;; Remove space between CJK char and opening style marker
(goto-char (point-min))
(while (re-search-forward "\\(\\cC\\) +\\(\\*\\*\\|`\\|<u>\\)" nil t)
(replace-match "\\1\\2"))
;; Remove space between closing style marker and CJK char
(goto-char (point-min))
(while (re-search-forward "\\(\\*\\*\\|`\\|</u>\\) +\\(\\cC\\)" nil t)
(replace-match "\\1\\2"))
;; Handle single * (italic) separately to avoid conflict with **
(goto-char (point-min))
(while (re-search-forward "\\(\\cC\\) +\\(\\*[^*]\\)" nil t)
(replace-match "\\1\\2"))
(goto-char (point-min))
(while (re-search-forward "\\([^*]\\*\\) +\\(\\cC\\)" nil t)
(replace-match "\\1\\2"))
;; Remove space before CJK punctuation
(goto-char (point-min))
(while (re-search-forward "\\(\\cC\\|\\*\\*\\|`\\|</u>\\) +\\(\\cP\\)" nil t)
(replace-match "\\1\\2"))
;; Step 3: Restore code blocks
(dolist (block code-blocks)
(goto-char (point-min))
(when (search-forward (car block) nil t)
(replace-match (cdr block) t t))))
(buffer-string)))
(defun my/blog-export-monthly (&optional file)
"Export monthly org FILE to Hexo markdown.
If FILE is nil, use current buffer's file or current monthly."
(interactive)
(let* ((org-file (or file
(when (and (buffer-file-name)
(string-suffix-p ".org" (buffer-file-name)))
(buffer-file-name))
(my/blog--current-monthly-file))))
;; Debug: show which file we're exporting
(message "Exporting: %s" org-file)
;; Read file contents directly
(with-temp-buffer
(insert-file-contents org-file)
(org-mode)
(let* ((title (my/blog--get-org-property "TITLE"))
(date (or (my/blog--get-org-property "DATE")
(format-time-string "%Y-%m-%d %H:%M:%S")))
(structure (my/blog--collect-structure (current-buffer)))
(intro (plist-get structure :intro))
(sections (plist-get structure :sections))
(export-file (expand-file-name (concat title ".md") my/blog-export-dir))
(year-month (if (string-match "\\([0-9]\\{4\\}\\)-\\([0-9]\\{2\\}\\)" date)
(format "%s-%s" (match-string 1 date) (match-string-no-properties 2 date))
(format-time-string "%Y-%m"))))
;; Generate markdown content
(with-temp-buffer
;; Front matter
(insert "---\n")
(insert (format "title: %s\n" title))
(insert "lang: zh\n")
(insert "categories:\n - 想法迭代\n")
(insert "mathjax: false\n")
(insert "hidden: false\n")
;; Don't include abbrlink - let hexo-abbrlink auto-generate it
(insert (format "date: %s\n" (if (string-match ":" date) date (concat date " 00:00:00"))))
(insert (format "diary_month: %s\n" year-month))
(insert "tags:\n")
(insert "description:\n")
(insert "---\n\n")
;; Intro
(when (not (string-empty-p intro))
(insert (my/blog--convert-org-to-md intro) "\n\n"))
;; More marker
(insert "<!--more-->\n\n")
;; TOC
(insert (my/blog--generate-hexo-toc sections) "\n")
;; Collect monthly posts for auto-fill
(let* ((date-parts (split-string date "-"))
(export-year (string-to-number (nth 0 date-parts)))
(export-month (string-to-number (nth 1 date-parts)))
(monthly-posts (my/blog--collect-monthly-posts export-year export-month)))
;; Main content
(let ((skippable-sections '("折腾博客" "编程历程"))
(hr-inserted nil))
(dolist (sec sections)
(let ((level (plist-get sec :level))
(title (plist-get sec :title))
(source (plist-get sec :source))
(content (plist-get sec :content))
(has-subsections nil))
;; Check if this section has subsections with content
(when (= level 1)
(let ((sec-idx (cl-position sec sections)))
(cl-loop for i from (1+ sec-idx) below (length sections)
for next-sec = (nth i sections)
while (> (plist-get next-sec :level) 1)
when (not (string-empty-p (or (plist-get next-sec :content) "")))
do (setq has-subsections t))))
;; Special handling for 我写的文章
(when (and (= level 1)
(string= title "我写的文章")
(or (null content) (string-empty-p content))
(not has-subsections)
monthly-posts)
;; Auto-fill with scanned posts
(setq content (mapconcat
(lambda (post)
(format "- [《%s》](%s)\n" (car post) (cdr post)))
monthly-posts
"")))
;; Skip empty skippable sections (no content and no subsections)
(unless (and (= level 1)
(member title skippable-sections)
(or (null content) (string-empty-p content))
(not has-subsections))
;; Insert hr before first output section
(when (and (= level 1)
(not hr-inserted)
(not (member title '("商业与社会" "心理与关系" "科学与自然" "技术与创造"))))
(insert "\n---\n")
(setq hr-inserted t))
(cond
;; Level 1 -> ## heading
((= level 1)
(insert (format "\n## %s\n\n" title)))
;; Level 2 -> #### heading (with optional link)
((= level 2)
(if source
(insert (format "#### [《%s》](%s)\n\n" title source))
(insert (format "#### %s\n\n" title)))))
;; Content
(when (and content (not (string-empty-p content)))
(insert (my/blog--convert-org-to-md content) "\n\n")))))))
;; Write to file
(write-region (point-min) (point-max) export-file))
(message "Exported to: %s" export-file)
(find-file export-file)))))
;;; Capture Templates for Monthly
(defun my/blog--capture-target-monthly (section)
"Return capture target for SECTION in current monthly."
(let ((file (my/blog--current-monthly-file)))
;; Ensure file exists
(unless (file-exists-p file)
(my/blog-create-monthly))
`(file+headline ,file ,section)))
(defun my/blog-capture-to-monthly ()
"Capture an entry directly to the current monthly.
Prompts for section selection."
(interactive)
(let* ((sections (mapcar #'car my/blog-monthly-sections))
(section (completing-read "Section: " sections nil t))
(file (my/blog--current-monthly-file)))
;; Ensure monthly exists
(unless (file-exists-p file)
(my/blog-create-monthly))
;; Set up temporary capture template
(let ((org-capture-templates
`(("x" "Monthly Entry" entry
(file+headline ,file ,section)
"** %^{标题}\n:PROPERTIES:\n:CUSTOM_ID: %(my/blog--slugify (org-capture-get :annotation))\n:SOURCE: %^{URL}\n:END:\n\n%?\n\n%U"))))
(org-capture nil "x"))))
;; Add a simple menu entry for monthly capture
(defun my/blog--add-monthly-capture-templates ()
"Add monthly capture templates to `org-capture-templates'."
;; We use function-based targets for dynamic file resolution
(add-to-list 'org-capture-templates
'("m" "Monthly (博客月刊)") t)
(add-to-list 'org-capture-templates
`("ma" "→ 商业与社会" entry
(function (lambda () (my/blog--goto-monthly-section "商业与社会")))
"** %^{标题}\n:PROPERTIES:\n:CUSTOM_ID: %(my/blog--slugify \"%\\1\")\n:SOURCE: %^{URL}\n:END:\n\n%?\n\n%U") t)
(add-to-list 'org-capture-templates
`("mb" "→ 心理与关系" entry
(function (lambda () (my/blog--goto-monthly-section "心理与关系")))
"** %^{标题}\n:PROPERTIES:\n:CUSTOM_ID: %(my/blog--slugify \"%\\1\")\n:SOURCE: %^{URL}\n:END:\n\n%?\n\n%U") t)
(add-to-list 'org-capture-templates
`("mc" "→ 技术与创造" entry
(function (lambda () (my/blog--goto-monthly-section "技术与创造")))
"** %^{标题}\n:PROPERTIES:\n:CUSTOM_ID: %(my/blog--slugify \"%\\1\")\n:SOURCE: %^{URL}\n:END:\n\n%?\n\n%U") t)
(add-to-list 'org-capture-templates
`("md" "→ 生活与文娱" entry
(function (lambda () (my/blog--goto-monthly-section "生活与文娱")))
"** %^{标题}\n:PROPERTIES:\n:CUSTOM_ID: %(my/blog--slugify \"%\\1\")\n:SOURCE: %^{URL}\n:END:\n\n%?\n\n%U") t))
(defun my/blog--goto-monthly-section (section)
"Go to SECTION in current monthly file for capture."
(let ((file (my/blog--current-monthly-file)))
;; Ensure monthly exists
(unless (file-exists-p file)
(my/blog-create-monthly))
(set-buffer (org-capture-target-buffer file))
(goto-char (point-min))
(if (re-search-forward (format "^\\* %s" (regexp-quote section)) nil t)
(org-end-of-subtree)
(goto-char (point-max)))))
;; Add templates after org-capture is loaded
(with-eval-after-load 'org-capture
(run-with-idle-timer 1 nil #'my/blog--add-monthly-capture-templates))
;;; Regular Post Export
(defun my/blog-export-post (&optional file)
"Export regular org FILE to Hexo markdown.
If FILE is nil, use current buffer's file."
(interactive)
(let* ((org-file (or file
(when (and (buffer-file-name)
(string-suffix-p ".org" (buffer-file-name)))
(buffer-file-name)))))
(unless org-file
(error "No org file specified"))
(message "Exporting post: %s" org-file)
;; Read file contents
(with-temp-buffer
(insert-file-contents org-file)
(org-mode)
(let* ((title (my/blog--get-org-property "TITLE"))
(date (or (my/blog--get-org-property "DATE")
(format-time-string "%Y-%m-%d")))
(categories (or (my/blog--get-org-property "CATEGORIES") "未分类"))
(lang (or (my/blog--get-org-property "LANG") "zh"))
(mathjax (or (my/blog--get-org-property "MATHJAX") "false"))
(hidden (or (my/blog--get-org-property "HIDDEN") "false"))
(abbrlink (or (my/blog--get-org-property "ABBRLINK") ""))
(tags (or (my/blog--get-org-property "TAGS") ""))
(description (or (my/blog--get-org-property "DESCRIPTION") ""))
(export-file (expand-file-name
(concat (file-name-base org-file) ".md")
my/blog-export-dir))
;; Get main content (after properties)
(content (my/blog--get-post-body)))
;; Generate markdown
(with-temp-buffer
;; Front matter
(insert "---\n")
(insert (format "title: %s\n" title))
(insert (format "lang: %s\n" lang))
(insert (format "categories:\n - %s\n" categories))
(insert (format "mathjax: %s\n" mathjax))
(insert (format "hidden: %s\n" hidden))
;; Only include abbrlink if explicitly set (let hexo-abbrlink auto-generate if empty)
(when (and abbrlink (not (string-empty-p abbrlink)))
(insert (format "abbrlink: %s\n" abbrlink)))
(insert (format "date: %s\n"
(if (string-match ":" date) date (concat date " 00:00:00"))))
;; Format tags as YAML list if not empty
(if (and tags (not (string-empty-p tags)))
(progn
(insert "tags:\n")
(dolist (tag (split-string tags "," t "[ \t]+"))
(insert (format " - %s\n" tag))))
(insert "tags:\n"))
(insert (format "description: %s\n" description))
(insert "---\n\n")
;; Description/excerpt if provided
(when (and description (not (string-empty-p description)))
(insert description "\n\n"))
;; Main content (#+MORE in org will become <!--more--> via convert function)
(insert (my/blog--convert-org-to-md content))
;; Save
(write-region (point-min) (point-max) export-file))
(message "Exported to: %s" export-file)))))
(defun my/blog--get-post-body ()
"Get the body content of the org file (excluding properties header and drawers)."
(save-excursion
(goto-char (point-min))
;; Skip past all #+KEYWORD lines and empty lines at beginning
(while (and (not (eobp))
(looking-at "^\\(#\\+\\|$\\)"))
(forward-line 1))
;; Skip any file-level drawers (PROPERTIES, LOGBOOK, etc.)
(while (and (not (eobp))
(looking-at "^[ \t]*:\\([A-Z]+\\):[ \t]*$"))
(if (re-search-forward "^[ \t]*:END:" nil t)
(forward-line 1)
(forward-line 1)))
;; Skip any blank lines after drawers
(while (and (not (eobp))
(looking-at "^[ \t]*$"))
(forward-line 1))
;; Get everything from here to end
(buffer-substring-no-properties (point) (point-max))))
;;; Convert Entry to Blog Post
(defun my/blog-create-post-from-entry ()
"Convert current org entry to a standalone blog post.
Creates a new org file in the blog posts directory with front matter."
(interactive)
(unless (derived-mode-p 'org-mode)
(error "Not in org-mode"))
;; Move to heading if not already there
(unless (org-at-heading-p)
(org-back-to-heading t))
(let* ((heading (org-get-heading t t t t))
(title (read-string "文章标题: " heading))
(slug (my/blog--slugify title))
(category (read-string "分类: " "技术"))
(date (format-time-string "%Y-%m-%d"))
(filename (concat slug ".org"))
(posts-dir (expand-file-name "posts" my/blog-org-dir))
(filepath (expand-file-name filename posts-dir))
;; Get entry content (without heading)
(content (save-excursion
(org-back-to-heading t)
(let ((start (progn (forward-line 1) (point)))
(end (org-end-of-subtree t t)))
(buffer-substring-no-properties start end)))))
;; Ensure posts directory exists
(unless (file-exists-p posts-dir)
(make-directory posts-dir t))
;; Check if file already exists
(when (file-exists-p filepath)
(unless (y-or-n-p (format "文件 %s 已存在，覆盖? " filename))
(error "已取消")))
;; Prompt for optional fields
(let ((tags (read-string "标签 (逗号分隔，可留空): "))
(description (read-string "描述 (可留空): ")))
;; Create new file with complete front matter
(with-temp-buffer
(insert (format "#+TITLE: %s\n" title))
(insert (format "#+DATE: %s\n" date))
(insert (format "#+CATEGORIES: %s\n" category))
(insert "#+LANG: zh\n")
(insert "#+MATHJAX: false\n")
(insert "#+HIDDEN: false\n")
(insert "#+ABBRLINK:\n")
(insert (format "#+TAGS: %s\n" (if (string-empty-p tags) "" tags)))
(insert (format "#+DESCRIPTION: %s\n\n" (if (string-empty-p description) "" description)))
;; Clean up content (remove leading/trailing whitespace)
(insert (string-trim content))
(insert "\n")
(write-file filepath)))
;; Ask whether to delete original entry
(when (y-or-n-p "删除原条目? ")
(org-cut-subtree))
;; Open the new file
(find-file filepath)
(message "已创建博客文章: %s\n用 C-c b p 导出为 Markdown" filepath)))
;;; Image Insertion
(defun my/blog--url-p (string)
"Return non-nil if STRING looks like a URL."
(string-match-p "^https?://" string))
(defun my/blog--download-image (url target-file)
"Download image from URL to TARGET-FILE."
(require 'url)
(let ((url-request-method "GET"))
(with-current-buffer (url-retrieve-synchronously url t)
;; Skip HTTP headers
(goto-char (point-min))
(re-search-forward "\r?\n\r?\n" nil t)
;; Write binary content to file
(let ((coding-system-for-write 'binary))
(write-region (point) (point-max) target-file))
(kill-buffer))))
(defun my/blog-insert-image ()
"Insert an image link for blog post.
Supports both local files and web URLs.
For local files: select and copy to post's asset folder.
For web URLs: download and save with a specified filename."
(interactive)
(unless (buffer-file-name)
(error "Buffer must be visiting a file"))
(let* ((post-name (file-name-base (buffer-file-name)))
(target-dir (expand-file-name post-name my/blog-export-dir))
;; Get source: can be file path or URL
(source (read-string "Image file or URL: "))
(is-url (my/blog--url-p source))
;; For URLs without extension, ask for filename; for local files, use original name
(image-name (if is-url
(let ((default-name (file-name-nondirectory (url-filename (url-generic-parse-url source)))))
(read-string "Save as (e.g. photo.jpg): "
(if (string-match-p "\\." default-name) default-name "")))
(file-name-nondirectory source)))
(target-file (expand-file-name image-name target-dir))
(alt-text (read-string "Alt text (optional): ")))
;; Validate filename for URLs
(when (and is-url (string-empty-p image-name))
(error "Filename is required for web images"))
;; Create target directory if needed
(unless (file-directory-p target-dir)
(make-directory target-dir t)
(message "Created directory: %s" target-dir))
;; Download or copy image
(unless (file-exists-p target-file)
(if is-url
(progn
(message "Downloading %s..." source)
(my/blog--download-image source target-file)
(message "Downloaded to %s" target-file))
(copy-file source target-file)
(message "Copied %s to %s" image-name target-dir)))
;; Insert org link
(if (string-empty-p alt-text)
(insert (format "[[./%s]]" image-name))
(insert (format "[[./%s][%s]]" image-name alt-text)))))
;;; Provide
(provide 'pkg-blog)
;;; pkg-blog.el ends here