Windows10 Lock screen picture auto saver.

wallpaper-copy.el

;; wallpaper-copy.el
;; Copyright (C) 2020, 2022, 2023 fubuki -*- coding: utf-8 -*-

;; Author: fubukiATfrill.org
;; Version: @(#)$Revision: 1.11 $
;; Keywords: multimedia

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License.

;; This program 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 General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; Saved the wallpaper of Win10 not to duplicate.

;;; Installation:

;; (require 'wallpaper-copy)
;; (add-hook 'kill-emacs-hook #'(lambda () (wallpaper-copy))) 

;;; Change Log:

;;; Code:

(defconst wallpaper-copy-version "@(#)$Revision: 1.11 $")

(defgroup wallpaper nil
  "Wallpaper Copy."
  :group  'multimedia
  :version "26.3"
  :prefix "wallpaper-")

(defcustom wallpaper-assets
  (let ((dir
         (concat
          (file-name-as-directory
           (replace-regexp-in-string "\\\\" "/" (getenv "LOCALAPPDATA")))
          "Packages/Microsoft.Windows.ContentDeliveryManager_cw5n1h2txyewy/\
LocalState/Assets/")))
    (if (eq system-type 'cygwin)
        (cygwin-convert-file-name-from-windows dir)
      dir))
        "Windows10 lock screen ramdom wallpaper location."
  :type  'directory
  :group 'wallpaper)

(defcustom wallpaper-spot
  (let ((dir "~/spot/"))
    (unless (file-exists-p dir)
      (make-directory dir))
    dir)
  "Wallpaper copy directory."
  :type  'directory
  :group 'wallpaper)

(defcustom wallpaper-bin-cmp-length 256
  "Length of compare binary."
  :type  'integer
  :group 'wallpaper)
  
(defcustom wallpaper-dup-suffix "_"
  "Duplicate file name add character."
  :type  'string
  :group 'wallpaper)

(defcustom wallpaper-copy-verbose nil
  "Verbose mode."
  :type  '(choice (const nil) (const t))
  :group 'wallpaper)

(defvar wallpaper-suffix '(("\377\330\377[\340\341]" . ".jpg") ("\211PNG" . ".png"))
  "バイナリ先頭4バイトのマジックとそれに対応するサフィクス.")

(defun wallpaper-bin-cmp (cell1 cell2)
  "各引数は \(filename . filelength) のコンスセル.
CELL1 と CELL2 の CDR が同一且つ CELL1 と CELL2 の CAR の
バイナリ\(先頭 `wallpaper-bin-cmp-length'バイト)が一致すれば non-NIL."
  (let ((bin-get
         (lambda (file)
           (with-temp-buffer
             (insert-file-contents-literally file nil 0 wallpaper-bin-cmp-length)
             (set-buffer-multibyte nil)
             (buffer-string)))))
    (and (eq (cdr cell1) (cdr cell2))
         (equal (funcall bin-get (car cell1)) (funcall bin-get (car cell2))))))

(defun wallpaper-bsearch (cell db)
  "CELL にマッチするものを DB からリストで返す. 無ければ NIL を返す."
  (let* ((beg 0)
         (end (1- (length db)))
         mid focus result)
    (catch 'break
      (while (<= beg end)
        (setq mid (/ (+ beg end) 2)
              focus (aref db mid))
        (cond
         ((= (cdr cell) (cdr focus))
          (while (<= beg end)
            (when (wallpaper-bin-cmp cell (aref db beg))
              (setq result (cons (aref db beg) result)))
            (setq beg (1+ beg)))
          (throw 'break result))
         ((> (cdr cell) (cdr focus))
          (setq beg (1+ mid)))
         (t
          (setq end (1- mid))))))))

(defun wallpaper-exist-file (cell databse)
  "DATABASE の中にバイナリレベルで一致する CELL があれば non-NIL.
CELL はフルパスファイル名とそのサイズのコンスセル. DATABASE はその集り."
  (let ((db (apply 'vector databse)))
    (wallpaper-bsearch cell db)))

(defun wallpaper-directory-files-with-length (dir)
  "DIR の中をファイル名とサイズのコンスセルのリストとしてサイズの小さい順にソートして返す."
  (let ((files (directory-files-and-attributes
                dir t directory-files-no-dot-files-regexp 'no-sort))
        result)
    (dolist (f files (sort result (lambda (a b) (< (cdr a) (cdr b)))))
      (push (cons (car f) (file-attribute-size (cdr f))) result))))

(defun wallpaper-image-type (file)
  "FILE が jpg か png かを拡張子文字列で返す.
調べるのは先頭 4バイトのみ.
該当しない場合、またはファイルサイズが 16 bytes 以下なら nil.
拡張子区切であるドットは既についている."
  (let* ((len 16)
         (obj (with-temp-buffer
                (set-buffer-multibyte nil)
                (and (eq len
                         (cadr (insert-file-contents-literally file nil 0 len)))
                     (buffer-substring 1 5)))))
    (and obj (assoc-default obj wallpaper-suffix #'string-match))))

;;;###autoload
(defun wallpaper-copy (&optional dst src)
  "Win10 の壁紙ディレクトリに作られたファイルを重複しないよう退避."
  (interactive)
  (let* ((dst  (or dst wallpaper-spot))
         (dsts (wallpaper-directory-files-with-length dst))
         (srcs (wallpaper-directory-files-with-length (or src wallpaper-assets)))
         dstname ext)
    (and wallpaper-copy-verbose (message "wallpaper-copy..."))
    (dolist (cell srcs)
      (unless (wallpaper-exist-file cell dsts)
        (setq dstname (concat (file-name-as-directory dst) (file-name-nondirectory (car cell)))
              ext     (or (wallpaper-image-type (car cell)) ""))
        (when (file-exists-p (concat dstname ext))
          (setq dstname (concat dstname wallpaper-dup-suffix)))
        (message "%s -> %s" (car cell) (concat dstname ext))
        (copy-file (car cell) (concat dstname ext)) 0))
    (and wallpaper-copy-verbose (message "wallpaper-copy...done"))))

(provide 'wallpaper-copy)
;; fin.