;;; 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 "<<>>" 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 -> (case insensitive) (goto-char (point-min)) (let ((case-fold-search t)) (while (re-search-forward "^#\\+MORE\\s-*$" nil t) (replace-match ""))) ;; Convert \\\\ ->
(line break within paragraph) (goto-char (point-min)) (while (re-search-forward "\\\\\\\\\\s-*$" nil t) (replace-match "
")) ;; 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_ -> text (goto-char (point-min)) (while (re-search-forward "_\\([^_\n]+\\)_" nil t) (replace-match "\\1")) ;; Convert image links BEFORE other link conversions ;; [[file:path/image.png][alt]] or [[./path/image.png][alt]] → ![alt](image.png) (goto-char (point-min)) (while (re-search-forward "\\[\\[\\(?:file:\\|\\.?/\\)?\\([^]]*\\.\\(png\\|jpg\\|jpeg\\|gif\\|webp\\|svg\\)\\)\\]\\[\\([^]]+\\)\\]\\]" nil t) (replace-match "![\\3](\\1)")) ;; [[file:image.png]] or [[./image.png]] → ![](image.png) (goto-char (point-min)) (while (re-search-forward "\\[\\[\\(?:file:\\|\\.?/\\)?\\([^]]*\\.\\(png\\|jpg\\|jpeg\\|gif\\|webp\\|svg\\)\\)\\]\\]" nil t) (replace-match "![](\\1)")) ;; Convert links: [[url][text]] -> [text](url) (goto-char (point-min)) (while (re-search-forward "\\[\\[\\([^]]+\\)\\]\\[\\([^]]+\\)\\]\\]" nil t) (replace-match "[\\2](\\1)")) ;; Convert plain links: [[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\\) +\\(\\*\\*\\|`\\|\\)" nil t) (replace-match "\\1\\2")) ;; Remove space between closing style marker and CJK char (goto-char (point-min)) (while (re-search-forward "\\(\\*\\*\\|`\\|\\) +\\(\\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\\|\\*\\*\\|`\\|\\) +\\(\\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 "\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 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