;;; my-media-segment.el -- Media segmentation utility -*- lexical-binding: t -*- ;; Copyright (C) 2023 Free Software Foundation. ;; Author: Yuchen Pei ;; Package-Requires: ((emacs "28.2")) ;; This file is part of dotfiles. ;; dotfiles is free software: you can redistribute it and/or modify it under ;; the terms of the GNU Affero General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; dotfiles is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY ;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General ;; Public License for more details. ;; You should have received a copy of the GNU Affero General Public ;; License along with dotfiles. If not, see . ;;; Commentary: ;; Media segmentation utility. ;;; Code: ;;; A utility using ffmpeg to cut a media file into smaller ones, from a ;;; description of the timestamps. (defvar my-media-segment-queued-jobs nil) (defvar my-media-segment-max-inflight 3) (defun my-media-segment-enqueue-process (start-process-function) "Enqueue a process that can started by applying 'start-process'. The process can be started by applying 'start-process' on START-PROCESS-ARGS." ;; somehow only this version works, but not nconc or setq with append ;; the problem with the other two is that the operation gets stuck after the ;; initial 'my-media-segment-max-inflight' operations. (add-to-list 'my-media-segment-queued-jobs start-process-function) ;; (nconc my-media-segment-queued-jobs (list start-process-function)) ;; (setq my-media-segment-queued-jobs ;; (append my-media-segment-queued-jobs (list start-process-function))) ) (defun my-media-segment-dequeue-process () (when my-media-segment-queued-jobs (funcall (pop my-media-segment-queued-jobs)))) (defun my-segment-media-file-1 (media-file-name desc-file-name) "Run ffmpeg asynchronously to segment file-name according to description. Uses `my-media-segment-max-inflight' to limit number of inflight tasks." (interactive (list (read-file-name "Choose media file: ") (read-file-name "Choose description file: "))) (let* ((dir (file-name-sans-extension (expand-file-name media-file-name))) (info (my-get-media-segments (with-temp-buffer (insert-file-contents desc-file-name) (buffer-string)))) (total (length info)) (pad (1+ (floor (log10 total)))) (idx 0) (thunk)) (dolist (media info) (setq idx (1+ idx)) (ignore-errors (dired-create-directory dir)) (let* ((title (plist-get media :title)) (start (plist-get media :start)) (end (plist-get media :end)) (args (append (list "-ss" start) (when end (list "-to" end)) (list "-i" (expand-file-name media-file-name) (format (format "%%s/%%0%dd-%%s.%%s" pad) dir idx title (file-name-extension media-file-name)))))) (setq thunk (lambda () (message "Cutting %s-%s to %s (%d/%d)..." start (or end "") title idx total) (set-process-sentinel (apply 'start-process (append (list (format "ffmpeg-%s" title) (format "*ffmpeg-%s*" title) "ffmpeg") args)) (lambda (_ _) (my-media-segment-dequeue-process))))) (if (<= idx my-media-segment-max-inflight) (funcall thunk) (my-media-segment-enqueue-process thunk)))))) (defun my-get-media-segments (description) "Output title start end triplets." (let ((results) (title) (start) (end)) (with-temp-buffer (erase-buffer) (insert description) (goto-char (point-min)) (save-excursion (while (re-search-forward "\\(\\(?:[0-9]+:\\)?[0-9]+:[0-9]\\{2\\}\\)\\(?:[[:space:]]*-[[:space:]]*\\(\\(?:[0-9]+:\\)?[0-9]+:[0-9]\\{2\\}\\)\\)?" nil t) (setq start (match-string-no-properties 1) end (match-string-no-properties 2)) (replace-match "") (beginning-of-line 1) (setq title (replace-regexp-in-string "^[[:punct:][:space:]]*" "" (replace-regexp-in-string "[[:punct:][:space:]]*$" "" (buffer-substring-no-properties (point) (progn (beginning-of-line 2) (point)))))) (push (list :title (my-make-filename title) :start start :end end) results) ) (setq end nil) (dolist (result results) (unless (plist-get result :end) (plist-put result :end end) (setq end (plist-get result :start)))) (reverse results)) ))) (defvar my-segment-media-max-async 10) (defun my-segment-media-file (media-file-name desc-file-name synchronously) "Run ffmpeg asynchronously to segment file-name according to description. With a prefix-arg, run synchronously." (interactive (list (read-file-name "Choose media file: ") (read-file-name "Choose description file: ") current-prefix-arg)) (let* ((dir (file-name-sans-extension (expand-file-name media-file-name))) (info (my-get-media-segments (with-temp-buffer (insert-file-contents desc-file-name) (buffer-string)))) (total (length info)) (idx 0)) (when (or synchronously (<= total my-segment-media-max-async) (let ((choice (car (read-multiple-choice (format "Recognised many (%d) segments, continue asynchronously?" total) '((?y "yes") (?s "synchronously instead") (?n "cancel")))))) (cond ((eq choice ?y) t) ((eq choice ?s) (setq synchronously t)) (t nil)))) (dolist (media info) (setq idx (1+ idx)) (ignore-errors (dired-create-directory dir)) (let* ((title (plist-get media :title)) (start (plist-get media :start)) (end (plist-get media :end)) (args (append (list "-ss" start) (when end (list "-to" end)) (list "-i" (expand-file-name media-file-name) (format "%s/%s.%s" dir title (file-name-extension media-file-name)))))) (message "Cutting %s-%s to %s (%d/%d)..." start (or end "") title idx total) (if synchronously (apply 'call-process (append (list "ffmpeg" nil "*ffmpeg*" t) args)) (apply 'start-process (append (list (format "ffmpeg-%s" title) (format "*ffmpeg-%s*" title) "ffmpeg") args))))) (when synchronously (message "All %d segments splitted into %s" (length info) dir))))) (provide 'my-media-segment) ;;; my-media-segment.el ends here