dunm.scm

;;; dunm.scm
;;;   - cwd傘下のnode_modulesディレクトリのdisk usageを調べる
;;;   - usageに基づいて、(確認後に)消せるようにする

;;; (report-stats [#f])
;;; (report-stats #t)
;;;   傘下のnode_modulesディレクトリのdisk usageをプリントする。
;;;   arg1が#fのときは、1ヶ月以上アクセスしていないもののみを対象とする。
;;;   結果の情報は、変数 *result* に格納されている。

;;; (rmrf-nm)
;;;   *result* の値に基づいて、そこに含まれる node_modulesディレクトリを消去する。
;;;   *remove-switch* の値が#fの場合は、実際に /bin/rm -rf しない。

;;; (report-stats) を実行後に、*result* の値を手動で編集して、
;;; それから (rmrf-nm) するのが、一つの利用方法である。
;;; (Hint: Emacsのshell bufferとかでgaucheを実行すると便利である)

(use gauche.process)
(use gauche.collection)
(use util.match)
(use file.util)

(define pwd current-directory)  ; utilities for interactive use
(define chdir sys-chdir)


(define *one-month-unused*      ; command for search-node_modules
  "find . -type d -mtime +30 -name node_modules -print")

(define *all-time*              ; ditto
  "find . -type d -name node_modules -print")

(define (sub-node_modules? dirpath)
  ;; If "/node_modules/" is found anywhere other than the end,
  ;; the DIRPATH is judged as a sub-node_modules directory.
  (#/\/node_modules\/[^\/].*\/node_modules$/ dirpath))

(define (remove-sub-node_modules lines)
  (filter (lambda (x) (not (sub-node_modules? x))) lines))

(define (list-node_modules :optional all?)
  (let ((search-node_modules-command
         (if all? *all-time* *one-month-unused*)))
    (remove-sub-node_modules
     (process-output->string-list search-node_modules-command))))

(define (parse-du-line line)
  (match-let1 (amount path) (string-split line "\t")
    (list (string->number amount) path)))

(define (sort-lines lines)
  (sort lines > car))           ; non-destructive and stable

(define (du-node_modules dirs)
  (receive (out name) (sys-mkstemp "/tmp/dunm-")
    (call-with-output-process "xargs du -ms"
      (lambda (out)
        (for-each (lambda (x) (display x out) (newline out)) dirs) )
      :output out)
    (sort-lines
      (map parse-du-line
           (process-output->string-list (format #f "cat ~a" name))))))

(define (get-stats :optional all?)
  (let* ((lst (list-node_modules all?))
         (len (length lst))
         (usage (begin
                  (format #t "Found ~d node_module directories ..." len)
                  (du-node_modules lst)))
         (total (begin
                  (format #t "~%Usage has been acquired.~%")
                  (sys-sleep 1)
                  (fold-left (lambda (acc x) (+ acc (car x))) 0 usage))))
    (values len total usage)))

(define *result* #f)

(define (report-stats :optional all?)
  (receive (num total usages) (get-stats all?)
    (set! *result* (list num total usages))
    (for-each (lambda (x)
                (match-let1 (n p) x (format #t "~10:d   ~a~%" n p)))
              usages)
    (format #t "~10:d~%" total)))

(define (x-or-y-p x y fmt . args)
  (let1 fmt+ (apply format #f fmt args)
    (define (prompt)     (format #t "~a (~a or ~a) " fmt+ x y) (flush))
    (define (query-read) (prompt) (read-line))
    (let loop ((input (query-read)))
      (cond ((string-ci=? input x) #t)
            ((string-ci=? input y) #f)
            (else (loop (query-read)))))))
(define (y-or-n-p fmt . args)    (apply x-or-y-p "Y"   "N"  fmt args))
(define (yes-or-no-p fmt . args) (apply x-or-y-p "Yes" "No" fmt args))

(define *remove-switch* #f)

(define (tweak xs)
  (filter-map (lambda (x)
                (match-let1 (num path) x
                  (and (not (zero? num)) path)))
              xs))

(define (rmrf-nm :optional (dirs (tweak (caddr *result*))))
  (define (delete-dir dir)
    (format #t "Removing ~a ..." dir)
    (if *remove-switch*
        (sys-system #"/bin/rm -rf ~dir > /dev/null")
        (sys-sleep 1))
    (newline))
  (when (y-or-n-p "Really delete the selected node_modules directories?")
    (when (yes-or-no-p "Seriously?")
      (for-each delete-dir dirs)
      (format #t "Done.~%"))))

;; メモ

;; Gauche
;;   - ディレクトリ関連
;;     - (use file.util) する
;;     - (current-directory) や (sys-chdir "..") が使える
;;   - gauchのsort関数
;;     - destructiveではない。 (destructive版は sort!)
;;     - arg2(cmpFn)が与えられ、かつ 同値に対して#fを返す場合は、stable。
;;       ここでは、与えられた比較関数が > であることにより、結果はstableとなる。

;; findコマンドの時間指定オプション
;; (https://qiita.com/narumi_/items/9ea27362a1eb502e2dbc)
;;
;;   -mmin   ファイルのデータが最後に修正された日時 (分指定)
;;   -mtime  ファイルのデータが最後に修正された日時 (日指定)
;;   -amin   ファイルのデータに最後にアクセスされた日時 (分指定)
;;   -atime  ファイルのデータに最後にアクセスされた日時 (日指定)
;;   -cmin   ファイルのデータとステータスが最後に修正された日時 (分指定)
;;   -ctime  ファイルのデータとステータスが最後に修正された日時 (日指定)
;;
;;   現在から3日前まで (現在時間〜72時間前)
;;   # find ./ -mtime -3
;;   3日前 (72時間前〜96時間前)
;;   # find ./ -mtime 3
;;   過去から3日前まで (72時間前〜過去)
;;   # find ./ -mtime +2
;;   ※ (2+1)日前以降
;;
;;   daystartオプションを指定すると0時を基準にします。
;;   1日単位で範囲指定したい場合に使用します。
;;   例として、現在を12月24日03時00分とします。
;;
;;   現在から3日前まで (12月24日24時00分〜72時間前)
;;   # find ./ -daystart -mtime -3
;;   3日前 (12月21日24時00分〜24時間前)
;;   # find ./ -daystart -mtime 3
;;   過去から3日前まで (12月21日24時00分〜過去)
;;   # find ./ -daystart -mtime +2
;;   ※ (2+1)日前以降
;;
;;   12時間前まで (現在時間〜12時間前)
;;   # find ./ -mtime -0.5


#|
;; src/libio.scm
(define (port->string port)
  (let1 out (open-output-string :private? #t)
    (copy-port port out :unit 'byte)
    (get-output-string out)))

;; libsrc/gauche/process.scm
(define (call-with-input-process command proc :key (input *nulldev*)
                 ((:error err) #f) (host #f) (on-abnormal-exit :error)
                 :allow-other-keys rest)
  (let* ((p (%apply-run-process command input :pipe err host rest))
         (i (wrap-input-process-port p rest)))
    (unwind-protect (proc i)
      (begin
        (close-input-port i)
        (process-wait p)
        (handle-abnormal-exit on-abnormal-exit p)))))

(define (with-input-from-process command thunk . opts)
  (apply call-with-input-process command
         (cut with-input-from-port <> thunk)
         opts))

(define (process-output->string command . opts)
  (apply call-with-input-process command
         (^p (with-port-locking p
               (^[] (string-join (string-tokenize (port->string p)) " "))))
         opts))

(define (process-output->string-list command . opts)
  (apply call-with-input-process command
         port->string-list
         opts))

(define (call-with-output-process command proc :key (output *nulldev*)
                                  ((:error err) #f) (host #f)
                                  (on-abnormal-exit :error)
                                  :allow-other-keys rest)
  (let* ((p (%apply-run-process command :pipe output err host rest))
         (o (wrap-output-process-port p rest)))
    (unwind-protect (proc o)
      (begin
        (close-output-port o)
        (process-wait p)
        (handle-abnormal-exit on-abnormal-exit p)))))

(define (with-output-to-process command thunk . opts)
  (apply call-with-output-process command
         (cut with-output-to-port <> thunk)
         opts))
|#

#| ext/gauche/test-process.scm

;; We haven't tested file.util, so we need to roll our own
(define (find-executable cmd)
  (cond-expand
   [gauche.os.windows cmd] ; we emulate cmd, so no need to search.
   [else
    (let loop ([paths (string-split (sys-getenv "PATH") #[:])])
      (if (null? paths)
        cmd
        (let1 p (string-append (car paths) "/" cmd)
          (if (sys-access p X_OK)
            p
            (loop (cdr paths))))))]))

(define ls   (find-executable "ls"))
(define cat  (find-executable "cat"))
(define grep (find-executable "grep"))

(define (cmds . args)
  (let1 cmdlist (apply cmd args)
    (string-concatenate (apply append (map (^x `(,x " ")) cmdlist)))))

(test* "call-with-output-process" '(#t 1 2)
       (let1 s (call-with-input-file "test.o" port->string)
         (rmrf "test.o")
         (receive (x y)
             (call-with-output-process (cmds cat ">" "test.o")
               (lambda (out) (display s out) (values 1 2)))
           (let1 r (call-with-input-file "test.o" port->string)
             (list (equal? r s) x y)))))

(test* "call-with-output-process (redirect)" '(#t 1 2)
       (let1 s (call-with-input-file "test.o" port->string)
         (rmrf "test.o")
         (receive (x y)
             (call-with-output-process (cmd cat)
               (lambda (out) (display s out) (values 1 2))
               :output "test.o")
           (let1 r (call-with-input-file "test.o" port->string)
             (list (equal? r s) x y)))))

(test* "call-with-output-process (redirect/error - ignore)" #t
       (begin
         (call-with-output-process (cmds cat "NoSuchFile")
           (lambda (out) #f)
           :error "test1.o" :on-abnormal-exit :ignore)
         (sys-system (cmds cat "NoSuchFile" "2>" "test2.o"))
         (let ((r (call-with-input-file "test1.o" port->string))
               (s (call-with-input-file "test2.o" port->string)))
           (equal? r s))))

(test* "call-with-output-process (redirect/error - raise)" #t
       (guard (e ((<process-abnormal-exit> e)
                  (sys-system (cmds cat "NoSuchFile" "2>" "test2.o"))
                  (let ((r (call-with-input-file "test1.o" port->string))
                        (s (call-with-input-file "test2.o" port->string)))
                    (equal? r s))))
         (call-with-output-process (cmds cat "NoSuchFile")
           (lambda (out) #f) :error "test1.o")))

;; NB: On Solaris, cat seems to return 2 when the file doesn't exist.
(test* "call-with-output-process (redirect/error - handle)" (test-one-of 1 2)
       (let/cc k
         (call-with-output-process (cmd cat 'NoSuchFile)
           port->string
           :error "test1.o"
           :on-abnormal-exit (lambda (p)
                               (k (sys-wait-exit-status
                                   (process-exit-status p)))))))
|#