[1293] 草稿文件放开 .stem 后缀支持并导出样式包为 .stem 草稿 (#4533)

Co-authored-by: Claude <noreply@anthropic.com>

Author: da-liii

TeXmacs/progs/kernel/boot/abbrevs.scm

@@ -222,13 +222,19 @@
   (when (null? (cdr opts))
     ;; Issue #327: Use last file dialog directory if current buffer is scratch
     (let* ((master (buffer-get-master (current-buffer)))
+           (style-target (and (defined? 'style-package-target-url)
+                           (style-package-target-url (current-buffer))
+                         ) ;and
+           ) ;style-target
            (last-dir (and (url-scratch? master)
+                       (not style-target)
                        (defined? 'get-last-file-dialog-directory)
                        (get-last-file-dialog-directory)
                      ) ;and
            ) ;last-dir
           ) ;
-      (cond ((and last-dir (string? last-dir) (not (string-null? last-dir)))
+      (cond (style-target (set! opts (list (car opts) style-target)))
+            ((and last-dir (string? last-dir) (not (string-null? last-dir)))
              (set! opts (list (car opts) (system->url last-dir)))
             ) ;
             ((url-scratch? master)

TeXmacs/progs/source/source-edit.scm

@@ -192,9 +192,24 @@
   ) ;with
 ) ;define
 
-(tm-define (extract-style-file style?)
-  (let* ((tit (extract-source-title style?))
-         (packs (extract-use-package style?))
+(define style-package-targets (make-ahash-table))
+
+(tm-define (style-package-target-url buf) (ahash-ref style-package-targets buf))
+
+(define (style-package-compute-target orig)
+  (cond ((or (url-scratch? orig) (url-rooted-tmfs? orig))
+         (url-append (get-documents-path)
+           (string-append "LiiiSTEM/" (url-basename orig) ".stem")
+         ) ;url-append
+        ) ;
+        (else (url-append (url-head orig) (string-append (url-basename orig) ".stem")))
+  ) ;cond
+) ;define
+
+(tm-define (extract-style-package)
+  (let* ((orig (current-buffer))
+         (tit (extract-source-title #f))
+         (packs (extract-use-package #f))
          (inits (extract-style-parameters))
          (defs (extract-macro-definitions))
          (body `(document ,tit ,@packs ,@inits ,@defs))
@@ -203,7 +218,11 @@
                  (body ,body))
          ) ;doc
         ) ;
-    (new-buffer)
+    (new-buffer ".stem")
+    (ahash-set! style-package-targets
+      (current-buffer)
+      (style-package-compute-target orig)
+    ) ;ahash-set!
     (delayed (:idle 1) (buffer-set (current-buffer) doc))
   ) ;let*
 ) ;tm-define

TeXmacs/progs/source/source-menu.scm

@@ -175,8 +175,7 @@
  ("Edit macros" (open-macros-editor :global))
  ("Edit preamble" (toggle-preamble-mode))
  ---
- ("Extract style file" (extract-style-file #t))
- ("Extract style package" (extract-style-file #f))
+ ("Extract style package" (extract-style-package))
 ) ;menu-bind
 
 (menu-bind source-menu

TeXmacs/progs/source/tests/extract-style-package-test.scm

@@ -0,0 +1,75 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; MODULE      : extract-style-package-test.scm
+;; DESCRIPTION : 单元测试：导出样式包生成 .stem 草稿文件及宏菜单结构验证
+;; COPYRIGHT   : (C) 2026 Mogan STEM
+;;
+;; USAGE
+;;   xmake b stem
+;;   xmake r extract-style-package-test
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(import (liii check))
+
+(check-set-mode! 'report-failed)
+
+(load "./TeXmacs/progs/source/source-menu.scm")
+(load "./TeXmacs/progs/source/source-edit.scm")
+
+(define (menu-contains-label? m label)
+  (cond ((null? m) #f)
+        ((pair? m)
+         (or (menu-contains-label? (car m) label) (menu-contains-label? (cdr m) label))
+        ) ;
+        ((string? m) (string=? m label))
+        (else #f)
+  ) ;cond
+) ;define
+
+(define (test-source-macros-menu-items)
+  (let ((menu (source-macros-menu)))
+    ;; 验证已移除 "Extract style file"，仅保留 "Extract style package"
+    (check (menu-contains-label? menu "Extract style file") => #f)
+    (check (menu-contains-label? menu "Extract style package") => #t)
+  ) ;let
+) ;define
+
+(define (test-extract-style-package-stem-buffer)
+  (let ((orig-buf (current-buffer)))
+    (extract-style-package)
+    (let* ((new-buf (current-buffer)) (name (url->string (url-tail new-buf))))
+      ;; 验证新创建的 buffer 是 .stem 后缀的草稿文件
+      (check (string-starts? name "draft_") => #t)
+      (check (string-ends? name ".stem") => #t)
+      (check (url-scratch? new-buf) => #t)
+      ;; 验证记录了目标保存路径
+      (check (url? (style-package-target-url new-buf)) => #t)
+    ) ;let*
+    ;; 切回原 buffer 并关闭测试草稿 buffer
+    (buffer-close (current-buffer))
+    (switch-to-buffer orig-buf)
+  ) ;let
+) ;define
+
+(define (test-style-package-compute-target)
+  (for-each (lambda (case
+                    ) ;case
+              (check (url->system (style-package-compute-target (system->url (car case))))
+                =>
+                (cdr case)
+              ) ;check
+            ) ;lambda
+    '(("/home/da/docs/paper.tmu" . "/home/da/docs/paper.stem")
+      ("/home/da/projects/report.tm" . "/home/da/projects/report.stem")
+      ("/home/da/文档/测试.tmu" . "/home/da/文档/测试.stem")
+      ("/tmp/my_paper.tmu" . "/tmp/my_paper.stem"))
+  ) ;for-each
+) ;define
+
+(tm-define (regtest-extract-style-package)
+  (test-source-macros-menu-items)
+  (test-extract-style-package-stem-buffer)
+  (test-style-package-compute-target)
+  (check-report)
+) ;tm-define

TeXmacs/progs/texmacs/texmacs/tm-files-test.scm

@@ -60,15 +60,16 @@
 ) ;define
 
 (define (draft-name-stamp-part name)
-  (let* ((body (substring name 6 (- (string-length name) 4)))
+  (let* ((dot (string-rindex name #\.))
+         (body (substring name 6 dot))
          (cut (or (string-index body #\-) (string-length body)))
         ) ;
     (substring body 0 cut)
   ) ;let*
 ) ;define
 
 (define (test-scratch-buffer-name-has-date-time-underscore)
-  (let* ((path (scratch-buffer-name))
+  (let* ((path (scratch-buffer-name ".tmu"))
          (name (url->string (url-tail (system->url path))))
          (stamp (draft-name-stamp-part name))
         ) ;
@@ -80,6 +81,30 @@
   ) ;let*
 ) ;define
 
+(define (test-scratch-buffer-name-stem)
+  (let* ((path (scratch-buffer-name ".stem"))
+         (name (url->string (url-tail (system->url path))))
+         (stamp (draft-name-stamp-part name))
+        ) ;
+    (check (string-starts? name "draft_") => #t)
+    (check (string-ends? name ".stem") => #t)
+    (check (string-length stamp) => 15)
+    (check (substring stamp 8 9) => "_")
+  ) ;let*
+) ;define
+
+(define (test-scratch-buffer-title-stem)
+  (let ((tmu-title (scratch-buffer-title (draft-test-url "draft_20250802_153000.tmu")))
+        (stem-title (scratch-buffer-title (draft-test-url "draft_20250802_153000.stem"))
+        ) ;stem-title
+        (stem-n-title (scratch-buffer-title (draft-test-url "draft_20250802_153000-1.stem"))
+        ) ;stem-n-title
+       ) ;
+    (check stem-title => tmu-title)
+    (check stem-n-title => tmu-title)
+  ) ;let
+) ;define
+
 (define (test-scratch-buffer-title-old-and-new-stamp)
   ;; 往年草稿不显示时刻,新旧文件名必须得到同一标题
   (let ((old (scratch-buffer-title (draft-test-url "draft_20250802153000.tmu")))
@@ -122,6 +147,8 @@
   (test-auto-backup-official-url)
   (test-auto-backup-texmacs-path-buffer?)
   (test-scratch-buffer-name-has-date-time-underscore)
+  (test-scratch-buffer-name-stem)
+  (test-scratch-buffer-title-stem)
   (test-scratch-buffer-title-old-and-new-stamp)
   (test-scratch-buffer-title-legacy-one-underscore-this-week)
   (check-report)

TeXmacs/progs/texmacs/texmacs/tm-files.scm

@@ -573,7 +573,7 @@
              (save-buffer-check-faithful name opts)
              (choose-file (lambda (x) (apply save-buffer-as-main (cons x opts)))
                "Save TeXmacs file"
-               "tmu"
+               "action_save_as"
              ) ;choose-file
            ) ;if
           ) ;
@@ -1201,57 +1201,70 @@
   (and (not (buffer-exists? u)) (not (url-exists? u)))
 ) ;define
 
-(define (scratch-candidate dir stamp)
-  (url-append dir (string-append "draft_" stamp ".tmu"))
+(define (normalize-draft-ext ext)
+  (if (equal? ext ".stem") ".stem" ".tmu")
+) ;define
+
+(define (scratch-candidate dir stamp ext)
+  (url-append dir (string-append "draft_" stamp ext))
 ) ;define
 
 ;; 秒级名字仍冲突时,追加 -2、-3 …… 保证唯一
 
-(define (scratch-unique-name dir stamp i)
+(define (scratch-unique-name dir stamp i ext)
   (let ((u (scratch-candidate dir
              (if (= i 0) stamp (string-append stamp "-" (number->string i)))
+             ext
            ) ;scratch-candidate
         ) ;u
        ) ;
-    (if (scratch-name-free? u) u (scratch-unique-name dir stamp (+ i 1)))
+    (if (scratch-name-free? u) u (scratch-unique-name dir stamp (+ i 1) ext))
   ) ;let
 ) ;define
 
 ;; 新 scratch buffer 的名字:日期与时刻用 _ 分开,精确到秒,冲突加 -N
-;; 例: draft_20260901_194700.tmu / draft_20260901_194700-1.tmu
+;; 例: draft_20260901_194700.tmu / draft_20260901_194700-1.tmu / .stem
 ;; 返回系统路径字符串(供 C++ make_new_buffer 使用)
-(tm-define (scratch-buffer-name)
+(tm-define (scratch-buffer-name ext)
   (with dir
     (scratch-buffer-dir)
     (when (not (url-exists? dir))
       (system-mkdir dir)
     ) ;when
     (with full
       (date->string (current-date) "~Y~m~d_~H~M~S")
-      (url->system (scratch-unique-name dir full 0))
+      (url->system (scratch-unique-name dir full 0 (normalize-draft-ext ext)))
     ) ;with
   ) ;with
 ) ;tm-define
 
+(tm-define (new-buffer . opt-ext)
+  (cpp-new-buffer-with-ext (if (null? opt-ext) ".tmu" (normalize-draft-ext (car opt-ext)))
+  ) ;cpp-new-buffer-with-ext
+) ;tm-define
+
 ;; draft 文件名 → 纯数字时间戳,供标题按位切分(YYYYMMDDHH[MM][SS])。
 ;; 新格式 "draft_20260901_194700.tmu" → "20260901194700";
+;; ".stem" 格式 "draft_20260901_194700.stem" → "20260901194700";
 ;; 旧格式 "draft_202608242127-2.tmu" → "202608242127";
 ;; 非 draft 名返回 #f
 
 (define (draft-stamp u)
   (with name
     (url->string (url-tail u))
-    (and (string-starts? name "draft_")
-      (string-ends? name ".tmu")
-      (let* ((body (substring name 6 (- (string-length name) 4)))
-             (cut (or (string-index body #\-) (string-length body)))
-             (raw (substring body 0 cut))
-             ;; 去掉日期与时刻之间的 _,标题逻辑仍按连续数字下标切
-             (digits (string-join (string-split raw "_") ""))
-            ) ;
-        (and (>= (string-length digits) 12) digits)
-      ) ;let*
-    ) ;and
+    (let ((ext (url-suffix u)))
+      (and (in? ext '("tmu" "stem"))
+        (string-starts? name "draft_")
+        (let* ((body (substring name 6 (- (string-length name) (string-length ext) 1)))
+               (cut (or (string-index body #\-) (string-length body)))
+               (raw (substring body 0 cut))
+               ;; 去掉日期与时刻之间的 _,标题逻辑仍按连续数字下标切
+               (digits (string-join (string-split raw "_") ""))
+              ) ;
+          (and (>= (string-length digits) 12) digits)
+        ) ;let*
+      ) ;and
+    ) ;let
   ) ;with
 ) ;define